fortran66のブログ

fortran について書きます。

グラフィック用モジュール uhoplot

必要なモジュール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用グラフィックルーチンを参考にしました。

*1:指定し忘れてもそれなりに動くようですが、多分良くないのではと?

*2:いくつかのマルチスレッド用ルーチン。

*3:コンソール窓のハンドルを取るルーチン。