Intel Fortran コンパイラの version が上がるうちに 64bit でコンパイルできなくなっていたのですが、一部 Windows API 呼び出しを修正することで 32/64bit 双方に対応するようにしました。
CreateWindowEx を CreateWindow に修正。
wc%lpszClassName = transfer(c_loc(ClassName) , 0_LPCSTR)
wc%lpfnWndProc = transfer(c_funloc(MainWndProc), 0_LPCSTR) ! CALLBACK procedure name
hWndMain = CreateWindow( ClassName, & ....
...... transfer(c_loc(win32), 0_LPVOID) )
integer(INT_PTR_KIND()) :: stack = 0
wnd%hThread = CreateThread(NULL, stack, Thread_Proc, NULL, CREATE_SUSPENDED, wnd%id) 等の変数を暗黙に32bit長に変換していたものを、適宜32/64bit長になるようにしました。
H28.4 Lorenz の綴りが間違っていたので直しておきますｗ
ソース・プログラム
module m_oop implicit none type :: t_rgb integer :: ir, ig, ib end type t_rgb type :: t_win integer :: nx, ny end type t_win type :: t_view real :: x0, x1, y0, y1 end type t_view type, abstract :: t_device character(len = 80) :: title = 'Plotter' type (t_win ) :: win = t_win (640, 480) type (t_view) :: view = t_view(0.0, 1.0, 0.0, 1.0) contains procedure (device_on ), deferred, pass :: on procedure (device_off ), deferred, pass :: off procedure (device_show), deferred, pass :: show procedure (device_pen ), deferred, pass :: pen generic :: lineTo => lineTo_i, lineTo_r generic :: moveTo => moveTo_i, moveTo_r generic :: dot => dot_i , dot_r generic :: text => text_i , text_r procedure (device_lineTo_i), deferred, pass, private :: lineTo_i procedure (device_lineTo_r), deferred, pass, private :: lineTo_r procedure (device_moveTo_i), deferred, pass, private :: moveTo_i procedure (device_moveTo_r), deferred, pass, private :: moveTo_r procedure (device_dot_i ), deferred, pass, private :: dot_i procedure (device_dot_r ), deferred, pass, private :: dot_r procedure (device_text_i ), deferred, pass, private :: text_i procedure (device_text_r ), deferred, pass, private :: text_r end type t_device abstract interface subroutine device_on(self) import :: t_device class(t_device), intent(in out) :: self end subroutine device_on subroutine device_off(self) import :: t_device class(t_device), intent(in) :: self end subroutine device_off subroutine device_show(self) import :: t_device class(t_device), intent(in) :: self end subroutine device_show subroutine device_pen(self, line_width, rgb) import :: t_device, t_rgb class(t_device), intent(in out) :: self integer, intent(in), optional :: line_width type (t_rgb), intent(in), optional :: rgb end subroutine device_pen subroutine device_lineTo_i(self, ix, iy) import :: t_device class(t_device), intent(in) :: self integer, intent(in) :: ix, iy end subroutine device_lineTo_i subroutine device_moveTo_i(self, ix, iy) import :: t_device class(t_device), intent(in) :: self integer, intent(in) :: ix, iy end subroutine device_moveTo_i subroutine device_lineTo_r(self, x, y) import :: t_device class(t_device), intent(in) :: self real, intent(in) :: x, y end subroutine device_lineTo_r subroutine device_moveTo_r(self, x, y) import :: t_device class(t_device), intent(in) :: self real, intent(in) :: x, y end subroutine device_moveTo_r subroutine device_dot_i(self, ix, iy, rgb) import :: t_device, t_rgb class(t_device), intent(in) :: self integer, intent(in) :: ix, iy type (t_rgb), intent(in) :: rgb end subroutine device_dot_i subroutine device_dot_r(self, x, y, rgb) import :: t_device, t_rgb class(t_device), intent(in) :: self real , intent(in) :: x, y type (t_rgb), intent(in) :: rgb end subroutine device_dot_r subroutine device_text_i(self, ix, iy, txt, rgb, ifontsize, ifontdirection) import :: t_device, t_rgb class(t_device) :: self integer :: ix, iy character (LEN = *) :: txt type (t_rgb), optional :: rgb integer , optional :: ifontsize, ifontdirection intent(in) :: self, ix, iy, txt, rgb, ifontsize, ifontdirection end subroutine device_text_i subroutine device_text_r(self, x, y, txt, rgb, ifontsize, ifontdirection) import :: t_device, t_rgb class(t_device) :: self real :: x, y character (LEN = *) :: txt type (t_rgb), optional :: rgb integer , optional :: ifontsize, ifontdirection intent(in) :: self, x, y, txt, rgb, ifontsize, ifontdirection end subroutine device_text_r end interface end module m_oop module m_win32 use, intrinsic :: iso_c_binding use ifwina use ifwinty use ifmt, only : RTL_CRITICAL_SECTION use m_oop implicit none type :: t_wnd integer (LPINT) :: hThread = 0 integer (LPDWORD):: id = 0 integer (HANDLE) :: hWnd = 0 integer (HANDLE) :: hDC = 0 integer (HANDLE) :: hPen = 0 end type t_wnd type, extends(t_device) :: t_win32 integer , private :: line_width = 1 type (t_rgb), private :: rgb = t_rgb(0, 0, 0) type (t_wnd), private :: wnd = t_wnd(0, 0, 0, 0, 0) type (RTL_CRITICAL_SECTION), private :: CriticalSection = RTL_CRITICAL_SECTION(0,0,0,0,0,0) contains procedure, pass :: on => gr_on procedure, pass :: off => gr_off procedure, pass :: show => gr_show procedure, pass :: pen => gr_pen procedure, pass :: lineTo_i => gr_lineTo_i procedure, pass :: lineTo_r => gr_lineTo_r procedure, pass :: moveTo_r => gr_moveTo_r procedure, pass :: moveTo_i => gr_moveTo_i procedure, pass :: dot_i => gr_dot_i procedure, pass :: dot_r => gr_dot_r procedure, pass :: text_i => gr_text_i procedure, pass :: text_r => gr_text_r end type t_win32 type (c_ptr) :: c_p ! not used as a variable: mold for transfer function integer, save :: nwin = 0 integer (DWORD), save :: iThreadPrivate_wnd = 0 integer (DWORD), save :: iThreadPrivate_cri = 0 type (RTL_CRITICAL_SECTION), save :: CriticalSection_g contains !-------------------------------------------------------------------------------- integer(LRESULT) function WinMain( hInstance, nCmdShow, win32 ) implicit none integer (HANDLE), intent(in) :: hInstance integer (SINT) , intent(in) :: nCmdShow type (t_win32) , intent(in) :: win32 type (T_WNDCLASS) :: wc type (T_MSG) :: mesg integer (HANDLE) :: hWndMain integer (BOOL) :: iretb character (LEN = 256) :: ClassName = 'Fortran'//char(0) integer :: iwindow_frame_x, iwindow_frame_y type (T_RTL_CRITICAL_SECTION), pointer :: lpCriticalSection_l logical, save :: first = .true. ! iretb = TlsSetValue(iThreadPrivate_Wnd, loc(win32%wnd)) call c_f_pointer(c_loc(win32%CriticalSection), lpCriticalSection_l) call InitializeCriticalSection( lpCriticalSection_l ) iretb = TlsSetValue(iThreadPrivate_Cri, loc(lpCriticalSection_l)) ! ! Init Main window iwindow_frame_x = 2 * GetSystemMetrics(SM_CXFIXEDFRAME) !side line = 6, title bar = 25 iwindow_frame_y = 2 * GetSystemMetrics(SM_CYFIXEDFRAME) + GetSystemMetrics(SM_CYCAPTION) ! if (first) then WinMain = -1 ! Error code wc%lpszClassName = transfer(c_loc(ClassName) , 0_LPCSTR) wc%lpfnWndProc = transfer(c_funloc(MainWndProc), 0_LPCSTR) ! CALLBACK 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 ! initialize window first = .false. end if ! Init instance WinMain = -2 ! Error code hWndMain = CreateWindow( ClassName, & trim(win32%title)//char(0), & int(ior(WS_OVERLAPPED, WS_SYSMENU)), & CW_USEDEFAULT, CW_USEDEFAULT, & win32%win%nx + iwindow_frame_x, & win32%win%ny + iwindow_frame_y, & 0, 0, & hInstance, & transfer(c_loc(win32), 0_LPVOID) ) 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 ! call c_f_pointer(transfer(TlsGetValue(iThreadPrivate_Cri), c_p), lpCriticalSection_l) call DeleteCriticalSection( lpCriticalSection_l ) return end function WinMain !------------------------------------------------------------------------------------- integer (LRESULT) function MainWndProc( hWnd, mesg, wParam, lParam ) !DEC$ ATTRIBUTES STDcall, DECORATE, ALIAS : 'MainWndProc' :: MainWndProc 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 ! type (t_wnd) , pointer :: wnd type (T_RTL_CRITICAL_SECTION), pointer :: lpCriticalSection_l type (T_RTL_CRITICAL_SECTION), pointer :: lpCriticalSection_g ! MainWndProc = 0 call c_f_pointer(c_loc(CriticalSection_g), lpCriticalSection_g) select case ( mesg ) case (WM_CREATE) call EnterCriticalSection( lpCriticalSection_g ) call c_f_pointer(transfer(TlsGetValue(iThreadPrivate_Cri), c_p), lpCriticalSection_l) call EnterCriticalSection( lpCriticalSection_l ) call c_f_pointer(transfer(TlsGetValue(iThreadPrivate_Wnd), c_p), wnd) ! LOC(wnd) = TlsGetValue(iThreadPrivate_Wnd) wnd%hWnd = hWnd hDC = GetDC(hWnd) wnd%hDC = CreateCompatibleDC(hDC) iretb = GetClientRect(hWnd, rc) hBmp = CreateCompatibleBitmap(hDC, rc%right - rc%left, rc%bottom - rc%top) 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) call LeaveCriticalSection( lpCriticalSection_l ) call LeaveCriticalSection( lpCriticalSection_g ) case (WM_DESTROY) call EnterCriticalSection( lpCriticalSection_g ) call c_f_pointer(transfer(TlsGetValue(iThreadPrivate_Cri), c_p), lpCriticalSection_l) call EnterCriticalSection( lpCriticalSection_l ) call c_f_pointer(transfer(TlsGetValue(iThreadPrivate_Wnd), c_p), wnd) iretb = DeleteObject( wnd%hDC ) call PostQuitMessage( 0 ) call LeaveCriticalSection( lpCriticalSection_l ) call LeaveCriticalSection( lpCriticalSection_g ) case (WM_PAINT) call EnterCriticalSection( lpCriticalSection_g ) call c_f_pointer(transfer(TlsGetValue(iThreadPrivate_Cri), c_p), lpCriticalSection_l) call EnterCriticalSection( lpCriticalSection_l ) call c_f_pointer(transfer(TlsGetValue(iThreadPrivate_Wnd), c_p), wnd) 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( lpCriticalSection_l ) call LeaveCriticalSection( lpCriticalSection_g ) case (WM_RBUTTONUP) call EnterCriticalSection( lpCriticalSection_g ) call c_f_pointer(transfer(TlsGetValue(iThreadPrivate_Cri), c_p), lpCriticalSection_l) call EnterCriticalSection( lpCriticalSection_l ) call c_f_pointer(transfer(TlsGetValue(iThreadPrivate_Wnd), c_p), wnd) iretb = DeleteObject( wnd%hDC ) call PostQuitMessage( 0 ) call LeaveCriticalSection( lpCriticalSection_l ) call LeaveCriticalSection( lpCriticalSection_g ) case default MainWndProc = DefWindowProc( hWnd, mesg, wParam, lParam ) end select return end function MainWndProc !------------------------------------------------------------------------------------- subroutine gr_on(self) use IFMT, only : CreateThread ! multithread module class(t_win32), intent(in out) :: self integer (BOOL) :: iretb integer (HANDLE) :: hBmp integer(INT_PTR_KIND()) :: stack = 0 type (T_RECT) :: rc type (T_RTL_CRITICAL_SECTION), pointer :: lpCriticalSection_g associate(wnd => self%wnd) call c_f_pointer(c_loc(CriticalSection_g), lpCriticalSection_g) if (nwin == 0) then iThreadPrivate_Wnd = TlsAlloc() iThreadPrivate_Cri = TlsAlloc() call InitializeCriticalSection( lpCriticalSection_g ) end if nwin = nwin + 1 wnd%hThread = CreateThread(NULL, stack, Thread_Proc, NULL, CREATE_SUSPENDED, wnd%id) iretb = SetThreadPriority(wnd%hThread, THREAD_PRIORITY_BELOW_NORMAL) iretb = ResumeThread(wnd%hThread) call sleep(50) ! 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) end associate return contains integer (LONG) function Thread_Proc(lp_ThreadParameter) !DEC$ ATTRIBUTES STDcall, decorate, ALIAS:"Thread_Proc" :: Thread_Proc integer (LPINT), intent(in) :: lp_ThreadParameter integer (HANDLE) :: hInst hInst = GetModuleHandle(NULL) Thread_Proc = WinMain(hInst, SW_SHOWNORMAL, self) return end function Thread_Proc end subroutine gr_on !------------------------------------------------------------------------------------- subroutine gr_off(self) class(t_win32), intent(in) :: self integer (BOOL) :: iretb integer (DWORD) :: iwait type (T_RTL_CRITICAL_SECTION), pointer :: lpCriticalSection_g associate(wnd => self%wnd) iwait = INFINITE iretb = InvalidateRect(wnd%hWnd, NULL, FALSE) iretb = DeleteObject(wnd%hPen) iretb = WaitForSingleObject(wnd%hThread, iwait) iretb = CloseHandle(wnd%hThread) iretb = PostMessage(wnd%hWnd, WM_DESTROY, NULL, NULL) nwin = nwin - 1 if (nwin == 0) then iretb = TlsFree(iThreadPrivate_Wnd) iretb = TlsFree(iThreadPrivate_Cri) call c_f_pointer(c_loc(CriticalSection_g), lpCriticalSection_g) call DeleteCriticalSection( lpCriticalSection_g ) end if end associate return end subroutine gr_off !------------------------------------------------------------------------------------- subroutine gr_show(self) class(t_win32), intent(in) :: self type (T_RTL_CRITICAL_SECTION), pointer :: lpCriticalSection_l integer (BOOL):: iretb associate(wnd => self%wnd) call c_f_pointer(c_loc(self%CriticalSection), lpCriticalSection_l) call EnterCriticalSection( lpCriticalSection_l ) iretb = InvalidateRect(wnd%hWnd, NULL, FALSE) call LeaveCriticalSection( lpCriticalSection_l ) end associate return end subroutine gr_show !------------------------------------------------------------------------------------- subroutine gr_pen(self, line_width, rgb) class(t_win32), intent(in out) :: self integer, intent(in), optional :: line_width type (t_rgb), intent(in), optional :: rgb type (T_RTL_CRITICAL_SECTION), pointer :: lpCriticalSection_l integer (BOOL) :: iretb associate( rgb_ => self%rgb, line_width_ => self%line_width, wnd => self%wnd ) if ( present(rgb) ) rgb_ = rgb if ( present(line_width) ) line_width_ = line_width call c_f_pointer(c_loc(self%CriticalSection), lpCriticalSection_l) call EnterCriticalSection( lpCriticalSection_l ) iretb = DeleteObject(wnd%hPen) wnd%hPen = CreatePen(PS_SOLID, line_width_, irgb(rgb_)) iretb = SelectObject(wnd%hDC, wnd%hPen) iretb = MoveToEx(wnd%hDC, 0, 0, NULL) call LeaveCriticalSection( lpCriticalSection_l ) end associate return end subroutine gr_pen !---------------------------------------------------------------- integer function irgb(rgb) type(t_rgb), intent(in) :: rgb irgb = rgb%ir + (rgb%ig + (rgb%ib * 256)) * 256 return end function irgb !---------------------------------------------------------------- subroutine gr_moveTo_i(self, ix, iy) class (t_win32), intent(in) :: self integer , intent(in) :: ix, iy type (T_RTL_CRITICAL_SECTION), pointer :: lpCriticalSection_l integer (BOOL):: iretb associate(wnd => self%wnd) call c_f_pointer(c_loc(self%CriticalSection), lpCriticalSection_l) call EnterCriticalSection( lpCriticalSection_l ) iretb = MoveToEx(wnd%hDC, ix, iy, NULL) call LeaveCriticalSection( lpCriticalSection_l ) end associate return end subroutine gr_moveTo_i !---------------------------------------------------------------- subroutine gr_lineTo_i(self, ix, iy) class (t_win32), intent(in) :: self integer , intent(in) :: ix, iy type (T_RTL_CRITICAL_SECTION), pointer :: lpCriticalSection_l integer (BOOL):: iretb associate(wnd => self%wnd) call c_f_pointer(c_loc(self%CriticalSection), lpCriticalSection_l) call EnterCriticalSection( lpCriticalSection_l ) iretb = LineTo(wnd%hDC, ix, iy) call LeaveCriticalSection( lpCriticalSection_l ) end associate return end subroutine gr_lineTo_i !------------------------------------------------------------------------------------- subroutine gr_dot_i(self, ix, iy, rgb) class (t_win32), intent(in) :: self integer , intent(in) :: ix, iy type (t_rgb) , intent(in) :: rgb type (T_RTL_CRITICAL_SECTION), pointer :: lpCriticalSection_l integer (BOOL):: iretb associate(wnd => self%wnd) call c_f_pointer(c_loc(self%CriticalSection), lpCriticalSection_l) call EnterCriticalSection( lpCriticalSection_l ) iretb = SetPixel(wnd%hDC, ix, iy, irgb(rgb)) call LeaveCriticalSection( lpCriticalSection_l ) end associate return end subroutine gr_dot_i !---------------------------------------------------------------- subroutine gr_text_i(self, ix, iy, txt, rgb, ifontsize, ifontdirection) class (t_win32) :: self integer :: ix, iy character (LEN = *) :: txt type (t_rgb), optional :: rgb integer , optional :: ifontsize, ifontdirection intent(in) :: self, ix, iy, txt, rgb, ifontsize, ifontdirection integer (BOOL) :: iretb integer (HANDLE) :: hFont integer :: kfontsize, kfontdirection type (T_RTL_CRITICAL_SECTION), pointer :: lpCriticalSection_l associate(wnd => self%wnd) if ( present(rgb) ) iretb = SetTextColor(wnd%hDC, irgb(rgb)) if ( present(ifontsize) ) then kfontsize = ifontsize else kfontsize = 10 end if if ( present(ifontdirection) ) then kfontdirection = ifontdirection else kfontdirection = 0 end if call c_f_pointer(c_loc(self%CriticalSection), lpCriticalSection_l) call EnterCriticalSection( lpCriticalSection_l ) 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( lpCriticalSection_l ) end associate return end subroutine gr_text_i !---------------------------------------------------------------- subroutine gr_text_r(self, x, y, txt, rgb, ifontsize, ifontdirection) class (t_win32) :: self real :: x, y character (LEN = *) :: txt type (t_rgb), optional :: rgb integer , optional :: ifontsize, ifontdirection intent(in) :: self, x, y, txt, rgb, ifontsize, ifontdirection integer :: ix, iy call gr_xyToixy(self, x, y, ix, iy) call gr_text_i(self, ix, iy, txt, rgb, ifontsize, ifontdirection) return end subroutine gr_text_r !---------------------------------------------------------------- subroutine gr_xyToixy(self, x, y, ix, iy) class (t_win32), intent(in ) :: self real , intent(in ) :: x, y integer , intent(out) :: ix, iy associate (v => self%view, w => self%win) ix = NINT( (x - v%x0) / (v%x1 - v%x0) * w%nx ) iy = -NINT( (y - v%y0) / (v%y1 - v%y0) * w%ny ) + w%ny end associate return end subroutine gr_xyToixy !------------------------------------------------------------------------------------- subroutine gr_moveTo_r(self, x, y) class (t_win32), intent(in) :: self real , intent(in) :: x, y integer :: ix, iy call gr_xyToixy(self, x, y, ix, iy) call gr_moveTo_i(self, ix, iy) return end subroutine gr_moveTo_r !------------------------------------------------------------------------------------- subroutine gr_lineTo_r(self, x, y) class (t_win32), intent(in) :: self real , intent(in) :: x, y integer :: ix, iy call gr_xyToixy(self, x, y, ix, iy) call gr_lineTo_i(self, ix, iy) return end subroutine gr_lineTo_r !------------------------------------------------------------------------------------- subroutine gr_dot_r(self, x, y, rgb) class (t_win32), intent(in) :: self real , intent(in) :: x, y type (t_rgb) , intent(in) :: rgb integer :: ix, iy call gr_xyToixy(self, x, y, ix, iy) call gr_dot_i(self, ix, iy, rgb) return end subroutine gr_dot_r end module m_win32 module m_plot use m_win32 implicit none private public :: t_device, t_win32 public :: t_rgb, t_win, t_view end module m_plot
module m_mandel implicit none integer, private, parameter :: kd = SELECTED_REAL_KIND(15) contains pure elemental integer function imandel(z) complex(kd), intent(in) :: z complex(kd) :: c c = (0.0_kd, 0.0_kd) do imandel = 150, 1, -1 if (abs(c) > 2.0_kd) exit c = c * c - z end do return end function imandel end module m_mandel module m_jacobi implicit none contains subroutine laplace(v) real, intent(out) :: v(-50:50, -50:50) logical :: mask(lbound(v, 1):ubound(v, 1), lbound(v, 2):ubound(v, 2)) integer :: i, j, iter mask = .true. mask(-10, -5:5) = .false. ! static voltage mask( 10, -5:5) = .false. v = 0.0 v(-10, -5:5) = 10.0 v( 10, -5:5) = -10.0 ! do iter = 1, 200 forall (i = lbound(v, 1) + 1:ubound(v, 1) - 1, j = lbound(v, 2) + 1:ubound(v, 2) - 1, mask(i, j)) v(i, j) = 0.25 * ( v(i - 1, j) + v(i + 1, j) + v(i, j - 1) + v(i, j + 1) ) end forall end do return end subroutine laplace end module m_jacobi !================================================================== program Mandel use m_plot use m_mandel use m_jacobi implicit none integer, parameter :: kd = SELECTED_REAL_KIND(15) integer, parameter :: m = 1000 integer :: nwinx = 750, nwiny = 750 integer :: i, j, k, imax, jmax, maxiter, icount, ix, iy real (kd) :: xmin, xmax, ymin, ymax real (kd) :: xmin1, xmax1, ymin1, ymax1 real (kd) :: x, y, z, dx, dy, dz, a, b, c, d, p real (kd) :: t0, t1 real :: v(-50:50, -50:50) integer, allocatable :: ic1(:, :), ic2(:, :) integer :: icol(0:m), it0, it1 real ::rx, ry, x0, x1, y0, y1, ax, ay, xx0, yy0, x00, y00, ddx, ddy integer :: nxd, nyd character(20) :: buf, fmt class(t_device), allocatable :: fig1, fig2, fig3, fig4, fig5, fig6 type(t_rgb), parameter :: rgb_black = t_rgb(0, 0, 0) ! color set maxiter = 150 icol(0) = 0 ! black j = irgb(255, 255, 255) do i = maxiter, 1, -1 icol(i) = j if (j > 1) j = j - irgb(255, 255, 255) / maxiter end do ! print *, 'Fig.1 start' xmin = 1.10950d0 xmax = 1.10951d0 ymin = 0.24758d0 ymax = 0.24759d0 allocate( fig1, source = t_win32('Mandelbrot 1', t_win(nwinx, nwiny), t_view(xmin, xmax, ymin, ymax)) ) allocate( ic1(0:nwinx, 0:nwiny) ) call system_clock(it0) call cpu_time(t0) do concurrent (i = 0:nwinx, j = 0:nwiny) x = xmin + i * (xmax - xmin) / nwinx y = ymin + j * (ymax - ymin) / nwiny ic1(i, j) = imandel(cmplx(x, y, kd)) end do call cpu_time(t1) call system_clock(it1) print *, ' do concurrent time =', t1 - t0, it1 - it0 ! ! print *, 'Fig.2 start' xmin = -2.0d0 xmax = 2.0d0 ymin = -2.0d0 ymax = 2.0d0 ! allocate( fig2, source = t_win32('Mandelbrot 2', t_win(nwinx, nwiny), t_view(xmin, xmax, ymin, ymax)) ) allocate( ic2(0:nwinx, 0:nwiny) ) call system_clock(it0) call cpu_time(t0) do concurrent (i = 0:nwinx, j = 0:nwiny) x = xmin + i * (xmax - xmin) / nwinx y = ymin + j * (ymax - ymin) / nwiny ic2(i, j) = imandel(cmplx(x, y, kd)) end do call cpu_time(t1) call system_clock(it1) print *, ' do concurrent time =', t1 - t0, it1 - it0 ! call fig1%on() call fig2%on() pause do i = 0, nwinx do j = 0, nwiny rx = xmin + i * (xmax - xmin) / nwinx ry = ymin + j * (ymax - ymin) / nwiny call fig1%dot( i, j, to_rgb(icol(ic1(i, j))) ) call fig2%dot(rx, ry, to_rgb(icol(ic2(i, j))) ) end do call fig1%show() call fig2%show() end do deallocate( ic1 ) deallocate( ic2 ) ! print *, 'Fig.3 start' allocate(fig3, source = t_win32('Lorenz attractor', t_win(800, 600))) call fig3%on() call fig3%pen(2, t_rgb(255, 125, 0)) a = 10.0d0 b = 28.0d0 c = 8.0d0 / 3.0d0 d = 0.01d0 x = 1.0d0 y = 1.0d0 z = 1.0d0 do k = 1, 3000 dx = a * (y - x) dy = x * (b - z) - y dz = x * y - c * z x = x + d * dx y = y + d * dy z = z + d * dz if (k < 100) call fig3%moveTo( INT(12 * (x + 30)), INT(12 * z) ) call fig3%lineTo( INT(12 * (x + 30)), INT(12 * z) ) call fig3%show() end do ! print *, 'Fig.4 start' allocate(fig4, source = t_win32('Chaos', t_win(640, 480))) call fig4%on() do ix = 1, 640 p = 0.3 x = ix * (3.0 - 1.5) / 640.0 + 1.5 do i = 1, 50 p = p + x * p * (1.0 - p) end do do i = 51, 100 y = p / 1.5 * 480.0 call fig4%dot(ix, 480 - INT(y), t_rgb(0, 255, 122)) p = p + x * p * (1 - p) end do call fig4%show() end do ! print *, 'Fig.5 start' allocate(fig5, source = t_win32('Laplace', t_win(1200, 600))) call fig5%on() call laplace(v) ! x-direction do i = lbound(v, 2), ubound(v, 2) ix = 600 + 10 * lbound(v, 2) + 2 * i iy = 300 - 3 * i call fig5%moveto(ix, iy) do j = lbound(v, 1), ubound(v, 1) ix = 600 + 10 * j + 2 * i iy = 300 - 3 * i - v(j, i) * 20 call fig5%lineto(ix, iy) end do end do ! y-direction do j = lbound(v, 1), ubound(v, 1) ix = 600 + 10 * j + 2 * lbound(v, 2) iy = 300 - 3 * lbound(v, 2) call fig5%moveto(ix, iy) do i = lbound(v, 2), ubound(v, 2) ix = 600 + 10 * j + 2 * i iy = 300 - 3 * i - v(j, i) * 20 call fig5%lineto(ix, iy) end do end do call fig5%show() print *, 'Fig.6 start' x0 = 0.0 x1 = 23.0 y0 = -1.0 y1 = 1.2 ax = 5.0 !(x1 - x0) / 4 ay = 1.0 !(y1 - y0) / 2 nxd = 5 nyd = 2 xx0 = 0.0 yy0 = -1.0 ddx = (x1 - x0) * 0.333 ddy = (y1 - y0) * 0.333 xmin = x0 - ddx xmax = x1 + ddx ymin = y0 - ddy ymax = y1 + ddy allocate(fig6, source = t_win32('Fig6', t_win(800, 600), t_view(xmin, xmax, ymin, ymax))) call fig6%on() call fig6%pen(2) call fig6%moveTo(x0, y0) call fig6%lineTo(x0, y1) call fig6%lineTo(x1, y1) call fig6%lineTo(x1, y0) call fig6%lineTo(x0, y0) call fig6%moveTo(x0, 0.0) call fig6%lineTo(x1, 0.0) call fig6%text( x0 + ddx / 2, y1 + ddy / 2, ' Bessel function J0, J1', t_rgb(0, 0, 0), 40) call fig6%pen(1, t_rgb(0, 0, 0)) ! x-axis fmt = '(f5.1)' call fig6%text( x0 + ddx, y0 - ddy / 2, ' X-AXIS', t_rgb(0, 0, 0), 20) i = 0 x00 = xx0 + (ax / nxd) do i = 0, int( abs(x1 - x00) / (ax / nxd) ) rx = x00 + (ax / nxd) * i ry = y0 - ddy / 5 call fig6%moveTo(rx, y0) if (nint(mod(rx - xx0, ax)) == 0) then call fig6%pen(2) call fig6%moveTo(rx, y0) call fig6%lineTo(rx, ry) write(buf, fmt) rx call fig6%text(rx - ddx * 0.20, y0 - ddy / 4, buf, t_rgb(0, 0, 0), 15 ) else call fig6%pen(1) call fig6%moveTo(rx, y0 ) call fig6%lineTo(rx, y0 - ddy / 10) end if end do ! y-axis fmt = '(f5.1)' call fig6%text( x0 - ddx / 2, y0 + ddy, ' Y-AXIS', t_rgb(0, 0, 0), 20, 900) do i = 0, int( abs(y1 - y0) / (ay / nyd) ) rx = x0 - ddx / 10 ry = y0 + (ay / nyd) * i call fig6%moveTo(x0, ry) if (nint(mod(ry - yy0, ay)) == 0) then call fig6%pen(2) call fig6%moveTo(x0 , ry) call fig6%lineTo(x0 - ddx / 10, ry) write(buf, fmt) ry call fig6%text(rx - ddx / 8, ry - ddy * 0.25, buf, t_rgb(0, 0, 0), 12, 900 ) else call fig6%pen(1) call fig6%moveTo(x0 , ry) call fig6%lineTo(x0 - ddx / 20, ry) end if end do call fig6%moveTo(x0, y0) call fig6%pen(1) call fig6%moveTo(x0, BESSEL_J0(x0)) do i = 1, 100 rx = x0 + (x1 - x0) / 100 * i ry = BESSEL_J0(rx) ! Fortran2008 call fig6%lineTo(rx, ry) end do call fig6%pen(1, t_rgb(0, 0, 255)) call fig6%moveTo(x0, BESSEL_J1(x0)) do i = 1, 100 rx = x0 + (x1 - x0) / 100 * i ry = BESSEL_J1(rx) ! Fortran2008 call fig6%lineTo(rx, ry) end do call fig6%show() call fig6%off() deallocate(fig6) call fig1%off() deallocate(fig1) call fig2%off() deallocate(fig2) call fig3%off() deallocate(fig3) call fig4%off() deallocate(fig4) call fig5%off() deallocate(fig5) stop ' Normal End' contains integer function irgb(ir, ig, ib) integer, intent(in) :: ir, ig, ib irgb = ir + (ig + (ib * 256)) * 256 return end function irgb type(t_rgb) function to_rgb(i) integer, intent(in) :: i to_rgb%ir = mod(i, 256) to_rgb%ig = mod((i / 256), 256) to_rgb%ib = mod((i / 256) / 256, 256) return end function to_rgb end program Mandel
