! ! Contains: ! Module STUFF ! Subroutines: ! ThreadDlg1 ! OnRun ! OnStop ! BadTopoDlg ! BadTopoDlg2 ! OnThreadEnd1 ! OnThreadEnd2 ! Functions: ! PerimTest ! MODULE STUFF USE DFWin, ONLY: handle INTEGER(handle) :: hThread logical bStopped integer MaxRange integer iprogress END MODULE STUFF ! ! Thread used in Perimeter/Area testing ! subroutine ThreadDlg1 USE DFWIN USE DFLOGM USE GLOBAL USE STUFF implicit none external OnRun, OnStop INTEGER :: iDummy TYPE (DIALOG) :: Dlg TYPE (T_SECURITY_ATTRIBUTES), TARGET :: saMine TYPE (T_SECURITY_ATTRIBUTES), POINTER :: ptsaMine INTEGER:: idThread INTERFACE INTEGER(4) FUNCTION PerimTest(h) !DEC$ATTRIBUTES STDCALL:: PerimTest INTEGER h END FUNCTION END INTERFACE INCLUDE "Resource.fd" iDummy=DlgInit(IDD_DIALOG2, Dlg) iDummy = DlgSet(Dlg, IDC_BUTTON_stop, .false., DLG_ENABLE) iDummy=DlgSetSub(Dlg, IDC_BUTTON_run, OnRun) iDummy=DlgSetSub(Dlg, IDC_BUTTON_stop, OnStop) iDummy=DlgModal(Dlg) CALL DlgUnInit(Dlg) end subroutine ThreadDlg1 ! ! Callback routine upon pressing "RUN" Button ! SUBROUTINE OnRun(Dlg, ID, iAction) USE DFWIN USE DFLOGM USE STUFF IMPLICIT NONE INCLUDE "Resource.fd" TYPE(Dialog) :: Dlg INTEGER :: ID, iAction, iDummy TYPE (T_SECURITY_ATTRIBUTES), TARGET :: saMine TYPE (T_SECURITY_ATTRIBUTES), POINTER :: ptsaMine INTEGER(handle) :: idThread INTERFACE INTEGER(4) FUNCTION PerimTest(h) !DEC$ATTRIBUTES STDCALL:: PerimTest INTEGER h END FUNCTION END INTERFACE bStopped = .FALSE. !Start a new thread for working routine ... !Set up ("optional" but actually REQUIRED) first parameter of CreateThread(): saMine%nLength = 12 ! bytes saMine%lpSecurityDescriptor = NULL saMine%bInheritHandle = .FALSE. ptsaMine => saMine hThread = CreateThread(ptsaMine, 0, LOC(PerimTest), LOC(Dlg), 0, LOC(idThread)) ! accepting default stack size (first "0"); immediate execution (2nd "0"). ! Disable 'Run' Button so that another calculation cannot be concurrently started iDummy = DlgSet(Dlg, ID, .FALSE., DLG_ENABLE) iDummy = DlgSet(Dlg, IDC_BUTTON_STOP, .TRUE., DLG_ENABLE) iDummy = DlgSet(Dlg, IDCANCEL, .FALSE., DLG_ENABLE) END SUBROUTINE OnRun ! ! Callback routine upon pressing "STOP" Button ! SUBROUTINE OnStop(Dlg, ID, iAction) USE DFWIN USE DFLOGM USE STUFF ! This tiny MODULE of COMMON-like variables is above in this file. It includes hThread. USE GLOBAL IMPLICIT NONE TYPE(Dialog):: Dlg INTEGER ID, iAction, idThread, iDummy INCLUDE "Resource.fd" !Setting event (raising its state to TRUE) will cause !the thread to exit when first testing event state bStopped = .TRUE. !Disable "Stop" button while terminating thread iDummy = DlgSet(Dlg, ID, .FALSE., DLG_ENABLE) ! force thread to shut off when certain time is exceeded iDummy = WaitForSingleObject(hThread, 500) IF (iDummy.EQ.WAIT_TIMEOUT) THEN !Thread didn't exit within 0.5s , kill it (_DANGEROUS_) iDummy = TerminateThread(hThread, 0) END IF !Re-Enable buttons iDummy = DlgSet(Dlg, IDC_BUTTON_RUN, .TRUE., DLG_ENABLE) iDummy = DlgSet(Dlg, ID, .FALSE., DLG_ENABLE) iDummy = DlgSet(Dlg, IDCANCEL, .TRUE., DLG_ENABLE) ! Send message msg = " Perimeter test was interrupted by user." iDummy = DlgSet(Dlg, IDC_DIALOG2_TEXT, TRIM(msg) // CHAR(0), DLG_TITLE) msg = " Press Close button to close the window!" iDummy = DlgSet(Dlg, IDC_DIALOG2_TEXT2, TRIM(msg) // CHAR(0), DLG_TITLE) iDummy = CloseHandle(hThread) END SUBROUTINE OnStop ! ! Work routine as a new thread ! INTEGER(4) FUNCTION PerimTest(Dlg) !DEC$ATTRIBUTES STDCALL:: PerimTest !DEC$ATTRIBUTES REFERENCE:: Dlg USE DFLOGM USE DFWIN USE GLOBAL ! needs for Nflags, Eside, Fside USE STUFF IMPLICIT NONE integer(4) i, iDummy, ie, j, je, jf1, je1 integer(4) NCOND, NDONE, NLEFT, Kfault, Kele integer(4) n, n1, n2, n3, node integer(4) k, percent, old_percent real per0(3), tempvec(3), tempv2(3), tempv3(3) real Alpha, Beta, Gamma, lon, lat real Boxhalf, SolidAngle, rpercent, x, y real(8) within, sumarea logical droploose, OK type(dialog) Dlg include "resource.fd" ! Initialize all static text box msg = ' 'C iDummy = DlgSet(Dlg, IDC_DIALOG2_TEXT, msg, DLG_TITLE) msg = ' 'C iDummy = DlgSet(Dlg, IDC_DIALOG2_TEXT2, msg, DLG_TITLE) msg = ' 'C iDummy = DlgSet(Dlg, IDC_DIALOG2_TEXT3, msg, DLG_TITLE) msg = ' 'C iDummy = DlgSet(Dlg, IDC_DIALOG2_TEXT4, msg, DLG_TITLE) msg = ' 'C iDummy = DlgSet(Dlg, IDC_DIALOG2_TEXT5, msg, DLG_TITLE) !! ----- Check for isolated nodes --------- droploose = .false. i=1 1 if (mod(i, 100) == 0) then write(msg,"('Checking that all nodes belong to some element...', I8)") i end if iDummy = DlgSet(Dlg, IDC_DIALOG2_TEXT, TRIM(msg) // CHAR(0), DLG_TITLE) call OnAnyE(i, 1, NUMEL, ie, je) if (ie == 0) then call OnAnyF(i, 1, NFL, ie, je) if(ie == 0) then if (droploose) then call dropnodesize(-999, i) i = i - 1 else call beepqq(1000, 40) call BadTopoDlg(droploose) if(droploose) then goto 1 else msg = 'Perimeter test cannot be completed!' iDummy = DlgSet(Dlg, IDC_DIALOG2_TEXT,TRIM(msg) // CHAR(0), DLG_TITLE) msg = 'Press Close to close the dialog box...' iDummy = DlgSet(Dlg, IDC_DIALOG2_TEXT2, TRIM(msg) // CHAR(0), DLG_TITLE) ! End Thread upon abnormal case call OnThreadEnd2(Dlg) PerimTest = 0 return end if end if end if end if ! 1st ie == 0 if (i < NUMNOD) then i = i + 1 goto 1 end if !! -------- Form boundary node list ------------------------ msg = 'Making a list of all boundary nodes...' iDummy = DlgSet(Dlg, IDC_DIALOG2_TEXT, trim(msg) // CHAR(0), DLG_TITLE) ! Prepare to count all exterior nodes ! Note: Nflag, Eside, Fside are allocated in subroutine "PATest" ! Nflags(1:2, 1:NUMNOD) = 0 ! 1: already known, 2: exterior node Eside(1:3, 1:NUMEL) = 0 Fside(1:2, 1:NFL) = 0 ! NCOND = 0 old_percent = 0 do i = 1, NUMEL do j = 1, 3 call NEXTto(i, j, Kfault, jf1, Kele, je1) if(Kele > 0) then ! ordinary interior side Eside(j, i) = 0 elseif(Kfault == 0) then ! external side Eside(j, i) = 1 n1 = nodes(mod(j,3)+1, i) n2 = nodes(mod(j+1,3)+1,i) if(Nflags(1, n1)==1) then ! already know n1 else NCOND = NCOND + 1 Nflags(1:2, n1) = 1 end if if(Nflags(1, n2)==1) then ! already know n2 else NCOND = NCOND + 1 Nflags(1:2, n2) = 1 end if else ! Triangular element has one exterior fault element adjacent to it Eside(j, i) = 0 n2 = nodes(mod(j+1,3)+1, i) if(nodef(1,Kfault) == n2) then Fside(2, Kfault) = 1 ! side 2 external do k = 3, 4 n = nodef(k, Kfault) if(Nflags(1,n)==1) then ! already know it else NCOND = NCOND + 1 ! another external node Nflags(1:2, n) = 1 end if end do else ! side 1 external Fside(1, Kfault) = 1 do k = 1, 2 n = nodef(k, Kfault) if(Nflags(1,n)==1) then ! already know it else NCOND = NCOND + 1 Nflags(1:2, n) = 1 end if end do end if end if end do ! next j percent = int(real(i) / real(NUMEL) * 100.0) if (percent /= old_percent) THEN write(msg,"(I8, ' nodes found', I5, '% of search completed.')") NCOND, percent old_percent = percent end if iDummy = DlgSet(Dlg, IDC_DIALOG2_TEXT2, trim(msg) // CHAR(0), DLG_TITLE) end do ! next i !! if(NCOND == 0) then msg = 'No boundary nodes found; grid covers entire sphere.' iDummy = DlgSet(Dlg, IDC_DIALOG2_TEXT, trim(msg) // CHAR(0), DLG_TITLE) msg = ' ' iDummy = DlgSet(Dlg, IDC_DIALOG2_TEXT2, trim(msg) // CHAR(0), DLG_TITLE) goto 110 ! calculate element area elseif(NCOND > MXBN) then write(msg,"(' Number of boundary nodes (', I6,') exceeds limit of ', I6)") NCOND, MXBN iDummy = DlgSet(Dlg, IDC_DIALOG2_TEXT, trim(msg) // CHAR(0), DLG_TITLE) msg = ' Test cannot be completed! ' iDummy = DlgSet(Dlg, IDC_DIALOG2_TEXT2, trim(msg) // CHAR(0), DLG_TITLE) call OnThreadEnd2(Dlg) PerimTest = 0 return else msg = 'Linking these nodes in order to form the perimeter...' iDummy = DlgSet(Dlg, IDC_DIALOG2_TEXT, trim(msg) // CHAR(0), DLG_TITLE) iDummy = DlgSet(Dlg, IDC_DIALOG2_TEXT2, ' 'C, DLG_TITLE) end if !! begin loop to link nodes to form perimeter !! start from lowest-numbered boundary node do i = 1, NUMNOD if(Nflags(1,i)==1) goto 2 ! L831 end do ! 2 NODCON(1) = i per0(1:3) = nodeABG(1:3, i) NDONE = 1 NLEFT = NCOND ! go indefinite loop which traces around the perimeter ! it progresses by one of 3 steps ! 1. one node at a time along a new triangle side ! 2. one node at a time along a new fault element side ! 3. by finding another node which shares the same location ! !---- Beginning of main loop ------ ! 3 node = NODCON(NDONE) if(NDONE > 1) then do j = 1, NDONE -1 if(node == NODCON(j)) then ! Display dialog for asking arc size in degree call BadTopoDlg2(boxhalf) msg = ' working on the locations of the "extra" external nodes... ' iDummy = DlgSet(Dlg, IDC_DIALOG2_TEXT, trim(msg) // CHAR(0), DLG_TITLE) msg = ' 'C iDummy = DlgSet(Dlg, IDC_DIALOG2_TEXT2, msg, DLG_TITLE) iDummy = DlgSet(Dlg, IDC_DIALOG2_TEXT3, msg, DLG_TITLE) ! output open(10, file = "BADNODES.DIG", status ='unknown', action ='write') do i = 1, NUMNOD if(Nflags(2,i)==1) then ! external node node = i OK = .false. do k = 1, NDONE - 1 if(node == NODCON(k)) OK = .true. ! linked already end do tempvec(1:3) = nodeABG(1:3, i) call ABG2lonlat(tempvec, lon, lat) lat = lat * 57.2958 lon = lon * 57.2958 write(10, "('Boundary node',I5,'at (Lon ',SP,F8.3, & ' ,Lat ',F7.3)") node, lon, lat if(OK) then write(10,30) lon - Boxhalf, lat + Boxhalf write(10,30) lon - Boxhalf, lat - Boxhalf write(10,30) lon + Boxhalf, lat - Boxhalf write(10,30) lon + Boxhalf, lat + Boxhalf write(10,30) lon - Boxhalf, lat + Boxhalf write(10,"('*** end of line segment ***')") else write(10,30) lon - Boxhalf, lat write(10,30) lon + Boxhalf, lat write(10,"('*** end of line segment ***')") write(10,30) lon, lat + Boxhalf write(10,30) lon, lat - Boxhalf write(10,"('*** end of line segment ***')") end if end if end do close(10) 30 format(SP, 3P, E13.6,',',0P, 2P,E12.5) msg = ' DONE with locations of the "extra" external nodes ...' iDummy = DlgSet(Dlg, IDC_DIALOG2_TEXT2, trim(msg) // CHAR(0), DLG_TITLE) call OnThreadEnd2(Dlg) PerimTest = 0 return end if end do end if percent = real(NDONE)/real(NCOND)*100.0 write(msg,"(I8, ' nodes found', I5, '% of search completed.')") NDONE, percent iDummy = DlgSet(Dlg, IDC_DIALOG2_TEXT2, trim(msg) // CHAR(0), DLG_TITLE) ! start node Alpha = nodeABG(1, node) Beta = nodeABG(2, node) Gamma = nodeABG(3, node) ! look for an adjacent triangular element using this node do i = 1, NUMEL do j=1, 3 if(Eside(j,i) == 1) then n1 = nodes(mod(j,3)+1, i) if(n1==node) goto 4 !L846 end if end do end do goto 8 ! L850 4 n2 = nodes(mod(j+1,3)+1, i) NDONE = NDONE + 1 if(NDONE <= NCOND) NODCON(NDONE) = n2 Nflags(1,n2) = 0 !! for looking for another exterior node at the same location NLEFT = NLEFT - 1 if (NLEFT > 0) then goto 3 ! as Bscript L840 else goto 100 ! as L870 end if ! ! one node at a time along a new fault element side ! 8 do i = 1, NFL if(Fside(1,i) == 1) then ! side 1 is external if(nodef(1,i) == node) then n2 = nodef(2,i) goto 10 ! L856 end if elseif(Fside(2,i) == 1) then ! side 2 is external !! if(nodef(2,i) == node) then ! bug discovered, for side 2, nodef(2,i) should be nodef(3,i) !! if(nodef(3,i) == node) then n2 = nodef(4, i) goto 10 ! L856 end if end if end do goto 16 ! L860 10 NDONE = NDONE + 1 if(NDONE <= NCOND) NODCON(NDONE) = n2 Nflags(1, n2) = 0 NLEFT = NLEFT - 1 if(NLEFT > 0) then goto 3 else goto 100 end if ! ! finding another node which shares the same location ! 16 do i = 1, NUMNOD if((Nflags(1,i)==1).and.(i /= node)) then if((nodeABG(1,i) == Alpha).and.(nodeABG(2,i) == beta).and.& (nodeABG(3,i) == Gamma)) goto 18 !L867 end if end do msg = 'Bad grid topology: while tracing perimeter, Could not find & &any way to continue! Either through shared boundary elements, & &or through other boundary nodes sharing the same position.' iDummy = DlgSet(Dlg, IDC_DIALOG2_TEXT, trim(msg) // CHAR(0), DLG_TITLE) ! further information output call ABG2lonlat(per0, lon, lat) lon = lon * 57.2958 lat = lat * 57.2958 write(msg,"('Search begin at (Lon ', F8.3,',Lat ', F8.3,' ) with node ', i8)") lon, lat, NODCON(1) iDummy = DlgSet(Dlg, IDC_DIALOG2_TEXT2, trim(msg) // CHAR(0), DLG_TITLE) tempvec(1) = Alpha tempvec(2) = Beta tempvec(3) = Gamma call ABG2lonlat(tempvec, lon, lat) lon = lon*57.2958 lat = lat*57.2958 write(msg,'("circled around the perimeter in the counterclockwise direction", & "and failed at (Lon ", F8.3,",Lat ", F8.3, " ) with node ", i8)') lon, lat, node iDummy = DlgSet(Dlg, IDC_DIALOG2_TEXT3, trim(msg) // CHAR(0), DLG_TITLE) call beepqq(1000, 40) call OnThreadEnd2(Dlg) PerimTest = 0 return 18 NDONE = NDONE + 1 if(NDONE <= NCOND) NODCON(NDONE) = i Nflags(1,i) = 0 NLEFT = NLEFT - 1 if(NLEFT > 0) goto 3 ! 100 write(msg,"(I8,' nodes linked; 100% of perimeter completed .')") NCOND iDummy = DlgSet(Dlg, IDC_DIALOG2_TEXT, trim(msg) // CHAR(0), DLG_TITLE) msg = ' 'C iDummy = DlgSet(Dlg, IDC_DIALOG2_TEXT2, trim(msg) // CHAR(0), DLG_TITLE) iDummy = DlgSet(Dlg, IDC_DIALOG2_TEXT3, trim(msg) // CHAR(0), DLG_TITLE) ! up to this stage, no failing at all, so continue... ! form triangle using one side (center point to NODCON(i),i = NCOND, 1, -1) and center point ! counterwise sum up 110 tempvec(1:3) = 0. do i = 1, NUMNOD tempvec(1:3) = tempvec(1:3) + nodeABG(1:3, i) end do call UnitVec(tempvec) within = 0.D0 if(NCOND > 0) then tempv2(1:3) = nodeABG(1:3, NODCON(NCOND)) do i = 1, NCOND tempv3(1:3) = nodeABG(1:3, NODCON(i)) call Steradians(tempvec, tempv2, tempv3, SolidAngle) within = within + DBLE(SolidAngle) write(msg,"(' Area within perimeter = ', SP, 1P, D15.7)") within iDummy = DlgSet(Dlg, IDC_DIALOG2_TEXT2, trim(msg) // CHAR(0), DLG_TITLE) tempv2(1:3) = tempv3(1:3) end do else ! sphere within = 12.56637061D0 ! 4 Pi steradians, whole sphere write(msg,"(' Area of sphere ', SP, 1P, D15.7)") within iDummy = DlgSet(Dlg, IDC_DIALOG2_TEXT2, trim(msg) // CHAR(0), DLG_TITLE) end if ! summing area of individual elements sumarea = 0.0D0 do i = 1, numEl n1 = nodes(1,i) tempvec(1:3) = nodeABG(1:3, n1) n2 = nodes(2,i) tempv2(1:3) = nodeABG(1:3, n2) n3 = nodes(3, i) tempv3(1:3) = nodeABG(1:3, n3) call Steradians(tempvec, tempv2, tempv3, solidAngle) sumArea = sumArea + DBLE(ABS(solidAngle)) !NOTE: Use of ABS() in statement above enables catching cases of grid folding ! (such as those caused by excessive node movement with AdjustNode). ! Use of signed element areas is NOT needed here to catch ! clockwise-defined "X" elements; those are already caught by the ! preceding Perimeter Test (in which case this Area Test is not run). write(msg,"(' Sum of element areas = ', SP, 1P, D15.7)") sumarea iDummy = DlgSet(Dlg, IDC_DIALOG2_TEXT3, trim(msg) // CHAR(0), DLG_TITLE) end do ! display comparison message if ((within < 0.0D0).or.(sumArea < 0.0D0)) then msg = "Negative area! Check: (1) Many elements were defined& & backwards? Delete any element with an X and redefine& & it counterclockwise. Or, (2) 1 element is missing& & from a global grid? Use View Gaps/Overlaps." iDummy = DlgSet(Dlg, IDC_DIALOG2_TEXT3, trim(msg) // CHAR(0), DLG_TITLE) else rpercent = 100.0D0 * DABS(within - sumarea) / sumarea x= real(within) y= real(sumarea) if ((x == y).OR.(rpercent < 0.0001)) then msg = 'Areas agree, within expected precision.' iDummy = DlgSet(Dlg, IDC_DIALOG2_TEXT4, trim(msg) // CHAR(0), DLG_TITLE) else write(msg,"('Discrepancy is ', SP, 1P, E9.2, 0P, ' steradian, or ', F9.4,'%')") ABS(x - y), rpercent iDummy = DlgSet(Dlg, IDC_DIALOG2_TEXT4, trim(msg) // CHAR(0), DLG_TITLE) write(msg,"('Check for overlapped or missing elements with View Gaps/Overlaps.')") iDummy = DlgSet(Dlg, IDC_DIALOG2_TEXT5, trim(msg) // CHAR(0), DLG_TITLE) end if end if ! ! After successfully finishing thread ! PerimTest = 1 CALL OnThreadEnd1(Dlg) END FUNCTION PerimTest ! ! Topology error dialog: remove dangling node point ! subroutine BadTopoDlg(DropOrNot) use dflib use dflogm use dfwin implicit none logical DropOrNot logical(4) bRet integer(4) iRet type(dialog) dlg include "resource.fd" bRet = DLGINIT(IDD_BADTOPO, dlg) iRet = DlgModal(dlg) if(iRet == IDOK) then DropOrNot = .true. else DropOrNot = .false. end if call DlgUninit(dlg) end subroutine BadTopoDlg ! ! Topology error dialog ! Bad topology, back to initial node before linking to all boundary nodes ! subroutine BadTopoDlg2(Boxsize) use dflib use dflogm use dfwin use global implicit none real Boxsize logical(4) bRet integer(4) iRet integer maxsize character(len=1024) szbuffer logical isnumber type(dialog) dlg include "resource.fd" maxsize = 1024 iRet = LoadString(GetModuleHandle(NULL), IDS_String5, szbuffer, maxsize) bRet = DLGINIT(IDD_BADTOPO2, dlg) bRet = DLGSET(dlg, IDC_BADTOPO2_STATIC, szbuffer) msg = '0.1'C bRet = DLGSETCHAR(dlg, IDC_BADTOPO2_EDIT, msg) iRet = DlgModal(dlg) bRet = DLGGETCHAR(dlg, IDC_BADTOPO2_EDIT, msg) CALL Repair_String(msg) if(IsNumber(msg)) then read(msg, *) Boxsize if((Boxsize < 0).or.(Boxsize > 10.0)) then boxsize = 0.1 end if else call error8('0.1') Boxsize = 0.1 ! default degree of arc end if call DlgUninit(dlg) end subroutine BadTopoDlg2 ! ! Close thread upon normal ending of thread work ! Note: Different from OnThreadEnd, here one more button("CLOSE") is added ! Thus status needs to be adjusted as well. ! subroutine OnThreadEnd1(Dlg) use dflogm use dfwin USE STUFF type(dialog) Dlg include "resource.fd" iDummy = DlgSet(Dlg, IDC_BUTTON_STOP, .FALSE., DLG_ENABLE) iDummy = DlgSet(Dlg, IDC_BUTTON_RUN, .TRUE., DLG_ENABLE) iDummy = DlgSet(Dlg, IDCANCEL, .TRUE., DLG_ENABLE) iDummy = CloseHandle(hThread) end subroutine OnThreadEnd1 ! ! close thread upon ABNORMAL ending of thread work! ! subroutine OnThreadEnd2(Dlg) use dflogm use dfwin use stuff type(dialog) dlg include "resource.fd" iDummy = DlgSet(Dlg, IDC_BUTTON_STOP, .FALSE., DLG_ENABLE) iDummy = DlgSet(Dlg, IDC_BUTTON_RUN, .FALSE., DLG_ENABLE) iDummy = DlgSet(Dlg, IDCANCEL, .TRUE., DLG_ENABLE) iDummy = CloseHandle(hThread) end subroutine OnThreadEnd2