! ! Contains: ! Subroutines: ! ThreadDlg1 ! OnRun ! OnStop ! BadTopoDlg ! BadTopoDlg2 ! OnThreadEnd1 ! OnThreadEnd2 ! Functions: ! PerimTest ! ! ! ! ! ! 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),POINTER:: NULL_SA 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, idThread, iDummy TYPE (T_SECURITY_ATTRIBUTES),POINTER:: NULL_SA 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 hThread = CreateThread(NULL_SA, 0, LOC(PerimTest), LOC(Dlg), 0, LOC(idThread)) ! 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 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 !Reenable buttons iDummy = DlgSet(Dlg, IDC_BUTTON_RUN, .TRUE., DLG_ENABLE) iDummy = DlgSet(Dlg, ID, .FALSE., DLG_ENABLE) iDummy = DlgSet(Dlg, IDCANCEL, .TRUE., DLG_ENABLE) !! sending 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 integer(4) i, ie, je, jf1, je1 integer(4) NCOND, NDONE, NLEFT, Kfault, Kele integer(4) n, n1, n2, node integer(4) k, percent real per0(3), tempvec(3), tempv2(3), tempv3(3) real Alpha, Beta, Gamma, lon, lat real Boxhalf, SolidAngle, rpercent 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) !! ----- Check for isolated nodes --------- droploose = .false. i=1 1 write(msg,"('Checking that all nodes belong to some element...', I5)") i 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 anormal case call OnThreadEnd2(Dlg) 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 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) write(msg,"(I6, ' nodes found', I5, '% of search completed.')") NCOND, percent 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) 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) return end if end do end if percent = real(NDONE)/real(NCOND)*100.0 write(msg,"(I6, ' 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) 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 sterradians(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.D0 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 sterradians(tempvec, tempv2, tempv3, SolidAngle) sumarea = sumarea + DBLE(SolidAngle) 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.D0).or.(sumarea < 0.D0)) 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 x= real(within) y= real(sumarea) if(x==y) then msg = 'Areas agree, within expected precision' iDummy = DlgSet(Dlg, IDC_DIALOG2_TEXT4, trim(msg) // CHAR(0), DLG_TITLE) else rpercent = 100*abs(x-y)/y write(msg,"('Discrepancy is ', SP, 1P, E9.2, 0P, ' or ', F8.3,'%')") x-y, rpercent iDummy = DlgSet(Dlg, IDC_DIALOG2_TEXT4, trim(msg) // CHAR(0), DLG_TITLE) ! delay the discrepancy information a bit call sleepqq(2000) write(msg,"('Check for overlapped or missing elements with VIEWGAP')") iDummy = DlgSet(Dlg, IDC_DIALOG2_TEXT4, 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 ANOMAL 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