! 
! 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                           !! a LOGICAL-valued function
! LRDraw                             !! SetLR
! 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,'Ready'C)
call setstatusbar(1,' 'C)
end subroutine About

!
! Callback routine for adding/deleting element
!
subroutine AddDeleteElement
use dflib
use global
implicit none
logical checked
logical(4) bRet
integer(4) iRet
integer iUnit
external AddElement, DeleteElement, Showxy
iUnit = getactiveqq()
contour = .FALSE.
CALL ClearHistory(.TRUE.) ! includeRedraw?
call CheckAllocate
! clear JIP, Non, Eon, Fon, which are global
call ClearNEFon
AddDeleteElement_checked = .true.
call setstatusbar(0,'AddDeleElement'C)
call setstatusbar(1,'Left-click 3 nodes counterclockwise to Add, Right-click center of element to Delete...'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 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
implicit none
integer(4), intent(in) :: unit, me, xpos, ypos
integer(4), intent(in) :: iKeyState
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
            if (MOD(JIP, 3) == 1) then
                write(msg, '(I4," node has been selected.")') MOD(JIP, 3)
            else
                write(msg, '(I4," nodes have been selected.")') MOD(JIP, 3)
            end if
			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)
                    if (ALLOCATED (element_data)) then
                        ! In Restore3+ editing, fill in (mu_1, switching_time_Ma, mu_2) from values saved during most recent element-deletion:
                        if (appType == 3) element_data(1:3, NUMEL) = deleted_element_data(1:3)
                    end if
                    IF (AppType == 1) THEN ! Shells mode; support v5.0+
                        continuum_LRi(NUMEL) = 0
                    END IF
				    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 dflib
use dfwin
use global
implicit none
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(.TRUE.) ! includeRedraw?
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
implicit none
integer(4), intent(in) :: unit, me, xpos, ypos
integer(4), intent(in) :: iKeyState
integer col, row
real x, y, tempvec(3)
logical 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) 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(.TRUE.) ! includeRedraw?
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 it...'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 for entering Block-set-value mode (for eqcm nodal fields)
!
subroutine BlockSetValue
use dflib
use dfwin
use global
implicit none
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 last value)'C)
    iRet = MODIFYMENUFLAGSQQ(2, 11, $MENUUNCHECKED)
    iUnit = GETACTIVEQQ()
	iRet = REGISTERMOUSEEVENT(iUnit, MOUSE$LBUTTONDOWN.OR.MOUSE$RBUTTONDOWN, SetEQCM)
  end if
else
    call error13
	return
end if ! EQCMDraw_checked
end subroutine BlockSetValue

!
! callback routine for entering Block-set-LR mode (for continuum_LRi = per-element INTEGERS)
!
SUBROUTINE BlockSetLR
use dflib
use dfwin
use global
implicit none
integer(4) iRet, iUnit
logical(4) bRet
external PickPoint, FinishPoly, SetLR
!- - - - - - - - - - - - - - - - - - - 
! Check if array is allocated
if(.not.gridLoaded) then
    call CheckAllocate
end if
! BlockSetLR mode is only legal after you first select Lithospheric Rheology (from Edit menu):
IF (LRDraw_checked) THEN
    IF (.NOT. blockSetLR_checked) THEN
        blockSetLR_checked = .TRUE.
        iUnit = GETACTIVEQQ()
        CALL SetStatusBar(0, "Block Set LR mode"C)
        !! Note: nPoly here store # of vertices of polygon, but...
        !!       in PB's code, nPoly stores # of planes. DIFFERENT!!!
        nPoly = 0
	    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 next to menu item
	    iRet = MODIFYMENUFLAGSQQ(2, 14, $MENUCHECKED)
    ELSE ! blockSetLR_checked; now turn if OFF.
        BlockSetLR_checked = .FALSE.
	    CALL SetStatusBar(0,'SetLR'C)
	    CALL SetStatusBar(1,'Setting element LR integer (Left-click to set value, Ctrl + Right-click to repeat last value)'C)
        iRet = MODIFYMENUFLAGSQQ(2, 14, $MENUUNCHECKED)
        iUnit = GETACTIVEQQ()
	    iRet = REGISTERMOUSEEVENT(iUnit, MOUSE$LBUTTONDOWN.OR.MOUSE$RBUTTONDOWN, SetLR)
    END IF
ELSE
    CALL Error15
END IF ! LRDraw_checked
END SUBROUTINE BlockSetLR

!
! 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
implicit none
integer(4) ierr
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)
    IF (AppType == 1) THEN ! Shells mode; support v5.0+
        IF (.NOT. ALLOCATED(continuum_LRi)) ALLOCATE( continuum_LRi(mxel), stat = ierr)
    ELSE IF (AppType == 3) THEN ! Restore3+ mode; support 3 per-element data:
        IF (.NOT. ALLOCATED(element_data))  ALLOCATE( element_data(3, mxel) )
    END IF
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)
    IF (AppType == 1) THEN ! Shells mode; support v5.0+
        IF (.NOT. ALLOCATED(fault_LRi)) ALLOCATE( fault_LRi(mxfel), stat = ierr)
    END IF
end if
end subroutine CheckAllocate

!
! Clear Basemap Linklist
!
subroutine ClearBase
! requires: LOGICAL variables baseLoaded, gridLoaded in Global
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,'Ready'C)
call setstatusbar(1,' 'C)
end subroutine ClearBase

!
! Clear linklist of basemap
!
subroutine ClearLinkList
use global
implicit none
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 dflib
use dfwin
use dflogm
use global
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 was registered before;
! necessary for showing new status message
iUnit = GetActiveQQ()
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(continuum_LRi)) DEALLOCATE(continuum_LRi)
	   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)
       IF (ALLOCATED(fault_LRi)) DEALLOCATE(fault_LRi)
	   NUMNOD = 0
	   NUMEL = 0
	   NFL = 0
	   if(BaseLoaded) then
	       call ClearBase
	   end if
       GridLoaded = .false.
	   Contour = 0
	   Colorin = 0
	   call CLEARSCREEN($GCLEARSCREEN)
	   CALL ClearHistory(.TRUE.) ! includeRedraw?
	   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
         new_FEG_title_line = "[grid title line]"
	   ! 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,'Ready'C)
  call setstatusbar(1,' 'C)
end subroutine ClearGrid

!
! Clear history of registermouseevent, and/or check-sign(s) in menu.
! It is optional to also redraw the screen contents.
!
SUBROUTINE ClearHistory(includeRedraw)
use dflib
use dfwin
use global
implicit none
LOGICAL, INTENT(IN):: includeRedraw
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)
  end if
end if
if (LRDraw_checked) then
  iRet = UNREGISTERMOUSEEVENT(iUnit, MOUSE$LBUTTONDOWN)
  iRet = UNREGISTERMOUSEEVENT(iUnit, MOUSE$RBUTTONDOWN)
  bRet = MODIFYMENUFLAGSQQ(2, 13, $MENUUNCHECKED)
  bRet = MODIFYMENUFLAGSQQ(2, 14, $MENUUNCHECKED)
  iRet = REGISTERMOUSEEVENT(iUnit, MOUSE$MOVE, Showxy)
  LRDraw_checked = .FALSE.
  if (BlockSetLR_checked) then
       BlockSetLR_checked = .false.
	   bRet = MODIFYMENUFLAGSQQ(2, 14, $MENUUNCHECKED)
  end if
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
contour = .FALSE. ! But, user can turn it on again by checking EQCMDraw or LRDraw
IF (includeRedraw) CALL Redraw()
end subroutine ClearHistory

