G0M
  69
ACCEL@SRC
AP$@@TH@@
ARINITSRC
BOUND@DAT
CHMASTSRC
CHOR1@JOB
CHOR1@SRC
CHOR2@JOB
CHOR2@SRC
CHOR3@SRC
CHRMN@SRC
CLOSE@CTE
COLM@@LST
COLM@@SRC
CONVRTSRC
COPEE@JOB
COPY@@JOB
CTEST@JOB
CTEST@SRC
DANC1@SRC
DANC2@SRC
DANC3@SRC
DANC4@SRC
DANC5@SRC
DANC6@SRC
DATA@@SRC
DIRECTJOB
DRAWITSRC
EDITD@SRC
ERASE@SRC
FILMODSRC
FLUSH1JOB
FLXDANSRC
INCREMSRC
INITL@SRC
INPUTSSRC
LOAD@@JOB
MAIN@@SRC
MOVINCSRC
NEXT@@SRC
NORMALSRC
OCHRMNSRC
ODRAWISRC
OPEN@@COM
PHASE2SRC
POINT@DAT
PRINT@JOB
PRTPRDSRC
PRTSUMSRC
RDCON@SRC
RDCONVSRC
ROTATESRC
RUN1@@JOB
SAV@@@SRC
SCHOR1SRC
SCHOR2SRC
SCOLM@SRC
SORTB@SRC
SRDCONSRC
SSORTBSRC
SYMBINSRC
SYMBL@JOB
SYMBLDSRC
TBLD@@SRC
TEST@@SRC
TRAN@@SRC
USR/P2EDT
VARI0@DAT
XTEST@SRC
[\].
ACCEL@SRC
	SUBROUTINE ACCEL
C		SUBROUTINE TO HANDLE JUMPS
C		(NOT CODED YET)
	RETURN
	END
[\].
AP$@@TH@@
C******  CHOR1 MAINLINE FOR CHOREO INTERACTIVE DANCE FACILITY**
C******  AUTHOR G. A. MCDOUGALL *******************************
    	REAL ARR(4,32),CLEN(11),SHPAR(2,11,13),SUPLAR(4,6,2)
	REAL SUPTAR(4,17),TBAR(50,8),TCLEN(11),LEN,POS
	REAL XMIN,XMAX,YMIN,YMAX,XA,XB,YA,YB,FLXAR(4,7)
	REAL BPB,EBAR9,EDAN9,TX,TY,FEXT
	INTEGER COL,SUP,DIR,LEV,ROT,FLX,ENDOF,CHG,X,Y,XC,YC
	INTEGER BAR,CONT,FIRST,FLIP,I,INT,IVECT(500)
	INTEGER LAST,IOT,IOP,STP,SIB
	INTEGER SORTV1(50),SORTV2(50),ZXY(3),IEV,FNM(3)
	INTEGER TAG,MODE,BEGIN,END
	INTEGER RECS,IV,ADJ,DEL
	COMMON/SYMBOL/ COL,SUP,DIR,LEV,ROT,FLX,LEN,POS,TX,TY
	COMMON/ARRAY/ ARR,SHPAR,FLXAR,SUPLAR,SUPTAR
	COMMON/SORTC/SORTV1,SORTV2,SIB
	COMMON/VECT/ IVECT,FIRST,LAST,TAG,MODE,BEGIN,END
	COMMON/LIMITS/ XMIN,XMAX,YMIN,YMAX
	COMMON/FRAME/ XA,XB,YA,YB
	COMMON/IOLU/ IOT,IOP
C******
	DATA FNM(3),FEXT/1H1 ,3HSRC/
	DATA CLEN,TCLEN/11*0.0,11*0.0/
	IOT = 4
	IOP=16
	IOD = 15
	WRITE (IOT,10)
	WRITE (IOT,11)
10 	FORMAT(' USING CHOREO YOU MAY CREATE OR CHANGE A DANCE')
11	FORMAT(' DO YOU WISH TO CREATE A DANCE?(1/0)')
	READ (IOT,) SW1
	WRITE (IOT,20)
20	FORMAT(' ENTER 4 CHAR. (NEW/OLD) DANCE NAME')
	READ (IOT,21) FNM(1),FNM(2)
21	FORMAT(2A2)
	CALL DELETE (15,5HDANC1,3HSRC,IEV)
25	CALL WAITFR (IEV)
	IF (IEV) 999,25,26
26      CALL ENTER (15,5HDANC1,3HSRC,IEV)
22	CALL WAITFR (IEV)
	IF (IEV) 999,22,23
23      WRITE (IOT,15)
15	FORMAT(' ENTER BEATS PER BAR (3 OR 4) ')
	READ (IOT,) BPB
	IF (SW1.NE.0) GOTO 60
	CALL EDITD
	GOTO 1000
60	CALL ARINIT
	EBAR9 = 999
	EDAN9 = 999
	ZR = 0
	BAR = 1
	SIB = 0
	WRITE (IOT,65)
65	FORMAT (' YOU MAY NOW ENTER SYMBOLS USING THE ACOUSTIC TABLET')
C******	ESTABLISH SCREEN LIMITS
	XMIN = 0
	XMAX = 20
	YMIN = 0
	YMAX = 20
C*************************************************************
80	CALL CLEAR(.TRUE.)
	CALL COLM
81	COL=0
	SUP  = 0
	DIR  = 0
	LEV  = 0
	ROT  = 0
	FLX  = 0
	LEN = 0.0
	POS = 0.0
	CHG  = 0
	SIB = SIB +1
90	READ (IOT,) X,Y
C90      CALL GETBLT(25,1,ZXY,IEV)
C	CALL WAITFR(IEV)
C	IF (ZXY(1).NE.0) GOTO 90
C	XC=ZXY(3)
C	YC=ZXY(2)
C	X=17-XC/56
C	Y=1+YC/56
C	IF ((X.GT.16).OR.(Y.GT.16)) GOTO 90
C	WRITE (IOT,) X,Y
  	GOTO (90,100,90,110,90,120,90,130,140,150,90,160,90,
     *  170,180,90),X
100	IF ((Y.EQ.1).OR.(Y.GE.13)) GOTO 90
	COL=Y-1
	GOTO 90
110	IF ((Y.EQ.1).OR.(Y.EQ.16)) GOTO 90
	SUP=Y-1
	GOTO 90
120	IF((Y.EQ.1).OR.(Y.GE.15)) GOTO 90
	DIR=Y-1
	GOTO 90
130	GOTO (90,131,131,131,90,90,90,90,132,133,134,90,90,
     *  90,90,90),Y
131	LEV=Y-1
	GOTO 90
132	ROT=8
	GOTO 90
133	ROT=1
	GOTO 90
134	ROT=2
	GOTO 90
140	IF (Y.EQ.9) GOTO 143
	IF (Y.EQ.11) GOTO 144
	GOTO 90
143	ROT=7
	GOTO 90
144	ROT=3
	GOTO 90
150	GOTO (90,151,151,151,151,151,151,90,152,153,154,90,90,
     *  90,90,90),Y
151	FLX=Y-1
	GOTO 90
152	ROT=6
	GOTO 90
153	ROT=5
	GOTO 90
154	ROT=4
	GOTO 90
160	GOTO (90,161,161,161,161,161,161,161,161,90,90,200,90,
     *  300,90,1000),Y
161	LEN=LEN+(Y-1)*.125
	IF (LEN.GT.BPB) LEN=BPB
	GOTO 90
C******	EDIT SECTION NOT  CODED YET
170	GOTO 90
C****** EDIT AND REPLAY ARE NOT CODED YET
180	GOTO 90
C******	END OF SYMBOL ***********************************************
200	CONTINUE
	IF (COL.NE.0) GOTO 204
	WRITE (IOT,201)
201	FORMAT(' DON''T FORGET TO ENTER THE COLUMN ')
	GOTO 90
204     IF (.NOT.((DIR.NE.0).AND.((LEN.EQ.0).OR.(LEV.EQ.0)))) GOTO 206
	WRITE (IOT,205)
205	FORMAT(' WHEN A DIRECTION SYMBOL IS ENTERED ,LEN & LEV ARE REQD')
	GOTO 90
206     TX = 2.8 + 1.5 * (COL-1)
	TY = 2.0 + CLEN (COL) * 4
	TAG=SIB
	WRITE(IOP,91) COL,SUP,DIR,LEV,ROT,FLX,LEN,POS
91	FORMAT(6I3,2F7.2)
	WRITE (IOP,) CLEN(COL)
   	CALL SYMBLD
	POS = CLEN(COL) + TCLEN(COL)
	CLEN(COL) = CLEN(COL) + LEN 
	WRITE (IOP,) POS,CLEN(COL)
	SORTV1(SIB) = (POS*1000)+COL
	TBAR(SIB,1) = FLOAT(COL)
	TBAR(SIB,2) = FLOAT(SUP)
	TBAR(SIB,3) = FLOAT(DIR)
	TBAR(SIB,4) = FLOAT(LEV)
	TBAR(SIB,5) = FLOAT(ROT)
	TBAR(SIB,6) = FLOAT(FLX)
	TBAR(SIB,7) = LEN
	TBAR(SIB,8) = POS
	GOTO 81
C****** END OF BAR *****************************************************
300     SIB = SIB - 1
   	DO 310 I=1,11
	TCLEN(I) = TCLEN(I)+BPB
	CLEN(I) = AMAX1(0.0,(CLEN(I)-BPB))
310	CONTINUE
	WRITE (IOP,) (SORTV1(I),I=1,SIB)
	CALL SORTB
	ABAR = FLOAT(BAR)
	WRITE (IOP,) (SORTV2(I) ,I=1,SIB)
	ASIB = FLOAT(SIB)
	WRITE (IOD,330) EBAR9,ABAR,ASIB,ZR,ZR,ZR,ZR,ZR
330	FORMAT(6F5.0,2F7.3)
	DO 320 I=1,SIB
	IN = SORTV2(I)
	WRITE (IOD,330) (TBAR(IN,J),J=1,8)
320	CONTINUE
	TSIB = TSIB + SIB
	SIB = 1
	BAR = BAR + 1
	GOTO 80
C******	END OF DANCE *******************************************************
999	CALL CLOSE (15,5HDANC1,3HSRC,IEV)
1000    WRITE (IOD,330) EDAN9,BAR,TSIB,ZR,ZR,ZR,ZR,ZR
	WRITE (IOT,) IEV
	STOP
	END
[\].
ARINITSRC
	SUBROUTINE ARINIT
C****** INITS ARRAYS FOR SYMBOLS -SHAPE,FLEXION,LEG SUP,TORS SUPP
C
	REAL A,B,C,D,FLXAR(4,7),INC,SUPLAR(4,6,2),ARR(4,32)
	REAL SHPAR(2,11,13),SUPTAR(4,17),STEP,GEN(10)
C
	COMMON/ARRAY/ ARR,SHPAR,FLXAR,SUPLAR,SUPTAR
	COMMON/IOLU/ IOT,IOP,IOD
C
	DATA GEN/.2,.4,.6,.8,.8,.6,.4,.2,.2,.4/
C*****	INITIALIZE SYMBOL SHAPE LINES ARRAYS
	STEP = 0.0  
	DO 10 I=1,11
	IF (I.GT.5) STEP=.5
	INC=.05*(I-1)
	SHPAR(1,I,1)=.0
	SHPAR(2,I,1)=1.0
	SHPAR(1,I,2)=.5-INC
	SHPAR(2,I,2)=.5+INC
	SHPAR(1,I,3)=INC
	SHPAR(2,I,3)=1.0-INC
	SHPAR(1,I,4)=.0
	SHPAR(2,I,4)=.5+STEP
	SHPAR(1,I,5)=.0
	SHPAR(2,I,5)=1.0-STEP
	SHPAR(1,I,6)=.5-STEP
	SHPAR(2,I,6)=1.0
	SHPAR(1,I,7)=STEP
	SHPAR(2,I,7)=1.0
	SHPAR(1,I,8)=.0
	SHPAR(2,I,8)=1.0-INC
	SHPAR(1,I,9)=.0
	SHPAR(2,I,9)=.5+INC
	SHPAR(1,I,10)=INC
	SHPAR(2,I,10)=1.0
	SHPAR(1,I,11)=.5-INC
	SHPAR(2,I,11)=1.0
	SHPAR(1,I,12)=.5-INC
	SHPAR(2,I,12)=1.0-INC
	SHPAR(1,I,13)=INC
	SHPAR(2,I,13)=.5+INC
10	CONTINUE
C*****	INITIALIZE SYMBOL FLEXION LINES ARRAY
	FLXAR(1,1)=.0
	FLXAR(2,1)=.0
	FLXAR(3,1)=1.0
	FLXAR(4,1)=.0
	STEP=.0
	DO 20 I=2,7
	IF (I.GT.4) STEP = .166
	FLXAR(1,I)=.166*(I-1)-STEP
	FLXAR(2,I)=.0
	FLXAR(3,I)=.166*(I-2)+STEP
	FLXAR(4,I)=.165
20 	CONTINUE
C*****	INITIALIZE SYMBOL SUPPORT LINES ARRAY
C******	LIMBS
	SUPLAR(1,1,1)=1.0
	SUPLAR(1,1,2)=1.0
	SUPLAR(2,1,1)=.2
	SUPLAR(2,1,2)=.0
	SUPLAR(3,1,1)=1.0
	SUPLAR(3,1,2)=1.0
	SUPLAR(4,1,1)=1.0
	SUPLAR(4,1,2)=1.0
	SUPLAR(1,2,1)=1.0
	SUPLAR(1,2,2)=1.0
	SUPLAR(2,2,1)=1.0
	SUPLAR(2,2,2)=.7
	SUPLAR(3,2,1)=.5
	SUPLAR(3,2,2)=.5
	SUPLAR(4,2,1)=.8
	SUPLAR(4,2,2)=.7
	SUPLAR(1,3,1)=1.0
	SUPLAR(1,3,2)=1.0
	SUPLAR(2,3,1)=.2
	SUPLAR(2,3,2)=.3
	SUPLAR(3,3,1)=.5
	SUPLAR(3,3,2)=.5
	SUPLAR(4,3,1)=.0
	SUPLAR(4,3,2)=.3
	DO 40 I=4,6
	SUPLAR(1,I,1)=1.0
	SUPLAR(2,I,1)=(I-2)*.2
	SUPLAR(3,I,1)=.5
	SUPLAR(4,I,1)=(I-3)*.2
        SUPLAR(1,I,2)=1.0
	SUPLAR(2,I,2)=.1+(I-4)*.4
	SUPLAR(3,I,2)=.5
	SUPLAR(4,I,2)=.1+(I-4)*.4
40 	CONTINUE
C****** TORSO
	B=.0
	DO 50 I=1,4
	A=0
	IF ((I.EQ.2).OR.(I.EQ.3)) A=1.
	IF (I.EQ.3) B=1.0
	C = 0.0
	IF ((I.EQ.1).OR.(I.EQ.2)) C=1.0
	SUPTAR(1,I)=A
	SUPTAR(2,I)=B
	SUPTAR(3,I)=C
	SUPTAR(4,I)=A
50	CONTINUE
	C = .4
	D = .2
	DO 60 I=5,12
	A=C
	B=D
	C=GEN(I-2)
	D=GEN(I-4)
	SUPTAR(1,I)=A
	SUPTAR(2,I)=B
        SUPTAR(3,I)=C
	SUPTAR(4,I)=D
60	CONTINUE
	DO 70 I=13,17
	INC=.0
	IF ((I.EQ.13).OR.(I.EQ.17)) INC=.1
	SUPTAR(1,I)=.1*(I-10)
	SUPTAR(2,I)=.2+INC
	SUPTAR(3,I)=.1*(I-10)
	SUPTAR(4,I)=.8-INC
70	CONTINUE
C	WRITE(IOP,) (((SHPAR(I,J,K),I=1,2),J=1,11),K=1,13)
C	WRITE(IOP,) ((FLXAR(I,J),I=1,4),J=1,7)
C	WRITE(IOP,) ((SUPTAR(I,J),I=1,4),J=1,17)
C	WRITE(IOP,) (((SUPLAR(I,J,K),I=1,4),J=1,6),K=1,2)
	RETURN
	END
[\].
BOUND@DAT
  0.8600000E+03 0.4120000E+04
  0.8600000E+03 0.4380000E+04
  0.8600000E+03 0.4530000E+04
  0.8600000E+03 0.4720000E+04
  0.8600000E+03 0.4940000E+04
  0.8600000E+03 0.5150000E+04
  0.8600000E+03 0.5380000E+04
  0.8600000E+03 0.5590000E+04
  0.8600000E+03 0.5810000E+04
  0.8600000E+03 0.5980000E+04
  0.8600000E+03 0.6050000E+04
  0.8600000E+03 0.6200000E+04
  0.8600000E+03 0.6410000E+04
  0.1500000E+04 0.6550000E+04
  0.2120000E+04 0.6600000E+04
  0.2620000E+04 0.6550000E+04
  0.2980000E+04 0.6510000E+04
  0.3440000E+04 0.6630000E+04
  0.3860000E+04 0.6770000E+04
  0.4150000E+04 0.6780000E+04
  0.4440000E+04 0.6810000E+04
  0.4710000E+04 0.6840000E+04
  0.4890000E+04 0.7000000E+04
  0.5070000E+04 0.7150000E+04
  0.5170000E+04 0.7070000E+04
  0.5260000E+04 0.7020000E+04
  0.5330000E+04 0.6960000E+04
  0.5440000E+04 0.6930000E+04
  0.5340000E+04 0.6770000E+04
  0.5290000E+04 0.6570000E+04
  0.5750000E+04 0.6260000E+04
  0.6730000E+04 0.5830000E+04
  0.8440000E+04 0.5660000E+04
  0.1005000E+05 0.5570000E+04
  0.1208000E+05 0.4520000E+04
  0.1370000E+05 0.3620000E+04
  0.1356000E+05 0.3400000E+04
  0.1351000E+05 0.3330000E+04
  0.1322000E+05 0.2890000E+04
  0.1298000E+05 0.2500000E+04
  0.1292000E+05 0.2420000E+04
  0.1236000E+05 0.1540000E+04
  0.1214000E+05 0.1240000E+04
  0.1199000E+05 0.1050000E+04
  0.1175000E+05 0.7200000E+03
  0.1154000E+05 0.3900000E+03
  0.1149000E+05 0.3100000E+03
  0.1146000E+05 0.2600000E+03
  0.1041000E+05 0.1400000E+04
  0.9010000E+04 0.2910000E+04
  0.7910000E+04 0.3330000E+04
  0.6360000E+04 0.3680000E+04
  0.5750000E+04 0.3790000E+04
  0.5290000E+04 0.3940000E+04
  0.5130000E+04 0.3950000E+04
  0.5010000E+04 0.3960000E+04
  0.4880000E+04 0.4000000E+04
  0.4710000E+04 0.4010000E+04
  0.4440000E+04 0.4060000E+04
  0.4150000E+04 0.4100000E+04
  0.3860000E+04 0.4120000E+04
  0.3440000E+04 0.4120000E+04
  0.2980000E+04 0.4120000E+04
  0.2620000E+04 0.4120000E+04
  0.2120000E+04 0.4120000E+04
  0.1500000E+04 0.4120000E+04
  0.5000000E+76 0.5000000E+76
  0.5000000E+76 0.5000000E+76
[\].
CHMASTSRC
C*****************************************************************
C
C  THIS IS THE MASTER PROGRAM FOR ...CHOREO... AN INTERACTIVE
C  CHOREOGRAPHY APPLICATION  BY RON NORDIN  APRIL 1, 1974.
C
C  THIS PROGRAM IS COMPOSED OF 4 STAGES
C
C*****************************************************************
C
C
C*****************************************************************
C
C  STAGE I - THIS IS AN INTERACTIVE STAGE IN WHICH MOVEMENT
C            INFORMATION IS BUILT UP IN A TABLE CALLED 'SYMTAB'
C
C*****************************************************************
C
C
      INTEGER SYMST1,SYMST2,SYMST3,BODYPT,MOVETP,SAVST3
      DIMENSION BEATS(20)
      COMMON/EYCEP/EYE(3),CEN(3),UP(3)
      COMMON/OIL/IVECT(300)
      COMMON/LINKIT/ISTRT,LINKS(6,15)
      COMMON/LIMITS/XMIN,XMAX,YMIN,YMAX
      COMMON/MOTION/SYMTAB(5,7,20),DIRTAB(9,2)
C
      DATA A,B/5HCHRME,4HNBIN/
      DATA C,D/5HCHRMN,4HCBIN/
C
C**********
C  LOAD THE 2 MENU FILES AND INITIALIZE VARIABLES
C**********
      CALL CLEAR (.FALSE.)
      CALL ERRSET(1)
      CALL MENU(A,B,-1)
      CALL MENU(C,D,-1)
      XMAX=30.
      YMAX=20.
      YMIN=-40.
      XMIN=-30.
      ION = 4
      IOFF = 5
C**********
C  --PUT UP TITLE PAGE. INTRP TO PROCEED.---
C
      CALL MENU(A,B,9)
      INTRP=10
5     IF(INTRP.EQ.0) GO TO 5
      CALL MENU(A,B,10)
C  VECTOR TABLE-DIRTAB
      DIRTAB(1,1)=-1.0
      DIRTAB(1,2)=0.00005
      DIRTAB(2,1)=-.92
      DIRTAB(2,2)=.37
      DIRTAB(3,1)=-.7
      DIRTAB(3,2)=.7
      DIRTAB(4,1)=-.37
      DIRTAB(4,2)=.92
      DIRTAB(5,1)=0.00005
      DIRTAB(5,2)=1.0
      DIRTAB(6,1)=.37
      DIRTAB(6,2)=.92
      DIRTAB(7,1)=.7
      DIRTAB(7,2)=.7
      DIRTAB(8,1)=.92
      DIRTAB(8,2)=.37
      DIRTAB(9,1)=1.0
      DIRTAB(9,2)=0.00005
C  EYE POINT
      EYE(1)=0.
      EYE(2)=0.
      EYE(3)=60.
      CEN(1)=0.
      CEN(2)=0.
      CEN(3)=0.
      UP(1)=0.
      UP(2)=10.
      UP(3)=0.
      DIST=40.
      NEW=1
C
C
C**********
C  --3 IS THE TOP OF THE NEW DANCE LOOP----
C
3     CALL MENU(C,D,10)
C
      SYMST3=1
      SAVST3=1
      EXFRAM=0.0
C  --PLCE DANCER IN THE NORMAL POSITION---
C  --SET NEW = 1 TO CALL ROTOR IN DRAWIT.--
      CALL NORMAL(DIST,NEW)
C
C**********
C  --ENTER BEAT TEMPO---
      TEMPO=8.0
C  --CHECK IF NEW DANCE OR READ IN: NEW? GOTO 1. READ IN? 4
      CALL MENU(C,D,1)
      CALL CRT(ION,401)
      CALL CRT(ION,402)
6     NUM=1
7     IF(NUM.EQ.-1) GO TO 7
      IF(NUM.EQ.2) GO TO 1
      IF(NUM.EQ.1)GO TO 4
      GO TO 6
C
C**********
C   READ IN DANCE MOVEMENT 
4     CONTINUE
      DO 11 K=1,8
      KCNT=K
      READ(8,9)BEATS(K)
      DO 8 J=1,7
8     READ(8,9)(SYMTAB(I,J,K),I=1,5)
9     FORMAT(5F7.2)
      IF(SYMTAB(5,7,K).EQ.9.) GO TO 12
11    CONTINUE
C
12    SYMST3=KCNT
C----GO AND GENERATE DISPLAY OF MOVEMENTS----
      GO TO 949
C*********************************************************
C
C  --START OF NEW POSITION LOOP-----
1     SYMST3= SYMST3 + 1
C
C  --START OF NEW BODY PART LOOP-----
C
2     CALL MENU(C,D,10)
      CALL MENU(A,B,1)
      CALL CRT(ION,401)
      CALL CRT(ION,402)
10    NUM =-1
15    IF ( NUM .EQ. -1) GO TO 15
      IF (NUM.GT.6 .OR.NUM.EQ.0) GO TO 10
      IF (NUM.GE.3 .AND. NUM.LE.6) GO TO 200
