SUBROUTINE PlanetaryGrid !Create a planetary F-E grid, while displaying a progress-bar along the bottom of the frame window USE DFLib USE DFWin USE DFLogm USE Global ! contains control parameter "nSlice" USE Icosahedron IMPLICIT NONE INTEGER(4) :: i, ie, je, m1, m2, m3, MaxRange, n, n1, n2, n3, s1 LOGICAL(4) :: beendone REAL(4) :: da, db, dc, fudge, r2, r2min, tempvec(3), tempv2(3), tempv3(3) !Additional local declarations associated with the progress-bar window: INTEGER(handle) :: hwndPB ! Handle of progress bar window. INTEGER(bool) :: bRet INTEGER(LRESULT) :: iRet INTEGER(LONG_PTR) :: lParam_range INTEGER(handle) :: hwndParent ! handle of parent window (which I will select as the top-level QuickWin frame window) INTEGER(UINT_PTR) :: step = 1 ! smallest increment of progress-bar movement will be one new element INTEGER(LONG_PTR) :: range_min = 0, range_max = 205 ! range_max will be set to (0.01 * peak expected value of numel) TYPE(T_RECT) :: rcClient ! ! Client area of parent window. INTEGER(4) :: cyVScroll; ! Height of scroll bar arrow, in client area of parent window. CALL SetStatusBar(0, '***BUSY***'C) ! Be sure that arrays are allocated: IF (.NOT.GridLoaded) THEN CALL CheckAllocate END IF CALL Make_Global_Grid(nslice) oldslice = nslice ! memory, in MODULE Global !At this point, planetary .feg should exist as a binary file in the current working folder, called Icosahedron.tmp. !Next, we have to read it in and fill the arrays (in Global): !Before starting real work, set up the progress-bar window: range_max = NINT(20.0 * (4**nslice) / 100.0) ! nslice comes from MODULE Global; it also controled MakeGlobalGrid, called just above. range_max = MAX(range_max, 1) ! don't risk any divide-by-zero errors deep inside Windows routines... lParam_range = ISHFT(range_max, 16) + range_min ! hi word, low word 16bit + 16bit !InitCommonControls() ! required for Windows 95 or earlier hwndParent = hFrame ! from MODULE Global bRet = GetClientRect(hwndParent, rcClient) cyVScroll = GetSystemMetrics(SM_CYVSCROLL) ! !Create a progress bar along the bottom of the client area of the parent window: hwndPB = CreateWindowEx( dwExStyle = 0, & ! 0 = WS_EX_LEFT (default) & lpClassName = PROGRESS_CLASS, & ! C-type documentation says "optional", but actually must be present! & lpWindowName = NULL, & ! C-type documentation says "optional", but actually must be present! & dwStyle = IOR(WS_CHILD, WS_VISIBLE), & & X = rcClient%left, & & Y = rcClient%bottom - cyVScroll, & & nWidth = rcClient%right, & & nHeight = cyVScroll, & & hWndParent = hwndParent, & ! C-type documentation says "optional", but actually must be present! & hMenu = NULL , & ! C-type documentation says "optional", but actually must be present! (0 or NULL are OK) & hInstance = hInst , & ! C-type documentation says "optional", but actually must be present! (from Global) & lpParam = NULL ) ! C-type documentation says "optional", but actually must be present! ! ! N.B. To control this progress-bar window, use: !FUNCTION SendMessage(hWnd, Msg, wParam, lParam) ! sendmessage interface for ref user32.f90 ! integer(LRESULT) :: SendMessage ! LRESULT ! integer(HANDLE) :: hWnd ! HWND hWnd ! integer(UINT) :: Msg ! UINT Msg ! integer(UINT_PTR) :: wParam ! WPARAM wParam ! integer(LONG_PTR) :: lParam ! LPARAM lParam !END FUNCTION ! ! Set the range and increment of the progress bar: iRet = SendMessage(hwndPB, PBM_SETRANGE, 0, lParam_range) iRet = SendMessage(hwndPB, PBM_SETSTEP, step, 0) !Begin actual work, translating from binary file to F-E grid in memory: OPEN(729, file='Icosahedron.tmp', status ='OLD', form ='UNFORMATTED') numnod = 0 numel = 0 ! grid in memory starts out empty nfl = 0 DO WHILE(.NOT.EOF(729)) READ(729) tempvec(1:3), tempv2(1:3), tempv3(1:3) fudge = 0.1 * (6.28318) / (5.0 * 2.0 ** nslice) ! locate (or create) nodes r2min = 3.E+10 ! "BIG" IF (numnod > 0) THEN !find closest existing node 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 END IF !Is closest existing node "close enough" to be treated as identical? IF (SQRT(r2min) < fudge) THEN n1 = n ELSE ! create a new node numnod = numnod + 1 GridLoaded = .true. IF (numnod == MXNODE) THEN CALL Error14('Node', MXNODE) RETURN END IF n1 = numnod EQCM(1:6, n1) = 0 nodeABG(1:3, n1)= tempvec(1:3) CALL DrawNode(inodecolor, n1) END IF ! 2nd node r2min = 3.E+10 DO i = 1, numnod da = nodeABG(1,i) - tempv2(1) db = nodeABG(2,i) - tempv2(2) dc = nodeABG(3,i) - tempv2(3) r2 = da*da + db*db + dc*dc IF (r2 0) THEN m1 = nodes(je, ie) m2 = nodes(MOD(je, 3) + 1, ie) m3 = nodes(MOD(je + 1, 3) + 1, ie) IF (((m2 == n2).and.(m3 == n3)).or.((m3 == n2).and.(m2 == n3))) THEN beendone = .TRUE. END IF IF (ie < numel) then s1 = ie + 1 GOTO 1 END IF END IF ! ie > 0 ! IF (beendone) THEN ! do nothing ELSE ! create new element: IF (numel == MXEL) THEN CALL Error14('Element', MXEL) RETURN END IF numel = numel + 1 nodes(1, numel) = n1 nodes(2, numel) = n2 nodes(3, numel) = n3 CALL CheckFlipped CALL DrawElement(ielecolor, numel) !--------------------------------------------------------------------------------------------------------------- ! Advance the current position of the progress bar by the increment, each time 100 new elements have been added: IF (MOD(numel, 100) == 0) iRet = SendMessage(hwndPB, PBM_STEPIT, 0, 0); !--------------------------------------------------------------------------------------------------------------- END IF END DO ! end of file CLOSE(729) ! finished gridding the whole planet! bRet = DestroyWindow(hwndPB) iRet = SetColorRGB(ifrontcolor) CALL SetStatusBar(0, 'Ready'C) CALL SetStatusBar(1, 'All Done ...'C) new_FEG_title_line = "[grid title line]" ! increment editing counter CALL IncreaseEditingCounter END SUBROUTINE PlanetaryGrid