!************************************************************************************** ! ! Program Orbwin: A Windows Based Meshing program ! ! Written by: Zhen Liu ! Date: 05/02/04 ! Modified through June-Sep. 2004, March-April, 2005 ! ! Note: The core parts of Orbwin are adapted from old DOS based program Orbweave, ! Written by Peter Bird, UCLA using BASIC. Without Orbweave, the current shape ! of Orbwin is not possible! ! !************************************************************************************** ! ! Major components: ! Orbwin.f90: Create a message loop to wait for events ! Menu.f90: Customized menu items and callback routines ! CallBacks.f90: Contains major Callback routines for menu items ! Orblib.f90: subroutines rewritten from Orbweave.bas, ORB2.bas, ORB3.bas ! OrbGlobals.f90: global variables floating across subroutines ! Comdlger.f90: subroutines to detect errors when common dialog is created ! Errormsg.f90: Error messages subroutines ! Icosahedron.f90: Icosahedron module supplied by Peter Bird at UCLA. ! LoadBase.f90: subroutine for creating dialog box to load basemap file ! LoadGrid.f90: subroutines for creating dialog box to load grid file ! OutputGrid.f90: subroutines for writing grid in specified filename ! ReadGrid.f90: subroutines for reading given grid ! SaveGrid.f90: subroutines for creating dialog box to save grid ! ThreadDlg.f90: modules and SUBR for multithread creation of global grid ! ThreadDlg1.f90: SUBR for multithread perimeter/area test ! ! Bugs fixed or improvements: ! *. Added showing node information in SUBR Showxy ! Now Showxy displays (lat, lon) and closest nodes information ! *. Fix small bugs caused by floating global variables ! JIP, NItsOn, EItsOn, FItsOn, Non(1:1000), Eon(1:1000), Fon(1:1000) ! New SUBR ClearNEFon called in SUBR AddDeleteElement, AdjustNode ! to reset those values to be zero ! * New compiler option: /check:bounds, /warn:argument_checking ! are turned on to debug the crashes shown as ! "forrtl:severe(157): Program Exception - access violation" ! which is caused by the code line in SUBR showxy ! ----- ! write(msg, "(' cursor Lon = ',F8.3, ' Lat = ',F8.3,' 'C)") lon,lat ! ----- ! Another modifications are: ! msg(50) --> msg(100) ! write(msg, "(' cursor Lon = ',F8.3, ' Lat = ',F8.3)") lon,lat ! msg= trim(msg) ! ! *. Added new status message in SUBR Set2ndOrigin ! * In FUNCTION PerimTest, msg is set to character(500) to avoid overflow error ! forrtl: severe (66): output statement overflows record, unit - 5, file internal formatted write ! Line 456 ! * Sep. 13, 2004. error message discovered on Peter's computer ! error message: forrtl severe(-8739) message not found ! line source: ! write(windowheightstring,"(F5.3)") windowheight ?? ! * Add new decision point dialog for choosing application types ! if restore2/NeoKinema or restore3, if fault related commands are chosen, given warnings. ! * Add ctrl + rightbutton to set (ele, Q, crust, mantle_thickness) to the last value chosen ! When setting many nodes to the same value, this will speed things up. ! * Add Block selection mode: only for convex polygon, but can be easily upgrade to arbitrary ! shape of polygon ! ! ** Fixed the bug, which I believe also exists in Orbweave.exe. The bug is in SUBR CutHealFlt ! Bug occurs as incorrect updates of element node list after new fault added. I manage to ! reproduce this bug repeatly using test91.feg. This bug is caused by: ! incidently the far side element has the same (n1, n2) as the side that cut as fault. This is caused ! because when we remove n2 or n1, all nodes above n2 or n1 are reduced by 1 and make them have the ! same value as n2 or n1. Thus when ooping far side elements, the program is tricked into this element ! and treat the side (n1, n2) of this element as fault, which in fact is not fault! ! This is not common bug but it does occur under special node number combination. ! I have corrected this problem by checking if adjacent element of this element is iebase, ! if it is not, it means the element does not have fault even though one side of element has the same ! (n1, n2) as the 1st side of new cut fault! ! ! ! Improvements made through March 2005: ! * Added capability to respecify the array size if specified size is not enough to read in a ! grid. This way, if you incidently specify not sufficient size for node, element, and fault, ! you do not need to quit and restart again. ! * Fixed minor bug: load old grid, clear up, then creat new grid and write out. The new grid takes ! the title line of old grid. This has been fixed. ! * Set to be zoomin/out mode whenever loading a grid for the first time. ! * Fixed bug: fault dips are in [1 189], now change dip output to [-89 89] for consistency with ! ORBNUMBER etc. Similar conversion is done when loading a grid so that within Orbwin, dips in [1 189]. ! * Added array bound check when adding nodes, elements, faults. Normally, if you specify the maximum ! array size to be large enough, you do not need to worry about this issue. But if array size limit ! is reached, adding new node/element/fault would crash the program before this fix! Now a warning message ! will be issued to prompt you to quit and restart program so that you can choose larger array size. ! * remove debug.log file ! ! Bug fixed, April 2005 ! ! * ThreadDlg1.f90: Function PerimTest(dlg), line 375-377, when searching new boundary node along ! new fault element side, if side 2 is external, node search should be on local node #3,4 of this ! fault element. Incidently, the search is limited to local node# 2,4. The bug causes Orbwin and Orbweave ! behaves differently when performing Perimeter test on grid with faults being outside. ! This bug has been fixed! ! ! Potential bugs: ! * SUBR Raiseone controls fill_color when VIEWGAP. However, It seems the way to pick up ! different color by incrementally increasing color index of given color table depends on screen ! display color quality (Highest 32 bit or Medium 16 bit) under display settings of Control Panel. ! Highest 32 bit -- ViewGap with changing colors works properly. But Medium 16 bit -- only one color can ! be seen during ViewGap! ! !**************************************************************** ! program Orbwin use dfwin use dflib use global implicit none ! variables integer(4) iret, ievent integer(4) iunit logical(4) bret character(15) szMessage type (windowconfig) wc type (rccoord) rc type (qwinfo) qw ! INTEGER iSt, jTop, jBottom, jLeft, jRight, jWidth, jHeight ! external showxy ! character(1) key integer checked ! INTERFACE INTEGER(4) FUNCTION FrameWndProc(hWnd,Msg,wParam,lParam) !DEC$ATTRIBUTES STDCALL:: FrameWndProc INTEGER:: hWnd,Msg,wParam,lParam END FUNCTION END INTERFACE ! wc: declared in global.c / global.mod ! ! set the child window properties to defaults and highest ! resolution graphics mode wc%numxpixels = -1 wc%numypixels = -1 wc%numtextcols = -1 wc%numtextrows = -1 wc%numcolors = -1 wc%fontsize = -1 wc%title ='Working Window'C bret = SETWINDOWCONFIG(wc) ! enter new frame window title iret = SetWindowText(GetHwndQQ(QWIN$FRAMEWINDOW)," & Orbwin"C) ! maximize the size of the main window qw%type = QWIN$MAX iret = SETWSIZEQQ(QWIN$FRAMEWINDOW,qw) ! maximize child window qw%type = QWIN$MAX iret = SETWSIZEQQ(0,qw) ! initialize all 6 drawing colors (global variables) DO DrawType = 1, 6 Redvalue = RGB_int_of_IDC_LIST_line(1, DrawType) Greenvalue = RGB_int_of_IDC_LIST_line(2, DrawType) Bluevalue = RGB_int_of_IDC_LIST_line(3, DrawType) RedByte = CHAR(Redvalue) ! converting from 4 bytes to 1 byte GreenByte = CHAR(Greenvalue) ! to prepare for use of "rgb macro" BlueByte = CHAR(Bluevalue) !NOTE: In OrbGlobals.f90, EQUIVALENCE (RebByte, RedInt1), ... ! This kludge was used because "RedInt1 = RedValue" doesn't work; ! it leads to integer overflow because INTEGER*1 uses one bit for sign, ! and thus has a range from -128 to +128 instead of from 0 to 255. IF (DrawType == 1) ifrontcolor = rgb(RedInt1,GreenInt1,BlueInt1) IF (DrawType == 2) ibasecolor = rgb(RedInt1,GreenInt1,BlueInt1) IF (DrawType == 3) inodecolor = rgb(RedInt1,GreenInt1,BlueInt1) IF (DrawType == 4) ielecolor = rgb(RedInt1,GreenInt1,BlueInt1) IF (DrawType == 5) ifaultcolor = rgb(RedInt1,GreenInt1,BlueInt1) IF (DrawType == 6) ibackcolor = rgb(RedInt1,GreenInt1,BlueInt1) END DO; DrawType = 0 ! returning to "uninitialized" value, meaning no list item selected iret = SETCOLORRGB(ifrontcolor) iret = SETBKCOLORRGB(ibackcolor) ! kill default QuickWin status bar hFrame=GETHWNDQQ(QWIN$FRAMEWINDOW) hMDI=FindWindowEx(hFrame,NULL,LOC('MDIClient'C),NULL) hStatus=GetWindow(hMDI,GW_HWNDNEXT) iSt=SendMessage(hStatus,WM_CLOSE,0,0) ! Subclass the Frame window with FrameWndProc. lpfnOldFrameProc is the ! address of default ("Old") Frame window procedure lpfnOldFrameProc=SetWindowLong(hFrame,GWL_WNDPROC,LOC(FrameWndProc)) ! Create new statusbar ist = sendmessage(hframe, WM_CREATESTATUS,0,0) call CLEARSCREEN($GCLEARSCREEN) call DecisionPtDlg ! after this, AppType is set ! Three purposes: ! 1. Specify the array size for nodes, elements, and faults ! If no # is specified -> Disable all editing submenus ! 2. Set windowheight, projection/scaler matrix to default value ! 3. Initialize values of global switches call Initialization ! ! draw default sphere circle call DrawGrid ! get current focus window and work on it iunit = getactiveqq() iret = REGISTERMOUSEEVENT (iunit, MOUSE$MOVE, showxy) do while (.TRUE.) ! Wait forever to allow event-driven action. ! call sleepqq(500) ! remove resource hogging by the do-while loop key = GETCHARQQ() select case(ichar(key)) case(1) ! ctrl-A: adjust node call AdjustNode case(2) ! ctrl-B: loadbase call LoadBase case(4) ! ctrl-D: drawgrid call DrawGrid case(5) ! ctrl-E: add/delete element call AddDeleteElement case(6) ! ctrl-F: cuthealfault call CutHealFault case(7) ! ctrl-G: loadGrid call LoadGrid case(8) ! ctrl-H: Fault Heading call Fheading case(9) ! ctrl-I: Fault inclination call Finclination case(11) ! ctrl-K: setColor call SetKolor case(13) ! ctrl-M: Draw Ele/Q/Crust/Mantle call eqcmDraw case(14) ! ctrl-N: add/delete node call AddDropNode case(15) ! ctrl-O: 2nd origin call Set2ndOrigin case(18) !Ctrl-R: Redraw call Redraw case(22) ! ctrl-V: savegrid, Note: ctrl-S does not work out!!! call SaveGrid case(24) ! ctrl-X: userexit call UserExit case(26) !ctrl-Z: zoominout call ZoomInOut end select end do end program orbwin !================================================================== !Subclassed procedure of Frame client window INTEGER FUNCTION FrameWndProc(hWnd,Msg_int,wParam,lParam) !DEC$ATTRIBUTES STDCALL:: FrameWndProc USE DFWIN USE COMCTL32 USE GLOBAL IMPLICIT NONE type(T_rect) sbrect, mdirect INTEGER hWnd,Msg_int,wParam,lParam INTEGER iSt, ID, iState, isbHeight integer iSBFieldPos(0:3) ! dist of right edge of status bar part from window edge integer jwidth SELECT CASE(Msg_int) CASE (WM_CREATETOOLBAR) !Request for toolbar creation, which means Toolbar can be added if you want ! CALL CreateMyToolbar FrameWndProc=0 CASE (WM_CREATESTATUS) ! process message for creating statusbar hStatus=CreateStatusWindow(WS_CHILD,''C,hFrame,0) iSt = getWindowRect(hstatus, sbrect) ! get statusbar rectangle infor. iSt = getClientRect(hMDI, mdirect) ! get client area info. (top, left, right. bottom) jWidth = mdirect%Right iSBFieldPos(3)=jWidth-20 iSBFieldPos(2)=jWidth-240 iSBFieldPos(1)=jWidth-460 iSBFieldPos(0)=100 iSt=SendMessage(hStatus,SB_SETPARTS,4,LOC(iSBFieldPos)) iSt=ShowWindow(hStatus,SW_SHOW) call setstatusbar(0,'Ready'C) ! move statusbar to seal the gap between default statusbar size and diff_size of frame and client area isbHeight = mdirect%bottom ! y-location of the top of statusbar relative to MDI iSt = MoveWindow(hStatus, 0, isbHeight, sbRect%Right, sbRect%Bottom - sbRect%top, .TRUE.) framewndproc = 0 CASE (WM_SIZE) ! how to adjust correspondingly when window size changes ! iSt = GetClientRect(hWnd, mdiRect) ! iSt = GetWindowRect(hToolbar, tbRect) ! itbHeight = tbRect%Bottom-tbRect%Top ! iSt = MoveWindow(hMDI, 0, itbHeight, mdiRect%Right, mdiRect%Bottom - itbHeight, .TRUE.) ! FrameWndProc = 0 CASE DEFAULT !Send all other messages further to normal processing FrameWndProc=CallWindowProc(lpfnOldFrameProc,hWnd,Msg_int,wParam,lParam) END SELECT END FUNCTION FrameWndProc