C
C*****************************************************************
C   HEAD AND TORSO MOVEMENT SELECTION BLOCK
C*****************************************************************
      BODYPT = (NUM *10) + 6
      SYMTAB (1,NUM,SYMST3) =1
      SYMST2 = NUM
C**********
C  CALL MENU PAGE 4
C**********
110   CALL MENU(A,B,2)
      CALL CRT(ION,401)
      CALL CRT(ION,402)
      CALL CRT(ION,BODYPT)
130   NUM = -1
      INTRP = 0
135   IF (INTRP.EQ.-1) GO TO 800
      IF (NUM.EQ.-1) GO TO 135
      IF (NUM.EQ.4 .OR. NUM.EQ.5 .OR. NUM.EQ.9 .OR. NUM.EQ.0) GO TO 130
C
C**********
C  IF EXTENTION OR FLEXION
C**********
      IF (NUM.EQ.1) SYMST1 = 2
      IF (NUM.EQ.6) SYMST1 =-2
C
C**********
C  IF ROTATION IN  OR  ROTATION OUT
C**********
      IF(NUM.EQ.3)SYMST1=4
      IF (NUM.EQ.8) SYMST1 =-4
C
C**********
C  IF INCLINATION LEFT  OR INCLINATION RIGHT
C**********
      IF (NUM.EQ.2) SYMST1 =-3
      IF (NUM.EQ.7) SYMST1 = 3
C
      MOVETP = NUM * 100
      GO TO 700
C
C*****************************************************************
C     ARMS AND LEGS  MOVEMENT SELECTION BLOCK
C******************************************************************
200   BODYPT = (NUM *10) + 6
      SYMTAB(1,NUM,SYMST3) = 1
      SYMST2 = NUM
C**********
C  CALL MENU PAGE 5
C**********
210   CALL MENU(A,B,3)
      CALL CRT(ION,401)
      CALL CRT(ION,402)
      CALL CRT(ION,BODYPT)
220   NUM =-1
      INTRP = 0
230   IF (INTRP.EQ.-1) GO TO 800
      IF (NUM.EQ.-1) GO TO 230
      IF(NUM.EQ.5 .OR. NUM.EQ.9 .OR. NUM.EQ.0) GO TO 220
      IF (SYMST2.EQ.3 .OR. SYMST2.EQ.5) GO TO 250
C
C**********
C   RIGHT ARM AND RIGHT LEG SELECTION
C**********
C
C**********
C  IF IN DEPTH FRONT OR BACK
C**********
      IF (NUM.EQ.1) SYMST1 = 2
      IF (NUM.EQ.6) SYMST1 =-2
C
C**********
C  IF ADDUCTION OR ABDUCTION
C**********
      IF (NUM.EQ.2) SYMST1 = 3
      IF (NUM.EQ.7) SYMST1 =-3
C
C**********
C  IF ROTATION IN OR OUT
C**********
      IF (NUM.EQ.3) SYMST1 =-4
      IF (NUM.EQ.8) SYMST1 = 4
C
C**********
C  IF FLEXION
C**********
      IF (NUM.EQ.4 .AND. SYMST2.EQ.4) SYMST1 = 5
      IF (NUM.EQ.4 .AND. SYMST2.EQ.6) SYMST1 =-5
C
      MOVETP = NUM * 1000
      GO TO 700
C
C**********
C     LFT ARM AND LEFT LEG SELECTION
C**********
250   IF (NUM.EQ.1) SYMST1 = 2
      IF (NUM.EQ.6) SYMST1 =-2
C
      IF (NUM.EQ.2) SYMST1 =-3
      IF (NUM.EQ.7) SYMST1 = 3
C
      IF (NUM.EQ.3) SYMST1 = 4
      IF (NUM.EQ.8) SYMST1 =-4
C
      IF (NUM.EQ.4 .AND. SYMST2.EQ.3) SYMST1 = 5
      IF (NUM.EQ.4 .AND. SYMST2.EQ.5) SYMST1 =-5
C
      MOVETP = NUM * 1000
      GO TO 700
C
C******************************************************************
C      MOVEMENT  **DEGREE**  SELECTION BLOCK
C******************************************************************
C
C**********
C  CALL MENU PAGE 6
C**********
700   CALL MENU(A,B,4)
      CALL CRT(ION,401)
      CALL CRT(ION,402)
      CALL CRT(ION,BODYPT)
      CALL CRT(ION,MOVETP)
      IF (SYMST2.EQ.5 .OR. SYMST2.EQ.6) GO TO 750
      IF (SYMST2.EQ.3 .OR. SYMST2.EQ.4) GO TO 730
      IF (SYMST2.EQ.2) GO TO 720
C
C**********
C      HEAD MOVEMENT  DEGREE  SELECTION
C**********
710   NUM =-1
711   IF (NUM.EQ.-1) GO TO 711
      IF (MOVETP.EQ.100 .AND. NUM.LE.4) GO TO 755
      IF (MOVETP.EQ.200 .AND. NUM.LE.4) GO TO 755
      IF (MOVETP.EQ.300 .AND. NUM.LE.4) GO TO 755
      IF (MOVETP.EQ.600 .AND. NUM.LE.4) GO TO 755
      IF (MOVETP.EQ.700 .AND. NUM.LE.4) GO TO 755
      IF (MOVETP.EQ.800 .AND. NUM.LE.4) GO TO 755
      GO TO 710
C
C**********
C   TORSO MOVEMENT  DEGREE  SELECTION
C**********
720   NUM =-1
721   IF (NUM.EQ.-1) GO TO 721
      IF (MOVETP.EQ.100 .AND. NUM.LE.4) GO TO 755
      IF (MOVETP.EQ.200 .AND. NUM.LE.4) GO TO 755
      IF (MOVETP.EQ.300 .AND. NUM.LE.4) GO TO 755
      IF (MOVETP.EQ.600 .AND. NUM.LE.8) GO TO 755
      IF (MOVETP.EQ.700 .AND. NUM.LE.4) GO TO 755
      IF (MOVETP.EQ.800 .AND. NUM.LE.4) GO TO 755
      GO TO 720
C
C**********
C    ARMS MOVEMENT DEGREE SELECTION
C**********
730   NUM =-1
731   IF (NUM.EQ.-1) GO TO 731
      IF (MOVETP.EQ.1000 .AND. NUM.LE.9) GO TO 755
      IF (MOVETP.EQ.2000 .AND. NUM.LE.9) GO TO 755
      IF (MOVETP.EQ.3000 .AND. NUM.LE.9) GO TO 755
      IF (MOVETP.EQ.4000 .AND. NUM.LE.9) GO TO 755
      IF (MOVETP.EQ.6000 .AND. NUM.LE.5) GO TO 755
      IF (MOVETP.EQ.7000 .AND. NUM.LE.8) GO TO 755
      IF (MOVETP.EQ.8000 .AND. NUM.LE.9) GO TO 755
      GO TO 730
C
C**********
C   LEGS MOVEMENT DEGREE SELECTION
C**********
750   NUM =-1
751   IF (NUM.EQ.-1) GO TO 751
      IF (MOVETP.EQ.1000 .AND. NUM.LE.9) GO TO 755
      IF (MOVETP.EQ.2000 .AND. NUM.LE.5) GO TO 755
      IF (MOVETP.EQ.3000 .AND. NUM.LE.4) GO TO 755
      IF (MOVETP.EQ.4000 .AND. NUM.LE.9) GO TO 755
      IF (MOVETP.EQ.6000 .AND. NUM.LE.5) GO TO 755
      IF (MOVETP.EQ.7000 .AND. NUM.LE.4) GO TO 755
      IF (MOVETP.EQ.8000 .AND. NUM.LE.5) GO TO 755
      GO TO 750
C
C******************************************************************
C  ADD TO SYMTAB TABLE
C******************************************************************
755   IF (SYMST1.LT.0) NUM =-NUM
      SYMST1 = IABS(SYMST1)
      SYMTAB(SYMST1,SYMST2,SYMST3) = NUM
C**********
C    RETURN TO MOVEMENT TYPE SLECTION
C**********
      IF (SYMST2.LE.2) GO TO 110
      GO TO 210
C
C******************************************************************
C    NEW POSITION COMPLETE ?
C******************************************************************
C
C**********
C  CALL MENU PAGE 7
C**********
800   CALL MENU(A,B,6)
      CALL CRT(ION,401)
      CALL CRT(ION,402)
810   NUM =-1
811   IF (NUM.EQ.-1) GO TO 811
      IF (NUM.GT.2 .OR. NUM.EQ.0) GO TO 810
      IF (NUM.EQ. 2) GO TO 900
C
      GO TO 2
C
C******************************************************************
C    NEW BODY DIRECTION ?
C
900   CALL MENU(A,B,7)
      CALL CRT(ION,401)
      CALL CRT(ION,402)
C  ---SELECT ORIENTATION-----
910   NUM =-1
      INTRP=0
911   IF (INTRP.EQ.-1) GO TO 915
      IF (NUM.EQ.-1) GO TO 911
      IF (NUM.EQ.9 .OR. NUM.EQ.0) GO TO 910
      SYMTAB(1,7,SYMST3)=1.
      SYMTAB(2,7,SYMST3) = NUM
C
C  --SELECT DIRECTION OF ROTATION----
912   NUM=-1
913   IF (NUM.EQ.-1) GO TO 913
      IF (NUM.LT.9 .AND. NUM.NE.0) GO TO 912
      SYMTAB(3,7,SYMST3) =NUM
915   CONTINUE
C
C  ----CONVERT SYMTAB TO VECTOR,ROLL AND FLEXION-----
      CALL CONVRT(SYMST3)
C::******************************************************
C
C  --ENTER NUMBER OF BEATS FOR THIS MOVEMENT.
      CALL MENU(A,B,10)
      CALL MENU(C,D,10)
      CALL MENU(C,D,5)
      CALL CRT(ION,401)
      CALL CRT(ION,402)
C  --WHOLE BEATS HERE--
      NUM=-1
922   IF(NUM.EQ.-1)GO TO 922
      BEATS(SYMST3)=NUM
C
C  ---QUARTER BEATS HERE---
      CALL MENU(C,D,6)
      CALL CRT(ION,401)
      CALL CRT(ION,402)
923   NUM=-1
924   IF(NUM.EQ.-1)GO TO 924
C  --TRAP OUT  ILLEGAL ENTRIES--
      IF(NUM.EQ.0)GO TO 923
      IF(NUM.GE.5)GO TO 923
C  --TOTAL--
      BEATS(SYMST3)=BEATS(SYMST3)+FLOAT(NUM-1)/4.0
C
      CALL MENU(A,B,10)
      CALL MENU(C,D,10)
C******************************************************************
C  --IS A PREVIEW REQUESTED?------
949   CALL MENU(C,D,10)
      CALL MENU(A,B,8)
      CALL CRT(ION,401)
      CALL CRT(ION,402)
950   NUM=2
951   IF (NUM.EQ.-1) GO TO 951
      IF (NUM.NE.1 .AND. NUM.NE.2) GO TO 950
      IF (NUM.EQ.2) GO TO 999
C
C     INCREMENT TO THE NEXT NEW POSITION DEFINITION
      GO TO 1
C*******************************************************************
C
C  --DISPLAY LOOP SECTION-----
999   CALL MENU(A,B,10)
      CALL MENU(C,D,10)
C
C***************
C   MAIN DISPLAY LOOP ----
C
1000  SAVST3=SAVST3+1
C
C  --CALCULATE NO. STEPS FOR THIS MOVEMENT--
      TOTFRM=BEATS(SAVST3)*TEMPO+EXFRAM
      ISTP=TOTFRM+0.5
      EXFRAM=TOTFRM-FLOAT(ISTP)
C
C --GO GENERATE RAC MATRICES--
      CALL GENRAC(SAVST3,ISTP,NEW,DIST)
C  --CHECK IF THIS IS THE LAST UNCALC. MOVEMENT--
      IF (SAVST3.LT.SYMST3) GO TO 1000
C
C******************************************************************
C    FILM SECTION--------------------
      IFM=1
1100  CALL DSPLAY(3,32767,IERR)
      CALL CLEAR
      CALL DSPLAY(1,32767,IERR)
      CALL PULSE(2,IFM)
      PAUSE
      IFM=IFM+10
      IF(IFM.LT.111)GO TO 1100
C
C 
C  STAGE IV - INTERACTIVE STAGE OFFERING A FACILITY TO 
C             SAVE THE DANCE DESCRIPTION.
C
C  ---CONTINUE OR END-----
      CALL MENU(A,B,10)
      CALL MENU(C,D,2)
      CALL CRT(ION,401)
      CALL CRT(ION,402)
1253  NUM=-1
1255  IF(NUM.EQ.-1) GO TO 1255
      IF (NUM.EQ.1) GO TO 1
      IF(NUM.EQ.2) GO TO 1260
      GO TO 1253
C
C**********
C  CALL MENU PAGE 11
C**********
1260  CALL MENU(C,D,3)
      CALL CRT(ION,401) 
      CALL CRT(ION,402)
1265  NUM=-1
1266  IF(NUM.EQ.-1) GO TO 1266
      IF (NUM.EQ.1) GO TO 1270
      IF(NUM.EQ.2)GO TO 1280
      GO TO 1265
C
1270  SYMTAB(5,7,SYMST3)=9.
      DO 1274 K=1,SYMST3
      WRITE(7,1275)BEATS(K)
      DO 1274 J=1,7
1274  WRITE(7,1275)(SYMTAB(I,J,K),I=1,5)
1275  FORMAT(1X,5F7.2)
C
C**********
C  CALL MENU PAGE 12
C**********
1280  CALL MENU(C,D,4)
      CALL CRT(ION,401)
      CALL CRT(ION,402)
1282  NUM=-1
1283  IF(NUM.EQ.-1)GO TO 1283
      IF(NUM.EQ.1)GO TO 3
      IF (NUM.EQ.2)GO TO 1290
      GO TO 1282
C
1290  STOP 7
      END
[\].
CHOR1@JOB
$JOB 21 T=5 UFD=RK1<G0M>
$MSG CHOR1 -CHOR1 TKB STEP
$DEL CHOR1 TSK
$DEL CHOR1 IMG
$TKB
SZ,UL:F4LIB}
CHOR1}
350}
TDV.GR}
CHOR1,ARINIT,COLM,SYMBLD,SORTB}
 }
$CON CHOR1}
$END
$END
$PAR TDV.GR
[\].
CHOR1@SRC
C	****************************************************************
C	CHOR1 (LABAN SYMBOL INPUT PHASE) FOR
C	*CHOREO* INTERACTIVE DANCE FACILITY (AUTHOR -G.A.MCDOUGALL)
C	-STORES EACH SYMBOL AS 8 NUMBERS IN "DANC1 SRC" FILE
C	-CALLS SYMBLD TO DISPLAY SYMBOL
C	-CALLS SORTB TO SORT SYMBOLS INTO READ ORDER
C	****************************************************************
C
	REAL BLEN,BTIM,SBTIM(11),TBAR(50,2)
	REAL XMIN,XMAX,YMIN,YMAX
	REAL XA,XB,YA,YB
C
	INTEGER COL,SUP,DIR,LEV,ROT,FLX,CHG
	INTEGER X,Y,XC,YC
	INTEGER TBARI(50,6),EBAR,EDAN
	INTEGER BAR,CONT,FLIP
	INTEGER STP,SIB,TSIB,CH,ZR,FNM(2)
	INTEGER SORTV1(50),SORTV2(50),ZXY(3)
	INTEGER FIRST,LAST,TAG,MODE,BEGIN,END,IVECT(400)
	INTEGER INT,ISPACE,FNC
	INTEGER IOT,IOP,IOD
C
	COMMON/SYMBOL/ COL,SUP,DIR,LEV,ROT,FLX,BLEN,BTIM,SBTIM
	COMMON/SORTC/SORTV1,SORTV2,SIB
	COMMON/VECT/ FIRST,LAST,TAG,MODE,BEGIN,END,IVECT
	COMMON/LIMITS/ XMIN,XMAX,YMIN,YMAX
	COMMON/FRAME/ XA,XB,YA,YB
	COMMON/IOLU/ IOT,IOP,IOD
C
	DATA TBARI,TBAR/300*0,100*0./
C
C		INIT LUN ASST'S  ****************************************
	IOT=4
	IOP=6
	IOD=17
C
	WRITE(IOT,9)
	WRITE (IOT,10)
	WRITE (IOT,11)
C
9	FORMAT('- ******** CHOREO INTERACTIVE DANCE FACILITY *********')
10	FORMAT(' YOU MAY  1-CREATE,2-CHANGE THE CHOREO "DANC1 SRC" FILE')
11	FORMAT(' ENTER YOUR CHOICE AS A NUMBER')
	READ (IOT,) CH
	IF (CH .EQ.2) GOTO 28
C		 CREATE -DELETE OLD FILE (IF PRESENT) 
23	CALL DELETE (IOD,5HDANC1,3HSRC,IEV)
25	CALL WAITFR (IEV)
	IF (IEV) 999,25,27
27	WRITE (IOT,15)
C
15	FORMAT( ' ENTER BEATS/BAR (3 OR 4)')
	READ (IOT,) BPB
C		OPEN THE DANCE FILE 
26	CALL ENTER (IOD,5HDANC1,3HSRC,IEV)
22	CALL WAITFR (IEV)
	IF (IEV) 999,22,60
C
C		CHANGE SYMBOLS IN EXISTING FILE
28 	CONTINUE
C	CALL SEEK(IOD,5HDANC1,3HSRC,IEV)
C	CALL EDITD (NOT CODED YET)
	GOTO 1000
C		INITIALIZATION SECTION **********************************
60 	CONTINUE
C		INIT SCREEN LIMITS
	XMIN=0.
	XMAX=20.
	YMIN=0.
	YMAX=20.
	XA=0.
	XB=20.
	YA=0.
	YB=20.
C		INITIALIZE ARRAYS USED TO BUILD SYMBOLS
	CALL ARINIT
C		INIT GEN PURPOSE VARS
	EBAR = 998
	EDAN =999
	ZR = 0
	RZR=0.
	BAR = 1
	SIB=0
	TSIB=0
	BBTIM=0.
	DO 64 I=1,11
64	SBTIM(I)=0.0
	WRITE(IOT,65) 
C
65	FORMAT(' NOW -ENTER SYMBOLS FROM THE ACOUSTIC TABLET')
C******************************************************************
C		SYMBOL PARAMETER ASSIGNMENT SECTION
80	CONTINUE
	CALL CLEAR(.TRUE.)
	CALL COLM
81	COL=0
	SUP  = 0
	DIR  = 0
	LEV  = 0
	ROT  = 0
	FLX  = 0
	BLEN = 0.0
	BTIM = 0.0
	GOTO 90
C	********************************* MANUAL INPUT SECTION *****
C90	WRITE (IOT,190) 
190	FORMAT(' CO SU DI LE RO FL BL  1=EOS/2=EOB/3=EOD')
	READ (IOT,) COL,SUP,DIR,LEV,ROT,FLX,BLEN,III
	GOTO (200,300,1000),III
	GOTO 90
C	*************************  A.T. INPUT SECTION  ******************
90	CALL GETBLT(25,0,ZXY,IEV)
	CALL WAITFR(IEV)
	XC=ZXY(3)
	YC=ZXY(2)
	X=17-XC/56
	Y=1+YC/56
	IF ((X.GT.16).OR.(Y.GT.16)) GOTO 90
C	****************************************************************
C		SET THE PARAMETER
  	GOTO (90,100,90,110,90,120,90,130,140,150,90,160,90,
     *  170,180,90),X
C		SET  **  COL  **
100	IF ((Y.EQ.1).OR.(Y.GE.13)) GOTO 90
	COL=Y-1
	WRITE (IOT,) COL
	GOTO 90
C		SET  **  SUP  **
110	IF (Y.EQ.16) GOTO 90
	SUP=Y-1
	WRITE (IOT,) SUP
	GOTO 90
C		SET  **  DIR  **
120	IF (Y.GE.15) GOTO 90
	DIR=Y-1
	WRITE (IOT,) DIR
	GOTO 90
C		SET  **  LEV  OR  ROT **
130	GOTO (90,131,131,131,90,90,90,90,132,132,132,90,90,
     *  90,90,90),Y
131	LEV=Y-1
	WRITE (IOT,) LEV
	GOTO 90
132	ROT=Y-2
	IF (Y.EQ.11) ROT=1
	WRITE (IOT,) ROT
	GOTO 90
C		SET  **  ROT  **
140	IF (Y.EQ.9) ROT=6
	IF (Y.EQ.10) ROT=0
	IF (Y.EQ.11) ROT=2
	WRITE (IOT,) ROT
	GOTO 90
C		SET  **  FLX  OR  ROT  **
150	GOTO (151,151,151,151,151,151,151,90,152,152,152,90,90,
     *  90,90,90),Y
151	FLX=Y-1
	WRITE (IOT,) FLX
	GOTO 90
152	ROT=5-(Y-9)
	WRITE (IOT,) ROT
	GOTO 90
C		SET  **  EOS,  EOB,  EOD  **
160	GOTO (161,161,161,161,161,161,161,161,161,90,90,200,90,
     *  300,90,1000),Y
C		SET  **  BLEN  **
161	BLEN=BLEN+(Y-1)*.125
	IF (BLEN.GT.BPB) BLEN=BPB
	IF (Y.EQ.1) BLEN=0
	WRITE (IOT,) BLEN
	GOTO 90
C		CHANGE SYMBOL (NOT CODED YET)
170	GOTO 90
C		EDIT,REPLAY NOT CODED YET
180	GOTO 90
C	***********************************************************
C		SYMBOL ERROR MSGS
200	CONTINUE
	IF (COL .GT. 0) GOTO 204
	WRITE (IOT,201)
201	FORMAT (' COL  IS ALSO REQUIRED')
	GOTO 90
204	IF (.NOT.((DIR.NE.0).AND.((LEN.EQ.0).OR.(LEV.EQ.0)))) GOTO 206
	WRITE(IOT,205)
205	FORMAT(' BLEN, LEV   ARE ALSO REQUIRED')
	GOTO 90
C	*****************************************************************
C		SYMBOL DISPLAY & STORE SECTION  
206	CONTINUE
	SIB=SIB+1
	TAG=SIB
C		BUILD AND DISPLAY SYMBOL
	CALL SYMBLD
C		CALC SYMBOL START TIME (BEAT UNITS)
	BTIM=BBTIM+SBTIM(COL)
	WRITE (IOT,) BTIM,SIB
C		UPDATE RELATIVE (WRT BAR) START TIME
	SBTIM(COL)=SBTIM(COL)+BLEN
C		STORE SORT ORDER
	SORTV1(SIB) = (BTIM*1000)+COL
C		STORE SYMBOL IN TEMP ARRAY (MUST BE SORTED BEFORE FILED)
	TBARI(SIB,1) = COL
	TBARI(SIB,2) = SUP
	TBARI(SIB,3) = DIR
	TBARI(SIB,4) = LEV
	TBARI(SIB,5) = ROT
	TBARI(SIB,6) = FLX
	TBAR(SIB,1) = BLEN
	TBAR(SIB,2) = BTIM
	WRITE (IOT,208)
208	FORMAT('------------------ END OF SYMBOL ------------')
	GOTO 81
C************************************************************************
C		END OF BAR PROCESSING  
300	CONTINUE
C		SORT THE SYMBOLS BY COL WITHIN STARTING LOCATION
	CALL SORTB
C		FILE HEADER & SYMBOL RECORDS IN ORDER
	WRITE (IOD,500) EBAR,BAR,SIB,ZR,ZR,ZR,RZR,RZR
500	FORMAT(6I3,2F7.3)
	DO 320 I=1,SIB
	IN = SORTV2(I)
	WRITE (IOD,500) TBARI(IN,1),TBARI(IN,2),TBARI(IN,3),TBARI(IN,4),
	1TBARI(IN,5),TBARI(IN,6),TBAR(IN,1),TBAR(IN,2)
320	CONTINUE
C
C		UPDATE TOTAL SYMBOLS IN DANCE & BAR # , RESET SIB
	TSIB = TSIB + SIB
	SIB = 0
	BAR = BAR + 1
C		UPDATE ABSOLUTE BAR START TIME, & RELATIVE (WRT BAR) 
C                                           SYMBOL START TIME
	BBTIM=BBTIM+BPB
	DO 310 I=1,11