!
! Clear JIP, Non(1000), Eon(1000), Fon(1000), which are
!       global but used in SUBR AddDeleteElement, AdjustNode
!
subroutine ClearNEFon
use global
implicit none
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 dflib
use dfwin
use global
implicit none
integer(4), intent(in) :: unit, mouseevent, xpos, ypos
integer(4), intent(in) :: iKeyState
integer col, row
integer(4) jj, nH
integer(4) i, iRet, iUnit, j, k
real r2min, 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 (at least, it did in Windows 3.1).
    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 ! The mouse-click landed on an element center.

        NMemo(1:NUMNOD) = 0 ! whole list reset to 0

        nH = nodes(1, jj) ! n1 in this element
        NMemo(nH) = 2 ! designate this node as a coloring (re)start point.
        nH = nodes(2, jj) ! n2 in this element
        NMemo(nH) = 2 ! designate this node as a coloring (re)start point.
        nH = nodes(3, jj) ! n3 in this element
        NMemo(nH) = 2 ! designate this node as a coloring (re)start point.

        EMemo(1:NUMEL) = 1 ! reset whole list to 1

        !Begin indefinite loop, which continues as long as more side-adjacent (and uncolored) elements can be found...
        1		  GotOne = .false. ! (unless/until at least one more element gets colored in the following loop)
        !Try to find another element, with at least one colored side, which has not been colored yet...
        do i = 1, NUMEL
	        if ( ((NMemo(nodes(1, i)) == 2).and.(NMemo(nodes(2, i)) == 2)) .or. &
                &((NMemo(nodes(2, i)) == 2).and.(NMemo(nodes(3, i)) == 2)) .or. &
                &((NMemo(nodes(3, i)) == 2).and.(NMemo(nodes(1, i)) == 2)) ) then
                !At least one of the 3 sides of this element has been colored.
                if (EMemo(i) == 2) then
                    !(do nothing more; the interior of this element is already colored-in)
		        else
			        ! ColorIn has to be set ahead of Call DrawElement
			        ColorIn = 1
			        call DrawElement(ielecolor, i)
			        ! Note that, in DrawElement, EMemo is reset to 1.
			        EMemo(i) = 2 
			        GotOne = .true. ! Note that this will cause the indefinite loop to continue, via a GOTO
			        do k = 1, 3
			            j = nodes(k,i)
			            NMemo(j) = 2
			        end do
		        end if
	        end if
        end do
        if (GotOne) then
	        goto 1
        else ! reset lists, to avoid future confusion
	        NMemo(1:NUMNOD) = 0
	        EMemo(1:NUMEL) = 1
        end if
        ! Special Kludge: restore back for mousemovement callback
        iRet = REGISTERMOUSEEVENT(iUnit, MOUSE$MOVE, Showxy)
    else  ! click was not on any element center
        call beepqq(1000, 40)
    end if
    return
end if
end subroutine ClickAndView

!
! Show ColorBar along with contour map of Elevation/Q/Crust/Mantle
!
subroutine ColorBar
use dflib
use dfwin
use Global
implicit none
character(50) font_selector
integer(4) iRet
integer(2) status
integer F_integer, i, iColor, 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()
font_selector = "h18frb" ! According to manual, argument should be a single text string (Fortran, or C format?).
                         ! Unfortunately, examples given show multiple adjacent strings with no concatenation, like ('t''Arial''h12pvb')!
                         ! I eventually found success by dropping the "Arial" part; perhaps this font is no longer supported?
status = SETFONT(font_selector)
IF (status < 1) THEN ! font selection failed!
    WRITE (0, "(' Font selection failed!')")
END IF
!
! first draw big box with gray background
iColor = RGBTOINTEGER(150, 150, 150)
iRet = SETCOLORRGB(iColor)
yextra = 12
poly(1)%xcoord = 0
poly(1)%ycoord = ystart + yextra
! each character width: 10 pixels; 10: format width > 10
poly(2)%xcoord = xt + 10* 10
poly(2)%ycoord = ystart + yextra
poly(3)%xcoord = xt + 10* 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 ! NOTE that index #1 (gray) is not used in the spectrum
   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 == 0) THEN ! color represents continuum_LRi(element#)
      WRITE (msg,'(F9.2)') F
   ELSE IF (iData == 1) THEN ! eqcm(1, ...)
      WRITE (msg,'(F9.3)') F
   ELSE IF (idata == 2) THEN ! eqcm(2, ...)
      WRITE (msg,'(F8.5)') F
   ELSE IF (idata == 3) THEN ! eqcm(3, ...)
      WRITE (msg,'(F9.1)') F
   ELSE IF (idata == 4) THEN ! eqcm(4, ...)
      WRITE (msg,'(F9.1)') F
   ELSE IF (idata == 5) THEN ! eqcm(5, ...)
      WRITE (msg,'(F9.3)') F
   ELSE IF (idata == 6) THEN ! eqcm(6, ...)
      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
	  go to 1
   end if
end do
end subroutine ColorBar


!
! Cut or healing a fault
!
subroutine CutHealFault
use dflib
use dfwin
use global
implicit none
logical checked
logical(4) bRet
integer(4) iRet, iUnit
external CutHealFlt, Showxy
if(AppType == 1) then ! thin-shell type
   iUnit = getactiveqq()
   CALL ClearHistory(.TRUE.) ! includeRedraw?
   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,' Click center(s) of element side(s): 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
implicit none
integer(4), intent(in) :: unit, MouseEvent, xpos, ypos
integer(4), intent(in) :: iKeyState
integer col, row
logical 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 r2min, 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
               fault_LRi(NFL) = 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
implicit none
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) go to 1
end if
end subroutine DeleteBogusFault

!
! Routine for deleting element
!
subroutine DeleteElement(unit, me, iKeyState, xpos, ypos)
use dfwin
use dflib
use global
implicit none
integer(4), intent(in) :: unit, me, xpos, ypos
integer(4), intent(in) :: iKeyState
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
              if (appType == 3) then ! save element data (to be copied into next-created element):
                  deleted_element_data(1:3) = element_data(1:3, jj)
              end if
			  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
                 if (appType == 3) then ! also re-place per-element data:
                     if (ALLOCATED(element_data)) THEN
				         do k = 1, 3
                            element_data(k, i) = element_data(k, (i + 1))
				         end do
                     end if
                 end if
                 IF (AppType == 1) then ! Shells mode; support v5.0+
                     IF (ALLOCATED(continuum_LRi)) THEN
                         continuum_LRi(i) = continuum_LRi(i + 1)
                     END IF
                 END IF
			  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;
!
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 exceeded, 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'
logical, intent(out) :: OK
type(dialog) dlg
logical(4) bRet
logical IsNumber
integer(4) iRet, top_idata
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 (AppType == 1) THEN ! Shells .FEG structure
             top_idata = 6
         ELSE ! (for now, also allow 6 fields in Restore and NeoKinema grids; at least, Restore4 FEGs may use 4 (EQCM) fields.
             top_idata = 6
         END IF
		 if ((idata >= 1).and.(idata <= top_idata)) then
		      contour = 1 ! .TRUE.
         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
   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 drawing Grid and Basemap at initial planet-sized windowheight = 2.02
!
subroutine DrawGrid
use dflib
use global
implicit none
integer dummy,tcol0, trow0, tcol1, trow1
integer(2) dummy2, tcol02, trow02, tcol12, trow12
integer(4) i, iRet
integer iUnit
logical 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(.TRUE.) ! includeRedraw?

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)
!
! prepare for possibility that neither .feg nor .dig is loaded:
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
tcol02 = tcol0; trow02 = trow0; tcol12 = tcol1; trow12 = trow1 ! INT(2) arguments
dummy2 = ELLIPSE($GBORDER, tcol02, trow02, tcol12, trow12)
! after feg successfully loaded
if (gridLoaded) then
  call SetStatusBar(1,'Overview of the .FEG file...'C)
  windowHeight = 2.02
  tolerance = windowHeight * 9 / SNGL(hiRow)
  call ABG2lonlat(nettempvec, winLon, winLat)
  call WinFrame(winLat, winLon, winRight, winOut, winUp)
  call Scaler
  ! if a basemap is also 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 any 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) then ! (but no .feg loaded yet)
  call SetStatusBar(1,'Overview of the .DIG file...'C)
  windowHeight = 2.02
  tolerance = windowHeight * 12 / SNGL(hiRow)
  call ABG2lonlat(nettempvec, winLon, winLat)
  call WinFrame(winLat, winLon, winRight, winOut, winUp)
  call Scaler
  call DrawBase
end if
end subroutine DrawGrid

