DECLARE SUB Interpolate (Ins!, s1!, s2!, s3!, EValues!(), Outs!, value!)
DECLARE SUB MouseHide ()
DECLARE SUB MouseShow ()
'DRAW2.BAS
'second module of DRAWGRID.BAS
'by Peter Bird, UCLA, 1992
'(c)Copyright 1992 by Peter Bird and the Regents of the University of California.
DECLARE FUNCTION ATAN2F! (Y!, X!)
DECLARE FUNCTION GETBIT% (NUMBER%, PLACE%)
DECLARE FUNCTION Inside% (X!, Y!, NPoly%, XPoly!(), YPoly!())
DECLARE FUNCTION Principal! (Angle!)
DECLARE SUB Blanker (R1%, R2%, C1%, C2%)
DECLARE SUB DERIV (Ins!, i%, NODES%(), POINTS!(), XNODE!(), YNODE!(), Outs!, EMemo%)
DECLARE SUB DropNode (Ins, AKA%, n%, NFL%, NUMEL%, Mods, EQCM!(), NFAKEN%, NMemo%(), NODEF%(), NODES%(), NREALN%, NUMNOD%, XNODE!(), YNODE!())
DECLARE SUB Finish (FileNum%)
DECLARE SUB IsJoined (Ins, FAZ!(), i%, NFL%, NODEF%(), Outs, FMemo%())
DECLARE SUB MidFault (Ins!, FAZ!(), i%, NODEF%(), Mods!, XNODE!(), YNODE!(), Outs!, NMemo%())
DECLARE SUB NEXTto (Ins, i%, J%, NFL%, NODEF%(), NODES%(), NUMEL%, Outs, KFAULT%, KELE%)
DECLARE SUB OnAny (Ins!, n%, N1%, NLast%, NODES%(), Outs!, ie%, je%)
DECLARE SUB Pixels (Ins!, X!, Y!, Outs!, col%, row%)
DECLARE SUB RaiseOne (Ins!, i%, NODES%(), XNODE!(), YNODE!())
DECLARE SUB SETBIT (NUMBER%, PLACE%, ONOFF%)
DECLARE SUB WaitForKey (a$)
DECLARE SUB XandY (Ins!, col%, row%, UnScale!(), Outs!, X!, Y!)
'--------------------------------------------------------------
OPTION BASE 1
'--------------------------------------------------------------------
DIM SHARED Letters(2, 14) AS STRING * 1 'Letter associated with (col,line) in menu
'---------------------------------------------------------------------
'Following COMMON gets parameters and constant-length arrays
'(but not dynamic, variable-length arrays) to the subprograms
'DrawNode, DrawElement, DrawFault in the fastest way, without
'having to put them on the stack and take them off in every call:
DIM FIPoint!(4)
DIM Icon1%(30), Icon2%(30)
DIM Scales!(2, 2)
COMMON SHARED Argument!, Colored%, CursorOn%, DoIcon%, FIPoint!(), HiCol%, HiColor%, HiRow%, Icon1%(), Icon2%(), LastPutC%, LastPutR%, Mantle%, R2C!, Scales!(), XatTL!, XCenter!, YatTL!, YCenter!
'---------------------------------------------------------------------

SUB AddNode (Ins, MXNODE%, NFL%, NModel%, NUMEL%, X!, Y!, Mods, EQCM!(), NMemo%(), NODEF%(), NODES%(), NREALN%, NUMNOD%, N1000%, XNODE!(), YNODE!(), Outs, n%)
'add a real node at (x,y); bump all fake nodes up if necessary.
'NModel% is the number of the existing node from which data are copied.
IF NUMNOD% = MXNODE% THEN
	LOCATE 1, 1: PRINT "CANNOT ADD ANY MORE NODES; LIMIT OF "; MXNODE%; " REACHED."
	EXIT SUB
END IF
NUMNOD% = NUMNOD% + 1
NREALN% = NREALN% + 1
IF NUMNOD% > NREALN% THEN 'move up all fake nodes
	FOR i% = NUMNOD% TO (NREALN% + 1) STEP -1
		NMemo%(i%) = NMemo%(i% - 1)
		XNODE!(i%) = XNODE!(i% - 1)
		YNODE!(i%) = YNODE!(i% - 1)
		EQCM!(1, i%) = EQCM!(1, i% - 1)
		EQCM!(2, i%) = EQCM!(2, i% - 1)
		EQCM!(3, i%) = EQCM!(3, i% - 1)
		IF Mantle% THEN EQCM!(4, i%) = EQCM!(4, i% - 1)
	NEXT i%
	FOR i% = 1 TO NUMEL%
		FOR J% = 1 TO 6
			IF NODES%(J%, i%) >= NREALN% THEN NODES%(J%, i%) = NODES%(J%, i%) + 1
		NEXT J%
	NEXT i%
	FOR i% = 1 TO NFL%
		FOR J% = 1 TO 6
			IF NODEF%(J%, i%) >= NREALN% THEN NODEF%(J%, i%) = NODEF%(J%, i%) + 1
		NEXT J%
	NEXT i%
END IF
IF NREALN% > N1000% THEN  'adjust round number N1000%
	IF (CLNG(N1000%) + 1000&) <= 32767& THEN
		N1000% = N1000% + 1000
	ELSE
		N1000% = (CLNG(N1000%) + 32767&) / 2
	END IF
END IF
n% = NREALN%
XNODE!(n%) = X!
YNODE!(n%) = Y!
NMemo%(n%) = NMemo%(NModel%)
EQCM!(1, n%) = EQCM!(1, NModel%)
EQCM!(2, n%) = EQCM!(2, NModel%)
EQCM!(3, n%) = EQCM!(3, NModel%)
IF Mantle% THEN EQCM!(4, n%) = EQCM!(4, NModel%)
END SUB

FUNCTION ATAN2F! (Y!, X!)
'arc-tangent function with two arguments, returning result from -Pi to +Pi.
IF (Y! = 0!) AND (X! = 0!) THEN
   'answer technically undefined; just return 0.
	ATAN2F! = 0!
ELSE
	IF X! > 0! THEN
	    'ordinary ATN function will work fine
		ATAN2F! = ATN(Y! / X!)
	ELSEIF X! = 0! THEN
		IF Y! > 0! THEN
			ATAN2F! = 1.570795
		ELSE
			ATAN2F! = -1.570795
		END IF
	ELSE
	    'x < 0
	    Prince! = ATN(Y! / X!)
	    IF Prince! > 0! THEN
		    ATAN2F! = Prince! - 3.141591
	    ELSE
		    ATAN2F! = Prince! + 3.141591
	    END IF
	END IF
END IF
END FUNCTION

SUB Blanker (R1%, R2%, C1%, C2%)
FOR i% = R1% TO R2%
	LOCATE i%, C1%
	FOR J% = C1% TO C2%
		PRINT " ";
	NEXT J%
NEXT i%
END SUB

SUB CIRCUIT (Ins, MXBN%, NFL%, NUMEL%, Mods, EQCM!(), NFAKEN%, NMemo%(), NODEF%(), NODES%(), NREALN%, NUMNOD%, XNODE!(), YNODE!(), Outs, FAILED%, NCOND%, NODCON%(), Work, FMemo%(), EMemo%())
'
'MAKE A LIST (NODCON%()) OF THE NCOND% NODES THAT ARE ON THE BOUNDARY
'AND REQIRE BOUNDARY CONDITIONS; THESE ARE IN COUNTERCLOCKWISE ORDER.
'ALSO MAKES AND USES LOGICAL LISTS OF WHICH ELEMENT SIDES ARE EXTERNAL:
'EMemo%(NUMEL%) AND FMemo%(NFL%).
'
'Technical Note: Outside this routine, the integer arrays
'   NMemo%() and EMemo%()
'   have only the values 1 (True) or 0 (False).
'   This routine will use only the higher (2, 4, and 8) bits,
'   leaving the 0/1 bit unchanged.
'   Integer array FMemo%() may have values 0, 1, 2, or 3 on entry;
'   only the higher (4 and 8) bits are used in this routine.
'   At line CleanUp below, the high bits are returned to 0.
'
	  DropLoose% = 0
	  XMin! = XNODE!(1): XMax! = XMin!
	  CALL Blanker(16, 24, 2, 79)
	  LOCATE 17, 14
	  PRINT "Checking that all nodes belong to some element..."
	  i% = 1
LoopOni:
		  a$ = INKEY$: IF LEN(a$) > 0 THEN GOTO StopShort
		  IF XNODE!(i%) < XMin! THEN XMin! = XNODE!(i%)
		  IF XNODE!(i%) > XMax! THEN XMax! = XNODE!(i%)
		  LOCATE 17, 63: PRINT i%
		  CALL OnAny(Ins, i%, 1, NUMEL%, NODES%(), Outs, ie%, je%)
		  IF ie% = 0 THEN
			  CALL OnAny(Ins, i%, 1, NFL%, NODEF%(), Outs, ie%, je%)
			  IF ie% = 0 THEN
				  IF DropLoose% THEN
					CALL DropNode(Ins, 0, i%, NFL%, NUMEL%, Mods, EQCM!(), NFAKEN%, NMemo%(), NODEF%(), NODES%(), NREALN%, NUMNOD%, XNODE!(), YNODE!())
					i% = i% - 1
				  ELSE
					BEEP
					CALL Blanker(16, 24, 2, 79)
					LOCATE 17, 31
					PRINT "BAD GRID TOPOLOGY."
					LOCATE 19, 21
					PRINT "SOME NODES DO NOT BELONG TO ANY ELEMENT."
					LOCATE 21, 19
					PRINT "(You must either delete them or connect them.)"
					LOCATE 23, 22
					INPUT ; "DO YOU WISH TO DELETE ALL UNUSED NODES"; a$
					IF UCASE$(LEFT$(a$, 1)) = "Y" OR UCASE$(LEFT$(a$, 2)) = "OK" THEN
						DropLoose% = NOT 0
						CALL Blanker(16, 24, 2, 79)
						LOCATE 17, 14
						PRINT "Checking that all nodes belong to some element..."
						GOTO LoopOni
					ELSE
						CALL Blanker(16, 24, 2, 79)
						LOCATE 17, 19
						PRINT "PERIMETER TEST CANNOT BE COMPLETED."
						FAILED% = NOT 0
						GOTO Cleanup
					END IF
				  END IF
			  END IF
		  END IF
	  IF i% < NUMNOD% THEN i% = i% + 1: GOTO LoopOni
	  CALL Blanker(17, 17, 2, 79)
	  LOCATE 17, 19
	  PRINT "Making a list of all boundary nodes:"
	  NCOND% = 0
	  FOR i% = 1 TO NUMEL%
		  FOR J% = 1 TO 3
			  a$ = INKEY$: IF LEN(a$) > 0 THEN GOTO StopShort
			  CALL NEXTto(Ins, i%, J%, NFL%, NODEF%(), NODES%(), NUMEL%, Outs, KFAULT%, KELE%)
			  IF KELE% > 0 THEN
'                    (ORDINARY INTERIOR SIDE)
				  CALL SETBIT(EMemo%(i%), J%, 0)
			  ELSEIF KFAULT% = 0 THEN
'                    (EXTERIOR SIDE)
				  CALL SETBIT(EMemo%(i%), J%, 1)
				  N1% = NODES%((J% MOD 3) + 1, i%)
				  N2% = NODES%((J% MOD 3) + 4, i%)
				  N3% = NODES%(((J% + 1) MOD 3) + 1, i%)
				  IF GETBIT%(NMemo%(N1%), 1) THEN
				  ELSE
					  NCOND% = NCOND% + 1
					  CALL SETBIT(NMemo%(N1%), 1, 1)
					  CALL SETBIT(NMemo%(N1%), 2, 1)
				  END IF
				  IF GETBIT%(NMemo%(N2%), 1) THEN
				  ELSE
					  NCOND% = NCOND% + 1
					  CALL SETBIT(NMemo%(N2%), 1, 1)
					  CALL SETBIT(NMemo%(N2%), 2, 1)
				  END IF
				  IF GETBIT%(NMemo%(N3%), 1) THEN
				  ELSE
					  NCOND% = NCOND% + 1
					  CALL SETBIT(NMemo%(N3%), 1, 1)
					  CALL SETBIT(NMemo%(N3%), 2, 1)
				  END IF
			  ELSE
'                    (TRIANGULAR ELEMENT HAS AN EXTERIOR FAULT ELEMENT
'                     ADJACENT TO IT)
				  CALL SETBIT(EMemo%(i%), J%, 0)
				  N2% = NODES%((J% MOD 3) + 4, i%)
				  IF NODEF%(2, KFAULT%) = N2% THEN
					  CALL SETBIT(FMemo%(KFAULT%), 3, 1)
					  FOR k% = 4 TO 6
						  n% = NODEF%(k%, KFAULT%)
						  IF GETBIT%(NMemo%(n%), 1) THEN
						  ELSE
							  NCOND% = NCOND% + 1
							  CALL SETBIT(NMemo%(n%), 1, 1)
							  CALL SETBIT(NMemo%(n%), 2, 1)
						  END IF
					  NEXT k%
				  ELSE
					  CALL SETBIT(FMemo%(KFAULT%), 2, 1)
					  FOR k% = 1 TO 3
						  n% = NODEF%(k%, KFAULT%)
						  IF GETBIT%(NMemo%(n%), 1) THEN
						  ELSE
							  NCOND% = NCOND% + 1
							  CALL SETBIT(NMemo%(n%), 1, 1)
							  CALL SETBIT(NMemo%(n%), 2, 1)
						  END IF
					  NEXT k%
				  END IF
			  END IF
		  NEXT J%
		  LOCATE 18, 19
		  Ipc% = CINT(100! * CSNG(i%) / CSNG(NUMEL%))
		  PRINT USING "##### nodes found; ###% of search completed."; NCOND%; Ipc%
	  NEXT i%
	  IF NCOND% > MXBN% THEN
		  CALL Blanker(16, 24, 2, 79)
		  LOCATE 16, 4
		  PRINT "NUMBER OF BOUNDARY NODES ("; NCOND%; ") EXCEEDS LIMIT OF "; MXBN%; ".";
		  LOCATE 18, 4
		  PRINT "TEST CANNOT BE COMPLETED."
		  BEEP
		  FAILED% = NOT 0
		  GOTO Cleanup
	  ELSE
		  FAILED% = 0
		  LOCATE 20, 15
		  PRINT "Linking these nodes in order to form the perimeter:"
	  END IF
	  IF NUMNOD% > NREALN% THEN
		  FOR i% = NREALN% + 1 TO NUMNOD%
			  IF GETBIT%(NMemo%(i%), 1) THEN
			  ELSE
				  CALL Blanker(16, 24, 2, 79)
				  LOCATE 16, 4
				  PRINT "BAD GRID TOPOLOGY; FAKE NODES ARE NOT PERMITTED IN THE INTERIOR."
				  LOCATE 18, 4
				  PRINT "Save, eXit, reNUMBER, restart DRAWGRID, and reLoad."
				  LOCATE 20, 4
				  PRINT "(When you reNUMBER, there is an option to convert fake nodes to real.)"
				  BEEP
				  FAILED% = NOT 0
				  GOTO Cleanup
			  END IF
		  NEXT i%
	  END IF
