673 lines
19 KiB
Fortran
673 lines
19 KiB
Fortran
C GIP
|
|
C SCREEN OF 24 LINES, 80 CHARACTERS ASSUMED
|
|
C
|
|
C
|
|
C 14 May 1991
|
|
C Modified to work on Sparcstations - connect digitiser to RS232-C port B
|
|
C 24 Sept 1992
|
|
C digitizer is now specified by environment variable DIGITIZER
|
|
C
|
|
SUBROUTINE FMAIN()
|
|
PARAMETER (IDMENU=30)
|
|
INTEGER XLANE(4),DY,DXMIN,XPEN,YPEN,YMEAN
|
|
INTEGER XLMENU(IDMENU),XRMENU(IDMENU)
|
|
INTEGER YBMENU(IDMENU),YTMENU(IDMENU)
|
|
CHARACTER CHARS(IDMENU),GEL(512),BASE(4),MENUE,GELNAM*40,ANS
|
|
INTEGER MENUP(IDMENU),SEQROW,SEQCOL,SEQLEN
|
|
INTEGER DEVNOS(6)
|
|
INTEGER ESC
|
|
CHARACTER*40 FILDIG,FILVT
|
|
CHARACTER SPACE,CESC,CBELL
|
|
C ALL SCREEN OUTPUT CONTROLLED USING CURSOR
|
|
C SCREEN SIZE MAXROW, MAXCOL
|
|
C DIRECTION FROM HERE IS INC (1 OR -1)
|
|
INTEGER TITLER,TITLEC,CURER,CUREC,CURFR,CURFC
|
|
COMMON /ESCCHR/ CESC
|
|
COMMON /BELCHR/ CBELL
|
|
PARAMETER (ESC=27,IBELL=7)
|
|
PARAMETER (INC=1,MAXR=24)
|
|
PARAMETER (TITLER=1,TITLEC=20,LORDR=3,LORDC=20,
|
|
+IERRR=MAXR,IERRC=10,
|
|
+INSTR1=MAXR-INC,INSTC1=10,INSTR2=MAXR-2*INC,INSTC2=10,
|
|
+CURER=MAXR-4*INC,CUREC=1,CURFR=2,CURFC=20)
|
|
PARAMETER (SEQROW=6,SEQCOL=10,SEQLEN=60)
|
|
C PARAMETER (FILDIG='/dev/ttyb')
|
|
PARAMETER (FILDIG='DIGITIZER')
|
|
DATA XLMENU/0,
|
|
+0,200,400,600,0,200,400,600,
|
|
+0,200,400,600,0,200,400,600,
|
|
+0,200,400,600,0,200,400,600,
|
|
+0,400,0,0,0/
|
|
DATA XRMENU/800,
|
|
+200,400,600,800,200,400,600,800,
|
|
+200,400,600,800,200,400,600,800,
|
|
+200,400,600,800,200,400,600,800,
|
|
+400,800,800,800,800/
|
|
DATA YBMENU/000,
|
|
+1800,1800,1800,1800,
|
|
+1600,1600,1600,1600,
|
|
+1400,1400,1400,1400,
|
|
+1200,1200,1200,1200,
|
|
+1000,1000,1000,1000,
|
|
+800,800,800,800,
|
|
+600,600,400,200,0/
|
|
DATA YTMENU/2000,2000,2000,2000,2000,
|
|
+1800,1800,1800,1800,
|
|
+1600,1600,1600,1600,
|
|
+1400,1400,1400,1400,
|
|
+1200,1200,1200,1200,
|
|
+1000,1000,1000,1000,
|
|
+800,800,600,400,200/
|
|
DATA CHARS/'W',
|
|
+'T','C','G','A',
|
|
+'2','1','4','3',
|
|
+'V','D','H','B',
|
|
+'L','K','N','M',
|
|
+'R','Y','X','-',
|
|
+'5','6','7','8',
|
|
+'D','R','S','S','C'/
|
|
DATA MENUP/0,1,2,3,4,5,6,7,8,9,10,
|
|
+ 11,12,13,14,15,16,17,18,19,20,
|
|
+ 21,22,23,24,50,51,53,52,56/
|
|
DATA SPACE/' '/
|
|
DATA BASE/'T','C','G','A'/
|
|
C PROBLEM WITH DEFINING ESCAPE AND BELL SO DO IT HERE AND PUT IT COMMON
|
|
C WRITE(CESC,2000)ESC
|
|
CESC=CHAR(ESC)
|
|
2000 FORMAT(A1)
|
|
CBELL=CHAR(IBELL)
|
|
CALL UNITNO(KBIN,KBOUT,DEVNOS,6)
|
|
C OPEN LOGICAL UNIT FOR SOME TERMINAL OUTPUT
|
|
CALL OPENT(DEVNOS(6),FILVT)
|
|
C CLEAR SCREEN
|
|
CALL CLEAR
|
|
C WRITE TITLE
|
|
CALL CURSOR(TITLER,TITLEC)
|
|
CALL WRITES('GIP v1.0 Author: Rodger Staden')
|
|
C define allowed Y distance from current pen position
|
|
DY=80
|
|
CALL OPENRS(DEVNOS(1),FILDIG,IOK,LRECL,8)
|
|
IF(IOK.NE.0)THEN
|
|
CALL CURSOR(IERRR,1)
|
|
CALL BLINE
|
|
CALL CURSOR(IERRR,IERRC)
|
|
CALL WRITES('******UNABLE TO OPEN DIGITIZER******')
|
|
STOP
|
|
END IF
|
|
C FLUSH DIGITIZER
|
|
C CALL FLUSH(DEVNOS(1))
|
|
CALL CURSOR(INSTR1,1)
|
|
CALL BLINE
|
|
CALL CURSOR(INSTR1,INSTC1)
|
|
CALL WRITES('The film must be firmly fixed to the light box')
|
|
5 CONTINUE
|
|
CALL CURSOR(CURFR,1)
|
|
CALL BLINE
|
|
CALL CURSOR(CURFR,CURFC)
|
|
CALL WRITES('? File of file names=')
|
|
READ(KBIN,1000,ERR=5)GELNAM
|
|
1000 FORMAT(A)
|
|
CALL OPENRS(DEVNOS(3),GELNAM,IOK,LRECL,1)
|
|
IF(IOK.NE.0)THEN
|
|
CALL CURSOR(IERRR,1)
|
|
CALL BLINE
|
|
CALL CURSOR(IERRR,IERRC)
|
|
CALL WRITES('******ERROR OPENING FILE******')
|
|
GO TO 5
|
|
END IF
|
|
C CLEAR ERROR LINE IN CASE ITS BEEN USED
|
|
CALL CURSOR(IERRR,1)
|
|
CALL BLINE
|
|
CALL CURSOR(INSTR2,1)
|
|
CALL BLINE
|
|
CALL CURSOR(INSTR2,INSTC2)
|
|
CALL WRITES(
|
|
+'Hit device menu origin, program origin, then hit start')
|
|
90 CONTINUE
|
|
CALL READPN(XPEN,YPEN,1,DEVNOS(1),KBOUT)
|
|
C START?
|
|
CALL INTERP(XLMENU,XRMENU,YBMENU,YTMENU,MENUP,CHARS,
|
|
+IDMENU,XPEN,YPEN,MENU,MENUE,KBOUT)
|
|
IF(MENU.NE.52)GO TO 90
|
|
100 CONTINUE
|
|
C CLEAR ERROR LINE IN CASE ITS BEEN USED
|
|
CALL CURSOR(IERRR,1)
|
|
CALL BLINE
|
|
C GET LANE ORDER
|
|
120 CONTINUE
|
|
C GET LANE ORDER
|
|
CALL LORDER(XLMENU,XRMENU,YBMENU,YTMENU,MENUP,
|
|
+CHARS,MENUE,IDMENU,BASE,DEVNOS(1),KBOUT,INSTR2,INSTC2,
|
|
+LORDR,LORDC)
|
|
C CLEAR ERROR LINE IN CASE ITS BEEN USED
|
|
CALL CURSOR(IERRR,1)
|
|
CALL BLINE
|
|
C GET LANE COORDS
|
|
CALL GETLAN(XLANE,YMEAN,DXMIN,
|
|
+XLMENU,XRMENU,YBMENU,YTMENU,MENUP,CHARS,MENUE,IDMENU,
|
|
+DEVNOS(1),KBOUT,INSTR2,INSTC2)
|
|
C CLEAR ERROR LINE IN CASE ITS BEEN USED
|
|
CALL CURSOR(IERRR,1)
|
|
CALL BLINE
|
|
C POINT TO GEL
|
|
IPGEL=0
|
|
******************************************************
|
|
200 CONTINUE
|
|
CALL CURSOR(INSTR2,1)
|
|
CALL BLINE
|
|
CALL CURSOR(INSTR2,INSTC2)
|
|
CALL WRITES('Hit start when ready to begin reading')
|
|
CALL READPN(XPEN,YPEN,1,DEVNOS(1),KBOUT)
|
|
C START?
|
|
CALL INTERP(XLMENU,XRMENU,YBMENU,YTMENU,MENUP,CHARS,
|
|
+IDMENU,XPEN,YPEN,MENU,MENUE,KBOUT)
|
|
IF(MENU.EQ.52)THEN
|
|
CALL CURSOR(INSTR2,1)
|
|
CALL BLINE
|
|
CALL CURSOR(INSTR2,INSTC2)
|
|
CALL WRITES
|
|
+ ('Hit bands, uncertainty codes, DELETE, RESET or STOP')
|
|
CALL READG(
|
|
+ XLMENU,XRMENU,YBMENU,YTMENU,MENUP,CHARS,
|
|
+ IDMENU,XLANE,YMEAN,DY,DXMIN,BASE,GEL,IPGEL,
|
|
+ SEQROW,SEQCOL,SEQLEN,DEVNOS(1),KBOUT,INSTR2,INSTC2)
|
|
CALL CURSOR(INSTR2,INSTC2)
|
|
IF(IPGEL.GT.0)THEN
|
|
50 CONTINUE
|
|
CALL CURSOR(INSTR2,1)
|
|
CALL BLINE
|
|
CALL CURSOR(INSTR2,INSTC2)
|
|
CALL WRITES('File name for this gel reading=')
|
|
READ(KBIN,1000,ERR=50)GELNAM
|
|
CALL OPENRS(DEVNOS(5),GELNAM,IOK,LRECL,1)
|
|
IF(IOK.EQ.0)THEN
|
|
CALL FMTDK(DEVNOS(5),GEL,IPGEL)
|
|
CLOSE(UNIT=DEVNOS(5))
|
|
WRITE(DEVNOS(3),1008)GELNAM
|
|
1008 FORMAT(A)
|
|
CALL CURSOR(INSTR2,INSTC2)
|
|
ELSE
|
|
CALL CURSOR(IERRR,1)
|
|
CALL BLINE
|
|
CALL CURSOR(IERRR,IERRC)
|
|
CALL WRITES('******ERROR OPENING FILE******')
|
|
GO TO 50
|
|
END IF
|
|
C CLEAR GEL FROM SCREEN
|
|
DO 441 I=1,IPGEL
|
|
CALL WRITEG(' ',SEQCOL,SEQROW,SEQLEN,I)
|
|
441 CONTINUE
|
|
END IF
|
|
CALL CURSOR(INSTR2,1)
|
|
CALL BLINE
|
|
CALL CURSOR(INSTR2,INSTC2)
|
|
CALL WRITES('? (y/n) (y) Read another sequence ')
|
|
READ(KBIN,1010)ANS
|
|
1010 FORMAT(A1)
|
|
IF((ANS.EQ.' ').OR.(ANS.EQ.'Y').OR.(ANS.EQ.'y'))GO TO 100
|
|
CALL CLEAR
|
|
STOP
|
|
END IF
|
|
GO TO 200
|
|
END
|
|
C DIGIT
|
|
C AUTHOR RODGER STADEN
|
|
C ROUTINES USED BY GELIN
|
|
C NONSTANDARD: CARRIAGE CONTROL $ USED BY ROUTINE BELL
|
|
C ROUTINES IN THIS LIB:
|
|
C READG
|
|
C INOUT
|
|
C LANE
|
|
C GETLAN
|
|
C GETMEN
|
|
C LORDER
|
|
C WRITEG
|
|
C INTERP
|
|
C READPN
|
|
SUBROUTINE READG(XLMENU,XRMENU,YBMENU,YTMENU,MENUP,CHARS,
|
|
+IDMENU,XLANE,YMEAN,DY,DXMIN,BASE,GEL,IPGEL,SEQROW,SEQCOL,
|
|
+SEQLEN,IDEVD,KBOUT,INSTR2,INSTC2)
|
|
C AUTHOR RODGER STADEN
|
|
C READS A SEQUENCE USING THE DIGITIZER UNTIL A STOP COMMAND IS GIVEN
|
|
C LANE COORDINATES CAN BE RESET.
|
|
INTEGER XLANE(4),DY,DXMIN,XPEN,YPEN,YMEAN
|
|
INTEGER XLMENU(IDMENU),XRMENU(IDMENU)
|
|
INTEGER YBMENU(IDMENU),YTMENU(IDMENU)
|
|
CHARACTER CHARS(IDMENU),GEL(512),BASE(4),MENUE,LASTCH
|
|
INTEGER MENUP(100),SEQCOL,SEQROW,SEQLEN,INSTR2,INSTC2
|
|
EXTERNAL LANE
|
|
LASTCH=' '
|
|
300 CONTINUE
|
|
CALL READPN(XPEN,YPEN,0,IDEVD,KBOUT)
|
|
C IN LANES?
|
|
C*****************************************************
|
|
L=LANE(XLANE,YMEAN,DY,DXMIN,XPEN,YPEN)
|
|
IF(L.NE.0)THEN
|
|
CALL GBELL(1,KBOUT)
|
|
C IN LANES
|
|
C EXPECTING A BAND SO DEAL WITH IT
|
|
C INCREMENT POINTER TO GEL CHARACTERS
|
|
IPGEL=IPGEL+1
|
|
GEL(IPGEL)=BASE(L)
|
|
C PUT ON SCREEN ETC
|
|
CALL WRITEG(GEL(IPGEL),SEQCOL,SEQROW,SEQLEN,IPGEL)
|
|
LASTCH='C'
|
|
ELSE
|
|
C IN MENU?
|
|
CALL INTERP(XLMENU,XRMENU,YBMENU,YTMENU,MENUP,CHARS,
|
|
+ IDMENU,XPEN,YPEN,MENU,MENUE,KBOUT)
|
|
C UNCERTAINTY CODE?
|
|
IF((MENU.GT.0).AND.(MENU.LT.25))THEN
|
|
C UNCERTAINTY CODE
|
|
CALL GBELL(1,KBOUT)
|
|
IPGEL=IPGEL+1
|
|
GEL(IPGEL)=MENUE
|
|
LASTCH='C'
|
|
CALL WRITEG(GEL(IPGEL),SEQCOL,SEQROW,SEQLEN,IPGEL)
|
|
C DELETE?
|
|
ELSE IF(MENU.EQ.50)THEN
|
|
C DELETE
|
|
C IF LAST CHAR A BASE THEN NEED TO REMOVE IT FROM GEL
|
|
IF((LASTCH.EQ.'C').AND.(IPGEL.GT.0))THEN
|
|
CALL GBELL(1,KBOUT)
|
|
CALL WRITEG(' ',SEQCOL,SEQROW,SEQLEN,IPGEL)
|
|
IPGEL=IPGEL-1
|
|
END IF
|
|
C RESET LANE CENTRES?
|
|
ELSE IF(MENU.EQ.51)THEN
|
|
CALL GBELL(1,KBOUT)
|
|
CALL GETLAN(XLANE,YMEAN,DXMIN,
|
|
+ XLMENU,XRMENU,YBMENU,YTMENU,
|
|
+ MENUP,CHARS,MENUE,IDMENU,
|
|
+ IDEVD,KBOUT,INSTR2,INSTC2)
|
|
CALL CURSOR(INSTR2,1)
|
|
CALL BLINE
|
|
CALL CURSOR(INSTR2,INSTC2)
|
|
CALL WRITES
|
|
+ ('Hit bands, uncertainty codes, DELETE, RESET or STOP')
|
|
C STOP?
|
|
ELSE IF(MENU.EQ.53)THEN
|
|
CALL GBELL(1,KBOUT)
|
|
RETURN
|
|
C FOR NOW NOT FOUND SO IGNORE
|
|
END IF
|
|
END IF
|
|
C NOT IN MENU
|
|
C NOT IN MENU OR LANES SO IGNORE
|
|
GO TO 300
|
|
END
|
|
C INOUT
|
|
C
|
|
C FUNCTION TO RETURN VALUE 1 IF XPEN,YPEN IN BOX, 0 ELSE
|
|
C AUTHOR RODGER STADEN
|
|
INTEGER FUNCTION INOUT(X1,X2,Y1,Y2,XPEN,YPEN)
|
|
IMPLICIT INTEGER (A-Z)
|
|
INOUT=0
|
|
IF((XPEN.LT.X1).OR.(XPEN.GT.X2))RETURN
|
|
IF((YPEN.LT.Y1).OR.(YPEN.GT.Y2))RETURN
|
|
INOUT=1
|
|
RETURN
|
|
END
|
|
C LANEORDER
|
|
C GETS LANE ORDER FROM TABLET
|
|
SUBROUTINE LORDER(XLMENU,XRMENU,YBMENU,YTMENU,MENUP,
|
|
+CHARS,MENUE,IDMENU,BASE,IDEVD,KBOUT,INSTR2,INSTC2,
|
|
+LORDR,LORDC)
|
|
C AUTHOR RODGER STADEN
|
|
INTEGER XLMENU(IDMENU),XRMENU(IDMENU)
|
|
INTEGER YBMENU(IDMENU),YTMENU(IDMENU)
|
|
INTEGER MENUP(IDMENU),INSTR2,INSTC2
|
|
CHARACTER BASE(4),BASES(4),CHARS(IDMENU),MENUE,SPACE
|
|
CHARACTER BASET*4
|
|
PARAMETER (IERRR=24,IERRC=10)
|
|
SAVE BASES,SPACE
|
|
DATA SPACE/' '/
|
|
DATA BASES/'T','C','G','A'/
|
|
C
|
|
10 CONTINUE
|
|
DO 5 I=1,4
|
|
BASET(I:I)=BASE(I)
|
|
5 CONTINUE
|
|
C
|
|
CALL CURSOR(LORDR,1)
|
|
CALL BLINE
|
|
CALL CURSOR(LORDR,LORDC)
|
|
CALL WRITES('Lane order is ')
|
|
CALL WRITES(BASET)
|
|
CALL CURSOR(INSTR2,1)
|
|
CALL BLINE
|
|
CALL CURSOR(INSTR2,INSTC2)
|
|
CALL WRITES('If lane order correct hit CONFIRM, else hit RESET')
|
|
CALL READPN(XPEN,YPEN,1,IDEVD,KBOUT)
|
|
CALL INTERP(XLMENU,XRMENU,YBMENU,YTMENU,MENUP,CHARS,
|
|
+IDMENU,XPEN,YPEN,MENU,MENUE,KBOUT)
|
|
IF(MENU.EQ.56)THEN
|
|
C CLEAR ERROR LINE IN CASE ITS BEEN USED
|
|
CALL CURSOR(IERRR,1)
|
|
CALL BLINE
|
|
RETURN
|
|
END IF
|
|
IF(MENU.EQ.51)THEN
|
|
CALL CURSOR(INSTR2,1)
|
|
CALL BLINE
|
|
CALL CURSOR(INSTR2,INSTC2)
|
|
CALL WRITES('Define lane order, left to right, using menu')
|
|
C COUNT POINTS
|
|
IP=1
|
|
20 CONTINUE
|
|
IF(IP.LE.4)THEN
|
|
CALL READPN(XPEN,YPEN,1,IDEVD,KBOUT)
|
|
CALL INTERP(XLMENU,XRMENU,YBMENU,YTMENU,MENUP,
|
|
+ CHARS,IDMENU,XPEN,YPEN,MENU,MENUE,KBOUT)
|
|
DO 30 I=1,4
|
|
IF(MENUE.EQ.BASES(I))THEN
|
|
BASE(IP)=MENUE
|
|
GO TO 31
|
|
END IF
|
|
30 CONTINUE
|
|
31 CONTINUE
|
|
IP=IP+1
|
|
GO TO 20
|
|
END IF
|
|
C ALL DIFFERENT?
|
|
DO 40 I=1,4
|
|
DO 41 J=I+1,4
|
|
IF(BASE(I).EQ.BASE(J))THEN
|
|
C SAME!
|
|
CALL CURSOR(INSTR2,1)
|
|
CALL BLINE
|
|
CALL CURSOR(IERRR,IERRC)
|
|
CALL WRITES('*****DUPLICATION IN LANE ORDER*****')
|
|
DO 35 K=1,4
|
|
BASE(K)=BASET(K:K)
|
|
35 CONTINUE
|
|
GO TO 10
|
|
END IF
|
|
41 CONTINUE
|
|
40 CONTINUE
|
|
END IF
|
|
GO TO 10
|
|
END
|
|
C INTERPXY
|
|
C
|
|
C INTERPRETS X,Y COORDS FROM DIGITIZER
|
|
SUBROUTINE INTERP(XL,XR,YB,YT,MENUP,CHARS,
|
|
+IDMENU,XPEN,YPEN,MENU,MENUE,KBOUT)
|
|
C AUTHOR RODGER STADEN
|
|
INTEGER XL(IDMENU),XR(IDMENU),YB(IDMENU),YT(IDMENU)
|
|
INTEGER MENUP(IDMENU),XPEN,YPEN
|
|
CHARACTER CHARS(IDMENU),MENUE
|
|
EXTERNAL INOUT
|
|
PARAMETER (IERRR=24,IERRC=10)
|
|
MENU=0
|
|
MENUE=CHARS(1)
|
|
C IN MENU AT ALL?
|
|
IF(INOUT(XL(1),XR(1),YB(1),YT(1),XPEN,YPEN).EQ.0)RETURN
|
|
DO 100 I=2,IDMENU
|
|
IF(INOUT(XL(I),XR(I),YB(I),YT(I),XPEN,YPEN).NE.1)GO TO 100
|
|
C MATCH
|
|
MENU=MENUP(I)
|
|
MENUE=CHARS(I)
|
|
RETURN
|
|
100 CONTINUE
|
|
C ERROR IN MENU
|
|
MENU=0
|
|
MENUE=CHARS(1)
|
|
CALL CURSOR(IERRR,1)
|
|
CALL BLINE
|
|
CALL CURSOR(IERRR,IERRC)
|
|
CALL WRITES('******ERROR IN MENU******')
|
|
RETURN
|
|
END
|
|
C
|
|
C READPEN GETS COORDS FROM DIGITIZER
|
|
SUBROUTINE READPN(XPEN,YPEN,IBELL,IDEVD,KBOUT)
|
|
C AUTHOR RODGER STADEN
|
|
CHARACTER INPUT*11,INPUTX*5,INPUTY*5
|
|
INTEGER XPEN,YPEN
|
|
C EQUIVALENCE (INPUT(2:6),INPUTX),(INPUT(7:11),INPUTY)
|
|
C NOTE ON IBM NEXT LINE EQUIVALENCE USED
|
|
EQUIVALENCE (INPUT(1:5),INPUTX),(INPUT(6:10),INPUTY)
|
|
PARAMETER (IERRR=24,IERRC=10)
|
|
1000 FORMAT(A)
|
|
1 CONTINUE
|
|
READ(IDEVD,1000,ERR=1)INPUT
|
|
1002 FORMAT(I5)
|
|
READ(INPUTX,1002,ERR=100)XPEN
|
|
READ(INPUTY,1002,ERR=100)YPEN
|
|
IF(IBELL.EQ.1)CALL GBELL(1,KBOUT)
|
|
C READ 2nd NEWLINE ON SUN
|
|
READ(IDEVD,1000,ERR=1)INPUT
|
|
RETURN
|
|
100 CONTINUE
|
|
CALL CURSOR(IERRR,1)
|
|
CALL BLINE
|
|
CALL CURSOR(IERRR,IERRC)
|
|
CALL WRITES('*********ERROR READING PEN********')
|
|
RETURN
|
|
END
|
|
C WRITEGEL
|
|
SUBROUTINE WRITEG(CHAR,STARTX,STARTY,LENGTH,IPGEL)
|
|
C AUTHOR RODGER STADEN
|
|
C WRITE OUT A CHARACTER
|
|
CHARACTER CHAR
|
|
INTEGER STARTX,STARTY,ROW,COL
|
|
ROW=(IPGEL-1)/LENGTH
|
|
COL=MOD(IPGEL,LENGTH)
|
|
IF(COL.EQ.0)COL=LENGTH
|
|
ROW=STARTY+ROW
|
|
COL=STARTX+COL
|
|
CALL CURSOR(ROW,COL)
|
|
CALL WRITES(CHAR)
|
|
RETURN
|
|
END
|
|
C
|
|
C GETLANE
|
|
SUBROUTINE GETLAN(XLANE,YMEAN,DXMIN,
|
|
+XLMENU,XRMENU,YBMENU,YTMENU,MENUP,CHARS,MENUE,IDMENU,
|
|
+IDEVD,KBOUT,INSTR2,INSTC2)
|
|
C AUTHOR RODGER STADEN
|
|
C GETS LANE ORDER
|
|
INTEGER XLANE(4)
|
|
INTEGER YTEMP(4)
|
|
INTEGER XLMENU(IDMENU),XRMENU(IDMENU)
|
|
INTEGER YBMENU(IDMENU),YTMENU(IDMENU)
|
|
INTEGER MENUP(IDMENU),INSTR2,INSTC2
|
|
INTEGER XPEN,YPEN,YMEAN,DXMIN
|
|
CHARACTER CHARS(IDMENU),MENUE,SEPAR*10
|
|
PARAMETER (IERRR=24,IERRC=10)
|
|
INSTR3=4
|
|
INSTC3=20
|
|
100 CONTINUE
|
|
CALL CURSOR(INSTR2,1)
|
|
CALL BLINE
|
|
CALL CURSOR(INSTR2,INSTC2)
|
|
CALL WRITES
|
|
+('Hit START, then, left to right,')
|
|
CALL WRITES(' the start centres of this clones lanes')
|
|
CALL READPN(XPEN,YPEN,1,IDEVD,KBOUT)
|
|
CALL INTERP(XLMENU,XRMENU,YBMENU,YTMENU,MENUP,CHARS,
|
|
+IDMENU,XPEN,YPEN,MENU,MENUE,KBOUT)
|
|
C START?
|
|
IF(MENU.NE.52)GO TO 100
|
|
C GOT START, EXPECT LANES NOW
|
|
200 CONTINUE
|
|
DO 300 I=1,4
|
|
CALL READPN(XPEN,YPEN,1,IDEVD,KBOUT)
|
|
C IN MENU?
|
|
CALL INTERP(XLMENU,XRMENU,YBMENU,YTMENU,MENUP,CHARS,
|
|
+IDMENU,XPEN,YPEN,MENU,MENUE,KBOUT)
|
|
IF(MENU.NE.0)GO TO 100
|
|
C NOT IN MENU SO RECORD POSITION
|
|
XLANE(I)=XPEN
|
|
YTEMP(I)=YPEN
|
|
300 CONTINUE
|
|
YMEAN=(YTEMP(1)+YTEMP(2)+YTEMP(3)+YTEMP(4))/4
|
|
C FIND LANE SEPARATION
|
|
DXMIN=(XLANE(4)-XLANE(1))/3
|
|
WRITE(SEPAR,1011)DXMIN
|
|
CALL CURSOR(INSTR3,1)
|
|
CALL BLINE
|
|
CALL CURSOR(INSTR3,INSTC3)
|
|
CALL WRITES('Mean lane separation = ')
|
|
CALL WRITES(SEPAR)
|
|
CALL CURSOR(INSTR2,1)
|
|
CALL BLINE
|
|
CALL CURSOR(INSTR2,INSTC2)
|
|
CALL WRITES(
|
|
+'If separation ok hit CONFIRM, else hit RESET')
|
|
1011 FORMAT(I6)
|
|
CALL READPN(XPEN,YPEN,1,IDEVD,KBOUT)
|
|
C IN MENU?
|
|
CALL INTERP(XLMENU,XRMENU,YBMENU,YTMENU,MENUP,CHARS,
|
|
+IDMENU,XPEN,YPEN,MENU,MENUE,KBOUT)
|
|
C
|
|
IF(MENU.NE.56)GO TO 100
|
|
C SET MINIMUM LANE CENTRE CLOSENESS TO 50% OF SEPARATION
|
|
DXMIN=DXMIN/2
|
|
C CLEAR ERROR LINE IN CASE ITS BEEN USED
|
|
CALL CURSOR(IERRR,1)
|
|
CALL BLINE
|
|
RETURN
|
|
END
|
|
C LANE
|
|
C RETURNS THE LANE NUMBER FOR GELIN
|
|
INTEGER FUNCTION LANE(XLANE,YMEAN,DY,DXMIN,XPEN,YPEN)
|
|
C AUTHOR RODGER STADEN
|
|
INTEGER XLANE(4),YMEAN,D(4)
|
|
INTEGER XPEN,YPEN,DXMIN,DY,X1,X2,Y1,Y2,DMIN
|
|
EXTERNAL INOUT
|
|
LANE=0
|
|
C IS THE POINT IN THE LANES?
|
|
X1=XLANE(1)-DXMIN
|
|
X2=XLANE(4)+DXMIN
|
|
Y1=YMEAN-DY
|
|
Y2=YMEAN+DY
|
|
IF(INOUT(X1,X2,Y1,Y2,XPEN,YPEN).EQ.0)RETURN
|
|
C
|
|
C IN LANES
|
|
C WHICH IS NEAREST XLANE VALUE
|
|
DO 10 I=1,4
|
|
D(I)=ABS(XLANE(I)-XPEN)
|
|
10 CONTINUE
|
|
C WHICH IS LEAST?
|
|
DMIN=D(1)
|
|
ICLOSE=1
|
|
DO 20 I=2,4
|
|
IF(D(I).GT.DMIN)GO TO 20
|
|
C CLOSER
|
|
ICLOSE=I
|
|
DMIN=D(I)
|
|
20 CONTINUE
|
|
C CLOSEST TO ICLOSE SO SET THIS CHAR AND SHIFT THIS LANE CENTRE
|
|
XLANE(ICLOSE)=XPEN
|
|
YMEAN=YPEN
|
|
LANE=ICLOSE
|
|
C MAKE SURE LANES ARE NOT TOO CLOSE
|
|
DO 30 I=2,4
|
|
IF(ABS(XLANE(I-1)-XLANE(I)).LT.DXMIN)LANE=0
|
|
30 CONTINUE
|
|
C RESET LANE SEPARATION
|
|
DXMIN=(XLANE(4)-XLANE(1))/6
|
|
RETURN
|
|
END
|
|
C BELL
|
|
C SUBROUTINE TO RING BELL N TIMES
|
|
SUBROUTINE GBELL(N,KBOUT)
|
|
C AUTHOR RODGER STADEN
|
|
CHARACTER CBELL
|
|
COMMON /BELCHR/ CBELL
|
|
CALL WRITES(CBELL)
|
|
RETURN
|
|
END
|
|
SUBROUTINE OPENT(IDEV,FILNAM)
|
|
C AUTHOR: RODGER STADEN
|
|
CHARACTER FILNAM*(*)
|
|
COMMON /TERM/IDEVT
|
|
SAVE /TERM/
|
|
PARAMETER (IERRR=24,IERRC=10)
|
|
IDEVT=IDEV
|
|
CALL OPENRS(IDEV,FILNAM,IOK,LRECL,10)
|
|
IF(IOK.EQ.0)RETURN
|
|
CALL CURSOR(IERRR,1)
|
|
CALL BLINE
|
|
CALL CURSOR(IERRR,IERRC)
|
|
CALL WRITES('****ERROR OPENING SCREEN FOR OUTPUT****')
|
|
RETURN
|
|
END
|
|
SUBROUTINE CLEAR
|
|
C AUTHOR: RODGER STADEN
|
|
CHARACTER STRING*4,CESC
|
|
COMMON /ESCCHR/ CESC
|
|
DATA STRING(2:4)/'[2J'/
|
|
STRING(1:1)=CESC
|
|
C CLEAR SCREEN
|
|
CALL WRITES(STRING)
|
|
RETURN
|
|
END
|
|
SUBROUTINE WRITES(CHARS)
|
|
C AUTHOR: RODGER STADEN
|
|
CHARACTER CHARS*(*)
|
|
INTEGER NUL
|
|
COMMON /TERM/IDEVT
|
|
SAVE /TERM/
|
|
DATA NUL/0/
|
|
C WRITE(IDEVT,1000)NUL,CHARS
|
|
C1000 FORMAT(A1,A)
|
|
WRITE(IDEVT,1000)CHARS
|
|
1000 FORMAT(A,$)
|
|
CALL FLUSH(IDEVT)
|
|
RETURN
|
|
END
|
|
SUBROUTINE CURSOR(LINE,COLUMN)
|
|
C AUTHOR: RODGER STADEN
|
|
C SETS CURSOR TO LINE AND COLUMN
|
|
INTEGER COLUMN
|
|
CHARACTER BLIN*2,BCOL*2,SPACE,ZERO,STRING*8,CESC
|
|
COMMON /ESCCHR/ CESC
|
|
EQUIVALENCE (STRING(3:4),BLIN),(STRING(6:7),BCOL)
|
|
SAVE STRING,ZERO,SPACE
|
|
DATA STRING(2:2)/'['/,STRING(8:8)/'H'/
|
|
DATA STRING(5:5)/';'/
|
|
DATA SPACE/' '/,ZERO/'0'/
|
|
STRING(1:1)=CESC
|
|
WRITE(BCOL,1002,ERR=100)COLUMN
|
|
WRITE(BLIN,1002,ERR=100)LINE
|
|
1002 FORMAT(I2.2)
|
|
C NEED TO SET SPACES TO ZEROS
|
|
C IF(BCOL(1:1).EQ.SPACE)BCOL(1:1)=ZERO
|
|
C IF(BLIN(1:1).EQ.SPACE)BLIN(1:1)=ZERO
|
|
CALL WRITES(STRING)
|
|
RETURN
|
|
100 CONTINUE
|
|
WRITE(*,*)'ERROR IN CURSOR SUBROUTINE'
|
|
RETURN
|
|
END
|
|
SUBROUTINE BLINE
|
|
CHARACTER BLANK*79
|
|
SAVE BLANK
|
|
DATA BLANK/' '/
|
|
CALL WRITES(BLANK)
|
|
RETURN
|
|
END
|
|
SUBROUTINE FMTDK(IDEV,SEQNCE,IDIM)
|
|
C AUTHOR: RODGER STADEN
|
|
CHARACTER SEQNCE(IDIM)
|
|
C SET POINTERS TO FIRST AND LAST ELEMENTS ONE WRITE
|
|
JS=1
|
|
JE=60
|
|
10 CONTINUE
|
|
C SET JE TO LAST ELEMENT IF NECESSARY
|
|
IF(JE.GT.IDIM)JE=IDIM
|
|
WRITE(IDEV,1002)(SEQNCE(I),I=JS,JE)
|
|
1002 FORMAT(' ',60A1)
|
|
C TEST FOR END
|
|
IF(JE.EQ.IDIM)GO TO 20
|
|
C INCREMENT FIRST AND LAST POINTERS
|
|
JS=JE+1
|
|
JE=JE+60
|
|
GO TO 10
|
|
20 CONTINUE
|
|
RETURN
|
|
END
|