! ! List of subroutines contained in Callbacks.f90 in alphabetical order: ! ! About ! AddDeleteElement ! AddElement ! AddDropNode ! AddNode ! AdjustNode ! BlockSetValue ! CheckAllocate ! ClearBase ! ClearLinkList ! ClearGrid ! ClearHistory ! ClearNEFon ! ClickAndView ! Colorbar !! Colorbar displayed when setting Ele/Q/Crust/Mantle ! CutHealFault ! CutHealFlt !! called by CutHealFault ! DeleteBogusFault ! DeleteElement ! DesionPtDlg !! Specify which dialog we work with ! DlgEQCM !! Dialog to choose for: Topo,Heatflow, Crust,Mantle thickness ! DlgFinc !! Dialog for fault inclination angle ! DrawGrid ! DropFault ! DropNode ! DropNodeSize ! EndButtonDown ! EndSetFhead ! eqcmDraw !! call DlgEQCM, setEQCM ! Fheading ! Finclination !! call setFinc ! FindElementSide ! Findfault ! FinishPoly ! Globegrid ! GTdialog ! GrayedMenu ! Help !! display orbwin_help.htm ! InitArraySize !! dialog box for specifying max value for node, element, fault ! Initialization !! Initialize global variables ! IsNumber ! MoveNode ! PATest ! PickFault ! PickPoint ! PinpointNode ! show the location given node #, Good for debug purpose ! PinpointElement ! show the element given element#, Good for debug purpose ! Redraw ! RestoreCursor ! SelectPoint_Zoom ! SelectNode ! SetEQCM ! SetFinc ! Setstatusbar ! my own statusbar ! Set2ndOrigin ! SetOrigin ! ShowOrigin ! SetFhead ! SetKolor ! SetPlotData ! Showxy ! TileGrid ! UserExit ! ViewGap ! WindowPosition ! WriteHeading ! ZoomInOut ! !======================================================================================== ! ! ! Dialog displaying author name, program version etc. ! subroutine About use dflib use dflogm use dfwin implicit none include 'resource.fd' type (dialog) dlg logical(4) bret integer(4) iret call setstatusbar(0,'About'C) call setstatusbar(1,' 'C) bret = DLGINIT(IDD_ABOUT, dlg) iret = DlgModal(dlg) call DlgUninit(dlg) ! update status bar call setstatusbar(0,'Running'C) call setstatusbar(1,' 'C) end subroutine About ! ! Callback routine for adding/deleting element ! subroutine AddDeleteElement use dflib use global logical checked logical(4) bret integer(4) iret integer iunit external AddElement, DeleteElement, Showxy iunit = getactiveqq() call ClearHistory call CheckAllocate ! clear JIP, Non, Eon, Fon, which are global call ClearNEFon !if (checked) then ! AddDeleteElement_checked = .false. ! call setstatusbar(1," Out of adding/deleting element mode "C) ! bret = MODIFYMENUFLAGSQQ(2,4,$MENUUNCHECKED) ! iret = UNREGISTERMOUSEEVENT(iunit, MOUSE$LBUTTONDOWN) ! iret = UNREGISTERMOUSEEVENT(iunit, MOUSE$RBUTTONDOWN) !else call clearhistory if(Contour) then contour = 0 call redraw end if AddDeleteElement_checked = .true. call setstatusbar(0,'AddDeleElement'C) call setstatusbar(1,'Left click 3 nodes to add, Right click center of element to delete, details see help/instructions...'C) bret = MODIFYMENUFLAGSQQ(2,4,$MENUCHECKED) iret = REGISTERMOUSEEVENT (iunit, MOUSE$LBUTTONDOWN, AddElement) iret = REGISTERMOUSEEVENT (iunit, MOUSE$RBUTTONDOWN, DeleteElement) iret = REGISTERMOUSEEVENT (iunit, MOUSE$MOVE, Showxy) !end if end subroutine AddDeleteElement ! ! Routine for Adding Element ! Add error bound check, March 2005 ! subroutine AddElement(unit, me, iKeyState, xpos, ypos) use dfwin use dflib use global integer unit, me, iKeyState, xpos, ypos integer col, row !integer contour integer(4) nH, ie, je integer k integer(4) n1, m1, m2, m3 real x, y logical OK, BeenDone type(xycoord) viewxy if((MOUSE$KS_LBUTTON.and.iKeyState) == MOUSE$KS_LBUTTON) then call getviewcoord(xpos, ypos, viewxy) col = viewxy%xcoord row = viewxy%ycoord call XandY(col, row, x, y) call exists(1, x, y, nH) if (nH > 0) then call OnAnyF(nH, 1, NFL, ie, je) if (ie == 0) then ! not on fault OK = .true. do k = 1, JIP ! Correct bug in basic code. Check if it was selected already if (nH == Eon(k)) OK = .false. end do if (OK) then JIP = mod(JIP, 3) + 1 write(msg, '(I4," nodes have been selected!!")') mod(JIP, 3) call setstatusbar(1, TRIM(msg) // CHAR(0)) Eon(JIP) = nH call drawnode(RGB(255,0,0),nH) if (JIP == 3) then JIP = 0 if (NUMEL > MXEL) call error2(" Element", NUMEL, MXEL) BeenDone = .false. ! check that the element does not already exist n1 = 1 3 call OnAnyE(Eon(1), n1, NUMEL, ie, je) if (ie > 0) then m1 = nodes(je, ie) m2 = nodes(mod(je,3) + 1,ie) m3 = nodes(mod(je+1,3) + 1, ie) if (((m2==Eon(2)).and.(m3==Eon(3))).or.((m3==Eon(2)).and.(m2==Eon(3)))) BeenDone = .true. if (ie < NUMEL) then n1 = ie + 1 goto 3 end if end if if (BeenDone) then ! element already exists call beepqq(1000,40) do k = 1, 3 nH = Eon(k) call drawnode(inodecolor, nH) end do else ! element is ok NUMEL = NUMEL + 1 if(NUMEL > mxel) then call beepqq(1000,40) call error14('Element', mxel) NUMEL = NUMEL - 1 return endif nodes(1, NUMEL) = Eon(1) nodes(2, NUMEL) = Eon(2) nodes(3, NUMEL) = Eon(3) call flipped(NUMEL) call drawelement(ielecolor, NUMEL) do k = 1, 3 nH = nodes(k, NUMEL) call drawnode(inodecolor, nH) end do ! increment editing counter call IncreaseEditingCounter end if end if ! JIP else ! node is in short list call beepqq(1000,40) end if ! ok else ! node on the fault call beepqq(1000,40) end if ! ie else ! cursor is not on any node call beepqq(1000,40) end if !nH end if ! left button down end subroutine AddElement ! ! Callback routine for adding/dropping Nodes ! subroutine AddDropNode use dfwin use dflib use global logical checked logical(4) bret integer(4) iret, iunit external AddNode, DropNode, Showxy if (.NOT.ShowNodes) then ShowNodes = .true. call Redraw end if iunit = getactiveqq() call ClearHistory call CheckAllocate !if (checked) then ! AddDropNode_checked = .false. ! call setstatusbar(1," Out of adding/dropping node mode"C) ! bret = MODIFYMENUFLAGSQQ(2,1,$MENUUNCHECKED) ! iret = UNREGISTERMOUSEEVENT(iunit, MOUSE$LBUTTONDOWN) ! iret = UNREGISTERMOUSEEVENT(iunit, MOUSE$RBUTTONDOWN) !else AddDropNode_checked = .true. call setstatusbar(0,'AddDropNode'C) call setstatusbar(1,' Left click to add, right click to drop node ...'C) bret = MODIFYMENUFLAGSQQ(2,1,$MENUCHECKED) iret = REGISTERMOUSEEVENT (iunit, MOUSE$LBUTTONDOWN, AddNode) iret = REGISTERMOUSEEVENT (iunit, MOUSE$RBUTTONDOWN, DropNode) iret = REGISTERMOUSEEVENT (iunit, MOUSE$MOVE, Showxy) !endif end subroutine AddDropNode ! ! callback subroutine in AddDropNode ! Add array bound check, March 2005 ! subroutine AddNode(unit, me, iKeyState, xpos, ypos) use dflib use global integer unit, me, iKeyState, xpos, ypos integer col, row real x, y, tempvec(3) integer outside integer(4) i,n type(xycoord) viewxy if((MOUSE$KS_LBUTTON.and.iKeyState) == MOUSE$KS_LBUTTON) then call GETVIEWCOORD(xpos, ypos, viewxy) col = viewxy%xcoord row = viewxy%ycoord call XandY(col, row, x, y) call xy2ABG(x, y, outside, tempvec) if (outside == 1) then call beepqq(1000,40) else numnod = numnod + 1 ! issue a warning and ask for quit if mxnode is reached if(numnod > mxnode) then call beepqq(1000, 40) call error14('node',mxnode) numnod = numnod - 1; return endif n = numnod do i = 1, 6 EQCM(i,n) = 0 end do nodeABG(1,n) = tempvec(1) nodeABG(2,n) = tempvec(2) nodeABG(3,n) = tempvec(3) call drawnode(inodecolor, n) GridLoaded = .true. ! incrementing editing counter call IncreaseEditingCounter end if end if end subroutine AddNode ! ! Callback routine for adjusting node location ! subroutine Adjustnode use dflib use global implicit none integer(4) iret logical(4) bret integer iunit logical checked external SelectNode, MoveNode, EndButtonDown iunit = getactiveqq() call ClearHistory call CheckAllocate ! clear JIP, Non, Eon, Fon, which are global call ClearNEFon !if (checked) then ! Adjustnode_checked = .false. ! call setstatusbar(1,"Out of Adjust Node Mode"C) ! bret = MODIFYMENUFLAGSQQ(2,3, $MENUUNCHECKED) ! iret = UNREGISTERMOUSEEVENT(iunit, MOUSE$LBUTTONDOWN) ! iret = UNREGISTERMOUSEEVENT(iunit, MOUSE$MOVE) ! iret = UNREGISTERMOUSEEVENT(iunit, MOUSE$LBUTTONUP) !else Adjustnode_checked = .true. call setstatusbar(0,'AdjustNode'C) call setstatusbar(1,'Adjust node -- left click any node and drag...'C) bret = MODIFYMENUFLAGSQQ(2,3, $MENUCHECKED) iret = REGISTERMOUSEEVENT (iunit, MOUSE$LBUTTONDOWN, SelectNode) iret = REGISTERMOUSEEVENT (iunit, MOUSE$MOVE, MoveNode) iret = REGISTERMOUSEEVENT (iunit, MOUSE$LBUTTONUP, EndButtonDown) !end if end subroutine Adjustnode ! ! callback routine when in Block set value mode ! subroutine BlockSetValue use dfwin use dflib use global integer(4) iret, iunit logical(4) bret external PickPoint, FinishPoly, setEQCM ! Check if array is allocated if(.not.GridLoaded) then call CheckAllocate end if ! Block set value mode only after you first select Menu Elevation/Q/Crust/Mantle if(eqcmDraw_checked) then if(.not.BlockSetValue_checked) then BlockSetValue_checked = .true. iunit = GETACTIVEQQ() call setstatusbar(0, "Block Set mode"C) !! Note: Npoly here store # of vertices of polygon !! PB script, Npoly stores # of planes. DIFFERENT!!! Npoly = 0 call setstatusbar(0,'EQCM/BlockSet'C) msg = 'Now outline a convex polygon counterclockwise with left mouse clicks, & & and finish with the right button.'C call setstatusbar(1, msg) ! Register MouseEvent iret = REGISTERMOUSEEVENT(iunit, MOUSE$LBUTTONDOWN, PickPoint) iret = REGISTERMOUSEEVENT(iunit, MOUSE$RBUTTONDOWN, FinishPoly) ! put check mark close to menu item iret = MODIFYMENUFLAGSQQ(2, 11, $MENUCHECKED) else BlockSetValue_checked = .false. call setstatusbar(0,'EQCMset'C) call setstatusbar(1,' setting nodal value (left click to set value, Ctrl + Right Click to repeat the last value)'C) iret = MODIFYMENUFLAGSQQ(2, 11, $MENUUNCHECKED) iret = REGISTERMOUSEEVENT(iunit, MOUSE$LBUTTONDOWN.OR.MOUSE$RBUTTONDOWN, setEQCM) endif else call error13 return endif ! eqcmDraw_checked end subroutine BlockSetValue ! ! check allocation of global array ! After Grid is cleared, if using Edit command, call this routine ! to allocate if maximum size is not zero ! subroutine CheckAllocate use global if (mxnode /= 0) then if(.not.allocated(nodeABG)) allocate(nodeABG(3,mxnode),stat = ierr) if(.not.allocated(eqcm)) allocate(eqcm(6,mxnode),stat = ierr) if(.not.allocated(NMemo)) allocate(NMemo(mxnode), stat = ierr) end if if (mxel /= 0) then if(.not.allocated(nodes)) allocate(nodes(3,mxel), stat = ierr) if(.not.allocated(EMemo)) allocate(EMemo(mxel), stat = ierr) end if if (mxfel /= 0) then if(.not.allocated(nodef)) allocate(nodef(4,mxfel), stat = ierr) if(.not.allocated(fdip)) allocate(fdip(2, mxfel), stat = ierr) if(.not.allocated(offset)) allocate(offset(mxfel), stat = ierr) end if end subroutine CheckAllocate ! ! Clear Basemap Linklist ! subroutine ClearBase ! require: BaseLoaded, GridLoaded use global use dflib implicit none ! update statusbar call setstatusbar(0,'ClearBase'C) call setstatusbar(1,' 'C) ! if(BaseLoaded) then call ClearLinkList BaseLoaded = .false. msg = ' Basemap cleared, ready for new basemap or other command'C call setstatusbar(1, msg) call redraw else call beepqq(1000, 40) call error9('Basemap') end if ! update status bar call setstatusbar(0,'Running'C) call setstatusbar(1,' 'C) end subroutine ClearBase ! ! Clear linklist of basemap ! subroutine ClearLinkList use global type(point), pointer:: tmp tmp => phead do while(associated(tmp)) phead => tmp%next_point deallocate(tmp) tmp => phead end do end subroutine ClearLinkList ! ! Clear Grid already loaded in memory ! subroutine ClearGrid ! require: GridLoaded use dfwin use dflib use global use dflogm implicit none include 'resource.fd' type(dialog) dlg logical(4) bret integer(4) iret integer iunit external Showxy ! update statusbar call setstatusbar(0, 'ClearGrid'C) call setstatusbar(1, ' 'C) ! unregister mousemove if it is registered before ! Necessary for showing new status message iret = unregistermouseevent(iunit, MOUSE$MOVE) if (GridLoaded) then bret = dlginit(IDD_ClearGrid, dlg) iret = dlgmodal(dlg) if (iret == IDOK) then ! save to BACKUP.feg first call IncreaseEditingCounter ! deallocate major arrays if (allocated(nodeABG)) deallocate(nodeABG) if (allocated(eqcm)) deallocate(eqcm) if (allocated(nodes)) deallocate(nodes) if (allocated(EMemo)) deallocate(EMemo) if (allocated(NMemo)) deallocate(NMemo) if (allocated(nodef)) deallocate(nodef) if (allocated(fdip)) deallocate(fdip) if (allocated(offset)) deallocate(offset) NUMNOD = 0 NUMEL = 0 NFL = 0 if(BaseLoaded) then call ClearBase end if GridLoaded = .false. Contour = 0 Colorin = 0 call CLEARSCREEN($GCLEARSCREEN) call ClearHistory call DrawGrid ! modify status message msg = " The grid was successfully cleared from the memory !!!" // CHAR(0) call setstatusbar(1,msg) ! modify window title title_string = 'Working Window'C iunit = getactiveqq() iret = SetWindowText(GetHwndQQ(iunit),title_string) ! clear title ! Otherwise, the leftover title from old cleared grid may write to ! newly created grid within the same session if (len_trim(title) /= 0) title ='' ! Unregister mouse_Left_ButtonDown if there is any iret = UNREGISTERMOUSEEVENT(iunit, MOUSE$LBUTTONDOWN) else end if else call beepqq(1000,100) call error9('Grid') end if ! update statusbar infor. call setstatusbar(0,'Running'C) call setstatusbar(1,' 'C) end subroutine ClearGrid ! ! clear history of registermouseevent, and/or check sign ! subroutine ClearHistory use dfwin use dflib use global integer iunit integer(4) cursor, oldcursor integer(4) iret logical(4) bret external Showxy iunit = getactiveqq() if(AddDropNode_checked) then iret = UNREGISTERMOUSEEVENT(iunit, MOUSE$LBUTTONDOWN) iret = UNREGISTERMOUSEEVENT(iunit, MOUSE$RBUTTONDOWN) bret = MODIFYMENUFLAGSQQ(2,1,$MENUUNCHECKED) AddDropNode_checked = .false. end if if(AdjustNode_checked) then iret = UNREGISTERMOUSEEVENT(iunit, MOUSE$LBUTTONDOWN) iret = UNREGISTERMOUSEEVENT(iunit, MOUSE$MOVE) iret = UNREGISTERMOUSEEVENT(iunit, MOUSE$LBUTTONUP) bret = MODIFYMENUFLAGSQQ(2,3,$MENUUNCHECKED) iret = REGISTERMOUSEEVENT(iunit, MOUSE$MOVE, Showxy) AdjustNode_checked = .false. end if if(AddDeleteElement_checked) then iret = UNREGISTERMOUSEEVENT(iunit, MOUSE$LBUTTONDOWN) iret = UNREGISTERMOUSEEVENT(iunit, MOUSE$RBUTTONDOWN) bret = MODIFYMENUFLAGSQQ(2,4,$MENUUNCHECKED) AddDeleteElement_checked = .false. end if if(CutHealFault_checked) then iret = UNREGISTERMOUSEEVENT(iunit, MOUSE$LBUTTONDOWN) iret = UNREGISTERMOUSEEVENT(iunit, MOUSE$RBUTTONDOWN) bret = MODIFYMENUFLAGSQQ(2,6,$MENUUNCHECKED) iret = REGISTERMOUSEEVENT(iunit, MOUSE$MOVE, Showxy) CutHealFault_checked = .false. ! whenever out of CutHealFault, delete bogus fault call DeleteBogusFault end if if(EQCMdraw_checked) then iret = UNREGISTERMOUSEEVENT(iunit, MOUSE$LBUTTONDOWN) iret = UNREGISTERMOUSEEVENT(iunit, MOUSE$RBUTTONDOWN) bret = MODIFYMENUFLAGSQQ(2, 10, $MENUUNCHECKED) iret = REGISTERMOUSEEVENT(iunit, MOUSE$MOVE, Showxy) EQCMdraw_checked = .false. if(BlockSetValue_checked) then BlockSetValue_checked = .false. bret = MODIFYMENUFLAGSQQ(2, 11, $MENUUNCHECKED) endif end if if(Finclination_checked) then iret = UNREGISTERMOUSEEVENT(iunit, MOUSE$LBUTTONDOWN) iret = UNREGISTERMOUSEEVENT(iunit, MOUSE$RBUTTONDOWN) bret = MODIFYMENUFLAGSQQ(2,7,$MENUUNCHECKED) iret = REGISTERMOUSEEVENT(iunit, MOUSE$MOVE, Showxy) Finclination_checked = .false. end if if(Fheading_checked) then iret = UNREGISTERMOUSEEVENT(iunit, MOUSE$LBUTTONDOWN) iret = UNREGISTERMOUSEEVENT(iunit, MOUSE$RBUTTONDOWN) bret = MODIFYMENUFLAGSQQ(2, 8, $MENUUNCHECKED) iret = REGISTERMOUSEEVENT(iunit, MOUSE$MOVE, Showxy) Fheading_checked = .false. end if if(ZoomInOut_checked) then iret = UNREGISTERMOUSEEVENT(iunit, MOUSE$LBUTTONDOWN) bret = MODIFYMENUFLAGSQQ(3,2,$MENUUNCHECKED) ZoomInOut_checked = .false. ! set cursor back to default type !cursor = LoadCursor(0, IDC_ARROW) !oldcursor = SetMouseCursor(cursor) end if if(Using2ndOrigin) then Using2ndOrigin = .false. iret = UNREGISTERMOUSEEVENT(iunit, MOUSE$LBUTTONDOWN) iret = UNREGISTERMOUSEEVENT(iunit, MOUSE$RBUTTONDOWN) iret = UNREGISTERMOUSEEVENT(iunit, MOUSE$MOVE) ! bret = MODIFYMENUFLAGSQQ(3,7, $MENUUNCHECKED) end if if(TileGrid_checked) then TileGrid_checked = .false. iret = UNREGISTERMOUSEEVENT(iunit, MOUSE$LBUTTONDOWN) iret = UNREGISTERMOUSEEVENT(iunit, MOUSE$RBUTTONDOWN) end if if(ViewGap_checked) then ViewGap_checked = .false. call clearscreen($GCLEARSCREEN) call Redraw iret = UNREGISTERMOUSEEVENT(iunit, MOUSE$LBUTTONDOWN) iret = UNREGISTERMOUSEEVENT(iunit, MOUSE$RBUTTONDOWN) end if end subroutine ClearHistory ! ! Clear JIP, Non(1000), Eon(1000), Fon(1000), which are ! global but used in SUBR AddDeleteElement, AdjustNode ! subroutine ClearNEFon use global JIP = 0 NItsOn = 0 EItsOn = 0 FItsOn = 0 Non(1:1000) = 0 Eon(1:1000) = 0 Fon(1:1000) = 0 end subroutine ClearNEFon ! ! ClickAndView: used by Callback routine ViewGap ! subroutine ClickAndView(unit, mouseevent, iKeyState, xpos, ypos) use dfwin use dflib use global integer unit, mouseevent, xpos, ypos integer col, row integer(4) jj, nH integer(4) i, j, k real x, y logical GotOne type(xycoord) viewxy external Showxy if (((MOUSE$KS_LBUTTON.and.iKeyState) == MOUSE$KS_LBUTTON).or. & ((MOUSE$KS_RBUTTON.and.iKeyState) == MOUSE$KS_RBUTTON)) then ! special Kludge: temporarily disable mouse move callback, ! otherwise, screen freezes irregularly iunit = getactiveqq() iret = UNREGISTERMOUSEEVENT(iunit, MOUSE$MOVE) ! call getviewcoord(xpos, ypos, viewxy) col = viewxy%xcoord row = viewxy%ycoord call XandY(col, row, x, y) call GetElement(x, y, jj, r2min) if(r2min < tolerance*tolerance) then nH = nodes(1, jj) NMemo(1:NUMNOD) = 0 NMemo(nH) = 2 EMemo(1:NUMEL) = 1 ! open(1, file='tmp.dat', status='unknown',action='write') 1 GotOne = .false. do i = 1, NUMEL if((NMemo(nodes(1,i))==2).or.(NMemo(nodes(2,i))==2.or. & NMemo(nodes(3,i))==2)) then if(EMemo(i) == 2) then else ! Following are NOT good programming practices that need to be ! redone when I have more time ! ColorIn has to be put ahead of Call DrawElement ColorIn = 1 call DrawElement(ielecolor, i) ! note: do not put ahead of DrawElement!!! ! As in DrawElement, EMemo is reset to 1 ! a better way is to use another EMemo array for local purpose ! and do not mess up with Global EMemo EMemo(i) = 2 GotOne = .true. ! write(1,*) i do k = 1, 3 j = nodes(k,i) if(NMemo(j) == 0) NMemo(j) = 1 end do end if end if end do if(GotOne) then do k = 1, NUMNOD if(NMemo(k) > 0) NMemo(k) = NMemo(k) + 1 end do goto 1 else NMemo(1:NUMNOD) = 0 EMemo(1:NUMEL) = 1 end if ! close(1) ! Special Kludge: restore back for mousemovement callback iret = REGISTERMOUSEEVENT(iunit, MOUSE$MOVE, Showxy) else ! click was not on element center call beepqq(1000, 40) end if return end if end subroutine ! ! Show ColorBar along with contour map of Elevation/Q/Crust/Mantle ! subroutine ColorBar use dflib use dfwin use Global integer(4) iret integer(2) status integer i, j, npnts, offst integer xt, yt, yb integer pixelheight, ystart, yextra real F type (xycoord) poly(4), xy ! width xt = int(.0225 * real(HiCol)) - 1 pixelheight = 20 ! # of pixels ystart = 0.5*HiRow npnts = 4 ! status = INITIALIZEFONTS() status = SETFONT('t''Arial''h18w8pvib') ! ! first draw big box with gray background icolor = RGB(150, 150, 150) iret = SETCOLORRGB(icolor) yextra = 10 poly(1)%xcoord = 0 poly(1)%ycoord = ystart + yextra ! each character width: 8 pixels; 10: format width > 8 poly(2)%xcoord = xt + 8* 10 poly(2)%ycoord = ystart + yextra poly(3)%xcoord = xt + 8* 10 poly(3)%ycoord = ystart - Hicolor*pixelHeight - yextra poly(4)%xcoord = 0 poly(4)%ycoord = ystart - Hicolor*pixelHeight - yextra status = POLYGON($GFILLINTERIOR, poly, int2(npnts)) ! do i = 2, Hicolor yb = ystart - pixelheight*(i-1) yt = ystart - pixelheight*i poly(1)%xcoord = 0 poly(1)%ycoord = yb poly(2)%xcoord = xt poly(2)%ycoord = yb poly(3)%xcoord = xt poly(3)%ycoord = yt poly(4)%xcoord = 0 poly(4)%ycoord = yt icolor = colorarray(i) iret = SETCOLORRGB(icolor) status = POLYGON($GFILLINTERIOR, poly, int2(npnts)) j = i - 1 1 F = botf + (topf - botf)*(j-1) /real(Hicolor - 1) ! set text color icolor = RGB(255, 255, 255) iret = SETCOLORRGB(icolor) if(idata == 1) then write(msg,'(F9.3)') F elseif(idata == 2) then write(msg,'(F8.5)') F elseif(idata == 3) then write(msg,'(F9.1)') F elseif(idata == 4) then write(msg,'(F9.1)') F elseif(idata == 5) then write(msg,'(F9.3)') F elseif(idata == 6) then write(msg,'(ES9.2)') F end if ! here 18 is height of font offst = 0.5 * 18.0 call moveto(xt, yb - offst, xy) call outgtext(trim(msg) // CHAR(0)) ! output ending value if(j == Hicolor - 1) then j = Hicolor yb = yt goto 1 end if end do end subroutine ColorBar ! ! Cut or healing a fault ! subroutine CutHealFault use dfwin use dflib use global logical checked logical(4) bret integer(4) iret, iunit external CutHealFlt, Showxy if(AppType == 1) then ! thin-shell type iunit = getactiveqq() call ClearHistory call CheckAllocate !if (checked) then ! CutHealFault_checked = .false. ! call setstatusbar(1," Out of Cut/Heal Fault mode"C) ! bret = MODIFYMENUFLAGSQQ(2,6,$MENUUNCHECKED) ! iret = UNREGISTERMOUSEEVENT(iunit, MOUSE$LBUTTONDOWN.OR.MOUSE$RBUTTONDOWN) !else CutHealFault_checked = .true. if(contour) then contour = 0 call redraw end if call setstatusbar(0,'Cut/Heal Fault'C) call setstatusbar(1,' Move to element side & Click, Left click: Cut, right click: Heal ...'C) bret = MODIFYMENUFLAGSQQ(2,6,$MENUCHECKED) iret = REGISTERMOUSEEVENT (iunit, MOUSE$LBUTTONDOWN.OR.MOUSE$RBUTTONDOWN, CutHealFlt) iret = REGISTERMOUSEEVENT (iunit, MOUSE$MOVE, Showxy) !endif else ! not thin-shell type CutHealFault_checked = .false. call error11(AppType) endif end subroutine CutHealFault ! ! Cut a new fault, Callback routine used in SUBR CutHealFault ! subroutine CutHealFlt(unit, MouseEvent, iKeyState, xpos, ypos) use dfwin use dflib use global integer unit, MouseEvent, iKeyState, xpos, ypos integer col, row integer outside integer(4) iebase, n1, n2, n3, n4 integer(4) s1 integer(4) ie integer(4) iefar, jefar, ietemp, jejoin, Kfault, Kele integer(4) ietemp1, jejoin1, Kfault1, jf1, Kele1, je1 integer(4) n, i integer jf, je, je2 real x, y real tempvec(3) logical faulted type(xycoord) viewxy if (((MOUSE$KS_LBUTTON.and.iKeyState) == MOUSE$KS_LBUTTON).or. & ((MOUSE$KS_RBUTTON.and.iKeyState) == MOUSE$KS_RBUTTON)) then call getviewcoord(xpos, ypos, viewxy) col = viewxy%xcoord row = viewxy%ycoord call XandY(col, row, x, y) call xy2ABG(x, y, outside, tempvec) if (outside) then call beepqq(1000,40) else if ((MOUSE$KS_LBUTTON.and.iKeyState) == MOUSE$KS_LBUTTON) then call FindElementSide(x, y, iebase, n1, n2, r2min) if (r2min > tolerance * tolerance) then call beepqq(1000,40) else ! cursor identify an element side ! check if this side is already a fault faulted = .false. s1 = 1 3 call OnAnyF(n1, s1, NFL, ie, je) if (ie > 0) then if (((n2 == nodef(1, ie)).or.(n2 == nodef(2, ie))) .or. & ((n2 == nodef(3, ie)).or.(n2 == nodef(4, ie)))) then faulted = .true. end if if (ie < NFL) then s1 = ie + 1 goto 3 end if end if ! action on whether the side is fault or not if (faulted) then call beepqq(1000,40) elseif (NFL == MXFEL) then call beepqq(1000, 40) call error14('Fault', MXFEL) else ! side is green and storage is OK, make new fault NFL = NFL + 1 fdip(1, NFL) = 90.0 fdip(2, NFL) = 90.0 offset(NFL) = 0.0 nodef(1, NFL) = n1 nodef(2, NFL) = n2 ! creat two new nodes tempvec(1) = nodeABG(1, n1) tempvec(2) = nodeABG(2, n1) tempvec(3) = nodeABG(3, n1) ! n4 node numnod = numnod + 1 if(numnod > mxnode) then call error14('Node', mxnode) numnod = numnod - 1 NFL = NFL - 1 return endif n = numnod do i = 1, 6 EQCM(i,n) = 0 end do nodeABG(1,n) = tempvec(1) nodeABG(2,n) = tempvec(2) nodeABG(3,n) = tempvec(3) nodef(4, NFL) = n n4 = n EQCM(1, n4) = EQCM(1, n1) EQCM(2, n4) = EQCM(2, n1) EQCM(3, n4) = EQCM(3, n1) EQCM(4, n4) = EQCM(4, n1) EQCM(5, n4) = EQCM(5, n1) EQCM(6, n4) = EQCM(6, n1) ! n3 node tempvec(1) = nodeABG(1, n2) tempvec(2) = nodeABG(2, n2) tempvec(3) = nodeABG(3, n2) numnod = numnod + 1 if(numnod > mxnode) then call error14('Node', mxnode) numnod = numnod - 1 NFL = NFL - 1 return endif n = numnod do i = 1, 6 EQCM(i,n) = 0 end do nodeABG(1, n) = tempvec(1) nodeABG(2, n) = tempvec(2) nodeABG(3, n) = tempvec(3) nodef(3, NFL) = n n3 = n EQCM(1:6,n3) = EQCM(1:6, n2) ! if there is an element on the far side, locate it s1 = 1 4 call OnAnyE(n1, s1, NUMEL, ie, je) if (ie > 0) then if (ie /= iebase) then je2 = mod(je, 3) + 1 if ((nodes(je2, ie) == n2)) then ! Here may come BUGS!!! ! Check if side = mod(je2,3) + 1 is a fault ! -------------- bug fixed portion ----------------- ietemp1 = ie jejoin1 = mod(je2, 3) + 1 call NEXTto(ietemp1, jejoin1, Kfault1, jf1, Kele1, je1) if(Kele1 /= iebase) goto 8 !---------------------------------------------------- iefar = ie jefar = mod(je2, 3) + 1 ! swing clockwise around n3-n2 end ietemp = iefar jejoin = mod(jefar, 3) + 1 ! clockwise: 5 call NEXTto(ietemp, jejoin, Kfault, jf, Kele, je) nodes(mod(jejoin,3)+1,ietemp) = n3 if (Kfault > 0) then if (jf == 1) then nodef(2, Kfault) = n3 else nodef(4, Kfault) = n3 end if if (Kfault == NFL) then ! come back to side 1; eliminate old node ! n3: aka; n2: node# to be dropped call dropnodesize(n3, n2) if (n1>n2) n1 = n1 - 1 if (n4>n2) n4 = n4 - 1 end if else ! no fault, continue pivoting clockwise ! je updated in NEXTto if (kele > 0) then ietemp = kele jejoin = mod(je, 3) + 1 goto 5 end if end if ! Kfault> 0 ! swing counterclockwise around n4-n1 end ietemp = iefar jejoin = mod(mod(jefar,3)+1, 3) + 1 ! counterclockwise 6 call NEXTto(ietemp,jejoin, Kfault, jf, Kele, je) nodes(mod(mod(jejoin,3)+1,3)+1,ietemp) = n4 if (Kfault > 0) then if (jf == 1) then nodef(1, Kfault) = n4 else nodef(3, Kfault) = n4 end if if (Kfault == NFL) then call dropnodesize(n4, n1) if (n2>n1) n2 = n2 - 1 if (n3>n1) n3 = n3 - 1 end if else if(Kele > 0) then ietemp = Kele jejoin = mod(mod(je,3)+1,3) + 1 goto 6 end if end if 8 end if ! nodes(je2, ie) == n2 end if ! ie/= iebase ! continue to search for far side if (ie < NUMEL) then s1 = ie + 1 goto 4 end if end if ! ie > 0 ! draw fault, NFL: new fault number call drawfault(ifaultcolor, NFL) ! increment editing counter call IncreaseEditingCounter end if ! endif of faulted end if ! r2min > tolerance^2 elseif ((MOUSE$KS_RBUTTON.and.iKeyState) == MOUSE$KS_RBUTTON) then call findfault(x, y, ie) if (ie > 0) then call dropfault(ie) ! increment editing counter call IncreaseEditingCounter else call beepqq(1000, 40) end if end if ! left or right button click end if ! outside end if ! left click or right click end subroutine CutHealFlt ! ! Delete bogus fault when exiting from CutHealFault command ! subroutine DeleteBogusFault use global integer(4) ie if(NFL > 0) then ie = NFL 1 if((nodef(1, ie) == nodef(4, ie)).and.(nodef(2,ie)== nodef(3,ie))) then call dropfault(ie) ! increment editing counter call IncreaseEditingCounter end if ie = ie - 1 if(ie > 0) goto 1 else end if end subroutine DeleteBogusFault ! ! Routine for deleting element ! subroutine DeleteElement(unit, me, iKeyState, xpos, ypos) use dfwin use dflib use global integer unit, me, iKeyState, xpos, ypos integer col, row integer m integer(4) i, k integer(4) jj integer(4) ie, je integer(4) na, nb, n1 real x, y real R2min logical OK type(xycoord) viewxy if ((MOUSE$KS_RBUTTON.and.iKeyState) == MOUSE$KS_RBUTTON) then if (mod(JIP, 3) == 0) then ! Make sure there is no unfinished click for adding element ! otherwise, clear up such selection call getviewcoord(xpos, ypos, viewxy) col = viewxy%xcoord row = viewxy%ycoord call XandY(col, row, x, y) call GetElement(x, y, jj, R2min) if (R2min < tolerance * tolerance) then ! now check for nodes involved in a fault OK = .true. do m = 1, 3 call OnAnyF(nodes(m, jj), 1, NFL, ie, je) if(ie > 0) OK = .false. end do if (OK) then call DrawElement(ibackcolor, jj) do m = 1, 3 na = nodes(m,jj) nb = nodes(mod(m,3)+1, jj) n1 = 1 4 call OnAnyE(na, n1,NUMEL, ie,je) if (ie == jj) then ! find itself n1 = jj + 1 goto 4 elseif (ie > 0) then if ((nb == nodes(mod(je+1,3)+1,ie)) .or. & (nb == nodes(mod(je,3)+1,ie))) then call drawelement(ielecolor, ie) else if (ie < NUMEL) then n1 = ie + 1 go to 4 end if end if end if end do ! next m NUMEL = NUMEL - 1 JIP = 0 do i = jj, NUMEL EMemo (i) = EMemo(i + 1) do k = 1, 3 nodes(k, i) = nodes(k, i + 1) end do end do ! next i ! increment editing counter call IncreaseEditingCounter else ! more than 1 nodes involved in a fault call beepqq(1000,40) end if else ! not on any element call beepqq(1000,40) end if ! on element elseif (JIP > 0) then do i = 1, JIP call drawnode(inodecolor, Eon(i)) end do JIP = 0 else call beepqq(1000,40) end if end if ! right click end subroutine DeleteElement ! ! Decision point dialog box for specifying the program type (1. thin-shells; 2. Restore2; ! 3. Restore3) ! subroutine DecisionPtDlg use dfwin use dflogm use global implicit none include 'resource.fd' type(dialog) dlg character(len = 1024) szbuffer integer maxsize integer(4) iret logical(4) bret maxsize = 1024 bret = DLGINIT(Decision_dialog, dlg) iret = LoadString(GetModuleHandle(NULL), IDS_String6, szbuffer, maxsize) bret = DlgSet(dlg, IDC_Decision_static2, szbuffer) bret = DlgSet(dlg, IDC_Decision_EDIT2, '1'C) iret = Dlgmodal(dlg) if(iret == IDOK) then bret = Dlggetchar(dlg, IDC_Decision_EDIT2, msg) CALL Repair_String(msg) if(len_trim(msg) == 0) then ! Not a valid number call error8('1') else ! number but check range, if exceed, use default read(msg, *) AppType if(AppType > 3) then call error8('1') AppType = 1 end if end if else ! for cancel button, use default AppType = 1 end if end subroutine DecisionPtDlg ! ! Dialog for setting EQCM ! subroutine DlgEQCM(OK) ! Modify: contour, idata use dflib use dflogm use dfwin use global implicit none include 'resource.fd' type(dialog) dlg logical(4) bret logical IsNumber logical OK integer(4) iret integer maxsize character(len = 1024) szbuffer maxsize = 1024 iret = LoadString(GetModuleHandle(NULL), IDS_String4, szbuffer, maxsize) bret = DLGINIT(IDD_EQCM, dlg) bret = DlgSet(dlg, IDC_EQCM_static1, szbuffer) iret = Dlgmodal(dlg) if (iret == IDOK) then OK = .true. bret = dlggetchar(dlg, IDC_EQCM_edit1, msg) CALL Repair_String(msg) if(len_trim(msg) == 0) then contour = 0 idata = 0 return else if(IsNumber(msg)) then read(msg, *) idata if((idata >= 1).and.(idata <=6)) then contour = 1 else call error10 contour = 0 idata = 0 return end if else call error7 ! not a valid number contour = 0 idata = 0 return end if end if else OK = .false. contour = 0 idata = 0 end if if (iret == IDOK) then call setbins ! use drawelement subroutine for drawing contour call redraw end if end subroutine DlgEQCM ! ! Dialog for setting fault inclination ! modified on March 27, 2005 ! default shallow dip, steep dip for thrust and normal fault: 20 and 55 deg for continental ! CCB, CTF, CRB. Other dip angle for oceanic spreading ridge, transform, convergent, & subduction ! see paper ! "Bird and Kagan, (2004), Plate-tectonic analysis of shallow seismicity: Apparent ! boundary width, beta, corner magnitude, couplied lithosphere thickness, and ! coupling in seven tectonic settings, Bull. Seismol. Soc. Am., 94(6), 2380-2399" ! ! subroutine DlgFinc use dflib use dflogm use dfwin use global implicit none include 'resource.fd' type (dialog) dlg integer(4) iret integer maxsize logical(4) bret logical IsNumber ! function to determine whether string is number character(len=1024) szbuffer maxsize = 1024 iret = LoadString(GetModuleHandle(NULL), IDS_String3, szbuffer, maxsize) bret = DLGINIT(IDD_Finclination, dlg) bret = DlgSet(dlg, IDC_Finc, szbuffer) write(msg, '(F8.1)') 20.0 bret = Dlgsetchar(dlg,IDC_Finc_edit1, TRIM(msg) // CHAR(0)) write(msg,'(F8.1)') 55.0 bret = Dlgsetchar(dlg,IDC_Finc_edit2, TRIM(msg) // CHAR(0)) iret = dlgmodal(dlg) if (iret == IDOK) then bret = dlggetchar(dlg, IDC_Finc_edit1, msg) CALL Repair_String(msg) ! prevent input in characters instead of numbers, ! which may crash the program!! if (len_trim(msg) /= 0) then if(IsNumber(trim(msg))) then read(msg,*) shallow else ! write(msg, '(" for shallow dip angle ", F8.3)') 30.0 write(msg, '(" for shallow dip angle ", F8.1)') 20.0 call error8(msg) ! shallow = 30.0 shallow = 20.0 end if end if bret = dlggetchar(dlg, IDC_Finc_edit2, msg) CALL Repair_String(msg) if (len_trim(msg) /= 0) then if(IsNumber(trim(msg))) then read(msg,*) steep else !write(msg,'("for steep dip angle ", F8.3)') 65.0 write(msg,'("for steep dip angle ", F8.1)') 55.0 call error8(msg) !steep = 65.0 steep = 55.0 end if end if call Dlguninit(dlg) if ((shallow > 90.0).or. (shallow < 0.0)) then call error5("shallow dip") return end if if ((steep > 90.0).or.(steep < 0.0)) then call error5("steep dip") return end if end if end subroutine DlgFinc ! ! Routine for always drawing grid and Basemap at windowheight = 2.02 ! Note: DrawGrid is only place to reset contour option off ! DrawGrid & Redraw: reset colorin(viewgap) option off ! subroutine Drawgrid use dflib use global integer dummy,tcol0, trow0, tcol1, trow1 integer(4) i, iret integer iunit integer visible external Showxy ! if edit command is Adjust node or set Ele/Q/Crust/Mantle before drawing grid, ! then disable these two commands if(Adjustnode_checked.or.eqcmDraw_checked) call ClearHistory iunit = getactiveqq() iret = REGISTERMOUSEEVENT(iunit, MOUSE$MOVE, Showxy) iret = SETCOLORRGB(ifrontcolor) call CLEARSCREEN($GCLEARSCREEN) ! ! update statusbar infor. and clear command history ! call setstatusbar(0, 'Draw grid'C) call setstatusbar(1,'Default view with center at (0,0), Zoom factor 2.02'C) ! ! winlat = 0.0 winlon = 0.0 windowheight = 2.02 call winframe(winlat, winlon, winright, winout, winup) call modeparms call scaler call pixels(-1.0,-1.0, tcol0, trow0, visible) ! upperleft corner call pixels(1.0, 1.0, tcol1, trow1, visible) ! downright corner dummy = ELLIPSE($GBORDER, tcol0, trow0, tcol1, trow1) ! after feg successfully loaded if (Gridloaded) then windowheight = 2.02 tolerance = windowheight * 9 / SNGL(Hirow) call ABG2lonlat(nettempvec, winlon, winlat) call winframe(winlat, winlon, winright, winout, winup) call scaler ! after basemap loaded if (BaseLoaded) call DrawBase ! Modify viewgap switch if (ColorIn) ColorIn = 0 ! Modify contour switch if (contour) then contour = 0 idata = 0 end if ! clear Bogus fault if(CutHealFault_checked) then call DeleteBogusFault end if ! draw node, color option is within drawnode, same for drawelement, drawfault do i = numnod, 1, -1 call drawnode(inodecolor,i) enddo do i = numel, 1, -1 call drawelement(ielecolor, i) enddo ! draw fault do i = nfl, 1, -1 call drawfault(ifaultcolor,i) enddo else if(BaseLoaded) call DrawBase end if end subroutine Drawgrid ! ! Eliminate fault# ie from memory and image ! subroutine dropfault(ie) ! input: ie use global integer(4) ie integer(4) n1, n2, i, n integer(4) aka integer m, j ! redraw using element side color fdip(1, ie) = 90.0 fdip(2, ie) = 90.0 call drawfault(ielecolor, ie) do m = 1, 2 n1 = nodef(m, ie) n2 = nodef(5-m, ie) if (n1>n2) then i = n1 n1 = n2 n2 = i end if if (n1 /= n2) then n = n2 aka = n1 call dropnodesize(aka, n) end if end do NFL = NFL - 1 do i = ie, NFL do j=1,4 nodef(j,i) = nodef(j, i+1) end do do j=1,2 fdip(j,i) = fdip(j,i+1) end do ! Fmemo(i) = Fmemo(i+1) offset(i) = offset(i+1) end do ! increment editing counter call IncreaseEditingCounter end subroutine dropfault ! ! CallBack routine for eliminating node ! subroutine DropNode(unit, me, iKeyState, xpos, ypos) use dflib use Global integer unit, me, iKeyState, xpos, ypos integer col, row integer(4) nH, k, ie, je integer(4) i real x, y type(xycoord) viewxy if((MOUSE$KS_RBUTTON.and.iKeyState) == MOUSE$KS_RBUTTON) then call getviewcoord(xpos, ypos, viewxy) col = viewxy%xcoord row = viewxy%ycoord call XandY(col, row, x, y) NItsOn = 0 call exists(1, x, y, nH) if (nH > 0) then do k = 1, numnod ! make list of all nodes at this spot NOT attached to element/fault if ((nodeABG(1,k)==nodeABG(1,nH)).and.(nodeABG(2,k) == nodeABG(2,nH)) & .and.(nodeABG(3,k) == nodeABG(3,nH))) then call onAnyE(k, 1, NUMEL, ie, je) if (ie == 0) then call OnAnyF(k, 1, NFL, ie, je) if (ie == 0) then NItsOn = NItsOn + 1 Non(NItsOn) = k end if end if end if end do ! next k end if if (NitsOn > 0) then ! if cursor is on >= 1 unused nodes n = Non(1) call drawnode(ibackcolor, n) ! all nodes shared one spot, so undraw once is enough ! do i = 1, NItsOn n = Non(i) call DropNodeSize(-999, n) ! change NUMNOD, nodeABG, nodes, nodeF etc.. do k = i+1, NItsOn if (Non(k) > n) Non(k) = Non(k) - 1 end do if (NUMNOD == 0) GridLoaded = .false. end do ! next i else call beepqq(1000,40) end if ! incrementing editing counter call IncreaseEditingCounter end if end subroutine DropNode ! ! Routine for adjusting the size of node associated arrays, after dropping node ! Eliminate node# n, if it occurs in element/fault lists, replace with aka ! Note: aka ONLY USEFUL in CutFault or HealFault subroutine DropNodeSize(aka,n) use Global integer(4) n integer(4) i, k integer(4) aka NUMNOD = NUMNOD - 1 ! node do k = n, NUMNOD do i = 1, 6 eqcm(i,k) = eqcm(i, k+1) end do nodeABG(1,k) = nodeABG(1,k+1) nodeABG(2,k) = nodeABG(2,k+1) nodeABG(3,k) = nodeABG(3,k+1) end do ! element do k = 1, 3 do i = 1, NUMEL if (nodes(k,i) == n) nodes(k,i) = aka ! Not necessary really. Since all vertices of elements that share n2 or n1 in SUBR CUTHEALFLT ! has been replaced by n3, or n4. But put here just in case ! Suspect there is a bug. aka should be reduced by 1 if aka > n ?? if (nodes(k,i) > n) nodes(k,i) = nodes(k,i) - 1 end do end do ! fault do k = 1, 4 do i = 1, NFL if (nodef(k,i) == n) nodef(k,i) = aka ! Not necessary really. But put here just in case if (nodef(k,i) > n) nodef(k,i) = nodef(k,i) - 1 end do end do end subroutine DropNodeSize ! ! CallBack routine for ending adjusting node mode ! subroutine EndButtonDown(unit, mouseevent, iKeyState, xpos, ypos) use global integer unit, mouseevent, iKeyState, xpos, ypos if (click == 1) then click = 0 ! increment editing counter call IncreaseEditingCounter endif end subroutine EndButtonDown ! ! CallBack routine for ending SetFhead ! subroutine EndSetFhead(unit, mouseevent, iKeyState, xpos, ypos) ! Colold, Col11, Rowold, Row11: global ! Heading, OldHead: global ! Col_MouseClick, Row_MouseClick: global use dflib use global integer(4) i, k, m, s1 integer(4) ie, je integer unit, mouseevent, iKeyState, xpos, ypos logical gotit real change, r real tempvec(3), tempv2(3), tempv3(3), tempv4(3) type(xycoord) xy if (Click == 1) then click = 0 if (Heading == oldhead) then do i = 1, NFL call drawfault(ifaultcolor, i) end do else ! update whole grid by moving nodes ! erase last drawing line call moveto(2*Colold-col11, 2*RowOld - row11, xy) iret = lineto(col11, row11) ! restore writing mode iret = SETWRITEMODE($GPSET) ! ensure heading change is minimal change = Heading - OldHead if(change > 1.570796) change = change - 3.141593 if(change > 1.570796) change = change - 3.141593 if(change > 1.570796) change = change - 3.141593 if(change > 1.570796) change = change - 3.141593 if(change < -1.570796) change = change + 3.141593 if(change < -1.570796) change = change + 3.141593 if(change < -1.570796) change = change + 3.141593 if(change < -1.570796) change = change + 3.141593 Heading = oldHead + change ! make a list of nodes, elements, faults to be redrafted call XandY(Col_MouseClick, Row_MouseClick, x, y) call findfault(x, y, ie) if(ie > 0) then ! found a fault center n1 = nodef(1, ie) n2 = nodef(2, ie) n3 = nodef(3, ie) n4 = nodef(4, ie) tempvec(1:3) = 0.5*(nodeABG(1:3, n1) + nodeABG(1:3, n2)) call unitVec(tempvec) tempv2(1:3) = nodeABG(1:3, n2) - nodeABG(1:3, n1) ! east pointing unit vector tempv3(1) = - tempvec(2) tempv3(2) = tempvec(1) tempv3(3) = 0 call unitVec(tempv3) call cross(tempvec, tempv3, tempv4) endif NItsOn = 4 Non(1) = n1 Non(2) = n2 Non(3) = n3 Non(4) = n4 NMemo(n1) = 1 NMemo(n2) = 2 NMemo(n3) = 2 NMemo(n4) = 1 ! find other nodes sharing same spot do k=1, NUMNOD if((nodeABG(1,k) == nodeABG(1, n1)).and. & (nodeABG(2,k) == nodeABG(2, n1)).and. & (nodeABG(3,k) == nodeABG(3, n1))) then if((k /= n1).and.(k /= n4)) then NItsOn = NItsOn + 1 Non(NItsOn) = k NMemo(k) = 1 ! (1,4) end end if end if if((nodeABG(1,k) == nodeABG(1, n2)).and. & (nodeABG(2,k) == nodeABG(2, n2)).and. & (nodeABG(3,k) == nodeABG(3, n2))) then if((k /= n2).and.(k /= n3)) then NItsOn = NItsOn + 1 Non(NItsOn) = k NMemo(k) = 2 ! (2, 3) end end if end if end do ! find element EItsOn = 0 do k = 1, NItsOn s1 = 1 3 call OnAnyE(Non(k), s1, NUMEL, ie, je) if(ie > 0) then gotit = .false. do m=1, EItsOn if(Eon(m)==ie) gotit = .true. end do if(gotit) then else EItsOn = EItsOn + 1 EOn(EItsOn) = ie end if if(ie < NUMEL) then if (ie < NUMEL) then s1 = ie + 1 goto 3 end if end if end if end do ! find fault FItsOn = 0 do k=1, NITsOn s1 = 1 4 call OnAnyF(Non(k), s1, NFL, ie, je) if(ie > 0) then gotit = .false. do m = 1, FItsOn if(Fon(m) == ie) gotit = .true. end do if(gotit) then else FItsOn = FItsOn + 1 Fon(FItsOn) = ie end if if(ie < NFL) then s1 = ie + 1 goto 4 end if end if end do ! undraft these tings in background color do k=1, FItsON call drawfault(ibackcolor, Fon(k)) end do do k=1, EItsON call drawelement(ibackcolor, Eon(k)) end do do k=1, NItsOn call drawnode(ibackcolor, Non(k)) end do ! correct node position r= 0.5*sqrt(tempv2(1)**2 + tempv2(2)**2 + tempv2(3)**2) r = r/sqrt(1-r**2) tempv2(1:3) = tempvec(1:3) + r*(cos(heading)*tempv4(1:3) + sin(heading)*tempv3(1:3)) call unitvec(tempv2) do m = 1, NItsON k= Non(m) if(NMemo(k) == 2) then NMemo(k) = 0 NodeABG(1:3, k) = tempv2(1:3) end if end do tempv2(1:3) = tempvec(1:3) - r*(cos(heading)*tempv4(1:3) + sin(heading)*tempv3(1:3)) call unitvec(tempv2) do m = 1, NItsOn k = Non(m) if(NMemo(k) == 1) then NMemo(k) = 0 NodeABG(1:3, k) = tempv2(1:3) end if end do ! redraft everything in correct position and colors do k=1, NItsOn call drawnode(inodecolor, Non(k)) end do do k=1, EItsOn call flipped(Eon(k)) call drawelement(ielecolor, Eon(k)) end do do k=1, FItsOn call drawfault(ifaultcolor, Fon(k)) end do ! increment editing counter call IncreaseEditingCounter end if ! heading == oldhead end if ! Click == 1 end subroutine EndSetFhead ! ! Show/Edit elevation/Q/crust/mantle lithosphere thickness ! subroutine eqcmDraw use dfwin use dflib use global logical(4) bret logical OK integer checked external setEQCM iunit = getactiveqq() call ClearHistory call CheckAllocate !if(checked) then ! eqcmDraw_checked = .false. ! call setstatusbar(1," Out of setting nodal value ..."C) ! bret = MODIFYMENUFLAGSQQ(2, 10, $MENUUNCHECKED) !else ! initialize global variable last_value, which is used in setEQCM last_val = 99999.00 eqcmDraw_checked = .true. call setstatusbar(0,'EQCMset'C) call setstatusbar(1,' setting nodal value (left click to set value, Ctrl + Right Click to repeat the last value) 'C) bret = MODIFYMENUFLAGSQQ(2,10,$MENUCHECKED) call DlgEQCM(OK) if(OK) then if((contour == 0).or.(idata == 0)) then else iret = REGISTERMOUSEEVENT(iunit, MOUSE$LBUTTONDOWN.OR.MOUSE$RBUTTONDOWN, setEQCM) end if else eqcmDraw_checked = .false. call setstatusbar(0,'Running'C) call setstatusbar(1,' 'C) bret = MODIFYMENUFLAGSQQ(2,10,$MENUUNCHECKED) end if !end if end subroutine eqcmDraw ! ! Fault heading(azimuth) ! subroutine Fheading use dfwin use dflib use global logical checked logical(4) bret integer(4) iret, iunit external PickFault, SetFhead, EndSetFhead iunit = getactiveqq() call ClearHistory call CheckAllocate if(Apptype == 1) then ! thin-shell type !if (checked) then ! Fheading_checked = .false. ! call setstatusbar(1," Out of Fault Heading (Azimuth) ") ! bret = MODIFYMENUFLAGSQQ(2,8,$MENUUNCHECKED) ! iret = UNREGISTERMOUSEEVENT(iunit, MOUSE$LBUTTONDOWN.OR.MOUSE$RBUTTONDOWN) ! iret = UNREGISTERMOUSEEVENT(iunit, MOUSE$MOVE) ! iret = UNREGISTERMOUSEEVENT(iunit, MOUSE$LBUTTONUP.OR.MOUSE$RBUTTONUP) !else Fheading_checked = .true. ! contour = 0 ! call redraw ! does not work with contour mode, as writemode is XOR !! call setstatusbar(0,'Fheading'C) call setstatusbar(1,' Adjust the heading(azimuth) of a fault, Ctrl + left mouse click for details... 'C) bret = MODIFYMENUFLAGSQQ(2,8,$MENUCHECKED) iret = REGISTERMOUSEEVENT (iunit, MOUSE$LBUTTONDOWN.OR.MOUSE$RBUTTONDOWN, PickFault) iret = REGISTERMOUSEEVENT (iunit, MOUSE$MOVE, SetFhead) iret = REGISTERMOUSEEVENT (iunit, MOUSE$LBUTTONUP.OR.MOUSE$RBUTTONUP, EndSetFhead) !endif else ! not thin-shell type Fheading_checked = .false. call error11(AppType) endif return end subroutine Fheading ! ! callback routine Finclination (Fault dip) ! call DlgFinc ! subroutine Finclination use dfwin use dflib use global logical(4) bret integer(4) iret, iunit integer checked external SetFinc, Showxy iunit = getactiveqq() call ClearHistory call CheckAllocate if(AppType == 1) then ! thin-shell type !if(checked) then ! Finclination_checked = .false. ! call setstatusbar(1," Out of Inclination(dip) of fault ..."C) ! bret = MODIFYMENUFLAGSQQ(2,7,$MENUUNCHECKED) ! iret = UNREGISTERMOUSEEVENT(iunit, MOUSE$LBUTTONDOWN.OR.MOUSE$RBUTTONDOWN) !else Finclination_checked = .true. call setstatusbar(0,'Finclination'C) call setstatusbar(1,' Inclination(dip) of fault...'C) bret = MODIFYMENUFLAGSQQ(2,7,$MENUCHECKED) call DlgFinc JIP = 1 ! JIP: global variable, initialize here for SetFinc call setstatusbar(1, "Click near a midpoint ... "C) iret = REGISTERMOUSEEVENT (iunit, MOUSE$LBUTTONDOWN.OR.MOUSE$RBUTTONDOWN, SetFinc) iret = REGISTERMOUSEEVENT (iunit, MOUSE$MOVE, Showxy) !end if else ! not thin-shell type Finclination_checked = .false. call error11(AppType) endif return end subroutine Finclination ! ! Common routine used by CutFault and HealFault ! subroutine FindElementSide(x, y, iebase, n1, n2, r2min) ! input: x, y ! output: n1, n2 (potential fault nodes 1, 2), iebase (element#), r2min(min_distance) use dfwin use global implicit none real r2min, r2 real x, y real x1,y1, x2, y2, xc, yc, dx, dy real tempv2(3), tempv3(3) integer(4) i integer j, j1, k1, j2, k2 integer iebase, n1, n2 integer visible r2min = 2.0E+10 do i = 1, NUMEL do j = 1, 3 j1 = mod(j, 3) + 1 k1 = nodes(j1, i) tempv2(1) = nodeABG(1, k1) tempv2(2) = nodeABG(2, k1) tempv2(3) = nodeABG(3, k1) call ABG2xy(tempv2, visible, x1, y1) if (visible) then j2 = mod(j1,3) + 1 k2 = nodes(j2, i) tempv3(1) = nodeABG(1, k2) tempv3(2) = nodeABG(2, k2) tempv3(3) = nodeABG(3, k2) call ABG2xy(tempv3, visible, x2, y2) if (visible) then xc = 0.5 * (x1 + x2) yc = 0.5 * (y1 + y2) dx = x - xc dy = y - yc r2 = dx*dx + dy*dy if (r2 < r2min) then r2min = r2 iebase = i n1 = k2 n2 = k1 ! n1, n2 are now fault nodes 1 nd 2 end if ! end if ! 1st visible end if ! 2nd visible end do end do ! i end subroutine FindElementSide ! ! Return # of faultelement whose midpoint is near projected point (x, y), otherwise, return 0 ! subroutine Findfault(x, y, ie) ! input: x, y (projection points) ! output: ie (fault#) use global real x, y, x1, y1, x2, y2, xc, yc, dx, dy real r2min, r2 real tempvec(3) integer(4) ie, i, k1, k2 integer visible r2min = 3.3e+38 do i = 1, NFL k1 = nodef(1, i) tempvec(1) = nodeABG(1, k1) tempvec(2) = nodeABG(2, k1) tempvec(3) = nodeABG(3, k1) call ABG2xy(tempvec, visible, x1, y1) if (visible) then k2 = nodef(2, i) tempvec(1) = nodeABG(1,k2) tempvec(2) = nodeABG(2,k2) tempvec(3) = nodeABG(3,k2) call ABG2xy(tempvec, visible, x2, y2) if (visible) then xc = 0.5 * (x1 + x2) yc = 0.5 * (y1 + y2) dx = x - xc dy = y - yc r2 = dx*dx + dy*dy if (r2 < r2min) then r2min = r2 ie = i end if end if end if end do if (r2min > tolerance * tolerance) ie = 0 end subroutine findfault ! ! Callback routine in "TileGrid" and "BlockSetValue" ! controlled by global variables: ! TileGrid_checked and BlockSetValue_checked ! subroutine FinishPoly(iunit, MouseEvent, iKeystate, xpos, ypos) use dflib use dflogm use Global include 'resource.fd' real tempvec(3), tempv2(3), tempv3(3), tempv4(3) real dot, r2, r2min, da, db, dc real node_val integer iunit, MouseEvent, iKeystate, x, y integer col, row, visible integer(4) i, j, n, n1, n2, n3, s1, ie, je integer(4) m1, m2, m3 integer(4) iret logical OK1, OK2, OK3, beendone logical IsNumber ! logical function character(50) message type(xycoord) xy type(dialog) dlg !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! common /TG/ x0, y0, tempvec, tempv2, tempv4 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! if((MOUSE$KS_RBUTTON.and.iKeystate)== MOUSE$KS_RBUTTON) then if (Npoly < 3) then call beepqq(1000, 40) call setstatusbar(1, " Polygon has to have at least 3 vertices, pick more ..."C) return end if Npoly = Npoly + 1 vertCol(Npoly) = vertCol(1) vertRow(Npoly) = vertRow(1) call cross(tempvec, tempv4, tempv3) Normals(1:3, Npoly) = tempv3(1:3) call pixels(x0, y0, col, row, visible) call moveto(colold, rowold, xy) iret = lineto(col, row) end if !! undraw polygon iret = setcolorRGB(ibackcolor) do i = 1, NPoly-1 call moveto(VertCol(i), VertRow(i), xy) iret = lineto(VertCol(i+1),VertRow(i+1)) end do call moveto(VertCol(NPoly), VertRow(Npoly), xy) iret = lineto(VertCol(1), VertRow(1)) ! iret = SETPIXELRGB(VertCol(1), VertRow(1), ibackcolor) iret = SETPIXELRGB(VertCol(1)+1, VertRow(1), ibackcolor) iret = SETPIXELRGB(VertCol(1)-1, VertRow(1), ibackcolor) iret = SETPIXELRGB(VertCol(1), VertRow(1)+1, ibackcolor) iret = SETPIXELRGB(VertCol(1), VertRow(1)-1, ibackcolor) ! if(TileGrid_checked) then ! Once finish polygon, start create new grid open(729, file='Icosahedron.tmp', status ='old', form ='unformatted') do while(.not.eof(729)) read(729) tempvec(1:3), tempv2(1:3), tempv3(1:3) ! check this element with respect to polygon boundary OK1 = .true. do i=1, Npoly dot = Normals(1,i)*tempvec(1) + Normals(2, i)*tempvec(2) + & Normals(3, i)*tempvec(3) if(dot < 0) OK1=.false. end do OK2 = .true. do i=1, Npoly dot = Normals(1,i)*tempv2(1) + Normals(2, i)*tempv2(2) + & Normals(3,i)*tempv2(3) if(dot < 0) OK2=.false. end do OK3 = .true. do i=1, Npoly dot = Normals(1,i)*tempv3(1) + Normals(2,i)*tempv3(2) + & Normals(3,i)*tempv3(3) if(dot < 0) OK3=.false. end do ! three sides of element are all OK fudge = 0.1 * (6.28318) / (5.0 * 2.0 ** nslice) if(OK1.and.OK2.and.OK3) then ! locate (or create) nodes r2min = 3.e+10 do i=1,NUMNOD da = nodeABG(1,i) - tempvec(1) db = nodeABG(2,i) - tempvec(2) dc = nodeABG(3,i) - tempvec(3) r2 = da*da + db*db + dc*dc if(r2 < r2min) then r2min = r2 n = i end if end do if(sqrt(r2min) < fudge) then n1 = n else ! new node NUMNOD = NUMNOD + 1 if(NUMNOD == MXNODE) then call error14('Node', MXNODE) return end if n1= NUMNOD EQCM(1:6, n1) = 0 nodeABG(1:3, n1)= tempvec(1:3) call drawnode(inodecolor, n1) end if ! 2nd node r2min = 3.e+10 do i = 1, NUMNOD da = nodeABG(1,i) - tempv2(1) db = nodeABG(2,i) - tempv2(2) dc = nodeABG(3,i) - tempv2(3) r2 = da*da + db*db + dc*dc if(r2 0) then m1 = nodes(je, ie) m2 = nodes(mod(je,3)+1, ie) m3 = nodes(mod(je+1,3)+1,ie) if(((m2==n2).and.(m3==n3)).or.((m3==n2).and.(m2==n3))) then beendone = .true. end if if(ie < NUMEL) then s1 = ie + 1 goto 1 end if end if ! ie ! if(NFL > 0) then s1 = 1 3 call OnAnyF(n1, s1, NFL, ie, je) if(ie > 0) then if(nodef(je,ie) /= nodef(5-je,ie)) beendone = .true. if(ie < NFL) then s1 = ie + 1 goto 3 end if end if s1 = 1 5 call OnAnyF(n2, s1, NFL, ie, je) if(ie > 0) then if(nodef(je,ie) /= nodef(5-je,ie)) beendone = .true. if(ie < NFL) then s1 = ie + 1 goto 5 end if end if s1 = 1 7 call OnAnyF(n3, s1, NFL, ie, je) if(ie > 0) then if(nodef(je,ie) /= nodef(5-je, ie)) beendone = .true. if(ie < NFL) then s1 = ie + 1 goto 7 end if end if end if ! NFL if(beendone) then ! do nothing else if(NUMEL == MXEL) then call error14('Element', MXEL) return end if NUMEL = NUMEL + 1 nodes(1, NUMEL) = n1 nodes(2, NUMEL) = n2 nodes(3, NUMEL) = n3 call checkflipped call drawelement(ielecolor, NUMEL) GridLoaded = .true. end if end if ! OK1.and.OK2.and.OK3 end do ! end of file close(729) ! finished tiling the whole region Npoly = 0 iret = setcolorRGB(ifrontcolor) call setstatusbar(1, 'All Done ...'C) ! increment editing counter call IncreaseEditingCounter elseif(eqcmDraw_checked.and.BlockSetValue_checked) then bret = DLGINIT(IDD_SETEQCM, dlg) bret = DLGSETCHAR(dlg, IDC_SETEQCM_EDIT1, 'unknown'C) iret = DlgModal(dlg) if(iret == IDOK) then bret = DLGGETCHAR(dlg, IDC_SETEQCM_EDIT1, message) CALL Repair_String(message) if(.not.IsNumber(message)) then call error7 call Dlguninit(dlg) Npoly = 0 return end if read(message, *) node_val else Npoly = 0 return end if call DlgUninit(dlg) do i = 1, numnod tempv3(1:3) = nodeABG(1:3, i) OK3 = .true. do j = 1, Npoly dot = Normals(1,j)*tempv3(1) + Normals(2,j)*tempv3(2) + & Normals(3,j)*tempv3(3) if(dot < 0) OK3 = .false. end do if(OK3) then EQCM(idata, i) = node_val end if end do ! since it is in block mode, redraw once after all node values are set ! no need to track local nodes, elements, and faults for simplicity ! but need to update contour value and color bar call setbins call colorbar call Redraw Npoly = 0 ! increment editing counter call IncreaseEditingCounter endif end subroutine FinishPoly ! ! CallBack routine for overlaying the earth with global grid ! subroutine Globegrid ! require:nslice (global) ! Modify numnod, numel,nodes use dfwin use dflib use global use Icosahedron logical Exceeded logical OK Exceeded = .false. OK = .false. call ClearHistory call setstatusbar(0,'GlobeGrid'C) call setstatusbar(1,'Overlay the globe with global grid'C) if (.not.(GridLoaded)) then call GTdialog(OK) if(OK) then oldslice = nslice numel = 20*(4**nslice) numnod = numel if (numnod > mxnode) then call error2('node', numnod, mxnode) exceeded = .true. end if if (numel > mxel) then call error2('element',numel, mxel) exceeded = .true. end if if (exceeded) then numnod = 0 numel = 0 return endif ! check if required array has been allocated if (.not.allocated(nodeABG)) allocate(nodeABG(3, mxnode)) if (.not.allocated(nodes)) allocate(nodes(3,mxel)) if (.not.allocated(eqcm)) allocate(eqcm(6,mxnode)) if (.not.allocated(nodef)) allocate(nodef(4,mxfel)) if (.not.allocated(fdip)) allocate(fdip(2,mxfel)) if (.not.allocated(offset)) allocate(offset(mxfel)) if (.not.allocated(EMemo)) allocate(EMemo(mxel)) if (.not.allocated(NMemo)) allocate(NMemo(mxnode)) ! call Make_Global_Grid (nslice, numnod, nodeABG, numel, nodes) call ThreadDlg ! adjust element with reverse vertice order call CheckFlipped GridLoaded = .true. call drawgrid ! modify window title title_string = 'untitled grid'C iunit = getactiveqq() iret = SetWindowText(GetHwndQQ(iunit),title_string) ! increment editing counter call IncreaseEditingCounter end if ! OK else call error3 end if ! update status bar call setstatusbar(0,'Running'C) call setstatusbar(1,' 'C) end subroutine Globegrid ! ! Dialog for global/Tile grid resolution ! subroutine GTdialog(OK) ! return: nslice use dflogm use dflib use dfwin use global include 'resource.fd' logical(4) bret logical OK integer(4) iret type(dialog) dlg integer Maxinput character(512) szbuffer character(10) string Maxinput = 512 ! use string table if string length > 256, which is limit of static text box iret = LoadString( GetModuleHandle(NULL), IDS_String2, & szbuffer, MAXINPUT) bret = dlginit(IDD_GTslice,dlg) bret = DlgSet(dlg,IDC_GT_help1, szbuffer,DLG_title) write(string, '(I5)') oldslice string = trim(ADJUSTL(string)) if(oldslice == 9999) then bret = Dlgset(dlg, IDC_Nslice, ' 'C) else bret = dlgset(dlg,IDC_Nslice, string // CHAR(0)) end if iret = DlgModal(dlg) if (iret == IDOK) then bret = dlggetchar(dlg,IDC_Nslice, string) read(string,*) nslice OK = .true. elseif (iret == IDCANCEL) then OK = .false. end if call DlgUninit(dlg) end subroutine GTdialog ! ! Disable submenu states of main menu ! If no array size is initialized, then all modified submenu are disabled!! ! subroutine GrayedMenu use dflib logical(4) bret ! modify submenu states of EDIT bret = modifymenuflagsqq(2,1,$MENUGRAYED) bret = modifymenuflagsqq(2,3,$MENUGRAYED) bret = modifymenuflagsqq(2,4,$MENUGRAYED) bret = modifymenuflagsqq(2,6,$MENUGRAYED) bret = modifymenuflagsqq(2,7,$MENUGRAYED) bret = modifymenuflagsqq(2,8,$MENUGRAYED) bret = modifymenuflagsqq(2,10,$MENUGRAYED) bret = modifymenuflagsqq(2,11,$MENUGRAYED) ! modify submenu states of TOOLS bret = modifymenuflagsqq(4,1,$MENUGRAYED) bret = modifymenuflagsqq(4,2,$MENUGRAYED) end subroutine GrayedMenu ! ! Detailed help information ! Note: Orbwin_help.htm required! ! subroutine Help use dflib use dfwin implicit none integer(4) iret call setstatusbar(0,'Help'C) call setstatusbar(1,'Display orbwin_help.htm'C) iret = WinExec('Explorer.exe orbwin_help.htm'C,SW_MAXIMIZE) ! update status bar call setstatusbar(0,'Running'C) call setstatusbar(1,' 'C) end subroutine Help ! ! Update editing counter, which monitors # of editing times ! if total # reaches 10, automatically saving current mesh grid information ! in 'BACKUP.FEG' on the hard drive. ! This way hopes to reduce annoying loss of whole grid work suffered by users due to ! undiscovered bugs that cause program crashes during running time! ! subroutine IncreaseEditingCounter use global editingcounter = editingcounter + 1 if (mod(editingcounter, 10) == 0) then call autosave('BACKUP.FEG') editingcounter = 0 call sleepqq(500) endif ! update back of status bar if(ZoomInOut_checked) then call setstatusbar(1,'Move mouse to the desired window center and Click'C) endif if(AddDropNode_checked) then call setstatusbar(1, ' Left click to add, right click to drop node ...'C) endif if(AdjustNode_checked) then !call ClearHistory call setstatusbar(1, 'Adjust node -- left click any node and drag...'C) endif if(AddDeleteElement_checked) then call setstatusbar(1,'Left click 3 nodes to add, Right click center of element to delete, details see help/instructions...'C) endif if(CutHealfault_checked) then call setstatusbar(1, ' Move to element side & Click, Left click: Cut, right click: Heal ...'C) endif if(Finclination_checked) then call setstatusbar(1, 'Adjust the dip (inclination) of a fault, Ctrl + left mouse click for details... 'C) endif if(Fheading_checked) then call setstatusbar(1, 'Adjust the heading(azimuth) of a fault, Ctrl + left mouse click for details... 'C) endif if(eqcmDraw_checked) then !call ClearHistory call setstatusbar(1, ' setting nodal value (left click to set value, Ctrl + Right Click to repeat the last value) 'C) endif if(TileGrid_checked) then ! call ClearHistory msg = 'Now outline a convex polygon counterclockwise with left mouse clicks, & & finishing with the right button.'C call setstatusbar(1, msg) endif end subroutine IncreaseEditingCounter ! ! Modified on March 15, 2005, seperated from Initialization ! Initialize global node, element, fault array size ! and GLOBAL variable GrayMenu ! subroutine InitArraySize use dflib use dflogm use dfwin use global implicit none include 'resource.fd' type (dialog) dlg character(50) string logical(4) bret integer(4) iret integer(4) ierr bret = dlginit(IDD_Initialize,dlg) write(string,'(I6)') mxnode bret = dlgset(dlg,IDC_Initialize_node, TRIM(string) // CHAR(0)) write(string,'(I6)') mxel bret = dlgset(dlg,IDC_Initialize_element,TRIM(string) // CHAR(0)) write(string,'(I6)') mxfel bret = dlgset(dlg,IDC_Initialize_fault, TRIM(string) // CHAR(0)) iret = dlgmodal(dlg) if (iret == IDOK) then bret = dlggetchar(dlg,IDC_Initialize_node, string) CALL Repair_String(string) read(string,*) mxnode bret = dlggetchar(dlg,IDC_Initialize_element, string) read(string,*) mxel bret = dlggetchar(dlg,IDC_Initialize_fault, string) read(string,*) mxfel elseif (iret == IDCANCEL) then mxnode = 0 mxel = 0 mxfel = 0 end if call DlgUninit(dlg) end subroutine InitArraySize ! ! 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 ! subroutine Initialization ! Modify global(mxnode, mxel, mxfel) ! Set switch GrayMenu use dflib use dflogm use dfwin use Global ! module contained in file OrbGlobals.f90 integer(4) i, ierr, j ! ! Obtain array size ! mxnode = 0 mxel = 0 mxfel = 0 call InitArraySize ! ! Allocate global array, set GLOBAL variable GrayMenu ! GrayMenu = .false. if ((mxnode == 0).and.(mxel == 0).and.(mxfel == 0)) then GrayMenu = .true. else ! allocate global array if (mxnode /= 0) then if(.not.allocated(nodeABG)) allocate(nodeABG(3,mxnode),stat = ierr) if(.not.allocated(eqcm)) allocate(eqcm(6,mxnode),stat = ierr) if(.not.allocated(NMemo)) allocate(NMemo(mxnode), stat = ierr) end if if (mxel /= 0) then if(.not.allocated(nodes)) allocate(nodes(3,mxel), stat = ierr) if(.not.allocated(EMemo)) allocate(EMemo(mxel), stat = ierr) end if if (mxfel /= 0) then if(.not.allocated(nodef)) allocate(nodef(4,mxfel), stat = ierr) if(.not.allocated(fdip)) allocate(fdip(2, mxfel), stat = ierr) if(.not.allocated(offset)) allocate(offset(mxfel), stat = ierr) end if end if if (GrayMenu) then call GrayedMenu end if ! ! Set global logical switch ! BaseLoaded = .false. GridLoaded = .false. DoIcon = .true. ShowNodes = .true. AddDropNode_checked = .false. AdjustNode_checked = .false. AddDeleteElement_checked = .false. BlockSetValue_checked = .false. ZoomInOut_checked = .false. Finclination_checked = .false. Fheading_checked = .false. Using2ndOrigin = .false. TileGrid_checked = .false. ViewGap_checked = .false. ! ! initialize transformation matrix ! winlon = 0.0 winlat = 0.0 windowheight = 2.02 call winframe(winlat, winlon, winright, winout, winup) call modeparms call scaler tolerance = windowheight * 9 / SNGL(Hirow) ! ! initialize color table ! !inodecolor = RGB(0,0,255) ! blue <== now replaced by code in OrbWin.f90 !ielecolor = RGB(0, 255, 0) ! green <== now replaced by code in OrbWin.f90 !ifaultcolor = RGB(255, 0, 0) ! red <== now replaced by code in OrbWin.f90 ifaultcolor2 = RGB(255, 255, 0) ! yellow <== now replaced by code in OrbWin.f90 ! ! initialize color contour option ! contour = 0 ColorIn = 0 ! ! initialize grid size index ! oldslice = 9999 ! ! initialize parameter for adjusting node and element etc. ! NItsOn = 0 EItsOn = 0 FItsOn = 0 JIP = 0 ! ! initialize editing counter ! editingcounter = 0 ! ! initialize title line ! title = ' ' ! ! initialize color array DO i = 1, 15 SELECT CASE(i) CASE( 1); Redvalue= 60; Greenvalue= 60; Bluevalue= 60 CASE( 2); Redvalue=121; Greenvalue= 0; Bluevalue=121 CASE( 3); Redvalue=255; Greenvalue= 0; Bluevalue=255 CASE( 4); Redvalue= 0; Greenvalue= 0; Bluevalue=125 CASE( 5); Redvalue= 0; Greenvalue= 0; Bluevalue=255 CASE( 6); Redvalue= 0; Greenvalue=202; Bluevalue=202 CASE( 7); Redvalue= 0; Greenvalue=101; Bluevalue= 0 CASE( 8); Redvalue= 0; Greenvalue=255; Bluevalue= 0 CASE( 9); Redvalue=255; Greenvalue=255; Bluevalue= 0 CASE(10); Redvalue=161; Greenvalue= 80; Bluevalue= 20 CASE(11); Redvalue=255; Greenvalue=165; Bluevalue= 12 CASE(12); Redvalue=255; Greenvalue= 0; Bluevalue= 0 CASE(13); Redvalue=255; Greenvalue=161; Bluevalue=121 CASE(14); Redvalue=210; Greenvalue=210; Bluevalue=210 CASE(15); Redvalue=255; Greenvalue=255; Bluevalue=255 END SELECT 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. colorpick = RGB(RedInt1,GreenInt1,BlueInt1) ! may still have defective high byte, due to undefined byte left by rgb macro! colorarray(i) = IAND(colorpick, Z'00FFFFFF') ! this operation should fix any problem !Following lines are just for confirmation during debugging: Redvalue = MOD (colorarray(i), 256) ! least significant byte Greenvalue = MOD((colorarray(i) / 256), 256) Bluevalue = colorarray(i) / 65536 ! most signignicant byte of the 3 non-zero bytes j = i ! wasted statement; put breakpoint here END DO end subroutine Initialization ! ! Instruction dialog ! subroutine Instructions use dflib use dflogm use dfwin implicit none include 'resource.fd' type(dialog) dlg integer(2) iret logical(4) bret character(200) szAbout integer(4) maxsize character(len=1024) szbuffer maxsize = 1024 ! update status bar call setstatusbar(0,'Instructions'C) call setstatusbar(1,' 'C) iret = LoadString(GetModuleHandle(NULL), IDS_String1, szbuffer, maxsize) bret = DLGINIT(IDD_Instructions, dlg) bret = DlgSet(dlg, IDC_Edit1, szbuffer) iret = DlgModal(dlg) call DlgUninit(dlg) ! update status bar call setstatusbar(0,'Running'C) call setstatusbar(1,' 'C) end subroutine Instructions ! ! check if msg is a valid number, utility funcition ! note: following cases not considered: ++, -- etc. ! logical function IsNumber(msg) character*(*) msg character*1 C1 integer len, i integer icode, numdot, numplus, numminus, numE integer iposition IsNumber = .true. msg=adjustl(msg) len = len_trim(msg) numdot = 0 numplus = 0 numminus = 0 numE = 0 if(len == 0) IsNumber = .false. ! ! identify if input contains character other than '. + - e' ! do i = 1, len C1 = msg(i:i) icode = ichar(C1) if((icode < 48).or.(icode > 57)) then IsNumber = .false. if(icode == 46) then numdot = numdot + 1 ! dot point if(numdot <= 1) IsNumber = .true. end if if(icode == 43) then numplus = numplus + 1 ! plus if(numplus <= 2) IsNumber = .true. end if if(icode == 45) then ! minus numminus = numminus + 1 ! plus if(numminus <= 2) IsNumber = .true. end if if((icode == 69).or.(icode == 101)) then numE = numE + 1 ! e/E if(numE <= 1) IsNumber = .true. end if if(.not.IsNumber) goto 10 end if end do 10 continue ! single +, -, . case if(IsNumber) then if((numdot == 1).and.(len == 1)) IsNumber = .false. if(((numminus == 1).or.(numplus == 1)).and.(len == 1)) IsNumber = .false. end if ! last one has to be digit if(IsNumber) then if((ichar(msg(len:len)) < 48).or.(ichar(msg(len:len)) > 57)) IsNumber = .false. end if ! if the first one is '+' or '-' or '.'sign, 2nd one has to be digit if(msg(1:1) == '+'.or.msg(1:1) == '-'.or.msg(1:1) =='.') then if(len > 1) then if((ichar(msg(2:2)) < 48).or.(ichar(msg(2:2)) > 57)) IsNumber = .false. end if end if ! first one can not be 'e' if((msg(1:1) == 'e').or.(msg(1:1)=='E')) then IsNumber = .false. end if ! in case of following ee+30, +++, ---, or ++-, --+ if((numE >= 2).or.(numplus >= 3).or.(numdot >= 2).or.(numminus >=3).or. & ((numplus + numminus) >= 3)) IsNumber = .false. ! for cases: if two ++, --, or one +, one -, IsNumber is .true. ! then only valid format: +xxx.xxxE+xx, -xxx.xxxE-xx, -xxx.xxxE+xx, +xxx.xxxE-xx. ! i.e., first one must be +/-, then E+/E- if((numminus == 2).or.(numplus == 2).or.((numplus == 1).and.(numminus == 1))) then ! has to begin with '+' or '-' if((msg(1:1) == '+').or.(msg(1:1) == '-')) then if((ichar(msg(2:2)) >= 48).and.(ichar(msg(2:2)) <= 57)) then iposition = index(msg, 'E', back = .true.) if(iposition == 0) then iposition = index(msg, 'e', back=.true.) end if if((iposition /= 0).and.(iposition > 2).and.(len > 4)) then IsNumber = .true. else IsNumber = .false. end if else IsNumber = .false. end if else IsNumber = .false. end if end if end function ! ! Redraw adjacent nodes, elements, faults when mouse move ! subroutine MoveNode(iunit, me, iKeyState, xpos, ypos) ! require: Click use global use dflib integer iunit, me, iKeyState integer xpos, ypos type(xycoord) viewxy integer outside integer(4) nH real xc, yc, tempvec(3) ! draw new position if (click == 1) then call getviewcoord(xpos, ypos, viewxy) ColNew = viewxy%xcoord RowNew = viewxy%ycoord if ((ColNew /= ColOld).or.(RowNew /= RowOld)) then ! draw session do i = 1, FItsOn call drawfault(ibackcolor, Fon(i)) end do do i = 1, EItsOn call drawelement(ibackcolor, Eon(i)) end do call drawnode(ibackcolor, Non(1)) call XandY(ColNew, RowNew, xc,yc) call xy2ABG(xc, yc, outside, tempvec) if (outside) then call beepqq(1000,40) else do i = 1, NItsOn nH = Non(i) nodeABG(1,nH) = tempvec(1) nodeABG(2,nH) = tempvec(2) nodeABG(3,nH) = tempvec(3) end do end if do i = 1, EItsOn call drawelement(ielecolor, Eon(i)) end do do i = 1, FItsOn call drawfault(ifaultcolor, Fon(i)) end do call drawnode(inodecolor, Non(1)) end if ! endif of x1 =/ xold, y1 =/ yold ColOld = ColNew RowOld = RowNew end if end subroutine MoveNode ! ! Perimeter/Area test ! major work is accomplished by ThreadDlg1.f90 ! subroutine PATest ! Require: Nflags, Eside, Fside -- global use dfwin use dflib use global call ClearHistory call setstatusbar(0,'PATest'C) call setstatusbar(1,' Perform Perimeter and Area test...'C) if(GridLoaded) then if(NUMNOD /=0) then if(.not.allocated(Nflags)) allocate(Nflags(2,NUMNOD), stat = ierr) end if if(NUMEL /=0) then if(.not.allocated(Eside)) allocate(Eside(3, NUMEL), stat = ierr) end if if(NFL /=0) then if(.not.allocated(Fside)) allocate(Fside(2,NFL), stat = ierr) end if else call error4 return end if call ThreadDlg1 if(allocated(Nflags)) deallocate(Nflags) if(allocated(Eside)) deallocate(Eside) if(allocated(Fside)) deallocate(Fside) ! update status bar call setstatusbar(0,'Running'C) call setstatusbar(1,' 'C) end subroutine PATest ! ! Callback routine in Fheading: PickFault ! subroutine PickFault(unit, mouseevent, iKeystate, xpos, ypos) ! ColOld, RowOld: global use dfwin use dflib use global implicit none integer unit, mouseevent, iKeystate, xpos, ypos integer(4) ie, n1, n2, n3, n4 integer col, row integer outside, visible real x, y, x1, y1, x2, y2, xc, yc real Headout, Headout1, Headout2, ScreenHead ! fixup : global ! xold, yold: global ! Heading, OldHead: global real atan2f ! function real tempvec(3), tempv2(3), tempv3(3), tempv4(3), tempv5(3) real Edot, Ndot type(xycoord) viewxy if(((MOUSE$KS_LBUTTON.AND.iKeystate)== MOUSE$KS_LBUTTON).OR. & ((MOUSE$KS_RBUTTON.AND.iKeystate)== MOUSE$KS_RBUTTON)) then call getviewcoord(xpos, ypos, viewxy) col = viewxy%xcoord row = viewxy%ycoord Col_MouseClick = col Row_MouseClick = row call XandY(col, row, x, y) call xy2ABG(x, y, outside, tempvec) if(outside) then call beepqq(1000, 40) else call findfault(x, y, ie) if(ie > 0) then ! found a fault center ! CLICK = 1 ! call DrawFault(ifaultcolor2, ie) ! locate midpoint precisely n1 = nodef(1, ie) n2 = nodef(2, ie) n3 = nodef(3, ie) n4 = nodef(4, ie) tempvec(1:3) = 0.5*(nodeABG(1:3, n1) + nodeABG(1:3, n2)) call unitVec(tempvec) call ABG2xy(tempvec, visible, xc, yc) call pixels(xc, yc, ColOld, RowOld, visible) call XandY(ColOld, RowOld, XOld, YOld) ! find initial heading tempv2(1:3) = nodeABG(1:3, n2) - nodeABG(1:3, n1) ! east pointing unit vector tempv3(1) = - tempvec(2) tempv3(2) = tempvec(1) tempv3(3) = 0 call unitVec(tempv3) ! north pointing unit vector call cross(tempvec, tempv3, tempv4) ! use matrix product Edot = tempv2(1)*tempv3(1) + tempv2(2)*tempv3(2) + tempv2(3)*tempv3(3) Ndot = tempv2(1)*tempv4(1) + tempv2(2)*tempv4(2) + tempv2(3)*tempv4(3) oldHead = ATAN2F(Edot, Ndot) ! do some fixup when correcting projected heading to true heading tempv5(1:3) = nodeABG(1:3, n1) call ABG2xy(tempv5, visible, x1, y1) tempv5(1:3) = nodeABG(1:3, n2) call ABG2xy(tempv5, visible, x2, y2) screenHead = 1.570796 - ATAN2F(y2 - y1, x2 - x1) fixup = oldHead - screenHead if(fixup > 6.28318) fixup = fixup - 6.28318 if(fixup < -6.28318) fixup = fixup + 6.28318 ! initialize for display without mouse move ! note: when mousemove, Heading is either changed or remain unchanged Heading = oldHead col11 = colold row11 = rowold call WriteHeading else call beepqq(1000, 40) end if !ie end if ! outside end if ! mouse end subroutine PickFault ! ! Callback routine for TileGrid ! subroutine PickPoint(iunit, MouseEvent, iKeystate, xpos, ypos) ! Npoly, ColOld, RowOld: global ! local named COMMON block used: use dflib use global integer iunit, MouseEvent, iKeyState, xpos, ypos integer col, row integer outside real x, y, x0, y0 real tempvec(3), tempv2(3), tempv3(3), tempv4(3) type(xycoord) viewxy, xy !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! common /TG/ x0, y0, tempvec, tempv2, tempv4 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! if((MOUSE$KS_LBUTTON.and.iKeyState) == MOUSE$KS_LBUTTON) then if(Npoly > Npoly_maxsize) then call error6('Npoly', Npoly_maxsize) return end if ! keep statusbar prompt information msg = 'Now outline a convex polygon counterclockwise with left mouse clicks, & & finishing with the right button.'C call setstatusbar(1, msg) ! set color for line, this may be replaced by SETWRITEMODE($GXOR) iret = SETCOLORRGB(ifrontcolor) ! call getviewcoord(xpos,ypos, viewxy) col = viewxy%xcoord row = viewxy%ycoord call XandY(col, row, x, y) !! tempv2(1:3) = tempvec(1:3) !! call XY2ABG(x, y, outside, tempvec) if(outside) then call beepqq(1000, 40) else Npoly = Npoly + 1 vertcol(Npoly) = col vertrow(Npoly) = row if(Npoly > 1) then call cross(tempv2, tempvec, tempv3) Normals(1:3, Npoly) = tempv3(1:3) end if if(Npoly < 2) then iret = SETPIXELRGB(col, row, ifrontcolor) iret = SETPIXELRGB(col+1, row, ifrontcolor) iret = SETPIXELRGB(col-1, row, ifrontcolor) iret = SETPIXELRGB(col, row+1, ifrontcolor) iret = SETPIXELRGB(col, row-1, ifrontcolor) x0 = x y0 = y tempv4(1:3) = tempvec(1:3) else ! draw line call moveto(ColOld, RowOld, xy) iret = lineto(col, row) end if ColOld = col RowOld = row end if end if end subroutine PickPoint ! ! Display location of specified node # ! subroutine PinpointNode use dflib use dflogm use global implicit none include 'resource.fd' type(dialog) dlg logical(4) bret logical IsNumber integer(4) iret, inode integer colbase, rowbase, boxhalf integer visible real tempvec(3), x, y type(xycoord) xy if(GridLoaded) then ! update status bar call setstatusbar(0,'ShowNode'C) call setstatusbar(1,' Display node location 'C) ! bret = DLGINIT(IDD_ShowNode_dialog, dlg) bret = DlgSet(dlg, IDC_ShowNode_Edit,'1'C) iret = Dlgmodal(dlg) if (iret == IDOK) then bret = dlggetchar(dlg, IDC_ShowNode_edit, msg) CALL Repair_String(msg) if(len_trim(msg) == 0) then return else if(IsNumber(msg)) read(msg, "(I8)") inode end if else call setstatusbar(0,'Ready...'C) call setstatusbar(1,' 'C) return end if if (iret == IDOK) then if(inode > numnod) then call error14('Node', numnod) return else !ShowNodes = .true. !(not necessary because of cross symbol) tempvec(1:3) = nodeABG(1:3, inode) call ABG2lonlat(tempvec, winlon, winlat) call winframe(winlat,winlon, winright, winout, winup) call Scaler if(contour) contour = 0 call redraw call ABG2xy(tempvec, visible, x, y) call pixels(x, y, colbase, rowbase, visible) ! draw plus at node location boxhalf = 10 iret = SETCOLORRGB(ifrontcolor) call moveto(colbase - boxhalf, rowbase, xy) iret = lineto(colbase + boxhalf, rowbase) call moveto(colbase, rowbase - boxhalf, xy) iret = lineto(colbase, rowbase + boxhalf) endif end if else ! no grid in memory call error4 endif ! update status bar call setstatusbar(0,'Running'C) call setstatusbar(1,' 'C) end subroutine PinpointNode ! ! Display location of element # ! subroutine PinpointElement use dflib use dflogm use global implicit none include 'resource.fd' type(dialog) dlg logical(4) bret logical IsNumber integer(4) iret, iele integer visible, colA, rowA, colB, rowB, colC, rowC real tempvec(3), x, y type(xycoord) poly(4) ! update statusbar call setstatusbar(0,'ShowElement'C) call setstatusbar(1,'Display single element by specifying which element 'C) if(GridLoaded) then bret = DLGINIT(IDD_ShowElement_dialog, dlg) bret = DlgSet(dlg, IDC_ShowElement_Edit,'1'C) iret = Dlgmodal(dlg) if (iret == IDOK) then bret = dlggetchar(dlg, IDC_ShowElement_edit, msg) CALL Repair_String(msg) if(len_trim(msg) == 0) then return else if(IsNumber(msg)) read(msg, "(I8)") iele end if else call setstatusbar(0, 'Ready...'C) call setstatusbar(1, ' 'C) return end if call setstatusbar(0,'ShowElement'C) call setstatusbar(1,' display element location 'C) if (iret == IDOK) then if(iele > numel) then call error14('Element', numel) return else ! use first vertice as new center of window tempvec(1:3) = nodeABG(1:3, nodes(1,iele)) call ABG2lonlat(tempvec, winlon, winlat) call winframe(winlat,winlon, winright, winout, winup) call Scaler if(contour) contour = 0 call redraw ! flood the element call ABG2xy(tempvec, visible, x, y) call pixels(x,y, colA, rowA, visible) tempvec(1:3) = nodeABG(1:3, nodes(2,iele)) call ABG2xy(tempvec, visible, x, y) call pixels(x,y, colB, rowB, visible) tempvec(1:3) = nodeABG(1:3, nodes(3,iele)) call ABG2xy(tempvec, visible, x, y) call pixels(x,y, colC, rowC, visible) poly(1)%xcoord = colA poly(1)%ycoord = rowA poly(2)%xcoord = colB poly(2)%ycoord = rowB poly(3)%xcoord = colC poly(3)%ycoord = rowC poly(4)%xcoord = colA poly(4)%ycoord = rowA iret = POLYGON($GFILLINTERIOR, poly, INT2(3)) endif end if else call error4 ! no grid in memory return endif ! GridLoaded or not ! update status bar call setstatusbar(0,'Running'C) call setstatusbar(1,' 'C) end subroutine PinpointElement ! ! Redraw everything using current window configuration ! i.e., scales/unscales, windowheight,R2C etc. ! subroutine Redraw use dflib use dfwin use global integer(4) i,iret !integer contour integer iunit integer dummy,tcol0, trow0, tcol1, trow1, visible external Showxy iunit = getactiveqq() ! reset for 2nd origin option ! in order to associate mouse movement with SUBR Showxy if(Using2ndOrigin) then call setstatusbar(0, ' 'C) call setstatusbar(1, ' 'C) Using2ndOrigin = .false. iret = UNREGISTERMOUSEEVENT(iunit, MOUSE$LBUTTONDOWN) iret = UNREGISTERMOUSEEVENT(iunit, MOUSE$RBUTTONDOWN) iret = UNREGISTERMOUSEEVENT(iunit, MOUSE$MOVE) end if ! clear bogus fault if(CutHealFault_checked) then call DeleteBogusFault end if ! register for mouse move if(Adjustnode_checked .or. Using2ndOrigin) then else iret = REGISTERMOUSEEVENT(iunit, MOUSE$MOVE, Showxy) end if ! draw peripheral circle of earth iret = SETBKCOLORRGB(ibackcolor) iret = SETCOLORRGB(ifrontcolor) call CLEARSCREEN($GCLEARSCREEN) call pixels(-1.0,-1.0, tcol0, trow0, visible) ! upperleft corner call pixels(1.0, 1.0, tcol1, trow1, visible) ! downright corner dummy = ELLIPSE($GBORDER, tcol0, trow0, tcol1, trow1) if (GridLoaded) then ! Modify some switch if(ColorIn) ColorIn = 0 ! no viewing gap ! draw node do i = numnod, 1, -1 call drawnode(inodecolor,i) enddo do i = numel, 1, -1 call drawelement(ielecolor, i) enddo ! draw fault do i = nfl, 1, -1 call drawfault(ifaultcolor,i) enddo if(contour) call colorbar end if if (BaseLoaded) call DrawBase end subroutine redraw ! ! CallBackRoutine: Restore back to default mouse cursor (arrow) ! subroutine RestoreCursor(unit, mouseevent, iKeyState,x,y) use dfwin use dflib implicit none integer(2) unit, mouseevent, iKeyState integer(4) iret, x, y integer(4) cursor, oldcursor ! cursor = LoadCursor(0, IDC_ARROW) ! oldcursor = SetMouseCursor(cursor) end subroutine RestoreCursor ! ! MouseCallBack routine used in subroutine ZoominOut ! subroutine SelectPoint_Zoom(unit,mouseevent,iKeyState,x,y) ! Modify: global(zcol,zrow) use dfwin use dflib use global implicit none integer(2) unit, iKeyState, mouseevent integer(4) iret, x,y integer(4) cursor, oldcursor integer(2) iret1 real(8) xnode1, ynode1 real xc,yc,tempvec(3) integer(2) outside type (xycoord) viewxy type (wxycoord) windxy ! cursor = LoadCursor(0, IDC_SIZEALL) ! oldcursor = SetMouseCursor(cursor) if ((MOUSE$KS_LBUTTON.AND.iKeyState)== MOUSE$KS_LBUTTON) then call GETVIEWCOORD (X,Y, viewxy) ! call GETWINDOWCOORD(viewxy%xcoord,viewxy%ycoord, windxy) xnode1 = viewxy%xcoord ynode1 = viewxy%ycoord iret = SETWRITEMODE($GPSET) zcol = int(xnode1) zrow = int(ynode1) call XandY(zcol,zrow, xc,yc) call xy2ABG(xc,yc,outside, tempvec) if (outside == 1) then call beepqq(1000,40) else call ABG2lonlat(tempvec, winlon, winlat) call winframe(winlat,winlon, winright, winout, winup) call Scaler IF (contour) CALL SetBins ! checking global switch to see if contouring is active !(which would also mean the idata has been defined) call Redraw end if end if end subroutine SelectPoint_Zoom ! ! Callback routine, used in Adjustnode ! subroutine SelectNode(unit, mouseevent, iKeyState, xpos, ypos) ! require: ColOld, RowOld use dflib use global integer unit, mouseevent, iKeyState integer xpos,ypos real xc,yc type(xycoord) viewxy !!!! integer(4) s1, nH integer(4) n, i integer(4) ie, je !integer contour integer outside real tempvec(3) !!!! click = 0 if ((MOUSE$KS_LBUTTON.AND.iKeyState)== MOUSE$KS_LBUTTON) then call GETVIEWCOORD (xpos,ypos, viewxy) ColOld = viewxy%xcoord RowOld = viewxy%ycoord call XandY(ColOld,RowOld, xc,yc) NItsOn = 0 s1 = 1 1 call exists(s1, xc, yc, nH) if (nH > 0) then NItsOn = NItsOn + 1 Non(NItsOn) = nH if (nH <= NUMNOD) then s1 = nH + 1 goto 1 end if end if if (NItsOn > 0) then click = 1 call drawnode(ifaultcolor,Non(1)) EItsOn = 0 FItsOn = 0 do n = 1, NItsOn nH = Non(n) s1 = 1 2 call OnAnyE(nH, s1, NUMEL, ie, je) if (ie > 0) then EItsOn = EItsOn + 1 Eon(EitsOn) = ie if (ie < NUMEL) then s1 = ie + 1 goto 2 end if end if do i = 1, NFL if ((nH == nodef(1,i)).or.(nH == nodef(2,i))) then FItsOn = FItsOn + 1 Fon(FItsOn) = i end if end do ! next i end do ! next n else call beepqq(1000,40) end if end if end subroutine SelectNode ! ! Set Elevation/Heat flow/Crust thickness/Mantle thickness/Density-anomaly/Cooling-curvature ! Left button --> invoke dialog window for setting value ! Ctrl- Right button --> repeat the last value set through Left Button ! subroutine setEQCM(unit, mouseevent, iKeystate, xpos, ypos) ! require: NItsOn, EItsOn, FItsOn, Non ... use dflib use dflogm use global include 'resource.fd' integer unit, mouseevent, iKeyState, xpos, ypos integer Col, Row integer n1, nH, e1, ie, je, f1 real x, y real node_val real maxf, minf type(xycoord) viewxy type(dialog) dlg logical(4) bret logical drawall integer(4) iret character(50) message ! process mouse click drawall = .false. if (((MOUSE$KS_LBUTTON.and.iKeyState) == MOUSE$KS_LBUTTON).OR.& ((MOUSE$KS_RBUTTON.and.iKeyState) == MOUSE$KS_RBUTTON)) then call GETVIEWCOORD (xpos,ypos, viewxy) Col = viewxy%xcoord Row = viewxy%ycoord call XandY(Col,Row, x,y) NItsOn = 0 EItsOn = 0 FItsOn = 0 n1 = 1 1 call exists(n1, x, y, nH) if(nH > 0) then NItsOn = NItsOn + 1 Non(NItsOn) = nH e1 = 1 2 call OnAnyE(nH, e1, NUMEL, ie, je) if(ie > 0) then EItsOn = EItsOn + 1 EOn(EItsOn) = ie if (ie < NUMEL) then e1 = ie + 1 goto 2 end if end if f1 = 1 3 call OnAnyF(nH, f1, NFL, ie, je) if(ie > 0) then FItsOn = FItsOn + 1 FOn(FItsOn) = ie if (ie < NFL) then f1 = ie + 1 goto 3 end if end if if(n1 < NUMNOD) then n1 = nH + 1 goto 1 end if end if if(NItsOn == 0) then call beepqq(1000, 40) else if((MOUSE$KS_LBUTTON.and.iKeyState) == MOUSE$KS_LBUTTON) then ! Left button down write(message, '(F12.4)') EQCM(idata,Non(1)) bret = DLGINIT(IDD_SETEQCM, dlg) bret = DLGSETCHAR(dlg, IDC_SETEQCM_EDIT1, trim(message) // CHAR(0)) iret = DlgModal(dlg) if(iret == IDOK) then bret = DLGGETCHAR(dlg, IDC_SETEQCM_EDIT1, message) CALL Repair_String(message) if(.not.IsNumber(message)) then call error7 call Dlguninit(dlg) return end if read(message, *) node_val last_val = node_val ! check old maximum or minimum value, put before new node value assigned, so ! it works maxf = eqcm(idata, 1) minf = maxf do i = 1, numnod if(eqcm(idata,i) > maxf) maxf = eqcm(idata,i) if(eqcm(idata,i) < minf) minf = eqcm(idata,i) end do do k = 1, NItsOn EQCM(idata, NOn(k)) = node_val end do IF ((idata >= 5).AND.(node_val /= 0.0)) OrbData5 = .TRUE. ! global switch if((node_val > maxf).or.(node_val < minf)) drawall = .true. ! increment editing counter call IncreaseEditingCounter else call DlgUninit(dlg) return end if call DlgUninit(dlg) elseif((MOUSE$KS_CONTROL.and.iKeyState) == MOUSE$KS_CONTROL) then ! Ctrl + right button down if(last_val == 99999.00) then call error12 return end if do k = 1, NItsOn EQCM(idata, NOn(k)) = last_val end do drawall = .false. ! increment editing counter call IncreaseEditingCounter end if ! reassign values to color bands, and refresh color bar if(contour) then call setbins call colorbar end if ! if range ends change, redraw all old contours if(drawall) then call redraw else ! otherwise, plotting only locals to speed up do i = 1, EItsOn call drawelement(ielecolor, Eon(i)) end do do i = 1, FItsOn call drawfault(ifaultcolor, Fon(i)) end do endif end if end if end subroutine setEQCM ! ! Set Fault inclination (dipping), routine used by Finclination ! subroutine SetFinc(unit, mouseevent, iKeystate, xpos, ypos) ! require: JIP (global) use dfwin use dflib use global integer unit, MouseEvent, iKeyState, xpos, ypos integer col, row integer outside integer(4) ie, je integer(4) n1, n2 real x, y real tempvec(3), tempv2(3), tempv3(3) real A1, B1, G1, A2, B2, G2, AC, BC, GC, FA, FB, FG real VA, VB, VG, dot, sense, newdip logical faulted type(xycoord) viewxy if (((MOUSE$KS_LBUTTON.and.iKeyState) == MOUSE$KS_LBUTTON).or. & ((MOUSE$KS_RBUTTON.and.iKeyState) == MOUSE$KS_RBUTTON)) then call GETVIEWCOORD (xpos,ypos, viewxy) Col = viewxy%xcoord Row = viewxy%ycoord call XandY(Col,Row, x,y) call xy2ABG(x, y, outside,tempvec) if (outside) then call beepqq(1000, 40) else if(JIP==1) then call findfault(x, y, ie) if (ie>0) then JIP = 2 n1 = nodef(1,ie) n2 = nodef(2,ie) A1 = nodeABG(1, n1) B1 = nodeABG(2, n1) G1 = nodeABG(3, n1) A2 = nodeABG(1, n2) B2 = nodeABG(2, n2) G2 = nodeABG(3, n2) AC = 0.5*(A1 + A2) BC = 0.5*(B1 + B2) GC = 0.5*(G1 + G2) FA = A2 - AC FB = B2 - BC FG = G2 - GC tempvec(1) = AC tempvec(2) = BC tempvec(3) = GC tempv2(1) = FA tempv2(2) = FB tempv2(3) = FG call cross(tempv2, tempvec, tempv3) call drawfault(ifaultcolor2, ie) call setstatusbar(1,"Click near either end ..."C) else call beepqq(1000, 40) end if return ! necessary elseif(JIP==2) then JIP = 3 VA = tempvec(1) - AC VB = tempvec(2) - BC VG = tempvec(3) - GC dot = FA*VA + FB*VB + FG*VG if (dot > 0) then je = 2 else je = 1 end if call setstatusbar(1,"Click near the other end..."C) else ! JIP ==3 JIP = 1 je = 3 - je VA = tempvec(1) - AC VB = tempvec(2) - BC VG = tempvec(3) - GC call setstatusbar(1,"Click near a midpoint ..."C) end if sense = VA * tempv3(1) + VB* tempv3(2) + VG*tempv3(3) if(((MOUSE$KS_LBUTTON.and.iKeyState) == MOUSE$KS_LBUTTON).and.& ((MOUSE$KS_RBUTTON.and.iKeyState) == MOUSE$KS_RBUTTON)) then newdip = 90.0 elseif((MOUSE$KS_LBUTTON.and.iKeyState) == MOUSE$KS_LBUTTON) then if (sense > 0) then newdip = shallow else newdip = 180 - shallow end if elseif((MOUSE$KS_RBUTTON.and.iKeyState) == MOUSE$KS_RBUTTON) then if (sense > 0) then newdip = steep else newdip = 180 - steep end if end if call drawfault(ibackcolor, ie) fdip(je, ie) = newdip call drawfault(ifaultcolor, ie) ! increment editing counter call IncreaseEditingCounter ! return end if ! outside end if end subroutine SetFinc ! ! my own setstatusbar ! Statusbar has 5 parts, controlled by partID ! SUBROUTINE SetStatusBar(partID, msg2) USE dfwin USE Global IMPLICIT NONE INTEGER, INTENT(IN):: partID INTEGER ist CHARACTER*(*), INTENT(IN):: msg2 ist = SendMessage(hstatus, SB_SETTEXTA, partID, LOC(msg2)) ! Note: hStatus is the status bar handle, located in Global. END SUBROUTINE SetStatusBar ! ! 2nd origin (re)set ! subroutine Set2ndOrigin use dflib integer(4) iret integer iunit logical(4) bret external SetOrigin, ShowOrigin ! Following common blocks used only in SetOrigin and Set2ndOrigin common Ochosen, linedown, col1, row1, col2, row2 linedown = .false. Ochosen = .false. call clearhistory call setstatusbar(0, 'Set2ndOrigin'C) call setstatusbar(1,'Left-Click to define North pole, Right-Click to define prime meridian.'C) iunit = getactiveqq() iret = REGISTERMOUSEEVENT(iunit, MOUSE$LBUTTONDOWN.OR.MOUSE$RBUTTONDOWN, SetOrigin) iret = REGISTERMOUSEEVENT(iunit, MOUSE$MOVE, ShowOrigin) end subroutine Set2ndOrigin ! ! callback routine for Set2ndOrigin ! Note: special use: COMMON BLOCK ! subroutine SetOrigin(unit, mouseevent, iKeystate, xpos, ypos) use dfwin use dflib use global integer unit, mouseevent, iKeystate, xpos, ypos integer col0, row0, col1, row1, col, row integer outside, i, j real xo, yo, xr, yr real tempvec(3), tempv2(3), tempv3(3), tempv4(3) logical Ochosen logical linedown type(xycoord) viewxy type(xycoord) xy common Ochosen, linedown, col1, row1, col2, row2 if((MOUSE$KS_LBUTTON.AND.iKeystate)== MOUSE$KS_LBUTTON) then call getviewcoord(xpos, ypos, viewxy) col0 = viewxy%xcoord row0 = viewxy%ycoord call XandY(Col0, Row0, xo, yo) call xy2ABG(xo, yo, outside, tempvec) if(outside) then call beepqq(1000, 40) else Ochosen = .true. end if elseif((MOUSE$KS_RBUTTON.AND.iKeystate)== MOUSE$KS_RBUTTON) then if(Ochosen) then call getviewcoord(xpos, ypos, viewxy) col = viewxy%xcoord row = viewxy%ycoord call XandY(col, row, xr, yr) if((xr == xo).and.(yr==yo)) then call beepqq(1000, 40) else call xy2ABG(xr, yr, outside, tempv2) call ABG2lonlat(tempv2, lon, lat) if(outside) then call beepqq(1000, 40) else ! if point accepted, execute (1) local part iret = SETWRITEMODE($GXOR) ! Note: linedown, col1, row1, col2, row2 storing in common block if(linedown) then call moveto(col1, row1, xy) iret = lineto(col2, row2) end if call moveto(col0, row0, xy) iret = lineto(col, row) linedown = .true. col1 = col0 row1 = row0 col2 = col row2 = row ! (2) global part cart2(1:3,3) = tempvec(1:3) call cross(tempvec, tempv2, tempv3) call unitVec(tempv3) cart2(1:3,2) = tempv3(1:3) call cross(tempv3, tempvec, tempv4) cart2(1:3,1) = tempv4(1:3) end if end if ! reset Ochosen and Using2ndOrigin Ochosen=.false. Using2ndOrigin = .true. else call beepqq(1000, 40) end if ! Ochosen end if ! set back the default writing mode iret = SETWRITEMODE($GPSET) end subroutine SetOrigin ! ! callback routine for Set2ndOrigin ! subroutine ShowOrigin(unit, me, iKeystate, xpos, ypos) use dflib use dfwin use global implicit none integer unit, me, iKeystate, xpos, ypos integer(4) iret integer(2) outside integer i, j, col, row real xc, yc, tempvec(3), tempv2(3) real lon, lat type(xycoord) viewxy call getviewcoord(xpos,ypos,viewxy) col = viewxy%xcoord row = viewxy%ycoord call XandY(col, row, xc,yc) call xy2ABG(xc,yc,outside, tempvec) if (outside /= 1) then call ABG2lonlat(tempvec, lon,lat) lon = lon*57.2958 lat = lat*57.2958 write(msg, '(" cursor Lon=",F8.3,",Lat=",F7.3)," "C') lon,lat call setstatusbar(2, TRIM(msg) // CHAR(0)) ! 2nd coordinates if(using2ndOrigin) then do i = 1,3 tempv2(i) = 0. do j = 1,3 tempv2(i) = tempv2(i) + tempvec(j)*cart2(j,i) end do end do call ABG2lonlat(TempV2, lon, lat) lon = lon*57.2958 lat = lat*57.2958 write(msg, '(" OR: Lon=",F8.3,",Lat=",F7.3)," "C') lon,lat call setstatusbar(3, TRIM(msg) // CHAR(0)) endif else call setstatusbar(2,' 'C) call setstatusbar(3,' 'C) end if end subroutine ShowOrigin ! ! Set Fault Heading (azimuth) ! subroutine SetFhead(unit, mouseevent, iKeystate, xpos, ypos) ! require: Click, ColOld, RowOld use dfwin use dflib use global implicit none integer unit, mouseevent, iKeyState, xpos, ypos integer col, row type(xycoord) viewxy, xy integer outside integer(2) iret, mode integer(4) nH !integer col1, row1 real xc, yc, tempvec(3) real xp, yp real atan2f ! draw new position if (click == 1) then call getviewcoord(xpos, ypos, viewxy) Col = viewxy%xcoord Row = viewxy%ycoord if ((abs(col - ColOld) > 6).or.(abs(row - RowOld) > 6)) then mode = SETWRITEMODE($GXOR) ! Erase old one call moveto(2*Colold-col11, 2*RowOld - row11, xy) iret = lineto(col11, row11) ! draw new one call moveto(2*ColOld-col, 2*RowOld - row, xy) iret = lineto(col, row) call XandY(col, row, xp, yp) Heading = 1.570796 - atan2f(yp - yold, xp - xold) + fixup col11 = col row11 = row else Heading = oldHead end if call WriteHeading end if end subroutine SetFhead ! ! Set color and other drawing options ! subroutine SetKolor use dflib use dflogm use dfwin use global implicit none include 'resource.fd' type(dialog) dlg logical(4) bret integer(4) iret external SetPlotData ! ! call setstatusbar(0,'SetKolor'C) ! call setstatusbar(1,' 'C) ! bret = DLGINIT(IDD_COLOR, dlg) ! Set choice of objects to draw in list box bret = DlgSet(dlg,IDC_LIST, 6, DLG_NUMITEMS) bret = DlgSet(dlg,IDC_LIST, "Color of Outer Circle"C, 1) bret = DlgSet(dlg,IDC_LIST, "Color of Basemap"C, 2) bret = DlgSet(dlg,IDC_LIST, "Color of Node"C, 3) bret = DlgSet(dlg,IDC_LIST, "Color of Element"C, 4) bret = DlgSet(dlg,IDC_LIST, "Color of Fault"C, 5) bret = DlgSet(dlg,IDC_LIST, "Color of Background"C, 6) ! bret = DlgSet(dlg,IDC_SPIN_Red , 255, DLG_RANGEMAX) bret = DlgSet(dlg,IDC_SPIN_Red , 0, DLG_RANGEMIN) iret = dlgset(dlg,IDC_SPIN_Red , Redvalue ) bret = DlgSet(dlg,IDC_SPIN_Green , 255, DLG_RANGEMAX) bret = DlgSet(dlg,IDC_SPIN_Green , 0, DLG_RANGEMIN) iret = dlgset(dlg,IDC_SPIN_Green , Greenvalue ) bret = DlgSet(dlg,IDC_SPIN_Blue , 255, DLG_RANGEMAX) bret = DlgSet(dlg,IDC_SPIN_Blue , 0, DLG_RANGEMIN) iret = dlgset(dlg,IDC_SPIN_Blue , Bluevalue ) if(DoIcon) then bret = DlgSet(dlg, IDC_Radio_YES, .true.) bret = DlgSet(dlg, IDC_Radio_No, .false.) else bret = DlgSet(dlg, IDC_Radio_YES, .false.) bret = DlgSet(dlg, IDC_Radio_No, .true.) end if if(ShowNodes) then bret = DlgSet(dlg, IDC_Radio_YES_2, .true.) bret = DlgSet(dlg, IDC_Radio_No_2, .false.) else bret = DlgSet(dlg, IDC_Radio_YES_2, .false.) bret = DlgSet(dlg, IDC_Radio_No_2, .true.) end if ! bret = DlgSetSub(dlg,IDC_LIST,SetPlotData) bret = DlgSetSub(dlg,IDC_SPIN_Red ,SetPlotData) bret = DlgSetSub(dlg,IDC_SPIN_Green,SetPlotData) bret = DlgSetSub(dlg,IDC_SPIN_Blue ,SetPlotData) bret = DlgSetSub(dlg,IDC_EDIT_Red,SetPlotData) bret = DlgSetSub(dlg,IDC_EDIT_Green,SetPlotData) bret = DlgSetSub(dlg,IDC_EDIT_Blue,SetPlotData) bret = DlgSetSub(dlg,IDC_RADIO_Yes,SetPlotData) bret = DlgSetSub(dlg,IDC_RADIO_No, SetPlotData) bret = DlgSetSub(dlg,IDC_RADIO_Yes_2,SetPlotData) bret = DlgSetSub(dlg,IDC_RADIO_No_2, SetPlotData) bret = DlgSetSub(dlg,IDC_Draw,SetPlotData) bret = DlgSetSub(dlg,IDOK,SetPlotData) iret = DlgModal(dlg) call DlgUninit(dlg) ! redraw call Redraw end subroutine SetKolor ! ! Dialog callback routine, used in SetKolor ! subroutine SetPlotData(dlg, control_name, callbacktype) use dflib use dflogm use dfwin use global implicit none include 'resource.fd' type(dialog) dlg logical(4) bret integer(4) iret integer(4) ios logical check_state integer control_name, callbacktype character(50) string select case(control_name) case(IDC_LIST) ! get object type bret = DLGGET (dlg,IDC_LIST,string) if (string == 'Color of Outer Circle') then DrawType = 1 else if (string == 'Color of Basemap') then DrawType = 2 else if (string == 'Color of Node') then DrawType = 3 else if (string == 'Color of Element') then DrawType = 4 else if (string == 'Color of Fault') then DrawType = 5 else if (string == 'Color of Background') then DrawType = 6 end if Redvalue = RGB_int_of_IDC_LIST_line(1, DrawType) WRITE (string, "(I3)") Redvalue bret = DlgSet( dlg,IDC_EDIT_Red, TRIM(string) // CHAR(0) ) iret = dlgset(dlg,IDC_SPIN_Red , Redvalue ) Greenvalue = RGB_int_of_IDC_LIST_line(2, DrawType) WRITE (string, "(I3)") Greenvalue bret = DlgSet( dlg,IDC_EDIT_Green, TRIM(string) // CHAR(0) ) iret = dlgset(dlg,IDC_SPIN_Green , Greenvalue ) Bluevalue = RGB_int_of_IDC_LIST_line(3, DrawType) WRITE (string, "(I3)") Bluevalue bret = DlgSet( dlg,IDC_EDIT_Blue, TRIM(string) // CHAR(0) ) iret = dlgset(dlg,IDC_SPIN_Blue , Bluevalue ) case(IDC_RADIO_Yes) DoIcon = .true. case(IDC_RADIO_No) DoIcon = .false. case(IDC_RADIO_Yes_2) ShowNodes = .true. case(IDC_RADIO_No_2) ShowNodes = .false. case(IDC_Draw, IDOK) bret = DlgGet(dlg,IDC_EDIT_Red, string ) if(string == ' ') then string = '0' Redvalue = 0 else ! number has been entered in the box READ (string, *,IOSTAT=ios) Redvalue Redvalue = MAX(0,MIN(Redvalue, 255)) WRITE (string, "(I3)") Redvalue end if bret = DlgSet( dlg,IDC_EDIT_Red, TRIM(string) // CHAR(0) ) iret = DlgSet(dlg,IDC_SPIN_Red , Redvalue ) IF (DrawType > 0) RGB_int_of_IDC_LIST_line(1, DrawType) = Redvalue bret = DlgGet(dlg,IDC_EDIT_Green, string ) if(string == ' ') then string = '0' Greenvalue = 0 else ! number has been entered in the box READ (string, *,IOSTAT=ios) Greenvalue Greenvalue = MAX(0,MIN(Greenvalue, 255)) WRITE (string, "(I3)") Greenvalue end if bret = DlgSet( dlg,IDC_EDIT_Green, TRIM(string) // CHAR(0) ) iret = DlgSet(dlg,IDC_SPIN_Green , Greenvalue ) IF (DrawType > 0) RGB_int_of_IDC_LIST_line(2, DrawType) = Greenvalue bret = DlgGet(dlg,IDC_EDIT_Blue, string ) if(string == ' ') then string = '0' Bluevalue = 0 else ! number has been entered in the box READ (string, *,IOSTAT=ios) Bluevalue Bluevalue = MAX(0,MIN(Bluevalue, 255)) WRITE (string, "(I3)") Bluevalue end if bret = DlgSet( dlg,IDC_EDIT_Blue, TRIM(string) // CHAR(0) ) iret = DlgSet(dlg,IDC_SPIN_Blue , Bluevalue ) IF (DrawType > 0) RGB_int_of_IDC_LIST_line(3, DrawType) = Bluevalue 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 SELECT IF (control_name == IDC_DRAW) CALL Redraw IF (control_name == IDOK) CALL DLGEXIT(dlg) END SUBROUTINE SetPlotData ! ! Display (Lon,Lat) coordinates of mouse cursor ! subroutine Showxy(unit, mouseevent, iKeyState,x,y) use dfwin use dflib use global ! where msg is declared as character(255) implicit none character(9) :: c9lat, c9lon integer(2) unit, mouseevent, iKeyState integer(4) iret, x, y integer ios integer(2) outside real xc, yc, tempvec(3) real lon, lat ! integer numnear integer(4) nearones(4) ! type(xycoord) viewxy SAVE call getviewcoord(x,y,viewxy) call XandY(x,y,xc,yc) call xy2ABG(xc,yc,outside, tempvec) if (outside /= 1) then call ABG2lonlat(tempvec, lon,lat) lon = lon*57.2958 lat = lat*57.2958 !GPBhere: Next line generates abends in ORBWIN!for_write_int_format_xmit, which calls ORBWIN!for__release_lun, ! which then calls ORBWIN!for__release_lun {again? recursively?}, which calls ORBWIN!for__free_vm, ! which finally calls ORBWIN!free, which calls a string of 6 NTDLL!xxxxxx funtions. write(msg, 99, IOSTAT = ios, err = 100) lon,lat 99 FORMAT (" cursor Lon=",F8.3,",Lat=",F7.3) ! So, I have replaced it with two uses of intrinsic function ENCODE and a concatenation: ! ENCODE (9, 101, c9lon, ERR = 100) lon ! ENCODE (9, 101, c9lat, ERR = 100) lat 101 FORMAT(F9.3) ! msg = " cursor Lon = " // c9lon // " Lat = " // c9lat // CHAR(0) ! Unfortunately, I now get abends from ENCODE!!! The path of subsequent calls is similar, but different in detail. CALL Repair_String(msg) ! just for good luck! call setstatusbar(2, TRIM(msg) // CHAR(0)) ! display node information only if grid is loaded if(GridLoaded) then call nearest_(xc, yc, numnear, nearones) write(msg, '(" Nearest nodes: ", I5, " ", I5, " ", I5)') nearones(1), nearones(2), nearones(3) call setstatusbar(3, TRIM(msg) // CHAR(0)) endif else call setstatusbar(2,' 'C) call setstatusbar(3,' 'C) end if ! 100 return end subroutine Showxy ! ! Tile grid over a given polygon region ! subroutine TileGrid ! require: oldslice use dfwin use dflib use global use Icosahedron integer(4) iret, iunit logical(4) bret logical OK external PickPoint, FinishPoly ! Check if array is allocated if(.not.GridLoaded) then call CheckAllocate end if ! iunit = GETACTIVEQQ() call setstatusbar(0,'TileRegionGrid'C) call setstatusbar(1, ' Tile grid over a given polygon region ...'C) TileGrid_checked = .true. !! Note: Npoly here store # of vertices of polygon !! PB script, Npoly stores # of planes. DIFFERENT!!! Npoly = 0 OK = .false. call GTdialog(OK) if(OK) then if(nslice /= oldslice) then call setstatusbar(1, 'Creating working file icosahedron.tmp on disk ...'C) ! creat Icosahedron.tmp file to the hard drive only. No loop call Make_Global_Grid(nslice) oldslice = nslice call sleepqq(1000) end if msg = 'Now outline a convex polygon counterclockwise with left mouse clicks, & &finishing with the right button.'C call setstatusbar(1, msg) ! Register MouseEvent iret = REGISTERMOUSEEVENT(iunit, MOUSE$LBUTTONDOWN, PickPoint) iret = REGISTERMOUSEEVENT(iunit, MOUSE$RBUTTONDOWN, FinishPoly) else call setstatusbar(0, 'Running'C) call setstatusbar(1, ' 'C) end if end subroutine TileGrid ! ! User defined exit function ! subroutine UserExit use dfwin use dflib use global ! only global variable used is IUNITD implicit none logical bret integer(4) iret ! update statusbar infor call setstatusbar(0,'UserExit'C) call setstatusbar(1,' 'C) iret = setexitqq(QWIN$EXITNOPERSIST) iret = messageboxqq('Press OK to Exit'C,'Confirm Exit'C, & MB$OKCANCEL) if(iret == MB$IDOK) then call exit() end if ! update statusbar infor. call setstatusbar(0,'Running'C) call setstatusbar(1,' 'C) end subroutine UserExit ! ! Visual checking gap or overlay in the mesh grid ! subroutine ViewGap use dflib use global integer(4) iret integer iunit external ClickAndView call clearhistory ! update statusbar information call setstatusbar(0, 'ViewGap'C) call setstatusbar(1, 'Viewing gap by continuously changing color pixel...'C) if(Contour) then Contour = 0 call redraw end if if(GridLoaded) then iunit = getactiveqq() iret = REGISTERMOUSEEVENT(iunit, MOUSE$LBUTTONDOWN .OR. MOUSE$RBUTTONDOWN, ClickAndView) ViewGap_checked = .true. else call error4 end if end subroutine ! ! New viewing window position ! subroutine WindowPosition use dflib use dflogm use global implicit none include 'resource.fd' type(dialog) dlg logical(4) bret logical IsNumber integer(4) iret real winlatD, winlonD ! change statusbar infor. call setstatusbar(0,'WindowPosition'C) call setstatusbar(1, 'Set precise window center position ...'C) winlatD = winlat * 57.2958 winlonD = winlon * 57.2958 bret = dlginit(IDD_WindowPosition,dlg) write (msg, '(SP, F8.3)') winlatD bret = dlgsetchar(dlg,IDC_WindowPosition_lat,TRIM(msg) // CHAR(0)) write (msg, '(SP, F8.3)') winlonD bret = dlgsetchar(dlg,IDC_WindowPosition_lon,TRIM(msg) // CHAR(0)) iret = dlgmodal(dlg) if (iret == IDOK) then bret = dlggetchar(dlg, IDC_WindowPosition_lat, msg) ! prevent input in characters instead of numbers, ! which may crash the program!! CALL Repair_String(msg) if(.not.IsNumber(msg)) then call error7 call Dlguninit(dlg) return end if if (len_trim(msg) /= 0) read(msg,*) winlatD bret = dlggetchar(dlg, IDC_WindowPosition_lon, msg) CALL Repair_String(msg) if(.not.IsNumber(msg)) then call error7 call Dlguninit(dlg) return end if if (len_trim(msg) /= 0) read(msg,*) winlonD if ((winlatD > 90.0).or. (winlatD < -90.0)) then call error5("lat") return end if if ((winlonD > 180.0).or.(winlonD < -180.0)) then call error5("lon") return end if winlat = winlatD * 0.017453293 winlon = winlonD * 0.017453293 call winframe(winlat,winlon, winright, winout, winup) call Scaler IF (contour) CALL SetBins ! checking global switch to see if contouring is active !(which would also mean the idata has been defined) call redraw else end if call Dlguninit(dlg) ! update statusbar infor. call setstatusbar(0,'Ready...'C) call setstatusbar(1,' 'C) end subroutine WindowPosition ! ! common portion for routine: PickFault, SetFhead ! subroutine WriteHeading ! Heading: global use dflib use global real Headout, Headout1, Headout2 Headout = 57.2958*Heading if(Headout < 0) Headout = Headout + 360.0 if(HeadOut < 180.) then HeadOut1 = HeadOut HeadOut2 = HeadOut + 180.0 else HeadOut1 = HeadOut - 180.0 HeadOut2 = HeadOut end if write(msg, '(F6.2, "/ ", F6.2, "degrees"), " "C') Headout1, Headout2 call setstatusbar(2, msg) end subroutine WriteHeading ! ! specify new window height and zoom in given point within current plot ! subroutine ZoomInOut ! requires: global(windowheightstring,windowheight,xc,yc) ! SUB: XandY, xy2ABG, SelectPoint_Zoom use dflib use dflogm use dfwin USE Global ! declares windowHeightString as character*(255) implicit none include 'resource.fd' type (dialog) dlg logical(4) bret logical checked logical IsNumber integer ios integer(4) iret,iunit integer(4) keystate,ixpos, iypos integer(4) cursor, oldcursor external SelectPoint_Zoom, Showxy ! clear any check mark call ClearHistory ! iunit = getactiveqq() !if (ZoomInOut_checked) then ! ZoomInOut_checked = .false. ! call setstatusbar(1, "Out of Zoom in & Out"C) ! bret = MODIFYMENUFLAGSQQ(3,2,$MENUUNCHECKED) ! iret = UNREGISTERMOUSEEVENT(iunit, MOUSE$LBUTTONDOWN) ! ! set cursor back to default type ! ! cursor = LoadCursor(0, IDC_ARROW) ! ! oldcursor = SetMouseCursor(cursor) !else ZoomInOut_checked = .true. call setstatusbar(0, 'ZoomInOut'C) call setstatusbar(1, 'Move mouse to the desired window center and Click'C) bret = MODIFYMENUFLAGSQQ(3,2,$MENUCHECKED) bret = DlgInit(IDD_ZoomInOut,dlg) !Note: Both of the following forms sometimes generate Access Violation abends: WHY? !WRITE (windowHeightString, '(F5.3)', IOSTAT = ios, err = 100) windowheight !ENCODE (5, "(F5.3)", windowHeightString) windowheight !CALL Repair_String(windowHeightString) ! just for luck !Completely different method used out of desperation: external WRITE/READ OPEN (UNIT = 73, FILE = "windowHeightString.txt", STATUS = "NEW") WRITE (73, "(F5.3)") windowheight CLOSE (73, DISP = "KEEP") OPEN (UNIT = 73, FILE = "windowHeightString.txt", STATUS = "OLD") READ (73, "(A5)") windowHeightString CLOSE (73, DISP = "DELETE") bret = DlgSet(dlg,IDC_EDIT_windowheight, TRIM(windowHeightString) // CHAR(0)) iret = DlgModal(dlg) bret = DlgGetChar(dlg,IDC_EDIT_windowheight, windowHeightString) CALL Repair_String(windowHeightString) if (LEN_TRIM(windowHeightString) == 0) then else if(IsNumber(windowHeightString)) then read(windowHeightString,*) windowheight else write(windowHeightstring,'(F5.3)', IOSTAT = ios, err = 100) windowheight call error8(windowHeightString) end if end if tolerance = windowheight * 9 / SNGL(Hirow) 100 call DlgUninit(dlg) iret = REGISTERMOUSEEVENT (iunit, MOUSE$LBUTTONDOWN, SelectPoint_Zoom) !endif end subroutine zoominout