'   BEGIN CIRCUIT WITH LOWEST-NUMBERED BOUNDARY NODE
	  FOR i% = 1 TO NUMNOD%
		  IF GETBIT%(NMemo%(i%), 1) THEN GOTO L831
	  NEXT i%
L831:  NODCON%(1) = i%
	  XPer0! = XNODE!(i%)
	  YPer0! = YNODE!(i%)
	  NDONE% = 1
	  NLEFT% = NCOND%
'      BEGINNING OF INDEFINATE LOOP WHICH TRACES AROUND THE PERIMETER.
'      EACH TIME, IT PROGRESSES BY ONE OF 3 STEPS:
'      -2 NODES AT A TIME ALONG A TRIANGLE SIDE, OR
'      -2 NODES AT A TIME ALONG A FAULT ELEMENT SIDE, OR
'      -BY FINDING ANOTHER (CORNER) NODE WHICH SHARES THE SAME LOCATION.
'
'      FIRST, BE SURE THAT WE ARE NOT STARTING ON A MIDPOINT:
	  CALL OnAny(Ins, i%, 1, NUMEL%, NODES%(), Outs, ie%, je%)
	  IF ie% > 0 THEN  'we are on a continuum element side
		  IF je% >= 4 THEN  'we are at midpoint; step to end of side
			  je% = je% - 2: IF je% = 4 THEN je% = 1
			  J% = NODES%(je%, ie%)
			  NDONE% = 2
			  NODCON%(2) = J%
			  NLEFT% = NCOND% - 1
		  END IF
	  ELSE   'we are on a boundary fault, on the outside
		  CALL OnAny(Ins, i%, 1, NFL%, NODEF%(), Outs, ie%, je%)
		  IF (je% = 2) OR (je% = 5) THEN
			  je% = je% + 1
			  J% = NODEF%(je%, ie%)
			  NDONE% = 2
			  NODCON%(2) = J%
			  NLEFT% = NCOND% - 1
		  END IF
	  END IF
'
'      BEGINNING OF MAIN INDEFINATE LOOP:
L840:  NODE% = NODCON%(NDONE%)
		  a$ = INKEY$: IF LEN(a$) > 0 THEN GOTO StopShort
		  'check that we have not already counted this node!
		  IF NDONE% > 1 THEN
			  FOR J% = 1 TO NDONE% - 1
				  IF NODE% = NODCON%(J%) THEN
					  CALL Blanker(16, 24, 2, 79)
					  LOCATE 17, 31
					  PRINT "BAD GRID TOPOLOGY."
					  LOCATE 18, 10
					  PRINT "CAME BACK TO INITIAL NODE BEFORE LINKING ALL BOUNDARY NODES;"
					  LOCATE 19, 26
					  PRINT "GRID IS NOT SIMPLY-CONNECTED;"
					  LOCATE 20, 3
					  PRINT "IT HAS EITHER SOME GAP(S) OR OVERLAP(S) INSIDE, OR SOME ISLAND(S) OUTSIDE."
					  BEEP
					  LOCATE 22, 7
					  PRINT "A special basemap file, BADNODES.DIG, is being created to show the"
					  LOCATE 23, 7
					  PRINT "locations of the 'extra' external nodes ..... (Working)"
					  BoxSize! = .01 * (XMax! - XMin!)
					  OPEN "BADNODES.DIG" FOR OUTPUT AS #4 LEN = 128
						  FOR i% = 1 TO NUMNOD%
							  IF GETBIT%(NMemo%(i%), 2) THEN
								  NODE% = i%
								  OK% = 0  'false
								  FOR k% = 1 TO NDONE% - 1
									  IF NODE% = NODCON%(k%) THEN
										  OK% = NOT 0 'true
									  END IF
								  NEXT k%
								  PRINT #4, USING "Boundary node ##### at (+#.###^^^^_,+#.###^^^^)"; NODE%; XNODE!(NODE%); YNODE!(NODE%)
								  IF OK% THEN
									  PRINT #4, USING " +#.#####^^^^_,+#.#####^^^^"; XNODE!(NODE%) - BoxSize!; YNODE!(NODE%) + BoxSize!
									  PRINT #4, USING " +#.#####^^^^_,+#.#####^^^^"; XNODE!(NODE%) - BoxSize!; YNODE!(NODE%) - BoxSize!
									  PRINT #4, USING " +#.#####^^^^_,+#.#####^^^^"; XNODE!(NODE%) + BoxSize!; YNODE!(NODE%) - BoxSize!
									  PRINT #4, USING " +#.#####^^^^_,+#.#####^^^^"; XNODE!(NODE%) + BoxSize!; YNODE!(NODE%) + BoxSize!
									  PRINT #4, USING " +#.#####^^^^_,+#.#####^^^^"; XNODE!(NODE%) - BoxSize!; YNODE!(NODE%) + BoxSize!
									  PRINT #4, "*** end of line segment ***"
								  ELSE
									  PRINT #4, USING " +#.#####^^^^_,+#.#####^^^^"; XNODE!(NODE%) - BoxSize!; YNODE!(NODE%)
									  PRINT #4, USING " +#.#####^^^^_,+#.#####^^^^"; XNODE!(NODE%) + BoxSize!; YNODE!(NODE%)
									  PRINT #4, "*** end of line segment ***"
									  PRINT #4, USING "Boundary node #####_, continued"; NODE%
									  PRINT #4, USING " +#.#####^^^^_,+#.#####^^^^"; XNODE!(NODE%); YNODE!(NODE%) + BoxSize!
									  PRINT #4, USING " +#.#####^^^^_,+#.#####^^^^"; XNODE!(NODE%); YNODE!(NODE%) - BoxSize!
									  PRINT #4, "*** end of line segment ***"
								  END IF
							  END IF
						  NEXT i%
					  CLOSE #4
					  LOCATE 23, 7
					  PRINT "locations of the 'extra' external nodes ..... DONE.  Press Enter <Ù"
					  FAILED% = NOT 0
					  GOTO Cleanup
				  END IF
			  NEXT J%
		  END IF
		  LOCATE 21, 15
		  Ipc% = CINT(100! * CSNG(NDONE%) / CSNG(NCOND%))
		  PRINT USING "##### nodes linked; ###% of perimeter completed."; NDONE%; Ipc%
		  X! = XNODE!(NODE%)
		  Y! = YNODE!(NODE%)
'           LOOK FOR AN ADJACENT TRIANGULAR ELEMENT USING THIS NODE.
		  FOR i% = 1 TO NUMEL%
			  FOR J% = 1 TO 3
				  IF GETBIT%(EMemo%(i%), J%) THEN
					  N1% = NODES%((J% MOD 3) + 1, i%)
					  IF N1% = NODE% GOTO L846
				  END IF
			  NEXT J%
		  NEXT i%
		  GOTO L850
L846:       N2% = NODES%((J% MOD 3) + 4, i%)
		  NDONE% = NDONE% + 1
		  IF NDONE% <= NCOND% THEN NODCON%(NDONE%) = N2%
		  CALL SETBIT(NMemo%(N2%), 1, 0)
		  N3% = NODES%(((J% + 1) MOD 3) + 1, i%)
		  NDONE% = NDONE% + 1
		  IF NDONE% <= NCOND% THEN NODCON%(NDONE%) = N3%
		  CALL SETBIT(NMemo%(N3%), 1, 0)
		  NLEFT% = NLEFT% - 2
		  IF NLEFT% > 0 THEN
			  GOTO L840
		  ELSE
			  GOTO L870
		  END IF
'           ELSE, LOOK FOR AN ADJACENT FAULT ELEMENT USING THIS NODE.
L850:       FOR i% = 1 TO NFL%
			  IF GETBIT%(FMemo%(i%), 2) THEN
				  IF NODEF%(1, i%) = NODE% THEN
					  N2% = NODEF%(2, i%)
					  N3% = NODEF%(3, i%)
					  GOTO L856
				  END IF
			  ELSEIF GETBIT%(FMemo%(i%), 3) THEN
				  IF NODEF%(4, i%) = NODE% THEN
					  N2% = NODEF%(5, i%)
					  N3% = NODEF%(6, i%)
					  GOTO L856
				  END IF
			  END IF
		  NEXT i%
		  GOTO L860
L856:       NDONE% = NDONE% + 1
		  IF NDONE% <= NCOND% THEN NODCON%(NDONE%) = N2%
		  CALL SETBIT(NMemo%(N2%), 1, 0)
		  NDONE% = NDONE% + 1
		  IF NDONE% <= NCOND% THEN NODCON%(NDONE%) = N3%
		  CALL SETBIT(NMemo%(N3%), 1, 0)
		  NLEFT% = NLEFT% - 2
		  IF NLEFT% > 0 THEN
			  GOTO L840
		  ELSE
			  GOTO L870
		  END IF
'           ELSE, LOOK FOR ANOTHER EXTERIOR CORNER NODE AT SAME LOCATION.
L860:       FOR i% = 1 TO NUMNOD%
			  IF (i% <> NODE%) AND GETBIT%(NMemo%(i%), 1) THEN
				  CALL OnAny(Ins, i%, 1, NUMEL%, NODES%(), Outs, ie%, je%)
				  IF je% <= 3 AND ((XNODE!(i%) = X!) AND (YNODE!(i%) = Y!)) THEN GOTO L867
			  END IF
		  NEXT i%
		  CALL Blanker(16, 24, 2, 79)
		  LOCATE 16, 10: PRINT "BAD GRID TOPOLOGY: WHILE TRACING PERIMETER,"
		  LOCATE 17, 10: PRINT "COULD NOT FIND ANY WAY TO CONTINUE,"
		  LOCATE 18, 10: PRINT "EITHER THROUGH SHARED BOUNDARY ELEMENTS, OR"
		  LOCATE 19, 10: PRINT "THROUGH OTHER BOUNDARY NODES SHARING THE SAME POSITION."
		  LOCATE 21, 10: PRINT "Search began at ("; XPer0!; ","; YPer0!; ") with node "; NODCON%(1);
		  LOCATE 22, 10: PRINT "circled around the perimeter in the counterclockwise direction,";
		  LOCATE 23, 10: PRINT "and failed at ("; X!; ","; Y!; ") with node"; NODE%; ".";
		  BEEP
		  FAILED% = NOT 0
		  GOTO Cleanup
L867:       NDONE% = NDONE% + 1
		  IF NDONE% <= NCOND% THEN NODCON%(NDONE%) = i%
		  CALL SETBIT(NMemo%(i%), 1, 0)
		  NLEFT% = NLEFT% - 1
	  IF NLEFT% > 0 GOTO L840
'      END OF INDEFINATE LOOP WHICH TRACES AROUND PERIMETER.
L870:  LOCATE 21, 15
	  PRINT USING "##### nodes linked; 100% of perimeter completed."; NCOND%
'-----------------------------------------------------------------
Cleanup:
		'restore work arrays to their original bit values (0 or 1):
		FOR i% = 1 TO NUMNOD%
			NMemo%(i%) = NMemo%(i%) MOD 2
		NEXT i%
		FOR i% = 1 TO NUMEL%
			EMemo%(i%) = EMemo%(i%) MOD 2
		NEXT i%
		FOR i% = 1 TO NFL%
			FMemo%(i%) = FMemo%(i%) MOD 4
		NEXT i%
		EXIT SUB
'-----------------------------------------
StopShort:
FAILED% = NOT 0
CALL Blanker(16, 24, 2, 79)
LOCATE 18, 21
PRINT "PERIMETER TEST WAS INTERRUPTED BY USER."
LOCATE 20, 24
PRINT "Press any key to return to menu."
GOTO Cleanup
'------------------------------------------
END SUB

SUB Delay18th (n%)
'delay for n%/18 seconds
Start! = TIMER
StopAt! = Start! + CSNG(n%) / 18!
TimeNow! = TIMER
DO WHILE TimeNow! < StopAt!
	TimeNow! = TIMER
LOOP
EXIT SUB
END SUB

SUB DERIV (Ins, i%, NODES%(), POINTS!(), XNODE!(), YNODE!(), Outs, EMemo%)
'   CALCULATES DETMIN, THE MINIMUM VALUE (OVER THE 7
'   INTERNAL INTEGRATION POINTS) OF THE DETERMINANT OF THE
'   JACOBIAN MATRIX FOR THE TRANSFORMATION FROM INTERNAL
'   TO EXTERNAL COORDINATES, ASSUMING THAT TRIANGLE HAS
'   AN AREA OF ONE.
DIM B!(4), c!(4), DN!(6, 2), X!(6), Y!(6)
DetMin! = 3.3E+38
FOR J% = 1 TO 6
	NODE% = NODES%(J%, i%)
	X!(J%) = XNODE!(NODE%)
	Y!(J%) = YNODE!(NODE%)
NEXT J%
B!(1) = Y!(2) - Y!(3)
B!(2) = Y!(3) - Y!(1)
B!(3) = Y!(1) - Y!(2)
B!(4) = B!(1)
c!(1) = X!(3) - X!(2)
c!(2) = X!(1) - X!(3)
c!(3) = X!(2) - X!(1)
c!(4) = c!(1)
FOR m% = 1 TO 7
	FOR J% = 1 TO 3
		DN!(J%, 1) = B!(J%) * (4! * POINTS!(J%, m%) - 1!)
		DN!(J% + 3, 1) = 4! * (B!(J%) * POINTS!(J% + 1, m%) + B!(J% + 1) * POINTS!(J%, m%))
		DN!(J%, 2) = c!(J%) * (4! * POINTS!(J%, m%) - 1!)
		DN!(J% + 3, 2) = 4! * (c!(J%) * POINTS!(J% + 1, m%) + c!(J% + 1) * POINTS!(J%, m%))
	NEXT J%
	AJ11! = 0!: AJ12! = 0!: AJ21! = 0!: AJ22! = 0!
	FOR J% = 1 TO 6
		AJ11! = AJ11! + DN!(J%, 1) * X!(J%)
		AJ12! = AJ12! + DN!(J%, 1) * Y!(J%)
		AJ21! = AJ21! + DN!(J%, 2) * X!(J%)
		AJ22! = AJ22! + DN!(J%, 2) * Y!(J%)
	NEXT J%
	DETJAC! = AJ11! * AJ22! - AJ12! * AJ21!
	IF DETJAC! < DetMin! THEN DetMin! = DETJAC!
