必要なモジュール2つ。一つはグラフィック窓を開くため。もう一つは線などを描くため。
ビルド・オプションとしては、ライブラリをマルチスレッド用に指定する必要があります*1。
Intel Visual FortranのWindows用定義モジュールには、名前の二重定義があったり*2、定義が抜けていたり*3、たまに不都合なことがあるので、微妙に回避策を取る必要があります。
MODULE uho_win USE ifwina USE ifwinty USE ifmt, ONLY : RTL_CRITICAL_SECTION IMPLICIT NONE TYPE :: t_wnd INTEGER (HANDLE) :: hWnd INTEGER (HANDLE) :: hDC INTEGER (LPINT) :: hThread INTEGER :: id INTEGER (HANDLE) :: hPen CHARACTER (LEN = 80) :: title = 'Fortran Plot' INTEGER :: nsize_x = 320, nsize_y = 240 REAL :: xmin = 0.0, xmax = 1.0, ymin = 0.0, ymax = 1.0 END TYPE TYPE (t_wnd) :: wnd TYPE (RTL_CRITICAL_SECTION) :: lpCriticalSection CONTAINS !----------------------------------------------------------------------------------- INTEGER FUNCTION WinMain( hInstance, hPrevInstance, lpszCmdLine, nCmdShow, wnd) IMPLICIT NONE INTEGER (HANDLE), INTENT(IN) :: hInstance, hPrevInstance INTEGER (LPSTR) , INTENT(IN) :: lpszCmdLine INTEGER (SINT) , INTENT(IN) :: nCmdShow TYPE (t_wnd) , INTENT(IN OUT) :: wnd ! Variables LOGICAL, SAVE :: qfirst = .TRUE. TYPE (T_WNDCLASS) :: wc TYPE (T_MSG) :: mesg INTEGER (HANDLE) :: hWndMain INTEGER (BOOL) :: iretb CHARACTER (LEN = 256) :: ClassName = "Fortran"C INTEGER :: noffset_x, noffset_y !side line = 6, title bar = 25 ! Init Main window noffset_x = 2 * GetSystemMetrics(SM_CXFIXEDFRAME) noffset_y = 2 * GetSystemMetrics(SM_CYFIXEDFRAME) + GetSystemMetrics(SM_CYCAPTION) ! WinMain = -1 ! Error code IF (qfirst) THEN wc%lpszClassName = LOC(ClassName) wc%lpfnWndProc = LOC(MainWndProc) ! CALL BACK procedure name wc%style = IOR(CS_VREDRAW , CS_HREDRAW) wc%hInstance = hInstance wc%hIcon = NULL wc%hCursor = LoadCursor( NULL, IDC_ARROW ) wc%hbrBackground = ( COLOR_WINDOW + 1 ) IF (RegisterClass(wc) == 0) RETURN qfirst = .FALSE. END IF !Init instance WinMain = -2 ! Error code hWndMain = CreateWindowEx( 0, ClassName, & TRIM(wnd%title)//''C, & INT(IOR(WS_OVERLAPPED, WS_SYSMENU)), & CW_USEDEFAULT, CW_USEDEFAULT, & wnd%nsize_x + noffset_x, & wnd%nsize_y + noffset_y, & 0, & 0, & hInstance, & LOC(wnd) ) IF (hWndMain == 0) RETURN iretb = ShowWindow( hWndMain, nCmdShow ) iretb = UpdateWindow( hWndMain ) ! Message Loop DO WHILE ( GetMessage (mesg, NULL, 0, 0) ) iretb = TranslateMessage( mesg ) iretb = DispatchMessage( mesg ) END DO WinMain = mesg%wParam RETURN END FUNCTION WinMain !---------------------------------------------------------- INTEGER*4 FUNCTION MainWndProc( hWnd, mesg, wParam, lParam ) !DEC$ ATTRIBUTES STDCALL, DECORATE, ALIAS : 'MainWndProc' :: MainWndProc USE IFMT IMPLICIT NONE INTEGER (HANDLE) , INTENT(IN) :: hWnd INTEGER (UINT) , INTENT(IN) :: mesg INTEGER (fwParam), INTENT(IN) :: wParam INTEGER (flParam), INTENT(IN) :: lParam ! INTEGER (HANDLE) :: hDC, hBmp INTEGER (BOOL) :: iretb TYPE (T_PAINTSTRUCT) :: ps TYPE (T_RECT) :: rc ! MainWndProc = 0 SELECT CASE ( mesg ) CASE (WM_CREATE) hDC = GetDC(hWnd) iretb = GetClientRect(hWnd, rc) hBmp = CreateCompatibleBitmap(hDC, rc%right - rc%left, rc%bottom - rc%top) wnd%hWnd = hWnd wnd%hDC = CreateCompatibleDC(hDC) iretb = SelectObject(wnd%hDC, hBmp) iretb = PatBlt(wnd%hDC, 0, 0, rc%right - rc%left, rc%bottom - rc%top, WHITENESS) iretb = ReleaseDC(hWnd, hDC) iretb = DeleteObject(hBmp) CASE (WM_DESTROY) iretb = DeleteObject( wnd%hDC ) CALL PostQuitMessage( 0 ) CASE (WM_PAINT) CALL EnterCriticalSection(LOC(lpCriticalSection)) hDC = BeginPaint( wnd%hWnd, ps ) iretb = GetClientRect( wnd%hWnd, rc ) iretb = BitBlt(hDC, 0, 0, rc%right - rc%left, rc%bottom - rc%top, wnd%hDC, 0, 0, SRCCOPY) iretb = EndPaint( wnd%hWnd, ps ) CALL LeaveCriticalSection(LOC(lpCriticalSection)) CASE (WM_LBUTTONDOWN) WRITE(*, *) 'LBUTTON ', TRIM(wnd%title), wnd%hWnd CASE (WM_RBUTTONDOWN) WRITE(*, *) 'RBUTTON ', TRIM(wnd%title), wnd%hWnd CASE DEFAULT MainWndProc = DefWindowProc( hWnd, mesg, wParam, lParam ) END SELECT RETURN END FUNCTION MainWndProc !------------------------------------------------------------------------------------- END MODULE uho_win !=========================================================================================
以上のモジュールは、ほぼ最小限のウィンドウプログラムと同等で、コンソールプログラムから呼ばれたときにウィンドウを初期化して開きます。
以下のモジュールでは、開かれたウィンドウ上に、点を打ったり、線を引いたりします。
MODULE uhoplot USE uho_win CONTAINS !------------------------------------------------------------------------------------- INTEGER (HANDLE) FUNCTION get_DosHndl() IMPLICIT NONE INTERFACE FUNCTION GetConsoleWindow() ! non-existent in IFORTxx.MOD USE ifwinty INTEGER (HANDLE) :: GetConsoleWindow !DEC$ ATTRIBUTES DEFAULT, STDCALL, DECORATE, ALIAS:'GetConsoleWindow' :: GetConsoleWindow END FUNCTION END INTERFACE get_DosHndl = GetConsoleWindow() RETURN END FUNCTION get_DosHndl !------------------------------------------------------------------------------------- SUBROUTINE gr_on(text, nx, ny) USE IFMT ! multithread module IMPLICIT NONE CHARACTER (LEN = *), INTENT(IN), OPTIONAL :: text INTEGER , INTENT(IN), OPTIONAL :: nx, ny INTEGER (BOOL) :: iretb INTEGER (HANDLE) :: hBmp INTEGER (LPDWORD) :: id TYPE (T_RECT) :: rc IF (PRESENT(text)) wnd%title = TRIM(text) IF (PRESENT(nx) ) wnd%nsize_x = nx IF (PRESENT(ny) ) wnd%nsize_y = ny CALL InitializeCriticalSection(LOC(lpCriticalSection)) wnd%hThread = CreateThread(0, 0, Thread_Proc, LOC(wnd), CREATE_SUSPENDED, id) wnd%id = id iretb = SetThreadPriority(wnd%hThread, THREAD_PRIORITY_BELOW_NORMAL) iretb = ResumeThread(wnd%hThread) CALL Sleep(100) ! wait for Window initialization iretb = GetClientRect(wnd%hWnd, rc) hBmp = CreateCompatibleBitmap(wnd%hDC, rc%right - rc%left, rc%bottom - rc%top) iretb = SelectObject(wnd%hDC, hBmp) iretb = DeleteObject(hBmp) iretb = PatBlt(wnd%hDC, 0, 0, rc%right - rc%left, rc%bottom - rc%top, WHITENESS) wnd%hPen = CreatePen(PS_SOLID, 1, 0) RETURN END SUBROUTINE gr_on !------------------------------------------------------------------------------------- SUBROUTINE gr_off(isec) USE IFMT ! Module for multithread IMPLICIT NONE INTEGER (DWORD), INTENT(IN), OPTIONAL :: isec INTEGER (BOOL) :: iretb INTEGER (DWORD) :: iwait IF (PRESENT(isec)) THEN iwait = isec * 1000 ELSE iwait = INFINITE END IF CALL gr_show() ! iretb = DeleteObject(wnd%hPen) iretb = WaitForSingleObject(wnd%hThread, iwait) iretb = CloseHandle(wnd%hThread) iretb = PostMessage(wnd%hWnd, WM_DESTROY, NULL, NULL) wnd%hThread = NULL CALL DeleteCriticalSection(LOC(lpCriticalSection)) RETURN END SUBROUTINE gr_off !------------------------------------------------------------------------------------- INTEGER (LONG) FUNCTION Thread_Proc(lp_ThreadParameter) !DEC$ ATTRIBUTES STDCALL, ALIAS:"_thread_proc" :: Thread_Proc IMPLICIT NONE INTEGER (LPINT), INTENT(IN) :: lp_ThreadParameter INTEGER :: hInst TYPE (t_wnd) :: wnd POINTER (p_wnd, wnd) ! non-standard fortran p_wnd = lp_ThreadParameter hInst = GetModuleHandle(NULL) Thread_Proc = WinMain(hInst, NULL, NULL, SW_SHOWNORMAL, wnd) RETURN END FUNCTION Thread_Proc !------------------------------------------------------------------------------------- SUBROUTINE gr_dot(ix, iy, icol) IMPLICIT NONE INTEGER, INTENT(IN) :: ix, iy INTEGER, INTENT(IN) :: icol INTEGER (BOOL):: iretb CALL EnterCriticalSection(LOC(lpCriticalSection)) iretb = SetPixel(wnd%hDC, ix, iy, icol) CALL LeaveCriticalSection(LOC(lpCriticalSection)) RETURN END SUBROUTINE gr_dot !------------------------------------------------------------------------------------- SUBROUTINE gr_move(ix, iy) IMPLICIT NONE INTEGER, INTENT(IN) :: ix, iy INTEGER (BOOL):: iretb CALL EnterCriticalSection(LOC(lpCriticalSection)) iretb = MoveToEx(wnd%hDC, ix, iy, NULL) CALL LeaveCriticalSection(LOC(lpCriticalSection)) RETURN END SUBROUTINE gr_move !------------------------------------------------------------------------------------- SUBROUTINE gr_line(ix, iy) IMPLICIT NONE INTEGER, INTENT(IN) :: ix, iy INTEGER (BOOL):: iretb CALL EnterCriticalSection(LOC(lpCriticalSection)) iretb = LineTo(wnd%hDC, ix, iy) CALL LeaveCriticalSection(LOC(lpCriticalSection)) RETURN END SUBROUTINE gr_line !------------------------------------------------------------------------------------- SUBROUTINE gr_show() IMPLICIT NONE INTEGER (BOOL):: iretb iretb = InvalidateRect(wnd%hWnd, NULL, FALSE) RETURN END SUBROUTINE gr_show !------------------------------------------------------------------------------------- SUBROUTINE gr_pencol(icol) IMPLICIT NONE INTEGER, INTENT(IN) :: icol INTEGER :: iretb CALL EnterCriticalSection(LOC(lpCriticalSection)) iretb = DeleteObject(wnd%hPen) wnd%hPen = CreatePen(PS_SOLID, 1, icol) iretb = SelectObject(wnd%hDC, wnd%hPen) CALL LeaveCriticalSection(LOC(lpCriticalSection)) RETURN END SUBROUTINE gr_pencol !------------------------------------------------------------------------------------- SUBROUTINE gr_text(ix, iy, txt, icol) IMPLICIT NONE INTEGER, INTENT(IN) :: ix, iy CHARACTER (LEN = *), INTENT(IN) :: txt INTEGER, INTENT(IN), OPTIONAL :: icol INTEGER (BOOL):: iretb IF (PRESENT(icol)) iretb = SetTextColor(wnd%hDC, icol) CALL EnterCriticalSection(LOC(lpCriticalSection)) iretb = TextOut(wnd%hDC, ix, iy, txt, LEN_TRIM(txt)) CALL LeaveCriticalSection(LOC(lpCriticalSection)) RETURN END SUBROUTINE gr_text !------------------------------------------------------------------------------------- INTEGER FUNCTION irgb(ir, ig, ib) IMPLICIT NONE INTEGER, INTENT(IN) :: ir, ig, ib irgb = ir + (ig + (ib * 256)) * 256 RETURN END FUNCTION irgb !------------------------------------------------------------------------------------- END MODULE uhoplot !==========================================================================================|
この本の98用グラフィックルーチンを参考にしました。