310	SBTIM(I)=AMAX1(0.0,(SBTIM(I)-BPB))
	WRITE (IOT,311)
311	FORMAT(' ***************** END OF BAR ****************')
	GOTO 80
C***************************************************************
C		END OF DANCE PROCESSING  
1000	WRITE (IOD,500) EDAN,BAR,TSIB,ZR,ZR,ZR,RZR,RZR
C		CLOSE THE DANCE FILE
999	CONTINUE
	CALL CLOSE (IOD,5HDANC1,3HSRC,IEV)
	CALL WAITFR(IEV)
	WRITE(IOT,)IEV
2000	CONTINUE
	WRITE(IOT,2001)
C
2001	FORMAT(' TO VIEW ANIMATION OF DANCE -ENTER "CHOR2"')
	STOP
	END
[\].
CHOR2@JOB
$JOB 21 T=5 UFD=RK1<G0M>
$MSG CHOR2: CHOREO BATCH JOB TO ASSEMBLE AND TASK BUILD  CHOR2 TASK
 $FOR BRL_CHOR2,MOVINC,RDCON
 $FOR BRL_NORMAL,INITL,INPUTS,ROTATE,FILMOD,PRTPRD,PRTSUM,NEXT,DRAWIT
$DEL CHOR2 TSK
$DEL CHOR2 IMG
$TKB
SZ,UL:F4LIB}
CHOR2}
350}
TDV.GR}
CHOR2,RDCON,MOVINC,NORMAL,INITL,INPUTS,ROTATE,FILMOD,
PRTPRD,PRTSUM,NEXT,DRAWIT}
 }
$CON CHOR2
$END
[\].
CHOR2@SRC
C-------------------------------------------------------------------
C	CHOR2 (ANIMATION PHASE) FOR *CHOREO* INTERACTIVE DANCE FACILITY
C	(AUTHOR: GLEN MCDOUGALL) 
C	-CALLS RDCON TO READ "DANC1 SRC" FILE & CONVERT TO MODULE ANGLES
C	-COORDINATES TIMING FOR MODULE MOVEMENT
C	-CALLS MOVINC TO BUILD & DISPLAY EACH FRAME
C	-MODS 1-15=(HP,CH,RUA,RLA,RH,LUA,LLA,LH,HD,RUL,RLL,RF,LUL,LLL,LF)
C----------------------------------------------------------------------
	INTEGER FRMTIM,FTIM,FDUR1,FTIMN,FDURN
	INTEGER NFRMS(15)
	REAL LRPY,FANG(3,15)
C
	COMMON/LRPYC/LRPY(6,15),LFRM
	COMMON/FANGC/FANG,FRMTIM,NFRMS
	COMMON/IOLU/ IOT,IOP,IOD
	COMMON/EYCEP/EYE(3),CEN(3),UP(3)
	COMMON/LINKIT/ ISTRT,LINKS(6,15)
	COMMON/LIMITS/XMIN,XMAX,YMIN,YMAX
C******************************************************************
C		TERMINAL & PRINTER LUN'S
	IOT=4
	IOP=6
	IOD=17
C		SET UP VIEWING PARAMETERS
	XMIN=-30.
	XMAX=30.
	YMIN=-30.
	YMAX=30.
C
	EYE(1)=0.
	EYE(2)=0.
	EYE(3)=0.
	CEN(1)=0.
	CEN(2)=0.
	CEN(3)=0.
	UP(1)=0.
	UP(2)=10.
	UP(3)=0.
	DIST=60.
C
4	WRITE(IOT,5)
5	FORMAT(' ENTER VIEW: 1-BACK,2-FRONT,3-RSIDE,4-LSIDE,5-TOP')
	READ(IOT,) I
	IF((I.GT.5).OR.(I.LT.1)) GOTO 4
	IF (I.EQ.1) EYE(1)= -DIST
	IF (I.EQ.2) EYE(1)=  DIST
	IF (I.EQ.3) EYE(3)=  DIST
	IF (I.EQ.4) EYE(3)= -DIST
	IF (I.NE.5) GOTO 7
	EYE(2) = DIST
	EYE(1) = -DIST/6
7	CALL ROTER
	CALL CLEAR(.TRUE.)
C*****************************************************************
C		INIT -FOR EACH MODULE:# OF MOVEMENT FRAMES
C		& LOCAL ROLL, PITCH, YAW ROTATIONS & FINAL ANGLES 
        DO 21 M=1,15
	DO 21 L=1,6
	NFRMS(M)=0
	LRPY(L,M)=0.
	IF (L.GT.3) GOTO 21
	FANG(L,M)=0.
21	CONTINUE
	ISTRT=1
	NEW=0
C		READ IN MOD & LINK INFO & DISPLAY CHARLIE(AT ATTENTION)
	CALL INPUTS
	LFRM=1
	CALL MOVINC(DIST,NEW)
C
	WRITE(IOT,19)
 19     FORMAT(' ENTER TEMPO (IN BEATS PER MIN.)')
	READ(IOT,)TMPO
	FPBT=1440./TMPO
C		INIT PARAMETERS
	JUMP=0
	FRMTIM=0
C		OPEN THE DANCE FILE FOR FUTURE READS
	CALL SEEK(IOD,5HDANC1,3HSRC,IEV)
22	CALL WAITFR(IEV)
	IF (IEV) 999,22,23
23	CONTINUE
	WRITE (IOT,) IEV,FPBT
C***************************************************************************
C		READ & CONVERT DANCE FILE SYMBOLS INTO MOD ANGLES
2	CONTINUE
	CALL RDCON (FPBT)
	WRITE (IOP,) FRMTIM,LFRM
C		END OF DANCE ?
	IF (FRMTIM.LT.0) GOTO 999
C		CALC INCR ANGLES FOR NEW MOVEMENTS
	DO 15 MOD=1,15
	FDUR1=NFRMS(MOD)
	IF (FDUR1.EQ.0) GOTO 15
	LRPY(4,MOD)=(FANG(1,MOD)-LRPY(1,MOD))/FDUR1
	LRPY(5,MOD)=(FANG(2,MOD)-LRPY(2,MOD))/FDUR1
	LRPY(6,MOD)=(FANG(3,MOD)-LRPY(3,MOD))/FDUR1
15	CONTINUE
C*****************************************************************
	DO 398 I=1,15
	IF (NFRMS(I).EQ.0) GOTO 398
	WRITE (IOP,) NFRMS(I)
398	CONTINUE
	DO 399 I=1,15
	DO 399 J=1,6
	IF (LRPY(J,I).EQ.0) GOTO 399
	WRITE (IOP,) LRPY(J,I)
399	CONTINUE
C*****************************************************************
C		DISPLAY CHARLIE FOR LFRM FRAMES
C		USING LRPY ANGLES 
C
	CALL MOVINC(DIST,NEW)
C		UPDATE FRMTIM ("ABSOLUTE CLOCK")
	FRMTIM=FRMTIM+LFRM
C******************************************************************
C		UPDATE START ANGLES AND # OF REMAINING FRAMES
	DO 11 M=1,15
C		IF NO RECENT MOD MOVMNT -IGNORE
	IF (NFRMS(M).EQ.0) GOTO 11
C		UPDATE START ANGS
	LRPY(1,M)=FANG(1,M)
	LRPY(2,M)=FANG(2,M)
	LRPY(3,M)=FANG(3,M)
C		UPDATE # REMAINING FRMS
	NFRMS(M)=NFRMS(M)-LFRM
C		IF MOD MOVMNT ENDS ZERO INCR ANGS FOR MOD
	IF (NFRMS(M).NE.0) GOTO 11
	LRPY(4,M)=0.
	LRPY(5,M)=0.
	LRPY(6,M)=0.
11	CONTINUE
C***************************************************************
	DO 498 I=1,15
	IF (NFRMS(I) .EQ.0) GOTO 498
	WRITE (IOP,) NFRMS(I)
498	CONTINUE
	DO 499 I=1,15
	DO 499 J=1,6
	IF(LRPY(J,I).EQ.0) GOTO 499
	WRITE(IOP,) LRPY(J,I)
499	CONTINUE
	GOTO 2
C***************************************************************
C****************************************************************
999	CONTINUE
C		CLOSE THE DANCE FILE
	CALL CLOSE (IOD,5HDANC1,3HSRC,IEV)
88	CALL WAITFR(IEV)
	IF (IEV) 89,88,89
89	WRITE (IOT,) IEV
	STOP
	END
[\].
CHOR3@SRC
C	MAINLINE CHOR2
C-------------------------------------------------------------------
C	CHOR2 (ANIMATION PHASE) OF CHOREO INTERACTIVE DANCE FACILITY
C	AUTHOR: GLEN MCDOUGALL 
C
C	CALLS RDCON, BOOKKEEPS START & INCR ANGS FOR MODS, CALLS MOVINC
C----------------------------------------------------------------------
	INTEGER FRMTIM,FTIM,FDUR1,FTIMN,FDURN
	INTEGER NFRMS(15)
	REAL LRPY,FANG(3,15)
C
	COMMON/LRPYC/LRPY(6,15),LFRM
	COMMON/FANGC/FANG,FRMTIM,NFRMS
	COMMON/IOLU/ IOT,IOP,IOD
	COMMON/EYCEP/EYE(3),CEN(3),UP(3)
	COMMON/LINKIT/ ISTRT,LINKS(6,15)
	COMMON/LIMITS/XMIN,XMAX,YMIN,YMAX
C******************************************************************
C		TERMINAL & PRINTER LUN'S
	IOT=4
	IOP=6
	IOD=17
C		SET UP VIEWING PARAMETERS
C		"ENTER VIEW DESIRED -FRONT,TOP,SIDE"
	XMIN=-30.
	XMAX=30.
	YMIN=-30.
	YMAX=30.
	EYE(1)=0.
	EYE(2)=0.
	EYE(3)=60.
	CEN(1)=0.
	CEN(2)=0.
	CEN(3)=0.
	UP(1)=0.
	UP(2)=10.
	UP(3)=0.
	CALL ROTER
	CALL CLEAR(.TRUE.)
C*****************************************************************
	DIST=60.
	ISTRT=1
	NEW=0
C		READ IN MOD & LINK INFO
	CALL NORMAL(DIST,NEW)
C***********
	CALL INPUTS
	LFRM=1
	CALL MOVINC(DIST,NEW)
C		INIT LOCAL ROLL, PITCH, YAW ROTATIONS FOR EACH MODULE
        DO 21 M=1,15
	DO 21 L=1,6
	NFRMS(M)=0
21      LRPY(L,M)=0.
C		INIT FINAL ANGLE ARRAY
	DO 20 M=1,15
	DO 20 L=1,3
20	FANG(L,M)=LRPY(L,M)
C
C		READ IN TEMPO (IN BEATS/MIN) AND INIT VARS
	WRITE(IOT,19)
 19     FORMAT(' ENTER TEMPO')
	READ(IOT,)TMPO
	FPBT=1440./TMPO
C		INIT PARAMETERS
	JUMP=0
	FRMTIM=0
	LFRM=0
C
C		OPEN THE DANCE FILE FOR FUTURE READS
	CALL SEEK(IOD,5HDANC1,3HSRC,IEV)
22	CALL WAITFR(IEV)
	IF (IEV) 999,22,23
23	CONTINUE
	WRITE (IOT,) IEV,FPBT
C***************************************************************************
C****************************************************************
C		READ & CONVERT DANCE FILE SYMBOLS INTO MOD ANGLES
C		STORE FINAL ANGLES IN FANG AND SET NFRMS(M)
2	CONTINUE
C
	CALL RDCON (FPBT)
C		END OF DANCE ?
	IF (FRMTIM.LT.0) GOTO 999
C		CALC INCR ANGLES FOR NEW MOVEMENTS
	DO 15 MOD=1,15
	FDUR1=NFRMS(MOD)
	IF (FDUR1.EQ.0) GOTO 15
	LRPY(4,MOD)=(FANG(1,MOD)-LRPY(1,MOD))/FDUR1
	LRPY(5,MOD)=(FANG(2,MOD)-LRPY(2,MOD))/FDUR1
	LRPY(6,MOD)=(FANG(3,MOD)-LRPY(3,MOD))/FDUR1
15	CONTINUE
C*****************************************************************
	WRITE(IOP,)FRMTIM,LFRM,FDUR1
	DO 398 I=1,15
	IF (NFRMS(I).EQ.0) GOTO 398
	WRITE (IOP,) NFRMS(I)
398	CONTINUE
	DO 399 I=1,15
	DO 399 J=1,6
	IF (LRPY(J,I).EQ.0) GOTO 399
	WRITE (IOP,) LRPY(J,I)
399	CONTINUE
C*****************************************************************
C		DISPLAY CHARLIE FOR LFRM FRAMES
C		USING LRPY ANGLES AND NFRMS
C
	CALL MOVINC(DIST,NEW)
C		UPDATE FRMTIM ("ABSOLUTE CLOCK")
	FRMTIM=FRMTIM+LFRM
C******************************************************************
C		UPDATE START ANGLES AND # OF REMAINING FRAMES
	DO 11 M=1,15
C		IF NO RECENT MOD MOVMNT -IGNORE
	IF (NFRMS(M).EQ.0) GOTO 11
C		UPDATE START ANGS
	LRPY(1,M)=FANG(1,M)
	LRPY(2,M)=FANG(2,M)
	LRPY(3,M)=FANG(3,M)
C		UPDATE # REMAINING FRMS
	NFRMS(M)=NFRMS(M)-LFRM
C		IF MOD MOVMNT ENDS ZERO INCR ANGS FOR MOD
	IF (NFRMS(M).NE.0) GOTO 11
	LRPY(4,M)=0.
	LRPY(5,M)=0.
	LRPY(6,M)=0.
11	CONTINUE
C***************************************************************
	DO 498 I=1,15
	IF (NFRMS(I) .EQ.0) GOTO 498
	WRITE (IOP,) NFRMS(I)
498	CONTINUE
	DO 499 I=1,15
	DO 499 J=1,6
	IF(LRPY(J,I).EQ.0) GOTO 499
	WRITE(IOP,) LRPY(J,I)
499	CONTINUE
	GOTO 2
C***************************************************************
C****************************************************************
999	CONTINUE
C		CLOSE THE DANCE FILE
	CALL CLOSE (IOD,5HDANC1,3HSRC,IEV)
88	CALL WAITFR(IEV)
	IF (IEV) 89,88,89
89	WRITE (IOT,) IEV
	STOP
	END
[\].
CHRMN@SRC
  1
   1  13
 -0.5 -1.0  1.5  2.5  0.0  2.0
  2.5  0.0  2.0  2.5  1.5  2.5
  2.5  1.5  2.5  2.5  1.5 -2.5
  2.5  1.5 -2.5  2.5  0.0 -2.0
  2.5  0.0 -2.0 -0.5 -1.0 -1.5
 -0.5 -1.0 -1.5 -1.5  1.5 -2.0
 -1.5  1.5 -2.0 -0.5  2.3 -1.8
 -0.5  2.3 -1.8 -0.5  2.3  1.8
 -0.5  2.3  1.8 -1.5  1.5  2.0
 -1.5  1.5  2.0 -0.5 -1.0  1.5
 -0.5 -1.0  1.5 -0.5 -1.0 -1.5
  2.5  1.5 -2.5 -0.5  2.3 -1.8
 -0.5  2.3  1.8  2.5  1.5  2.5
  2
  14  35
  0.5  1.0  2.0  0.0  5.0  2.5
  0.0  5.0  2.5  2.0  8.0  1.5
  2.0  8.0  1.5  2.0  8.0 -1.5
  2.0  8.0 -1.5  0.0  5.0 -2.5  
  0.0  5.0 -2.5  0.5  1.0 -2.0
  0.5  1.0 -2.0  2.5  4.5 -0.5
  2.5  4.5 -0.5  2.5  4.5  0.5
  2.5  4.5  0.5  0.5  1.0  2.0
  0.5  1.0  2.0 -0.5  1.0  1.0
 -0.5  1.0  1.0 -1.5  6.0  2.5
 -1.5  6.0  2.5  0.5  9.0  2.0
  0.5  9.0  2.0  0.5  9.0 -2.0
  0.5  9.0 -2.0 -1.5  6.0 -2.5
 -1.5  6.0 -2.5 -0.5  1.0 -1.0
 -0.5  1.0 -1.0  0.5  1.0 -2.0
 -0.5  1.0  1.0 -0.5  1.0 -1.0
  0.0  5.0  2.5 -1.5  6.0  2.5
  0.0  5.0 -2.5 -1.5  6.0 -2.5
  0.5  9.0  2.0  2.0  8.0  1.5
  2.0  8.0  1.5  2.5  4.5  0.5
  2.5  4.5 -0.5  2.0  8.0 -1.5
  2.0  8.0 -1.5  0.5  9.0 -2.0
  3
  36  36
  0.0  0.0  0.0  0.0 -6.4  0.0 
  4
  37  37
  0.0  0.0  0.0  0.0 -6.0  0.0
  5
  38  42
  0.0  0.0  0.0  0.0  0.0  0.0
  0.0  0.0  0.0  0.0  0.0 -0.0
  0.0 -1.8 -0.8  0.0 -1.8 -0.3
  0.0 -2.5  1.0  0.0 -2.5 -0.2
  0.0 -2.5 -0.2  0.0 -1.2 -0.2
  6
  42  42
  0.0  0.0  0.0  0.0 -6.4  0.0  
  7
  43  43
  0.0  0.0  0.0  0.0 -6.0  0.0  
  8
  44  48
  0.0 -2.5  0.2  0.0 -1.2  0.2
  0.0  0.0  0.0  0.0 -2.5 -1.0
  0.0  0.0  0.0  0.0 -1.8  0.8
  0.0 -1.8  0.8  0.0 -1.8  0.3
  0.0 -2.5 -1.0  0.0 -2.5  0.2
  9 
  49 59
 -0.9  0.5  1.5 -0.3  3.0  1.5  
 -0.3  3.0  1.5 -0.3  3.0 -1.5
 -0.3  3.0 -1.5 -0.9  0.5 -1.5
 -0.9  0.5 -1.5  2.6 -1.4 -0.5 
  2.6 -1.4 -0.5  2.4  2.4 -1.3
  2.4  2.4 -1.3  2.4  2.4  1.3
  2.4  2.4  1.3  2.6 -1.4  0.5  
  2.6 -1.4  0.5 -0.9  0.5  1.5  
  2.6 -1.4  0.5  2.6 -1.4 -0.5
 -0.3  3.0  1.5  2.4  2.4  1.3
 -0.3  3.0 -1.5  2.4  2.4 -1.3
  10  
  60 60
  0.0  0.0  0.0  0.0 -8.0  0.0  
  11
  61  61
  0.0  0.0  0.0  0.0 -7.0  0.0  
  12
  62  67
  0.0  0.0  0.0 -0.5 -1.5  1.5
 -0.5 -1.5  1.5 -0.5 -1.5 -0.5
 -0.5 -1.5 -0.5  0.0  0.0  0.0
  0.0  0.0  0.0  3.0 -1.5  0.0
  3.0 -1.5  0.0 -0.5 -1.5  1.5
 -0.5 -1.5 -0.5  3.0 -1.5  0.0
  13
  68  68
  0.0  0.0  0.0  0.0 -8.0  0.0
  14
  69  69
  0.0  0.0  0.0  0.0 -7.0  0.0  
  15
  70  75
  0.0  0.0  0.0 -0.5 -1.5  0.5
 -0.5 -1.5  0.5 -0.5 -1.5 -1.5  
 -0.5 -1.5 -1.5  0.0  0.0  0.0  
  0.0  0.0  0.0  3.0 -1.5  0.0  
  3.0 -1.5  0.0 -0.5 -1.5 -1.5  
 -0.5 -1.5  0.5  3.0 -1.5  0.0  
  0
  1  0  2 10 13  0   0
  0.0  0.0  0.0
  2  1  3  6  9  0   0
  0.0  2.9  0.0
  3  2  4  0  0  0   0
  1.4  9.0  3.4
  4  3  5  0  0  0   0
  0.0 -6.5  0.0
  5  4  0  0  0  0   0
  0.0 -6.0  0.0
  6  2  7  0  0  0   0
  1.4  9.0 -3.4
  7  6  8  0  0  0   0
  0.0 -6.5  0.0  
  8  7  0  0  0  0   0
  0.0 -6.5  0.0
  9  2  0  0  0  0   0
  0.0  12.0  0.0
 10  1 11  0  0  0   0
  0.0  0.0  2.5
 11 10  12 0 0 0 0   0
  0.0 -8.0  0.0
 12 11  0  0  0  0   0
  0.0 -7.0  0.0
 13  1 14  0  0  0   0
  0.0  0.0 -2.5 
 14 13 15  0  0  0   0
  0.0 -8.0  0.0  
 15 14  0  0  0  0   0
  0.0 -7.0  0.0 
  0  0  0  0  0  0   0
[\].
CLOSE@CTE
	CALL COLM
	STOP
	END
[\].
COLM@@LST
0001	      SUBROUTINE COLM
0002	C**	SUBROUTINE TO DISPLAY COLUMNS
0003	        REAL COL(4,29),INC
0004	        INTEGER MODE,BEGIN,END,IVECT(500),FIRST
0005		INTEGER LAST,INT,ISPACE,FCN,TAG
0006		COMMON/LIMITS/ XMIN,XMAX,YMIN,YMAX
0007		COMMON/FRAME/ XA,XB,YA,YB
0008		COMMON/VECT/ IVECT,FIRST,LAST,TAG,MODE,BEGIN,END
0009	C**	COLUMN LINE DEFINITIONS
0010		COL(1,1)=2.8
0011		COL(2,1)=2
0012		COL(3,1)=19.3
0013		COL(4,1)=2
0014	C**
0015		DO 10 I=2,13
0016		COL(1,I)=2.8+1.5*(I-2)
0017		COL(2,I)=2
0018		COL(3,I)=2.8+1.5*(I-2)
0019		COL(4,I)=18
0020	 10	CONTINUE
0021	C**
0022		DO 20 I=14,29
0023		INC=0
0024		IF ((I.EQ.17).OR.(I.EQ.21).OR.(I.EQ.25).OR.(I.EQ.29))  INC=.1
0025		COL(1,I)=10.2-INC
0026		COL(2,I)=2+(I-13)
0027		COL(3,I)=10.4+INC
0028		COL(4,I)=2+(I-13)
0029	 20	CONTINUE
0030		CALL VECTOR(1,COL,1,29,IVECT,1,LAST,4,1,.FALSE.)
0031		CALL DSPLAY (3,99,IERR)
0032		CALL DSPLAY (6,99,IERR,IVECT,1,LAST)
0033		RETURN
0034		END
[\].
COLM@@SRC
      SUBROUTINE COLM
C**	SUBROUTINE TO DISPLAY COLUMNS
        REAL ARR(4,32),INC
C	REAL XMIN,XMAX,YMIN,YMAX
C	REAL XA,XB,YA,YB
C
        INTEGER FIRST,LAST,TAG,MODE,BEGIN,END,IVECT(400)
	INTEGER INT,ISPACE,FCN
C
	COMMON/VECT/ FIRST,LAST,TAG,MODE,BEGIN,END,IVECT
	COMMON/LIMITS/ XMIN,XMAX,YMIN,YMAX
	COMMON/FRAME/ XA,XB,YA,YB
C
C**	COLUMN LINE DEFINITIONS
	IOT=4
	ARR(1,1)=2.8
	ARR(2,1)=2
	ARR(3,1)=19.3
	ARR(4,1)=2
C**
	DO 10 I=2,13
	ARR(1,I)=2.8+1.5*(I-2)
	ARR(2,I)=2
	ARR(3,I)=2.8+1.5*(I-2)
	ARR(4,I)=18
 10	CONTINUE
C**
	DO 20 I=14,29
	INC=0
	IF ((I.EQ.17).OR.(I.EQ.21).OR.(I.EQ.25).OR.(I.EQ.29))  INC=.1
	ARR(1,I)=10.2-INC
	ARR(2,I)=2+(I-13)
	ARR(3,I)=10.4+INC
	ARR(4,I)=2+(I-13)
 20	CONTINUE
