' DRAWGRID.BAS ' (composed of module DRAWGRID.BAS plus module DRAW2.BAS, ' plus mouse utility module MYMOUSE.BAS, plus INCLUDE files ' MYMOUSE.BI and GENERAL.BI) ' These files contains source code to be compiled with ' Microsoft's BASIC Professional Development System, version 7.1, to ' create an interactive editor of 2-D finite element grids composed of ' linear-strain (6-node) triangles and quadratic-slip (6-node) ' curvilinear fault elements. The grids lie in a flat (x,y) plane. ' (Such grids are used by the finite element program FAULTS and PLATES, ' by the same author.) ' ' The compiled program absolutely requires: ' * a Microsoft-compatible serial mouse, and ' * mouse driver software loaded and running, and ' * a graphics card and monitor. ' For speed, it is VERY desirable that the PC: ' * be equipped with a math coprocessor or 80486 or Pentium chip, ' * run at 20 MHz or higher, ' * has a hard disk, and ' * that the graphics card should have enough memory to hold two pages of ' graphics in some mode (EGA, VGA, or CGA). Otherwise, the menu screen ' and window will have to be recreated every time you switch between them. ' Color EGA or VGA is nice, as you can see highlighted nodes/elements/faults. ' SuperVGA modes are not utilized. ' If a basemap is desired (for location reference, surface geology, ' fault traces, latitude/longitude grids, etc.) then it should be ' digitized using program DIGITIZE, by the same author. ' ' Written by Peter Bird, Department of Earth and Space Sciences, ' University of California, Los Angeles, CA 90095-1567. ' Version 1.G, 24 March 2000. ' (c) Copyright 1993, 1995, 1998, 1999, 2000 ' by Peter Bird and the Regents of the University of California. '---------------------------------------------------------------------- 'All mouse subprograms are modified from MicroSoft BASIC Prof. Dev. System: REM $INCLUDE: 'GENERAL.BI' REM $INCLUDE: 'MYMOUSE.BI' '---------------------------------------------------------------------- 'The following occur at the end of this module: DECLARE SUB FirstScreen (Ins, BestMode%, Foreground%, HotColor%, Red%, Green%, Yellow%, White%, Outs, PageNow%) DECLARE SUB SecondScreen (Ins, BestMode%, Foreground%, HotColor%, Outs, PageNow%) 'The following subprograms are included in 2nd module DRAW2.BAS: DECLARE FUNCTION ATAN2F! (Y!, X!) DECLARE FUNCTION GETBIT% (Number%, Place%) DECLARE FUNCTION Inside% (X!, Y!, NPoly%, XPoly!(), YPoly!()) DECLARE FUNCTION Principal! (Angle!) DECLARE SUB AddNode (Ins, MXNODE%, NFL%, NModel%, NUMEL%, X!, Y!, Mods, EQCM!(), NMemo%(), NODEF%(), NODES%(), NREALN%, NUMNOD%, N1000%, XNODE!(), YNODE!(), Outs, n%) DECLARE SUB Blanker (R1%, R2%, C1%, C2%) DECLARE SUB CIRCUIT (Ins, MXBN%, NFL%, NUMEL%, Mods, EQCM!(), NFAKEN%, NMemo%(), NODEF%(), NODES%(), NREALN%, NUMNOD%, XNODE!(), YNODE!(), Outs, FAILED%, NCOND%, NODCON%(), Work, FMemo%(), EMemo%()) DECLARE SUB Delay18th (n%) DECLARE SUB DERIV (Ins, i%, NODES%(), POINTS!(), XNODE!(), YNODE!(), Outs, EMemo%) DECLARE SUB DrawBase (Brown%, ColOldBase%, RowOldBase%, XOldBase!) DECLARE SUB DrawElement (BotF!, ColorIn%, Contour%, DFC!, EMemo%(), EQCM!(), i%, IData%, Logs%, NMemo%(), NODES%(), ReDo%, UseColor%, XNODE!(), YNODE!()) DECLARE SUB DrawFault (FAZ!(), FDIP!(), FMemo%(), i%, NMemo%(), NODEF%(), UseColor%, XNODE!(), YNODE!()) DECLARE SUB DrawNode (n%, UseColor%, XNODE!(), YNODE!()) DECLARE SUB DropNode (Ins, AKA%, n%, NFL%, NUMEL%, Mods, EQCM!(), NFAKEN%, NMemo%(), NODEF%(), NODES%(), NREALN%, NUMNOD%, XNODE!(), YNODE!()) DECLARE SUB Exists (Ins, n1%, NUMNOD%, X!, XNODE!(), Y!, YNODE!(), Tolerance!, Outs, n%) DECLARE SUB Finish (FileNum%) 'read past any junk at the end of a record DECLARE SUB GetArgs (Ins, i%, NODEF%(), XNODE!(), YNODE!(), Outs, FAZ!()) DECLARE SUB GetFileName (Text$, LineN%, NewName$) DECLARE 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% _ ) DECLARE SUB IsJoined (Ins, FAZ!(), i%, NFL%, NODEF%(), Outs, FMemo%()) DECLARE SUB LineOfNumbers (Ins, Rec$, Outs, AreNumbers%) DECLARE SUB MidFault (Ins, FAZ!(), i%, NODEF%(), Mods, XNODE!(), YNODE!(), Outs, NMemo%()) DECLARE SUB Nearest (Ins, NUMNOD%, X!, XNODE!(), Y!, YNODE!(), Outs, NumNear%, NearOnes%()) DECLARE SUB OnAny (Ins!, n%, n1%, NLast%, NODES%(), Outs!, ie%, je%) DECLARE SUB Pixels (Ins, X!, Y!, Outs, col%, row%) DECLARE SUB PutNet (GridFileN$, TITLE$, NUMNOD%, NREALN%, NFAKEN%, N1000%, NMemo%(), XNODE!(), YNODE!(), EQCM!(), NUMEL%, NODES%(), NFL%, NODEF%(), FAZ!(), FDIP!(), OFFSET!()) DECLARE SUB RunMenu (Ins, background%, BestMode%, CD$, CommandKey$, CW1%, CW2%, Foreground%, HCol%(), HotCol%, HotColor%, HotLine%, HRow%, Lines%, Mask%(), MXEL%, MXFEL%, MXNODE%, NFL%, NUMEL%, NUMNOD%, Places%(), RAM&, RW1%, RW2%, Trial$, Outs, _ Current$) DECLARE SUB Scaler (Ins, WindowWidth!, Outs, Tolerance!, UnScale!()) DECLARE SUB SetBins (Ins, Ask%, Contour%, EQCM!(), IData%, NUMNOD%, Mods, OldBotF!, OldIData%, OldTopF!, Outs, BotF!, DFC!, Logs%, NeedToDraw%, TopF!) DECLARE SUB SetMenu (Ins, background%, BestMode%, Current$, Foreground%, HCol%(), HotCol%, HotLine%, HighPage%, Lines%, Mask%(), Mods, NeedMenu%, Outs, HRow%, PageNow%, Places%(), Trial$) DECLARE SUB TwoToOne (Ins, From2nd11!, From2nd12!, From2ndX!, From2ndY!, Mods, X!, Y!) DECLARE SUB WaitForKey (a$) DECLARE SUB XandY (Ins, col%, row%, UnScale!(), Outs, X!, Y!) DECLARE SUB XYBounds (Ins, NUMNOD%, XNODE!(), YNODE!(), Outs, XMin!, XMax!, YMin!, YMax!) DECLARE SUB XORLine (X1%, Y1%, X2%, Y2%, HiColor%) '---------------------------------------------------------------------- 'arrays of constant size: OPTION BASE 1 DIM EOn%(12), FOn%(12), JOn%(12), NearOnes%(4), NOn%(24) DIM DIPS!(3) DIM POINTS!(4, 7) DIM FIPoint!(4) DIM XPoly!(20), YPoly!(20) DIM Modes%(1 TO 12) DIM LastPage%(1 TO 12) DIM Icon1%(30), Icon2%(30) 'triangle or X symbols for element centers DIM Places%(26, 2) 'Col and line numbers for each letter DIM HCol%(2) DIM Scales!(2, 2) 'matrix which converts (x,y) to (col,row) DIM UnScale!(2, 2)'matrix which converts (col,row) to (x,y) DIM Renum%(6) 'internal node numbers of an element in counterclockwise order DIM Mask%(1200) 'storage for the highlight mask, 29 characters x 1 line DIM TITLE AS STRING * 80 DIM ColArray&(0 TO 15) '--------------------------------------------------------------------- '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: COMMON SHARED Argument!, Colored%, CursorOn%, DoIcon%, FIPoint!(), HiCol%, HiColor%, HiRow%, Icon1%(), Icon2%(), LastPutC%, LastPutR%, Mantle%, R2C!, Scales!(), XatTL!, XCenter!, YatTL!, YCenter! '--------------------------------------------------------------------- 'FALSE% = 0 'Note: These are commented out because they 'TRUE% = NOT FALSE% 'already appear in an $INCLUDEd file above. '---------------------------------------------------------------------- 'Code to find highest-resolution video mode available ' by trial-and (trapped) error; a mode with two graphics ' pages is preferred to one with better color or resolution, for speed. ON ERROR GOTO ErrorHandler GOTO Beginning: ErrorHandler: RESUME TryAgain Beginning: Modes%(1) = 12 'VGA + color 1st choice Modes%(2) = 11 'VGA + monochrome 2nd choice Modes%(3) = 9 'EGA + color | Modes%(4) = 10 'EGA + monochrome | Modes%(5) = 3 'Hercules V Modes%(6) = 2 'CGA (used as monochrome) Last choice FOR i% = 7 TO 12 Modes%(i%) = Modes%(i% - 6) NEXT i% FOR i% = 1 TO 6 LastPage%(i%) = 1 'HAVING TWO PAGES TAKES PRECEDENCE OVER RESOLUTION! NEXT i% FOR i% = 7 TO 12 LastPage%(i%) = 0 NEXT i% ModeNum% = 0 TryAgain: ModeNum% = ModeNum% + 1 BestMode% = Modes%(ModeNum%) HighPage% = LastPage%(ModeNum%) SCREEN BestMode%, , HighPage%, HighPage% PageNow% = HighPage% 'statement above causes error until correct mode is found SELECT CASE BestMode% CASE 2 Colored% = FALSE% HiColor% = 1 HiRow% = 199 HiCol% = 639 Lines% = 25 HotColor% = 1 Brown% = 1 Green% = 1 Red% = 1 Yellow% = 1 White% = 1 CASE 3 Colored% = FALSE% HiColor% = 1 HiRow% = 347 HiCol% = 719 Lines% = 25 HotColor% = 1 Brown% = 1 Green% = 1 Red% = 1 Yellow% = 1 White% = 1 CASE 9 Colored% = TRUE% HiColor% = 15 ColArray&(15) = 63& ColArray&(14) = 55& ColArray&(13) = 28& ColArray&(12) = 36& ColArray&(11) = 38& ColArray&(10) = 20& ColArray&(9) = 54& ColArray&(8) = 18& ColArray&(7) = 16& ColArray&(6) = 11& ColArray&(5) = 9& ColArray&(4) = 8& ColArray&(3) = 45& ColArray&(2) = 40& ColArray&(1) = 56& ColArray&(0) = 0& PALETTE USING ColArray&(0) Brown% = 10 Green% = 8 Red% = 12 Yellow% = 9 White% = 15 Blue% = 5 HotColor% = Yellow% Foreground% = White% background% = 20 'for this mode, uses color (not attribute) HiRow% = 349 HiCol% = 639 Lines% = 25 CASE 10 Colored% = FALSE% HiColor% = 1 HiRow% = 349 HiCol% = 639 Lines% = 25 HotColor% = 1 Brown% = 1 Green% = 1 Red% = 1 Yellow% = 1 White% = 1 CASE 11 Colored% = FALSE% HiColor% = 1 HiRow% = 479 HiCol% = 639 Lines% = 30 HotColor% = 1 Brown% = 1 Green% = 1 Red% = 1 Yellow% = 1 White% = 1 CASE 12 Colored% = TRUE% HiColor% = 15 ColArray&(15) = 4144959 ColArray&(14) = 3421236 ColArray&(13) = 1976383 ColArray&(12) = 63& ColArray&(11) = 207167 ColArray&(10) = 332840 ColArray&(9) = 16191& ColArray&(8) = 16128& ColArray&(7) = 6400& ColArray&(6) = 3289600 ColArray&(5) = 4128768 ColArray&(4) = 2031616 ColArray&(3) = 4128831 ColArray&(2) = 1966110 ColArray&(1) = 986895 ColArray&(0) = 0& PALETTE USING ColArray&(0) Brown% = 10 Green% = 8 Red% = 12 Yellow% = 9 White% = 15 Blue% = 5 HotColor% = Yellow% Foreground% = White% background% = Brown% 'for this mode, uses attribute (not color) HiRow% = 479 HiCol% = 639 END SELECT ON ERROR GOTO AnyError 'turn off special handler; use generic one. LastPutC% = HiCol% - 6 LastPutR% = HiRow% - 6 GOTO LogicalStart '========================================================================= AnyError: 'generic error handler; most versatile one. BEEP CALL Delay18th(24) SCREEN BestMode%, , HighPage%, HighPage% CLS NeedMenu% = TRUE% LOCATE 2, 30 PRINT "ERROR INTERRUPT"; ' LOCATE 6, 10 PRINT "Logical error with code number of "; ERR LOCATE 7, 14 IF ERR = 9 THEN PRINT "( Subscript out of range: Due to bug in code! )" LOCATE 8, 10 PRINT "I suggest that you save grid immediately, under a new filename." ELSEIF ERR = 5 THEN PRINT "( Illegal function call )" ELSEIF ERR = 6 THEN PRINT "( Overflow: integer over 32767 or real over 3.4E+38)" ELSEIF ERR = 7 THEN PRINT "( Out of memory: Increase Reserve& and recompile. )" ELSEIF ERR = 11 THEN PRINT "( Division by zero )" ELSEIF ERR = 14 THEN PRINT "( Bad file; each line must end with both CR and LF bytes. )" ELSEIF ERR = 52 OR ERR = 64 THEN PRINT "( Bad file name )" ELSEIF ERR = 53 THEN PRINT "( File not found )" ELSEIF ERR = 55 THEN PRINT "( File already open )" ELSEIF ERR = 61 THEN PRINT "( Disk full )" ELSEIF ERR = 62 THEN PRINT "( Attempt to Input past end of file )"; LOCATE 8, 16 PRINT "Possible cause: reading FAULTS-format .FEG file in PLATES mode."; ELSEIF ERR = 70 THEN PRINT "( Permission to access file denied )" ELSEIF ERR = 71 OR ERR = 72 THEN PRINT "( Disk not ready or physically defective )" ELSEIF ERR = 76 THEN PRINT "( Path not found )" ELSE PRINT "( consult the appendix of any QuickBASIC manual )"; END IF ' ErrorCode% = ERDEV AND &HF a$ = ERDEV$ IF a$ = "" THEN a$ = "[null]" LOCATE 10, 10 PRINT "OR, device "; a$; " reports device Error Number of "; ErrorCode%; ' LOCATE 20, 5 PRINT "YOUR OPTIONS ARE:" LOCATE 22, 5 PRINT "1) Press the spacebar to return to the program, at statement after error."; LOCATE 23, 5 PRINT "2) Press Enter to abort the current command and return to the menu."; LOCATE 24, 5 PRINT "3) Press ESCape to abort DrawGrid and return to the o/s."; CALL WaitForKey(a$) IF ASC(a$) = 27 THEN SYSTEM ELSEIF ASC(a$) = 13 THEN SCREEN BestMode%, , PageNow%, PageNow% RESUME AfterError ELSEIF ASC(a$) = 32 THEN SCREEN BestMode%, , PageNow%, PageNow% RESUME NEXT ELSE GOTO AnyError END IF '========================================================================= LogicalStart: ' 'initialize mouse MouseInit 'initialize logical flags NeedMenu% = TRUE% NeedToDraw% = TRUE% ColorIn% = FALSE% Contour% = FALSE% Logs% = FALSE% ReDo% = FALSE% DoIcon% = TRUE% Remind% = FALSE% IntLabel% = FALSE% NewTopology% = FALSE% ChangesInRAM% = FALSE% CursorOn% = FALSE% 'initialize grid NUMNOD% = 0: NREALN% = 0: NFAKEN% = 0: N1000% = 30000 NUMEL% = 0: NFL% = 0 TITLE = "TITLE?" ' initialize window Argument! = 0! XatTL! = 0! WindowWidth! = 1! YatTL! = WindowWidth! * .75 CALL Scaler(Ins, WindowWidth!, Outs, Tolerance!, UnScale!()) 'initialize second coordinate system Using2nd% = FALSE% From2nd11! = 1! From2nd12! = 0! From2ndX! = 0! From2ndY! = 0! To2nd11! = 1! To2nd12! = 0! To2ndX! = 0! To2ndY! = 0! 'initialize data editing IData% = 1 'create highlight mask CLS col% = (HiCol% + 1) * 29! / 80! - 1 row% = (HiRow% + 1) / Lines% - 1 IF Colored% THEN LINE (0, 0)-(col%, row%), 1, BF ELSE LINE (0, 0)-(col%, row%), , BF END IF GET (0, 0)-(col%, row%), Mask% 'create triangle icon CLS IF Colored% THEN COLOR Green% LINE (0, 0)-(0, 6) LINE (0, 6)-(6, 6) LINE (6, 6)-(0, 0) GET (0, 0)-(6, 6), Icon1% 'create X icon CLS IF Colored% THEN COLOR HotColor% LINE (0, 0)-(6, 6) LINE (0, 6)-(6, 0) GET (0, 0)-(6, 6), Icon2% 'points for plotting fault dips FIPoint!(1) = .125 FIPoint!(2) = .375 FIPoint!(3) = .625 FIPoint!(4) = .875 'order of nodes around an element Renum%(1) = 1: Renum%(2) = 4: Renum%(3) = 2: Renum%(4) = 5: Renum%(5) = 3: Renum%(6) = 6 'integration points of triangular elements POINTS!(1, 1) = .333333: POINTS!(2, 1) = .333333: POINTS!(3, 1) = .333333: POINTS!(4, 1) = .333333 POINTS!(1, 2) = .059715: POINTS!(2, 2) = .47014: POINTS!(3, 2) = .47014: POINTS!(4, 2) = .059715 POINTS!(1, 3) = .47014: POINTS!(2, 3) = .059715: POINTS!(3, 3) = .47014: POINTS!(4, 3) = .47014 POINTS!(1, 4) = .47014: POINTS!(2, 4) = .47014: POINTS!(3, 4) = .059715: POINTS!(4, 4) = .47014 POINTS!(1, 5) = .797426: POINTS!(2, 5) = .101286: POINTS!(3, 5) = .101286: POINTS!(4, 5) = .797426 POINTS!(1, 6) = .101286: POINTS!(2, 6) = .797426: POINTS!(3, 6) = .101286: POINTS!(4, 6) = .101286 POINTS!(1, 7) = .101286: POINTS!(2, 7) = .101286: POINTS!(3, 7) = .797426: POINTS!(4, 7) = .101286 '------------------------------------------- 'introductory screens CALL FirstScreen(Ins, BestMode%, Foreground%, HotColor%, Red%, Green%, Yellow%, White%, Outs, PageNow%)'------------------------------------------------------- CALL SecondScreen(Ins, BestMode%, Foreground%, HotColor%, Outs, PageNow%) '--------------------------------------------- ' initialize menu Current$ = "D" HotCol% = 1 HotLine% = 3 CW1% = (HiCol% + 1) / 80! 'corners of dialog box, for blanking CW2% = (HiCol% + 1) * 79! / 80! - 1 'purposes RW1% = (HiRow% + 1) * 15! / Lines% RW2% = (HiRow% + 1) * 24! / Lines% - 1 'fault dips Shallow! = 25! Steep! = 65! '---------------------------------------------------------------- 'Determine default disk and current directory. ' SCREEN BestMode%, , HighPage%, HighPage% PageNow% = HighPage% IF Colored% THEN COLOR Foreground% CLS LOCATE 12, 30 PRINT "One moment, please ..." SHELL "CHDIR > TEMP9375.284" OPEN "TEMP9375.284" FOR INPUT AS #1 LEN = 128 LINE INPUT #1, CD$ CLOSE #1 KILL "TEMP9375.284" CD$ = UCASE$(CD$) IF RIGHT$(CD$, 1) = "\" THEN CD$ = LEFT$(CD$, LEN(CD$) - 1) '--------------------------------------------------------------- 'determine limits on array sizes: 'Note 1: This must be done AFTER the SHELL command, not before. 'Note 2: This calculation assumes an OPTION BASE 1 statement is above. Reserve& = 3 * 1024& ' Reserve a tiny bit of memory for rounding- RAM& = FRE(-1) - Reserve& ' up of array lengths to segment boundaries. IF Mantle% THEN MXFEL% = RAM& / 222 ELSE MXFEL% = RAM& / 198 ' First estimate, w/o considering boundary. END IF MXNODE% = 6 * MXFEL% ' " " MXBN% = 16 * SQR(CSNG(MXNODE%)) '(4 for a square; 16 for extra tortuosity) GRAM& = RAM& - 2 * MXBN% ' Correct RAM for boundary array(s) IF Mantle% THEN MXFEL% = GRAM& / 222 MXHL% = 6 * MXFEL% ELSE MXFEL% = GRAM& / 198 MXHL% = 1 END IF ' Corrected limits: maximum faults MXEL% = 2 * MXFEL% ' maximum elements MXNODE% = 3 * MXEL% ' maximum nodes '------------------------------------------------------------------------ 'large arrays, all placed in far heap: REM $DYNAMIC DIM NMemo%(MXNODE%), XNODE!(MXNODE%), YNODE!(MXNODE%) IF Mantle% THEN DIM EQCM!(4, MXNODE%) ELSE DIM EQCM!(3, MXNODE%) END IF DIM NODES%(6, MXEL%), EMemo%(MXEL%) DIM FAZ!(2, MXFEL%), FDIP!(3, MXFEL%), FMemo%(MXFEL%) DIM NODEF%(6, MXFEL%), OFFSET!(MXFEL%) DIM NODCON%(MXBN%) 'initialize properties of node 1 (a popular model) EQCM!(1, 1) = 0! EQCM!(2, 1) = 0! EQCM!(3, 1) = 0! IF Mantle% THEN EQCM!(4, 1) = 0! NMemo%(1) = 1 '======================================================================= AfterError: CommandLoop: IF NeedMenu% THEN CALL SetMenu(Ins, background%, BestMode%, Current$, Foreground%, HCol%(), HotCol%, HotLine%, HighPage%, Lines%, Mask%(), Mods, NeedMenu%, Outs, HRow%, PageNow%, Places%(), Trial$) CALL RunMenu(Ins, background%, BestMode%, CD$, CommandKey$, CW1%, CW2%, Foreground%, HCol%(), HotCol%, HotColor%, HotLine%, HRow%, Lines%, Mask%(), MXEL%, MXFEL%, MXNODE%, NFL%, NUMEL%, NUMNOD%, Places%(), RAM&, RW1%, RW2%, Trial$, Outs, Current$) '----------------------------------------------------------------------- 'Carry Out The Commands! IF Current$ = "D" THEN GetNewCD: LOCATE 23, 5 PRINT "Current directory is now set to:"; Blanks$ = " " Pad% = 40 - LEN(CD$) a$ = CD$ + RIGHT$(Blanks$, Pad%) LOCATE 23, 38 PRINT a$; LOCATE 24, 5 PRINT "(Return/Enter to accept, or type preferred path)"; LOCATE 23, 38 CALL WaitForKey(a$) IF a$ = CHR$(13) THEN ELSE LOCATE 23, 38 PRINT Blanks$ LOCATE 23, 38 PRINT a$; a$ = UCASE$(a$) INPUT ; "", b$ TrialCD$ = a$ + b$ IF RIGHT$(TrialCD$, 1) = ":" THEN TrialCD$ = TrialCD$ + "\" CHDIR TrialCD$ IF MID$(TrialCD$, 2, 1) = ":" THEN CHDRIVE TrialCD$ CD$ = UCASE$(TrialCD$) END IF ELSEIF Current$ = "B" THEN IntLabel% = TRUE% GetBasemap: FileN$ = CD$ + "\*.DIG" IF LEN(DIR$(FileN$)) = 0 THEN CALL Blanker(16, 24, 2, 79) LOCATE 19, 10 PRINT "There are no .DIG files in the current directory." LOCATE 21, 10 PRINT "Press Enter to continue." CALL WaitForKey(a$) ELSE CALL Blanker(16, 24, 2, 79) LOCATE 16, 10: PRINT "The following .DIG files are available in the current directory,"; LOCATE 17, 3: FILES FileN$ NeedMenu% = TRUE% CALL Blanker(23, 24, 2, 79) LOCATE 23, 10 PRINT "If you do not want any of these basemap files, press ESCape now."; LOCATE 24, 10 PRINT "If you do, press Enter to continue ..."; CALL WaitForKey(a$) IF a$ = CHR$(27) THEN UsingBase% = FALSE% FOR i% = 16 TO 24 'repair damage to dialog box frame LOCATE i%, 1: PRINT CHR$(186); NEXT i% ELSE CALL Blanker(23, 24, 3, 78) a$ = "Enter an existing filename (1-8 characters, no extension): " CALL GetFileName(a$, 23, NewName$) BaseMapN$ = CD$ + "\" + NewName$ + ".DIG" IF LEN(DIR$(BaseMapN$)) = 0 THEN BEEP GOTO GetBasemap ELSE BinaryN$ = CD$ + "\" + NewName$ + ".BIN" IF (LEN(DIR$(BinaryN$)) = 0) OR (NewName$ = "BADNODES") THEN 'create a binary file ' nature of endmark must be inferred: SeeEWidth% = 3 'default SeeEndMark$ = "***" 'default CLOSE #2 OPEN BaseMapN$ FOR INPUT AS #2 LEN = 128 PastTitles% = FALSE% DO UNTIL EOF(2) LINE INPUT #2, Rec$ CALL LineOfNumbers(Ins, Rec$, Outs, AreNumbers%) IF AreNumbers% THEN PastTitles% = TRUE% ELSE IF PastTitles% THEN SeeEndMark$ = Rec$ EXIT DO END IF END IF LOOP SeeEWidth% = LEN(SeeEndMark$) IF SeeEWidth% > 4 THEN SeeEWidth% = 4 SeeEndMark$ = LEFT$(SeeEndMark$, 4) END IF CLOSE #2 OPEN BaseMapN$ FOR INPUT AS #2 LEN = 128 OPEN BinaryN$ FOR BINARY AS #3 LEN = 128 np& = 0 CALL Blanker(23, 24, 2, 79) LOCATE 23, 19: PRINT "Making a binary-file copy to speed access..."; LOCATE 24, 26: PRINT "Number of points read ="; DO UNTIL EOF(2) 'loop on line segments 'work past any titles (any number of titles): DO UNTIL EOF(2) 'loop on title lines LINE INPUT #2, Rec$ CALL LineOfNumbers(Ins, Rec$, Outs, AreNumbers%) IF AreNumbers% THEN EXIT DO LOOP 'Rec$ should now contain first numbers: DO 'loop on number pairs IF LEFT$(Rec$, SeeEWidth%) = SeeEndMark$ THEN X! = -.12345 'special value used as endmark Y! = 0! PUT #3, , X! PUT #3, , Y! EXIT DO ELSE np& = np& + 1& LOCATE 24, 50: PRINT np&; X! = VAL(MID$(Rec$, 2, 12)) Y! = VAL(MID$(Rec$, 15, 12)) PUT #3, , X! PUT #3, , Y! END IF 'prepare to loop by reading next line IF EOF(2) THEN EXIT DO LINE INPUT #2, Rec$ LOOP 'until this line segment is completed LOOP 'until all line segments are read CLOSE #2 CLOSE #3 END IF 'find limits of x any y for window scaling XMin! = 3E+38: XMax! = -3E+38 YMin! = 3E+38: YMax! = -3E+38 CLOSE #3 OPEN BinaryN$ FOR BINARY AS #3 LEN = 128 CALL Blanker(23, 24, 2, 79) LOCATE 23, 10 PRINT "Checking for extreme values of x and y to scale the window ..."; np& = 0 DO GET #3, , X! IF EOF(3) THEN EXIT DO 'Note: EOF for BINARY bases its value ' on the result of the last GET, and does not test for itself! GET #3, , Y! np& = np& + 1& IF X! <> -.12345 THEN IF X! > XMax! THEN XMax! = X! IF Y! > YMax! THEN YMax! = Y! IF X! < XMin! THEN XMin! = X! IF Y! < YMin! THEN YMin! = Y! END IF IF np& MOD 100& = 0 THEN LOCATE 24, 32: PRINT np&; " points read"; LOOP CLOSE #3 UsingBase% = TRUE% NeedToDraw% = TRUE% WindowWidth! = XMax! - XMin! YWidth! = (YMax! - YMin!) / .75 IF YWidth! > WindowWidth! THEN WindowWidth! = YWidth! XatTL! = .5 * (XMin! + XMax!) - .5 * WindowWidth! YatTL! = .5 * (YMin! + YMax!) + .375 * WindowWidth! Argument! = 0! CALL Scaler(Ins, WindowWidth!, Outs, Tolerance!, UnScale!()) FOR i% = 16 TO 24 'repair damage to dialog frame LOCATE i%, 1: PRINT CHR$(186); NEXT i% GOSUB ToPage0 GOSUB RunPage0 END IF END IF END IF ELSEIF Current$ = "C" THEN IntLabel% = FALSE% IF GridLoaded% THEN IF ChangesInRAM% THEN IF Colored% THEN COLOR HotColor% LOCATE 24, 5 PRINT "*** EDITING WORK WILL BE LOST IN __ SECONDS, UNLESS A KEY IS PRESSED! ***"; FOR i% = 10 TO 1 STEP -1 PLAY "MBL64O5C" LOCATE 24, 38: PRINT ; USING "##"; i%; FOR j% = 1 TO 7 CALL Delay18th(2) IF j% MOD 2 = 0 THEN LOCATE 24, 5: PRINT " "; : LOCATE 24, 75: PRINT " "; ELSE LOCATE 24, 5: PRINT "***"; : LOCATE 24, 75: PRINT "***"; END IF a$ = INKEY$: IF LEN(a$) > 0 THEN GOTO Collector NEXT j% NEXT i% END IF PLAY "MBL32O2AGFEDCO1BL4A" IF Colored% THEN COLOR Foreground% NeedToDraw% = TRUE% Contour% = FALSE% GridLoaded% = FALSE% ChangesInRAM% = FALSE% ColorIn% = FALSE% NUMNOD% = 0: NREALN% = 0: NFAKEN% = 0: N1000% = 30000 NUMEL% = 0: NFL% = 0: TITLE = "TITLE?" NewTopology% = FALSE% ELSE BEEP LOCATE 24, 32: PRINT "No grid is loaded."; CALL Delay18th(32) END IF ELSEIF Current$ = "L" THEN IntLabel% = TRUE% IF GridLoaded% THEN BEEP ELSE GetGridfile: FileN$ = CD$ + "\*.FEG" IF LEN(DIR$(FileN$)) = 0 THEN CALL Blanker(16, 24, 2, 79) LOCATE 19, 10 PRINT "There are no .FEG files in the current directory." LOCATE 20, 10 PRINT "Try changing directories with the Directory command." LOCATE 21, 10 PRINT "Press Enter to continue." CALL WaitForKey(a$) ELSE CALL Blanker(16, 24, 2, 79) LOCATE 16, 10: PRINT "The following .FEG files are available in the current directory,"; LOCATE 17, 3: FILES FileN$ NeedMenu% = TRUE% CALL Blanker(23, 24, 2, 79) LOCATE 23, 10 PRINT "If you do not want any of these grid files, press ESCape now."; LOCATE 24, 10 PRINT "If you do, press Enter to continue ..."; CALL WaitForKey(a$) IF a$ = CHR$(27) THEN GridFileN$ = "" GridLoaded% = FALSE% FOR i% = 16 TO 24 'repair damage to window frame LOCATE i%, 1: PRINT CHR$(186); NEXT i% ELSE CALL Blanker(23, 24, 3, 78) a$ = "Enter an existing filename (1-8 characters, no extension): " CALL GetFileName(a$, 23, NewName$) GridFileN$ = CD$ + "\" + NewName$ + ".FEG" IF LEN(DIR$(GridFileN$)) = 0 THEN BEEP GOTO GetGridfile ELSE GridLoaded% = TRUE% NeedToDraw% = TRUE% CALL 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%) IF FAILED% THEN BEEP CALL WaitForKey(a$) GOTO Collector END IF 'outer limits of x and y are needed to rescale window CALL XYBounds(Ins, NUMNOD%, XNODE!(), YNODE!(), Outs, XMin!, XMax!, YMin!, YMax!) WindowWidth! = 1.02 * (XMax! - XMin!) YWidth! = 1.02 * (YMax! - YMin!) / .75 IF YWidth! > WindowWidth! THEN WindowWidth! = YWidth! XatTL! = .5 * (XMin! + XMax!) - .5 * WindowWidth! YatTL! = .5 * (YMin! + YMax!) + .375 * WindowWidth! Argument! = 0! CALL Scaler(Ins, WindowWidth!, Outs, Tolerance!, UnScale!()) FOR i% = 16 TO 24 'repair damage to dialog box LOCATE i%, 1: PRINT CHR$(186); NEXT i% GOSUB ToPage0 GOSUB RunPage0 END IF END IF END IF END IF ELSEIF Current$ = "S" THEN IF GridLoaded% THEN SaveGridfile: FileN$ = CD$ + "\*.FEG" IF LEN(DIR$(FileN$)) = 0 THEN CALL Blanker(16, 24, 2, 79) LOCATE 19, 10 PRINT "(There are no .FEG files in the current directory.)" ELSE CALL Blanker(16, 24, 2, 79) LOCATE 16, 10: PRINT "The following .FEG files are already in the current directory,"; LOCATE 17, 3: FILES FileN$ NeedMenu% = TRUE% CALL Blanker(23, 24, 2, 79) END IF CALL Blanker(23, 24, 3, 78) a$ = "Enter a filename to save under (1-8 characters, no extension): " CALL GetFileName(a$, 23, NewName$) GridFileN$ = CD$ + "\" + NewName$ + ".FEG" '- - - - - - - - - - - - - - - - - - - - - - - - - - 'This section should NOT be needed, in theory! 'But, it is included to prevent any possible loss of information: FOR i% = 1 TO NUMEL% FOR j% = 1 TO 3 NMemo%(NODES%(j%, i%)) = 0 NEXT j% NEXT i% FOR i% = 1 TO NFL% NMemo%(NODEF%(1, i%)) = 0 NMemo%(NODEF%(3, i%)) = 0 NMemo%(NODEF%(4, i%)) = 0 NMemo%(NODEF%(6, i%)) = 0 NEXT i% '- - - - - - - - - - - - - - - - - - - - - - - - - CALL PutNet(GridFileN$, TITLE, NUMNOD%, NREALN%, NFAKEN%, N1000%, NMemo%(), XNODE!(), YNODE!(), EQCM!(), NUMEL%, NODES%(), NFL%, NODEF%(), FAZ!(), FDIP!(), OFFSET!()) ChangesInRAM% = FALSE% IF NewTopology% THEN Remind% = TRUE% FOR i% = 16 TO 24 'repair damage to window frame LOCATE i%, 1: PRINT CHR$(186); NEXT i% ELSE BEEP END IF ELSEIF Current$ = "X" THEN IF GridLoaded% THEN BEEP ELSE IF LEN(DIR$("BADNODES.BIN")) > 0 THEN CLOSE #3 KILL "BADNODES.BIN" END IF IF Remind% THEN CLS LOCATE 10, 13 PRINT "Since you have created or modified a grid, remember that" LOCATE 12, 13 PRINT "it is necessary to renumber the nodes with utility program" LOCATE 14, 13 PRINT "NUMBER before using the grid in finite element program FAULTS." LOCATE 24, 60: PRINT "Press any key ..."; CALL WaitForKey(a$) END IF CLS SYSTEM END IF ELSEIF Current$ = "W" THEN IntLabel% = TRUE% LOCATE 21, 10: PRINT USING "Current X of window center = +#.##^^^^"; XCenter!; LOCATE 22, 10: PRINT "Press Enter to accept, or enter X: "; CALL WaitForKey(a$) IF ASC(a$) = 13 THEN 'no change in x ax! = XCenter! ELSE LOCATE 22, 45: PRINT a$; INPUT ; "", b$ a$ = a$ + b$ ax! = VAL(a$) END IF LOCATE 23, 10: PRINT USING "Current Y of window center = +#.##^^^^"; YCenter!; LOCATE 24, 10: PRINT "Press Enter to accept, or enter Y: "; CALL WaitForKey(a$) IF ASC(a$) = 13 THEN 'no change in x ay! = YCenter! ELSE LOCATE 24, 45: PRINT a$; INPUT ; "", b$ a$ = a$ + b$ ay! = VAL(a$) END IF XatTL! = XatTL! + (ax! - XCenter!) YatTL! = YatTL! + (ay! - YCenter!) CALL Scaler(Ins, WindowWidth!, Outs, Tolerance!, UnScale!()) NeedToDraw% = TRUE% GOSUB ToPage0 GOSUB RunPage0 ELSEIF Current$ = "O" THEN IntLabel% = TRUE% LineDown% = FALSE% GOSUB ToPage0 OLoop: GOSUB RunPage0 IF Left% THEN OChosen% = TRUE% MouseXYB Row0%, Col0%, MouseLeft%, MouseRight% CALL XandY(Ins, Col0%, Row0%, UnScale!(), Outs, XO!, YO!) GOTO OLoop ELSEIF Right% THEN IF OChosen% THEN MouseXYB row%, col%, MouseLeft%, MouseRight% CALL XandY(Ins, col%, row%, UnScale!(), Outs, XR!, YR!) IF (XR! = XO!) AND (YR! = YO!) THEN BEEP ELSE Using2nd% = TRUE% Arg2nd! = ATAN2F(YR! - YO!, XR! - XO!) To2nd11! = COS(Arg2nd!) To2nd12! = SIN(Arg2nd!) From2nd11! = To2nd11! From2nd12! = -To2nd12! To2ndX! = -To2nd11! * XO! - To2nd12! * YO! To2ndY! = To2nd12! * XO! - To2nd11! * YO! From2ndX! = -From2nd11! * To2ndX! - From2nd12! * To2ndY! From2ndY! = From2nd12! * To2ndX! - From2nd11! * To2ndY! IF LineDown% THEN CALL XORLine(col1%, row1%, col2%, row2%, HiColor%) GOSUB MouseOff CALL XORLine(Col0%, Row0%, col%, row%, HiColor%) GOSUB MouseOn LineDown% = TRUE% col1% = Col0%: row1% = Row0% col2% = col%: row2% = row% END IF ELSE BEEP END IF GOTO OLoop END IF ELSEIF Current$ = "Z" THEN IntLabel% = TRUE% GetWide: CALL Blanker(22, 24, 2, 79) LOCATE 22, 10: PRINT USING "Current width of window = +#.##^^^^"; WindowWidth!; LOCATE 23, 10: PRINT "Press Enter to accept, or enter new width: "; CALL WaitForKey(a$) IF ASC(a$) = 13 THEN 'no change in window width a! = WindowWidth! ELSE LOCATE 23, 54: PRINT a$; INPUT ; "", b$ a$ = a$ + b$ a! = VAL(a$) IF a! <= 0! THEN BEEP GOTO GetWide END IF END IF LOCATE 24, 10: PRINT "Now click on desired center of window..."; CALL Delay18th(18) GOSUB ToPage0 NewCenter: GOSUB RunPage0 IF Left% OR Right% THEN MouseXYB row%, col%, MouseLeft%, MouseRight% CALL XandY(Ins, col%, row%, UnScale!(), Outs, XC!, YC!) WindowWidth! = a! XatTL! = XC! + .625 * WindowWidth! * COS(2.4981 + Argument!) YatTL! = YC! + .625 * WindowWidth! * SIN(2.4981 + Argument!) CALL Scaler(Ins, WindowWidth!, Outs, Tolerance!, UnScale!()) NeedToDraw% = TRUE% DO WHILE Left% OR Right% 'wait for button to lift MouseXYB MouseRow%, MouseCol%, Left%, Right% LOOP MousePut 0, 0 GOTO NewCenter END IF ELSEIF Current$ = "T" THEN IntLabel% = TRUE% Angle! = 57.296 * Argument! LOCATE 20, 4: PRINT "ANGLE, in degrees, measures the counterclockwise rotation of the" LOCATE 21, 4: PRINT "screen relative to the (x,y) coordinate system, which is the same as" LOCATE 22, 4: PRINT "the clockwise rotation of the (x,y) system with respect to the screen." LOCATE 23, 10: PRINT USING "Current value of ANGLE = +###."; Angle!; LOCATE 24, 10: PRINT "Press Enter to accept, or enter ANGLE: "; CALL WaitForKey(a$) IF ASC(a$) = 13 THEN 'no change in x a! = Argument! ELSE LOCATE 24, 49: PRINT a$; INPUT ; "", b$ a$ = a$ + b$ a! = VAL(a$) / 57.296 END IF Argument! = a! XatTL! = XCenter! + .625 * WindowWidth! * COS(Argument! + 2.498) YatTL! = YCenter! + .625 * WindowWidth! * SIN(Argument! + 2.498) CALL Scaler(Ins, WindowWidth!, Outs, Tolerance!, UnScale!()) NeedToDraw% = TRUE% GOSUB ToPage0 GOSUB RunPage0 ELSEIF Current$ = "R" THEN IntLabel% = TRUE% NeedToDraw% = TRUE% Contour% = FALSE% NeedMenu% = TRUE% ColorIn% = FALSE% Using2nd% = FALSE% From2nd11! = 1! From2nd12! = 0! From2ndX! = 0! From2ndY! = 0! To2nd11! = 1! To2nd12! = 0! To2ndX! = 0! To2ndY! = 0! GOSUB ToPage0 GOSUB RunPage0 ELSEIF (Current$ = "H") OR (Current$ = "Q") THEN IntLabel% = TRUE% IF ColorIn% THEN NeedToDraw% = TRUE% ColorIn% = FALSE% END IF GetSide: CALL Blanker(24, 24, 2, 79) IF Current$ = "H" THEN LOCATE 24, 4: PRINT "Enter length of all element sides: "; INPUT ; "", a$ XSide! = VAL(a$) 'this method avoids Redo-from-start scrolling! IF XSide! <= 0! THEN BEEP GOTO GetSide END IF YSide! = .866025 * XSide! Slant! = .577351 ELSE LOCATE 24, 4: PRINT "Enter length along x' axis of 2-element rectangles: "; INPUT ; "", a$ XSide! = VAL(a$) IF XSide! <= 0! THEN BEEP GOTO GetSide END IF GetSide2: CALL Blanker(24, 24, 2, 79) LOCATE 24, 4: PRINT "Enter length along y' axis of 2-element rectangles: "; INPUT ; "", a$ YSide! = VAL(a$) IF YSide! <= 0! THEN BEEP GOTO GetSide2 END IF Slant! = 0! END IF Fudge! = .1 * XSide! IF YSide! < XSide! THEN Fudge! = .1 * YSide! GOSUB ToPage0 NewPoly: NPoly% = 0 'begin input of convex polygon MorePoly: GOSUB RunPage0 IF Left% THEN NPoly% = NPoly% + 1 IF NPoly% > 19 THEN BEEP NeedToDraw% = TRUE% GOTO Collector END IF MouseXYB row%, col%, MouseLeft%, MouseRight% CALL XandY(Ins, col%, row%, UnScale!(), Outs, X!, Y!) XPoly!(NPoly%) = X! YPoly!(NPoly%) = Y! GOSUB MouseOff IF NPoly% = 1 THEN PSET (col%, row%), HotColor% PSET (col% + 1, row%), HotColor% PSET (col% - 1, row%), HotColor% PSET (col%, row% + 1), HotColor% PSET (col%, row% - 1), HotColor% ELSE CALL XORLine(ColOld%, RowOld%, col%, row%, HiColor%) END IF GOSUB MouseOn DO WHILE Left%: MouseXYB MouseRow%, MouseCol%, Left%, Right%: LOOP ColOld% = col% RowOld% = row% GOTO MorePoly ELSEIF Right% THEN IF NPoly% < 3 THEN BEEP GOTO MorePoly END IF NPoly% = NPoly% + 1 XPoly!(NPoly%) = XPoly!(1) YPoly!(NPoly%) = YPoly!(1) CALL Pixels(Ins, XPoly!(1), YPoly!(1), Outs, col%, row%) GOSUB MouseOff CALL XORLine(ColOld%, RowOld%, col%, row%, HiColor%) XMin! = 3E+38: XMax! = -3E+38 YMin! = 3E+38: YMax! = -3E+38 FOR i% = 1 TO NPoly% X2! = To2nd11! * XPoly!(i%) + To2nd12! * YPoly!(i%) + To2ndX! Y2! = -To2nd12! * XPoly!(i%) + To2nd11! * YPoly!(i%) + To2ndY! IF X2! > XMax! THEN XMax! = X2! IF Y2! > YMax! THEN YMax! = Y2! IF X2! < XMin! THEN XMin! = X2! IF Y2! < YMin! THEN YMin! = Y2! NEXT i% Y1% = CINT(YMin! / YSide!) Y2% = CINT(YMax! / YSide!) X1% = CINT((XMin! - Slant! * YMax!) / XSide!) X2% = CINT((XMax! - Slant! * YMin!) / XSide!) FOR Y% = Y1% TO Y2% FOR X% = X1% TO X2% FOR Half% = 1 TO 2 'allow for abort (e.g., elements too small) CommandKey$ = INKEY$ IF LEN(CommandKey$) > 0 THEN GOTO Collector ' IF Half% = 1 THEN 'lower left triangle X1! = X% * XSide! + Slant! * Y% * YSide! Y1! = Y% * YSide! X2! = (X% + 1) * XSide! + Slant! * Y% * YSide! Y2! = Y% * YSide! X3! = X% * XSide! + Slant! * (Y% + 1) * YSide! Y3! = (Y% + 1) * YSide! ELSE 'upper right triangle X1! = (X% + 1) * XSide! + Slant! * (Y% + 1) * YSide! Y1! = (Y% + 1) * YSide! X2! = X% * XSide! + Slant! * (Y% + 1) * YSide! Y2! = (Y% + 1) * YSide! X3! = (X% + 1) * XSide! + Slant! * Y% * YSide! Y3! = Y% * YSide! END IF CALL TwoToOne(Ins, From2nd11!, From2nd12!, From2ndX!, From2ndY!, Mods, X1!, Y1!) IF Inside%(X1!, Y1!, NPoly%, XPoly!(), YPoly!()) THEN CALL TwoToOne(Ins, From2nd11!, From2nd12!, From2ndX!, From2ndY!, Mods, X2!, Y2!) IF Inside%(X2!, Y2!, NPoly%, XPoly!(), YPoly!()) THEN CALL TwoToOne(Ins, From2nd11!, From2nd12!, From2ndX!, From2ndY!, Mods, X3!, Y3!) IF Inside%(X3!, Y3!, NPoly%, XPoly!(), YPoly!()) THEN 'build an element- but be sure not to duplicate nodes or elements! IF NUMNOD% > MXNODE% - 6 THEN LOCATE 1, 1 PRINT "LIMIT OF "; MXNODE%; " NODES HAS BEEN REACHED."; CALL WaitForKey(a$) GOTO Collector END IF IF NUMEL% = MXEL% THEN LOCATE 2, 1 PRINT "LIMIT OF "; MXEL%; " ELEMENTS HAS BEEN REACHED."; CALL WaitForKey(a$) GOTO Collector END IF NUMEL% = NUMEL% + 1 GridLoaded% = TRUE% NewTopology% = TRUE% ChangesInRAM% = TRUE% 'node 1 CALL Exists(Ins, 1, NUMNOD%, X1!, XNODE!(), Y1!, YNODE!(), Fudge!, Outs, n%) IF n% = 0 THEN CALL AddNode(Ins, MXNODE%, NFL%, 1, NUMEL%, X1!, Y1!, Mods, EQCM!(), NMemo%(), NODEF%(), NODES%(), NREALN%, NUMNOD%, N1000%, XNODE!(), YNODE!(), Outs, n%) UseColor% = Yellow% CALL DrawNode(n%, UseColor%, XNODE!(), YNODE!()) END IF NODES%(1, NUMEL%) = n% NMemo%(n%) = 0 'node 2 CALL Exists(Ins, 1, NUMNOD%, X2!, XNODE!(), Y2!, YNODE!(), Fudge!, Outs, n%) IF n% = 0 THEN CALL AddNode(Ins, MXNODE%, NFL%, 1, NUMEL%, X2!, Y2!, Mods, EQCM!(), NMemo%(), NODEF%(), NODES%(), NREALN%, NUMNOD%, N1000%, XNODE!(), YNODE!(), Outs, n%) UseColor% = Yellow% CALL DrawNode(n%, UseColor%, XNODE!(), YNODE!()) END IF NODES%(2, NUMEL%) = n% NMemo%(n%) = 0 'node 3 CALL Exists(Ins, 1, NUMNOD%, X3!, XNODE!(), Y3!, YNODE!(), Fudge!, Outs, n%) IF n% = 0 THEN CALL AddNode(Ins, MXNODE%, NFL%, 1, NUMEL%, X3!, Y3!, Mods, EQCM!(), NMemo%(), NODEF%(), NODES%(), NREALN%, NUMNOD%, N1000%, XNODE!(), YNODE!(), Outs, n%) UseColor% = Yellow% CALL DrawNode(n%, UseColor%, XNODE!(), YNODE!()) END IF NODES%(3, NUMEL%) = n% NMemo%(n%) = 0 'node 4 X4! = .5 * (X1! + X2!) Y4! = .5 * (Y1! + Y2!) CALL Exists(Ins, 1, NUMNOD%, X4!, XNODE!(), Y4!, YNODE!(), Fudge!, Outs, n%) IF n% = 0 THEN CALL AddNode(Ins, MXNODE%, NFL%, 1, NUMEL%, X4!, Y4!, Mods, EQCM!(), NMemo%(), NODEF%(), NODES%(), NREALN%, NUMNOD%, N1000%, XNODE!(), YNODE!(), Outs, n%) UseColor% = Yellow% CALL DrawNode(n%, UseColor%, XNODE!(), YNODE!()) END IF NODES%(4, NUMEL%) = n% NMemo%(n%) = 1 'node 5 X5! = .5 * (X2! + X3!) Y5! = .5 * (Y2! + Y3!) CALL Exists(Ins, 1, NUMNOD%, X5!, XNODE!(), Y5!, YNODE!(), Fudge!, Outs, n%) IF n% = 0 THEN CALL AddNode(Ins, MXNODE%, NFL%, 1, NUMEL%, X5!, Y5!, Mods, EQCM!(), NMemo%(), NODEF%(), NODES%(), NREALN%, NUMNOD%, N1000%, XNODE!(), YNODE!(), Outs, n%) UseColor% = Yellow% CALL DrawNode(n%, UseColor%, XNODE!(), YNODE!()) END IF NODES%(5, NUMEL%) = n% NMemo%(n%) = 1 'node 6 X6! = .5 * (X3! + X1!) Y6! = .5 * (Y3! + Y1!) CALL Exists(Ins, 1, NUMNOD%, X6!, XNODE!(), Y6!, YNODE!(), Fudge!, Outs, n%) IF n% = 0 THEN CALL AddNode(Ins, MXNODE%, NFL%, 1, NUMEL%, X6!, Y6!, Mods, EQCM!(), NMemo%(), NODEF%(), NODES%(), NREALN%, NUMNOD%, N1000%, XNODE!(), YNODE!(), Outs, n%) UseColor% = Yellow% CALL DrawNode(n%, UseColor%, XNODE!(), YNODE!()) END IF NODES%(6, NUMEL%) = n% NMemo%(n%) = 1 CALL DERIV(Ins, NUMEL%, NODES%(), POINTS!(), XNODE!(), YNODE!(), Outs, EMemo%(NUMEL%)) UseColor% = Green% CALL DrawElement(BotF!, ColorIn%, Contour%, DFC!, EMemo%(), EQCM!(), NUMEL%, IData%, Logs%, NMemo%(), NODES%(), ReDo%, UseColor%, XNODE!(), YNODE!()) 'if another element already has this center spot, back up! XSum! = X1! + X2! + X3! YSum! = Y1! + Y2! + Y3! FOR i% = 1 TO NUMEL% - 1 n1% = NODES%(1, i%): N2% = NODES%(2, i%): N3% = NODES%(3, i%) xt! = XNODE!(n1%) + XNODE!(N2%) + XNODE!(N3%) yt! = YNODE!(n1%) + YNODE!(N2%) + YNODE!(N3%) IF xt! = XSum! AND yt! = YSum! THEN NUMEL% = NUMEL% - 1 EXIT FOR END IF NEXT i% END IF END IF END IF NEXT Half% NEXT X% NEXT Y% 'erase box around elements CALL Pixels(Ins, XPoly!(1), YPoly!(1), Outs, ColOld%, RowOld%) FOR i% = 2 TO NPoly% CALL Pixels(Ins, XPoly!(i%), YPoly!(i%), Outs, col%, row%) CALL XORLine(ColOld%, RowOld%, col%, row%, HiColor%) ColOld% = col% RowOld% = row% NEXT i% PRESET (col%, row%) PRESET (col% + 1, row%) PRESET (col% - 1, row%) PRESET (col%, row% + 1) PRESET (col%, row% - 1) GOSUB MouseOn GOTO NewPoly END IF ELSEIF Current$ = "A" THEN IntLabel% = TRUE% IF (ColorIn% OR Contour%) THEN NeedToDraw% = TRUE% Contour% = FALSE% ColorIn% = FALSE% END IF GOSUB ToPage0 DoMore: GOSUB RunPage0 MouseClick MouseRow%, MouseCol%, LC%, RC% IF LC% OR RC% THEN 'new node attached MouseXYB RowHOld%, ColHOld%, MouseLeft%, MouseRight% CALL XandY(Ins, ColHOld%, RowHOld%, UnScale!(), Outs, X!, Y!) NItsOn% = 0 n1% = 1 AreMore: CALL Exists(Ins, n1%, NUMNOD%, X!, XNODE!(), Y!, YNODE!(), Tolerance!, Outs, nH%) IF nH% > 0 THEN NItsOn% = NItsOn% + 1 NOn%(NItsOn%) = nH% n1% = nH% + 1 IF n1% <= NUMNOD% THEN GOTO AreMore END IF IF NItsOn% > 0 THEN GOSUB MouseOff UseColor% = Red% CALL DrawNode(NOn%(1), UseColor%, XNODE!(), YNODE!()) GOSUB MouseOn EItsOn% = 0 FItsOn% = 0 FOR n% = 1 TO NItsOn% nH% = NOn%(n%) n1% = 1 AB: CALL OnAny(Ins, nH%, n1%, NUMEL%, NODES%(), Outs, ie%, je%) IF ie% > 0 THEN EItsOn% = EItsOn% + 1 EOn%(EItsOn%) = ie% IF ie% < NUMEL% THEN n1% = ie% + 1 GOTO AB END IF END IF FOR i% = 1 TO NFL% IF nH% = NODEF%(1, i%) OR nH% = NODEF%(2, i%) OR nH% = NODEF%(3, i%) THEN FItsOn% = FItsOn% + 1 FOn%(FItsOn%) = i% FOR k% = 1 TO 6: NMemo%(NODEF%(k%, i%)) = 0: NEXT k% END IF NEXT i% NEXT n% 'erase old graphics before changing NMemo% GOSUB MouseOff UseColor% = 0 FOR j% = 1 TO EItsOn% CALL DrawElement(BotF!, ColorIn%, Contour%, DFC!, EMemo%(), EQCM!(), EOn%(j%), IData%, Logs%, NMemo%(), NODES%(), ReDo%, UseColor%, XNODE!(), YNODE!()) NEXT j% FOR j% = 1 TO FItsOn% CALL DrawFault(FAZ!(), FDIP!(), FMemo%(), FOn%(j%), NMemo%(), NODEF%(), UseColor%, XNODE!(), YNODE!()) NEXT j% GOSUB MouseOn 'change NMemo% FOR i% = 1 TO EItsOn% ie% = EOn%(i%) FOR j% = 1 TO NItsOn% nH% = NOn%(j%) CALL OnAny(Ins, nH%, ie%, ie%, NODES%(), Outs, ke%, je%) IF je% > 0 THEN EXIT FOR NEXT j% SELECT CASE je% CASE 1 NMemo%(NODES%(4, ie%)) = 0 NMemo%(NODES%(6, ie%)) = 0 CASE 2 NMemo%(NODES%(4, ie%)) = 0 NMemo%(NODES%(5, ie%)) = 0 CASE 3 NMemo%(NODES%(5, ie%)) = 0 NMemo%(NODES%(6, ie%)) = 0 CASE 4 NMemo%(NODES%(4, ie%)) = 0 CASE 5 NMemo%(NODES%(5, ie%)) = 0 CASE 6 NMemo%(NODES%(6, ie%)) = 0 END SELECT NEXT i% 'redraw with NMemo off GOSUB MouseOff UseColor% = Red%: n% = NOn%(1) CALL DrawNode(n%, UseColor%, XNODE!(), YNODE!()) UseColor% = Green% FOR j% = 1 TO EItsOn% i% = EOn%(j%) CALL DERIV(Ins, i%, NODES%(), POINTS!(), XNODE!(), YNODE!(), Outs, EMemo%(i%)) CALL DrawElement(BotF!, ColorIn%, Contour%, DFC!, EMemo%(), EQCM!(), i%, IData%, Logs%, NMemo%(), NODES%(), ReDo%, UseColor%, XNODE!(), YNODE!()) NEXT j% UseColor% = Red% FOR j% = 1 TO FItsOn% CALL GetArgs(Ins, FOn%(j%), NODEF%(), XNODE!(), YNODE!(), Outs, FAZ!()) CALL DrawFault(FAZ!(), FDIP!(), FMemo%(), FOn%(j%), NMemo%(), NODEF%(), UseColor%, XNODE!(), YNODE!()) NEXT j% GOSUB MouseOn ChangesInRAM% = TRUE% ELSE BEEP END IF GOTO DoMore ELSEIF Left% OR Right% THEN 'still attached MouseXYB RowH%, ColH%, MouseLeft%, MouseRight% IF ColH% <> ColHOld% OR RowH% <> RowHOld% THEN GOSUB MouseOff UseColor% = 0: n% = NOn%(1) CALL DrawNode(n%, UseColor%, XNODE!(), YNODE!()) FOR j% = 1 TO EItsOn% CALL DrawElement(BotF!, ColorIn%, Contour%, DFC!, EMemo%(), EQCM!(), EOn%(j%), IData%, Logs%, NMemo%(), NODES%(), ReDo%, UseColor%, XNODE!(), YNODE!()) NEXT j% FOR j% = 1 TO FItsOn% CALL DrawFault(FAZ!(), FDIP!(), FMemo%(), FOn%(j%), NMemo%(), NODEF%(), UseColor%, XNODE!(), YNODE!()) NEXT j% CALL XandY(Ins, ColH%, RowH%, UnScale!(), Outs, X!, Y!) FOR n% = 1 TO NItsOn% nH% = NOn%(n%) XNODE!(nH%) = X!: YNODE!(nH%) = Y! NEXT n% UseColor% = Red%: n% = NOn%(1) CALL DrawNode(n%, UseColor%, XNODE!(), YNODE!()) UseColor% = Green% FOR j% = 1 TO EItsOn% i% = EOn%(j%) CALL DERIV(Ins, i%, NODES%(), POINTS!(), XNODE!(), YNODE!(), Outs, EMemo%(i%)) CALL DrawElement(BotF!, ColorIn%, Contour%, DFC!, EMemo%(), EQCM!(), i%, IData%, Logs%, NMemo%(), NODES%(), ReDo%, UseColor%, XNODE!(), YNODE!()) NEXT j% UseColor% = Red% FOR j% = 1 TO FItsOn% CALL GetArgs(Ins, FOn%(j%), NODEF%(), XNODE!(), YNODE!(), Outs, FAZ!()) NEXT j% FOR j% = 1 TO FItsOn% CALL IsJoined(Ins, FAZ!(), FOn%(j%), NFL%, NODEF%(), Outs, FMemo%()) NEXT j% FOR j% = 1 TO FItsOn% CALL DrawFault(FAZ!(), FDIP!(), FMemo%(), FOn%(j%), NMemo%(), NODEF%(), UseColor%, XNODE!(), YNODE!()) NEXT j% GOSUB MouseOn ColHOld% = ColH%: RowHOld% = RowH% END IF NeedGrid% = TRUE%: NeedFaults% = TRUE%: NextFault% = NFL% GOTO DoMore END IF ELSEIF Current$ = "N" THEN IntLabel% = TRUE% IF (ColorIn% OR Contour%) THEN NeedToDraw% = TRUE% ColorIn% = FALSE% Contour% = FALSE% END IF GOSUB ToPage0 MoreNodes: GOSUB RunPage0 MouseClick MouseRow%, MouseCol%, Left%, Right% IF Left% THEN 'add node row% = MouseRow% col% = MouseCol% CALL XandY(Ins, col%, row%, UnScale!(), Outs, X!, Y!) CALL AddNode(Ins, MXNODE%, NFL%, 1, NUMEL%, X!, Y!, Mods, EQCM!(), NMemo%(), NODEF%(), NODES%(), NREALN%, NUMNOD%, N1000%, XNODE!(), YNODE!(), Outs, n%) GridLoaded% = TRUE% NewTopology% = TRUE% ChangesInRAM% = TRUE% UseColor% = Yellow% GOSUB MouseOff CALL DrawNode(n%, UseColor%, XNODE!(), YNODE!()) GOSUB MouseOn DO WHILE Left% OR Right%: MouseXYB MouseRow%, MouseCol%, Left%, Right%: LOOP GOTO MoreNodes ELSEIF Right% THEN 'remove node(s) row% = MouseRow% col% = MouseCol% CALL XandY(Ins, col%, row%, UnScale!(), Outs, X!, Y!) NItsOn% = 0 CALL Exists(Ins, 1, NUMNOD%, X!, XNODE!(), Y!, YNODE!(), Tolerance!, Outs, nH%) IF nH% > 0 THEN FOR k% = 1 TO NUMNOD% IF XNODE!(k%) = XNODE!(nH%) AND YNODE!(k%) = YNODE!(nH%) THEN CALL OnAny(Ins, k%, 1, NUMEL%, NODES%(), Outs, ie%, je%) IF ie% = 0 THEN CALL OnAny(Ins, k%, 1, NFL%, NODEF%(), Outs, ie%, je%) IF ie% = 0 THEN NItsOn% = NItsOn% + 1 NOn%(NItsOn%) = k% END IF END IF END IF NEXT k% END IF UseColor% = 0 IF NItsOn% > 0 THEN GOSUB MouseOff n% = NOn%(1) CALL DrawNode(n%, UseColor%, XNODE!(), YNODE!()) GOSUB MouseOn FOR i% = 1 TO NItsOn% n% = NOn%(i%) CALL DropNode(Ins, AKA%, n%, NFL%, NUMEL%, Mods, EQCM!(), NFAKEN%, NMemo%(), NODEF%(), NODES%(), NREALN%, NUMNOD%, XNODE!(), YNODE!()) FOR k% = i% + 1 TO NItsOn% IF NOn%(k%) > n% THEN NOn%(k%) = NOn%(k%) - 1 NEXT k% NewTopology% = TRUE% ChangesInRAM% = TRUE% IF NUMNOD% = 0 THEN GridLoaded% = FALSE% NEXT i% ELSE BEEP END IF DO WHILE Left% OR Right%: MouseXYB MouseRow%, MouseCol%, Left%, Right%: LOOP GOTO MoreNodes END IF ELSEIF Current$ = "E" THEN IntLabel% = FALSE% IF (ColorIn% OR Contour%) THEN NeedToDraw% = TRUE% ColorIn% = FALSE% Contour% = FALSE% END IF JIP% = 0 GOSUB ToPage0 MoreEs: DO WHILE Left% OR Right%: MouseXYB MouseRow%, MouseCol%, Left%, Right%: LOOP LOCATE 25, 25: PRINT JIP%; " nodes have been selected"; GOSUB RunPage0 MouseClick MouseRow%, MouseCol%, Left%, Right% IF Left% THEN 'add JIP% = (JIP% MOD 6) + 1 MouseXYB row%, col%, MouseLeft%, MouseRight% CALL XandY(Ins, col%, row%, UnScale!(), Outs, X!, Y!) CALL Exists(Ins, 1, NUMNOD%, X!, XNODE!(), Y!, YNODE!(), Tolerance!, Outs, n%) IF n% > 0 THEN CALL OnAny(Ins, n%, 1, NFL%, NODEF%(), Outs, ie%, je%) IF ie% = 0 THEN 'not on a fault (good) CALL OnAny(Ins, n%, 1, NUMEL%, NODES%(), Outs, ie%, je%) IF ie% = 0 THEN OK% = TRUE% ELSE 'node is in some element(s) IF je% <= 3 AND (JIP% MOD 2) = 1 THEN OK% = TRUE% ELSEIF je% >= 4 AND (JIP% MOD 2) = 0 THEN 'already a midpoint; check that its not used twice IF ie% = NUMEL% THEN OK% = TRUE% ELSE n1% = ie% + 1 CALL OnAny(Ins, n%, n1%, NUMEL%, NODES%(), Outs, ie%, je%) IF ie% = 0 THEN OK% = TRUE% ELSE OK% = FALSE% END IF END IF ELSE OK% = FALSE% END IF END IF 'reject this node if it was already selected FOR k% = 1 TO JIP% - 1 IF n% = EOn%(k%) THEN OK% = FALSE% NEXT k% IF OK% THEN EOn%(JIP%) = n% GOSUB MouseOff UseColor% = Red% CALL DrawNode(n%, UseColor%, XNODE!(), YNODE!()) GOSUB MouseOn IF JIP% = 6 THEN 'completed IF NUMEL% = MXEL% THEN LOCATE 2, 1 PRINT "LIMIT OF "; MXEL%; " ELEMENTS HAS BEEN REACHED."; CALL WaitForKey(a$) GOTO Collector END IF 'check that this element does not already exist NItsOn% = 0 FOR j% = 2 TO 6 STEP 2 n% = EOn%(j%) n1% = 1 MNE: CALL OnAny(Ins, n%, n1%, NUMEL%, NODES%(), Outs, ie%, je%) IF ie% > 0 THEN NItsOn% = NItsOn% + 1 NOn%(NItsOn%) = ie% IF ie% < NUMEL% THEN n1% = ie% + 1 GOTO MNE END IF END IF NEXT j% IF NItsOn% = 3 THEN IF NOn%(1) = NOn%(2) OR NOn%(2) = NOn%(3) OR NOn%(3) = NOn%(1) THEN BeenDone% = TRUE% ELSE BeenDone% = FALSE% END IF ELSEIF NItsOn% = 2 THEN IF NOn%(1) = NOn%(2) THEN BeenDone% = TRUE% ELSE BeenDone% = FALSE% END IF ELSE BeenDone% = FALSE% END IF IF BeenDone% THEN BEEP GOSUB MouseOff UseColor% = Yellow% FOR j% = 1 TO 6 n% = EOn%(j%) CALL DrawNode(n%, UseColor%, XNODE!(), YNODE!()) NEXT j% GOSUB MouseOn ELSE 'element is OK... NUMEL% = NUMEL% + 1 NewTopology% = TRUE% ChangesInRAM% = TRUE% NODES%(1, NUMEL%) = EOn%(1) NODES%(2, NUMEL%) = EOn%(3) NODES%(3, NUMEL%) = EOn%(5) NODES%(4, NUMEL%) = EOn%(2) NODES%(5, NUMEL%) = EOn%(4) NODES%(6, NUMEL%) = EOn%(6) FOR i% = 1 TO 6: NMemo%(EOn%(i%)) = 0: NEXT i% CALL DERIV(Ins, NUMEL%, NODES%(), POINTS!(), XNODE!(), YNODE!(), Outs, EMemo%(NUMEL%)) GOSUB MouseOff UseColor% = Green% CALL DrawElement(BotF!, ColorIn%, Contour%, DFC!, EMemo%(), EQCM!(), NUMEL%, IData%, Logs%, NMemo%(), NODES%(), ReDo%, UseColor%, XNODE!(), YNODE!()) UseColor% = Yellow% FOR j% = 1 TO 6 n% = NODES%(j%, NUMEL%) CALL DrawNode(n%, UseColor%, XNODE!(), YNODE!()) NEXT j% GOSUB MouseOn END IF END IF ELSE BEEP 'using this node creates bad topology JIP% = JIP% - 1 END IF ELSE BEEP 'node was on some fault JIP% = JIP% - 1 END IF ELSE BEEP 'cursor is not on any node JIP% = JIP% - 1 END IF GOTO MoreEs ELSEIF Right% THEN 'subtract an element IF JIP% MOD 6 = 0 THEN MouseXYB row%, col%, MouseLeft%, MouseRight% CALL XandY(Ins, col%, row%, UnScale!(), Outs, X!, Y!) R2Min! = 3.3E+38 FOR i% = 1 TO NUMEL% n1% = NODES%(1, i%): N2% = NODES%(2, i%): N3% = NODES%(3, i%) X1! = XNODE!(n1%): X2! = XNODE!(N2%): X3! = XNODE!(N3%): Y1! = YNODE!(n1%): Y2! = YNODE!(N2%): Y3! = YNODE!(N3%): XC! = .333333 * (X1! + X2! + X3!) YC! = .333333 * (Y1! + Y2! + Y3!) dx! = X! - XC!: DY! = Y! - YC! R2! = dx! * dx! + DY! * DY! IF R2! < R2Min! THEN R2Min! = R2!: j% = i% END IF NEXT i% IF R2Min! < Tolerance! ^ 2 THEN GOSUB MouseOff UseColor% = 0 CALL DrawElement(BotF!, ColorIn%, Contour%, DFC!, EMemo%(), EQCM!(), j%, IData%, Logs%, NMemo%(), NODES%(), ReDo%, UseColor%, XNODE!(), YNODE!()) FOR m% = 4 TO 6 n% = NODES%(m%, j%) 'redraw any neighboring elements that were partly blanked n1% = 1 TA: CALL OnAny(Ins, n%, n1%, NUMEL%, NODES%(), Outs, ie%, je%) IF ie% = j% THEN n1% = j% + 1 GOTO TA ELSEIF ie% > 0 THEN UseColor% = Green% CALL DrawElement(BotF!, ColorIn%, Contour%, DFC!, EMemo%(), EQCM!(), ie%, IData%, Logs%, NMemo%(), NODES%(), ReDo%, UseColor%, XNODE!(), YNODE!()) END IF 'redraw any neighboring faults, and check that ends are free CALL OnAny(Ins, n%, 1, NFL%, NODEF%(), Outs, ife%, jfe%) IF ife% > 0 THEN UseColor% = Red% CALL DrawFault(FAZ!(), FDIP!(), FMemo%(), ife%, NMemo%(), NODEF%(), UseColor%, XNODE!(), YNODE!()) 'if end-nodes of fault are not free, then free them! NL% = NODEF%(jfe% + 1, ife%) ie% = 0 CALL OnAny(Ins, NL%, 1, j% - 1, NODES%(), Outs, ie%, je%) IF ie% = 0 THEN CALL OnAny(Ins, NL%, j% + 1, NUMEL%, NODES%(), Outs, ie%, je%) IF ie% > 0 THEN CALL AddNode(Ins, MXNODE%, NFL%, 1, NUMEL%, XNODE!(NL%), YNODE!(NL%), Mods, EQCM!(), NMemo%(), NODEF%(), NODES%(), NREALN%, NUMNOD%, N1000%, XNODE!(), YNODE!(), Outs, New%) NODEF%(jfe% + 1, ife%) = New% END IF NR% = NODEF%(jfe% - 1, ife%) ie% = 0 CALL OnAny(Ins, NR%, 1, j% - 1, NODES%(), Outs, ie%, je%) IF ie% = 0 THEN CALL OnAny(Ins, NR%, j% + 1, NUMEL%, NODES%(), Outs, ie%, je%) IF ie% > 0 THEN CALL AddNode(Ins, MXNODE%, NFL%, 1, NUMEL%, XNODE!(NR%), YNODE!(NR%), Mods, EQCM!(), NMemo%(), NODEF%(), NODES%(), NREALN%, NUMNOD%, N1000%, XNODE!(), YNODE!(), Outs, New%) NODEF%(jfe% - 1, ife%) = New% END IF END IF NEXT m% GOSUB MouseOn NUMEL% = NUMEL% - 1 NewTopology% = TRUE% ChangesInRAM% = TRUE% FOR i% = j% TO NUMEL% EMemo%(i%) = EMemo%(i% + 1) FOR k% = 1 TO 6 NODES%(k%, i%) = NODES%(k%, i% + 1) NEXT k% NEXT i% ELSE BEEP 'not on any element symbol END IF ELSEIF JIP% > 0 THEN 'delete the element which is in progress GOSUB MouseOff UseColor% = Yellow% FOR i% = 1 TO JIP% CALL DrawNode(EOn%(i%), UseColor%, XNODE!(), YNODE!()) NEXT i% JIP% = 0 GOSUB MouseOn ELSE BEEP END IF GOTO MoreEs ELSE CALL Blanker(25, 25, 25, 60) END IF ELSEIF Current$ = "F" THEN IntLabel% = TRUE% IF (ColorIn% OR Contour%) THEN NeedToDraw% = TRUE% ColorIn% = FALSE% Contour% = FALSE% END IF GOSUB ToPage0 MF: DO WHILE Left% OR Right%: MouseXYB MouseRow%, MouseCol%, Left%, Right%: LOOP GOSUB RunPage0 IF Left% OR Right% THEN 'locate nearest midpoint MouseXYB row%, col%, MouseLeft%, MouseRight% CALL XandY(Ins, col%, row%, UnScale!(), Outs, X!, Y!) END IF IF Left% THEN 'cut a new fault CALL Exists(Ins, 1, NUMNOD%, X!, XNODE!(), Y!, YNODE!(), Tolerance!, Outs, nMid%) IF nMid% > 0 THEN EItsOn% = 0 n1% = 1 MS: CALL OnAny(Ins, nMid%, n1%, NUMEL%, NODES%(), Outs, ie%, je%) IF ie% > 0 THEN EItsOn% = EItsOn% + 1 EOn%(EItsOn%) = ie% JOn%(EItsOn%) = je% IF ie% < NUMEL% THEN n1% = ie% + 1 GOTO MS END IF END IF CALL OnAny(Ins, nMid%, 1, NFL%, NODEF%(), Outs, ifault%, jfault%) 'cannot be on any fault or boundary; must be shared by two elements as a side node IF ifault% = 0 AND EItsOn% = 2 AND JOn%(1) >= 4 THEN IF NFL% = MXFEL% THEN LOCATE 3, 1 PRINT "MAXIMUM OF "; MXFEL%; " FAULTS HAS BEEN REACHED." CALL WaitForKey(a$) GOTO Collector END IF NFL% = NFL% + 1 NewTopology% = TRUE% ChangesInRAM% = TRUE% FDIP!(1, NFL%) = 90!: FDIP!(2, NFL%) = 90!: FDIP!(3, NFL%) = 90!: OFFSET!(NFL%) = 0! jt% = JOn%(1) - 2: IF jt% = 4 THEN jt% = 1 n1% = NODES%(jt%, EOn%(1)) N2% = NODES%(JOn%(1), EOn%(1)) N3% = NODES%(JOn%(1) - 3, EOn%(1)) NODEF%(1, NFL%) = n1%: NODEF%(2, NFL%) = N2%: NODEF%(3, NFL%) = N3%: CALL GetArgs(Ins, NFL%, NODEF%(), XNODE!(), YNODE!(), Outs, FAZ!()) X1! = XNODE!(n1%): Y1! = YNODE!(n1%) X2! = XNODE!(N2%): Y2! = YNODE!(N2%) X3! = XNODE!(N3%): Y3! = YNODE!(N3%) CALL AddNode(Ins, MXNODE%, NFL% - 1, N2%, NUMEL%, X2!, Y2!, Mods, EQCM!(), NMemo%(), NODEF%(), NODES%(), NREALN%, NUMNOD%, N1000%, XNODE!(), YNODE!(), Outs, n%) NMemo%(n%) = NMemo%(NODEF%(2, NFL%)) NODEF%(5, NFL%) = n% '1st new node is midpoint NODES%(JOn%(2), EOn%(2)) = n% 'assign to opposite element 'swing around N4-N3 end: CALL AddNode(Ins, MXNODE%, NFL% - 1, N3%, NUMEL%, X3!, Y3!, Mods, EQCM!(), NMemo%(), NODEF%(), NODES%(), NREALN%, NUMNOD%, N1000%, XNODE!(), YNODE!(), Outs, New%) NODEF%(4, NFL%) = New% jt% = JOn%(2) - 2: IF jt% = 4 THEN jt% = 1 NODES%(jt%, EOn%(2)) = New% jPivot% = jt% EIn% = EOn%(2) Clockwise: jt% = jPivot% + 3 n% = NODES%(jt%, EIn%) CALL OnAny(Ins, n%, 1, EIn% - 1, NODES%(), Outs, ie%, je%) IF ie% = 0 THEN CALL OnAny(Ins, n%, EIn% + 1, NUMEL%, NODES%(), Outs, ie%, je%) IF ie% > 0 THEN EIn% = ie% jPivot% = je% - 2: IF jPivot% = 4 THEN jPivot% = 1 NODES%(jPivot%, EIn%) = New% GOTO Clockwise ELSE CALL OnAny(Ins, n%, 1, NFL% - 1, NODEF%(), Outs, ie%, je%) IF ie% > 0 THEN NODEF%(je% + 1, ie%) = New% ELSEIF n% = NODEF%(2, NFL%) THEN n% = NODEF%(3, NFL%) AKA% = New% CALL DropNode(Ins, AKA%, n%, NFL%, NUMEL%, Mods, EQCM!(), NFAKEN%, NMemo%(), NODEF%(), NODES%(), NREALN%, NUMNOD%, XNODE!(), YNODE!()) END IF END IF 'swing around N6-N1 end: CALL AddNode(Ins, MXNODE%, NFL% - 1, n1%, NUMEL%, X1!, Y1!, Mods, EQCM!(), NMemo%(), NODEF%(), NODES%(), NREALN%, NUMNOD%, N1000%, XNODE!(), YNODE!(), Outs, New%) NODEF%(6, NFL%) = New% jt% = JOn%(2) - 3 NODES%(jt%, EOn%(2)) = New% jPivot% = jt% EIn% = EOn%(2) CounterCW: jt% = jPivot% + 2: IF jt% = 3 THEN jt% = 6 n% = NODES%(jt%, EIn%) CALL OnAny(Ins, n%, 1, EIn% - 1, NODES%(), Outs, ie%, je%) IF ie% = 0 THEN CALL OnAny(Ins, n%, EIn% + 1, NUMEL%, NODES%(), Outs, ie%, je%) IF ie% > 0 THEN EIn% = ie% jPivot% = je% - 3 NODES%(jPivot%, EIn%) = New% GOTO CounterCW ELSE CALL OnAny(Ins, n%, 1, NFL% - 1, NODEF%(), Outs, ie%, je%) IF ie% > 0 THEN NODEF%(je% - 1, ie%) = New% ELSEIF n% = NODEF%(2, NFL%) THEN n% = NODEF%(1, NFL%) AKA% = New% CALL DropNode(Ins, AKA%, n%, NFL%, NUMEL%, Mods, EQCM!(), NFAKEN%, NMemo%(), NODEF%(), NODES%(), NREALN%, NUMNOD%, XNODE!(), YNODE!()) END IF GOSUB MouseOff UseColor% = Red% CALL IsJoined(Ins, FAZ!(), NFL%, NFL%, NODEF%(), Outs, FMemo%()) CALL DrawFault(FAZ!(), FDIP!(), FMemo%(), NFL%, NMemo%(), NODEF%(), UseColor%, XNODE!(), YNODE!()) GOSUB MouseOn END IF ELSE BEEP END IF ELSE BEEP END IF GOTO MF ELSEIF Right% THEN 'heal a fault CALL Exists(Ins, 1, NUMNOD%, X!, XNODE!(), Y!, YNODE!(), Tolerance!, Outs, nMid%) IF nMid% > 0 THEN CALL OnAny(Ins, nMid%, 1, NFL%, NODEF%(), Outs, ie%, je%) IF ie% > 0 THEN IF je% = 2 OR je% = 5 THEN GOSUB MouseOff UseColor% = 0 CALL DrawFault(FAZ!(), FDIP!(), FMemo%(), ie%, NMemo%(), NODEF%(), UseColor%, XNODE!(), YNODE!()) 'make sure any Joints are broken FAZ!(1, ie%) = 3!: FAZ!(2, ie%) = 4! 'impossible CALL IsJoined(Ins, FAZ!(), ie%, NFL%, NODEF%(), Outs, FMemo%()) ' UseColor% = Green% IF Colored% THEN FDIP!(1, ie%) = 90!: FDIP!(2, ie%) = 90!: FDIP!(3, ie%) = 90!: CALL DrawFault(FAZ!(), FDIP!(), FMemo%(), ie%, NMemo%(), NODEF%(), UseColor%, XNODE!(), YNODE!()) ELSE CALL OnAny(Ins, nMid%, 1, NUMEL%, NODES%(), Outs, ke%, le%) CALL DrawElement(BotF!, ColorIn%, Contour%, DFC!, EMemo%(), EQCM!(), ke%, IData%, Logs%, NMemo%(), NODES%(), ReDo%, UseColor%, XNODE!(), YNODE!()) END IF GOSUB MouseOn FOR m% = 1 TO 3 n1% = NODEF%(m%, ie%) N2% = NODEF%(7 - m%, ie%) IF n1% > N2% THEN i% = n1%: n1% = N2%: N2% = i% END IF IF n1% <> N2% THEN n% = N2% AKA% = n1% CALL DropNode(Ins, AKA%, n%, NFL%, NUMEL%, Mods, EQCM!(), NFAKEN%, NMemo%(), NODEF%(), NODES%(), NREALN%, NUMNOD%, XNODE!(), YNODE!()) END IF NEXT m% NFL% = NFL% - 1 NewTopology% = TRUE% ChangesInRAM% = TRUE% FOR i% = ie% TO NFL% FOR j% = 1 TO 6 NODEF%(j%, i%) = NODEF%(j%, i% + 1) NEXT j% FOR j% = 1 TO 3 FDIP!(j%, i%) = FDIP!(j%, i% + 1) NEXT j% FAZ!(1, i%) = FAZ!(1, i% + 1) FAZ!(2, i%) = FAZ!(2, i% + 1) FMemo%(i%) = FMemo%(i% + 1) OFFSET!(i%) = OFFSET!(i% + 1) NEXT i% ELSE BEEP 'not on midpoint node END IF ELSE BEEP 'not on a fault node END IF ELSE BEEP 'not on a node END IF GOTO MF END IF ELSEIF Current$ = "I" THEN IntLabel% = FALSE% IF (ColorIn% OR Contour%) THEN NeedToDraw% = TRUE% ColorIn% = FALSE% Contour% = FALSE% END IF GSh: LOCATE 21, 18 PRINT USING "Left mouse button = shallow dip = ##.# degrees."; Shallow!; LOCATE 22, 18: PRINT "(Press Enter to accept, or type new number)"; CALL WaitForKey(a$) IF ASC(a$) <> 13 THEN LOCATE 21, 52: PRINT a$; " " LOCATE 21, 53: INPUT ; "", b$ a$ = a$ + b$ T! = VAL(a$) IF T! < 1! OR T! > 90! THEN BEEP GOTO GSh ELSE Shallow! = T! LOCATE 21, 52: PRINT USING "##.#"; T! END IF END IF GSt: LOCATE 23, 18 PRINT USING "Right mouse button = steep dip = ##.# degrees."; Steep!; LOCATE 24, 18: PRINT "(Press Enter to accept, or type new number)"; LOCATE 23, 52 CALL WaitForKey(a$) IF ASC(a$) <> 13 THEN LOCATE 23, 52: PRINT a$; " " LOCATE 23, 53: INPUT ; "", b$ a$ = a$ + b$ T! = VAL(a$) IF T! < 1! OR T! > 90! THEN BEEP GOTO GSt ELSE Steep! = T! LOCATE 23, 52: PRINT USING "##.#"; T! END IF END IF Fudge! = .05 * WindowWidth! JIP% = 0 GOSUB ToPage0 MI: DO WHILE Left% OR Right%: MouseXYB MouseRow%, MouseCol%, Left%, Right%: LOOP JIP% = (JIP% MOD 3) + 1 LOCATE 25, 28 SELECT CASE JIP% CASE 1 PRINT "Click near a midpoint "; CASE 2 PRINT "Click near either end "; CASE 3 PRINT "Click near the other end"; END SELECT GOSUB RunPage0 IF Left% OR Right% THEN MouseXYB row%, col%, MouseLeft%, MouseRight% CALL XandY(Ins, col%, row%, UnScale!(), Outs, X!, Y!) 'pause 0.3 seconds to see if second button will also be pushed CALL Delay18th(6) OldLeft% = Left% OldRight% = Right% MouseXYB MouseRow%, MouseCol%, Left%, Right% Left% = Left% OR OldLeft% Right% = Right% OR OldRight% IF JIP% = 1 THEN CALL Exists(Ins, 1, NUMNOD%, X!, XNODE!(), Y!, YNODE!(), Fudge!, Outs, n%) IF n% > 0 THEN CALL OnAny(Ins, n%, 1, NFL%, NODEF%(), Outs, ie%, je%) IF ie% > 0 THEN IF je% = 2 OR je% = 5 THEN n1% = NODEF%(1, ie%) N2% = NODEF%(2, ie%) N3% = NODEF%(3, ie%) X1! = XNODE!(n1%): Y1! = YNODE!(n1%) X2! = XNODE!(N2%): Y2! = YNODE!(N2%) X3! = XNODE!(N3%): Y3! = YNODE!(N3%) je% = 2 SF! = .5 ELSE BEEP: JIP% = JIP% - 1: GOTO MI END IF ELSE BEEP: JIP% = JIP% - 1: GOTO MI END IF ELSE BEEP: JIP% = JIP% - 1: GOTO MI END IF ELSEIF JIP% = 2 THEN FX! = X3! - X1!: FY! = Y3! - Y1! VX! = X! - X2!: VY! = Y! - Y2! Dot! = FX! * VX! + FY! * VY! IF Dot! > 0! THEN je% = 3 SF! = 1! ELSE je% = 1 SF! = 0! END IF ELSE 'JIP% = 3 je% = 4 - je% SF! = 1! - SF! END IF DF1DS! = 4! * SF! - 3! DF2DS! = -8! * SF! + 4! DF3DS! = 4! * SF! - 1! DXDS! = DF1DS! * X1! + DF2DS! * X2! + DF3DS! * X3! DYDS! = DF1DS! * Y1! + DF2DS! * Y2! + DF3DS! * Y3! Arg! = ATAN2F!(DYDS!, DXDS!) Theta! = ATAN2F!((Y! - YNODE!(NODEF%(je%, ie%))), (X! - XNODE!(NODEF%(je%, ie%)))) Sense! = SIN(Arg! - Theta!) IF Left% AND Right% THEN NewDip! = 90! ELSEIF Left% THEN IF Sense! > 0! THEN NewDip! = Shallow! ELSE NewDip! = 180! - Shallow! END IF ELSEIF Right% THEN IF Sense! > 0! THEN NewDip! = Steep! ELSE NewDip! = 180! - Steep! END IF END IF GOSUB MouseOff UseColor% = 0 CALL DrawFault(FAZ!(), FDIP!(), FMemo%(), ie%, NMemo%(), NODEF%(), UseColor%, XNODE!(), YNODE!()) FDIP!(je%, ie%) = NewDip! UseColor% = Red% CALL DrawFault(FAZ!(), FDIP!(), FMemo%(), ie%, NMemo%(), NODEF%(), UseColor%, XNODE!(), YNODE!()) GOSUB MouseOn ChangesInRAM% = TRUE% GOTO MI ELSE CALL Blanker(25, 25, 28, 60) END IF ELSEIF Current$ = "J" THEN IntLabel% = FALSE% IF (ColorIn% OR Contour%) THEN NeedToDraw% = TRUE% ColorIn% = FALSE% Contour% = FALSE% END IF GOSUB ToPage0 MJ: DO WHILE Left% OR Right%: MouseXYB MouseRow%, MouseCol%, Left%, Right%: LOOP GOSUB RunPage0 IF Left% OR Right% THEN MouseXYB row%, col%, MouseLeft%, MouseRight% CALL XandY(Ins, col%, row%, UnScale!(), Outs, X!, Y!) n1% = 1: NItsOn% = 0 MNJ: CALL Exists(Ins, n1%, NUMNOD%, X!, XNODE!(), Y!, YNODE!(), Tolerance!, Outs, nH%) IF nH% > 0 THEN NItsOn% = NItsOn% + 1 NOn%(NItsOn%) = nH% n1% = nH% + 1 IF n1% <= NUMNOD% THEN GOTO MNJ END IF IF NItsOn% > 0 THEN FItsOn% = 0 FOR i% = 1 TO NFL% FOR j% = 1 TO NItsOn% IF NODEF%(1, i%) = NOn%(j%) OR NODEF%(6, i%) = NOn%(j%) THEN FItsOn% = FItsOn% + 1 FOn%(FItsOn%) = i% EOn%(FItsOn%) = 1 EXIT FOR ELSEIF NODEF%(3, i%) = NOn%(j%) OR NODEF%(4, i%) = NOn%(j%) THEN FItsOn% = FItsOn% + 1 FOn%(FItsOn%) = i% EOn%(FItsOn%) = 3 EXIT FOR END IF NEXT j% NEXT i% IF FItsOn% = 1 OR FItsOn% = 2 THEN nH% = NOn%(1) GOSUB MouseOff UseColor% = Yellow% FOR j% = 1 TO FItsOn% CALL DrawFault(FAZ!(), FDIP!(), FMemo%(), FOn%(j%), NMemo%(), NODEF%(), UseColor%, XNODE!(), YNODE!()) NEXT j% CALL Pixels(Ins, XNODE!(nH%), YNODE!(nH%), Outs, ColOld%, RowOld%) CALL MousePut(RowOld%, ColOld%) CALL XandY(Ins, ColOld%, RowOld%, UnScale!(), Outs, XOld!, YOld!) CALL Blanker(25, 25, 15, 65) IF EOn%(1) = 1 THEN OldArg! = FAZ!(1, FOn%(1)) ELSE OldArg! = FAZ!(2, FOn%(1)) END IF Wind: MouseXYB row%, col%, MouseLeft%, MouseRight% IF col% <> ColOld% OR row% <> RowOld% THEN CALL XORLine(2 * ColOld% - col%, 2 * RowOld% - row%, col%, row%, HiColor%) CALL XandY(Ins, col%, row%, UnScale!(), Outs, Xp!, Yp!) Arg! = 57.298 * ATAN2F!(Yp! - YOld!, Xp! - XOld!) ELSE Arg! = 57.298 * OldArg! END IF LOCATE 25, 30: PRINT USING "+###.# degrees from +X"; Arg!; CALL Delay18th(2) 'to SEE the line CALL XORLine(2 * ColOld% - col%, 2 * RowOld% - row%, col%, row%, HiColor%) MouseXYB MouseRow%, MouseCol%, Left%, Right% IF Left% OR Right% THEN GOTO Wind IF row% <> RowOld% OR col% <> ColOld% THEN CALL XandY(Ins, col%, row%, UnScale!(), Outs, X!, Y!) Arg! = ATAN2F!(Y! - YNODE!(nH%), X! - XNODE!(nH%)) ELSE Arg! = OldArg! END IF UseColor% = 0 FOR j% = 1 TO FItsOn% CALL DrawFault(FAZ!(), FDIP!(), FMemo%(), FOn%(j%), NMemo%(), NODEF%(), UseColor%, XNODE!(), YNODE!()) n% = NODEF%(2, FOn%(j%)) CALL DrawNode(n%, UseColor%, XNODE!(), YNODE!()) NEXT j% FOR j% = 1 TO FItsOn% i% = FOn%(j%) IF EOn%(j%) = 1 THEN FAZ!(1, i%) = Arg! ELSE FAZ!(2, i%) = Arg! END IF CALL MidFault(Ins, FAZ!(), i%, NODEF%(), Mods, XNODE!(), YNODE!(), Outs, NMemo%()) CALL GetArgs(Ins, i%, NODEF%(), XNODE!(), YNODE!(), Outs, FAZ!()) NEXT j% FOR j% = 1 TO FItsOn% CALL IsJoined(Ins, FAZ!(), FOn%(j%), NFL%, NODEF%(), Outs, FMemo%()) NEXT j% FOR j% = 1 TO FItsOn% UseColor% = Red% CALL DrawFault(FAZ!(), FDIP!(), FMemo%(), FOn%(j%), NMemo%(), NODEF%(), UseColor%, XNODE!(), YNODE!()) n% = NODEF%(2, FOn%(j%)) UseColor% = Yellow% CALL DrawNode(n%, UseColor%, XNODE!(), YNODE!()) NEXT j% GOSUB MouseOn CALL Blanker(25, 25, 15, 65) IF EOn%(1) = 1 THEN k% = 0 ELSE k% = 1 END IF IF GETBIT%(FMemo%(FOn%(1)), k%) THEN LOCATE 25, 35: PRINT "JOINED"; ELSE IF FItsOn% = 1 THEN LOCATE 25, 40: PRINT "OK"; ELSE LOCATE 25, 20: PRINT "Impossible angle, Adjust node(s) first"; BEEP END IF END IF ChangesInRAM% = TRUE% ELSE BEEP END IF ELSE BEEP END IF GOTO MJ ELSE CALL Blanker(25, 25, 15, 65) END IF ELSEIF Current$ = "U" THEN IntLabel% = TRUE% IF (ColorIn% OR Contour%) THEN NeedToDraw% = TRUE% ColorIn% = FALSE% Contour% = FALSE% END IF GOSUB ToPage0 MU: DO WHILE Left% OR Right%: MouseXYB MouseRow%, MouseCol%, Left%, Right%: LOOP GOSUB RunPage0 MouseClick MouseRow%, MouseCol%, Left%, Right% IF Left% OR Right% THEN MouseXYB row%, col%, MouseLeft%, MouseRight% CALL XandY(Ins, col%, row%, UnScale!(), Outs, X!, Y!) n1% = 1: NItsOn% = 0 MNU: CALL Exists(Ins, n1%, NUMNOD%, X!, XNODE!(), Y!, YNODE!(), Tolerance!, Outs, nH%) IF nH% > 0 THEN NItsOn% = NItsOn% + 1 NOn%(NItsOn%) = nH% n1% = nH% + 1 IF n1% <= NUMNOD% THEN GOTO MNU END IF IF NItsOn% > 0 THEN OK% = FALSE% '(unless found True below) EItsOn% = 0 FOR m% = 1 TO NItsOn% nH% = NOn%(m%) n1% = 1 MUE: CALL OnAny(Ins, nH%, n1%, NUMEL%, NODES%(), Outs, i%, je%) IF i% > 0 AND je% >= 4 THEN OK% = TRUE% EItsOn% = EItsOn% + 1 EOn%(EItsOn%) = i% n1% = i% + 1 IF n1% <= NUMEL% THEN GOTO MUE END IF NEXT m% FItsOn% = 0 CALL OnAny(Ins, NOn%(1), 1, NFL%, NODEF%(), Outs, ie%, je%) IF ie% > 0 AND (je% = 2 OR je% = 5) THEN OK% = TRUE% FItsOn% = 1 FOn%(1) = ie% END IF IF OK% THEN 'undraw the old stuff GOSUB MouseOff UseColor% = 0 FOR m% = 1 TO FItsOn% CALL DrawFault(FAZ!(), FDIP!(), FMemo%(), FOn%(m%), NMemo%(), NODEF%(), UseColor%, XNODE!(), YNODE!()) NEXT m% FOR m% = 1 TO EItsOn% CALL DrawElement(BotF!, ColorIn%, Contour%, DFC!, EMemo%(), EQCM!(), EOn%(m%), IData%, Logs%, NMemo%(), NODES%(), ReDo%, UseColor%, XNODE!(), YNODE!()) NEXT m% n% = NOn%(1): CALL DrawNode(n%, UseColor%, XNODE!(), YNODE!()) 'interpolate IF FItsOn% > 0 THEN i% = FOn%(1) n1% = NODEF%(1, i%): N2% = NODEF%(2, i%): N3% = NODEF%(3, i%): N5% = NODEF%(5, i%) XNODE!(N2%) = .5 * (XNODE!(n1%) + XNODE!(N3%)) YNODE!(N2%) = .5 * (YNODE!(n1%) + YNODE!(N3%)) XNODE!(N5%) = XNODE!(N2%) YNODE!(N5%) = YNODE!(N2%) CALL GetArgs(Ins, i%, NODEF%(), XNODE!(), YNODE!(), Outs, FAZ!()) CALL IsJoined(Ins, FAZ!(), i%, NFL%, NODEF%(), Outs, FMemo%()) NMemo%(N2%) = 1 NMemo%(N5%) = 1 ELSE nH% = NOn%(1) CALL OnAny(Ins, nH%, 1, NUMEL%, NODES%(), Outs, ie%, je%) j1% = je% - 3 j2% = je% - 2: IF j2% = 4 THEN j2% = 1 XNODE!(nH%) = .5 * (XNODE!(NODES%(j1%, ie%)) + XNODE!(NODES%(j2%, ie%))) YNODE!(nH%) = .5 * (YNODE!(NODES%(j1%, ie%)) + YNODE!(NODES%(j2%, ie%))) NMemo%(nH%) = 1 END IF 'redraw the modified stuff UseColor% = Yellow% n% = NOn%(1): CALL DrawNode(n%, UseColor%, XNODE!(), YNODE!()) UseColor% = Green% FOR m% = 1 TO EItsOn% i% = EOn%(m%) CALL DERIV(Ins, i%, NODES%(), POINTS!(), XNODE!(), YNODE!(), Outs, EMemo%(i%)) CALL DrawElement(BotF!, ColorIn%, Contour%, DFC!, EMemo%(), EQCM!(), i%, IData%, Logs%, NMemo%(), NODES%(), ReDo%, UseColor%, XNODE!(), YNODE!()) NEXT m% UseColor% = Red% FOR m% = 1 TO FItsOn% CALL DrawFault(FAZ!(), FDIP!(), FMemo%(), FOn%(m%), NMemo%(), NODEF%(), UseColor%, XNODE!(), YNODE!()) NEXT m% GOSUB MouseOn ChangesInRAM% = TRUE% NeedGrid% = TRUE%: NeedFaults% = TRUE%: NextFault% = NFL% ELSE BEEP END IF ELSE BEEP END IF GOTO MU END IF ELSEIF Current$ = "V" THEN 'View and/or edit nodal data IF (NUMNOD% = 0) THEN BEEP ELSE LastF! = 0! CALL Blanker(16, 24, 2, 79) LOCATE 16, 8: PRINT "Any of the following can be displayed using 14 color steps:"; LOCATE 17, 15: PRINT "1 = elevation (for SHELLS) or mu_ (for RESTORE)"; LOCATE 18, 15: PRINT "2 = heat-flow (Q)"; LOCATE 19, 15: PRINT "3 = crustal-thickness"; LOCATE 20, 15: IF Mantle% THEN PRINT "4 = mantle-lithosphere-thickness"; V1: CALL Blanker(22, 22, 15, 79) IF Mantle% THEN TopChoice% = 4 ELSE TopChoice% = 3 END IF LOCATE 22, 15: PRINT USING "Enter your choice (1-#): #"; TopChoice%; IData% LOCATE 22, 40: INPUT ; "", a$ IF a$ <> "" THEN n% = VAL(a$) IF (n% < 1) OR (n% > TopChoice%) THEN BEEP CALL Blanker(22, 22, 2, 79) GOTO V1 END IF IData% = n% END IF IF Colored% THEN Ask% = TRUE% 'just once CALL SetBins(Ins, Ask%, Contour%, EQCM!(), IData%, NUMNOD%, Mods, OldBotF!, OldIData%, OldTopF!, Outs, BotF!, DFC!, Logs%, NeedToDraw%, TopF!) Ask% = FALSE% Contour% = TRUE% DoIcon% = FALSE% END IF ColorIn% = FALSE% GOSUB ToPage0 V3: GOSUB RunPage0 MouseClick MouseRow%, MouseCol%, Left%, Right% IF Left% OR Right% THEN row% = MouseRow% col% = MouseCol% CALL XandY(Ins, col%, row%, UnScale!(), Outs, X!, Y!) NItsOn% = 0 EItsOn% = 0 FItsOn% = 0 n1% = 1 V4: CALL Exists(Ins, n1%, NUMNOD%, X!, XNODE!(), Y!, YNODE!(), Tolerance!, Outs, nH%) IF nH% > 0 THEN NItsOn% = NItsOn% + 1 NOn%(NItsOn%) = nH% e1% = 1 V5: CALL OnAny(Ins, nH%, e1%, NUMEL%, NODES%(), Outs, ie%, je%) IF ie% > 0 THEN EItsOn% = EItsOn% + 1 EOn%(EItsOn%) = ie% IF ie% < NUMEL% THEN e1% = ie% + 1 GOTO V5 END IF END IF f1% = 1 V6: CALL OnAny(Ins, nH%, f1%, NFL%, NODEF%(), Outs, ie%, je%) IF ie% > 0 THEN FItsOn% = FItsOn% + 1 FOn%(FItsOn%) = ie% IF ie% < NFL% THEN f1% = ie% + 1 GOTO V6 END IF END IF IF n1% < NUMNOD% THEN n1% = nH% + 1 GOTO V4 END IF END IF IF NItsOn% = 0 THEN BEEP ELSE IF Colored% THEN COLOR Foreground% CALL Blanker(Lines%, Lines%, 19, 60) LOCATE Lines%, 20: PRINT "Value: "; EQCM!(IData%, NOn%(1)); "; Change?: "; INPUT ; "", a$ IF a$ <> "" THEN IF a$ = "'" THEN F! = LastF! ELSE F! = VAL(a$) LastF! = F! END IF IF (IData% > 1) AND (F! < 0!) THEN BEEP ELSE FOR k% = 1 TO NItsOn% EQCM!(IData%, NOn%(k%)) = F! NEXT k% 'GPB ChangesInRAM% = TRUE% ReDo% = TRUE% GOSUB MouseOff UseColor% = Green% FOR i% = 1 TO EItsOn% CALL DrawElement(BotF!, ColorIn%, Contour%, DFC!, EMemo%(), EQCM!(), EOn%(i%), IData%, Logs%, NMemo%(), NODES%(), ReDo%, UseColor%, XNODE!(), YNODE!()) NEXT i% UseColor% = Red% FOR i% = 1 TO FItsOn% CALL DrawFault(FAZ!(), FDIP!(), FMemo%(), FOn%(i%), NMemo%(), NODEF%(), UseColor%, XNODE!(), YNODE!()) NEXT i% GOSUB MouseOn END IF END IF END IF GOTO V3 END IF END IF ELSEIF Current$ = "P" THEN IF NUMEL% > 0 THEN CALL CIRCUIT(Ins, MXBN%, NFL%, NUMEL%, Mods, EQCM!(), NFAKEN%, NMemo%(), NODEF%(), NODES%(), NREALN%, NUMNOD%, XNODE!(), YNODE!(), Outs, FAILED%, NCOND%, NODCON%(), Work, FMemo%(), EMemo%()) IF FAILED% THEN CALL WaitForKey(CommandKey$) IF ASC(CommandKey$) = 13 THEN CommandKey$ = "" ELSE CALL Blanker(16, 24, 2, 79) LOCATE 17, 20 PRINT "Area within perimeter = " Within# = 0# X1! = XNODE!(NODCON%(NCOND%)) Y1! = YNODE!(NODCON%(NCOND%)) FOR i% = 1 TO NCOND% X2! = XNODE!(NODCON%(i%)) Y2! = YNODE!(NODCON%(i%)) Within# = Within# + (Y2! - Y1!) * .5# * (X1! + X2!) X1! = X2!: Y1! = Y2! NEXT i% LOCATE 17, 44 PRINT USING "+#.######^^^^^"; Within# LOCATE 19, 20 PRINT "Sum of element areas = " SumArea# = 0# FOR i% = 1 TO NUMEL% EArea! = 0! X1! = XNODE!(NODES%(6, i%)) Y1! = YNODE!(NODES%(6, i%)) FOR j% = 1 TO 6 k% = Renum%(j%) X2! = XNODE!(NODES%(k%, i%)) Y2! = YNODE!(NODES%(k%, i%)) EArea! = EArea! + (Y2! - Y1!) * .5 * (X1! + X2!) X1! = X2!: Y1! = Y2! NEXT j% SumArea# = SumArea# + CDBL(EArea!) NEXT i% LOCATE 19, 44 PRINT USING "+#.######^^^^^"; SumArea# IF Within# < 0# OR SumArea# < 0# THEN LOCATE 20, 9 PRINT "A negative area suggests that many elements were defined backwards." LOCATE 21, 9 PRINT "Delete any elements with an X and redefine them counterclockwise." ELSE X! = CSNG(Within#): Y! = CSNG(SumArea#) IF X! = Y! THEN LOCATE 21, 30: PRINT "Areas agree exactly." ELSE Z! = ABS(X! - Y!) Zpc! = 100! * Z! / Y! LOCATE 21, 20 PRINT USING "Discrepancy is +#.##^^^^, or ####.###%"; Z!; Zpc! LOCATE 21, 35: PRINT " " IF Zpc! > .01 THEN LOCATE 22, 6 PRINT "A significant discrepancy often means that two elements share the same" LOCATE 23, 6 PRINT "nodes and overlap; check for duplications. Try command Gap/overlap." END IF END IF END IF CALL WaitForKey(CommandKey$) IF ASC(CommandKey$) = 13 THEN CommandKey$ = "" END IF ELSE BEEP END IF ELSEIF Current$ = "G" THEN IntLabel% = TRUE% IF Colored% THEN NeedToDraw% = TRUE% ColorIn% = TRUE% Contour% = FALSE% 'outer limits of x and y are needed to rescale window CALL XYBounds(Ins, NUMNOD%, XNODE!(), YNODE!(), Outs, XMin!, XMax!, YMin!, YMax!) WindowWidth! = 1.06 * (XMax! - XMin!) YWidth! = 1.06 * (YMax! - YMin!) / .75 IF YWidth! > WindowWidth! THEN WindowWidth! = YWidth! XatTL! = .5 * (XMin! + XMax!) - .5 * WindowWidth! YatTL! = .5 * (YMin! + YMax!) + .375 * WindowWidth! Argument! = 0! CALL Scaler(Ins, WindowWidth!, Outs, Tolerance!, UnScale!()) GOSUB ToPage0 GOSUB RunPage0 ELSE BEEP END IF END IF ' 'common collector after any command is completed: Collector: GOSUB MouseOff SCREEN BestMode%, , HighPage%, HighPage% PageNow% = HighPage% IF Colored% THEN IF BestMode% <= 10 THEN COLOR Foreground%, background% ELSE COLOR Foreground% END IF END IF IF HighPage% = 0 THEN NeedMenu% = TRUE% GOTO CommandLoop ' '=============================================================== ' 'Entry to this section is by GOSUB ToPage0 'switches to the graphics screen, if necessary ToPage0: SCREEN BestMode%, , 0, 0 PageNow% = 0 IF Colored% THEN IF BestMode% <= 10 THEN COLOR White%, 0 'black background ELSE COLOR White% END IF END IF IF HighPage% = 0 THEN NeedToDraw% = TRUE% ELSE LOCATE 1, 80: PRINT LEFT$(Current$, 1); END IF GOSUB MouseOn MouseClick MouseRow%, MouseCol%, Left%, Right% 'clear any old mouse clicks RETURN ' '================================================================ RunPage0: ' DO ' "endless" loop ' ' (1) Update x and y coordinates printed in corner(s). ' MouseXYB row%, col%, MouseLeft%, MouseRight% IF (col% <> OldCol%) OR (row% <> OldRow%) THEN CALL XandY(Ins, col%, row%, UnScale!(), Outs, X!, Y!) LOCATE Lines% - 1, 1: PRINT USING "X=+#.###^^^^"; X!; LOCATE Lines%, 1: PRINT USING "Y=+#.###^^^^"; Y!; IF Using2nd% THEN X2! = To2nd11! * X! + To2nd12! * Y! + To2ndX! Y2! = -To2nd12! * X! + To2nd11! * Y! + To2ndY! LOCATE Lines% - 1, 68: PRINT USING "X'=+#.###^^^^"; X2!; LOCATE Lines%, 68: PRINT USING "Y'=+#.###^^^^"; Y2!; END IF IF IntLabel% THEN IF NUMNOD% > 0 THEN LOCATE Lines% - 1, 14: PRINT "Nearest"; CALL Nearest(Ins, NUMNOD%, X!, XNODE!(), Y!, YNODE!(), Outs, NumNear%, NearOnes%()) LOCATE Lines% - 1, 35: PRINT USING "node(s): ##### ##### #####"; NearOnes%(1); NearOnes%(2); NearOnes%(3); ELSE CALL Blanker(Lines% - 1, Lines% - 1, 14, 67) END IF IF NFL% > 0 THEN R2toF! = 9.99E+29 FOR jf% = 1 TO NFL% R2! = (X! - XNODE!(NODEF%(2, jf%))) ^ 2 + (Y! - YNODE!(NODEF%(2, jf%))) ^ 2 IF R2! < R2toF! THEN R2toF! = R2! CursorF% = jf% END IF NEXT jf% LOCATE Lines% - 1, 22: PRINT USING "fault: ####"; CursorF%; LOCATE Lines% - 1, 33: PRINT ","; ELSE CALL Blanker(Lines% - 1, Lines% - 1, 22, 34) END IF ELSE CALL Blanker(Lines% - 1, Lines% - 1, 14, 67) END IF OldCol% = col%: OldRow% = row% END IF ' ' (2) Check mouse button or key action, and return ' MouseXYB MouseRow%, MouseCol%, Left%, Right% IF Left% OR Right% THEN RETURN END IF CommandKey$ = INKEY$ IF LEN(CommandKey$) > 0 THEN RETURN END IF ' ' (3) Clear screen (and initialize flags) if NeedToDraw% ' IF NeedToDraw% THEN NeedToDraw% = FALSE% ReDo% = FALSE% CALL MousePut(0, 0) CLS CALL XandY(Ins, OldCol%, OldRow%, UnScale!(), Outs, X!, Y!) LOCATE Lines% - 1, 1: PRINT USING "X=+#.###^^^^"; X!; LOCATE Lines%, 1: PRINT USING "Y=+#.###^^^^"; Y!; NeedGrid% = GridLoaded% IF NeedGrid% THEN NeedNodes% = TRUE% NextNode% = NUMNOD% NeedElements% = TRUE% NextElement% = NUMEL% NeedFaults% = TRUE% NextFault% = NFL% END IF NeedBase% = UsingBase% NeedBar% = Contour% IF NeedBase% THEN CLOSE #3 OPEN BinaryN$ FOR BINARY AS #3 LEN = 128 GET #3, , XOldBase! GET #3, , YOldBase! IF XOldBase! = -.12345 THEN ' file begins with end mark; do nothing ELSE 'start new segment with single point CALL Pixels(Ins, XOldBase!, YOldBase!, Outs, ColOldBase%, RowOldBase%) IF Colored% THEN PSET (ColOldBase%, RowOldBase%), Brown% ELSE PSET (ColOldBase%, RowOldBase%) END IF END IF END IF LOCATE 1, 79: PRINT CHR$(221); LEFT$(Current$, 1); LOCATE 2, 79: PRINT CHR$(223) + CHR$(223); GOSUB MouseOn OldCol% = 0 OldRow% = 0 CALL MousePut(0, 0) END IF ' ' 4) Add to graphics, taking only one of the following: ' a) Draw one more node, until done. ' b) Draw one more triangular continuum element, until done. ' c) Draw one more fault element, until done. ' d) Draw one more line from basemap file, until done. ' e) Add color bar to one side of figure, if Contour% ' IF NeedGrid% THEN IF NeedNodes% THEN IF NextNode% > 0 THEN n% = NextNode% UseColor% = Yellow% CALL DrawNode(n%, UseColor%, XNODE!(), YNODE!()) NextNode% = NextNode% - 1 ELSE NeedNodes% = FALSE% END IF ELSEIF NeedElements% THEN IF NextElement% > 0 THEN UseColor% = Green% CALL DrawElement(BotF!, ColorIn%, Contour%, DFC!, EMemo%(), EQCM!(), NextElement%, IData%, Logs%, NMemo%(), NODES%(), ReDo%, UseColor%, XNODE!(), YNODE!()) NextElement% = NextElement% - 1 ELSE NeedElements% = FALSE% END IF ELSEIF NeedFaults% THEN IF NextFault% > 0 THEN UseColor% = Red% CALL DrawFault(FAZ!(), FDIP!(), FMemo%(), NextFault%, NMemo%(), NODEF%(), UseColor%, XNODE!(), YNODE!()) NextFault% = NextFault% - 1 ELSE NeedFaults% = FALSE% END IF ELSE NeedGrid% = FALSE% END IF ELSEIF NeedBase% THEN IF EOF(3) THEN NeedBase% = FALSE% CLOSE #3 ELSE CALL DrawBase(Brown%, ColOldBase%, RowOldBase%, XOldBase!) END IF ELSEIF NeedBar% THEN 'GPB NeedBar% = FALSE% CALL Blanker(Lines% - 6 - HiColor%, Lines% - 7, 1, 12) COLOR Foreground% LOCATE Lines% - 7, 3 IF Logs% THEN PRINT 10! ^ BotF! ELSE PRINT BotF!; END IF xt% = CINT(.0225 * HiCol%) - 1 FOR kc% = 2 TO HiColor% yb% = CSNG(HiRow%) * (CSNG(Lines% - 6 - kc%) - .5) / CSNG(Lines%) yt% = CSNG(HiRow%) * (CSNG(Lines% - 5 - kc%) - .5) / CSNG(Lines%) LINE (0, yb%)-(xt%, yt%), kc%, BF LOCATE Lines% - 6 - kc%, 3 F! = BotF! + (TopF! - BotF!) * CSNG(kc% - 1) / CSNG(HiColor% - 1) IF Logs% THEN F! = 10! ^ F! END IF PRINT F!; NEXT kc% END IF ' LOOP ' "endless" loop '=============================================================== MouseOn: IF NOT CursorOn% THEN MouseShow CursorOn% = TRUE% END IF RETURN ' MouseOff: IF CursorOn% THEN MouseHide CursorOn% = FALSE% END IF RETURN