Plotルーチンから非標準構文を取り除く
以前のバージョンでは、Fortran規格外の Cray Pointer を使っていたのですが、Fortran2003 の規格内のルーチンで書き直しました。
また、以前のものは微妙にスレッド競合が起きていて時々挙動がおかしかったので修正しました。
その他微妙な修正も含む途中メモ。
2-20 微妙にミス修正
ソース・コード
module m_oop implicit none type :: t_rgb integer :: ir, ig, ib end type t_rgb type, abstract :: t_device character(len = 80) :: title = 'Plotter' integer :: nsize_x = 640, nsize_y = 480 integer :: line_width = 1 type (t_rgb) :: rgb = t_rgb(0, 0, 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 procedure (device_lineTo), deferred, pass :: lineTo procedure (device_moveTo), deferred, pass :: moveTo procedure (device_dot ), deferred, pass :: dot procedure (device_text ), deferred, pass :: text 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(self, ix, iy) import :: t_device class(t_device), intent(in) :: self integer, intent(in) :: ix, iy end subroutine device_lineTo subroutine device_moveTo(self, ix, iy) import :: t_device class(t_device), intent(in) :: self integer, intent(in) :: ix, iy end subroutine device_moveTo subroutine device_dot(self, ix, iy, icol) import :: t_device, t_rgb class(t_device), intent(in) :: self integer, intent(in) :: ix, iy integer, intent(in) :: icol ! type (t_rgb), intent(in) :: rgb end subroutine device_dot subroutine device_text(self, ix, iy, txt, rgb, ifontsize, ifontdirection) import :: t_device, t_rgb class(t_device), intent(in) :: self integer, intent(in) :: ix, iy character (LEN = *), intent(in) :: txt type (t_rgb), intent(in), optional :: rgb integer, optional, intent(in) :: ifontsize, ifontdirection end subroutine device_text 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 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 => gr_lineTo procedure, pass :: moveTo => gr_moveTo procedure, pass :: dot => gr_dot procedure, pass :: text => gr_text end type t_win32 integer, save :: nwin = 0 integer (DWORD), save :: iThreadPrivate_Win32 = 0 type ( RTL_CRITICAL_SECTION), save :: gCriticalSection type (T_RTL_CRITICAL_SECTION), pointer :: lpgCriticalSection contains !-------------------------------------------------------------------------------- integer(4) 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 logical, save :: first = .true. ! 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) , int(0)) wc%lpfnWndProc = transfer(c_funloc(MainWndProc), int(0)) ! 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 = CreateWindowEx( 0, ClassName, & trim(win32%title)//char(0), & int(ior(WS_OVERLAPPED, WS_SYSMENU)), & CW_USEDEFAULT, CW_USEDEFAULT, & win32%nsize_x + iwindow_frame_x, & win32%nsize_y + iwindow_frame_y, & 0, 0, & hInstance, & transfer(c_loc(win32), int(0)) ) 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 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_CREATESTRUCT), pointer :: cs type (t_win32) , pointer :: win32 type (c_ptr) :: c_p ! mold for transfer function ! type (T_RTL_CRITICAL_SECTION), pointer :: lpCriticalSection ! call c_f_pointer(c_loc(gCriticalSection), lpgCriticalSection) call EnterCriticalSection( lpgCriticalSection ) MainWndProc = 0 select case ( mesg ) case (WM_CREATE) call c_f_pointer(transfer(lParam , c_p), cs ) ! LOC(cs ) = lParam call c_f_pointer(transfer(cs%lpCreateParams, c_p), win32) ! LOC(win32) = cs%lpCreateParams iretb = TlsSetValue(iThreadPrivate_Win32, cs%lpCreateParams) associate (wnd => win32%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) end associate case (WM_DESTROY) call c_f_pointer(transfer(TlsGetValue(iThreadPrivate_Win32), c_p), win32) ! LOC(win32) = TlsGetValue(iThreadPrivate_Win32) call c_f_pointer(c_loc(win32%CriticalSection), lpCriticalSection) associate (wnd => win32%wnd) call EnterCriticalSection( lpCriticalSection ) ! EnterCriticalSection( LOC(win32%CriticalSection) ) iretb = DeleteObject( wnd%hDC ) call PostQuitMessage( 0 ) call LeaveCriticalSection( lpCriticalSection ) end associate case (WM_PAINT) call c_f_pointer(transfer(TlsGetValue(iThreadPrivate_Win32), c_p), win32) call c_f_pointer(c_loc(win32%CriticalSection), lpCriticalSection) associate (wnd => win32%wnd) call EnterCriticalSection( 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( lpCriticalSection ) end associate case (WM_RBUTTONUP) call c_f_pointer(transfer(TlsGetValue(iThreadPrivate_Win32), c_p), win32) call c_f_pointer(c_loc(win32%CriticalSection), lpCriticalSection) associate (wnd => win32%wnd) call EnterCriticalSection( lpCriticalSection ) iretb = DeleteObject( wnd%hDC ) call PostQuitMessage( 0 ) call LeaveCriticalSection( lpCriticalSection ) end associate case default MainWndProc = DefWindowProc( hWnd, mesg, wParam, lParam ) end select call LeaveCriticalSection( lpgCriticalSection ) 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 type (T_RECT) :: rc type (T_RTL_CRITICAL_SECTION), pointer :: lpCriticalSection associate(wnd => self%wnd) if (nwin == 0) then iThreadPrivate_Win32 = TlsAlloc() call c_f_pointer(c_loc(gCriticalSection), lpgCriticalSection) call InitializeCriticalSection( lpgCriticalSection ) end if call c_f_pointer(c_loc(self%CriticalSection), lpCriticalSection) call InitializeCriticalSection( lpCriticalSection ) nwin = nwin + 1 wnd%hThread = CreateThread(NULL, 0, Thread_Proc, NULL, CREATE_SUSPENDED, wnd%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) end associate return contains integer (LONG) function Thread_Proc(lp_ThreadParameter) !DEC$ ATTRIBUTES STDcall, ALIAS:"_thread_proc" :: Thread_Proc integer (LPINT), intent(in) :: lp_ThreadParameter integer :: hInst hInst = GetModuleHandle(NULL) Thread_Proc = WinMain(hInst, SW_SHOWNORMAL, self) return end function Thread_Proc end subroutine gr_on !------------------------------------------------------------------------------------- subroutine gr_off(self) use, intrinsic :: iso_c_binding class(t_win32), intent(in) :: self integer (BOOL) :: iretb integer (DWORD) :: iwait type (T_RTL_CRITICAL_SECTION), pointer :: lpCriticalSection 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) call c_f_pointer(c_loc(self%CriticalSection), lpCriticalSection) call DeleteCriticalSection( lpCriticalSection ) nwin = nwin - 1 if (nwin == 0) then iretb = TlsFree(iThreadPrivate_Win32) call DeleteCriticalSection( lpgCriticalSection ) 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 integer (BOOL):: iretb associate(wnd => self%wnd) call c_f_pointer(c_loc(self%CriticalSection), lpCriticalSection) call EnterCriticalSection( lpCriticalSection ) iretb = InvalidateRect(wnd%hWnd, NULL, FALSE) call LeaveCriticalSection( lpCriticalSection ) 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 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) call EnterCriticalSection( lpCriticalSection ) 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 ) 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(self, ix, iy) class(t_win32), intent(in) :: self integer, intent(in) :: ix, iy type (T_RTL_CRITICAL_SECTION), pointer :: lpCriticalSection integer (BOOL):: iretb associate(wnd => self%wnd) call c_f_pointer(c_loc(self%CriticalSection), lpCriticalSection) call EnterCriticalSection( lpCriticalSection ) iretb = MoveToEx(wnd%hDC, ix, iy, NULL) call LeaveCriticalSection( lpCriticalSection ) end associate return end subroutine gr_moveTo !---------------------------------------------------------------- subroutine gr_lineTo(self, ix, iy) class(t_win32), intent(in) :: self integer, intent(in) :: ix, iy type (T_RTL_CRITICAL_SECTION), pointer :: lpCriticalSection integer (BOOL):: iretb associate(wnd => self%wnd) call c_f_pointer(c_loc(self%CriticalSection), lpCriticalSection) call EnterCriticalSection( lpCriticalSection ) iretb = LineTo(wnd%hDC, ix, iy) call LeaveCriticalSection( lpCriticalSection ) end associate return end subroutine gr_lineTo !------------------------------------------------------------------------------------- subroutine gr_dot(self, ix, iy, icol) class(t_win32), intent(in) :: self integer, intent(in) :: ix, iy, icol type (T_RTL_CRITICAL_SECTION), pointer :: lpCriticalSection integer (BOOL):: iretb associate(wnd => self%wnd) call c_f_pointer(c_loc(self%CriticalSection), lpCriticalSection) call EnterCriticalSection( lpCriticalSection ) iretb = SetPixel(wnd%hDC, ix, iy, icol) call LeaveCriticalSection( lpCriticalSection ) end associate return end subroutine gr_dot !---------------------------------------------------------------- subroutine gr_text(self, ix, iy, txt, rgb, ifontsize, ifontdirection) class(t_win32), intent(in) :: self integer, intent(in) :: ix, iy character (LEN = *), intent(in) :: txt type (t_rgb), intent(in), optional :: rgb integer, optional, intent(in) :: ifontsize, ifontdirection integer (BOOL) :: iretb integer (HANDLE) :: hFont integer :: kfontsize, kfontdirection type (T_RTL_CRITICAL_SECTION), pointer :: lpCriticalSection 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) call EnterCriticalSection( 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( lpCriticalSection ) end associate return end subroutine gr_text end module m_win32 module m_plot use m_oop use m_win32 implicit none private public :: t_rgb, t_device, t_win32, t_wnd 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 = 800, nwiny = 600 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 :: ic(:, :) integer :: icol(0:m), it0, it1 class(t_device), allocatable :: fig1, fig2, fig3, fig4, fig5 type(t_rgb), parameter :: rgb_black = t_rgb(0, 0, 0) ! xmin = -2.0d0 xmax = 2.0d0 ymin = -2.0d0 ymax = 2.0d0 maxiter = 150 ! dx = xmax - xmin dy = ymax - ymin if (dx <= 0.0_kd .OR. dy <= 0.0_kd .OR. maxiter <= 0 .OR. maxiter > M) stop 'input error' if (dx * nwinx > dy * nwiny) then imax = nwinx jmax = nint(nwinx * dy / dx) else imax = nint(nwiny * dx / dy) jmax = int(nwiny) end if ! dx = dx / real(imax, kd) dy = dy / real(jmax, kd) 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 ! allocate( ic(0:imax, 0:jmax) ) call system_clock(it0) call cpu_time(t0) do concurrent (i = 0:imax, j = 0:jmax) x = xmin + i * dx y = ymax - j * dy ic(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 ! allocate(fig1, source = t_win32('Mandelbrot 1', imax, jmax, 1, rgb_black)) call fig1%on() do i = 0, imax do j = 0, jmax call fig1%dot(i, j, icol(ic(i, j))) end do call fig1%show() end do deallocate( ic ) ! xmin = 1.10950d0 xmax = 1.10951d0 ymin = 0.24758d0 ymax = 0.24759d0 ! dx = xmax - xmin dy = ymax - ymin if (dx <= 0.0_kd .OR. dy <= 0.0_kd .OR. maxiter <= 0 .OR. maxiter > M) stop 'input error' if (dx * nwinx > dy * nwiny) then imax = nwinx jmax = nint(nwinx * dy / dx) else imax = nint(nwiny * dx / dy) jmax = int(nwiny) end if ! dx = dx / real(imax, kd) dy = dy / real(jmax, kd) allocate( ic(0:imax, 0:jmax) ) call system_clock(it0) call cpu_time(t0) do concurrent (i = 0:imax, j = 0:jmax) x = xmin + i * dx y = ymax - j * dy ic(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 ! allocate(fig2, source = t_win32('Mandelbrot 2', imax, jmax, 1, rgb_black)) call fig2%on() do i = 0, imax do j = 0, jmax call fig2%dot(i, j, icol(ic(i, j))) end do call fig2%show() end do ! allocate(fig3, source = t_win32('Lorenz attractor', 800, 600, 1, rgb_black)) 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 ! allocate(fig4, source = t_win32('Chaos', 640, 480, 1, rgb_black)) 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), irgb(0, 255, 122)) p = p + x * p * (1 - p) end do call fig4%show() end do ! allocate(fig5, source = t_win32('Laplace', 1200, 600, 1, rgb_black)) 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() 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 contains 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 program Mandel