C 
	CALL VECTOR (1,ARR,1,29,IVECT,1,LAST,7,1,.FALSE.)
	CALL DSPLAY (3,51,IERR)
	CALL DSPLAY (6,51,IERR,IVECT,1,LAST)
	RETURN
	END
[\].
CONVRTSRC
	SUBROUTINE RDCONV
C
C**     SUBROUTINE TO DETERMINE ROTATIONS ABOUT
C**	THE COORDINATE AXES FOR EACH OF 15 MODULES
C
	INTEGER A,B,C,D,E,F,R,S
	REAL AR(9)
	COMMON/SYMRSC/SYMRS(4,6),NM
	COMMON/SYMBOL/ A,B,C,D,E,F,BLEN,POS
	DATA AR/0.0,22.5,45.0,67.5,90.0,112.5,135.,157.5,180./
  114	CONTINUE
	DO 20 I=1,4
	DO 20 J=1,6
  20	SYMRS(I,J)=0.0
	R=J=1
	L=2
	M=3
	BETA=GAMA=EPSI=0.0
	A=A+1
	C=C+1
	D=D+1
  	WRITE(4,115)
  115   FORMAT (' ENTER DUMMY VALUES FOR A-F,BLEN,POS')
        READ(4,120) A,B,C,D,E,F,BLEN,POS
 120    FORMAT(6I2,2F8.2)
	IF(A.EQ.99) GO TO 210
C
C**	DETERMINE BODY PART
C
	GO TO (1,2,3,4,5,6,7,8,9,10,11,12),A
  1	CONTINUE
  6	CONTINUE
  7	GO TO 210
C
C**	DETERMINE HAND ROTATIONS
C
  2	SYMRS(J,1)=8
  11    IF(A.EQ.11) SYMRS(J,1)=5
	GO TO (41,42,43,43,45,45,47,47,47,47,92,92),C
  41	GO TO 210
  42    GO TO 990
  43	EPSI=AR(5)
	GAMA=(2*(C/4)-1)*AR(D+D/3)
	GO TO 990
  45	EPSI=AR(9)
	GAMA=(2*(C/6)-1)*AR(D+D/3)
	GO TO 990
  47	IF(C.EQ.8.OR.C.EQ.9) R=-1.0
	EPSI=R*AR(7)
	GAMA=(2*(C/8)-1)*AR(D+D/3)
	GO TO 990
	GO TO 990
C
C**	HEAD ROTATIONS
C
  12	SYMRS(J,1)= 9
  61	GO TO (62,62,64,64,65,65,67,67,67,67,72,72),C
  62	GO TO 980
  64	EPSI=(2*(C/4)-1)*AR(2*D-1)
	GO TO 980
  65	IF(C.LT.9.AND.C.NE.6) R=-1.0
	GAMA=R*AR(2*D-1)
	GO TO 980
  67	IF(C.EQ.8.OR.C.EQ.9) S=-1.0
	BETA=S*AR(3)
	GO TO 65
  72	BETA=(E-1)*AR(3)
	IF(C.EQ.12) BETA= -1.*BETA
	GO TO 980
C
C**	CHEST AND TORSO ROTATIONS
C
  3	SYMRS(J,1)= 1
  10	IF(A.EQ.10) SYMRS(J,1)= 2
	GO TO 61
C
C**	ARM ROTATIONS
C
  4	SYMRS(J,1)= 6
  9	IF(A.EQ.9) SYMRS(J,1)= 3
	IF(A.EQ.4) GO TO 940
C
C**	RIGHT ARM ROTATIONS
C
  960	GO TO (81,82,83,83,85,86,85,85,85,85,92,92),C
  81	GO TO 950
C
  82	IF(A.EQ.9.OR.A.EQ.4) GAMA=(2*(D/4)-1)*AR(5)
	IF(D.EQ.3) GAMA1=AR(9)
	IF(A.EQ.5.OR.A.EQ.8) GAMA=(D-3)*AR(5)
	GO TO 955
  83	EPSI=AR(2*D-1)
  831	BETA=(1-2*(C/4))*AR(5)
	GAMA=(D-3)*AR(3)
	GO TO 950
  85	GAMA=(D-3)*AR(3)
	EPSI=(1-C/8)*AR(5)
	IF(C.EQ.7) BETA=AR(3)
	IF(C.EQ.8) BETA=-AR(3)
	IF(C.EQ.9) BETA=AR(7)
	IF(C.EQ.10) BETA=-AR(7)
	GO TO 950
  86	GAMA=(1-2*(D/4))*AR(7+2*(D/3))
	EPSI=(1-C/8)*AR(5)
	GO TO 950
  92	EPSI=(E-1)*AR(3)
	IF(A.EQ.2) EPSI=-1.0*EPSI
	GO TO 950
C
C**	LEFT ARM ROTATIONS
C
  940	GO TO (101,102,103,103,85,86,85,85,86,86,111,112),C
  101	GO TO 950
  102	GO TO 82
  103	EPSI=-AR(2*D-1)
	GO TO 831
  111	CONTINUE
  112	GO TO 92
C
C**	LEG ROTATIONS
C
  5	SYMRS(J,1)=13
	GO TO 940
  8	SYMRS(J,1)=10
	GO TO 960
C
C**	FLEXION OF ARMS AND LEGS
C
  950	GAMA1=AR(1+F+F/4)
  955	IF(A.EQ.8.OR.A.EQ.5) GAMA1=-1.*GAMA1
C
C**	ASSIGN INFORMATION TO  RODAK FILE
C
	IF(A.EQ.4) SYMRS(L,1)= 7
	IF(A.EQ.5) SYMRS(L,1)= 14
	IF(A.EQ.8)  SYMRS(L,1)= 11
	IF(A.EQ.9) SYMRS(L,1)= 4
	SYMRS(L,6)= GAMA1
	GO TO 990
  980	IF(A.NE.3) GO TO 990
	SYMRS(L,6)=SYMRS(M,6)=-GAMA
	SYMRS(L,1)=10
	SYMRS(M,1)=13
  990	IF(A.EQ.2) EPSI= -1.0*EPSI
	SYMRS(J,2)=SYMRS(L,2)=SYMRS(M,2)=BLEN
	SYMRS(J,3)=SYMRS(L,3)=SYMRS(M,3)=POS
	SYMRS(J,4)= EPSI
	SYMRS(J,5)= BETA 
	SYMRS(J,6)= GAMA
        WRITE(4,) (SYMRS(J,I),I=1,6)
	IF(SYMRS(L,1).NE.0.0) WRITE(4,) (SYMRS(L,I),I=1,6)
	IF(SYMRS(M,1).NE.0.0) WRITE(4,) (SYMRS(M,I),I=1,6)
	GO TO 114
  210	RETURN
	END
[\].
COPEE@JOB
$JOB 20(010) COPEE JOB    SAVAGE
$UIC <GOM>
$PUP T 17 _ 19 TESTD SRC
$END
$JOB FLUSH
$END
[\].
COPY@@JOB
$JOB 20(003) COPY JOB
$UIC <GOM>
$PUP T 6 _ 17 TESTD SRC
$END
$JOB FLUSH
$END
[\].
CTEST@JOB
$JOB 21 T=5 UFD=RK1<G0M>
$MSG CTEST -CTEST TKB STEP
$DEL CTEST TSK
$DEL CTEST IMG
$TKB
SZ,UL:F4LIB}
CTEST}
350}
TDV.GR}
CTEST}
 }
$CON CTEST}
$END
[\].
CTEST@SRC
C	CTEST     *TEST TO GET BLOODY GRAPHICS WORKING!!!!!
        REAL ARR(4,4),INC
C
	INTEGER FIRST,LAST,TAG,MODE,BEGIN,END,IVECT(125)
	INTEGER INT,ISPACE,FCN
C
	COMMON/VECT/ FIRST,LAST,TAG,MODE,BEGIN,END,IVECT
	COMMON/LIMITS/ XMIN,XMAX,YMIN,YMAX
C
	XMIN=0.
	XMAX=20.
	YMIN=0.
	YMAX=20.
	IOP=6
	IOT=4
	FIRST=1
	TAG=1
	MODE=1
	BEGIN=1
	END=2
C
	CALL CLEAR(.TRUE.)
C**	COLUMN LINE DEFINITIONS
	ARR(1,1)=2.8
	ARR(2,1)=2
	ARR(3,1)=19.3
	ARR(4,1)=2
	ARR(1,2)=2.8
	ARR(2,2)=4
	ARR(3,2)=19.3
	ARR(4,2)=4
C**
C***********
CCALL DSPLAY(7,IGET,IERR)
CWRITE(IOP,) IGET,IERR
	CALL VECTOR (MODE,ARR,BEGIN,END,IVECT,FIRST,LAST,6,0,-1)
	WRITE(IOP,) LAST,IERR,ARR,IVECT(1),IVECT(2),IVECT(3)
	WRITE(IOP,) IVECT(4),IVECT(5),IVECT(6),IVECT(7),IVECT(8)
	WRITE(IOP,) IVECT(9),IVECT(10),IVECT(11),IVECT(12),IVECT(13)
	MODE=3
C	
CCALL DSPLAY (MODE,TAG,IERR)
CWRITE(IOT,) IERR
CMODE=6
CCALL DSPLAY (MODE,TAG,IERR,IVECT,FIRST,LAST)
	WRITE (IOT,10)
10	FORMAT (' ENTER :   FIRST,LAST')
	READ (IOT,) FIRST,LAST
	CALL DRAW (IVECT,FIRST,LAST)
	PAUSE 1
	WRITE(IOT,) IERR
C	RETURN
	STOP
	END
[\].
DANC1@SRC
999  1  0  0  0  0  0.000  0.000
[\].
DANC2@SRC
  2  0  3  1  0  0  1.000  0.000
  2  0  3  2  0  0  1.000  1.000
  2  0  3  3  0  0  1.000  2.000
  2  0  5  1  0  0  1.000  3.000
  2  0  5  2  0  0  1.000  4.000
  2  0  5  3  0  0  1.000  5.000
  2  0  7  1  0  0  1.000  6.000
  2  0  7  2  0  0  1.000  7.000
  2  0  7  3  0  0  1.000  8.000
  2  0  9  1  0  0  1.000  9.000
  2  0  9  2  0  0  1.000 10.000
  2  0  9  3  0  0  1.000 11.000
  2  0 11  1  0  0  1.000 12.000
  2  0 11  2  0  0  1.000 13.000
  2  0 11  3  0  0  1.000 14.000
  2  0 11  2  0  0  1.000 15.000
998  0  0  0  0  0  0.000  0.000
999  0  0  0  0  0  0.000  0.000
[\].
DANC3@SRC
998  1  4  0  0  0  0.000  0.000
  2  0  3  1  0  0  1.000  0.000
  2  0  3  2  0  0  1.000  1.000
  2  0  3  3  0  0  1.000  2.000
  2  0  5  3  0  0  1.000  3.000
998  2  4  0  0  0  0.000  0.000
  2  0  5  1  0  0  1.000  4.000
  2  0  5  2  0  0  1.250  5.000
  2  0  7  2  0  0  1.000  6.250
  2  0  7  1  0  0  1.000  7.250
998  3  1  0  0  0  0.000  0.000
  2  0  7  3  0  0  1.000  8.250
999  4  9  0  0  0  0.000  0.000
[\].
DANC4@SRC
998  1  4  0  0  0  0.000  0.000
  2  0  3  1  0  0  1.000  0.000
  2  0  3  2  0  0  1.000  1.000
999  4  9  0  0  0  0.000  0.000
[\].
DANC5@SRC
998  4 22  0  0  0  0.000  0.000
  2  0  4  2  0  0  0.500 00.000
  4  0  0  0  0  0  1.000 00.000
  5  0  1  2  0  0  1.000 00.000
  6  0  1  2  0  0  1.000 00.000
  7  0  0  0  0  0  3.000 00.000
  9  0  5  2  0  0  0.500 00.000
  2  0  3  1  0  0  0.500 00.500
  9  0  2  1  0  0  0.500 00.500
  2  0  4  2  0  0  1.000  1.000
  4  0  0  0  0  0  1.000  1.000
  5  0  0  2  0  0  2.000  1.000
  6  0  1  2  0  0  2.000  1.000
  9  0  5  2  0  0  1.000  1.000
  2  0  2  2  0  0  1.000  2.000
  4  0  2  3  0  0  0.500  2.000
  9  0  3  2  0  0  1.000  2.000
  4  0  3  2  0  0  0.500  2.500
  2  0  1  3  0  0  1.000  3.000
  5  0  1  2  0  0  1.000  3.000
  7  0  3  3  0  0  0.500  3.000
  9  0  1  3  0  0  1.000  3.000
  7  0  2  2  0  0  0.500  3.500
999  5 37  0  0  0  0.000  0.000
[\].
DANC6@SRC
998  1  2  0  0  0  0.000  0.000
  2  0  2  3  2  6  1.000  0.000
  4  0  4  2  0  0  1.000  0.000
999  2  2  0  0  0  0.000  0.000
998  1  4  0  0  0  0.000  0.000
  2  0  4  2  0  0  1.000  0.000
  2  0  9  2  0  0  1.000  1.000
  2  0  3  2  0  0  1.000  2.000
  2  0 11  2  0  0  1.000  3.000
998  2  4  0  0  0  0.000  0.000
  2  0  7  2  0  0  1.000  4.000
  2  0 10  2  0  0  1.000  5.000
  2  0  2  2  0  0  1.000  6.000
  2  0  8  2  0  0  1.000  7.000
998  3  1  0  0  0  0.000  0.000
  2  0  4  2  0  0  1.000  8.000
  2  0  4  2  0  0  1.000  9.000
999  4  9  0  0  0  0.000  0.000
[\].
DATA@@SRC
  350.  900.
  550.  575.
  200.  500.
  230.  275.
  250.  175.
  700.  900.
  260.  575.
  250.  500.
  410.  275.
  250.  175.
  350.  900.
  800.  575.
  500.  425.
  120.  275.
  250.  175.
  575.  175.
[\].
DIRECTJOB
$JOB 20(010) DIRECT  JOB  /MCDOUGALL
$UIC <GOM>
$PUP L 16 _  15
$JOB FLUSH
$END
[\].
DRAWITSRC
          SUBROUTINE DRAWIT(DIST,NEW,MODULE,IFUNC)
C		DRAWS CHARLIE IN 2D USING 3D INFO
	INTEGER NEW,MODULE,IFUNC
	REAL DIST
          COMMON/PAINT/I2STRT,I2END,PICT(4,100)
          COMMON/POINTS/LNS(2,15),PTS(6,100)
          COMMON/BULK/I3STRT,I3END,OBJ(6,100)
          COMMON/OIL/IVECT(400)
          COMMON/LIMITS/XMIN,XMAX,YMIN,YMAX
          MODL=MODULE
2	I2STRT=LNS(1,MODL)
	I2END=LNS(2,MODL)
	I3STRT=I2STRT
	I3END=I2END
          CALL MAPPER(DIST)
          CALL VECTOR(1,PICT,I2STRT,I2END,IVECT,1,LAST,6,0,-1)
	CALL DSPLAY(3,MODL,IER)
	CALL DSPLAY(IFUNC,MODL,IER,IVECT,1,LAST)
          CALL NEXT(MODL,MODULE)
	IF (MODULE.NE.MODL) GOTO 2
	RETURN
          END
[\].
EDITD@SRC
	SUBROUTINE EDITD
C****** EDITS DANCE FILES FOR SYM ADDS,DELS,CHANGES
C****** NOT CODED YET
	RETURN
	END
[\].
ERASE@SRC
C******  SUBROUTINE TO ERASE SYMBOLS FROM SCREEN
	SUBROUTINE ERASE
	CALL DSPLAY (8,IGET,IERR)
	RETURN
	END
[\].
FILMODSRC
C         SUBROUTINE TO FILL OBJ
C
          SUBROUTINE FILMOD(INMOD)
          COMMON/PROD/PAC(3,3,15)
          COMMON/SUMIT/PSUM(3,16,5)
          COMMON/POINTS/LNS(2,15),PTS(6,100)
          COMMON/BULK/I3STRT,I3END,OBJ(6,100)
          COMMON/LINKIT/ISTRT,LINKS(6,15)
          MODULE=INMOD
          INDEX=2
2         IMOD=LINKS(1,MODULE)
          CALL PRTPRD(IMOD,MODULE)
          CALL PRTSUM(IMOD,MODULE)
          IF(IMOD.EQ.0)IMOD=16
          I3STRT=LNS(1,MODULE)
          I3END=LNS(2,MODULE)
          DO 69 K=I3STRT,I3END
          DO 69 I=1,3
          SUM=0.
          DO 68 L=1,3
68        SUM=PAC(I,L,MODULE)*PTS(L,K)+SUM
69        OBJ(I,K)=SUM
          DO 79 K=I3STRT,I3END
          DO 79 I=1,3
          SUM=0.
          II=I+3
          DO 78 L=1,3
78        SUM=PAC(I,L,MODULE)*PTS(L+3,K)+SUM
79        OBJ(II,K)=SUM
          IF(IMOD.EQ.16)GO TO 12
          I=1
10        I=I+1
          INSON=LINKS(I,IMOD)
          IF(INSON.NE.MODULE)GO TO 10
          INSON=I-1
          GO TO 13
12        INSON=1
13        DO 96 K=I3STRT,I3END
          DO 96 I=1,6
          II=I
          IF(I.GT.3)II=I-3
96        OBJ(I,K)=OBJ(I,K)+PSUM(II,IMOD,INSON)
          CALL NEXT(MODULE,INMOD)
          IF(MODULE.EQ.INMOD)GO TO 99
          GO TO 2
C		WRITE (6,) RAC,PAC,PSUM
99        RETURN
          END
[\].
FLUSH1JOB
$JOB 20(050)  FLUSH1 JOB / MCDOUGALL
$UIC <GOM>
$END
$JOB FLUSH
$END
[\].
FLXDANSRC
  2  0  1  0  0  0  0.000  0.000
  2  0  1  1  0  1  1.000  1.000
  2  0  1  0  0  0  1.000  2.000
  2  0  1  0  0  3  1.000  3.000
  2  0  1  0  0  0  1.000  4.000
  2  0  1  0  0  5  1.000  5.000
  2  0  1  0  0  0  1.000  6.000
  2  0  1  0  0  3  1.000  7.000
  2  0  1  0  0  0  1.000  8.000
  2  0  1  0  0  6  1.000  9.000
  2  0  1  0  0  6  1.000 10.000
999  0  0  0  0  0  0.000  0.000
[\].
INCREMSRC
C    SUBROUTINE INCREM 
	REAL AX,AY,AZ,FRTIM,ROT(15,3),GUANO(15,10),LEN
	REAL POS,THY,THX,THZ,FPBT,TMPO
	INTEGER FL,OUTLU
	DATA FRTIM,II/0.0,1/
	DATA GUANO,ROT/150*0.0,45*0.0/
	OUTLU=4
	WRITE(OUTLU,19)
  19    FORMAT(' ENTER TEMPO')
	READ(OUTLU,)TMPO
	FPBT=1440/TMPO
	MINDUR=0
	WRITE(OUTLU,3133)
 3133   FORMAT(' FILE LENGTH')
	READ(OUTLU,)FL
   1    WRITE(OUTLU,13)
13      FORMAT(' ENTER M POS LEN X Y Z')
       IF(II.GT.FL)GO TO 8
	MINDUR=4
	READ(OUTLU,)M,POS,LEN,THX,THY,THZ
	II=II+1
	FRML=LEN*FPBT
	FRMP=POS*FPBT
	WRITE(OUTLU,)M,POS,LEN,THX,THY,THZ,FRML,FRMP,FRTIM
	WRITE(OUTLU,)MINDUR
  101   FORMAT(10F6.2)
C
C   UPDATE LINES IN GUANO WHERE SYMBOLS START
C
  2	IF(FRTIM.LT.FRMP) GO TO 3
C
	GUANO(M,5)=GUANO(M,2)
	GUANO(M,6)=GUANO(M,3)
	GUANO(M,7)=GUANO(M,4)
	GO TO 44
	IF(THY.EQ.0.0)GO TO 11
	IF(THY.EQ.90.0)GO TO 22
	GO TO 44
  11    IF(THZ.EQ.90.0)GUANO(M,9)=0.0
	GO TO 33
   22   IF(THZ.NE.0.0)GO TO 44
	GUANO(M,9)=0.0
	GO TO 33
   44   GUANO(M,2)=THX
	GUANO(M,3)=THY
	GUANO(M,4)=THZ
	GUANO(M,9)=(GUANO(M,3)-GUANO(M,6))/FRML
  33    GUANO(M,8)=(GUANO(M,2)-GUANO(M,5))/FRML
	GUANO(M,10)=(GUANO(M,4)-GUANO(M,7))/FRML
	GUANO(M,1)=GUANO(M,1)+FRML
	MINDUR=MIN0(MINDUR,INT(GUANO(M,1)))
	GO TO 1
  3     WRITE(OUTLU,69)((GUANO(LL,KK),KK=1,10),LL=1,15)
  69    FORMAT(10F6.2)
C
C    UPDATE LINES IN GUANO WHERE SYMBOLS CONTINUE
C
        DO 5 MD=1,15
	IF(FRTIM.LT.GUANO(MD,1))GO TO 4
C
C   UPDATE LINES IN GUANO WHERE RESTS START
C
	GUANO(MD,5)=GUANO(MD,2)
	GUANO(MD,6)=GUANO(MD,3)
	GUANO(MD,7)=GUANO(MD,4)
	GUANO(MD,8)=0.
	GUANO(MD,9)=0.
	GUANO(MD,10)=0.
	GUANO(MD,1)=GUANO(MD,1)+MINDUR
     	GO TO 5
C     RESET STARTING TIMES
  4     GUANO(MD,5)=GUANO(MD,5)+GUANO(MD,8)*MINDUR
	GUANO(MD,6)=GUANO(MD,6)+GUANO(MD,9)*MINDUR
	GUANO(MD,7)=GUANO(MD,7)+GUANO(MD,10)*MINDUR
  5	CONTINUE
	WRITE(OUTLU,69)((GUANO(LLL,KKK),KKK=1,10),LLL=1,15)
C   
C   DO FOR MINDUR FRAMES
C
	DO 7 L=1,MINDUR
C
C   FOR EACH FRAME INCREMENT THE 15 MODULES
C
	DO 6 MOD=1,15
	AX=GUANO(MOD,5)+GUANO(MOD,8)*L
	AY=GUANO(MOD,6)+GUANO(MOD,9)*L
	AZ=GUANO(MOD,7)+GUANO(MOD,10)*L
	CALL ROTATE(AX,0.,0.,MOD)
	CALL ROTATE(0.,AY,0.,MOD)
	CALL ROTATE(0.,0.,AZ,MOD)
C
C   FILL UP ROT WITH ABSOLUTE MODULE ORIENTATIONS
C
	GO TO(10,20,30,40,50,30,60,70,30,20,80,
     @90,20,100,110),MOD
C
C   HIPS (1)
C
   10	ROT(1,1)=AX
	ROT(1,2)=AY
	ROT(1,3)=AZ
	GO TO 6
C
C   TORSO,UPPER RIGHT LEG,UPPER LEFT LEG
C   (  2         10             13       )
C
  20	ROT(MOD,1)=ROT(1,1)+AX
	ROT(MOD,2)=ROT(1,2)+AY
	ROT(MOD,3)=ROT(1,3)+AZ
	GO TO 6
C
C   UPPER RIGHT ARMD,UPPER LEFT ARMD,HEAD
C   (     3               6          9  )
C
  30	ROT(MOD,1)=ROT(2,1)+AX
	ROT(MOD,2)=ROT(2,2)+AY
	ROT(MOD,3)=ROT(2,3)+AZ
	GO TO 6
C
C   LOWER ARM (4)
C
  40	ROT(MOD,1)=ROT(3,1)+AX
	ROT(MOD,2)=ROT(3,2)+AY
	ROT(MOD,3)=ROT(3,3)+AZ
	GO TO 6
C
C   LEFT HAND (5)
C
  50	ROT(MOD,1)=ROT(4,1)+AX
	ROT(MOD,2)=ROT(4,2)+AY
	ROT(MOD,3)=ROT(4,3)+AZ
	GO TO 6