NEXT m%
IF DetMin! > 0! THEN
	Area! = .5 * (B!(3) * c!(1) - B!(1) * c!(3))
	IF Area! > 0! THEN
		EMemo% = 0
	ELSE
		EMemo% = 1
	END IF
ELSE
	EMemo% = 1
END IF
END SUB

SUB DrawBase (Blue%, ColOldBase%, RowOldBase%, XOldBase!)
GET #3, , XBASE!
GET #3, , YBASE!
IF XOldBase! = -.12345 THEN
	IF XBASE! = -.12345 THEN
		'consecutive end marks; do nothing
	ELSE  'start new segment with single point
		CALL Pixels(Ins, XBASE!, YBASE!, Outs, ColBase%, RowBase%)
		IF Colored% THEN
			PSET (ColBase%, RowBase%), Blue%
		ELSE
			PSET (ColBase%, RowBase%)
		END IF
	END IF
ELSE
	IF XBASE! = -.12345 THEN
		'segment is over; do nothing
	ELSE
		CALL Pixels(Ins, XBASE!, YBASE!, Outs, ColBase%, RowBase%)
		IF Colored% THEN
			LINE (ColOldBase%, RowOldBase%)-(ColBase%, RowBase%), Blue%
		ELSE
			LINE (ColOldBase%, RowOldBase%)-(ColBase%, RowBase%)
		END IF
	END IF
END IF
XOldBase! = XBASE!
ColOldBase% = ColBase%
RowOldBase% = RowBase%
END SUB

SUB DrawElement (BotF!, ColorIn%, Contour%, DFC!, EMemo%(), EQCM!(), i%, IData%, Logs%, NMemo%(), NODES%(), Redo%, UseColor%, XNODE!(), YNODE!())
DIM ECol%(6), ECol!(6), ERow%(6), ERow!(6), EValues!(6)
k1% = NODES%(1, i%)
k2% = NODES%(2, i%)
k3% = NODES%(3, i%)
k4% = NODES%(4, i%)
k5% = NODES%(5, i%)
k6% = NODES%(6, i%)
DX! = XNODE!(k1%) - XCenter!
DY! = YNODE!(k1%) - YCenter!
R21! = DX! * DX! + DY! * DY!
DX! = XNODE!(k2%) - XCenter!
DY! = YNODE!(k2%) - YCenter!
R22! = DX! * DX! + DY! * DY!
DX! = XNODE!(k3%) - XCenter!
DY! = YNODE!(k3%) - YCenter!
R23! = DX! * DX! + DY! * DY!
IF (R21! < R2C!) OR (R22! < R2C!) OR (R23! < R2C!) THEN
	FOR k% = 1 TO 6
		CALL Pixels(Ins, XNODE!(NODES%(k%, i%)), YNODE!(NODES%(k%, i%)), Outs, ECol%(k%), ERow%(k%))
		ECol!(k%) = ECol%(k%)
		ERow!(k%) = ERow%(k%)
	NEXT k%