!
! Eliminate  fault# ie from memory and image
!
subroutine DropFault(ie)
use Global
implicit none
integer(4), intent(in) :: 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)
   fault_LRi(i) = fault_LRi(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
implicit none
integer(4), intent(in) :: unit, me, xpos, ypos
integer(4), intent(in) :: iKeyState
integer col, row
integer(4) nH, k, ie, je
integer(4) i, n
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
implicit none
integer(4), intent(in) :: aka, n
integer(4) i, k
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
implicit none
integer(4), intent(in) :: unit, mouseevent, xpos, ypos
integer(4), intent(in) :: iKeyState
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
implicit none
integer(4), intent(in) :: unit, mouseevent, xpos, ypos
integer(4), intent(in) :: iKeyState
integer(4) i, k, m, n1, n2, n3, n4, s1
integer(4) ie, je
integer(2) col11_2, iret_2, row11_2
logical gotit
real(4) change, r, x, y
real(4) 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)
   col11_2 = col11; row11_2 = row11 ! INT(2) arguments required
   iret_2 = lineto(col11_2, row11_2)
   ! restore writing mode
   iret_2 = 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 dflib
use dfwin
use global
implicit none
logical(4) bRet
logical OK
integer(4) iRet, iUnit
external SetEQCM, ShowXY
iUnit = GETACTIVEQQ()
IF (eqcmDraw_checked) THEN ! It's ALREADY on; so, turn it off!
	eqcmDraw_checked = .FALSE.
	bRet = MODIFYMENUFLAGSQQ(2, 10, $MENUUNCHECKED)
    !Also be sure "child" command BlockSetValue is also turned off:
    BlockSetValue_checked = .FALSE.
	bRet = MODIFYMENUFLAGSQQ(2, 11, $MENUUNCHECKED)
    !general clean-up:
	CALL SetStatusBar(0, 'ShowXY'C)
	CALL SetStatusBar(1, 'Done setting nodal values...'C)
    iRet = REGISTERMOUSEEVENT(iUnit, MOUSE$LBUTTONDOWN.OR.MOUSE$RBUTTONDOWN, ShowXY)
    contour = .FALSE.
    CALL Redraw
ELSE ! Turn it on!
    ! initialize global variable "last_value", which is used in SetEQCM dialog:
	eqcmDraw_checked = .TRUE.
    BlockSetValue_checked = .FALSE. ! (initially, ...)
	CALL SetStatusBar(0, 'EQCMset'C)
	CALL SetStatusBar(1, 'Setting nodal value (Left-click to set value, Ctrl + Right-click to repeat last value)'C)
	bRet = MODIFYMENUFLAGSQQ(2, 10, $MENUCHECKED)
	bRet = MODIFYMENUFLAGSQQ(2, 11, $MENUUNCHECKED) ! (initially, ...)
    contour = .TRUE.
	last_val = 99999.00
	CALL DlgEQCM(OK)
	IF (OK) THEN
        iRet = REGISTERMOUSEEVENT(iUnit, MOUSE$LBUTTONDOWN.OR.MOUSE$RBUTTONDOWN, SetEQCM)
    ELSE
        CALL ClearHistory(.TRUE.) ! includeRedraw?
	    EQCMDraw_checked = .FALSE.
		CALL SetStatusBar(0, 'Ready'C)
	    CALL SetStatusBar(1, ' 'C)
	    bRet = MODIFYMENUFLAGSQQ(2, 10, $MENUUNCHECKED)	    
        iRet = REGISTERMOUSEEVENT(iUnit, MOUSE$LBUTTONDOWN.OR.MOUSE$RBUTTONDOWN, ShowXY)
	END IF
END IF
END SUBROUTINE EQCMDraw

!
! Fault heading(azimuth)
!
subroutine FHeading
use dflib
use dfwin
use global
implicit none
logical checked
logical(4) bRet
integer(4) iRet, iUnit
external PickFault, SetFhead, EndSetFhead
iUnit = getactiveqq()
CALL ClearHistory(.TRUE.) ! includeRedraw?
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,'To adjust the heading (azimuth) of a fault, Left-click on its center and drag; release.'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)
!    calls DlgFinc
!
subroutine FInclination
use dflib
use dfwin
use global
implicit none
logical(4) bRet
integer(4) iRet, iUnit
integer checked
external SetFinc, Showxy
iUnit = getactiveqq()
CALL ClearHistory(.TRUE.) ! includeRedraw?
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, intent(in) :: x, y
integer(4), intent(out) :: iebase, n1, n2
real, intent(out) :: r2min
real r2, x1,y1, x2,y2, xc,yc, dx,dy
real tempv2(3), tempv3(3)
integer(4) i
integer j, j1, k1, j2, k2
logical 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 and 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
implicit none
real, intent(in) :: x, y
integer(4), intent(out) :: ie
real x1, y1, x2, y2, xc, yc, dx, dy
real r2min, r2
real tempvec(3)
integer(4) i, k1, k2
logical 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" and "BlockSetLR"
!  controlled by global variables: 
!                TileGrid_checked and BlockSetValue_checked and BlockSetLR_checked (?)
!
subroutine FinishPoly(iUnit, MouseEvent, iKeystate, xpos, ypos)
use dflib
use dflogm
use Global
implicit none
include 'resource.fd'
integer(4), intent(in) :: iUnit, MouseEvent, xpos, ypos
integer(4), intent(in) :: iKeyState
real tempvec(3), tempv2(3), tempv3(3), tempv4(3)
real dot, fudge, r2, r2min, da, db, dc, x, y
real node_val
real x0, y0
integer col, row
integer(4) i, j, LRi, n, n1, n2, n3, s1, ie, je
integer(4) m1, m2, m3
integer(4) iRet
integer(2) arg1_2, arg2_2, col_2, iret_2, row_2
logical bRet, OK1, OK2, OK3, beendone, visible
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)
     col_2 = col; row_2 = row ! INT(2) arguments required
	 iret_2 = lineto(col_2, row_2)
end if
!! undraw polygon
iRet = setcolorRGB(ibackcolor)
do i = 1, NPoly-1
   call moveto(VertCol(i), VertRow(i), xy)
   arg1_2 = VertCol(i+1); arg2_2 = VertRow(i+1) ! required INT(2) arguments
   iret_2 = lineto(arg1_2, arg2_2)