C
C   LOWER LEFT ARM (7)
C
  60    ROT(MOD,1)=ROT(6,1)+AX
	ROT(MOD,2)=ROT(6,2)+AY
	ROT(MOD,3)=ROT(6,3)+AZ
	GO TO 6
C
C   RIGHT HAND (8)
C
  70    ROT(MOD,1)=ROT(7,1)+AX
	ROT(MOD,2)=ROT(7,2)+AY
	ROT(MOD,3)=ROT(7,3)+AZ
	GO TO 6
C
C   LOWER RIGHT LEG (10)
C
  80    ROT(MOD,1)=ROT(10,1)+AX
	ROT(MOD,2)=ROT(10,2)+AY
	ROT(MOD,3)=ROT(10,3)+AZ
	GO TO 6
C
C   RIGHT FOOT (12)
C
  90	ROT(MOD,1)=ROT(11,1)+AX
	ROT(MOD,2)=ROT(11,2)+AY
	ROT(MOD,3)=ROT(11,3)+AZ
	GO TO 6
C
C   LOWER LEFT LEG (14)
C
  100	ROT(MOD,1)=ROT(13,1)+AX
	ROT(MOD,2)=ROT(13,2)+AY
	ROT(MOD,3)=ROT(13,3)+AZ
	GO TO 6
C
C  LEFT FOOT (15)
C
  110	ROT(MOD,1)=ROT(14,1)+AX
	ROT(MOD,2)=ROT(14,2)+AY
	ROT(MOD,3)=ROT(14,3)+AZ
  6     CONTINUE
   99   FORMAT(3F7.3)
C
C   BUILD AND DISPLAY MODULES FOR THIS FRAME
C
 111    FORMAT(10F6.2)
  7	CONTINUE
	WRITE(OUTLU,99)((ROT(NN,JJ),JJ=1,3),NN=1,15)
	FRTIM=FRTIM+MINDUR
	GO TO 2
  8	CONTINUE
	STOP
	END
C    
      
           
[\].
INITL@SRC
	SUBROUTINE INITL(NEW)
C     		SUBROUTINE TO INITIALIZE LINKS AND RAC
C		AFTER EACH FRAME
C  		NEW = 1 ZERO LINKS AND RAC; NEW = 0 ZERO RAC ONLY.
          COMMON/LINKIT/ISTRT,LINKS(6,15)
          COMMON/ACCUM/RAC(3,3,15)
C
C		CHANGE LINK INFO IF SUPPORT CHANGES?
      IF(NEW.NE.1)GO TO 50
          DO 96 I=1,15
          DO 96 J=1,6
96        LINKS(J,I)=0
C
C		INIT RAC (LOCAL FRAME ROTATIONS)
50    CONTINUE
      DO 69 I=1,15
          DO 69 J=1,3
          DO 69 K=1,3
          RAC(K,J,I)=0.
          IF(K.EQ.J)RAC(K,J,I)=1.
69        CONTINUE
          RETURN
          END
[\].
INPUTSSRC
	SUBROUTINE INPUTS
C		 READS MOD,LINK INFO FROM CHRMN SRC
	REAL PTS,PSUM,C
	INTEGER MOD,IST,IEN
	INTEGER PARENT,SON1,SON2,SON3,SON4,SON5
	COMMON/IOLU/ IOT,IOP
	COMMON/POINTS/LNS(2,15),PTS(6,100)
	COMMON/CENTS/C(3,15)
	COMMON/LINKIT/ISTRT,LINKS(6,15)
	COMMON/SUMIT/PSUM(3,16,5)
C		MODULE INFO ARRAYS:
C			PTS-      ENDPTS OF EACH LINE IN EACH MODULE
C			LNS-      STRT & END LINES FOR EACH MODULE
	CALL SEEK(17,5HCHRMN,3HSRC,IEV)
4       READ(17,) MOD
	IF (MOD.EQ.0) GOTO 5
	READ (17,) IST,IEN
	LNS(1,MOD)=IST
	LNS(2,MOD)=IEN
	READ(17,)((PTS(J,K),J=1,6),K=IST,IEN)
	GOTO 4
C		LINK INFO
5	READ (17,) MOD,PARENT,SON1,SON2,SON3,SON4,SON5
	IF (MOD.EQ.0) GOTO 99
	LINKS(1,MOD)=PARENT
	LINKS(2,MOD)=SON1
	LINKS(3,MOD)=SON2
	LINKS(4,MOD)=SON3
	LINKS(5,MOD)=SON4
	LINKS(6,MOD)=SON5
	READ(17,)(C(J,MOD),J=1,3)
	IF (PARENT.NE.0) GOTO 5
	DO 11 I=1,3
11	PSUM(I,16,1)=C(I,MOD)
	GOTO 5
99	CALL CLOSE(17)
C		WRITE(IOP,) LINKS,LNS,PTS,PSUM,C
	RETURN
	END
[\].
LOAD@@JOB
$JOB 20(002) 'LOAD'
$UIC <GOM>
$PUP T 15 _ 19 13MY77 BKS
$END
[\].
MAIN@@SRC
C	MAINLINE TO TEST SUBROUTINES
	CALL ???
	STOP
	END
[\].
MOVINCSRC
	SUBROUTINE MOVINC(DIST,NEW)
C		FOR EACH FRAME -ROTATE MODULES & DISPLAY CHARLIE
C
	INTEGER FRMTIM,FDURN
	REAL LRPY
C
	COMMON/IOLU/ IOT,IOP,IOD
	COMMON/EYCEP/EYE(3),CEN(3),UP(3)
	COMMON/LINKIT/ ISTRT,LINKS(6,15)
	COMMON/LIMITS/XMIN,XMAX,YMIN,YMAX
	COMMON/LRPYC/LRPY(6,15),LFRM
C***********************************************************************
C		BUILD & DISPLAY LFRM FRAMES
	DO 1250 IFRM=1,LFRM
C		FOR THIS FRAME ...
	CALL INITL(0)
	DO 1240 M=1,15
C		FOR THIS MODULE ...
C		ROTATE MODULE M 
	AX=LRPY(1,M)+IFRM*LRPY(4,M)
	AY=LRPY(2,M)+IFRM*LRPY(5,M)
	AZ=LRPY(3,M)+IFRM*LRPY(6,M)
C
C		WRITE(IOT,) AZ,AY,AX
	CALL ROTATE(AY,AZ,AX,M)
C
C		TRANSLATE MODULE M (JUMP)
	IF ((JUMP.EQ.0).AND.(M.NE.1)) GOTO 1240
	DX = 1
	DY = 1
	DZ = 1
C	CALL TRANS(DX,DY,DZ)
1240	CONTINUE
C		BUILD, DISPLAY & STORE FRAME
	CALL FILMOD(1)
	CALL DRAWIT(DIST,0,1,6)
C	CALL PULSE(ID,IF)
1250	CONTINUE
C******************************************************************
	RETURN
	END
[\].
NEXT@@SRC
          SUBROUTINE NEXT(MOD,INMOD)
C		PICKS OUT NEXT MODULE TO BE PROCESSED
          COMMON/LINKIT/ISTRT,LINKS(6,15)
C
          INDEX=2
100       MOD1=LINKS(INDEX,MOD)
          IF(MOD1.EQ.0)GO TO 102
          MOD=MOD1
          GO TO 2
102       IF(INDEX.GE.6)GO TO 101
          INDEX=INDEX+1
          GO TO 100
101       IF(MOD.EQ.INMOD)GO TO 2
          IPAR=LINKS(1,MOD)
          INDEX=1
104       INDEX=INDEX+1
          ITEST=LINKS(INDEX,IPAR)
          IF(ITEST.EQ.MOD)GO TO 103
          GO TO 104
103       MOD=IPAR
          GO TO 102
2         RETURN
          END
[\].
NORMALSRC
	SUBROUTINE NORMAL(DIST,NEW)
C		READ IN MOD, LINK INFO & NORMALIZE CHARLIE
	COMMON/LINKIT/ISTRT,LINKS(6,15)
	COMMON/BULK/I3STRT,I3END,OBJ(6,100)
C		ZERO OUT LINKS & RAC ARRAYS
	CALL INITL(NEW)
C		READ IN MODULE & LINK INFO FOR CHARLIE, HIPS ARE BASE MODULE
	CALL INPUTS
	ISTRT=1
	IFUNC=6
C*************
10	CONTINUE
	WRITE(4,11)
11	FORMAT(' Y Z X M')
	READ(4,) Z,Y,X,M
	IF (Z.EQ.999.) GOTO 999
	CALL ROTATE(Z,Y,X,M)
	GOTO 30
C		NORMALIZE HANDS,FEET
	CALL ROTATE(90.0,0.,0.,5)
	CALL ROTATE(-90.0,0.,0.,8)
	CALL ROTATE(0.,0.,90.0,12)
	CALL ROTATE(0.,0.,90.0,15)
C		HEAD
C		TORSO
C		L ARM
	CALL ROTATE(0.,0.,-90.0,6)
C		R ARM
	CALL ROTATE(0.,0.,-90.0,3)
C		L LEG
	CALL ROTATE(0.,0.,-90.0,13)
C		R LEG
	CALL ROTATE(0.,0.,-90.0,10)
C		BODY
	CALL ROTATE(0.,90.0,0.,1)
C 		CONTRUCT POSITION & RECORD
30	CONTINUE
	CALL FILMOD(ISTRT)
	CALL DRAWIT(DIST,NEW,ISTRT,IFUNC)
C	CALL PULSE(ID,IF)
	GOTO 10
C999	WRITE(6,) ((OBJ(I,J),I=1,6),J=1,80)
999	CONTINUE
	RETURN
	END
[\].
OCHRMNSRC
  1
   1  13
 -0.5 -1.0  1.5  2.5  0.0  2.0
  2.5  0.0  2.0  2.5  1.5  2.5
  2.5  1.5  2.5  2.5  1.5 -2.5
  2.5  1.5 -2.5  2.5  0.0 -2.0
  2.5  0.0 -2.0 -0.5 -1.0 -1.5
 -0.5 -1.0 -1.5 -1.5  1.5 -2.0
 -1.5  1.5 -2.0 -0.5  2.3 -1.8
 -0.5  2.3 -1.8 -0.5  2.3  1.8
 -0.5  2.3  1.8 -1.5  1.5  2.0
 -1.5  1.5  2.0 -0.5 -1.0  1.5
 -0.5 -1.0  1.5 -0.5 -1.0 -1.5
  2.5  1.5 -2.5 -0.5  2.3 -1.8
 -0.5  2.3  1.8  2.5  1.5  2.5
  2
  14  35
  0.5  1.0  2.0  0.0  5.0  2.5
  0.0  5.0  2.5  2.0  8.0  1.5
  2.0  8.0  1.5  2.0  8.0 -1.5
  2.0  8.0 -1.5  0.0  5.0 -2.5  
  0.0  5.0 -2.5  0.5  1.0 -2.0
  0.5  1.0 -2.0  2.5  4.5 -0.5
  2.5  4.5 -0.5  2.5  4.5  0.5
  2.5  4.5  0.5  0.5  1.0  2.0
  0.5  1.0  2.0 -0.5  1.0  1.0
 -0.5  1.0  1.0 -1.5  6.0  2.5
 -1.5  6.0  2.5  0.5  9.0  2.0
  0.5  9.0  2.0  0.5  9.0 -2.0
  0.5  9.0 -2.0 -1.5  6.0 -2.5
 -1.5  6.0 -2.5 -0.5  1.0 -1.0
 -0.5  1.0 -1.0  0.5  1.0 -2.0
 -0.5  1.0  1.0 -0.5  1.0 -1.0
  0.0  5.0  2.5 -1.5  6.0  2.5
  0.0  5.0 -2.5 -1.5  6.0 -2.5
  0.5  9.0  2.0  2.0  8.0  1.5
  2.0  8.0  1.5  2.5  4.5  0.5
  2.5  4.5 -0.5  2.0  8.0 -1.5
  2.0  8.0 -1.5  0.5  9.0 -2.0
  3
  36  36
  0.0  0.0  0.0  6.4  0.0  0.0 
  4
  37  37
  0.0  0.0  0.0  6.0  0.0  0.0
  5
  38  42
  0.0  0.0  0.0  2.5  0.0  1.0
  0.0  0.0  0.0  1.8  0.0 -0.8
  1.8  0.0 -0.8  1.8  0.0 -0.3
  2.5  0.0  1.0  2.5  0.0 -0.2
  2.5  0.0 -0.2  1.2  0.0 -0.2
  6
  42  42
  0.0  0.0  0.0  6.4  0.0  0.0  
  7
  43  43
  0.0  0.0  0.0  6.0  0.0  0.0  
  8
  44  48
  2.5  0.0  0.2  1.2  0.0  0.2
  0.0  0.0  0.0  2.5  0.0 -1.0
  0.0  0.0  0.0  1.8  0.0  0.8
  1.8  0.0  0.8  1.8  0.0  0.3
  2.5  0.0 -1.0  2.5  0.0  0.2
  9 
  49 59
 -0.9  0.5  1.5 -0.3  3.0  1.5  
 -0.3  3.0  1.5 -0.3  3.0 -1.5
 -0.3  3.0 -1.5 -0.9  0.5 -1.5
 -0.9  0.5 -1.5  2.6 -1.4 -0.5 
  2.6 -1.4 -0.5  2.4  2.4 -1.3
  2.4  2.4 -1.3  2.4  2.4  1.3
  2.4  2.4  1.3  2.6 -1.4  0.5  
  2.6 -1.4  0.5 -0.9  0.5  1.5  
  2.6 -1.4  0.5  2.6 -1.4 -0.5
 -0.3  3.0  1.5  2.4  2.4  1.3
 -0.3  3.0 -1.5  2.4  2.4 -1.3
  10  
  60 60
  0.0  0.0  0.0  8.0  0.0  0.0  
  11
  61  61
  0.0  0.0  0.0  7.0  0.0  0.0  
  12
  62  67
  0.0  0.0  0.0 -0.5 -1.5  1.5
 -0.5 -1.5  1.5 -0.5 -1.5 -0.5
 -0.5 -1.5 -0.5  0.0  0.0  0.0
  0.0  0.0  0.0  3.0 -1.5  0.0
  3.0 -1.5  0.0 -0.5 -1.5  1.5
 -0.5 -1.5 -0.5  3.0 -1.5  0.0
  13
  68  68
  0.0  0.0  0.0  8.0  0.0  0.0
  14
  69  69
  0.0  0.0  0.0  7.0  0.0  0.0  
  15
  70  75
  0.0  0.0  0.0 -0.5 -1.5  0.5
 -0.5 -1.5  0.5 -0.5 -1.5 -1.5  
 -0.5 -1.5 -1.5  0.0  0.0  0.0  
  0.0  0.0  0.0  3.0 -1.5  0.0  
  3.0 -1.5  0.0 -0.5 -1.5 -1.5  
 -0.5 -1.5  0.5  3.0 -1.5  0.0  
  0
  1  0  2 10 13  0   0
  0.0  0.0  0.0
  2  1  3  6  9  0   0
  0.0  2.9  0.0
  3  2  4  0  0  0   0
  1.4  9.0  3.4
  4  3  5  0  0  0   0
  6.5  0.0  0.0
  5  4  0  0  0  0   0
  6.0  0.0  0.0
  6  2  7  0  0  0   0
  1.4  9.0 -3.4
  7  6  8  0  0  0   0
  6.5  0.0  0.0  
  8  7  0  0  0  0   0
  6.0  0.0  0.0
  9  2  0  0  0  0   0
  0.0  12.0  0.0
 10  1 11  0  0  0   0
  0.0  0.0  2.5
 11 10  12 0 0 0 0   0
  8.0  0.0  0.0
 12 11  0  0  0  0   0
  7.0  0.0  0.0
 13  1 14  0  0  0   0
  0.0  0.0 -2.5 
 14 13 15  0  0  0   0
  8.0  0.0  0.0  
 15 14  0  0  0  0   0
  7.0  0.0  0.0 
  0  0  0  0  0  0   0
[\].
ODRAWISRC
C         SUBROUTINE TO DRAW STRUCTURE
          SUBROUTINE DRAWIT(DIST,NEW,MODULE,IFUNC)
          COMMON/PAINT/I2STRT,I2END,PICT(4,100)
          COMMON/POINTS/LNS(2,15),PTS(6,100)
          COMMON/BULK/I3STRT,I3END,OBJ(6,100)
          COMMON/OIL/IVECT(300)
          COMMON/LIMITS/XMIN,XMAX,YMIN,YMAX
          COMMON/EYCEP/EYE(3),CEN(3),UP(3)
          COMMON/LINKIT/ISTRT,LINKS(6,15)
          MODL=MODULE
          IF(NEW.EQ.2)GO TO 3
          IF(NEW.EQ.1)GO TO 1
3         MOD=MODULE
9      CALL DSPLAY(3,MOD,IER)
          CALL NEXT(MOD,MODULE)
          IF(MOD.EQ.MODULE)GO TO 4
          GO TO 9
4         IF(NEW.NE.2)GO TO 2
1         CALL ROTER
2         I2STRT=LNS(1,MODL)
          I2END=LNS(2,MODL)
          I3STRT=I2STRT
          I3END=I2END
          CALL MAPPER(DIST)
          CALL VECTOR(1,PICT,I2STRT,I2END,IVECT,1,LAST,6,0,-1)
      CALL DSPLAY(IFUNC,MODL,IER,IVECT,1,LAST)
          CALL NEXT(MODL,MODULE)
          IF(MODL.EQ.MODULE)GO TO 5
          GO TO 2
5         NEW=0
          RETURN
          END
[\].
OPEN@@COM
CLOSE
OPEN 
[\].
PHASE2SRC
C	SUBROUTINE PHASE2
C		PHASE2 (ANIMATION PHASE) FOR CHOREO INTERACTIVE DANCE FACILITY
C		** G.A. MCDOUGALL **
C		 READS SYMBOL FILE, GETS MODULE ANGLES, UPDATES LRPY ARRAY
C
	INTEGER FRMTIM,FTIM,FDUR,FTIMN,FDURN
	INTEGER NFRMS(15)
	REAL LRPY
C
	COMMON/LRPYC/LRPY(6,15),LFRM
	COMMON/SYMRS0/SYMRS(4,4),NM,FDUR,FTIM
	COMMON/SYMRS1/SYMRSN(4,4),NMN,FDURN,FTIMN
	COMMON/IOLU/ IOT,IOP,IOD
	COMMON/EYCEP/EYE(3),CEN(3),UP(3)
	COMMON/LINKIT/ ISTRT,LINKS(6,15)
	COMMON/LIMITS/XMIN,XMAX,YMIN,YMAX
C******************************************************************
C		TERMINAL & PRINTER LUN'S
	IOT=4
	IOP=6
	IOD=17
C		SET UP VIEWING PARAMETERS
C		"ENTER VIEW DESIRED -FRONT,TOP,SIDE"
	XMIN=-30.
	XMAX=30.
	YMIN=-30.
	YMAX=30.
	EYE(1)=0.
	EYE(2)=0.
	EYE(3)=60.
	CEN(1)=0.
	CEN(2)=0.
	CEN(3)=0.
	UP(1)=0.
	UP(2)=10.
	UP(3)=0.
	CALL CLEAR(.TRUE.)
C*****************************************************************
	DIST=60.
	NEW=1
C		READ IN MOD & LINK INFO, NORMALIZE CHARLIE & DISPLAY HIM
	CALL NORMAL(DIST,NEW)
C		INIT LOCAL ROLL, PITCH, YAW ROTATIONS FOR EACH MODULE
        DO 21 M=1,15
	DO 21 L=1,6
	NFRMS(M)=0
21      LRPY(L,M)=0.
C		READ IN TEMPO (IN BEATS/MIN) AND INIT VARS
	WRITE(IOT,19)
 19     FORMAT(' ENTER TEMPO')
	READ(IOT,)TMPO
	FPBT=1440./TMPO
C		INIT PARAMETERS
	JUMP=0
	FRMTIM=0
	LFRM=0
C
	WRITE (IOT,) TMPO,FPBT,FRMTIM,LFRM
	GOTO 12
C***************************************************************************
C		FOR ALL MODULES -UPDATE START ANGS, INCREM ANGS& REMAINING FRAMES
2	CONTINUE
	DO 11 M=1,15
C		IF NO RECENT MOD MOVMENT -DO NEXT MOD
	IF (NFRMS(M) .EQ. 0) GOTO 11
C		UPDATE START POSITION ANGLES
	LRPY(1,M)=LRPY(1,M)+LFRM*LRPY(4,M)
	LRPY(2,M)=LRPY(2,M)+LFRM*LRPY(5,M)
	LRPY(3,M)=LRPY(3,M)+LFRM*LRPY(6,M)
C		UPDATE # OF REMAINING FRAMES
	NFRMS(M)=NFRMS(M)-LFRM
C		IF MOVEMENT HAS ENDED  -SET INCR ROTS TO ZERO
	IF (NFRMS(M) .NE. 0) GOTO 11
	LRPY(4,M)=0.
	LRPY(5,M)=0.
	LRPY(6,M)=0.
11 	CONTINUE
	WRITE (IOP,) NFRMS
	WRITE (IOP,) (LRPY(I,1),I=1,6)
C****************************************************************
C		CONTINUE WITH LAST (OLD)  SYMBOL READ IN LAST TIME
C		SET INCREMENTAL ANGLES FOR NEW MOVEMENT
14	CONTINUE
C		UPDATE SYMRS
	DO 60 I=1,NMN
	DO 60 J=1,4
60	SYMRS(I,J)=SYMRSN(I,J)
	FTIM=FTIMN
	FDUR=FDURN
	NM=NMN
C
	DO 15 I=1,NM
	MOD=IFIX(SYMRS(I,1))
	NFRMS(MOD)=FDUR
C
	LRPY(4,MOD)=(SYMRS(I,2)-LRPY(1,MOD))/FDUR
	LRPY(5,MOD)=(SYMRS(I,3)-LRPY(2,MOD))/FDUR
	LRPY(6,MOD)=(SYMRS(I,4)-LRPY(3,MOD))/FDUR
15	CONTINUE
C*****************************************************************
C		READ SYMBOL FILE & CONVERT TO ANGLES FOR 1-4 MODULES
C		PROCESS ONLY THOSE SYMBOLS WHICH START AT FRAMTIM
12	CONTINUE
	CALL RDCONV(FPBT)
C**********************
	WRITE(IOP,)FRMTIM,FTIM,FDUR,NFRMS,SYMRS
	WRITE(IOP,) FTIMN,FDURN,NMN,SYMRSN
C
C		END OF DANCE???
	IF (FTIMN .LT.0) GOTO 999
C		IF SYMBOL STARTS AFTER FRMTIM  LEAVE IT FOR NEXT RETURN
C		   & PROCESS PREVIOUS SYMBOLS
	IF (FTIMN .LE. FRMTIM) GOTO 14
C*****************************************************************
C		LFRM = #FRAMES TO BE PROCESSED IN MOVINC
C		     = MIN (NON 0) VALU OF NFRAMES
C
100	NLOW=1000
	DO 101 M=1,15
	LOW=NFRMS(M)
	IF (LOW .EQ. 0) GOTO 101
	IF (NLOW .GT. LOW) NLOW=LOW
101 	CONTINUE
	LFRM=NLOW
C************************************************************
C		DISPLAY CHARLIE FOR LFRM FRAMES
	CALL MOVINC(DIST,NEW)
C		UPDATE FRMTIM ("ABSOLUTE CLOCK")
	FRMTIM=FRMTIM+LFRM
	GOTO 2
C******************************************************************
999	CONTINUE
	STOP
	END
