C*****************************************************************************
C
C	             Gidis Support Function Test Controller
C
C-----------------------------------------------------------------------------
C
C Program	: Test Gidis Support/ TGidis.For
C Editor/Author	: John Malcolmson
C Date		: July 1986
C Language	: Fortran 77
C Notes		: The program is chained to by the Libtst program.
C
C*****************************************************************************
C
C	Test program is an implementation of the following:
C
C	Coupler Curves For a Four-Bar Crank And Rocker Linkage
C
C	Ref:	"Kinematic Analysis of Mechanisms", pp. 341, 342
C			by 
C		Joseph Edward Shigley
C
C		McGraw-Hill Book Co., 1959
C
C	Or:
C		"Machine Design", vol. 30. no. 8, p. 146, 1958
C
C*****************************************************************************

	Program TGidis

		Character*80	st
		Integer*2	valer, res
		INTEGER*2 	INIT(2)
		INTEGER*2	WMODE(2)
		INTEGER*2	IDS(3)
		INTEGER*2	NEWPIC(1)
		INTEGER*2	ENDPIC(1)
		INTEGER*2	SPMASK(2)
		INTEGER*2	SETPOS(3), XSET, YSET
		INTEGER*2	SPCOLR(2), PCV
		INTEGER*2	SSCOLR(2), SCV
		INTEGER*2	DLINE(3), LINEX1, LINEY1
		INTEGER*2	SCMAP(7), MAP, CMIDX, RED, GREEN, BLUE, MONO
		INTEGER*2	F0, F1, F2, F3, F4, F5, F6, F7
		BYTE		CLRSCR(11)
		INTEGER*2  	NX(120),NY(120), CHAN, BITE, I, II, XORG, YORG
		INTEGER*2 	BX(120), BY(120), CX(120), CY(120)
		INTEGER*4  	STATUS
		REAL*4	   	A, B, C1, C2, C3, C, D, FACTOR, X
		EQUIVALENCE	(LINEX1, DLINE(2))
		EQUIVALENCE	(LINEY1, DLINE(3))
		EQUIVALENCE	(PCV,    SPCOLR(2))
		EQUIVALENCE	(SCV,    SSCOLR(2))
		EQUIVALENCE	(XSET,   SETPOS(2))
		EQUIVALENCE	(YSET,   SETPOS(3))
		EQUIVALENCE	(MAP,    SCMAP(2))
		EQUIVALENCE	(CMIDX,  SCMAP(3))
		EQUIVALENCE	(RED,    SCMAP(4))
		EQUIVALENCE	(GREEN,  SCMAP(5))
		EQUIVALENCE	(BLUE,   SCMAP(6))
		EQUIVALENCE	(MONO,   SCMAP(7))
		Integer*4	Report, Pnum
		Integer*4	Param(-7:22), rprt
		Character*14	dest
		Logical*2	appnd, Page

		Open(unit=2,file='DAT:DGIDIS.DAT',Type='OLD')
		Read(2,5) Param
5		Format( 104A )
		Close(unit=2)
		Call ConSts(Param(-3),appnd,Page,Pnum)
		Call OpenOutput( Param(-7), appnd )