end do
call moveto(VertCol(NPoly), VertRow(Npoly), xy)
arg1_2 = VertCol(1); arg2_2 = VertRow(1) ! required INT(2) arguments
iret_2 = lineto(arg1_2, arg2_2)
!
arg1_2 = VertCol(1); arg2_2 = VertRow(1) ! required INT(2) arguments
iRet = SETPIXELRGB(arg1_2, arg2_2, ibackcolor)
arg1_2 = VertCol(1)+1; arg2_2 = VertRow(1) ! required INT(2) arguments
iRet = SETPIXELRGB(arg1_2, arg2_2, ibackcolor)
arg1_2 = VertCol(1)-1; arg2_2 = VertRow(1) ! required INT(2) arguments
iRet = SETPIXELRGB(arg1_2, arg2_2, ibackcolor)
arg1_2 = VertCol(1); arg2_2 = VertRow(1)+1 ! required INT(2) arguments
iRet = SETPIXELRGB(arg1_2, arg2_2, ibackcolor)
arg1_2 = VertCol(1); arg2_2 = VertRow(1)-1 ! required INT(2) arguments
iRet = SETPIXELRGB(arg1_2, arg2_2, ibackcolor)
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
IF (TileGrid_checked) THEN
    ! Once user finishes defining the polygon, start creating 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<r2min) then
	    	       r2min = r2
		    	   n = i
		       end if
    		end do
	    	if(sqrt(r2min)<fudge) then
		        n2 = n   
		    else
		        ! new node
                NUMNOD = NUMNOD + 1
    			if(NUMNOD == MXNODE) then
	    		    call error14('Node', MXNODE)
		    		return
                end if
    			n2 = NUMNOD
	    		EQCM(1:6, n2) = 0
		    	nodeABG(1:3, n2) = tempv2(1:3)
			    call drawnode(inodecolor, n2)
    		end if
	    	! 3rd node
		    r2min = 3.e+10
    		do i=1, NUMNOD
	    	    da = nodeABG(1,i) - tempv3(1)
		    	db = nodeABG(2,i) - tempv3(2)
			    dc = nodeABG(3,i) - tempv3(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
    		    n3 = n
	    	else
		        NUMNOD = NUMNOD + 1
			    if(NUMNOD == MXNODE) then
			         call error14('Node', MXNODE)
    				 return
	    		end if
		    	n3 = NUMNOD
			    EQCM(1:6, n3) = 0
			    nodeABG(1:3, n3) = tempv3(1:3)
    			call drawnode(inodecolor, n3)
	    	end if
		    ! check if this element does not already exist
    		! and that it won't use non-unique fault nodes
            beendone = .false.
		    s1 = 1
    1		call OnAnyE(n1, s1, 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==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
               IF (AppType == 1) THEN ! Shells mode; support v5.0+
                   continuum_LRi(NUMEL) = 0
               ELSE IF (AppType == 3) THEN ! Restore3+ mode; provide initial definition of mu_ as 0.0D0:
!GPBhere
                   element_data(1:3, NUMEL) = 0.0D0
               END IF
		       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
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
ELSE IF (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
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
ELSE IF (LRDraw_checked.AND.BlockSetLR_checked) THEN
    bRet = DLGINIT(IDD_SETLR, dlg)
    bRet = DLGSETCHAR(dlg, IDC_SETLR_EDIT1, 'unknown'C)
    iRet = DlgModal(dlg)
    IF (iRet == IDOK) THEN
        bRet = DLGGETCHAR(dlg, IDC_SETLR_EDIT1, message)
        CALL Repair_String(message)
		IF (.NOT.IsNumber(message)) THEN
			CALL Error7
			CALL DlgUnInit(dlg)
			nPoly = 0
			RETURN
        END IF
        READ (message, *) LRi
    ELSE
		nPoly = 0
		RETURN
    END IF
    CALL DlgUnInit(dlg)
	DO i = 1, numEl
        n1 = nodes(1, i)
        n2 = nodes(2, i)
        n3 = nodes(3, i)
        tempv3(1) = (nodeABG(1, n1) + nodeABG(1, n2) + nodeABG(1, n3)) / 3.0
        tempv3(2) = (nodeABG(2, n1) + nodeABG(2, n2) + nodeABG(2, n3)) / 3.0
        tempv3(3) = (nodeABG(3, n1) + nodeABG(3, n2) + nodeABG(3, n3)) / 3.0
	    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
	        continuum_LRi(i) = LRi
	    END IF
    END DO ! i = 1, numEl
	DO i = 1, nFl
        n1 = nodeF(1, i)
        n2 = nodeF(2, i)
        tempv3(1) = (nodeABG(1, n1) + nodeABG(1, n2)) / 2.0
        tempv3(2) = (nodeABG(2, n1) + nodeABG(2, n2)) / 2.0
        tempv3(3) = (nodeABG(3, n1) + nodeABG(3, n2)) / 2.0
	    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
	        fault_LRi(i) = LRi
	    END IF
    END DO ! i = 1, nFl
	! Since it is in block-mode, redraw ONCE after all element LR# integers are set.
	CALL SetBinsLR
	CALL Redraw
	nPoly = 0 ! forget about each polygon as soon as it is used.
	! increment editing counter
	CALL IncreaseEditingCounter
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
END IF
END SUBROUTINE FinishPoly

!
! CallBack routine for overlaying the earth with global grid
!
subroutine GlobeGrid
! require:nslice (global)
! Modify numnod, numel,nodes
use dflib
use dfwin
use Global
use Icosahedron
implicit none
integer iRet, iUnit
logical Exceeded
logical OK
Exceeded = .false.
OK = .false.
CALL ClearHistory(.FALSE.) ! includeRedraw?  NO; wastes time, because planet is empty at this point.  (GlobeGrid not allowed if grid present.)
call setstatusbar(0, 'GlobeGrid'C)
call setstatusbar(1, 'Overlay the planet with a 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 that required arrays have been allocated:
     if (.not.allocated(nodeABG)) allocate(nodeABG(3, mxnode))
     if (.not.allocated(eqcm)) allocate(eqcm(6,mxnode))
     if (.not.allocated(NMemo)) allocate(NMemo(mxnode))
     if (.not.allocated(nodes)) allocate(nodes(3,mxel))
     if (.not.allocated(EMemo)) allocate(EMemo(mxel))
     IF (AppType == 1) THEN ! Shells mode; support v5.0+
         IF (.NOT. ALLOCATED(continuum_LRi)) ALLOCATE ( continuum_LRi(mxel) )
     END IF
     if (.not.allocated(nodef)) allocate(nodef(4,mxfel))
     if (.not.allocated(fdip)) allocate(fdip(2,mxfel))
     if (.not.allocated(offset)) allocate(offset(mxfel))
     IF (AppType == 1) THEN ! Shells mode; support v5.0+
         IF (.NOT. ALLOCATED(fault_LRi)) ALLOCATE ( fault_LRi(mxfel) )
     END IF
     !
     call PlanetaryGrid ! which does all the hard work!
     !
     ! adjust any elements with reversed order of vertices!
     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,'Ready'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
implicit none
include 'resource.fd'
logical, intent(out) :: OK
logical(4) bRet
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 inapplicable menu commands
! (in the case that no array-sizes were initialized)
!
SUBROUTINE GrayedMenu
use dflib
implicit none
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)
bRet = modifymenuflagsqq(2, 13, $MENUGRAYED)
bRet = modifymenuflagsqq(2, 14, $MENUGRAYED)
! modify submenu states of TOOLS
bRet = modifymenuflagsqq(4,  1, $MENUGRAYED)
bRet = modifymenuflagsqq(4,  2, $MENUGRAYED)
END SUBROUTINE GrayedMenu
!
! Disable inapplicable menu commands
! (in the case that no array-sizes were initialized)
!
SUBROUTINE GrayedLRMenu
use dflib
implicit none
logical(4) bRet
! modify submenu states of EDIT 
bRet = modifymenuflagsqq(2, 13, $MENUGRAYED)
bRet = modifymenuflagsqq(2, 14, $MENUGRAYED)
END SUBROUTINE GrayedLRMenu

!
! Detailed help information
! Note: Orbwin_help.htm required!
!
subroutine Help  ! (now appearing in drop-down menu as "Manual" under top-level menu item "Help")
use dflib
use dfwin
implicit none
integer(4) iRet
call setstatusbar(0,'Manual'C)
call setstatusbar(1,'Display OrbWin_manual.pdf'C)
iRet = WinExec('Explorer.exe http://peterbird.name/oldFTP/OrbWin/OrbWin_manual.pdf'C,SW_MAXIMIZE)
IF (iRet <= 31) THEN ! previous invocation of the Edge/Internet Explorer browser did not succeed; try Chrome...
    iRet = WinExec('Chrome.exe http://peterbird.name/oldFTP/OrbWin/OrbWin_manual.pdf'C,SW_MAXIMIZE)
END IF
! update status bar
call setstatusbar(0,'Ready'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, we hope to reduce annoying losses of extensive grid-editing work due to 
! any undiscovered bugs that might cause program crashes during running time!
!
subroutine IncreaseEditingCounter
use global
implicit none
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(.TRUE.) ! includeRedraw?
  call setstatusbar(1, 'Adjust node: Left-click any node and drag it...'C)
endif
if(AddDeleteElement_checked) then
  call setstatusbar(1,'Left-click 3 nodes counterclockwise to Add, Right-click center of element to Delete...'C) 
endif
if(CutHealfault_checked) then
  call setstatusbar(1, ' Click center(s) of element side(s): Left-click = Cut; Right-click = Heal ...'C)
endif
if(Finclination_checked) then
  call setstatusbar(1, 'To adjust the dip (inclination) of a fault: Left-click on its center ... 'C) 
endif
if(Fheading_checked) then
  call setstatusbar(1, 'To adjust the heading (azimuth) of a fault, Left-click on its center and drag; release.'C)
endif
if(EQCMDraw_checked) then
  !CALL ClearHistory(.TRUE.) ! includeRedraw?
  call setstatusbar(1, 'Setting nodal value (Left-click to set value, Ctrl + Right-click to repeat last value)'C)
endif
if(TileGrid_checked) then
  ! CALL ClearHistory(.TRUE.) ! includeRedraw?
	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: separated 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,'(I10)') mxnode
bRet = DlgSet(dlg,IDC_Initialize_node, TRIM(string) // CHAR(0))
write(string,'(I10)') mxel
bRet = DlgSet(dlg,IDC_Initialize_element,TRIM(string) // CHAR(0))
write(string,'(I10)') 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, mxel, mxfel are not changed, and remain at the hard-coded suggested values
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 variables in MODULE Global: (mxnode, mxel, mxfel), and
! Set Global logical switches grayMenu & grayLRMenu.
use dflib
use dflogm
use dfwin
use Global ! module contained in file Global.f90
implicit none
integer(4) i, ierr, j
!
! Obtain array sizes
!
! Values suggested to the user:
mxnode = 1500000       ! 1.5M nodes and elements allows for nslice <= 8, with room for local editing 
mxel   = 1500000       ! Using these suggestions, memory usage of OrbWin will be no more than: 1.6 MB (base .EXE) + 82 MB (grid arrays) = 84 MB.
                       ! Such memory usage would have been impossible under DOS or Windows 3.1, but is no problem today (even for small 32-bit Windows systems).
IF (AppType == 1) THEN ! referring to previous dialog, and INTEGER stored in MODULE Global.
    mxfel = 50000
ELSE
    mxfel = 0 ! No faults allowed in NeoKinema or Restore-type .FEG files.
END IF
call InitArraySize
!
! Allocate global arrays, or set Global variable GrayMenu:
GrayMenu = ((mxNode == 0).AND.(mxEl == 0).AND.(mxFEl == 0))
IF (.NOT.GrayMenu) THEN ! allocate global arrays
   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)
      IF (AppType == 1) THEN ! Shells mode; support v5.0+
          IF (.NOT. ALLOCATED(continuum_LRi)) ALLOCATE ( continuum_LRi(mxel), stat = ierr )
      END IF
   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)
      IF (AppType == 1) THEN ! Shells mode; support v5.0+
          IF (.NOT. ALLOCATED(fault_LRi)) ALLOCATE ( fault_LRi(mxfel), stat = ierr )
      END IF
   end if
END IF
IF (GrayMenu) THEN
   CALL GrayedMenu
END IF
!
! Prevent attempts to set Lithospheric Rheology indeces (LR#s) if appType /= 1 (i.e., /= "Shells")
!
grayLRMenu = (appType.NE.1)
IF (grayLRMenu) THEN
    CALL GrayedLRMenu
END IF
!
! Set other Global logical switches
!
BaseLoaded = .false.
GridLoaded = .false.
DoIcon = .true.
ShowNodes = .true.
AddDropNode_checked = .false.
AdjustNode_checked = .false.
AddDeleteElement_checked = .false.
BlockSetValue_checked = .false.
BlockSetLR_checked = .false.
Finclination_checked = .false.
Fheading_checked = .false.
Using2ndOrigin = .false.
TileGrid_checked = .false.
ViewGap_checked = .false.
!
! initialize transformation matrix
!
winlon = 0.0 ! center at 0 degrees East
winlat = 0.0 ! center at 0 degrees North
windowheight = 2.02 ! radii, or slightly more than one diameter of the planet
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 ! .FALSE.
ColorIn = 0 ! .FALSE.
!
! 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
!
  old_FEG_title_line = ' '
!
! 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 to debug
END DO
end subroutine Initialization

!
! Instruction dialog
!
subroutine Instructions ! (now appearing in menu and status-bar as "Hints")
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,'Hints'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,'Ready'C)
call setstatusbar(1,' 'C)
end subroutine Instructions

!
! Utility function: Check whether msg is a valid number?
! Note: following cases not considered: ++, -- etc.
!
logical function IsNumber(msg)
implicit none
character*(*), intent(in) :: msg
character*132 msg2
character*1 C1
integer len, i
integer icode, numdot, numplus, numminus, numE
integer iposition
IsNumber = .true. ! unless ...
msg2 = adjustl(msg)
len = len_trim(msg2)
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 = msg2(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(msg2(len:len)) < 48).or.(ichar(msg2(len:len)) > 57)) IsNumber = .false.
end if
! if the first one is '+' or '-' or '.'sign, 2nd one has to be digit
if(msg2(1:1) == '+'.or.msg2(1:1) == '-'.or.msg2(1:1) =='.') then
   if(len > 1) then
      if((ichar(msg2(2:2)) < 48).or.(ichar(msg2(2:2)) > 57)) IsNumber = .false. 
   end if   
end if
! first one can not be 'e'
if((msg2(1:1) == 'e').or.(msg2(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((msg2(1:1) == '+').or.(msg2(1:1) == '-')) then
          if((ichar(msg2(2:2)) >= 48).and.(ichar(msg2(2:2)) <= 57)) then
		      iposition = index(msg2, 'E', back = .true.)
			  if(iposition == 0) then
			     iposition = index(msg2, '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 IsNumber

!
! Show/Edit per-element Lithospheric Rheology indeces (LR#s):
!
SUBROUTINE LRDraw
USE dflib
USE dfwin
USE Global
IMPLICIT NONE
LOGICAL(4) bRet
LOGICAL OK
INTEGER(4) iRet, iUnit, LRi
EXTERNAL SetLR, ShowXY
!- - - - - - - - - - - - -
iUnit = GETACTIVEQQ()
IF (LRDraw_checked) THEN ! just turn it off!
    LRDraw_checked = .FALSE.
    bRet = MODIFYMENUFLAGSQQ(2, 13, $MENUUNCHECKED)
    contour = .FALSE. ! cancel the current coloring-in of continuum triangular elements.
    !Also, be sure that "child" command BlockSetLR is also turned off:
    BlockSetLR_checked = .FALSE.
    iRet = MODIFYMENUFLAGSQQ(2, 14, $MENUUNCHECKED)
    !clean-up:
	CALL SetStatusBar(0,'ShowXY'C)
	CALL SetStatusBar(1," Done setting LR# values ..."C)
    contour = .FALSE.
    CALL Redraw
	iRet = REGISTERMOUSEEVENT(iUnit, MOUSE$LBUTTONDOWN.OR.MOUSE$RBUTTONDOWN, ShowXY)
ELSE ! turn it on, and set up initialization:
    CALL ClearHistory(.TRUE.) ! includeRedraw?
    LRDraw_checked = .TRUE.
    bRet = MODIFYMENUFLAGSQQ(2, 13, $MENUCHECKED)
    iRet = REGISTERMOUSEEVENT(iUnit, MOUSE$LBUTTONDOWN.OR.MOUSE$RBUTTONDOWN, SetLR)
    ! initialize global variable "last_value", which is used in SetLR dialog:
    last_val = 0.0
    CALL setstatusbar(0, 'SetLR'C)
    CALL setstatusbar(1, 'Setting element LR index (Left-click to set value, Ctrl + Right-click to repeat last value)'C)


    iData = 0 ! As opposed to iData = 1, 2, ..., 6 in DlgEQCM
    contour = .TRUE. ! in Global
    CALL SetBinsLR
    CALL Redraw
END IF
END SUBROUTINE LRDraw

! 
! Redraw adjacent nodes, elements, faults when mouse move
!
subroutine MoveNode(iUnit, me, iKeyState, xpos, ypos) 
! require: Click
use global
use dflib
implicit none
integer(4), intent(in) :: iUnit, me, xpos, ypos
integer(4), intent(in) :: iKeyState
integer(4) i, nH
type(xycoord) viewxy
logical outside
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
! Requires: Nflags, Eside, Fside -- in MODULE Global
use dfwin
use dflib
use Global
implicit none
integer ierr
CALL ClearHistory(.FALSE.) ! includeRedraw?  NO; just wastes time!
call setstatusbar(0,'PATest'C)
call setstatusbar(1,' Perform Perimeter and Area tests...'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(.not.allocated(Fside)) allocate(Fside(2, MAX(NFL,1)), stat = ierr) ! avoid error in Perimeter/Area test
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,'Ready'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(4), intent(in) :: unit, mouseevent, xpos, ypos
integer(4), intent(in) :: iKeyState
integer(4) ie, n1, n2, n3, n4
integer col, row
logical outside
logical 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
implicit none
integer(4), intent(in) :: iUnit, MouseEvent, xpos, ypos
integer(4), intent(in) :: iKeyState
integer(4) col, row, iRet
integer(2) col_2, row_2
logical 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
              col_2 = col; row_2 = row ! required INT(2) arguments
		      iRet = SETPIXELRGB(col_2, row_2, ifrontcolor)
              col_2 = col+1; row_2 = row ! required INT(2) arguments
			  iRet = SETPIXELRGB(col_2, row_2, ifrontcolor)
              col_2 = col-1; row_2 = row ! required INT(2) arguments
			  iRet = SETPIXELRGB(col_2, row_2, ifrontcolor)
              col_2 = col; row_2 = row+1 ! required INT(2) arguments
			  iRet = SETPIXELRGB(col_2, row_2, ifrontcolor)
              col_2 = col; row_2 = row-1 ! required INT(2) arguments
			  iRet = SETPIXELRGB(col_2, row_2, ifrontcolor)
			  x0 = x
			  y0 = y
			  tempv4(1:3) = tempvec(1:3)
         else ! draw line
		      call moveto(ColOld, RowOld, xy)
              col_2 = col; row_2 = row ! regquired INT(2) arguments
			  iRet = lineto(col_2, row_2) 
		 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
logical visible
integer(2) arg1_2, arg2_2
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
         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)
         arg1_2 = colbase - boxhalf; arg2_2 = rowbase ! required INT(2) arguments
         call moveto(arg1_2, arg2_2, xy)
         arg1_2 = colbase + boxhalf; arg2_2 = rowbase ! required INT(2) arguments
	     iRet = lineto(arg1_2, arg2_2)
         arg1_2 = colbase; arg2_2 = rowbase - boxhalf ! required INT(2) arguments
	     call moveto(arg1_2, arg2_2, xy)
         arg1_2 = colbase; arg2_2 = rowbase + boxhalf ! required INT(2) arguments
	     iRet = lineto(arg1_2, arg2_2)
      endif
    end if
else
    ! no grid in memory
	call error4
endif
! update status bar
call setstatusbar(0,'Ready'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 colA, rowA, colB, rowB, colC, rowC
logical visible
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
         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,'Ready'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
implicit none
integer(4) i,iRet
!integer contour
integer iUnit
integer tcol0, trow0, tcol1, trow1
integer(2) dummy, tcol0_2, trow0_2, tcol1_2, trow1_2
integer(4) iColor
logical visible
external Showxy, iColorFromLRi
INTEGER*4 iColorFromLRi
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
tcol0_2 = tcol0; trow0_2 = trow0; tcol1_2 = tcol1; trow1_2 = trow1 ! required INT(2) arguments
dummy = ELLIPSE($GBORDER, tcol0_2, trow0_2, tcol1_2, trow1_2)
IF (GridLoaded) THEN
  colorIn = .FALSE.
  ! draw nodes
  DO i = numNod, 1, -1
     CALL DrawNode (iNodeColor, i)
  END DO
  ! draw elements
  plot_eleCenter_icons = (windowheight < 0.1D0).OR.(numel < 2000) ! located in Global; checked by DrawElement
  DO i = numEl, 1, -1
    CALL DrawElement (iEleColor, i) ! N.B. iEleColor refers only to outline + icon, not to any filling.
  END DO
  ! draw faults
  DO i = nFl, 1, -1
    IF (LRDraw_checked) THEN
        iColor = iColorFromLRi (fault_LRi(i))
    ELSE
        iColor = iFaultColor
    END IF
    CALL DrawFault (iColor, i)
  END DO
  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(4), intent(in) :: unit, mouseevent, x, y
   integer(4), intent(in) :: iKeyState
   integer(4) iRet
   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(4), intent(in) :: unit, mouseevent, x, y
integer(4), intent(in) :: iKeyState
integer(4) iRet
integer(4) cursor, oldcursor
integer(2) iret1
real(8) xnode1, ynode1

real xc,yc,tempvec(3)
logical 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) then
      call beepqq(1000,40)
    else
      call ABG2lonlat(tempvec, winlon, winlat)
	  call winframe(winlat,winlon, winright, winout, winup)
	  call Scaler
      IF (contour) THEN
          IF (LRDraw_checked) THEN
              CALL SetBinsLR 
          ELSE
              CALL SetBins
          END IF
      END IF
	  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
implicit none
integer(4), intent(in) :: unit, mouseevent, xpos, ypos
integer(4), intent(in) :: iKeyState
real xc,yc
type(xycoord) viewxy
!!!! 
integer(4) s1, nH
integer(4) n, i
integer(4) ie, je
!integer contour
logical 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/Crustal-thickness/Mantle-lithosphere-thickness/Density-anomaly/Cooling-curvature
! Left-button --> invoke dialog window for setting value
! Ctrl + Right-button --> repeat the last value set through Left-Button dialog
!
subroutine SetEQCM(unit, mouseevent, iKeystate, xpos, ypos)
! requires Global: NItsOn, EItsOn, FItsOn, Non ...
use dflib
use dflogm
use global
implicit none
include 'resource.fd'
integer(4), intent(in) :: unit, mouseevent, xpos, ypos
integer(4), intent(in) :: iKeyState
integer Col, Row
integer i, k, n1, nH, e1, ie, je, f1
real x, y
real node_val, replaced_nodal_value
real maxf, minf
type(xycoord) viewxy
type(dialog) dlg
logical(4) bRet
logical drawall
logical IsNumber ! external function: Is a given text-string a number?
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 ! Remember this user-entry, in case the user wants to repeat it (with Ctrl-RightClick).
 	  		  ! Check old maximum & minimum values, before new node value is assigned:
 		      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
              ! Remember the value that is about to be replaced:
              replaced_nodal_value = EQCM(idata, NOn(1))
              ! Make the assignment to the new value:
              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 new nodal value is a new extreme, it will be necessary to change the color bar and redraft everything:
              IF ((node_val > maxf).OR.(node_val < minf)) drawAll = .TRUE.
              !ALSO, if old value WAS an extreme, but new value is NOT, then again we MAY have to change the color bar, so it's best to just redraft everything:
              IF ((replaced_nodal_value == minf).AND.(node_val > replaced_nodal_value)) drawAll = .TRUE.
              IF ((replaced_nodal_value == maxf).AND.(node_val < replaced_nodal_value)) drawAll = .TRUE.
 	          ! increment editing counter
			  call IncreaseEditingCounter
          else
		      call DlgUninit(dlg)
		      return
          end if
          call DlgUninit(dlg)
        else if ((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 element Lithospheric Rheology index (LR#) of a continuum triangular element or a linear fault element:
! Left-button --> invoke dialog window for setting value
! Ctrl + Right-button --> repeat the last value set through Left-Button
!
subroutine SetLR(unit, mouseevent, iKeystate, xpos, ypos)
! requires: NItsOn, EItsOn, FItsOn, Non ...
use dflib
use dflogm
use global
implicit none
include 'resource.fd'
integer(4), intent(in) :: unit, mouseevent, xpos, ypos
integer(4), intent(in) :: iKeyState
integer col, row
integer(4) i, iColor, LRi, nE, new_integer, nF
real x, y
real replaced_value
real maxf, minf
type(xycoord) viewxy
type(dialog) dlg
logical(4) bRet
logical drawall
logical IsNumber ! external function: Is a given text-string a number?
integer(4) iRet
character(50) message
EXTERNAL iColorFromLRi
INTEGER*4 iColorFromLRi
!- - - - - - - - - - - - - - - - -
! 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)
 	CALL ExistsCentroid(x, y, nE) ! Did this mouse-click hit the centroid of any triangular continuum element?
    CALL ExistsMidpoint(x, y, nF) ! Did this mouse-click hit the midpoint of any linear fault element?
    IF (nE > 0) THEN ! hit a triangular continuum element!
	    IF ((MOUSE$KS_LBUTTON.and.iKeyState) == MOUSE$KS_LBUTTON) THEN
            ! Left button down
            WRITE (message, "(I8)") continuum_LRi(nE)
            bRet = DLGINIT(IDD_SETLR, dlg)
            bRet = DLGSETCHAR(dlg, IDC_SETLR_EDIT1, trim(message) // CHAR(0))
            iRet = DlgModal(dlg)
            IF (iRet == IDOK) THEN
                bRet = DLGGETCHAR(dlg, IDC_SETLR_EDIT1, message)
                CALL Repair_String(message)
	            IF (.NOT.IsNumber(message)) THEN
		            CALL Error7
		            CALL Dlguninit(dlg)
		            RETURN
                END IF
                READ (message, *) new_integer
	            last_val = 1.0 * new_integer ! Remember this user-entry, in case the user wants to repeat it (with Ctrl-RightClick).
 	            ! Check old maximum & minimum values, before new node value is assigned:
 	            maxF = continuum_LRi(1)
                minF = maxF
                DO i = 2, numEl
                    IF (continuum_LRi(i) > maxF) maxF = continuum_LRi(i)
		            IF (continuum_LRi(i) < minF) minF = continuum_LRi(i) 
                END DO
                DO i = 1, nFl
                    IF (fault_LRi(i) > maxF) maxF = fault_LRi(i)
		            IF (fault_LRi(i) < minF) minF = fault_LRi(i) 
                END DO
                ! Remember the value that is about to be replaced:
                replaced_value = 1.0 * continuum_LRi(nE)
                ! Make the assignment to the new value:
                continuum_LRi(nE) = new_integer
                !
                drawAll = .FALSE.
                !If new value is a new extreme, it will be necessary to change the color bar and redraft everything:
                IF ((new_integer > NINT(maxF)).OR.(new_integer < NINT(minF))) drawAll = .TRUE.
                !ALSO, if old value WAS an extreme, but new value is NOT, then again we MAY have to change the color bar, so it's best to just redraft everything:
                IF ((replaced_value == minF).AND.(new_integer > NINT(replaced_value))) drawAll = .TRUE.
                IF ((replaced_value == maxF).AND.(new_integer < NINT(replaced_value))) drawAll = .TRUE.
 	            ! increment editing counter
	            CALL IncreaseEditingCounter
            ELSE ! (iRet /= IDOK)...
	            CALL DlgUninit(dlg)
	            RETURN
            END IF
            CALL DlgUninit(dlg)
        ELSE IF ((MOUSE$KS_CONTROL.and.iKeyState) == MOUSE$KS_CONTROL) THEN
		      ! Ctrl + right button down
		      IF (last_val == 99999.00) THEN
			     CALL Error12
				 RETURN
			  END IF
              continuum_LRi(nE) = NINT(last_val)
			  drawAll = .false.	  
              ! increment editing counter
			  CALL IncreaseEditingCounter
	    END IF ! L or R mouse button was pressed
        ! reassign values to color bands, and refresh color bar
		IF (contour) THEN
		   CALL SetBinsLR
		   CALL ColorBar
        END IF
		! If range ends change, redraw all old contours
	    IF (drawAll) THEN
		    CALL Redraw
        ELSE
            ! otherwise, plotting only one element (faster)
            CALL DrawElement (iEleColor, nE) ! Note: iEleColor only refers to the outline; DrawElement will decide shading.
        END IF ! drawAll, or not
    ELSE IF (nF > 0) THEN ! hit the mid-point of a linear fault element!
	    IF ((MOUSE$KS_LBUTTON.and.iKeyState) == MOUSE$KS_LBUTTON) THEN
            ! Left button down
            WRITE (message, "(I8)") fault_LRi(nF)
            bRet = DLGINIT(IDD_SETLR, dlg)
            bRet = DLGSETCHAR(dlg, IDC_SETLR_EDIT1, trim(message) // CHAR(0))
            iRet = DlgModal(dlg)
            IF (iRet == IDOK) THEN
                bRet = DLGGETCHAR(dlg, IDC_SETLR_EDIT1, message)
                CALL Repair_String(message)
	            IF (.NOT.IsNumber(message)) THEN
		            CALL Error7
		            CALL Dlguninit(dlg)
		            RETURN
                END IF
                READ (message, *) new_integer
	            last_val = 1.0 * new_integer ! Remember this user-entry, in case the user wants to repeat it (with Ctrl-RightClick).
 	            ! Check old maximum & minimum values, before new node value is assigned:
 	            maxF = continuum_LRi(1)
                minF = maxF
                DO i = 2, numEl
                    IF (continuum_LRi(i) > maxF) maxF = continuum_LRi(i)
		            IF (continuum_LRi(i) < minF) minF = continuum_LRi(i) 
                END DO
                DO i = 1, nFl
                    IF (fault_LRi(i) > maxF) maxF = fault_LRi(i)
		            IF (fault_LRi(i) < minF) minF = fault_LRi(i) 
                END DO
                ! Remember the value that is about to be replaced:
                replaced_value = 1.0 * fault_LRi(nF)
                ! Make the assignment to the new value:
                fault_LRi(nF) = new_integer
                !
                drawAll = .FALSE.
                !If new value is a new extreme, it will be necessary to change the color bar and redraft everything:
                IF ((new_integer > NINT(maxF)).OR.(new_integer < NINT(minF))) drawAll = .TRUE.
                !ALSO, if old value WAS an extreme, but new value is NOT, then again we MAY have to change the color bar, so it's best to just redraft everything:
                IF ((replaced_value == minF).AND.(new_integer > NINT(replaced_value))) drawAll = .TRUE.
                IF ((replaced_value == maxF).AND.(new_integer < NINT(replaced_value))) drawAll = .TRUE.
 	            ! increment editing counter
	            CALL IncreaseEditingCounter
            ELSE ! (iRet /= IDOK)...
	            CALL DlgUninit(dlg)
	            RETURN
            END IF
            CALL DlgUninit(dlg)
        ELSE IF ((MOUSE$KS_CONTROL.and.iKeyState) == MOUSE$KS_CONTROL) THEN
		    ! Ctrl + right button down
		    IF (last_val == 99999.00) THEN
			    CALL Error12
			    RETURN
		    END IF
            fault_LRi(nF) = NINT(last_val)
		    drawAll = .FALSE.	  
            ! increment editing counter
		    CALL IncreaseEditingCounter
	    END IF ! L or R mouse button was pressed
        ! reassign values to color bands, and refresh color bar
		IF (contour) THEN
		   CALL SetBinsLR
		   CALL ColorBar
        END IF
		! If range ends change, redraw all old contours
	    IF (drawAll) THEN
            CALL SetBinsLR
		    CALL Redraw
        ELSE
            ! otherwise, plotting only one element (faster)
            IF (LRDraw_checked) THEN
                iColor = iColorFromLRi (fault_LRi(nF))
            ELSE
                iColor = iFaultColor
            END IF
            CALL DrawFault (iColor, nF)
        END IF ! drawAll, or not
    ELSE ! Did not hit either a triangular continuum element (centroid) or a linear fault element (centroid); COMPLAIN!
        CALL BeepQQ(1000, 40)
    END IF ! hit a triangular continuum element, a linear fault element, or neither
END IF ! mouse was clicked
END SUBROUTINE SetLR

!
! Set Fault inclination (dipping), routine used by FInclination
!
subroutine SetFInc(unit, mouseevent, iKeyState, xpos, ypos)
! requires: JIP (in Global)
use dfwin
use dflib
use global
implicit none
integer(4), intent(in) :: unit, MouseEvent, xpos, ypos
integer(4), intent(in) :: iKeyState
integer col, row
logical 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
SAVE ! implicit in Digital Fortran; must be requested in Intel Fortran
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
       else if((MOUSE$KS_LBUTTON.and.iKeyState) == MOUSE$KS_LBUTTON) then
	        if (sense > 0) then
			    newdip = shallow
			else
			    newdip = 180 - shallow
			end if
       else if((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

!
! Status bar has 5 parts, controlled by partID
!
SUBROUTINE SetStatusBar(partID, msg2)
    USE DFWin
    USE Global
    IMPLICIT NONE
    INTEGER(handle), INTENT(IN):: partID ! Note that "handle" (from DFWin) = 4 on the IA-32 platform, but = 8 on the x64 platform.
    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
implicit none
integer(4) iRet
integer col1, row1, col2, row2, iUnit
logical(4) bRet, linedown, Ochosen
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(.FALSE.) ! includeRedraw?  NO; just wastes time!
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
implicit none
integer(4), intent(in) :: unit, mouseevent, xpos, ypos
integer(4), intent(in) :: iKeyState
integer col, row, col0, row0, col1, row1, col2, row2
integer i, j
integer(2) arg1_2, arg2_2, iret_2
real lat, lon, xo, yo, xr, yr
real tempvec(3), tempv2(3), tempv3(3), tempv4(3)
logical Ochosen
logical linedown, outside
type(xycoord) viewxy
type(xycoord) xy
SAVE ! implicit in Digital Fortran; must be requested in Intel Fortran
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
else if((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_2 = SETWRITEMODE($GXOR)
					   ! Note: linedown, col1, row1, col2, row2 storing in common block
					   if(linedown) then
                         arg1_2 = col1; arg2_2 = row1 ! required INT(2) arguments
					     call moveto(arg1_2, arg2_2, xy)
                         arg1_2 = col2; arg2_2 = row2 ! required INT(2) arguments
					     iret_2 = lineto(arg1_2, arg2_2)
                       end if
                       arg1_2 = col0; arg2_2 = row0 ! required INT(2) arguments
					   call moveto(arg1_2, arg2_2, xy)
                       arg1_2 = col; arg2_2 = row ! required INT(2) arguments
					   iret_2 = lineto(arg1_2, arg2_2)
					   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_2 = 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(4), intent(in) :: unit, me, xpos, ypos
integer(4), intent(in) :: iKeyState
integer(4) iRet
logical 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 (.not.outside) then
    call ABG2lonlat(tempvec, lon,lat)
	lon = lon*57.2958
	lat = lat*57.2958
    write(msg, '(" cursor Lon = ",F8.3," E, Lat = ",F7.3," N")') 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," E, Lat = ",F7.3," N")') 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(4), intent(in) :: unit, mouseevent, xpos, ypos
integer(4), intent(in) :: iKeyState
integer(2) arg1_2, arg2_2, iret_2
integer col, row
type(xycoord) viewxy, xy
logical 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
      arg1_2 = 2*Colold-col11; arg2_2 = 2*RowOld - row11 ! required INT(2) arguments
	  call moveto(arg1_2, arg2_2, xy)
      arg1_2 = col11; arg2_2 = row11 ! required INT(2) arguments
	  iret_2 = lineto(arg1_2, arg2_2)
	  ! draw new one
      arg1_2 = 2*ColOld-col; arg2_2 = 2*RowOld - row ! required INT(2) arguments
	  call moveto(arg1_2, arg2_2, xy)
      arg1_2 = col; arg2_2 = row ! required INT(2) arguments
	  iret_2 = lineto(arg1_2, arg2_2)
	  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
integer(4) :: control_name
logical(4) bRet
integer(4) iRet
integer(4) ios
logical check_state
integer callbacktype
character(50) string
  select case(control_name)
    case(IDC_LIST)  !  get object type
      bRet = DLGGET (dlg, IDC_LIST, string) ! (in), (in), (out)
      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
integer(4), intent(in) :: unit, mouseevent, x, y
integer(4), intent(in) :: iKeyState
character(9) :: c9lat, c9lon
integer(4) iRet
integer ios
logical outside
real xc, yc, tempvec(3)
real lon, lat
integer numNear
integer(4) nearOnes(5)
type(xycoord) viewxy
SAVE
call getviewcoord(x,y,viewxy)
call XandY(x,y,xc,yc)
call xy2ABG(xc,yc,outside, tempvec)
if (.not.outside) 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," E, Lat = ",F7.3," N")
!   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)
       IF (numNear <= 0) THEN
           WRITE(msg, '(" Nearest node:  ")')
       ELSE IF (numNear == 1) THEN
           WRITE(msg, '(" Nearest node:  ", I6)') nearones(1:1)
       ELSE IF (numNear == 2) THEN
           WRITE(msg, '(" Nearest nodes: ", I6, " ", I6)') nearones(1:2)
       ELSE IF (numNear == 3) THEN
           WRITE(msg, '(" Nearest nodes: ", I6, " ", I6, " ", I6)') nearones(1:3)
       ELSE IF (numNear == 4) THEN
           WRITE(msg, '(" Nearest nodes: ", I6, " ", I6, " ", I6, " ", I6)') nearones(1:4)
       ELSE IF (numNear >= 5) THEN
           WRITE(msg, '(" Nearest nodes: ", I6, " ", I6, " ", I6, " ", I6, " ", I6)') nearones(1:5)
       END IF
	   CALL SetStatusBar(3, TRIM(msg) // CHAR(0))
    END IF
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
! requires: oldslice (in Global)
use dflib
use dfwin
use global
use Icosahedron
implicit none
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, 'TileRegionalGrid'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, 'Ready'C)
	call setstatusbar(1, ' 'C)
end if
end subroutine TileGrid

!
! User defined exit function
!
subroutine UserExit
use dfwin
use dflogm
use dflib
use global
implicit none
logical bRet
integer(4) iRet
type(dialog) dlg
include 'resource.fd'
! update statusbar infor
call setstatusbar(0,'UserExit'C)
call setstatusbar(1,' 'C)
!first, caution user that loaded and edited grid has not been saved:
if (GridLoaded.and.(editingcounter > 0)) then
   bRet = dlginit(IDD_ClearGrid, dlg)
   iRet = dlgmodal(dlg)
   if (iRet == IDOK) then
       ! save to BACKUP.feg first?
	   call IncreaseEditingCounter
   else if (iRet == IDCANCEL) then
       !do not even offer a chance to Exit, just now
       return
   end if
end if
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,'Ready'C)
  call setstatusbar(1,' 'C)
end subroutine UserExit

!
! Visual checking for any gap(s) or overlap(s) in the mesh
!
subroutine ViewGap
use dflib
use global
implicit none
integer(4) iRet
integer iUnit
external ClickAndView
CALL ClearHistory(.TRUE.) ! includeRedraw?
! update statusbar information
call setstatusbar(0, 'ViewGap'C)
call setstatusbar(1, 'View any gap(s)/overlap(s) by coloring plate(s); repeatedly left-click on various element centers...'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 ViewGap

!
! 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
!- - - - - - - - - - - - - - - - - -
CALL ClearHistory(.FALSE.) ! includeRedraw?  NO; redundant; Redraw will happen AFTER user input!
! Change statusbar info:
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 > 360.0).or.(winlonD < -360.0)) then
      call error5("lon")
      return
   end if
   winlatD = MIN(89.9, MAX(-89.9, winLatD)) ! avoid any singularities at the poles
   winlat = winlatD * 0.017453293
   winlon = winlonD * 0.017453293
   call winframe(winlat,winlon, winright, winout, winup)
   call Scaler
   IF (contour) THEN
       IF (LRDraw_checked) THEN
           CALL SetBinsLR
       ELSE
           CALL SetBins
       END IF
   END IF
   CALL Redraw
END IF
CALL DlgUnInit(dlg)
! Update statusbar info:
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
implicit none
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", " ")') 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 dfwin
    use dflogm
    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
    !- - - - - - - - - - - - --- - - - - 
    CALL ClearHistory(.FALSE.) ! includeRedraw?  NO; redundant, because Redraw will occur after user chooses new center point.
    iUnit = getactiveqq()
    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, "(F6.3)") windowheight
    CLOSE (73, DISP = "KEEP")
    OPEN (UNIT = 73, FILE = "windowHeightString.txt", STATUS = "OLD")
    READ (73, "(A6)") 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 ! normal change-of-zoom:
            read(windowHeightString, *) windowheight
            !Silently guard against crazy values (e.g., non-positive?):
            windowheight = MAX(0.001, MIN(3.0, windowheight))
        else ! bad # entered by user; error condition
            write(windowHeightstring, "(F6.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)
end subroutine ZoomInOut