[\].
POINT@DAT
  0.8600000E+03 0.4120000E+04
  0.8600000E+03 0.4380000E+04
  0.8600000E+03 0.4530000E+04
  0.8600000E+03 0.4720000E+04
  0.8600000E+03 0.4940000E+04
  0.8600000E+03 0.5150000E+04
  0.8600000E+03 0.5380000E+04
  0.8600000E+03 0.5590000E+04
  0.8600000E+03 0.5810000E+04
  0.8600000E+03 0.5980000E+04
  0.8600000E+03 0.6050000E+04
  0.8600000E+03 0.6200000E+04
  0.8600000E+03 0.6410000E+04
  0.1500000E+04 0.4120000E+04
  0.1500000E+04 0.4380000E+04
  0.1500000E+04 0.4530000E+04
  0.1500000E+04 0.4710000E+04
  0.1500000E+04 0.4920000E+04
  0.1500000E+04 0.5130000E+04
  0.1500000E+04 0.5350000E+04
  0.1500000E+04 0.5560000E+04
  0.1500000E+04 0.5770000E+04
  0.1500000E+04 0.5950000E+04
  0.1500000E+04 0.6010000E+04
  0.1500000E+04 0.6200000E+04
  0.1500000E+04 0.6550000E+04
  0.2120000E+04 0.4120000E+04
  0.2120000E+04 0.4380000E+04
  0.2120000E+04 0.4530000E+04
  0.2120000E+04 0.4720000E+04
  0.2120000E+04 0.4920000E+04
  0.2120000E+04 0.5130000E+04
  0.2120000E+04 0.5340000E+04
  0.2120000E+04 0.5550000E+04
  0.2120000E+04 0.5760000E+04
  0.2120000E+04 0.5940000E+04
  0.2120000E+04 0.6010000E+04
  0.2120000E+04 0.6200000E+04
  0.2120000E+04 0.6600000E+04
  0.2620000E+04 0.4120000E+04
  0.2620000E+04 0.4380000E+04
  0.2620000E+04 0.4530000E+04
  0.2620000E+04 0.4720000E+04
  0.2620000E+04 0.4910000E+04
  0.2620000E+04 0.5120000E+04
  0.2620000E+04 0.5330000E+04
  0.2620000E+04 0.5530000E+04
  0.2620000E+04 0.5730000E+04
  0.2620000E+04 0.5920000E+04
  0.2620000E+04 0.6010000E+04
  0.2620000E+04 0.6200000E+04
  0.2620000E+04 0.6550000E+04
  0.2980000E+04 0.4120000E+04
  0.2980000E+04 0.4440000E+04
  0.2980000E+04 0.4530000E+04
  0.2980000E+04 0.4720000E+04
  0.2980000E+04 0.4910000E+04
  0.2980000E+04 0.5130000E+04
  0.2980000E+04 0.5320000E+04
  0.2980000E+04 0.5530000E+04
  0.2980000E+04 0.5720000E+04
  0.2980000E+04 0.5910000E+04
  0.2980000E+04 0.6030000E+04
  0.2980000E+04 0.6220000E+04
  0.2980000E+04 0.6510000E+04
  0.3440000E+04 0.4120000E+04
  0.3440000E+04 0.4340000E+04
  0.3440000E+04 0.4450000E+04
  0.3440000E+04 0.4650000E+04
  0.3440000E+04 0.4870000E+04
  0.3440000E+04 0.5110000E+04
  0.3440000E+04 0.5340000E+04
  0.3440000E+04 0.5550000E+04
  0.3440000E+04 0.5770000E+04
  0.3440000E+04 0.6000000E+04
  0.3440000E+04 0.6130000E+04
  0.3440000E+04 0.6280000E+04
  0.3440000E+04 0.6630000E+04
  0.3860000E+04 0.4120000E+04
  0.3860000E+04 0.4250000E+04
  0.3860000E+04 0.4370000E+04
  0.3860000E+04 0.4610000E+04
  0.3860000E+04 0.4850000E+04
  0.3860000E+04 0.5100000E+04
  0.3860000E+04 0.5360000E+04
  0.3860000E+04 0.5580000E+04
  0.3860000E+04 0.5830000E+04
  0.3860000E+04 0.6070000E+04
  0.3860000E+04 0.6240000E+04
  0.3860000E+04 0.6340000E+04
  0.3860000E+04 0.6770000E+04
  0.4150000E+04 0.4100000E+04
  0.4150000E+04 0.4180000E+04
  0.4150000E+04 0.4310000E+04
  0.4150000E+04 0.4770000E+04
  0.4150000E+04 0.4830000E+04
  0.4150000E+04 0.5090000E+04
  0.4150000E+04 0.5360000E+04
  0.4150000E+04 0.5600000E+04
  0.4150000E+04 0.5860000E+04
  0.4150000E+04 0.6120000E+04
  0.4150000E+04 0.6310000E+04
  0.4150000E+04 0.6370000E+04
  0.4150000E+04 0.6780000E+04
  0.4440000E+04 0.4060000E+04
  0.4440000E+04 0.4150000E+04
  0.4440000E+04 0.4260000E+04
  0.4440000E+04 0.4550000E+04
  0.4440000E+04 0.4820000E+04
  0.4440000E+04 0.5090000E+04
  0.4440000E+04 0.5340000E+04
  0.4440000E+04 0.5650000E+04
  0.4440000E+04 0.5930000E+04
  0.4440000E+04 0.6220000E+04
  0.4440000E+04 0.6390000E+04
  0.4440000E+04 0.6500000E+04
  0.4440000E+04 0.6810000E+04
  0.4710000E+04 0.4010000E+04
  0.4710000E+04 0.4120000E+04
  0.4710000E+04 0.4200000E+04
  0.4710000E+04 0.4520000E+04
  0.4710000E+04 0.4810000E+04
  0.4710000E+04 0.5080000E+04
  0.4710000E+04 0.5310000E+04
  0.4710000E+04 0.5680000E+04
  0.4710000E+04 0.5990000E+04
  0.4710000E+04 0.6300000E+04
  0.4710000E+04 0.6460000E+04
  0.4710000E+04 0.6610000E+04
  0.4710000E+04 0.6840000E+04
  0.4890000E+04 0.7000000E+04
  0.5070000E+04 0.7150000E+04
  0.4880000E+04 0.4000000E+04
  0.4880000E+04 0.4090000E+04
  0.4880000E+04 0.4180000E+04
  0.4880000E+04 0.4510000E+04
  0.4880000E+04 0.4810000E+04
  0.4880000E+04 0.5080000E+04
  0.4880000E+04 0.5310000E+04
  0.4880000E+04 0.5690000E+04
  0.4880000E+04 0.5980000E+04
  0.4880000E+04 0.6260000E+04
  0.4880000E+04 0.6400000E+04
  0.4880000E+04 0.6550000E+04
  0.4880000E+04 0.6760000E+04
  0.5050000E+04 0.6930000E+04
  0.5170000E+04 0.7070000E+04
  0.5010000E+04 0.3960000E+04
  0.5010000E+04 0.4070000E+04
  0.5010000E+04 0.4140000E+04
  0.5010000E+04 0.4500000E+04
  0.5010000E+04 0.4810000E+04
  0.5010000E+04 0.5080000E+04
  0.5010000E+04 0.5300000E+04
  0.5010000E+04 0.5690000E+04
  0.5010000E+04 0.5980000E+04
  0.5010000E+04 0.6220000E+04
  0.5010000E+04 0.6350000E+04
  0.5010000E+04 0.6500000E+04
  0.5010000E+04 0.6700000E+04
  0.5150000E+04 0.6880000E+04
  0.5260000E+04 0.7020000E+04
  0.5130000E+04 0.3950000E+04
  0.5130000E+04 0.4050000E+04
  0.5130000E+04 0.4120000E+04
  0.5130000E+04 0.4490000E+04
  0.5130000E+04 0.4800000E+04
  0.5130000E+04 0.5070000E+04
  0.5130000E+04 0.5300000E+04
  0.5130000E+04 0.5690000E+04
  0.5130000E+04 0.5970000E+04
  0.5130000E+04 0.6170000E+04
  0.5130000E+04 0.6300000E+04
  0.5130000E+04 0.6430000E+04
  0.5130000E+04 0.6630000E+04
  0.5250000E+04 0.6800000E+04
  0.5330000E+04 0.6960000E+04
  0.5290000E+04 0.3940000E+04
  0.5290000E+04 0.4040000E+04
  0.5290000E+04 0.4100000E+04
  0.5290000E+04 0.4490000E+04
  0.5290000E+04 0.4810000E+04
  0.5290000E+04 0.5040000E+04
  0.5290000E+04 0.5280000E+04
  0.5290000E+04 0.5670000E+04
  0.5290000E+04 0.5950000E+04
  0.5290000E+04 0.6140000E+04
  0.5290000E+04 0.6260000E+04
  0.5290000E+04 0.6390000E+04
  0.5290000E+04 0.6570000E+04
  0.5340000E+04 0.6770000E+04
  0.5440000E+04 0.6930000E+04
  0.5750000E+04 0.3790000E+04
  0.5750000E+04 0.3930000E+04
  0.5750000E+04 0.4020000E+04
  0.5750000E+04 0.4340000E+04
  0.5750000E+04 0.4620000E+04
  0.5750000E+04 0.4860000E+04
  0.5750000E+04 0.5090000E+04
  0.5750000E+04 0.5430000E+04
  0.5750000E+04 0.5680000E+04
  0.5750000E+04 0.5870000E+04
  0.5750000E+04 0.6030000E+04
  0.5750000E+04 0.6150000E+04
  0.5750000E+04 0.6260000E+04
  0.6360000E+04 0.3680000E+04
  0.6370000E+04 0.3800000E+04
  0.6400000E+04 0.3890000E+04
  0.6440000E+04 0.4120000E+04
  0.6480000E+04 0.4350000E+04
  0.6510000E+04 0.4540000E+04
  0.6540000E+04 0.4750000E+04
  0.6590000E+04 0.5000000E+04
  0.6620000E+04 0.5200000E+04
  0.6660000E+04 0.5400000E+04
  0.6700000E+04 0.5610000E+04
  0.6720000E+04 0.5660000E+04
  0.6730000E+04 0.5830000E+04
  0.7910000E+04 0.3330000E+04
  0.7930000E+04 0.3410000E+04
  0.7970000E+04 0.3560000E+04
  0.8020000E+04 0.3770000E+04
  0.8060000E+04 0.3880000E+04
  0.8110000E+04 0.4210000E+04
  0.8160000E+04 0.4420000E+04
  0.8210000E+04 0.4650000E+04
  0.8260000E+04 0.4850000E+04
  0.8310000E+04 0.5060000E+04
  0.8350000E+04 0.5280000E+04
  0.8360000E+04 0.5340000E+04
  0.8440000E+04 0.5660000E+04
  0.9010000E+04 0.2910000E+04
  0.9040000E+04 0.3000000E+04
  0.9100000E+04 0.3150000E+04
  0.9190000E+04 0.3370000E+04
  0.9270000E+04 0.3590000E+04
  0.9370000E+04 0.3820000E+04
  0.9440000E+04 0.4040000E+04
  0.9540000E+04 0.4260000E+04
  0.9620000E+04 0.4490000E+04
  0.9720000E+04 0.4710000E+04
  0.9800000E+04 0.4940000E+04
  0.9840000E+04 0.5050000E+04
  0.1005000E+05 0.5570000E+04
  0.1041000E+05 0.1400000E+04
  0.1045000E+05 0.1470000E+04
  0.1051000E+05 0.1570000E+04
  0.1057000E+05 0.1700000E+04
  0.1067000E+05 0.1880000E+04
  0.1071000E+05 0.1980000E+04
  0.1105000E+05 0.2800000E+04
  0.1120000E+05 0.2900000E+04
  0.1137000E+05 0.3200000E+04
  0.1164000E+05 0.3710000E+04
  0.1182000E+05 0.4050000E+04
  0.1186000E+05 0.4140000E+04
  0.1208000E+05 0.4520000E+04
  0.1146000E+05 0.2600000E+03
  0.1149000E+05 0.3100000E+03
  0.1154000E+05 0.3900000E+03
  0.1175000E+05 0.7200000E+03
  0.1199000E+05 0.1050000E+04
  0.1214000E+05 0.1240000E+04
  0.1236000E+05 0.1540000E+04
  0.1292000E+05 0.2420000E+04
  0.1298000E+05 0.2500000E+04
  0.1322000E+05 0.2890000E+04
  0.1351000E+05 0.3330000E+04
  0.1356000E+05 0.3400000E+04
  0.1370000E+05 0.3620000E+04
  0.5000000E+76 0.5000000E+76
  0.5000000E+76 0.5000000E+76
[\].
PRINT@JOB
$JOB 20(010) PRINT JOB /MCDOUGALL
$UIC <GOM>
$PUP T 16 _ 17 SYMBL JOB
$PUP  T 16 _ 17  SYMDIS SRC
$PUP T 16 _ 17 YCHECK SRC
$PUP T 16 _ 17 XCHECK SRC
$PUP T 16 _ 17 ERASE SRC
$PUP T 16 _ 17  COPY JOB
$PUP T 16 _ 17 CHOR2 SRC
$PUP T 16 _ 17 COMPL JOB
$PUP T 16 _ 17 SYMDI SRC
$PUP T 16 _  17 SYMBOL  SRC
$PUP T 16 _ 17  COLM SRC
$PUP T 16 _ 17 COLM JOB
$PUP T 16 _ 17 DATA SRC
$PUP T 16 _ 17 DATA2 SRC
$END 
$JOB FLUSH
$END
[\].
PRTPRDSRC
	SUBROUTINE PRTPRD(IMOD,MOD)
C****** CALCULATES PAC PARTIAL PRODUCT MATRIXS
	COMMON/ACCUM/RAC(3,3,15)
	COMMON/PROD/PAC(3,3,15)
C
	IF (IMOD.EQ.0) GOTO 100
	DO 69 K=1,3
	DO 69 J=1,3
	SUM=0.
	DO 68 I=1,3
68	SUM=PAC(J,I,IMOD)*RAC(I,K,MOD)+SUM
69 	PAC(J,K,MOD)=SUM
	GOTO 99
C
C		ABSOLUTE & ACCUMULATED ANGLES ARE EQ FOR HIPS
100	DO 101 K=1,3
	DO 101 J=1,3
101	PAC(J,K,MOD)=RAC(J,K,MOD)
99	RETURN
	END
[\].
PRTSUMSRC
	SUBROUTINE PRTSUM(MODULE,ISON)
C		SUBROUTINE TO CALCULATE PARTIAL SUMS  PSUM
          COMMON/CENTS/C(3,15)
          COMMON/PROD/PAC(3,3,15)
          COMMON/SUMIT/PSUM(3,16,5)
          COMMON/LINKIT/ISTRT,LINKS(6,15)
C
          IF(MODULE.EQ.0)GO TO 99
C         PICK OUT PARENT
          IMOD=LINKS(1,MODULE)
          I=1
10        I=I+1
          NUMSON=LINKS(I,MODULE)
          IF(NUMSON.NE.ISON)GO TO 10
          NUMSON=I-1
          IF(IMOD.EQ.0)GO TO 12
          I=1
11        I=I+1
          INSON=LINKS(I,IMOD)
          IF(INSON.NE.MODULE)GO TO 11
          INSON=I-1
          GO TO 13
12        INSON=1
          IMOD=16
13        DO 69 J=1,3
          SUM=0.
          DO 68 I=1,3
68        SUM=PAC(J,I,MODULE)*C(I,ISON)+SUM
69        PSUM(J,MODULE,NUMSON)=SUM
          DO 67 I=1,3
67    PSUM(I,MODULE,NUMSON)=PSUM(I,MODULE,NUMSON)+PSUM(I,
     2IMOD,INSON)
99        RETURN
          END
[\].
RDCON@SRC
C-------------------------------------------------------------------------
	SUBROUTINE RDCON(FPBT)
C	(AUTHOR: GLEN MCDOUGALL)
C	-READS SYMBOL FILE,ASSIGNS LOC ROT ANG. FOR  MODS.
C	-USES RH COORD SYSTEM
C-------------------------------------------------------------------------
C
	INTEGER COL,SUP,DIR,LEV,ROT,FLX
	INTEGER FRMTIM,FTIM,FDUR
	INTEGER LEFT,MOD,NFRMS(15)
C
	REAL DIRA(14),FANG(3,15),JMPSPN(4,2),RTTHIP(3,3)
	REAL LRPY(6,15)
C
	COMMON /SYMBOL/ COL,SUP,DIR,LEV,ROT,FLX,BDUR,BTIM
	COMMON /FANGC/ FANG,FRMTIM,NFRMS
	COMMON /LRPYC/LRPY,LFRM
	COMMON/IOLU/IOT,IOP,IOD
C
	DATA DIRA /0.,0.,90.,270.,0.,360.,180.,180.,45.,315.,
	1135.,225.,0.,0./
C*************************************************************************
C		PROCESS LAST SYMBOL READ IN BEFORE READING NEXT ONE
	IF (FRMTIM .GT. 0) GOTO 15
10	READ (IOD,11) COL,SUP,DIR,LEV,ROT,FLX,BDUR,BTIM
11	FORMAT (6I3,2F7.2)
	IF (COL .EQ. 998) GOTO 10
	IF (COL .NE. 999) GOTO 15
	FRMTIM=-1
	GOTO 999
15	CONTINUE
	FTIM=IFIX(BTIM*FPBT)
C		ONLY PROCESS SYMBOLS STARTING AT FRMTIM
	IF (FTIM.GT.FRMTIM) GOTO 999
C
 	LEFT=0
	FLXA=FLX*30
	FDUR=IFIX(BDUR*FPBT)
C
C  BODY PARTS:  LH  LA  HI  LL   LS   RS   RL   CH  RA  RH  HD
C  MODULES   :  8   6,7  1  13,14,15  10,11,12  2   3,4  5   9
20	GOTO (  800,600,100,1300,1301,1001,1000,200,300,500,900),COL
C
C		UPPER ARM ************************************************
600	LEFT=1
300	CONTINUE
	MOD=3+3*LEFT
	FANG(1,MOD)=ROT*45
	FANG(2,MOD)=DIRA(DIR+1)
	FANG(3,MOD)=(LEV*45)-(FLXA*.5)
	NFRMS(MOD)=FDUR
C		WATCH FOR LIMB STRAIGHT UP OR DOWN
	VAL=ABS(LRPY(3,MOD))
C		WRITE(IOP,) VAL,LRPY(3,MOD)
	IF (.NOT.((VAL.EQ.0.).OR.(VAL.EQ.180.))) GOTO 310
	LRPY(2,MOD)=FANG(2,MOD)
C		WRITE(IOP,) FANG(2,MOD),LRPY(2,MOD)
310	CONTINUE
C		LOWER ARM  ***************************************
700	CONTINUE
400	CONTINUE
	MOD=MOD+1
	FANG(3,MOD)=FLXA
	NFRMS(MOD)=FDUR
	GOTO 10
C		HAND  *******************************************
800	LEFT=1
500	CONTINUE
	MOD=5+3*LEFT
	FANG(1,(MOD-1))=ROT*45
	FANG(3,MOD)=FLXA-90.
	NFRMS(MOD)=FDUR
	GOTO 10
C		HIPS (TORSO)  *********************************
100	CONTINUE
	IF (.NOT.((DIR.EQ.12).OR.(DIR.EQ.13))) GOTO 10
	MOD=1
	FANG(MOD,2)=ROT*45
C	TRRHIP(?,?)=?
	GOTO 10
C		CHEST  ******************************************
200	CONTINUE
	GOTO 10
C		HEAD   *******************************************
900	CONTINUE
	GOTO 10
C		UPPER LEG   ************************************
1300	LEFT=1
1301    CONTINUE
1000	CONTINUE
1001	CONTINUE
	MOD=10+3*LEFT
	FANG(1,MOD)=ROT*45
	FANG(2,MOD)=DIRA(DIR+1)
	FANG(3,MOD)=(LEV*45)+(FLXA*.5)
	NFRMS(MOD)=FDUR
C		LOWER LEG   *********************************
1400	CONTINUE
1100	CONTINUE
	MOD=MOD+1
	FANG(3,MOD)=-FLXA
	NFRMS(MOD)=FDUR
C		FOOT   *******************************************
1500	CONTINUE
1200	CONTINUE
	MOD=MOD+1
C	FANG(2,MOD)=90
	GOTO 10
C
C*****************************************************************
C		FIND LFRM = MIN NON ZERO VALU OF NFRMS
999	NLOW=1000
	DO 5000 M=1,15
	LOW=NFRMS(M)
	IF (LOW.EQ.0) GOTO 5000
	IF(NLOW.GT.LOW) NLOW=LOW
5000	CONTINUE
	LFRM=NLOW
C*********************************************************************
	RETURN
	END
[\].
RDCONVSRC
	SUBROUTINE RDCONV(FPBT)
C		READS SYMBOL FILE,ASSIGNS LOC.ROT.ANG. FOR 1-4 MODS.
C
	INTEGER COL,SUP,DIR,LEV,ROT,FLX
	INTEGER FTIM,FDUR
	INTEGER FTIMN,FDURN
C
	REAL AR (9)
C
	COMMON/SYMRS0/SYMRS(4,4),NM,FDUR,FTIM
	COMMON/SYMRS1/SYMRSN(4,4),NMN,FDURN,FTIMN
	COMMON/IOLU/IOT,IOP,IOD
C*************************************************************************
C		STORE NEW VALUES IN SYMRSN
	WRITE(IOT,100)
100	FORMAT(' ENTER  BTIM  BDUR  NMN')
	READ (IOT,) BTIM,BDUR,NMN
	FDURN=IFIX(BDUR*FPBT)
	FTIMN=IFIX(BTIM*FPBT)
	I=0
10	I=I+1
	WRITE(IOT,115)
115	FORMAT(' ENTER   M  RO PI YA')
	READ (IOT,) M,RO,PI,YA
C
	SYMRSN(I,1)=M
	SYMRSN(I,2)=RO
	SYMRSN(I,3)=PI
	SYMRSN(I,4)=YA
C
	IF (I .LT.NMN) GOTO 10
C*******************************************************************************
999	RETURN
	END
T
D
[\].
ROTATESRC
	SUBROUTINE ROTATE(PI,YA,RO,MOD)
C		ROTATES A MODULE ABOUT PRINCIPAL AXII
C		IN  (Y, Z, X)  ORDER
C		(RH COORD SYSTEM:   +X=RIGHT,+Y=UP,+Z=TOWARDS YOU)
	DIMENSION SAVE(3,3),AM(3,3)
	COMMON/ACCUM/ RAC(3,3,15)
	DATA RD/.017145/
 	II=0
5	II=II+1
	GOTO (20,30,10,99,99),II
C****** ROLL MATRIX
10	IF (RO .EQ. 0.) GOTO 5
	AM(1,1)=1.
	AM(2,1)=0.
	AM(3,1)=0.
	AM(1,2)=0.
	AM(2,2)=COS(RO*RD)
	IF(RO.LT.0.0)AM(2,2)=-AM(2,2)
	AM(3,2)=SIN(RO*RD)
	AM(1,3)=0.
	AM(2,3)=-AM(3,2)
	AM(3,3)=AM(2,2)
	GOTO 40
C****** PITCH MATRIX
20	IF (PI .EQ. 0.) GOTO 5
	AM(1,1)=COS(PI*RD)
	IF(PI.LT.0.0)AM(1,1)=-AM(1,1)
	AM(2,1)=0.
	AM(1,3)=SIN(PI*RD)
	AM(1,2)=0.
	AM(2,2)=1.
	AM(3,2)=0.
	AM(3,1)=-AM(1,3)
	AM(2,3)=0.
	AM(3,3)=AM(1,1)
	GOTO 40
C****** YAW MATRIX
30 	IF (YA .EQ. 0.) GOTO 5
3	AM(1,1)=COS(YA*RD)
	IF(YA.LT.0.0)AM(1,1)=-AM(1,1)
	AM(2,1)=SIN(YA*RD)
	AM(3,1)=0.
	AM(1,2)=-AM(2,1)
	AM(2,2)=AM(1,1)
	AM(3,2)=0.
	AM(1,3)=0.
	AM(2,3)=0.
	AM(3,3)=1.
C****** SAVE RAC
40	CONTINUE
	DO 68 K=1,3
	DO 68 I=1,3
68	SAVE(I,K)=RAC(I,K,MOD)
C**
C	WRITE (6,) I,AM,SAVE
C**
C****** FORM NEW RAC
	DO 69 K=1,3
	DO 69 I=1,3
	SUM=0.
	DO 67 J=1,3
67	SUM=SAVE(I,J)*AM(J,K)+SUM
69	RAC(I,K,MOD)=SUM
	GOTO 5
99	RETURN
	END