'GPB
	IF Contour% THEN
		  RSteps! = .55 * (ABS(ERow%(1) - ERow%(2)) + ABS(ERow%(2) - ERow%(3)) + ABS(ERow%(3) - ERow%(1)))
		  CSteps! = .55 * (ABS(ECol%(1) - ECol%(2)) + ABS(ECol%(2) - ECol%(3)) + ABS(ECol%(3) - ECol%(1)))
		  IF RSteps! < 3! THEN RSteps! = 3
		  IF CSteps! < 3! THEN CSteps! = 3
		  RStepsize! = 1! / RSteps!
		  CStepsize! = 1! / CSteps!
		  Stepsize! = RStepsize!
		  IF CStepsize! < RStepsize! THEN Stepsize! = CStepsize!
		  MouseHide
		  FOR k% = 1 TO 6
			EValues!(k%) = EQCM!(IData%, NODES%(k%, i%))
		  NEXT k%
		  FOR s1! = 0! TO 1! STEP Stepsize!
			FOR s2! = 0! TO 1! STEP Stepsize!
				s3! = 1! - s1! - s2!
				IF (s3! >= 0!) THEN
					CALL Interpolate(Ins, s1!, s2!, s3!, ERow!(), Outs, row!)
					row% = row! + .5
					IF ((row% >= 0) AND (row% <= HiRow%)) THEN
						CALL Interpolate(Ins, s1!, s2!, s3!, ECol!(), Outs, column!)
						column% = column! + .5
						IF ((column% >= 0) AND (column% <= HiCol%)) THEN
							CALL Interpolate(Ins, s1!, s2!, s3!, EValues!(), Outs, F!)
							IF Logs% THEN
								IF F! > 0! THEN
									F! = LOG(F!) / LOG(10#)
								ELSE
									F! = BotF!
								END IF
							END IF 'Logs%
							index% = INT(2! + (F! - BotF!) / DFC!)
							IF ((index% >= 0) AND (index% <= HiColor%)) THEN
								PSET (column%, row%), index%
							ELSE
								PSET (column%, row%), 0
							END IF 'legal color, or not
						END IF 'legal column
					END IF 'legal row
				ELSE
					GOTO JumpOut
				END IF 's3! >= 0.0, or not
			NEXT s2!
JumpOut:
		  NEXT s1!
		  MouseShow
	END IF 'Contour%
	FOR k% = 4 TO 6 'draw sides
		KA% = k% - 3
		KB% = ((k% - 3) MOD 3) + 1
		IF NMemo%(NODES%(k%, i%)) THEN  'a straight side
			IF Colored% THEN
				LINE (ECol%(KA%), ERow%(KA%))-(ECol%(KB%), ERow%(KB%)), UseColor%
			ELSE
				IF UseColor% THEN
					LINE (ECol%(KA%), ERow%(KA%))-(ECol%(KB%), ERow%(KB%)), , , &HF0F0
				ELSE
					LINE (ECol%(KA%), ERow%(KA%))-(ECol%(KB%), ERow%(KB%)), 0, , &HF0F0
				END IF
			END IF
		ELSE  'a curved side
			X1! = XNODE!(NODES%(KA%, i%))
			Y1! = YNODE!(NODES%(KA%, i%))
			X2! = XNODE!(NODES%(k%, i%))
			Y2! = YNODE!(NODES%(k%, i%))
			X3! = XNODE!(NODES%(KB%, i%))
			Y3! = YNODE!(NODES%(KB%, i%))
			SB! = 0!
			ColA% = ECol%(KA%)
			RowA% = ERow%(KA%)
			FOR n% = 1 TO 6
				SA! = SB!
				SB! = n% * .166667
				F1! = 1! - 3! * SB! + 2! * SB! * SB!
				F2! = 4! * SB! * (1! - SB!)
				F3! = -SB! + 2! * SB! * SB!
				X! = F1 * X1! + F2! * X2! + F3! * X3!
				Y! = F1 * Y1! + F2! * Y2! + F3! * Y3!
				CALL Pixels(Ins, X!, Y!, Outs, ColB%, RowB%)
				IF Colored% THEN
					LINE (ColA%, RowA%)-(ColB%, RowB%), UseColor%
				ELSE
					IF UseColor% THEN
						LINE (ColA%, RowA%)-(ColB%, RowB%), , , &HF0F0
					ELSE
						LINE (ColA%, RowA%)-(ColB%, RowB%), 0, , &HF0F0
					END IF
				END IF
				ColA% = ColB%
				RowA% = RowB%
			NEXT n%
		END IF
	NEXT k%
	'add a schematic triangle at the center point, to click on?
	IF DoIcon% THEN
		ColC% = ((ECol%(1) + ECol%(2) + ECol%(3)) / 3) - 3
		RowC% = ((ERow%(1) + ERow%(2) + ERow%(3)) / 3) - 3
		IF ColC% >= 0 AND ColC% <= LastPutC% THEN
			IF RowC% >= 0 AND RowC% <= LastPutR% THEN
				IF EMemo%(i%) THEN
					IF UseColor% THEN
						PUT (ColC%, RowC%), Icon2%, PSET
					ELSE
						PUT (ColC%, RowC%), Icon2%, XOR
					END IF
				ELSE
					IF UseColor% THEN
						PUT (ColC%, RowC%), Icon1%, PSET
					ELSE
						PUT (ColC%, RowC%), Icon1%, XOR
					END IF
				END IF
			END IF
		END IF
	END IF 'DoIcon%
	IF ColorIn% THEN
		CALL RaiseOne(Ins, i%, NODES%(), XNODE!(), YNODE!())
	END IF
END IF
END SUB

SUB DrawFault (FAZ!(), FDIP!(), FMemo%(), i%, NMemo%(), NODEF%(), UseColor%, XNODE!(), YNODE!())
DIM ECol%(3), ERow%(3)
k1% = NODEF%(1, i%)
k2% = NODEF%(2, i%)
k3% = NODEF%(3, i%)
X1! = XNODE!(k1%)
Y1! = YNODE!(k1%)
X2! = XNODE!(k2%)
Y2! = YNODE!(k2%)
X3! = XNODE!(k3%)
Y3! = YNODE!(k3%)
DX! = XNODE!(k1%) - XCenter!
DY! = YNODE!(k1%) - YCenter!
R21! = DX! * DX! + DY! * DY!
DX! = XNODE!(k3%) - XCenter!
DY! = YNODE!(k3%) - YCenter!
R23! = DX! * DX! + DY! * DY!
IF (R21! > R2C!) AND (R23! > R2C!) THEN EXIT SUB
CALL Pixels(Ins, XNODE!(k1%), YNODE!(k1%), Outs, ECol%(1), ERow%(1))
IF NMemo%(k2%) THEN  'a straight fault
	CALL Pixels(Ins, XNODE!(k3%), YNODE!(k3%), Outs, ECol%(3), ERow%(3))
	IF Colored% THEN
		LINE (ECol%(1), ERow%(1))-(ECol%(3), ERow%(3)), UseColor%
	ELSE
		IF UseColor% THEN
			LINE (ECol%(1), ERow%(1))-(ECol%(3), ERow%(3))
		ELSE
			LINE (ECol%(1), ERow%(1))-(ECol%(3), ERow%(3)), 0
		END IF
	END IF
ELSE  'a curved side
	SB! = 0!
	ColA% = ECol%(1)
	RowA% = ERow%(1)
	FOR n% = 1 TO 6
		SA! = SB!
		SB! = n% * .166667
		F1! = 1! - 3! * SB! + 2! * SB! * SB!
		F2! = 4! * SB! * (1! - SB!)
		F3! = -SB! + 2! * SB! * SB!
		X! = F1! * X1! + F2! * X2! + F3! * X3!
		Y! = F1! * Y1! + F2! * Y2! + F3! * Y3!
		CALL Pixels(Ins, X!, Y!, Outs, ColB%, RowB%)
		IF Colored% THEN
			LINE (ColA%, RowA%)-(ColB%, RowB%), UseColor%
		ELSE
			IF UseColor% THEN
				LINE (ColA%, RowA%)-(ColB%, RowB%)
			ELSE
				LINE (ColA%, RowA%)-(ColB%, RowB%), 0
			END IF
		END IF
		ColA% = ColB%
		RowA% = RowB%
	NEXT n%
END IF
'plot 4 dip symbols, where they won't overlap the nodes
DX! = X3! - X1!
DY! = Y3! - Y1!
Size! = .1 * SQR(DX! * DX! + DY! * DY!)
FOR m% = 1 TO 4
	s! = FIPoint!(m%)
	F1! = 1! - 3! * s! + 2! * s! * s!
	F2! = 4! * s! * (1! - s!)
	F3! = -s! + 2! * s! * s!
	Dip! = FDIP!(1, i%) * F1! + FDIP!(2, i%) * F2! + FDIP!(3, i%) * F3!
	ADip! = 90! - ABS(Dip! - 90!)
	IF ADip! < 76! THEN
		X! = F1! * X1! + F2! * X2! + F3! * X3!
		Y! = F1! * Y1! + F2! * Y2! + F3! * Y3!
		DF1DS! = 4! * s! - 3!
		DF2DS! = -8! * s! + 4!
		DF3DS! = 4! * s! - 1!
		DXDS! = DF1DS! * X1! + DF2DS! * X2! + DF3DS! * X3!
		DYDS! = DF1DS! * Y1! + DF2DS! * Y2! + DF3DS! * Y3!
		Arg! = ATAN2F!(DYDS!, DXDS!)
		IF Dip! < 90! THEN
			Normal! = Arg! - 1.5714
		ELSE
			Normal! = Arg! + 1.5714
		END IF
		IF ADip! > 55! THEN 'steep fault
			CALL Pixels(Ins, X!, Y!, Outs, ColA%, RowA%)
			XP! = X! + Size! * COS(Normal!)
			YP! = Y! + Size! * SIN(Normal!)
			CALL Pixels(Ins, XP!, YP!, Outs, ColB%, RowB%)
			IF Colored% THEN
				LINE (ColA%, RowA%)-(ColB%, RowB%), UseColor%
			ELSE
				IF UseColor% THEN
					LINE (ColA%, RowA%)-(ColB%, RowB%)
				ELSE
					LINE (ColA%, RowA%)-(ColB%, RowB%), 0
				END IF
			END IF
		ELSEIF ADip! > 35! THEN 'intermediate dip
			XP! = X! + .5 * Size! * COS(Arg!)
			YP! = Y! + .5 * Size! * SIN(Arg!)
			CALL Pixels(Ins, XP!, YP!, Outs, ColA%, RowA%)
			XP! = XP! + Size! * COS(Normal!)
			YP! = YP! + Size! * SIN(Normal!)
			CALL Pixels(Ins, XP!, YP!, Outs, ColB%, RowB%)
			IF Colored% THEN
				LINE (ColA%, RowA%)-(ColB%, RowB%), UseColor%
			ELSE
				IF UseColor% THEN
					LINE (ColA%, RowA%)-(ColB%, RowB%)
				ELSE
					LINE (ColA%, RowA%)-(ColB%, RowB%), 0
				END IF
			END IF
			XP! = XP! - Size! * COS(Arg!)
			YP! = YP! - Size! * SIN(Arg!)
			CALL Pixels(Ins, XP!, YP!, Outs, ColA%, RowA%)
			IF Colored% THEN
				LINE -(ColA%, RowA%), UseColor%
			ELSE
				IF UseColor% THEN
					LINE -(ColA%, RowA%)
				ELSE
					LINE -(ColA%, RowA%), 0
				END IF
			END IF
			XP! = XP! - Size! * COS(Normal!)
			YP! = YP! - Size! * SIN(Normal!)
			CALL Pixels(Ins, XP!, YP!, Outs, ColA%, RowA%)
			IF Colored% THEN
				LINE -(ColA%, RowA%), UseColor%
			ELSE
				IF UseColor% THEN
					LINE -(ColA%, RowA%)
				ELSE
					LINE -(ColA%, RowA%), 0
				END IF
			END IF
		ELSE 'shallow dip
			XP! = X! + .5 * Size! * COS(Arg!)
			YP! = Y! + .5 * Size! * SIN(Arg!)
			CALL Pixels(Ins, XP!, YP!, Outs, ColA%, RowA%)
			XP! = X! + Size! * COS(Normal!)
			YP! = Y! + Size! * SIN(Normal!)
			CALL Pixels(Ins, XP!, YP!, Outs, ColB%, RowB%)
			IF Colored% THEN
				LINE (ColA%, RowA%)-(ColB%, RowB%), UseColor%
			ELSE
				IF UseColor% THEN
					LINE (ColA%, RowA%)-(ColB%, RowB%)
				ELSE
					LINE (ColA%, RowA%)-(ColB%, RowB%), 0
				END IF
			END IF
			XP! = X! - .5 * Size! * COS(Arg!)
			YP! = Y! - .5 * Size! * SIN(Arg!)
			CALL Pixels(Ins, XP!, YP!, Outs, ColA%, RowA%)
			IF Colored% THEN
				LINE -(ColA%, RowA%), UseColor%
			ELSE
				IF UseColor% THEN
					LINE -(ColA%, RowA%)
				ELSE
					LINE -(ColA%, RowA%), 0
				END IF
			END IF
		END IF
	END IF
NEXT m%
'mark Joined ends with boxes
IF GETBIT(FMemo%(i%), 0) THEN  'N1/N6 end
	col% = ECol%(1)
	row% = ERow%(1)
	Arg! = Principal!(FAZ(1, i%))
	GOSUB DrawBox
END IF
IF GETBIT(FMemo%(i%), 1) THEN  'N3/N4 end
	CALL Pixels(Ins, X3!, Y3!, Outs, ECol%(3), ERow%(3))
	col% = ECol%(3)
	row% = ERow%(3)
	Arg! = Principal!(FAZ(2, i%))
	GOSUB DrawBox
END IF
EXIT SUB
DrawBox:
AP! = Arg! + .46365 - Argument!
AM! = Arg! - .46365 - Argument!
DCP% = CINT(10! * COS(AP!))
DCM% = CINT(10! * COS(AM!))
DRP% = CINT(-7! * SIN(AP!))
DRM% = CINT(-7! * SIN(AM!))
IF Colored% THEN
	LINE (col% + DCM%, row% + DRM%)-(col% + DCP%, row% + DRP%), UseColor%
	LINE -(col% - DCM%, row% - DRM%), UseColor%
	LINE -(col% - DCP%, row% - DRP%), UseColor%
	LINE -(col% + DCM%, row% + DRM%), UseColor%
ELSE
	IF UseColor% THEN
		LINE (col% + DCM%, row% + DRM%)-(col% + DCP%, row% + DRP%)
		LINE -(col% - DCM%, row% - DRM%)
		LINE -(col% - DCP%, row% - DRP%)
		LINE -(col% + DCM%, row% + DRM%)
	ELSE
		LINE (col% + DCM%, row% + DRM%)-(col% + DCP%, row% + DRP%), 0
		LINE -(col% - DCM%, row% - DRM%), 0
		LINE -(col% - DCP%, row% - DRP%), 0
		LINE -(col% + DCM%, row% + DRM%), 0
	END IF
END IF
RETURN
END SUB

SUB DrawNode (n%, UseColor%, XNODE!(), YNODE!())
DX! = XNODE!(n%) - XCenter!
DY! = YNODE!(n%) - YCenter!
R2! = DX! * DX! + DY! * DY!
IF R2! < R2C! THEN
	CALL Pixels(Ins, XNODE!(n%), YNODE!(n%), Outs, col%, row%)
	IF Colored% THEN
		CIRCLE (col%, row%), 3, UseColor%
	ELSE
		IF UseColor% THEN
			CIRCLE (col%, row%), 3
		ELSE
			CIRCLE (col%, row%), 3, 0
		END IF
	END IF
END IF
END SUB

SUB DropNode (Ins, AKA%, n%, NFL%, NUMEL%, Mods, EQCM!(), NFAKEN%, NMemo%(), NODEF%(), NODES%(), NREALN%, NUMNOD%, XNODE!(), YNODE!())
'eliminate node n%; if it occurs in element/fault lists, replace with AKA%
'(AKA% is the OLD alias, before any renumbering.)
NUMNOD% = NUMNOD% - 1
IF n% <= NREALN% THEN
	NREALN% = NREALN% - 1
ELSEIF NFAKEN% > 0 THEN
	NFAKEN% = NFAKEN% - 1
ELSE
	BEEP
	EXIT SUB
END IF
FOR k% = n% TO NUMNOD%
	NMemo%(k%) = NMemo%(k% + 1)
	XNODE!(k%) = XNODE!(k% + 1)
	YNODE!(k%) = YNODE!(k% + 1)
	EQCM!(1, k%) = EQCM!(1, k% + 1)
	EQCM!(2, k%) = EQCM!(2, k% + 1)
	EQCM!(3, k%) = EQCM!(3, k% + 1)
	IF Mantle% THEN EQCM!(4, k%) = EQCM!(4, k% + 1)
NEXT k%
FOR k% = 1 TO 6
	FOR J% = 1 TO NUMEL%
		IF NODES%(k%, J%) = n% THEN NODES%(k%, J%) = AKA%
		IF NODES%(k%, J%) > n% THEN NODES%(k%, J%) = NODES%(k%, J%) - 1
	NEXT J%
	FOR J% = 1 TO NFL%
		IF NODEF%(k%, J%) = n% THEN NODEF%(k%, J%) = AKA%
		IF NODEF%(k%, J%) > n% THEN NODEF%(k%, J%) = NODEF%(k%, J%) - 1
	NEXT J%
NEXT k%
END SUB

SUB Exists (Ins, N1%, NUMNOD%, X!, XNODE!(), Y!, YNODE!(), Tolerance!, Outs, n%)
'check whether a node already exists at location and return number (or 0)
'testing begins with node N1, to allow for repeat calls, finding more than 1.
R2Min! = 3E+38
FOR i% = N1% TO NUMNOD%
	DX! = X! - XNODE!(i%)
	DY! = Y! - YNODE!(i%)
	R2! = DX! * DX! + DY! * DY!
	IF R2! < R2Min! THEN
		R2Min! = R2!
		iClose% = i%
	END IF
NEXT i%
RMin! = SQR(R2Min!)
IF RMin! <= Tolerance! THEN
	n% = iClose%
ELSE
	n% = 0
END IF
END SUB

SUB Finish (FileNum%)
'guaruntees that a whole line has been read from file #FileNum%,
'and that there are no remaining blanks, comments, etc. to confuse
'the next INPUT#FileNum instruction.
n& = SEEK(FileNum%)
SEEK #FileNum%, n& - 1&   'back up one byte
a$ = INPUT$(1, #FileNum%) ' get another copy of last byte read
IF ASC(a$) <> 10 THEN LINE INPUT #FileNum%, Dummy$
END SUB

SUB GetArgs (Ins, i%, NODEF%(), XNODE!(), YNODE!(), Outs, FAZ!())
'compute fault element i% azimuths from locations of node N1%,N2%,N3%
N1% = NODEF%(1, i%)
N2% = NODEF%(2, i%)
N3% = NODEF%(3, i%)
X1! = XNODE!(N1%): Y1! = YNODE!(N1%)
X2! = XNODE!(N2%): Y2! = YNODE!(N2%)
X3! = XNODE!(N3%): Y3! = YNODE!(N3%)
DXDS! = -3! * X1! + 4! * X2! - X3!
DYDS! = -3! * Y1! + 4! * Y2! - Y3!
FAZ!(1, i%) = Principal!(ATAN2F!(DYDS!, DXDS!))
DXDS! = X1! - 4! * X2! + 3! * X3!
DYDS! = Y1! - 4! * Y2! + 3! * Y3!
FAZ!(2, i%) = Principal!(ATAN2F!(DYDS!, DXDS!))
END SUB

FUNCTION GETBIT% (NUMBER%, PLACE%)
'RETURNS 0 (False) OR -1 (True) FROM THE 2**PLACE% POSITION, IN NUMBER%
IF (NUMBER% AND CINT(2 ^ PLACE%)) THEN
	GETBIT% = -1
ELSE
	GETBIT% = 0
END IF
END FUNCTION

SUB GetFileName (Text$, LineN%, NewName$)
GetFileN:
LOCATE LineN%, 3: PRINT Text$;
LOCATE LineN%, LEN(Text$) + 3: PRINT "        ";
LOCATE LineN%, LEN(Text$) + 3: INPUT ; "", FileN$
IF LEN(FileN$) < 1 OR LEN(FileN$) > 8 THEN GOTO GetFileN
NewName$ = ""
FOR i% = 1 TO LEN(FileN$)
	T$ = MID$(FileN$, i%, 1)
	T% = ASC(T$)
	OK1% = (T% = 33) OR ((T% >= 35) AND (T% <= 41))  '!#$%&()
	OK2% = (T% = 44) OR (T% = 45)     ',-
	OK3% = (T% >= 48) AND (T% <= 57)  '0123456789
	OK4% = (T% >= 64) AND (T% <= 90)  '@ABC...XYZ
	OK5% = (T% >= 97) AND (T% <= 123)  'abc...xyz{
	OK6% = (T% = 125) OR (T% = 126)    '}~
	OK% = OK1% OR OK2% OR OK3% OR OK4% OR OK5% OR OK6%
	IF OK5% THEN T$ = UCASE$(T$)
	IF OK% THEN NewName$ = NewName$ + T$ ELSE NewName$ = NewName$ + "_"
NEXT i%
LOCATE LineN%, LEN(Text$) + 3: PRINT "        ";
LOCATE LineN%, LEN(Text$) + 3: PRINT NewName$;
WaitTime! = 1!: StartTime! = TIMER: DO: TimeNow! = TIMER: LOOP UNTIL (TimeNow! - StartTime!) > WaitTime!
END SUB

SUB GetNet (Ins, GridFileN$, MXNODE%, MXEL%, MXFEL%, POINTS!(), Outs, TITLE$, NUMNOD%, NREALN%, NFAKEN%, N1000%, XNODE!(), YNODE!(), EQCM!(), NMemo%(), NUMEL%, NODES%(), EMemo%(), NFL%, NODEF%(), FAZ!(), FMemo%(), FDIP!(), OFFSET!(), FAILED%)
'read in a finite element grid, without checking for topology
'fake nodes are renumbered as just above real ones to save storage
DIM B!(3), c!(3), DIPS!(3), IFN%(6)
CLOSE #1
OPEN GridFileN$ FOR INPUT AS #1 LEN = 128
ln% = 0: LOCATE 24, 25: PRINT " Reading Line #";
ln% = ln% + 1: LOCATE 24, 41: PRINT ln%;
LINE INPUT #1, TITLE$
ln% = ln% + 1: LOCATE 24, 41: PRINT ln%;
INPUT #1, NUMNOD%, NREALN%, NFAKEN%, N1000%
IF (CLNG(N1000%) + CLNG(NFAKEN%)) > 32767& THEN
	CALL Blanker(16, 24, 2, 79)
	LOCATE 17, 8: PRINT "HIGHEST NODE NUMBERS WILL EXCEED VALUES OF 32,767 SET BY"
	LOCATE 18, 8: PRINT "THE STORAGE OF INTEGERS IN BASIC.  REDUCE N1000% OR USE SMALLER GRID."
	FAILED% = NOT 0: EXIT SUB
END IF
CALL Finish(1)
IF (NUMNOD% <> (NREALN% + NFAKEN%)) THEN
	CALL Blanker(16, 24, 2, 79)
	LOCATE 17, 8: PRINT "INCONSISTENT DATA:";
	LOCATE 18, 8: PRINT "NUMBER OF NODES SHOULD EQUAL TOTAL OF REAL NODES AND FAKE NODES.";
	FAILED% = NOT 0: EXIT SUB
END IF
IF (NUMNOD% > MXNODE%) THEN
	CALL Blanker(16, 24, 2, 79)
	LOCATE 17, 8: PRINT "NUMBER OF NODES IN GRID ("; NUMNOD%; ") WOULD EXCEED"
	LOCATE 18, 8: PRINT "THE LIMIT ("; MXNODE%; ") SET BY MEMORY.";
	FAILED% = NOT 0: EXIT SUB
END IF
IF (NREALN% > N1000%) THEN
	CALL Blanker(16, 24, 2, 79)
	LOCATE 17, 8: PRINT "NUMBER OF REAL NODES IN GRID ("; NREALN%; ") EXCEEDS"
	LOCATE 18, 8: PRINT "PARAMETER N1000% ("; N1000%; ") IN SAME FILE; ERROR.";
	FAILED% = NOT 0: EXIT SUB
END IF
FOR k% = 1 TO NUMNOD%
	ln% = ln% + 1
	LOCATE 24, 41: PRINT ln%;
	IF Mantle% THEN
		INPUT #1, i%, XI!, YI!, ELEVI!, QI!, ZMI!, HLI!
	ELSE
		INPUT #1, i%, XI!, YI!, ELEVI!, QI!, ZMI!
	END IF
	CALL Finish(1)
	IF i% > NREALN% THEN i% = i% - N1000% + NREALN%
	XNODE!(i%) = XI!
	YNODE!(i%) = YI!
	EQCM!(1, i%) = ELEVI!
	EQCM!(2, i%) = QI!
	EQCM!(3, i%) = ZMI!
	IF Mantle% THEN EQCM!(4, i%) = HLI!
	NMemo%(i%) = 0 '(some will be set True below)
NEXT k%
ln% = ln% + 1: LOCATE 24, 41: PRINT ln%;
INPUT #1, NUMEL%
CALL Finish(1)
IF (NUMEL% > MXEL%) THEN
	CALL Blanker(16, 24, 2, 79)
	LOCATE 17, 8: PRINT "NUMBER OF ELEMENTS IN GRID ("; NUMEL%; ") WOULD EXCEED"
	LOCATE 18, 8: PRINT "THE LIMIT ("; MXEL%; ") SET BY MEMORY.";
	FAILED% = NOT 0: EXIT SUB
END IF
FOR k% = 1 TO NUMEL%
	ln% = ln% + 1
	LOCATE 24, 41: PRINT ln%;
	INPUT #1, i%, IFN%(1), IFN%(2), IFN%(3), IFN%(4), IFN%(5), IFN%(6)
	CALL Finish(1)
	IF NUMNOD% > NREALN% THEN
		FOR J% = 1 TO 6
			IF IFN%(J%) > NREALN% THEN IFN%(J%) = IFN%(J%) - N1000% + NREALN%
		NEXT J%
	END IF
	FOR J% = 1 TO 6: NODES%(J%, i%) = IFN%(J%): NEXT J%
NEXT k%
ln% = ln% + 1: LOCATE 24, 41: PRINT ln%;
INPUT #1, NFL%
CALL Finish(1)
IF (NFL% > MXFEL%) THEN
	CALL Blanker(16, 24, 2, 79)
	LOCATE 17, 8: PRINT "NUMBER OF FAULTS IN GRID ("; NFL%; ") WOULD EXCEED"
	LOCATE 18, 8: PRINT "THE LIMIT ("; MXFEL%; ") SET BY MEMORY.";
	FAILED% = NOT 0: EXIT SUB
END IF
FOR k% = 1 TO NFL%
	ln% = ln% + 1
	LOCATE 24, 41: PRINT ln%;
	INPUT #1, i%, IFN%(1), IFN%(2), IFN%(3), IFN%(4), IFN%(5), IFN%(6), DIPS!(1), DIPS!(2), DIPS!(3), AZ1!, AZ3!, OFFST!
	CALL Finish(1)
	IF NUMNOD% > NREALN% THEN
		FOR J% = 1 TO 6
			IF IFN%(J%) > NREALN% THEN IFN%(J%) = IFN%(J%) - N1000% + NREALN%
		NEXT J%
	END IF
	FOR J% = 1 TO 6: NODEF%(J%, i%) = IFN%(J%): NEXT J%
	FOR L% = 1 TO 3
		IF DIPS!(L%) > 0! THEN
			FDIP!(L%, i%) = DIPS!(L%)
		ELSE
			FDIP!(L%, i%) = 180! + DIPS!(L%)
		END IF
	NEXT L%
	FAZ!(1, i%) = AZ1! * .017453293#
	FAZ!(2, i%) = AZ3! * .017453293#
	OFFSET!(i%) = OFFST!
NEXT k%
CLOSE #1
CALL Blanker(24, 24, 2, 79)
LOCATE 24, 17: PRINT "Computing midpoints of fault elements ...";
'  COMPUTE COORDINATES OF MIDPOINT NODES THAT WERE NOT INPUT.
'     FIRST, FAULTS:
FOR i% = 1 TO NFL%
	LOCATE 24, 60: PRINT i%;
	CALL MidFault(Ins, FAZ!(), i%, NODEF%(), Mods, XNODE!(), YNODE!(), Outs, NMemo%())
NEXT i%
'
CALL Blanker(24, 24, 2, 79)
LOCATE 24, 16: PRINT "Checking adjacent faults for Joined azimuths...";
'  COMPUTE COORDINATES OF MIDPOINT NODES THAT WERE NOT INPUT.
'     FIRST, FAULTS:
FOR i% = 1 TO NFL%
	LOCATE 24, 63: PRINT i%;
	CALL IsJoined(Ins, FAZ!(), i%, NFL%, NODEF%(), Outs, FMemo%())
NEXT i%
'
'    NEXT, OTHER ELEMENT SIDES, IF NEEDED:
CALL Blanker(24, 24, 2, 79)
LOCATE 24, 12: PRINT "Interpolating midpoints of simple triangle sides...";
FOR i% = 1 TO NUMEL%
	LOCATE 24, 63: PRINT i%;
	FOR J% = 4 TO 6
		JM% = J% - 3
		JP% = ((J% - 3) MOD 3) + 1
		NM% = NODES%(JM%, i%)
		NP% = NODES%(JP%, i%)
		XM! = XNODE!(NM%)
		XP! = XNODE!(NP%)
		YM! = YNODE!(NM%)
		YP! = YNODE!(NP%)
		XT! = .5 * (XM! + XP!)
		YT! = .5 * (YM! + YP!)
		n% = NODES%(J%, i%)
		IF ((XNODE!(n%) = 0!) AND (YNODE!(n%) = 0!)) THEN
			XNODE!(n%) = XT!
			YNODE!(n%) = YT!
			NMemo%(n%) = 1
		ELSE
			Side2! = (XM! - XP!) ^ 2 + (YM! - YP!) ^ 2
			Off2! = (XNODE!(n%) - XT!) ^ 2 + (YNODE!(n%) - YT!) ^ 2
			IF Off2! / Side2! <= .0001 THEN
				XNODE!(n%) = XT!
				YNODE!(n%) = YT!
				NMemo%(n%) = 1
			ELSE
				NMemo%(n%) = 0
			END IF
		END IF
	NEXT J%
NEXT i%
CALL Blanker(24, 24, 2, 79)
LOCATE 24, 12: PRINT "Testing elements for any inadmissable folding...";
FOR i% = 1 TO NUMEL%
	LOCATE 24, 60: PRINT i%;
	IF NMemo%(NODES%(4, i%)) AND NMemo%(NODES%(5, i%)) AND NMemo%(NODES%(6, i%)) THEN
		N1% = NODES%(1, i%): N2% = NODES%(2, i%): N3% = NODES%(3, i%)
		B!(1) = YNODE!(N2%) - YNODE!(N3%)
		B!(3) = YNODE!(N1%) - YNODE!(N2%)
		c!(1) = XNODE!(N3%) - XNODE!(N2%)
		c!(3) = XNODE!(N2%) - XNODE!(N1%)
		Area! = .5 * (B!(3) * c!(1) - B!(1) * c!(3))
		IF Area! > 0! THEN
			EMemo%(i%) = 0
		ELSE
			EMemo%(i%) = 1
		END IF
	ELSE
		CALL DERIV(Ins, i%, NODES%(), POINTS!(), XNODE!(), YNODE!(), Outs, EMemo%(i%))
	END IF
NEXT i%
FAILED% = 0
END SUB

FUNCTION Inside% (X!, Y!, NPoly%, XPoly!(), YPoly!())
'determine whether (x!,y!) is inside the convex polygon defined by the
'(NPoly%-1) vertices (XPoly!,YPoly!) in counterclockwise order.
FOR i% = 2 TO NPoly%
	DX1! = XPoly!(i%) - XPoly!(i% - 1)
	DY1! = YPoly!(i%) - YPoly!(i% - 1)
	DX2! = X! - XPoly!(i%)
	DY2! = Y! - YPoly!(i%)
	Test! = DX1! * DY2! - DX2! * DY1!
	IF Test! < 0! THEN
		Inside% = 0
		EXIT FUNCTION
	END IF
NEXT i%
Inside% = NOT 0
END FUNCTION

SUB IsJoined (Ins, FAZ!(), i%, NFL%, NODEF%(), Outs, FMemo%())
'checks fault element i% to see if any adjacent fault element shares both:
'   -two common end-nodes, and
'   -equal azimuth.
'If so, a value of 1 indicates a Join at the N1/N6 end, while 2 indicates
' a Join at the N3/N4, 3 indicates Joins at both ends, and 0 indicates none.
FMemo%(i%) = 0
Checked1% = 0
Checked2% = 0
N1% = NODEF%(1, i%)
N3% = NODEF%(3, i%)
N4% = NODEF%(4, i%)
N6% = NODEF%(6, i%)
IF N1% = N6% THEN Checked1% = -1
IF N3% = N4% THEN Checked2% = -1
FOR J% = 1 TO NFL%
	IF J% <> i% THEN
		IF NOT Checked1% THEN
			IF NODEF%(3, J%) = N1% THEN
				IF NODEF%(4, J%) = N6% THEN
					Ours! = Principal!(FAZ!(1, i%))
					Theirs! = Principal!(FAZ!(2, J%))
					IF ABS(Ours! - Theirs!) < .01 THEN
						CALL SETBIT(FMemo%(i%), 0, 1)
						CALL SETBIT(FMemo%(J%), 1, 1)
					ELSE
						CALL SETBIT(FMemo%(i%), 0, 0)
						CALL SETBIT(FMemo%(J%), 1, 0)
					END IF
				END IF
			ELSEIF NODEF%(6, J%) = N1% THEN
				IF NODEF%(1, J%) = N6% THEN
					Ours! = Principal!(FAZ!(1, i%))
					Theirs! = Principal!(FAZ!(1, J%))
					IF ABS(Ours! - Theirs!) < .01 THEN
						CALL SETBIT(FMemo%(i%), 0, 1)
						CALL SETBIT(FMemo%(J%), 0, 1)
					ELSE
						CALL SETBIT(FMemo%(i%), 0, 0)
						CALL SETBIT(FMemo%(J%), 0, 0)
					END IF
				END IF
			END IF
		END IF
		IF NOT Checked2% THEN
			IF NODEF%(1, J%) = N3% THEN
				IF NODEF%(6, J%) = N4% THEN
					Ours! = Principal!(FAZ!(2, i%))
					Theirs! = Principal!(FAZ!(1, J%))
					IF ABS(Ours! - Theirs!) < .01 THEN
						CALL SETBIT(FMemo%(i%), 1, 1)
						CALL SETBIT(FMemo%(J%), 0, 1)
					ELSE
						CALL SETBIT(FMemo%(i%), 1, 0)
						CALL SETBIT(FMemo%(J%), 0, 0)
					END IF
				END IF
			ELSEIF NODEF%(4, J%) = N3% THEN
				IF NODEF%(3, J%) = N4% THEN
					Ours! = Principal!(FAZ!(2, i%))
					Theirs! = Principal!(FAZ!(2, J%))
					IF ABS(Ours! - Theirs!) < .01 THEN
						CALL SETBIT(FMemo%(i%), 1, 1)
						CALL SETBIT(FMemo%(J%), 1, 1)
					ELSE
						CALL SETBIT(FMemo%(i%), 1, 0)
						CALL SETBIT(FMemo%(J%), 1, 0)
					END IF
				END IF
			END IF
		END IF
		IF Checked1% AND Checked2% THEN EXIT SUB
	END IF
NEXT J%
END SUB

SUB MidFault (Ins, FAZ!(), i%, NODEF%(), Mods, XNODE!(), YNODE!(), Outs, NMemo%())
'compute midpoint node position of fault i% from azimuths
N1% = NODEF%(1, i%)
N2% = NODEF%(2, i%)
N3% = NODEF%(3, i%)
N5% = NODEF%(5, i%)
DX! = XNODE!(N3%) - XNODE!(N1%)
DY! = YNODE!(N3%) - YNODE!(N1%)
AZ! = ATAN2F!(DY!, DX!)
PHI1! = FAZ!(1, i%) - AZ!
PHI1! = Principal!(PHI1!)
PHI2! = AZ! - FAZ!(2, i%)
PHI2! = Principal!(PHI2!)
IF ((ABS(PHI1!) > .001) OR (ABS(PHI2!) > .001)) THEN
	T1! = TAN(PHI1!)
	T2! = TAN(PHI2!)
	IF (ABS(T2! - T1!) >= ABS(T1! + T2!)) THEN
		FACTOR! = .9 * ABS(T1! + T2!) / ABS(T2! - T1!)
		IF (ABS(T1!) > ABS(T2!)) THEN
			T2! = T1! + FACTOR! * (T2! - T1!)
		ELSE
			T1! = T2! + FACTOR! * (T1! - T2!)
		END IF
	END IF
	PARRAL! = (T2! - T1!) / (4! * (T1! + T2!))
	PERPEN! = T1! * T2! / (2! * (T1! + T2!))
	XNODE!(N2%) = XNODE!(N1%) + DX! / 2! + PARRAL! * DX! - PERPEN! * DY!
	YNODE!(N2%) = YNODE!(N1%) + DY! / 2! + PERPEN! * DX! + PARRAL! * DY!
	NMemo%(N2%) = 0
	NMemo%(N5%) = 0
ELSE
	XNODE!(N2%) = (XNODE!(N1%) + XNODE!(N3%)) / 2!
	YNODE!(N2%) = (YNODE!(N1%) + YNODE!(N3%)) / 2!
	NMemo%(N2%) = 1
	NMemo%(N5%) = 1
END IF
XNODE!(N5%) = XNODE!(N2%)
YNODE!(N5%) = YNODE!(N2%)
END SUB

SUB Nearest (Ins, NUMNOD%, X!, XNODE!(), Y!, YNODE!(), Outs, NumNear%, NearOnes%())
'identifies up to 4 nodes (in same spot) nearest to (X!,Y!)
R2toN! = 9.99E+29
FOR i% = 1 TO NUMNOD%
	R2! = (X! - XNODE!(i%)) ^ 2 + (Y! - YNODE!(i%)) ^ 2
	IF R2! < R2toN! THEN
		XN! = XNODE!(i%)
		YN! = YNODE!(i%)
		R2toN! = R2!
	END IF
NEXT i%
NumNear% = 0
NearOnes%(1) = 0: NearOnes%(2) = 0: NearOnes%(3) = 0: NearOnes%(4) = 0:
FOR i% = 1 TO NUMNOD%
	IF XNODE!(i%) = XN! THEN
		IF YNODE!(i%) = YN! THEN
			NumNear% = NumNear% + 1
			NearOnes%(NumNear%) = i%
		END IF
	END IF
	IF NumNear% = 4 THEN GOTO DidIt:
NEXT i%
DidIt:
END SUB

SUB NEXTto (Ins, i%, J%, NFL%, NODEF%(), NODES%(), NUMEL%, Outs, KFAULT%, KELE%)
'
'  DETERMINE WHETHER THERE ARE MORE ELEMENTS ADJACENT TO SIDE J% OF
'  TRIANGULAR CONTINUUM ELEMENT I%.
'    J% = 1 MEANS THE SIDE OPPOSITE NODE # NODES%(1,I%).
'    J% = 2 MEANS THE SIDE OPPOSITE NODE # NODES%(2,I%).
'    J% = 3 MEANS THE SIDE OPPOSITE NODE # NODES%(3,I%).
'  IF A FAULT ELEMENT IS ADJACENT, ITS NUMBER IS KFAULT%; OTHERWISE,
'  KFAULT% IS SET TO ZERO.
'  IF ANOTHER TRIANGULAR CONTINUUM ELEMENT IS ADJACENT (EVEN ACROSS
'  FAULT ELEMENT KFAULT%) THEN ITS NUMBER IS KELE%; OTHERWISE, KELE% = 0.
'
'  THREE NODE NUMBERS ALONG THE SIDE OF INTEREST, COUNTERCLOCKWISE:
	  N1% = NODES%((J% MOD 3) + 1, i%)
	  N2% = NODES%((J% MOD 3) + 4, i%)
	  N3% = NODES%(((J% + 1) MOD 3) + 1, i%)
'  CHECK FOR ADJACENT FAULT ELEMENT FIRST:
	  FOUNDF% = 0
	  FOR k% = 1 TO NFL%
		  M1% = NODEF%(1, k%)
		  M2% = NODEF%(2, k%)
		  M3% = NODEF%(3, k%)
		  M4% = NODEF%(4, k%)
		  M5% = NODEF%(5, k%)
		  M6% = NODEF%(6, k%)
		  IF ((M1% = N3%) AND (M2% = N2%) AND (M3% = N1%)) OR ((M4% = N3%) AND (M5% = N2%) AND (M6% = N1%)) THEN
			  FOUNDF% = NOT 0
			  KFAULT% = k%
			  GOTO L11
		  END IF
	  NEXT k%
L11:   IF NOT FOUNDF% THEN KFAULT% = 0
'  IF THERE WAS A FAULT, REPLACE 3 NODE NUMBERS THAT WE SEARCH FOR:
	  IF FOUNDF% THEN
		  IF M2% = N2% THEN
			  N1% = M4%
			  N2% = M5%
			  N3% = M6%
		  ELSE
			  N1% = M1%
			  N2% = M2%
			  N3% = M3%
		  END IF
	  END IF
'  SEARCH FOR ADJACENT TRIANGULAR CONTINUUM ELEMENT:
	  FOUNDE% = 0
	  FOR k% = 1 TO NUMEL%
		  IF k% <> i% THEN
			  FOR L% = 1 TO 3
				  M1% = NODES%((L% MOD 3) + 1, k%)
				  M2% = NODES%((L% MOD 3) + 4, k%)
				  M3% = NODES%(((L% + 1) MOD 3) + 1, k%)
				  IF (M3% = N1%) AND (M2% = N2%) AND (M1% = N3%) THEN
					  FOUNDE% = NOT 0
					  KELE% = k%
					  GOTO L21
				  END IF
			  NEXT L%
		  END IF
	  NEXT k%
L21:   IF NOT FOUNDE% THEN KELE% = 0
END SUB

SUB OnAny (Ins, n%, N1%, NLast%, NODES%(), Outs, ie%, je%)
'locate any element including the specified node n%
ie% = 0
je% = 0
FOR i% = N1% TO NLast%
	FOR J% = 1 TO 6
		IF NODES%(J%, i%) = n% THEN
			ie% = i%
			je% = J%
			EXIT SUB
		END IF
	NEXT J%
NEXT i%
END SUB

SUB Pixels (Ins, X!, Y!, Outs, col%, row%)
'convert physical coordinates to pixels, using predefined transformation matrix.
Xprime! = X! - XatTL!
Yprime! = Y! - YatTL!
col! = Scales!(1, 1) * Xprime! + Scales!(1, 2) * Yprime!
row! = Scales!(2, 1) * Xprime! + Scales!(2, 2) * Yprime!
IF ABS(col!) < 32767 THEN
	col% = CINT(col!)
ELSEIF col! > 0! THEN
	col% = 32767
ELSE
	col% = -32767
END IF
IF ABS(row!) < 32767 THEN
	row% = CINT(row!)
ELSEIF row! > 0! THEN
	row% = 32767
ELSE
	row% = -32767
END IF
END SUB

FUNCTION Principal! (Angle!)
'Returns the principal value (-Pi/2 < Prinicpal! <= +Pi/2) associated with any
'angle; vectors pointing left are reversed.
CONST Pi! = 3.141592
CONST HalfPi! = 1.570796
CONST Scant! = -1.570795
T! = Angle!
DO WHILE T! > HalfPi!
	T! = T! - Pi!
LOOP
DO WHILE T! <= Scant!
	T! = T! + Pi!
LOOP
IF T! > HalfPi! THEN T! = HalfPi!
Principal! = T!
END FUNCTION

SUB PutNet (GridFileN$, TITLE$, NUMNOD%, NREALN%, NFAKEN%, N1000%, NMemo%(), XNODE!(), YNODE!(), EQCM!(), NUMEL%, NODES%(), NFL%, NODEF%(), FAZ!(), FDIP!(), OFFSET!())
'write out finite element grid to a file, in format used by
'the FAULTS finite element program.
DIM IFN%(6), DIPS!(3)
CLOSE #1
OPEN GridFileN$ FOR OUTPUT AS #1 LEN = 128
ln% = 0: LOCATE 24, 25: PRINT "Writing Line #";
ln% = ln% + 1: LOCATE 24, 41: PRINT ln%;
PRINT #1, TITLE$
ln% = ln% + 1: LOCATE 24, 41: PRINT ln%;
PRINT #1, USING "##### ##### ##### ##### F"; NUMNOD%; NREALN%; NFAKEN%; N1000%
FOR k% = 1 TO NREALN%
	ln% = ln% + 1: LOCATE 24, 41: PRINT ln%;
	IF NMemo%(k%) THEN
		IF Mantle% THEN
			PRINT #1, USING "#####  0_.0          0_.0         +#.##^^^^ +#.##^^^^ +#.##^^^^ +#.##^^^^"; k%; EQCM!(1, k%); EQCM!(2, k%); EQCM!(3, k%); EQCM!(4, k%)
		ELSE
			PRINT #1, USING "#####  0_.0          0_.0         +#.##^^^^ +#.##^^^^ +#.##^^^^"; k%; EQCM!(1, k%); EQCM!(2, k%); EQCM!(3, k%)
		END IF
	ELSE
		IF Mantle% THEN
			PRINT #1, USING "##### +#.#####^^^^ +#.#####^^^^ +#.##^^^^ +#.##^^^^ +#.##^^^^ +#.##^^^^"; k%; XNODE!(k%); YNODE!(k%); EQCM!(1, k%); EQCM!(2, k%); EQCM!(3, k%); EQCM!(4, k%)
		ELSE
			PRINT #1, USING "##### +#.#####^^^^ +#.#####^^^^ +#.##^^^^ +#.##^^^^ +#.##^^^^"; k%; XNODE!(k%); YNODE!(k%); EQCM!(1, k%); EQCM!(2, k%); EQCM!(3, k%)
		END IF
	END IF
NEXT k%
IF NUMNOD% > NREALN% THEN
	FOR k% = (NREALN% + 1) TO NUMNOD%
		i% = N1000% + k% - NREALN%
		ln% = ln% + 1: LOCATE 24, 41: PRINT ln%;
		IF NMemo%(k%) THEN
			IF Mantle% THEN
				PRINT #1, USING "#####  0_.0          0_.0         +#.##^^^^ +#.##^^^^ +#.##^^^^ +#.##^^^^"; k%; EQCM!(1, k%); EQCM!(2, k%); EQCM!(3, k%); EQCM!(4, k%)
			ELSE
				PRINT #1, USING "#####  0_.0          0_.0         +#.##^^^^ +#.##^^^^ +#.##^^^^"; k%; EQCM!(1, k%); EQCM!(2, k%); EQCM!(3, k%)
			END IF
		ELSE
			IF Mantle% THEN
				PRINT #1, USING "##### +#.#####^^^^ +#.#####^^^^ +#.##^^^^ +#.##^^^^ +#.##^^^^ +#.##^^^^"; k%; XNODE!(k%); YNODE!(k%); EQCM!(1, k%); EQCM!(2, k%); EQCM!(3, k%); EQCM!(4, k%)
			ELSE
				PRINT #1, USING "##### +#.#####^^^^ +#.#####^^^^ +#.##^^^^ +#.##^^^^ +#.##^^^^"; k%; XNODE!(k%); YNODE!(k%); EQCM!(1, k%); EQCM!(2, k%); EQCM!(3, k%)
			END IF
		END IF
	NEXT k%
END IF
ln% = ln% + 1: LOCATE 24, 41: PRINT ln%;
PRINT #1, USING "#####"; NUMEL%
FOR k% = 1 TO NUMEL%
	FOR J% = 1 TO 6: IFN%(J%) = NODES%(J%, k%): NEXT J%
	IF NUMNOD% > NREALN% THEN
		FOR J% = 1 TO 6
			IF IFN%(J%) > NREALN% THEN IFN%(J%) = N1000% + IFN%(J%) - NREALN%
		NEXT J%
	END IF
	ln% = ln% + 1: LOCATE 24, 41: PRINT ln%;
	PRINT #1, USING "##### ##### ##### ##### ##### ##### #####"; k%; IFN%(1); IFN%(2); IFN%(3); IFN%(4); IFN%(5); IFN%(6)
NEXT k%
ln% = ln% + 1: LOCATE 24, 41: PRINT ln%;
PRINT #1, USING "#####"; NFL%
FOR i% = 1 TO NFL%
	FOR J% = 1 TO 6: IFN%(J%) = NODEF%(J%, i%): NEXT J%
	IF NUMNOD% > NREALN% THEN
		FOR J% = 1 TO 6
			IF IFN%(J%) > NREALN% THEN IFN%(J%) = N1000% + IFN%(J%) - NREALN%
		NEXT J%
	END IF
	AZ1! = FAZ!(1, i%) / .017453293#
	AZ3! = FAZ!(2, i%) / .017453293#
	FOR J% = 1 TO 3
		IF FDIP!(J%, i%) <= 90.01 THEN
			DIPS!(J%) = FDIP!(J%, i%)
		ELSE
			DIPS!(J%) = FDIP!(J%, i%) - 180!
		END IF
	NEXT J%
	ln% = ln% + 1: LOCATE 24, 41: PRINT ln%;
	PRINT #1, USING "##### ##### ##### ##### ##### ##### ##### +##. +##. +##. +###.# +###.# +#.##^^^^"; i%; IFN%(1); IFN%(2); IFN%(3); IFN%(4); IFN%(5); IFN%(6); DIPS!(1); DIPS!(2); DIPS!(3); AZ1!; AZ3!; OFFSET!(i%)
NEXT i%
CLOSE #1
END SUB

SUB RaiseOne (Ins, ie%, NODES%(), XNODE!(), YNODE!())
'colors in an element, by increasing the color-code of every pixel one unit
DIM VCol%(3), VRow%(3), X!(4), Y!(4), Use%(3, 2)
False% = 0: True% = NOT 0
X!(1) = XNODE!(NODES%(1, ie%)): Y!(1) = YNODE!(NODES%(1, ie%))
X!(2) = XNODE!(NODES%(2, ie%)): Y!(2) = YNODE!(NODES%(2, ie%))
X!(3) = XNODE!(NODES%(3, ie%)): Y!(3) = YNODE!(NODES%(3, ie%))
CALL Pixels(Ins, X!(1), Y!(1), Outs, VCol%(1), VRow%(1))
CALL Pixels(Ins, X!(2), Y!(2), Outs, VCol%(2), VRow%(2))
CALL Pixels(Ins, X!(3), Y!(3), Outs, VCol%(3), VRow%(3))
Row1% = 32000: Row2% = -32000
FOR J% = 1 TO 3
	IF VRow%(J%) > Row2% THEN Row2% = VRow%(J%)
	IF VRow%(J%) < Row1% THEN Row1% = VRow%(J%)
NEXT J%
IF Row1% < 0 THEN Row1% = 0
IF Row1% > HiRow% THEN Row1% = HiRow%
IF Row2% < 0 THEN Row2% = 0
IF Row2% > HiRow% THEN Row2% = HiRow%
IF Row2% <= Row1% THEN EXIT SUB
IF VRow%(1) <> VRow%(2) THEN
	IF VRow%(2) > VRow%(1) THEN
		Use%(1, 1) = True%
		Use%(1, 2) = False%
	ELSE
		Use%(1, 1) = False%
		Use%(1, 2) = True%
	END IF
ELSE
	Use%(1, 1) = False%
	Use%(1, 2) = False%
END IF
IF VRow%(2) <> VRow%(3) THEN
	IF VRow%(3) > VRow%(2) THEN
		Use%(2, 1) = True%
		Use%(2, 2) = False%
	ELSE
		Use%(2, 1) = False%
		Use%(2, 2) = True%
	END IF
ELSE
	Use%(2, 1) = False%
	Use%(2, 2) = False%
END IF
IF VRow%(3) <> VRow%(1) THEN
	IF VRow%(1) > VRow%(3) THEN
		Use%(3, 1) = True%
		Use%(3, 2) = False%
	ELSE
		Use%(3, 1) = False%
		Use%(3, 2) = True%
	END IF
ELSE
	Use%(3, 1) = False%
	Use%(3, 2) = False%
END IF
X!(1) = CSNG(VCol%(1)): Y!(1) = CSNG(VRow%(1))
X!(2) = CSNG(VCol%(2)): Y!(2) = CSNG(VRow%(2))
X!(3) = CSNG(VCol%(3)): Y!(3) = CSNG(VRow%(3))
X!(4) = X!(1): Y!(4) = Y!(1)
FOR row% = Row1% TO (Row2% - 1)
	R! = CSNG(row%)
	Col1% = 0: Col2% = HiCol%
	FOR i% = 1 TO 3
		J% = i% + 1
		IF Use%(i%, 1) THEN
			Edge% = 1 + CINT(X!(i%) + (X!(J%) - X!(i%)) * (R! - Y!(i%)) / (Y!(J%) - Y!(i%)))
			IF Edge% > Col1% THEN Col1% = Edge%
		END IF
		IF Use%(i%, 2) THEN
			Edge% = CINT(X!(i%) + (X!(J%) - X!(i%)) * (R! - Y!(i%)) / (Y!(J%) - Y!(i%)))
			IF Edge% < Col2% THEN Col2% = Edge%
		END IF
	NEXT i%
	FOR col% = Col1% TO Col2%
		Hue% = POINT(col%, row%)
		Hue% = Hue% + 1
		PSET (col%, row%), Hue%
	NEXT col%
NEXT row%
END SUB

SUB RunMenu (Ins, Background%, BestMode%, CD$, a$, CW1%, CW2%, Foreground%, HCol%(), HotCol%, HotColor%, HotLine%, HRow%, Lines%, Mask%(), MXEL%, MXFEL%, MXNODE%, NFL%, NUMEL%, NUMNOD%, Places%(), RAM&, RW1%, RW2%, Trial$, Outs, Current$)
'operate the menu in an "endless" loop (until Enter is pressed)
IF LEN(a$) > 0 THEN
	IF ASC(a$) = 13 THEN 'ignore ENTER or an infinite loop occurs
		a$ = ""
	ELSE
		GOTO GetMoving
	END IF
END IF
DO
	'blank out the dialog box (unless more commands are coming in)
	a$ = INKEY$: IF LEN(a$) > 0 THEN GOTO GetMoving
	'place details in dialog box (unless more commands are coming in)
	IF Colored% THEN
		IF BestMode% <= 10 THEN
			COLOR Foreground%, Background%
			PALETTE 11, 20   'redefine attribute 11 (default is light cyan, yuck!)
						  'as brown (color 20).
			LINE (CW1%, RW1%)-(CW2%, RW2%), 11, BF 'must use an attribute
										    'number because color
										    'numbers not allowed.
		ELSE
			COLOR Foreground%
			CALL Blanker(16, 24, 2, 79)
		END IF
	ELSE
		CALL Blanker(16, 24, 2, 79)
	END IF
	a$ = INKEY$: IF LEN(a$) > 0 THEN GOTO GetMoving
	IF Trial$ = "D" THEN
		LOCATE 16, 10
		PRINT "Check or change the current directory (CD of DOS),"
		LOCATE 17, 10
		PRINT "which will be the default directory when a grid file"
		LOCATE 18, 10
		PRINT "is Loaded or Saved, or when a Basemap file is displayed."
		IF LEFT$(CD$, 1) = "A" OR LEFT$(CD$, 1) = "B" THEN
			LOCATE 20, 3
			PRINT "* Working from a floppy disk drive means that Loading, Saving, and drawing";
			LOCATE 21, 5
			PRINT "the Basemap will be VERY SLOW.  You may wish to eXit this program,";
			LOCATE 22, 5
			PRINT "move your .DIG and .FEG files to a hard disk, and restart.";
		END IF
	ELSEIF Trial$ = "B" THEN
		LOCATE 16, 10
		PRINT "Designate a basemap file to be displayed along with"
		LOCATE 17, 10
		PRINT "the finite element grid, for location reference."
		LOCATE 18, 10
		PRINT "Basemap files are created with program DIGITISE, have extension"
		LOCATE 19, 10
		PRINT ".DIG, and consist of line segments and polylines only"
		LOCATE 20, 10
		PRINT "(no text, color, or shading).  Basemap files could include"
		LOCATE 21, 10
		PRINT "faults, surface geology, state lines, coastlines, latitude-"
		LOCATE 22, 10
		PRINT "longitude grids, et cetera.";
	ELSEIF Trial$ = "C" THEN
		IF Colored% THEN COLOR HotColor%
		LOCATE 17, 35
		PRINT "CAUTION !!!"
		LOCATE 18, 8
		PRINT "This command erases any finite element grid currently in memory."
		LOCATE 19, 26
		PRINT "It does NOT save it first!"
		LOCATE 20, 12
		PRINT "Press Enter ONLY if you are certain you wish to clear."
		LOCATE 21, 17
		PRINT "(Otherwise, select Save, or another command.)"
	ELSEIF Trial$ = "L" THEN
		LOCATE 16, 10
		PRINT "Load a finite element grid file into memory for display"
		LOCATE 17, 10
		PRINT "and/or editing.  (Note: A Load command will not execute when"
		LOCATE 18, 10
		PRINT "another grid is already in memory; you must Clear it first.)"
	ELSEIF Trial$ = "S" THEN
		LOCATE 16, 10
		PRINT "Save the finite element grid currently in memory"
		LOCATE 17, 10
		PRINT "as a file on the hard disk."
	ELSEIF Trial$ = "X" THEN
		LOCATE 16, 10
		PRINT "Exit and return to DOS."
		LOCATE 18, 10
		PRINT "(Note: This command will not execute while there is a finite"
		LOCATE 19, 17
		PRINT " element grid in memory; you must Clear it first.)"
	ELSEIF Trial$ = "W" THEN
		LOCATE 16, 10
		PRINT "Move the viewing window further or more precisely than is"
		LOCATE 17, 10
		PRINT "possible with the Zoom command, by specifying coordinates."
	ELSEIF Trial$ = "O" THEN
		LOCATE 16, 10
		PRINT "To create a second Cartesian coordinate system, for convenience:"
		LOCATE 17, 10
		PRINT "Click the left mouse button on the desired (x'=0,y'=0) origin."
		LOCATE 18, 10
		PRINT "Click the right mouse button on another point to define the"
		LOCATE 19, 10
		PRINT "direction of the +x' axis.  The new (x',y') coordinates will"
		LOCATE 20, 10
		PRINT "be reported at lower right, in addition to (x,y) coordinates"
		LOCATE 21, 10
		PRINT "at lower left.  Grid and basemap files are unchanged.  This"
		LOCATE 22, 10
		PRINT "command is useful prior to commands H and/or Q.  It can also be"
		LOCATE 23, 10
		PRINT "used to measure distance between two points (= x' after second click).";
	ELSEIF Trial$ = "Z" THEN
		LOCATE 16, 10
		PRINT "After you supply a new window width below, you then click"
		LOCATE 17, 10
		PRINT "either mouse button on the point which is to be the center"
		LOCATE 18, 10
		PRINT "of the new window.  (If you leave the window width unchanged,"
		LOCATE 19, 10
		PRINT "this command can also be used for small window movements.)"
	ELSEIF Trial$ = "T" THEN
		LOCATE 16, 10
		PRINT "Turn the window through any angle with respect to the grid"
		LOCATE 17, 10
		PRINT "and the (x,y) axes.  (Same as turning axes and grid with"
		LOCATE 18, 10
		PRINT "respect to a fixed computer screen.)"
	ELSEIF Trial$ = "R" THEN
		LOCATE 16, 10
		PRINT "Redraw the contents of the graphics window,"
		LOCATE 17, 10
		PRINT "to eliminate unwanted messages, secondary coordinates,"
		LOCATE 18, 10
		PRINT "or debris resulting from editing."
		LOCATE 20, 10
		PRINT "Also redraws this menu (when Enter is pressed for the second time)."
	ELSEIF Trial$ = "H" THEN
		LOCATE 16, 10
		PRINT "Define a convex polygon by clicking the left mouse button on"
		LOCATE 17, 10
		PRINT "the vertices in the counterclockwise direction; end the polygon"
		LOCATE 18, 10
		PRINT "by clicking the right mouse button near the initial vertex."
		LOCATE 19, 10
		PRINT "A regular grid of equilateral triangles will be created"
		LOCATE 20, 10
		PRINT "within the region specified, such that no element crosses"
		LOCATE 21, 10
		PRINT "the boundary.  You will be prompted for the element size."
		LOCATE 22, 10
		PRINT "Phase and orientation of the grid are determined by the temporary"
		LOCATE 23, 10
		PRINT "origin (see command: 2nd Origin (re)set)."
	ELSEIF Trial$ = "Q" THEN
		LOCATE 16, 10
		PRINT "Define a convex polygon by clicking the left mouse button on"
		LOCATE 17, 10
		PRINT "the vertices in the counterclockwise direction; end the polygon"
		LOCATE 18, 10
		PRINT "by clicking the right mouse button near the initial vertex."
		LOCATE 19, 10
		PRINT "A regular grid of rectangular element-pairs will be created"
		LOCATE 20, 10
		PRINT "within the region specified, such that no element crosses"
		LOCATE 21, 10
		PRINT "the boundary.  You will be prompted for the element sizes."
		LOCATE 22, 10
		PRINT "Phase and orientation of the grid are determined by the temporary"
		LOCATE 23, 10
		PRINT "origin (see command: 2nd Origin (re)set)."
	ELSEIF Trial$ = "A" THEN
		LOCATE 16, 10
		PRINT "Adjust node locations by placing cursor over a node, holding"
		LOCATE 17, 10
		PRINT "either button down, and dragging to the desired position."
		LOCATE 18, 10
		PRINT "If an X symbol appears in any of the neighboring elements,"
		LOCATE 19, 10
		PRINT "then the node displacement was too extreme; reduce it."
		LOCATE 20, 10
		PRINT "(Caution: If you Adjust any nodes on faults that have been"
		LOCATE 21, 20
		PRINT "Joined, you will need to re-Join them, at both ends.)"
	ELSEIF Trial$ = "N" THEN
		LOCATE 16, 10
		PRINT "Add a node by clicking the left mouse button."
		LOCATE 18, 10
		PRINT "Remove a node by clicking the right mouse button."
		LOCATE 19, 10
		PRINT "(You will not be permitted to remove any node which is"
		LOCATE 20, 10
		PRINT "part of any element or fault; you must heal any fault(s)"
		LOCATE 21, 10
		PRINT "and delete any element(s) first.)"
	ELSEIF Trial$ = "E" THEN
		LOCATE 16, 10
		PRINT "Add a triangular element by clicking the left mouse button"
		LOCATE 17, 10
		PRINT "on 6 nodes in counterclockwise order, beginning at a corner."
		LOCATE 18, 10
		PRINT "(Note: You will not be permitted to include any node which"
		LOCATE 19, 10
		PRINT "is on a fault in a new element.  You must heal the fault"
		LOCATE 20, 10
		PRINT "using the F command, create the Element, and recut the Fault.)"
		LOCATE 22, 10
		PRINT "Remove an element by clicking the right mouse button"
		LOCATE 23, 10
		PRINT "on the little triangle symbol in its center."
	ELSEIF Trial$ = "F" THEN
		LOCATE 16, 6
		PRINT "Add a fault segment by clicking the left mouse button"
		LOCATE 17, 6
		PRINT "on any boundary between two elements, at its midpoint."
		LOCATE 18, 6
		PRINT "(Note: You will not be permitted to cut a fault along an external"
		LOCATE 19, 6
		PRINT "boundary, but you can create extra elements, then cut a fault, and then"
		LOCATE 20, 6
		PRINT "remove unwanted elements and nodes, leaving the fault on the boundary.)"
		LOCATE 22, 6
		PRINT "Heal (eliminate) any fault by clicking the right mouse button."
	ELSEIF Trial$ = "I" THEN
		LOCATE 16, 7
		PRINT "By default, faults are vertical (strike-slip) when created."
		LOCATE 17, 7
		PRINT "To change, specify dip at 3 points per fault (middle first, then ends)"
		LOCATE 18, 7
		PRINT "by clicking left mouse button for shallow dip and right mouse"
		LOCATE 19, 7
		PRINT "button for steeper dip, on the side to which the fault dips."
		LOCATE 20, 7
		PRINT "Clicking both buttons at once returns that point to vertical dip."
	ELSEIF Trial$ = "J" THEN
		LOCATE 16, 6
		PRINT "Connected vertical faults will artificially lock unless a third fault"
		LOCATE 17, 6
		PRINT "intersects there, or their azimuths agree.  Join adjacent faults"
		LOCATE 18, 6
		PRINT "by clicking either mouse button on their common end-node, then moving"
		LOCATE 19, 6
		PRINT "away along the desired tangent line, and releasing the button."
		LOCATE 20, 6
		PRINT "If you select a free fault-end, only one faults azimuth will be"
		LOCATE 21, 6
		PRINT "adjusted.  Fault midpoint nodes are displaced as required."
		LOCATE 22, 6
		PRINT "A succesful joint is shown by a small rectangle."
		LOCATE 23, 6
		PRINT "WARNING: Faults cannot have compound S bends, only simple ) bends.";
		LOCATE 24, 6
		PRINT "If you try to force an S bend, the azimuth of one end will be compromised.";
	ELSEIF Trial$ = "U" THEN
		LOCATE 16, 6
		PRINT "Straighten any fault or any element side by clicking either mouse button"
		LOCATE 17, 6
		PRINT "on its midpoint."
	ELSEIF Trial$ = "V" THEN
		LOCATE 16, 7
		PRINT "This command causes one of the nodal variables";
		LOCATE 17, 7
		PRINT "*elevation     *heat-flow      *crustal-thickness";
		LOCATE 18, 7
		IF (Mantle%) THEN PRINT "                               *mantle-lithosphere-thickness";
		LOCATE 19, 7
		PRINT "to be contoured in color (on color monitors) in all views, until";
		LOCATE 20, 7
		PRINT "you select Redraw.  By clicking on any node, you may check its";
		LOCATE 21, 7
		PRINT "value and (optionally) enter a new value.  If you don't want to";
		LOCATE 22, 7
		PRINT "change the value, just press Enter.  To repeat the last value";
		LOCATE 23, 7
		PRINT "typed, press ' [single quote] and Enter.";
	ELSEIF Trial$ = "P" THEN
		LOCATE 16, 4
		PRINT "This command tests the topology of the grid, specifically:"
		LOCATE 17, 5
		PRINT "(a) whether its boundary is simply connected, and"
		LOCATE 18, 5
		PRINT "(b) whether there are internal holes or overlap areas."
		LOCATE 19, 4
		PRINT "The actions taken are:"
		LOCATE 20, 5
		PRINT "(1) Locate a free element side, which is not attached to anything;"
		LOCATE 21, 5
		PRINT "(2) Trace around the boundary, back to the initial point;"
		LOCATE 22, 5
		PRINT "(3) Compute the area within this perimeter (treating sides as straight);"
		LOCATE 23, 5
		PRINT "(4) Compute the sum of the areas of elements (treating sides as straight);"
		LOCATE 24, 5
		PRINT "(5) Report results of (3) and (4) for comparison.";
	ELSEIF Trial$ = "G" THEN
		LOCATE 16, 5
		PRINT "This graphical test is designed to show any areas where elements"
		LOCATE 17, 5
		PRINT "may fail to meet (gaps) or may cover the same area twice (overlaps)."
		LOCATE 18, 5
		PRINT "After this command is selected, the insides of the elements will be"
		LOCATE 19, 5
		PRINT "colored in all succeeding views (until you Redraw or edit the grid)."
		LOCATE 20, 5
		PRINT "A gap or overlap should show up as a different color."
		LOCATE 21, 5
		PRINT "Be aware that elements are colored-in as if they had three straight"
		LOCATE 22, 5
		PRINT "sides; this can cause odd effects along curved faults and boundaries."
		LOCATE 24, 5
		PRINT "* THIS COMMAND IS ONLY AVAILABLE ON COLOR MONITORS!";
	ELSEIF Trial$ = "M" THEN
		KRAM% = RAM& / 1024&
		LOCATE 17, 16
		PRINT "Memory available for finite element grid: "; KRAM%; " K"
		LOCATE 19, 27
		PRINT "Number loaded   Limit     % of Limit"
		Npc% = CINT((100& * NUMNOD%) / MXNODE%)
		Epc% = CINT((100& * NUMEL%) / MXEL%)
		Fpc% = CINT((100& * NFL%) / MXFEL%)
		LOCATE 20, 20: PRINT USING "NODES:    #####        #####        ###%"; NUMNOD%; MXNODE%; Npc%
		LOCATE 21, 20: PRINT USING "ELEMENTS: #####        #####        ###%"; NUMEL%; MXEL%; Epc%
		LOCATE 22, 20: PRINT USING "FAULTS:   #####        #####        ###%"; NFL%; MXFEL%; Fpc%
	END IF
	CALL WaitForKey(a$)
GetMoving:
	NewHotCol% = HotCol%
	NewHotLine% = HotLine%
	IF LEN(a$) = 1 THEN  'letter command, or Esc, or Return
		a$ = UCASE$(a$)
		m% = ASC(a$)
		n% = m% - 64
		IF (n% > 0) AND (n% < 27) THEN
			IF Places%(n%, 1) > 0 THEN
				Trial$ = a$
				NewHotCol% = Places%(n%, 1)
				NewHotLine% = Places%(n%, 2)
			END IF
		ELSEIF m% = 27 THEN 'Esc key
			Trial$ = Current$
			n% = ASC(Current$) - 64
			NewHotCol% = Places%(n%, 1)
			NewHotLine% = Places%(n%, 2)
		ELSEIF m% = 13 THEN 'Enter key; ONLY EXIT FROM LOOP!
			Current$ = Trial$
			a$ = "" 'BLANK OUT COMMAND KEY TO PREVENT INFINITE LOOP!
			EXIT SUB
		ELSEIF m% = 50 THEN 'digit 2 is pseudonym for letter O.
			Trial$ = "O"
			NewHotCol% = Places%(15, 1)
			NewHotLine% = Places%(15, 2)
		END IF
	ELSE 'extended character = possible cursor command
		m% = ASC(RIGHT$(a$, 1))
		IF m% = 72 THEN      'Up cursor
			DO: NewHotLine% = ((NewHotLine% + 12) MOD 14) + 1
			LOOP UNTIL Letters(NewHotCol%, NewHotLine%) <> " "
		ELSEIF m% = 80 THEN  'Down cursor
			DO: NewHotLine% = ((NewHotLine% + 14) MOD 14) + 1
			LOOP UNTIL Letters(NewHotCol%, NewHotLine%) <> " "
		ELSEIF m% = 75 OR m% = 77 THEN 'Left/Right cursors
			NewHotCol% = HotCol% MOD 2 + 1
			IF Letters(NewHotCol%, NewHotLine%) = " " THEN
				NewHotCol% = HotCol%
				BEEP
			END IF
		END IF
	END IF
	'place highlight on tentative command choice
	PUT (HCol%(HotCol%), HRow%), Mask%, XOR 'erase old highlight
	HotCol% = NewHotCol%
	HotLine% = NewHotLine%
	HRow% = (HotLine% - 1) * (HiRow% + 1) / Lines%
	PUT (HCol%(HotCol%), HRow%), Mask%, XOR 'place new highlight
	Trial$ = Letters(HotCol%, HotLine%)
LOOP
END SUB

SUB Scaler (Ins, WindowWidth!, Outs, Tolerance!, UnScale!())
'compute a 2x2 matrix which converts (x,y) to (col,row) in pixels.
'in last statements, assumes that physical screen ratio is 4 units wide to 3 high.
CosA! = COS(Argument!)
Sina! = SIN(Argument!)
'deal with window rotation (counterclockwise, by Argument! radians)
Scales!(1, 1) = CosA!
Scales!(1, 2) = Sina!
Scales!(2, 1) = -Sina!
Scales!(2, 2) = CosA!
'correct for inversion of row # versus y
Scales!(2, 1) = -Scales!(2, 1)
Scales!(2, 2) = -Scales!(2, 2)
'adjust for pixel sizes
Scales!(1, 1) = Scales!(1, 1) * HiCol% / WindowWidth!
Scales!(1, 2) = Scales!(1, 2) * HiCol% / WindowWidth!
Scales!(2, 1) = Scales!(2, 1) * HiRow% / (WindowWidth! * .75)
Scales!(2, 2) = Scales!(2, 2) * HiRow% / (WindowWidth! * .75)
'find inverse matrix
Determinant! = Scales!(1, 1) * Scales!(2, 2) - Scales!(1, 2) * Scales!(2, 1)
UnScale!(1, 1) = Scales!(2, 2) / Determinant!
UnScale!(1, 2) = -Scales!(1, 2) / Determinant!
UnScale!(2, 1) = -Scales!(2, 1) / Determinant!
UnScale!(2, 2) = Scales!(1, 1) / Determinant!
'locate center point and radius of window
Angle! = Argument! - .643501
VX! = COS(Angle!) * .625 * WindowWidth!
VY! = SIN(Angle!) * .625 * WindowWidth!
XCenter! = XatTL! + VX!
YCenter! = YatTL! + VY!
R2C! = (.63 * WindowWidth) ^ 2
Tolerance! = WindowWidth! * 6! / CSNG(HiCol%)
END SUB

SUB SETBIT (NUMBER%, PLACE%, ONOFF%)
'IN NUMBER%, SETS THE 2**PLACE% BIT TO VALUE ONOFF% (O OR 1)
IF ONOFF% THEN
	NUMBER% = NUMBER% OR CINT(2 ^ PLACE%)
ELSE
	NUMBER% = NUMBER% AND (NOT CINT(2 ^ PLACE%))
END IF
END SUB

SUB SetMenu (Ins, Background%, BestMode%, Current$, Foreground%, HCol%(), HotCol%, HotLine%, HighPage%, Lines%, Mask%(), Mods, NeedMenu%, Outs, HRow%, PageNow%, Places%(), Trial$)
'draws the basic menu of commands
Trial$ = Current$
SCREEN BestMode%, , HighPage%, HighPage%
PageNow% = HighPage%
IF Colored% THEN
	IF BestMode% <= 10 THEN
		COLOR Foreground%, Background%
	ELSE
		COLOR Foreground%
	END IF
END IF
NeedMenu% = 0
CLS
LOCATE 1, 10
PRINT "CHOOSE COMMAND BY CURSOR OR CAPITAL LETTER, THEN PRESS Enter:"
LINE (0, ((HiRow% + 1) / Lines%) - 1)-(HiCol%, ((HiRow% + 1) / Lines%) - 1), Foreground%
LOCATE 2, 10: PRINT "FILE COMMANDS:"
LOCATE 9, 10: PRINT "WINDOW COMMANDS:"
LOCATE 2, 42: PRINT "G"
LOCATE 3, 42: PRINT "R"
LOCATE 4, 42: PRINT "I"
LOCATE 5, 42: PRINT "D"
LOCATE 7, 42: PRINT "C"
LOCATE 8, 42: PRINT "O"
LOCATE 9, 42: PRINT "M"
LOCATE 10, 42: PRINT "M"
LOCATE 11, 42: PRINT "A"
LOCATE 12, 42: PRINT "N"
LOCATE 13, 42: PRINT "D"
LOCATE 14, 42: PRINT "S"
'initialize highlighting, and color the group labels
HCol%(1) = HiCol% * .1
BoxLine% = 2 ' for FILE COMMANDS
HRow% = (BoxLine% - 1) * (HiRow% + 1) / Lines%
PUT (HCol%(1), HRow%), Mask%, AND
BoxLine% = 9 ' for WINDOW COMMANDS
HRow% = (BoxLine% - 1) * (HiRow% + 1) / Lines%
PUT (HCol%(1), HRow%), Mask%, AND '
HCol%(2) = HiCol% * .48 ' for GRID COMMANDS
FOR BoxLine% = 2 TO 14
	HRow% = (BoxLine% - 1) * (HiRow% + 1) / Lines%
	PUT (HCol%(2), HRow%), Mask%, AND
NEXT BoxLine%
HCol%(2) = HiCol% * .55 ' for highlighting commands
'list all commands, and create cross-reference tables
FOR i% = 1 TO 26: Places%(i%, 1) = 0: Places%(i%, 2) = 0: NEXT i%
FOR i% = 1 TO 14: Letters(1, i%) = " ": Letters(2, i%) = " ": NEXT i%
LOCATE 3, 10: PRINT "Directory (path) for files"
Letters(1, 3) = "D"
Places%(4, 1) = 1
Places%(4, 2) = 3
LOCATE 4, 10: PRINT "Basemap file"
Letters(1, 4) = "B"
Places%(2, 1) = 1
Places%(2, 2) = 4
LOCATE 5, 10: PRINT "Load  grid file"
Letters(1, 5) = "L"
Places%(12, 1) = 1
Places%(12, 2) = 5
LOCATE 6, 10: PRINT "Save  grid file"
Letters(1, 6) = "S"
Places%(19, 1) = 1
Places%(19, 2) = 6
LOCATE 7, 10: PRINT "Clear grid file"
Letters(1, 7) = "C"
Places%(3, 1) = 1
Places%(3, 2) = 7
LOCATE 8, 10: PRINT "eXit to DOS"
Letters(1, 8) = "X"
Places%(24, 1) = 1
Places%(24, 2) = 8
LOCATE 10, 10: PRINT "Window position"
Letters(1, 10) = "W"
Places%(23, 1) = 1
Places%(23, 2) = 10
LOCATE 11, 10: PRINT "2nd Origin (re)set"
Letters(1, 11) = "O"
Places%(15, 1) = 1
Places%(15, 2) = 11
LOCATE 12, 10: PRINT "Zoom in or out"
Letters(1, 12) = "Z"
Places%(26, 1) = 1
Places%(26, 2) = 12
LOCATE 13, 10: PRINT "Turn window frame"
Letters(1, 13) = "T"
Places%(20, 1) = 1
Places%(20, 2) = 13
LOCATE 14, 10: PRINT "Redraw window & menu"
Letters(1, 14) = "R"
Places%(18, 1) = 1
Places%(18, 2) = 14
LOCATE 2, 46: PRINT "Hexagons: add grid region"
Letters(2, 2) = "H"
Places%(8, 1) = 2
Places%(8, 2) = 2
LOCATE 3, 46: PRINT "sQuares: add grid region"
Letters(2, 3) = "Q"
Places%(17, 1) = 2
Places%(17, 2) = 3
LOCATE 4, 46: PRINT "Adjust node position(s)"
Letters(2, 4) = "A"
Places%(1, 1) = 2
Places%(1, 2) = 4
LOCATE 5, 46: PRINT "Node(s): add or delete"
Letters(2, 5) = "N"
Places%(14, 1) = 2
Places%(14, 2) = 5
LOCATE 6, 46: PRINT "Element(s): add or delete"
Letters(2, 6) = "E"
Places%(5, 1) = 2
Places%(5, 2) = 6
LOCATE 7, 46: PRINT "Fault(s): cut or heal"
Letters(2, 7) = "F"
Places%(6, 1) = 2
Places%(6, 2) = 7
LOCATE 8, 46: PRINT "Inclination (dip) of faults"
Letters(2, 8) = "I"
Places%(9, 1) = 2
Places%(9, 2) = 8
LOCATE 9, 46: PRINT "Join strike-slip faults"
Letters(2, 9) = "J"
Places%(10, 1) = 2
Places%(10, 2) = 9
LOCATE 10, 46: PRINT "Unbend elements/faults"
Letters(2, 10) = "U"
Places%(21, 1) = 2
Places%(21, 2) = 10
LOCATE 11, 46: PRINT "View or edit nodal data"
Letters(2, 11) = "V"
Places%(22, 1) = 2
Places%(22, 2) = 11
LOCATE 12, 46: PRINT "Perimeter test"
Letters(2, 12) = "P"
Places%(16, 1) = 2
Places%(16, 2) = 12
LOCATE 13, 46: PRINT "Gap/overlap test"
Letters(2, 13) = "G"
Places%(7, 1) = 2
Places%(7, 2) = 13
LOCATE 14, 46: PRINT "Memory check"
Letters(2, 14) = "M"
Places%(13, 1) = 2
Places%(13, 2) = 14
'frame the dialog box
LOCATE 15, 1: PRINT CHR$(201);
FOR i% = 2 TO 79: PRINT CHR$(205); : NEXT i%
PRINT CHR$(187);
FOR i% = 16 TO 24
LOCATE i%, 1: PRINT CHR$(186);
LOCATE i%, 80: PRINT CHR$(186);
NEXT i%
LOCATE 25, 1: PRINT CHR$(200);
FOR i% = 2 TO 79: PRINT CHR$(205); : NEXT i%
PRINT CHR$(188);
'initialize highlight
HRow% = (HotLine% - 1) * (HiRow% + 1) / Lines%
PUT (HCol%(HotCol%), HRow%), Mask%, XOR
END SUB

SUB TwoToOne (Ins, From2nd11!, From2nd12!, From2ndX!, From2ndY!, Mods, X!, Y!)
'convert from secondary to primary Cartesian coordinates
XT! = From2nd11! * X! + From2nd12! * Y! + From2ndX!
YT! = -From2nd12! * X! + From2nd11! * Y! + From2ndY!
X! = XT!
Y! = YT!
END SUB

SUB WaitForKey (a$)
'does nothing until a key is pressed; then returns the key as a$
a$ = ""
DO WHILE LEN(a$) = 0
	a$ = INKEY$
LOOP
END SUB

SUB XandY (Ins, col%, row%, UnScale!(), Outs, X!, Y!)
'convert pixel coordinates to (x,y) using predefined transformation matrix
Xprime! = UnScale!(1, 1) * col% + UnScale!(1, 2) * row%
Yprime! = UnScale!(2, 1) * col% + UnScale!(2, 2) * row%
X! = Xprime! + XatTL!
Y! = Yprime! + YatTL!
END SUB

SUB XORLine (X1%, Y1%, X2%, Y2%, HiColor%)
'draws a line, like LINE, but XOR's each pixel;
'thus, two successive calls erase the line
DX% = X2% - X1%
DY% = Y2% - Y1%
IF DX% = 0 AND DY% = 0 THEN
	EXIT SUB
ELSEIF ABS(DX%) > ABS(DY%) THEN 'quasihorizontal line
	Slope! = CSNG(DY%) / CSNG(DX%)
	IF DX% > 0 THEN
		TheStep% = 1
	ELSE
		TheStep% = -1
	END IF
	FOR X% = X1% TO X2% STEP TheStep%
		Y% = CINT(CSNG(X% - X1%) * Slope! + Y1%)
		Hue% = POINT(X%, Y%)
		Hue% = HiColor% - Hue%
		PSET (X%, Y%), Hue%
	NEXT X%
ELSE 'quasivertical line
	Slope! = CSNG(DX%) / CSNG(DY%)
	IF DY% > 0 THEN
		TheStep% = 1
	ELSE
		TheStep% = -1
	END IF
	FOR Y% = Y1% TO Y2% STEP TheStep%
		X% = CINT(CSNG(Y% - Y1%) * Slope! + X1%)
		Hue% = POINT(X%, Y%)
		Hue% = HiColor% - Hue%
		PSET (X%, Y%), Hue%
	NEXT Y%
END IF
END SUB

SUB XYBounds (Ins, NUMNOD%, XNODE!(), YNODE!(), Outs, XMin!, XMax!, YMin!, YMax!)
XMin! = 3E+38: XMax! = -3E+38
YMin! = 3E+38: YMax! = -3E+38
FOR i% = 1 TO NUMNOD%
	X! = XNODE!(i%)
	Y! = YNODE!(i%)
	IF X! > XMax! THEN XMax! = X!
	IF Y! > YMax! THEN YMax! = Y!
	IF X! < XMin! THEN XMin! = X!
	IF Y! < YMin! THEN YMin! = Y!
NEXT i%
END SUB