途中経過メモ 過去のルーチン流用で乱れ気味。
コンソールプログラムから呼び出せて、コンソールで入出力しながら簡単な二次元グラフを描いてゆける最小限度の簡潔なサブルーチン集を作りたいです。
ソース・プログラム
Fortran2008 ではベッセル関数や誤差関数などが組み込み関数として加わります。Intel Fortran ではその機能が先取りされています。
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(4) 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'//char(0) 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)//char(0), & 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 (LRESULT) 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) iretb = DeleteObject( wnd%hDC ) call PostQuitMessage( 0 ) case default MainWndProc = DefWindowProc( hWnd, mesg, wParam, lParam ) end select return end function MainWndProc !------------------------------------------------------------------------------- integer (HANDLE) function get_DosHndl() implicit none interface function GetConsoleWindow() ! non-existent in IFORTxx.MOD !DEC$ ATTRIBUTES DEFAULT, STDcall, DECORATE, ALIAS:'GetConsoleWindow' :: GetConsoleWindow use ifwinty integer (HANDLE) :: GetConsoleWindow end function end interface get_DosHndl = GetConsoleWindow() return end function get_DosHndl !------------------------------------------------------------------------------------- end module uho_win !================================================================================= module uhoplot use uho_win contains !------------------------------------------------------------------------------------- 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 call EnterCriticalSection( loc(lpCriticalSection) ) iretb = InvalidateRect(wnd%hWnd, NULL, FALSE) call LeaveCriticalSection( loc(lpCriticalSection)) 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, ifontsize, ifontdirection) implicit none integer, intent(in) :: ix, iy character (LEN = *), intent(in) :: txt integer, intent(in), optional :: icol integer (BOOL) :: iretb integer (HANDLE) :: hFont integer, optional, intent(in) :: ifontsize, ifontdirection integer :: kfontsize, kfontdirection if ( present(icol) ) iretb = SetTextColor(wnd%hDC, icol) if ( present(ifontsize) ) then kfontsize = ifontsize else kfontsize = 10 end if if ( present(ifontdirection) ) then kfontdirection = ifontdirection else kfontdirection = 0 end if call EnterCriticalSection( loc(lpCriticalSection) ) iretb = SetBkMode(wnd%hDC, TRANSPARENT) hFont = CreateFont( kfontsize , 10 , kfontdirection , 0 ,FW_DONTCARE , FALSE , FALSE , FALSE , & ANSI_CHARSET , OUT_DEFAULT_PRECIS , & CLIP_DEFAULT_PRECIS , PROOF_QUALITY , & ior(FIXED_PITCH, FF_ROMAN) , NULL ) iretb = SelectObject(wnd%hdc , hFont) iretb = TextOut(wnd%hDC, ix, iy, txt, len_trim(txt)) iretb = SelectObject(wnd%hdc , GetStockObject(SYSTEM_FONT)) iretb = DeleteObject(hFont) 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 !Relative coordinate !------------------------------------------------------------------------------------- subroutine gr_axis(xmin, xmax, ymin, ymax) real, intent(in) :: xmin, xmax, ymin, ymax wnd%xmin = xmin wnd%xmax = xmax wnd%ymin = ymin wnd%ymax = ymax return end subroutine gr_axis !---------------------------------------------------------------- subroutine to_ixy(x, y, ix, iy) real , intent(in ) :: x, y integer, intent(out) :: ix, iy ix = int( wnd%nsize_x * (x - wnd%xmin) / (wnd%xmax - wnd%xmin) ) iy = -int( wnd%nsize_y * (y - wnd%ymin) / (wnd%ymax - wnd%ymin) ) + wnd%nsize_y return end subroutine to_ixy !---------------------------------------------------------------- subroutine gr_wdot(x, y, icol) real, intent(in) :: x, y integer, intent(in) :: icol integer :: ix, iy integer (BOOL):: iretb call to_ixy(x, y, ix, iy) call EnterCriticalSection( loc(lpCriticalSection) ) iretb = SetPixel(wnd%hDC, ix, iy, icol) call LeaveCriticalSection( loc(lpCriticalSection) ) return end subroutine gr_wdot !---------------------------------------------------------------- subroutine gr_wmove(x, y) real, intent(in) :: x, y integer (BOOL):: iretb integer :: ix, iy call to_ixy(x, y, ix, iy) call EnterCriticalSection( loc(lpCriticalSection) ) iretb = MoveToEx(wnd%hDC, ix, iy, NULL) call LeaveCriticalSection( loc(lpCriticalSection) ) return end subroutine gr_wmove !---------------------------------------------------------------- subroutine gr_wline(x, y) real, intent(in) :: x, y integer (BOOL):: iretb integer :: ix, iy call to_ixy(x, y, ix, iy) call EnterCriticalSection( loc(lpCriticalSection) ) iretb = LineTo(wnd%hDC, ix, iy) call LeaveCriticalSection( loc(lpCriticalSection) ) return end subroutine gr_wline !---------------------------------------------------------------- subroutine gr_wtext(x, y, text, icol, ifontsize, ifontdirection) real, intent(in) :: x, y character, intent(in) :: text*(*) integer, optional, intent(in) :: icol integer :: ix, iy integer (BOOL):: iretb integer, optional, intent(in) :: ifontsize, ifontdirection integer :: kfontsize, kfontdirection if ( present(icol) ) iretb = SetTextColor(wnd%hDC, icol) if ( present(ifontsize) ) then kfontsize = ifontsize else kfontsize = 10 end if if ( present(ifontdirection) ) then kfontdirection = ifontdirection else kfontdirection = 0 end if call to_ixy(x, y, ix, iy) call EnterCriticalSection( loc(lpCriticalSection) ) call gr_text(ix, iy, text, icol, kfontsize, kfontdirection) call LeaveCriticalSection( loc(lpCriticalSection) ) return end subroutine gr_wtext !---------------------------------------------------------------- end module uhoplot !===================================================================================== module plotter use uhoplot real :: xpen = 0.0, ypen = 0.0 contains !---------------------------------------------------------------- subroutine move(x, y) real, intent(in) :: x, y xpen = x ypen = y return end subroutine move !---------------------------------------------------------------- subroutine move_rel(dx, dy) real, intent(in) :: dx, dy xpen = xpen + dx ypen = ypen + dy return end subroutine move_rel !---------------------------------------------------------------- subroutine draw(x, y) real, intent(in) :: x, y call gr_wmove(xpen, ypen) call gr_wline(x , y ) xpen = x ypen = y call gr_show() return end subroutine draw !---------------------------------------------------------------- subroutine draw_rel(dx, dy) real, intent(in) :: dx, dy call gr_wmove(xpen, ypen) call gr_wline(xpen + dx, ypen + dy) xpen = xpen + dx ypen = ypen + dy call gr_show() return end subroutine draw_rel !---------------------------------------------------------------- end MODULE plotter !================================================================ program plot use plotter real, parameter :: sc = 1.0 / 3.0 ! scale real :: xmin, ymin, xmax, ymax ! width real :: x0, x1, y0, y1, dx, dy real :: x, y, ax, ay character(20) :: buf x0 = 0.0 x1 = 20.0 y0 = -1.0 y1 = 1.0 dx = (x1 - x0) * sc dy = (y1 - y0) * sc xmin = x0 - dx xmax = x1 + dx ymin = y0 - dy ymax = y1 + dy call gr_on('XY-plot', 640, 480) call gr_axis(xmin, xmax, ymin, ymax) call gr_pencol(0) call move(x0, y0) call draw(x0, y1) call draw(x1, y1) call draw(x1, y0) call draw(x0, y0) call move(x0, 0.0) call draw(x1, 0.0) call gr_wtext( x0 + dx / 2, y1 + dy / 2, 'Bessel function J0, J1', 0, 30) ax = (x1 - x0) / 4 ay = (y1 - y0) / 2 ! x-axis call gr_wtext( x0 + dx, y0 - dy / 2, ' X-AXIS', 0, 20) do i = 0, 4 x = x0 + i * ax y = y0 - dy / 5 call move(x, y0) if (mod(i, 2) == 0) then call draw(x, y) write(buf, '(F5.1)') x call gr_wtext(x - dx * 0.25, y0 - dy / 4, buf, 0, 15 ) else call draw(x, y0 - dy / 10) end if end do ! y-axis call gr_wtext( x0 - dx / 2, y0 + dy, ' Y-AXIS', 0, 20, 900) do i = 0, 2 x = x0 - dx / 10 y = y0 + i * ay call move(x0, y) call draw(x , y) write(buf, '(G9.2)') y call gr_wtext(x - dx / 5, y - dy * 0.35, buf, 0, 12, 900 ) end do x = x0 y = BESSEL_J0(x) ! Fortran2008 call move(x, y) do i = 1, 100 x = x0 + (x1 - x0) / 100 * i y = BESSEL_J0(x) ! Fortran2008 call draw(x, y) end do x = x0 y = BESSEL_J1(x) ! Fortran2008 call move(x, y) do i = 1, 100 x = x0 + (x1 - x0) / 100 * i y = BESSEL_J1(x) ! Fortran2008 call draw(x, y) end do call gr_off() stop end program plot