[\].
RUN1@@JOB
$JOB 20(010) RUN1 JOB / MCDOUGALL 
$UIC <GOM>
$REM SYMDIS  
$INS SYMDIS  
$REQ SYMDIS  
$REM SYMDIS  
$END
[\].
SAV@@@SRC
      DIMENSION PTS(4,20),IVECT(200)
      COMMON/LIMITS/XMIN,XMAX,YMIN,YMAX
      I2B=1
      I2E=2
      XMAX=20.
      XMIN=-20.0
      YMIN=-20.
      YMAX=20.0
      PTS(1,1)=-5.0
      PTS(2,1)=-5.0
      PTS(1,2)=5.0
      PTS(2,2)=5.0
      PTS(1,3)=-5.9
      PTS(1,4)=10.0
      PTS(3,1)=-5.0
      PTS(4,1)=5.0
      PTS(3,2)=5.0
      PTS(4,2)=-5.0
      CALL CLEAR(.FALSE.)
      CALL VECTOR(1,PTS,I2B,I2E,IVECT,1,LAST,7,1,.FALSE.)
      CALL DRAW(IVECT,1,LAST)
      DO 200 I=1,5000
200   B=3*8*9*9*9*9/9999
      STOP
      END
[\].
SCHOR1SRC
C	****************************************************************
C	CHOR1 (LABAN SYMBOL INPUT PHASE) FOR
C	*CHOREO* INTERACTIVE DANCE FACILITY (AUTHOR -G.A.MCDOUGALL)
C	-STORES EACH SYMBOL AS 8 NUMBERS IN "DANC1 SRC" FILE
C	-CALLS SYMBLD TO DISPLAY SYMBOL
C	-CALLS SORTB TO SORT SYMBOLS INTO READ ORDER
C	****************************************************************
C
	REAL BLEN,BTIM,SBTIM(11),TBAR(50,2)
	REAL XMIN,XMAX,YMIN,YMAX
	REAL XA,XB,YA,YB
C
	INTEGER COL,SUP,DIR,LEV,ROT,FLX,CHG
	INTEGER X,Y,XC,YC
	INTEGER TBARI(50,6),EBAR,EDAN
	INTEGER BAR,CONT,FLIP,BPB
	INTEGER STP,SIB,TSIB,CH,ZR,FNM(2)
	INTEGER SORTV1(50),SORTV2(50),ZXY(3)
	INTEGER FIRST,LAST,TAG,MODE,BEGIN,END,IVECT(400)
	INTEGER INT,ISPACE,FNC
	INTEGER IOT,IOP,IOD
C
	COMMON/SYMBOL/ COL,SUP,DIR,LEV,ROT,FLX,BLEN,BTIM,SBTIM
	COMMON/SORTC/SORTV1,SORTV2,SIB
	COMMON/VECT/ FIRST,LAST,TAG,MODE,BEGIN,END,IVECT
	COMMON/LIMITS/ XMIN,XMAX,YMIN,YMAX
	COMMON/FRAME/ XA,XB,YA,YB
	COMMON/IOLU/ IOT,IOP,IOD
C
	DATA TBARI,TBAR/300*0,100*0./
C
C		INIT LUN ASST'S  ****************************************
C		INIT LUN ASSIGNMENTS
	IOT=4
	IOP=6
	IOD=17
C
	WRITE(IOT,9)
	WRITE (IOT,10)
	WRITE (IOT,11)
C
9	FORMAT('- ******** CHOREO INTERACTIVE DANCE FACILITY *********')
10	FORMAT(' YOU MAY  1-CREATE,2-CHANGE THE CHOREO "DANC1 SRC" FILE')
11	FORMAT(' ENTER YOUR CHOICE AS A NUMBER')
	READ (IOT,) CH
	IF (CH .EQ. 3) GOTO 2000
	IF (CH .EQ.2) GOTO 28
C		 CREATE -DELETE OLD FILE (IF PRESENT) 
23	CALL DELETE (IOD,5HDANC1,3HSRC,IEV)
25	CALL WAITFR (IEV)
	IF (IEV) 999,25,27
27	WRITE (IOT,15)
C
15	FORMAT( ' ENTER BEATS/BAR (3 OR 4)')
	READ (IOT,) BPB
C		OPEN THE DANCE FILE 
26	CALL ENTER (IOD,5HDANC1,3HSRC,IEV)
22	CALL WAITFR (IEV)
	IF (IEV) 999,22,60
C
C		CHANGE SYMBOLS IN EXISTING FILE
28 	CONTINUE
C	CALL SEEK(IOD,5HDANC1,3HSRC,IEV)
C	CALL EDITD (NOT CODED YET)
	GOTO 1000
C		INITIALIZATION SECTION **********************************
60 	CONTINUE
C		INIT SCREEN LIMITS
	XMIN=0.
	XMAX=20.
	YMIN=0.
	YMAX=20.
	XA=0.
	XB=20.
	YA=0.
	YB=20.
C		INITIALIZE ARRAYS USED TO BUILD SYMBOLS
	CALL ARINIT
C		INIT GEN PURPOSE VARS
	EBAR = 998
	EDAN =999
	ZR = 0
	RZR=0.
	BAR = 1
	SIB=0
	TSIB=0
	BBTIM=0.
	DO 64 I=1,11
64	SBTIM(I)=0.0
	WRITE(IOT,65) 
C
65	FORMAT(' NOW -ENTER SYMBOLS FROM THE ACOUSTIC TABLET')
C******************************************************************
C		SYMBOL PARAMETER ASSIGNMENT SECTION
80	CONTINUE
	CALL CLEAR(.TRUE.)
	CALL COLM
81	COL=0
	SUP  = 0
	DIR  = 0
	LEV  = 0
	ROT  = 0
	FLX  = 0
	BLEN = 0.0
	BTIM = 0.0
	GOTO 90
C	********************************* MANUAL INPUT SECTION *****
C90	WRITE (IOT,190) 
190	FORMAT(' CO SU DI LE RO FL BL  1=EOS/2=EOB/3=EOD')
	READ (IOT,) COL,SUP,DIR,LEV,ROT,FLX,BLEN,III
	GOTO (200,300,1000),III
	GOTO 90
C	*************************  A.T. INPUT SECTION  ******************
90     CALL GETBLT(25,0,ZXY,IEV)
	CALL WAITFR(IEV)
	XC=ZXY(3)
	YC=ZXY(2)
	X=17-XC/56
	Y=1+YC/56
	WRITE (IOT,) X,Y
	IF ((X.GT.16).OR.(Y.GT.16)) GOTO 90
C	****************************************************************
C		SET THE PARAMETER
  	GOTO (90,100,90,110,90,120,90,130,140,150,90,160,90,
     *  170,180,90),X
C		SET  **  COL  **
100	IF ((Y.EQ.1).OR.(Y.GE.13)) GOTO 90
	COL=Y-1
	GOTO 90
C		SET  **  SUP  **
110	IF ((Y.EQ.1).OR.(Y.EQ.16)) GOTO 90
	SUP=Y-1
	GOTO 90
C		SET  **  DIR  **
120	IF((Y.EQ.1).OR.(Y.GE.15)) GOTO 90
	DIR=Y-1
	GOTO 90
C		SET  **  LEV  OR  ROT **
130	GOTO (90,131,131,131,90,90,90,90,132,133,134,90,90,
     *  90,90,90),Y
131	LEV=Y-1
	GOTO 90
132	ROT=8
	GOTO 90
133	ROT=1
	GOTO 90
134	ROT=2
	GOTO 90
C		SET  **  ROT  **
140	IF (Y.EQ.9) GOTO 143
	IF (Y.EQ.11) GOTO 144
	GOTO 90
143	ROT=7
	GOTO 90
144	ROT=3
	GOTO 90
C		SET  **  FLX  OR  ROT  **
150	GOTO (90,151,151,151,151,151,151,90,152,153,154,90,90,
     *  90,90,90),Y
151	FLX=Y-1
	GOTO 90
152	ROT=6
	GOTO 90
153	ROT=5
	GOTO 90
154	ROT=4
	GOTO 90
C		SET  **  EOS,  EOB,  EOD  **
160	GOTO (90,161,161,161,161,161,161,161,161,90,90,200,90,
     *  300,90,1000),Y
C		SET  **  BLEN  **
161	BLEN=BLEN+(Y-1)*.125
	IF (LEN.GT.BPB) LEN=BPB
C
	GOTO 90
C
C		CHANGE SYMBOL (NOT CODED YET)
170	GOTO 90
C		EDIT,REPLAY NOT CODED YET
180	GOTO 90
C	***********************************************************
C		SYMBOL ERROR MSGS
200	CONTINUE
	IF (COL .GT. 0) GOTO 204
	WRITE (IOT,201)
201	FORMAT (' COL  IS ALSO REQUIRED')
	GOTO 90
204	IF (.NOT.((DIR.NE.0).AND.((LEN.EQ.0).OR.(LEV.EQ.0)))) GOTO 206
	WRITE(IOT,205)
205	FORMAT(' LENGTH, LEVEL   ARE ALSO REQUIRED')
	GOTO 90
C	*****************************************************************
C		SYMBOL DISPLAY & STORE SECTION  
206	CONTINUE
	SIB=SIB+1
	TAG=SIB
C		BUILD AND DISPLAY SYMBOL
	CALL SYMBLD
	WRITE (IOT,) SIB
C		CALC SYMBOL START TIME (BEAT UNITS)
C		     UPDATE RELATIVE (WRT BAR) START TIME
	SBTIM(COL)=SBTIM(COL)+BLEN
	BTIM=BBTIM+SBTIM(COL)
	WRITE(IOT,) COL,SUP,DIR,LEV,ROT,FLX,BLEN,BTIM,BBTIM,SBTIM(COL)
C		STORE SORT ORDER
	SORTV1(SIB) = (BTIM*1000)+COL
C		STORE SYMBOL IN TEMP ARRAY (MUST BE SORTED BEFORE FILED)
	TBARI(SIB,1) = COL
	TBARI(SIB,2) = SUP
	TBARI(SIB,3) = DIR
	TBARI(SIB,4) = LEV
	TBARI(SIB,5) = ROT
	TBARI(SIB,6) = FLX
	TBAR(SIB,1) = BLEN
	TBAR(SIB,2) = BTIM
C
	GOTO 81
C************************************************************************
C		END OF BAR PROCESSING  
300	CONTINUE
C		SORT THE SYMBOLS BY COL WITHIN STARTING LOCATION
	WRITE (IOP,) (SORTV1(I),I=1,SIB)
	CALL SORTB
	WRITE (IOP,) (SORTV2(I),I=1,SIB)
C		FILE HEADER & SYMBOL RECORDS IN ORDER
	WRITE (IOD,500) EBAR,BAR,SIB,ZR,ZR,ZR,RZR,RZR
500	FORMAT(6I3,2F7.3)
	DO 320 I=1,SIB
	IN = SORTV2(I)
	WRITE (IOD,500) TBARI(IN,1),TBARI(IN,2),TBARI(IN,3),TBARI(IN,4),
	1TBARI(IN,5),TBARI(IN,6),TBAR(IN,1),TBAR(IN,2)
320	CONTINUE
C
C		UPDATE TOTAL SYMBOLS IN DANCE & BAR # , RESET SIB
	TSIB = TSIB + SIB
	SIB = 0
	BAR = BAR + 1
C		UPDATE ABSOLUTE BAR START TIME, & RELATIVE (WRT BAR) 
C                                           SYMBOL START TIME
	BBTIM=BBTIM+BPB
	DO 310 I=1,11
310	SBTIM(I)=AMAX1(0.0,(SBTIM(I)-BPB))
	GOTO 80
C***************************************************************
C		END OF DANCE PROCESSING  
1000	WRITE (IOD,500) EDAN,BAR,TSIB,ZR,ZR,ZR,RZR,RZR
C		CLOSE THE DANCE FILE
999	CONTINUE
	WRITE (IOT,) IEV
	CALL CLOSE (IOD,5HDANC1,3HSRC,IEV)
	CALL WAITFR(IEV)
	WRITE(IOT,)IEV
C
2000	CONTINUE
	WRITE(IOT,2001)
C
2001	FORMAT(' TO VIEW ANIMATION OF DANCE -ENTER "CHOR2"')
	READ(IOT,) CH
	STOP
	END
[\].
SCHOR2SRC
C-------------------------------------------------------------------
C	CHOR2 (ANIMATION PHASE) FOR *CHOREO* INTERACTIVE DANCE FACILITY
C	(AUTHOR: GLEN MCDOUGALL) 
C	-CALLS RDCON TO READ "DANC1 SRC" FILE & CONVERT TO MODULE ANGLES
C	-COORDINATES TIMING FOR MODULE MOVEMENT
C	-CALLS MOVINC TO BUILD & DISPLAY EACH FRAME
C----------------------------------------------------------------------
	INTEGER FRMTIM,FTIM,FDUR1,FTIMN,FDURN
	INTEGER NFRMS(15)
	REAL LRPY,FANG(3,15)
C
	COMMON/LRPYC/LRPY(6,15),LFRM
	COMMON/FANGC/FANG,FRMTIM,NFRMS
	COMMON/IOLU/ IOT,IOP,IOD
	COMMON/EYCEP/EYE(3),CEN(3),UP(3)
	COMMON/LINKIT/ ISTRT,LINKS(6,15)
	COMMON/LIMITS/XMIN,XMAX,YMIN,YMAX
C******************************************************************
C		TERMINAL & PRINTER LUN'S
	IOT=4
	IOP=6
	IOD=17
C		SET UP VIEWING PARAMETERS
	XMIN=-30.
	XMAX=30.
	YMIN=-30.
	YMAX=30.
	EYE(1)=0.
	EYE(2)=0.
	EYE(3)=0.
	CEN(1)=0.
	CEN(2)=0.
	CEN(3)=0.
	UP(1)=0.
	UP(2)=10.
	UP(3)=0.
	DIST=60.
4	WRITE(IOT,5)
5	FORMAT(' ENTER VIEW: 1-FRONT,2=TOP,3-LSIDE')
	READ(IOT,) I
	IF((I.GT.3).OR.(I.LT.1)) GOTO 4
	EYE(I)=DIST
	CALL ROTER
	CALL CLEAR(.TRUE.)
C*****************************************************************
	ISTRT=1
	NEW=0
C		READ IN MOD & LINK INFO & DISPLAY CHARLIE (AT ATTENTION)
	CALL INPUTS
	LFRM=1
	CALL MOVINC(DIST,NEW)
C		INIT -FOR EACH MODULE:# OF MOVEMENT FRAMES
C		& LOCAL ROLL, PITCH, YAW ROTATIONS & FINAL ANGLES 
        DO 21 M=1,15
	DO 21 L=1,6
	NFRMS(M)=0
	LRPY(L,M)=0.
	IF (L.GT.3) GOTO 21
	FANG(L,M)=0.
21	CONTINUE
	WRITE(IOT,19)
 19     FORMAT(' ENTER TEMPO (IN BEATS PER MIN.)')
	READ(IOT,)TMPO
	FPBT=1440./TMPO
C		INIT PARAMETERS
	JUMP=0
	FRMTIM=0
C		OPEN THE DANCE FILE FOR FUTURE READS
	CALL SEEK(IOD,5HDANC1,3HSRC,IEV)
22	CALL WAITFR(IEV)
	IF (IEV) 999,22,23
23	CONTINUE
	WRITE (IOT,) IEV,FPBT
C***************************************************************************
C		READ & CONVERT DANCE FILE SYMBOLS INTO MOD ANGLES
2	CONTINUE
C
	CALL RDCON (FPBT)
C		END OF DANCE ?
	IF (FRMTIM.LT.0) GOTO 999
C		CALC INCR ANGLES FOR NEW MOVEMENTS
	DO 15 MOD=1,15
	FDUR1=NFRMS(MOD)
	IF (FDUR1.EQ.0) GOTO 15
	LRPY(4,MOD)=(FANG(1,MOD)-LRPY(1,MOD))/FDUR1
	LRPY(5,MOD)=(FANG(2,MOD)-LRPY(2,MOD))/FDUR1
	LRPY(6,MOD)=(FANG(3,MOD)-LRPY(3,MOD))/FDUR1
15	CONTINUE
C*****************************************************************
	WRITE(IOP,)FRMTIM,LFRM,FDUR1
	DO 398 I=1,15
	IF (NFRMS(I).EQ.0) GOTO 398
	WRITE (IOP,) NFRMS(I)
398	CONTINUE
	DO 399 I=1,15
	DO 399 J=1,6
	IF (LRPY(J,I).EQ.0) GOTO 399
	WRITE (IOP,) LRPY(J,I)
399	CONTINUE
C*****************************************************************
C		DISPLAY CHARLIE FOR LFRM FRAMES
C		USING LRPY ANGLES 
C
	CALL MOVINC(DIST,NEW)
C		UPDATE FRMTIM ("ABSOLUTE CLOCK")
	FRMTIM=FRMTIM+LFRM
C******************************************************************
C		UPDATE START ANGLES AND # OF REMAINING FRAMES
	DO 11 M=1,15
C		IF NO RECENT MOD MOVMNT -IGNORE
	IF (NFRMS(M).EQ.0) GOTO 11
C		UPDATE START ANGS
	LRPY(1,M)=FANG(1,M)
	LRPY(2,M)=FANG(2,M)
	LRPY(3,M)=FANG(3,M)
C		UPDATE # REMAINING FRMS
	NFRMS(M)=NFRMS(M)-LFRM
C		IF MOD MOVMNT ENDS ZERO INCR ANGS FOR MOD
	IF (NFRMS(M).NE.0) GOTO 11
	LRPY(4,M)=0.
	LRPY(5,M)=0.
	LRPY(6,M)=0.
11	CONTINUE
C***************************************************************
	DO 498 I=1,15
	IF (NFRMS(I) .EQ.0) GOTO 498
	WRITE (IOP,) NFRMS(I)
498	CONTINUE
	DO 499 I=1,15
	DO 499 J=1,6
	IF(LRPY(J,I).EQ.0) GOTO 499
	WRITE(IOP,) LRPY(J,I)
499	CONTINUE
	GOTO 2
C***************************************************************
C****************************************************************
999	CONTINUE
C		CLOSE THE DANCE FILE
	CALL CLOSE (IOD,5HDANC1,3HSRC,IEV)
88	CALL WAITFR(IEV)
	IF (IEV) 89,88,89
89	WRITE (IOT,) IEV
	STOP
	END
[\].
SCOLM@SRC
      SUBROUTINE COLM
C**	SUBROUTINE TO DISPLAY COLUMNS
        REAL ARR(4,32),INC
C	REAL XMIN,XMAX,YMIN,YMAX
C	REAL XA,XB,YA,YB
C
        INTEGER FIRST,LAST,TAG,MODE,BEGIN,END,IVECT(400)
	INTEGER INT,ISPACE,FCN
C
	COMMON/VECT/ FIRST,LAST,TAG,MODE,BEGIN,END,IVECT
	COMMON/LIMITS/ XMIN,XMAX,YMIN,YMAX
	COMMON/FRAME/ XA,XB,YA,YB
C
C**	COLUMN LINE DEFINITIONS
	IOT=4
	ARR(1,1)=2.8
	ARR(2,1)=2
	ARR(3,1)=19.3
	ARR(4,1)=2
C**
	DO 10 I=2,13
	ARR(1,I)=2.8+1.5*(I-2)
	ARR(2,I)=2
	ARR(3,I)=2.8+1.5*(I-2)
	ARR(4,I)=18
 10	CONTINUE
C**
	DO 20 I=14,29
	INC=0
	IF ((I.EQ.17).OR.(I.EQ.21).OR.(I.EQ.25).OR.(I.EQ.29))  INC=.1
	ARR(1,I)=10.2-INC
	ARR(2,I)=2+(I-13)
	ARR(3,I)=10.4+INC
	ARR(4,I)=2+(I-13)
 20	CONTINUE
C***********
	CALL DSPLAY(7,IGET,IERR)
	WRITE(IOT,) IGET,IERR
	CALL VECTOR (1,ARR,1,29,IVECT,1,LAST,7,1,.FALSE.)
	WRITE(IOT,) LAST
	CALL DSPLAY (3,51,IERR)
	WRITE(IOT,) IERR
	WRITE(IOT,) LAST
	CALL DSPLAY (6,51,IERR,IVECT,1,LAST)
	WRITE(IOT,) IERR,LAST
	RETURN
	END
[\].
SORTB@SRC
	SUBROUTINE SORTB
C	SORTS SYMBOLS OF BAR & STORES WRITE ORDER IN SORTV2
C	(ALLOWS SYMBOLS TO BE INPUT IN ANY ORDER FROM A.T.)
C
	INTEGER SIB,SORTV1(50),SORTV2(50)
	COMMON/SORTC/SORTV1,SORTV2,SIB
C
	DO 10 J=1,SIB
	LOWV=99999
	DO 20 I=1,SIB
	IF (SORTV1(I).GE.LOWV) GOTO 20
	LOWI=I
	LOWV=SORTV1(I)
20	CONTINUE
	SORTV2(J)=LOWI
	SORTV1(LOWI)=99999
10	CONTINUE
	RETURN
	END
[\].
SRDCONSRC
	SUBROUTINE RDCON(FPBT)
C		READS SYMBOL FILE,ASSIGNS LOC ROT ANG. FOR  MODS.
C
	INTEGER COL,SUP,DIR,LEV,ROT,FLX
	INTEGER FRMTIM,FTIM,FDUR
	INTEGER LEFT,MOD,NFRMS(15)
C
	REAL DIRA(14),FANG(3,15),JMPSPN(4,2),RTTHIP(3,3)
	REAL LRPY(6,15)
C
	COMMON /SYMBOL/ COL,SUP,DIR,LEV,ROT,FLX,BDUR,BTIM
	COMMON /FANGC/ FANG,FRMTIM,NFRMS
	COMMON /LRPYC/LRPY,LFRM
	COMMON/IOLU/IOT,IOP,IOD
C
	DATA DIRA /0.,0.,-90.,90.,0.,0.,-180.,180.,-45.,45.,
	1-135.,135.,0.,0./
C*************************************************************************
C		PROCESS LAST SYMBOL READ IN BEFORE READING NEXT ONE
	IF (FRMTIM .GT. 0) GOTO 15
10	READ (IOD,11) COL,SUP,DIR,LEV,ROT,FLX,BDUR,BTIM
11	FORMAT (6I3,2F7.2)
	IF (COL .EQ. 998) GOTO 10
	IF (COL .NE. 999) GOTO 15
	FRMTIM=-1
	GOTO 999
15	CONTINUE
	FTIM=IFIX(BTIM*FPBT)
C		ONLY PROCESS SYMBOLS STARTING AT FRMTIM
	IF (FTIM.GT.FRMTIM) GOTO 999
C
 	LEFT=0
	FLXA=FLX*30
	FDUR=IFIX(BDUR*FPBT)
	WRITE(IOP,) BTIM,FRMTIM,FTIM
C
C
20	GOTO(500,300,100,1000,1001,1301,1300,200,600,800,900),COL
C		UPPER ARM ************************************************
600	LEFT=1
300	CONTINUE
	MOD=3+3*LEFT
	FANG(1,MOD)=ROT*45
	FANG(2,MOD)=DIRA(DIR+1)
	FANG(3,MOD)=(LEV*45)-(FLXA*.5)
	NFRMS(MOD)=FDUR
C		WATCH FOR LIMB STRAIGHT UP OR DOWN
	VAL=ABS(LRPY(3,MOD))
	WRITE(IOP,) VAL,LRPY(3,MOD)
	IF (.NOT.((VAL.EQ.0.).OR.(VAL.EQ.180.))) GOTO 310
	LRPY(2,MOD)=DIRA(DIR+1)
	WRITE(IOP,) FANG(2,MOD),LRPY(2,MOD)
310	CONTINUE
C		LOWER ARM  ***************************************
700	CONTINUE
400	CONTINUE
	MOD=MOD+1
	FANG(3,MOD)=FLXA
	NFRMS(MOD)=FDUR
	GOTO 10
C		HAND  *******************************************
800	LEFT=1
500	CONTINUE
	MOD=5+3*LEFT
	FANG(1,(MOD-1))=ROT*45
	FANG(3,MOD)=FLXA-90.
	NFRMS(MOD)=FDUR
	GOTO 10
C		HIPS (TORSO)  *********************************
100	CONTINUE
	IF (.NOT.((DIR.EQ.12).OR.(DIR.EQ.13))) GOTO 10
	MOD=1
	FANG(MOD,2)=ROT*45