C		IF (page) Call SetPage( 'Gidis Support Functions\', pnum )


C	Define GIDIS initialization data block
		INIT(1)	  = 	"001*"400+"001
		INIT(2)	  =	"427
C	Define GIDIS Writing Mode data block; "4" = overlay mode
		WMODE(1)  =	"026*"400+"001
		WMODE(2)  =	"004
C	Define GIDIS Imposed Data Space data block
		IDS(1)	  =	"014*"400+"002
		IDS(2)	  =	"1700
		IDS(3)	  =	"1130
C	Define GIDIS New Picture data block
		NEWPIC(1) =	"006*"400+"000
C	Define GIDIS End Picture data block
		ENDPIC(1) =	"030*"400+"000
C	Define GIDIS Set Plane Mask data block header
		SPMASK(1) =	"024*"400+"001
C	Define GIDIS Set Position data block header
		SETPOS(1) =	"035*"400+"002
C	Define GIDIS Set Primary Color data block header
		SPCOLR(1) =	"025*"400+"001
C	Define GIDIS Set Secondary Color data block header
		SSCOLR(1) =	"017*"400+"001
C	Define GIDIS Set Color Map data block header
		SCMAP(1)  =	"020*"400+"006
C	Define GIDIS Draw Line data block header
		DLINE(1)  =	"031*"400+"002
C	Define octal fraction color intensities
		F0 	   = "000000
		F1 	   = "020000
		F2 	   = "040000
		F3 	   = "060000
		F4 	   = "100000
		F5 	   = "120000
		F6 	   = "140000
		F7         = "160000	
		CLRSCR(1)  = "033
		CLRSCR(2)  = "133
		CLRSCR(3)  = "060
		CLRSCR(4)  = "073
		CLRSCR(5)  = "060
		CLRSCR(6)  = "146
		CLRSCR(7)  = "033
		CLRSCR(8)  = "133
		CLRSCR(9)  = "062
		CLRSCR(10) = "112
		CLRSCR(11) = "200


C	Some early versions of GIDIS/RT expected byte counts; if you
C	have such a version, set BITE = 2.  Otherwise, set BITE = 1.

		BITE = 1

		XORG = 300
		YORG = 200

C	Clear screen

		CALL PRINT (CLRSCR)

C	Define the channel for GIDIS

		CHAN = 12

C	Open and initialize GIDIS

		CALL GIOPEN (STATUS, CHAN, 0, 1, 6, 0)
		IF (STATUS .NE. 0) GOTO 900

C	Do a GIDIS Initialize function

		CALL GIWRIT (STATUS, CHAN, INIT, BITE*2)
		IF (STATUS .NE. 0) GOTO 910

C	Set writing mode to "overlay"

		WMC = "004
		CALL GIWRIT (STATUS, CHAN, WMODE, BITE*2)
		IF (STATUS .NE. 0) GOTO 930

C	Define color map entry 0

		MAP   = 0
		CMIDX = 0
		RED   = 0
		GREEN = 0
		BLUE  = 0
		MONO  = 0
		CALL GIWRIT (STATUS, CHAN, SCMAP, BITE*7)
		IF (STATUS .NE. 0) GOTO 940

C	Define color map entry 1

		MAP   = 0
		CMIDX = 1
		RED   = 0
		GREEN = 0
		BLUE  = F7
		MONO  = F5
		CALL GIWRIT (STATUS, CHAN, SCMAP, BITE*7)
		IF (STATUS .NE. 0) GOTO 940

C	Define color map entry 2

		MAP   = 0
		CMIDX =	2
		RED   = 0
		GREEN = F7
		BLUE  = 0
		MONO  = F7
		CALL GIWRIT (STATUS, CHAN, SCMAP, BITE*7)
		IF (STATUS .NE. 0) GOTO 940

C	Define color map entry 3

		MAP   = 0
		CMIDX =	3
		RED   = 0
		GREEN = F7
		BLUE  = F7
		MONO  = F7
		CALL GIWRIT (STATUS, CHAN, SCMAP, BITE*7)
		IF (STATUS .NE. 0) GOTO 940

C	Define color map entry 4

		MAP   = 0
		CMIDX = 4
		RED   = F6
		GREEN = F5
		BLUE  = F7
		MONO  = F7
		CALL GIWRIT (STATUS, CHAN, SCMAP, BITE*7)
		IF (STATUS .NE. 0) GOTO 940

C	--------------------------------------------------------------------
C	Begin calculation of coupler curve

		PI = 3.1415927
		A  = 10.0
		B  = 4.0
		C1 = 6.0
		C2 = 5.0
		C3 = 3.0
		D  = 5.0
		C  = C1 + C2

C	Fudge factor to make drawing a reasonable size

6		FACTOR = 50.

		A      = A  * FACTOR
		B      = B  * FACTOR
		C1     = C1 * FACTOR
		C2     = C2 * FACTOR
		C3     = C3 * FACTOR
		C      = C  * FACTOR
		D      = D  * FACTOR

		C5     = SQRT(C1*C1 + C3*C3)

C	Worry about what happens if T4 > 90 degrees
C	...first check for 90-degree, 270-degree cases

		IF (C1) 8, 7, 8
7		IF (C3 .GE. 0) T4 = PI/2
		IF (C3 .LT. 0) T4 = 3*PI/2
		GOTO 17

C	Then worry about the other cases

8		T4 = ATAN(C3/C1)
		IF (C1) 9,17,17
9		T4 = PI + T4
17		DT = PI*2./120.
		T2 = 0.
		SIGN = +1.

C	Calculate points on the coupler curve every 3 degrees

		DO 10 K = 1, 120

			IF (K-61) 12, 11, 12
11			SIGN  = -SIGN
12			ST2   = SIN(T2)*B
			CT2   = COS(T2)*B
			EL    = SQRT(A*A + B*B -2.*A*CT2)
			S     = ABS(ST2) / EL
			BETA  = ATAN(S/SQRT(1. - S*S))
			S     = (C*C + EL*EL - D*D) / (2.*C*EL)
			IF (S) 21, 15, 21
15			PSI   = PI/2
			GOTO 22
21			PSI   = ATAN(SQRT(1. - S*S) / S)
			IF (S) 20, 21, 22
20			PSI   = PI - PSI
			GOTO 22
22			T3    = PSI - BETA*SIGN
			T5    = T3 + T4
			NX(K) = (C5*COS(T5)) + CT2 + XORG
			NY(K) = 600 - (C5*SIN(T5)) - ST2 - YORG
			BX(K) = CT2 + XORG
			BY(K) = 600 - ST2 - YORG 
			CX(K) = BX(K) + COS(T3)*C
			CY(K) = BY(K) - SIN(T3)*C
			T2    = T2 + DT

10		CONTINUE

C-----------------------------------------------------------------------------

C	Begin Plotting the Points
C	Issue New Picture request

		CALL GIWRIT (STATUS, CHAN, NEWPIC, BITE*1)
		IF (STATUS .NE. 0) GOTO 950

		CALL PRINT (CLRSCR)
		TYPE 99
99		FORMAT (1X,'	Plot of Four-Bar Linkage Coupler Curve')
		TYPE 100, A/FACTOR
100		FORMAT ('0A  = ',F4.1)
		TYPE 101, B/FACTOR
101		FORMAT (' B  = ',F4.1)
		TYPE 102, C1/FACTOR
102		FORMAT (' C1 = ',F4.1)
		TYPE 103, C2/FACTOR
103		FORMAT (' C2 = ',F4.1)
		TYPE 104, C3/FACTOR
104		FORMAT (' C3 = ',F4.1)
		TYPE 105, D/FACTOR
105		FORMAT (' D  = ',F4.1)


C	Set Imposed Data Space

		CALL GIWRIT (STATUS, CHAN, IDS, BITE*3)
		IF (STATUS .NE. 0) GOTO 960

C	Set the GIDIS plane mask for drawing axes in plane 1

		SPMASK(2) =	"001
		CALL GIWRIT (STATUS, CHAN, SPMASK, BITE*2)
		IF (STATUS .NE. 0) GOTO 920

C	Set color for axes; use writing index 1 to draw in plane 1

		PCV = 1
		CALL GIWRIT (STATUS, CHAN, SPCOLR, BITE*2)
		IF (STATUS .NE. 0) GOTO 980

C	Draw X, Y axes
C	Draw (X,Y) axes at (XORG, YORG)

		XSET = 0
		YSET = 600 - YORG
		CALL GIWRIT (STATUS, CHAN, SETPOS, BITE*3)
		IF (STATUS .NE. 0) GOTO 990

		LINEX1 = 960
		LINEY1 = 600 - YORG
		CALL GIWRIT (STATUS, CHAN, DLINE, BITE*3)
		IF (STATUS .NE. 0) GOTO 905

		XSET = XORG
		YSET = 0
		CALL GIWRIT (STATUS, CHAN, SETPOS, BITE*3)
		IF (STATUS .NE. 0) GOTO 990

		LINEX1 = XORG
		LINEY1 = 600
		CALL GIWRIT (STATUS, CHAN, DLINE, BITE*3)
		IF (STATUS .NE. 0) GOTO 905

C	Set position on coupler curve

		XSET = NX(1) 
		YSET = NY(1) 
		CALL GIWRIT (STATUS, CHAN, SETPOS, BITE*3)
		IF (STATUS .NE. 0) GOTO 990

C	Set the GIDIS plane mask for curve in plane 2

		SPMASK(2) =	"002
		CALL GIWRIT (STATUS, CHAN, SPMASK, BITE*2)
		IF (STATUS .NE. 0) GOTO 920

C	Set writing index for drawing curve in plane 2

		PCV = 2
		CALL GIWRIT (STATUS, CHAN, SPCOLR, BITE*2)
		IF (STATUS .NE. 0) GOTO 980

C	Draw the coupler curve

		DO 25 I = 1, 120
			LINEX1 = NX(I) 
			LINEY1 = NY(I) 
			CALL GIWRIT (STATUS, CHAN, DLINE, BITE*3)
			IF (STATUS .NE. 0) GOTO 905
25		CONTINUE


C	Draw in the links
C	Set the GIDIS plane mask for drawing links in plane 3

		SPMASK(2) =	"004
		CALL GIWRIT (STATUS, CHAN, SPMASK, BITE*2)
		IF (STATUS .NE. 0) GOTO 920

C	Set primary color for links

		PCV = 4
		CALL GIWRIT (STATUS, CHAN, SPCOLR, BITE*2)
		IF (STATUS .NE. 0) GOTO 980

C	Draw links at angle X

		DO 700 J = 1, 2
	 	    DO 500 I = 1, 120

C	Set "overlay" writing mode

			WMODE(2) = "004
			CALL GIWRIT (STATUS, CHAN, WMODE, BITE*2)
			IF (STATUS .NE. 0) GOTO 930

C	Set position at right end of "A" link (the fixed link)
C	fudged up a little so it doesn't draw on top of X-axis

			XSET = XORG + A
			YSET = 600 - YORG - 1
			CALL GIWRIT (STATUS, CHAN, SETPOS, BITE*3)
			IF (STATUS .NE. 0) GOTO 990

C	Draw "A" link (the fixed link)

			LINEX1 = XORG
			LINEY1 = 600 - YORG -  1
			CALL GIWRIT(STATUS, CHAN, DLINE, BITE*3)
			IF (STATUS .NE. 0) GOTO 905

C	Draw "B" link (the crank)

			LINEX1 = BX(I) 
			LINEY1 = BY(I) 
			CALL GIWRIT(STATUS, CHAN, DLINE, BITE*3)
			IF (STATUS .NE. 0) GOTO 905

C	Draw "C" link (the connecting link)

			LINEX1 = CX(I) 
			LINEY1 = CY(I) 
			CALL GIWRIT (STATUS, CHAN, DLINE, BITE*3)
			IF (STATUS .NE. 0) GOTO 905

C	Draw "D" link (the rocker link)

			LINEX1 = XORG + A
			LINEY1 = 600 - YORG - 1
			CALL GIWRIT (STATUS, CHAN, DLINE, BITE*3)
			IF (STATUS .NE. 0) GOTO 905

C	Position at end of "B" link

			XSET = BX(I) 
			YSET = BY(I) 
			CALL GIWRIT (STATUS, CHAN, SETPOS, BITE*3)
			IF (STATUS .NE. 0) GOTO 990

C	Draw connecting link triangle

			LINEX1 = NX(I) 
			LINEY1 = NY(I) 
			CALL GIWRIT (STATUS, CHAN, DLINE, BITE*3)
			IF (STATUS .NE. 0) GOTO 905
			LINEX1 = CX(I) 
			LINEY1 = CY(I) 
			CALL GIWRIT (STATUS, CHAN, DLINE, BITE*3)
			IF (STATUS .NE. 0) GOTO 905

C	Now erase previously drawn links

			II = I-1
			IF (II .LE. 0) II = 120

C	Set writing mode to "erase"

			WMODE(2) = "010
			CALL GIWRIT (STATUS, CHAN, WMODE, BITE*2)
			IF (STATUS .NE. 0) GOTO 930

C	Position at (0,0)

			XSET = XORG 
			YSET = 600 - YORG - 1
			CALL GIWRIT (STATUS, CHAN, SETPOS, BITE*3)
			IF (STATUS .NE. 0) GOTO 990

C	Erase "B" link (the crank)

			LINEX1 = BX(II) 
			LINEY1 = BY(II) 
			CALL GIWRIT(STATUS, CHAN, DLINE, BITE*3)
			IF (STATUS .NE. 0) GOTO 905

C	Erase "C" link (the connecting link)

			LINEX1 = CX(II) 
			LINEY1 = CY(II) 
			CALL GIWRIT (STATUS, CHAN, DLINE, BITE*3)
			IF (STATUS .NE. 0) GOTO 905

C	Erase "D" link (the rocker link)

			LINEX1 = XORG + A
			LINEY1 = 600 - YORG - 1
			CALL GIWRIT (STATUS, CHAN, DLINE, BITE*3)
			IF (STATUS .NE. 0) GOTO 905

C	Position at end of "B" link

			XSET = BX(II) 
			YSET = BY(II) 
			CALL GIWRIT (STATUS, CHAN, SETPOS, BITE*3)
			IF (STATUS .NE. 0) GOTO 990

C	Erase connecting link triangle

			LINEX1 = NX(II) 
			LINEY1 = NY(II) 
			CALL GIWRIT (STATUS, CHAN, DLINE, BITE*3)
			IF (STATUS .NE. 0) GOTO 905
			LINEX1 = CX(II) 
			LINEY1 = CY(II) 
			CALL GIWRIT (STATUS, CHAN, DLINE, BITE*3)
			IF (STATUS .NE. 0) GOTO 905

500		    CONTINUE

700		CONTINUE

		Goto 1000

C-----------------------------------------------------------------------------
C	Error Messages


900		Call MtFail( 'GIOPEN', 1 )
		Call Write2Int( 0,      10 )
		Call WriteInt(  Status, 10 )
		Call WriteLn
		valer = valer + 2**1		
		GOTO 1000

905		Call MtFail( 'drwlin', 2 )
		Call Write2Int( 0,      10 )
		Call WriteInt(  Status, 10 )
		Call WriteLn
		valer = valer + 2**2	
		GOTO 1000

910		Call MtFail( 'Nloadd', 3 )
		Call Write2Int( 0,      10 )
		Call WriteInt(  Status, 10 )
		Call WriteLn
		valer = valer + 2**3	
		GOTO 1000

920		Call MtFail( 'SPMask', 5 )
		Call Write2Int( 0,      10 )
		Call WriteInt(  Status, 10 )
		Call WriteLn
		valer = valer + 2**5	
		GOTO 1000

930		Call MtFail( 'SWRmod', 6 )
		Call Write2Int( 0,      10 )
		Call WriteInt(  Status, 10 )
		Call WriteLn
		valer = valer + 2**6	
		GOTO 1000

940		Call MtFail( 'ClrMap', 7 )
		Call Write2Int( 0,      10 )
		Call WriteInt(  Status, 10 )
		Call WriteLn
		valer = valer + 2**7	
		GOTO 1000

950		Call MtFail( 'PicReq', 8 )
		Call Write2Int( 0,      10 )
		Call WriteInt(  Status, 10 )
		Call WriteLn
		valer = valer + 2**8	
		GOTO 1000

960		Call MtFail( 'SetIDS', 9 )
		Call Write2Int( 0,      10 )
		Call WriteInt(  Status, 10 )
		Call WriteLn
		valer = valer + 2**9	
		GOTO 1000

970		Call MtFail( '2ndClr', 10 )
		Call Write2Int( 0,      10 )
		Call WriteInt(  Status, 10 )
		Call WriteLn
		valer = valer + 2**10	
		GOTO 1000

980		Call MtFail( 'PrmClr', 11 )
		Call Write2Int( 0,      10 )
		Call WriteInt(  Status, 10 )
		Call WriteLn
		valer = valer + 2**11	
		GOTO 1000

990		Call MtFail( 'SetPos', 12 )
		Call Write2Int( 0,      10 )
		Call WriteInt(  Status, 10 )
		Call WriteLn
		valer = valer + 2**12	
		GOTO 1000

1000		CALL GICLOS (STATUS, CHAN)
		CALL PRINT (CLRSCR)

		st = '===== Gidis Support Function Error Report Summary =====\'
		Call CenterString( st )
		Call WriteLn
		Rprt = Report( valer, 'GIDISS', 01 )
		st = '===== End of Gidis Support Function Report =====\'
		Call CenterString( st )
		Call WriteLn
		Call WriteLn

		Call GetPage( Pnum )
		Call StsCon( Appnd, Page, Pnum, Param(-3) )
		param(ABS(param(0))) = rprt
		Call CloseOutput
		Open(unit=2,file='DAT:DGIDIS.DAT',Type='NEW')
		Write(2,1005) Param
1005		Format( 104A )
		Close(unit=2)
		Call Setcmd( '@BIN:DGIDIS.COM' )

9999	END

C----------------------------------------------------------------------------)

C--------------------------------- Trans ------------------------------------)

	Subroutine Trans( in, out )

		Byte		in(120)
		Byte		out(14)
		Integer*4	i

		Do 10 i=1,14
			Out(i) = in(i)
10		Continue

	END

C----------------------------------------------------------------------------)