fortran66のブログ

fortran について書きます。

plot ルーチン 再改定 64bit 対応

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 の綴りが間違っていたので直しておきますw

f:id:fortran66:20141203030032j:plain

ソース・プログラム

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