C	TRRHIP(?,?)=?
	GOTO 10
C		CHEST  ******************************************
200	CONTINUE
	GOTO 10
C		HEAD   *******************************************
900	CONTINUE
	GOTO 10
C		UPPER LEG   ************************************
1300	LEFT=1
1301    CONTINUE
1000	CONTINUE
1001	CONTINUE
	MOD=10+3*LEFT
	FANG(1,MOD)=ROT*45
	FANG(2,MOD)=DIRA(DIR+1)
	FANG(3,MOD)=(LEV*45)+(FLXA*.5)
	NFRMS(MOD)=FDUR
C		LOWER LEG   *********************************
1400	CONTINUE
1100	CONTINUE
	MOD=MOD+1
	FANG(3,MOD)=-FLXA
	NFRMS(MOD)=FDUR
C		FOOT   *******************************************
1500	CONTINUE
1200	CONTINUE
	MOD=MOD+1
C	FANG(2,MOD)=90
	GOTO 10
C
C*****************************************************************
C		FIND LFRM = MIN NON ZERO VALU OF NFRMS
999	NLOW=1000
	DO 5000 M=1,15
	LOW=NFRMS(M)
	IF (LOW.EQ.0) GOTO 5000
	IF(NLOW.GT.LOW) NLOW=LOW
5000	CONTINUE
	LFRM=NLOW
C*********************************************************************
	RETURN
	END
[\].
SSORTBSRC
	SUBROUTINE SORTB
C****** SORTS SYMBOLS OF BAR INTO READ ORDER
C
	INTEGER SIB,SORTV1(50),SORTV2(50)
	COMMON/SORTC/SORTV1,SORTV2,SIB
C
	DO 10 J=1,SIB
	LOWV=99999
	DO 20 I=1,SIB
	IF (SORTV1(I).GE.LOWV) GOTO 20
	LOWI=I
	LOWV=SORTV1(I)
20	CONTINUE
	SORTV2(LOWI)=J
	SORTV1(LOWI)=99999
10	CONTINUE
	RETURN
	END
[\].
SYMBINSRC
C	SYMBIN    *INPUTS SYMBOL STRINGS INTO DANC1 SRC FILE
	INTEGER COL,SUP,DIR,LEV,ROT,FLX
	REAL BLEN,BTIM
	CALL ENTER(17,5HDANC1,3HSRC,IEV)
10	CALL WAITFR(IEV)
	IF (IEV) 1000,10,11
11	CONTINUE
	WRITE(4,20)
20	FORMAT('  CO SU DI LV RT FL BL BTM')
	READ (4,) COL,SUP,DIR,LEV,ROT,FLX,BLEN,BTIM
	IF (COL .EQ. 999) GOTO 999
12	FORMAT(6I3,2F7.3)
	WRITE(17,12) COL,SUP,DIR,LEV,ROT,FLX,BLEN,BTIM
	GOTO 11
999	CALL CLOSE (17,5HDANC1,3HSRC,IEV)
90	CALL WAITFR(IEV)
	IF (IEV) 1000,90,91
91	CONTINUE
1000	CONTINUE
	STOP
	END
[\].
SYMBL@JOB
$JOB 20(010) SYMBL JOB SPRINGY
$UIC <BKS>
$TKB
NRM,UL:F4LIB}
LABAN}
200}
GRAFIX}
CHOR2,YCHECK,XCHECK,SYMDIS,COLM,SYMBOL,ERASE} }
$REM LABAN
$INS LABAN
$REQ LABAN
$END
$JOB FLUSH
$END
[\].
SYMBLDSRC
	SUBROUTINE SYMBLD
C****** BUILDS SYMBOLS AND DISPLAYS THEM ON THE LABAN STAFF
C
	REAL SBTIM(11),BLEN,BTIM
	REAL ARR(4,32),SHPAR(2,11,13),FLXAR(4,7),SUPLAR(4,6,2)
	REAL SUPTAR(4,17)
C
	INTEGER COL,SUP,DIR,LEV,ROT,FLX
	INTEGER MODE,BEGIN,END,IVECT(400),FIRST
	INTEGER LAST,INT,ISPACE,FCN,TAG
	INTEGER FLIP,I,STP
C
	COMMON/SYMBOL/COL,SUP,DIR,LEV,ROT,FLX,BLEN,BTIM,SBTIM
	COMMON/ARRAY/ ARR,SHPAR,FLXAR,SUPLAR,SUPTAR
	COMMON/VECT/ FIRST,LAST,TAG,MODE,BEGIN,END,IVECT
	COMMON/LIMITS/ XMIN,XMAX,YMIN,YMAX
	COMMON/FRAME/ XA,XB,YA,YB
	COMMON/IOLU/ IOT,IOP,IOD
C
C****** TRANSLATE SYMBOL SHAPE TO SCREEN ,SET INTENSITY
	TX = 2.8 + 1.5*(COL-1)
	TY = 2.0 + 4. * SBTIM(COL)
	FIRST=1
	BEG=1
	END=1
	INT = 7
	ISPACE = 1
	SHRT = 0.0
	IF (DIR.EQ.0) GOTO 9
	IF (FLX.NE.0) SHRT = .167
	DO 5 I=1,11
	ARR(1,I)=TX+.1*(I-1)
	ARR(2,I)=TY+SHPAR(1,I,DIR)*(4*BLEN)+SHRT
	ARR(3,I)=TX+.1*(I-1)
	ARR(4,I)=TY+SHPAR(2,I,DIR)*(4*BLEN)
5	CONTINUE
	INT=3+(LEV-1)*2
	END=END+11
9       IF (ROT.EQ.0) GOTO 100
C****** TRANSLATE ROTATION PINS
	GOTO (10,20,30,40,50,60,70,80),ROT
10	X=.0
	Y=.3
	GOTO 90
20	X=.3
	Y=.3
	GOTO 90
30	X=.3
	Y=.0
	GOTO 90
40	X=.3
	Y=-.3
	GOTO 90
50	X=.0
	Y=-.3
	GOTO 90
60	X=-.3
	Y=-.3
	GOTO 90
70	X=-.3
	Y=.0
	GOTO 90
80	X=-.3
	Y=.3
90	ARR(1,END)=TX+.5
	ARR(2,END)=TY+SHRT+.5*BLEN*4
	ARR(3,END)=TX+X+.5
	ARR(4,END)=TY +Y+ SHRT+.5*BLEN*4
	END = END +1
100	IF (FLX.EQ.0) GOTO 200
C****** TRANSLATE FLEXION SYMBOLS
	STP = FLX + 1
	DO 110 I=1,STP
	ARR(1,END)=TX+FLXAR(1,I)
	ARR(2,END)=TY+FLXAR(2,I)
	ARR(3,END)=TX+FLXAR(3,I)
        ARR(4,END)=TY+FLXAR(4,I)
110	END=END+1
C****** TRANSLATE SUPPORT SYMBOLS
200	IF (SUP.EQ.0) GOTO 300
   	IF ((SUP.EQ.7).OR.(SUP.EQ.8)) GOTO 275
	FLIP =0
	IF (0.EQ.(MOD(SUP,2))) FLIP=1
	IF (SUP.GE.10) GOTO 250
	ARR(1,END)=TX+SUPLAR(1,1,1)-FLIP
	ARR(2,END)=TY+SUPLAR(2,1,1)
	ARR(3,END)=TX+SUPLAR(3,1,1)-FLIP
	ARR(4,END)=TY+SUPLAR(4,1,1)
	END = END+1
	IF (SUP.LE.6) STP=6
	IF (SUP.LE.4) STP=3
	IF (SUP.LE.2) STP = 2
	DO 210 I=2,STP
	ARR(1,END)=TX+SUPLAR(1,I,1)-FLIP
	ARR(2,END)=TY+SUPLAR(2,I,1)
	ARR(3,END)=TX+SUPLAR(3,I,1)
	ARR(4,END)=TY+SUPLAR(4,I,1)
210	END = END +1
	GOTO 300
C****** LEG SUPPORT
250	ARR(1,END)=TX+SUPLAR(1,I,2)-FLIP
	ARR(2,END)=TY+SUPLAR(2,I,2)
	ARR(3,END)=TX+SUPLAR(3,I,2)-FLIP
	ARR(4,END)=TY+SUPLAR(4,I,2)
	END = END +1
	IF (SUP.LE.14) STP = 6
	IF (SUP.LE.12) STP = 3
	IF (SUP.LE.10) STP = 2
	DO 260 I=2,STP
	ARR(1,END)=TX+SUPLAR(1,I,2)-FLIP
	ARR(2,END)=TY+SUPLAR(2,I,2)
	ARR(3,END)=TX+SUPLAR(3,I,2)
260      ARR(4,END)=TY+SUPLAR(4,I,2)
	END=END+STP+1
	GOTO 300
C****** TORSO SUPPORT
275	STP = 12
	IF (SUP.EQ.8) STP = 17
	DO 280 I=1,STP
	ARR(1,END)=TX+SUPTAR(1,I)
	ARR(2,END)=TY+SUPTAR(2,I)
	ARR(3,END)=TX+SUPTAR(3,I)
        ARR(4,END)=TY+SUPTAR(4,I)
280	END=END+1
	END = END + STP+1
C****** DISPLAY COMPLETED SYMBOL (HI INT. FOR ROT,FLX,SUP LNS)
300	END=END-1
	CALL VECTOR(1,ARR,BEGIN,END,IVECT,FIRST,LAST,INT,ISPACE,.FALSE.)
	CALL DSPLAY(3,TAG,IERR)
	CALL DSPLAY(6,TAG,IERR,IVECT,1,LAST)
	RETURN
	END
[\].
TBLD@@SRC
CLOSE
OPEN TBLD JOB
[\].
TEST@@SRC
C****** TEST  FOR FILE OPRNS
	INTEGER RECS,FNM(3)
	REAL COL,SUP,DIR,ROT,FLX,LEV
	REAL LEN,POS
	DATA FNM/2HDA,2HNC,1H1/
	RECS=15
	CALL SEEK (15,5HDANC1,3HSRC,IEV)
50	CALL WAITFR(IEV)
	IF (IEV) 1001,50,51
51      DO 10 M=1,RECS
52      READ (15,) COL,SUP,DIR,LEV,ROT,FLX,LEN,POS
	IF (COL.EQ.999.) GOTO 52
	WRITE (4,) COL,SUP,DIR,LEV,ROT,FLX,LEN,POS
10	CONTINUE
999     CALL CLOSE(15,5HDANC1,3HSRC,IEV)
1000	CALL WAITFR (IEV)
	IF (IEV) 1001,1000,1002
1001    WRITE (4,) IEV
1002    STOP
	END
[\].
TRAN@@SRC
	SUBROUTINE TRAN
C	ERASE THIS
TOP
[\].
USR/P2EDT
  2  0  3  1  0  0  1.000  0.000
  2  0  3  2  0  0  1.000  1.000
  2  0  3  3  0  0  1.000  2.000
  2  0  5  1  0  0  1.000  3.000
  2  0  5  2  0  0  1.000  4.000
  2  0  5  3  0  0  1.000  5.000
  2  0  7  1  0  0  1.000  6.000
  2  0  7  2  0  0  1.000  7.000
  2  0  7  3  0  0  1.000  8.000
  2  0  9  1  0  0  1.000  9.000
  2  0  9  2  0  0  1.000 10.000
  2  0  9  3  0  0  1.000 11.000
  2  0 11  1  0  0  1.000 12.000
  2  0 11  2  0  0  1.000 13.000
  2  0 11  3  0  0  1.000 14.000
  2  0 11  2  0  0  1.000 15.000
998  0  0  0  0  0  0.000  0.000
999  0  0  0  0  0  0.000  0.000
[\].
VARI0@DAT
  0.3400000E+01 0.0000000E+00
  0.3400000E+01 0.0000000E+00
  0.3400000E+01 0.0000000E+00
  0.3400000E+01 0.0000000E+00
  0.3400000E+01 0.0000000E+00
  0.3400000E+01 0.0000000E+00
  0.3400000E+01 0.0000000E+00
  0.3400000E+01 0.0000000E+00
  0.3400000E+01 0.0000000E+00
  0.3400000E+01 0.0000000E+00
  0.3400000E+01 0.0000000E+00
  0.3400000E+01 0.0000000E+00
  0.3400000E+01 0.7437500E+00
  0.1245700E+01 0.1314500E-12
  0.2684200E+01 0.6886000E+00
  0.3479000E+01 0.4958200E+00
  0.3397600E+01 0.3785000E+00
  0.3403100E+01-0.3764200E-01
  0.3512300E+01-0.3676100E+00
  0.3346300E+01-0.4771800E+00
  0.3579700E+01-0.5885200E+00
  0.3726700E+01-0.8485200E+00
  0.3734200E+01-0.4834300E+00
  0.3541300E+01-0.3320100E+00
  0.1290400E+01-0.5425500E+00
  0.1523500E+01 0.2297400E+00
  0.9460500E+00 0.1705300E-12
  0.1491500E+01-0.6159000E-03
  0.3391500E+01-0.1127600E-01
  0.3510300E+01-0.2564500E+00
  0.3583400E+01-0.4382000E+00
  0.3462800E+01-0.3935900E+00
  0.3601200E+01-0.3722300E+00
  0.3457700E+01-0.8028000E-01
  0.3323900E+01 0.8045300E-01
  0.2895600E+01 0.6774700E-01
  0.2726500E+01 0.1780900E+00
  0.7276300E+00 0.1777500E+00
  0.6293500E+00 0.6821200E-12
  0.4599500E+00 0.3979000E-12
  0.1387000E+01-0.3393500E+00
  0.2237400E+01-0.2768800E+00
  0.2411700E+01-0.3520100E+00
  0.2473700E+01-0.4249500E+00
  0.2659300E+01-0.3656700E+00
  0.2459500E+01-0.1234800E+00
  0.2591700E+01-0.1189200E+00
  0.2566700E+01 0.4681000E-01
  0.2310400E+01 0.1852300E+00
  0.2231600E+01-0.9042200E-01
  0.6526900E+00-0.3518200E-01
  0.6810000E+00-0.7126700E-01
  0.6965800E+00 0.9094900E-12
  0.1710900E+01 0.9826800E-01
  0.2478400E+01-0.8201100E-01
  0.2545900E+01-0.1786900E+00
  0.2519700E+01-0.1721600E+00
  0.2447600E+01-0.1000100E+00
  0.2649100E+01-0.1831800E+00
  0.2465800E+01-0.2290800E-01
  0.2382900E+01 0.5047900E-02
  0.2394900E+01-0.2776600E+00
  0.1951300E+01-0.8331500E-01
  0.6669000E+00 0.7080600E-01
  0.6623600E+00 0.6462000E-01
  0.7542700E+00 0.4547500E-12
  0.1808600E+01-0.5518700E-01
  0.2682000E+01 0.2456300E-01
  0.2729300E+01 0.1531900E-01
  0.2772900E+01 0.7424900E-01
  0.2895100E+01 0.2042300E-01
  0.2780000E+01 0.1472400E+00
  0.2943500E+01 0.1051800E+00
  0.2981500E+01 0.4103100E-01
  0.3053500E+01 0.2095800E+00
  0.2256900E+01-0.7091800E-01
  0.8267600E+00 0.3426400E+00
  0.8902400E+00 0.2630300E+00
  0.6605700E+00-0.1860800E-01
  0.1606500E+01-0.1094000E-01
  0.2306400E+01-0.7986500E-01
  0.2295200E+01-0.1265500E-01
  0.2152600E+01 0.3990800E-01
  0.2030300E+01 0.3137900E+00
  0.2362600E+01 0.4869600E+00
  0.2469000E+01 0.7025600E+00
  0.2989300E+01 0.7485700E+00
  0.3120800E+01 0.3169900E+00
  0.2472300E+01 0.4995000E+00
  0.9871600E+00 0.3106700E+00
  0.8942400E+00 0.1889200E+00
  0.6162500E+00-0.6375000E-01
  0.1357300E+01-0.6220100E-01
  0.1908100E+01 0.1432900E+00
  0.1680200E+01 0.8453600E-01
  0.1554800E+01 0.2451600E+00
  0.1864300E+01 0.4349800E+00
  0.1567800E+01 0.8428100E+00
  0.2153300E+01 0.1522100E+01
  0.2740700E+01 0.1626500E+01
  0.3380300E+01 0.1183800E+01
  0.2841600E+01-0.3172300E-01
  0.9890800E+00 0.4175900E+00
  0.1166500E+01 0.8045100E-01
  0.5155900E+00-0.8286200E-01
  0.1218200E+01 0.5229500E-01
  0.1659700E+01 0.3848100E-01
  0.1926700E+01 0.5088300E+00
  0.1680300E+01 0.3989800E+00
  0.1606100E+01 0.5438500E+00
  0.1758900E+01 0.7945100E+00
  0.1228100E+01 0.1530900E+01
  0.2177800E+01 0.2728100E+01
  0.3403800E+01 0.2651200E+01
  0.4232200E+01 0.1366300E+01
  0.1526500E+01 0.4430800E+00
  0.1440500E+01 0.1543400E+00
  0.5191700E+00-0.7079500E-01
  0.9596600E+00-0.1112600E+00
  0.1140200E+01 0.9413100E-01
  0.1198100E+01 0.7170400E-01
  0.1250900E+01 0.4873700E+00
  0.1283100E+01 0.4680500E+00
  0.1038900E+01 0.1071300E+01
  0.1316500E+01 0.1150800E+01
 -0.1034500E+00 0.2656100E+01
  0.1929800E+01 0.5238000E+01
  0.5016500E+01 0.2548300E+01
  0.4276000E+01 0.2912000E+01
  0.1409500E-01-0.1409500E-01
  0.6008000E+00 0.1373200E+01
  0.2898700E+01 0.3623400E+01
  0.1253000E+00-0.2088300E-01
  0.6620300E+00 0.1428400E+00
  0.7419800E+00-0.2427200E-01
  0.7186200E+00 0.3662100E+00
  0.8429700E+00 0.2602800E+00
  0.7006300E+00 0.6059000E+00
  0.8727300E+00 0.8264300E+00
  0.7316800E+00 0.1636800E+01
 -0.1059700E+00 0.1700700E+01
 -0.6172200E-03 0.3091700E+01
  0.4811700E+01 0.3794100E+01
  0.4592200E+01 0.7191500E+01
  0.4139600E+01 0.5069000E+01
  0.6527000E+00 0.4920600E+01
  0.3148300E+01 0.3423700E+01
  0.4931300E+00-0.9862600E-01
  0.2823500E+00-0.7967600E-01
  0.6544500E+00 0.3364900E+00
  0.5743300E+00 0.3463200E+00
  0.7108200E+00 0.5956100E+00
  0.5878500E+00 0.3447800E+00
  0.6492400E+00 0.1261000E+01
  0.6916900E+00 0.1364000E+01
  0.1900100E+00 0.1511800E+01
  0.3390900E-01 0.2872200E+01
  0.1066900E+01 0.2936800E+01
  0.3282200E+01 0.4026500E+01
  0.3502900E+01 0.5153600E+01
  0.2308200E+01 0.4847600E+01
  0.2401200E+01 0.3159500E+01
 -0.3313000E+00 0.2366400E-01
  0.4843700E+00 0.1206300E+00
  0.4269100E+00-0.8259600E-01
  0.6338300E+00 0.4387400E+00
  0.6287100E+00 0.2837400E+00
  0.7336000E+00 0.8164400E+00
  0.5426000E+00 0.1204000E+01
  0.9872600E+00 0.1797000E+01
  0.3400900E+00 0.1275100E+01
  0.5576800E+00 0.3360700E+01
 -0.5508300E+00 0.2812300E+01
 -0.5929700E+00 0.2662900E+01
  0.1176600E+01 0.1122700E+01
  0.1712700E+00 0.2229300E+01
  0.5792100E+00 0.1059700E+01
  0.4614200E+00-0.1190800E+00
  0.3419000E+00-0.3863200E-01
  0.7487100E+00 0.5780900E+00
  0.1218500E+01 0.9337700E+00
  0.1529200E+01 0.1098900E+01
  0.1711200E+01 0.1049100E+01
  0.2059800E+01 0.1506600E+01
  0.2033400E+01 0.1459100E+01
  0.2228200E+01 0.1249000E+01
 -0.7275200E+00 0.2784600E+01
 -0.1322600E+01 0.2469200E+01
 -0.1184600E+01 0.3018300E+01
  0.1434800E+01 0.1434800E+01
  0.7176200E+00 0.2152900E+01
  0.3091000E+00 0.1133400E+01
  0.2805100E+00-0.6816000E-01
  0.9503800E+00-0.3720600E-01
  0.1408300E+01-0.8339400E+00
  0.1570600E+01-0.8821800E+00
  0.1724200E+01-0.4638300E+00
  0.2204800E+01 0.1337100E+00
  0.2203700E+01 0.2764800E-01
  0.2060000E+01 0.6715400E-01
  0.1758500E+01 0.8053900E+00
  0.8164200E+00 0.1340800E+01
 -0.4385200E+00 0.2472300E+01
 -0.1072300E+01 0.1628800E+01
 -0.1565900E+01 0.8046800E+00
  0.8984100E+00-0.1913300E+00
  0.2547400E+01-0.8677800E+00
  0.2770600E+01-0.1072000E+00
  0.3126000E+01-0.2761400E+00
  0.3137600E+01-0.1144000E+01
  0.2856100E+01-0.8810400E+00
  0.2910800E+01-0.1453100E+00
  0.2827800E+01-0.2246400E+00
  0.2258000E+01-0.4916300E+00
  0.2007500E+01-0.9019200E+00
  0.5367600E+00-0.1704000E+00
  0.7075200E+00-0.1573500E+00
  0.8205700E+00-0.1830300E+00
  0.1590000E+01-0.4619900E+00
  0.2908700E+01-0.7062400E+00
  0.3242000E+01-0.1235200E+01
  0.2992800E+01-0.1096700E+01
  0.2906800E+01-0.1370000E+01
  0.3265400E+01-0.1193000E+01
  0.3251700E+01-0.1402900E+01
  0.3110100E+01-0.1335800E+01
  0.3435800E+01-0.7283700E+00
  0.3636900E+01-0.2755500E+00
  0.3003500E+01-0.4440100E+00
  0.9427700E+00-0.1811600E+00
  0.8431400E+00-0.6602900E-01
  0.1076800E+01-0.8312700E+00
  0.1377500E+01-0.6475500E+00
  0.3463100E+01-0.4485300E+01
  0.2747900E+01-0.4465500E+01
  0.2633400E+01-0.4113800E+01
  0.1510700E+01-0.3450500E+01
  0.3516300E+01-0.2044500E+01
  0.3482100E+01-0.1994000E+01
  0.3233700E+01-0.1948800E+01
  0.3352200E+01-0.1613600E+01
  0.3158000E+01-0.1212600E+01
  0.8038800E+00-0.3310000E+00
  0.8852000E+00-0.2772300E+00
  0.2403700E+01-0.2599900E+01
  0.2519000E+01-0.4291100E+01
  0.2212400E+01-0.5396700E+01
  0.2850300E+01-0.5216200E+01
  0.3349300E+01-0.5205000E+01
  0.3075200E+01-0.4409200E+01
  0.7599500E+00-0.2212000E+01
  0.5159100E+01-0.1580200E+01
  0.5690200E+01-0.3182600E+01
  0.5951700E+01-0.2620200E+01
  0.4885200E+01-0.1775200E+01
  0.1546400E+01-0.3813100E+00
  0.1378400E+01-0.7364200E+00
  0.3025900E+01-0.3285300E+01
  0.3025900E+01-0.4639900E+01
  0.4665700E+01-0.6411400E+01
  0.5887900E+01-0.4777200E+01
  0.6392600E+01-0.3479300E+01
  0.5624900E+01-0.2535400E+01
  0.7447600E+00-0.2962000E+01
  0.3135600E+01-0.3870400E+00
  0.6681600E+01-0.9455500E+00
  0.7106400E+01-0.1608600E+01
  0.5700300E+01-0.1153700E+01
  0.1490900E+01-0.5463000E+00
  0.1490900E+01-0.8282600E+00
[\].
XTEST@SRC
	CALL COLM
	STOP
	END
[\].
