fortran66のブログ

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)
       write(*, *) 'RBUTTON ', trim(wnd%title), wnd%hWnd
     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_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)
    implicit none
    integer, intent(in) :: ix, iy
    character (LEN = *), intent(in) :: txt
    integer, intent(in), optional :: icol
    integer (BOOL)   :: iretb
    integer (HANDLE) :: hFont

    if ( present(icol) ) iretb = SetTextColor(wnd%hDC, icol) 
    call EnterCriticalSection( loc(lpCriticalSection) )
    iretb = SetBkMode(wnd%hDC, TRANSPARENT)
    hFont = CreateFont( 10 , 7 , 0 , 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
  !-------------------------------------------------------------------------------------
end module uhoplot
!=====================================================================================
program snoopy
  use uhoplot
  integer :: ix, iy, ic, kx = 30, ky = 10, kff = 0, kdy = 8
  character(len = 136) :: text

  open(UNIT=7,FILE='SNPCAL.OUT',STATUS='old')
  text = ''
  do
    ix = kx
    iy = ky
    ic = 0
    call gr_on('snoopy', 1000, 1000)
    call gr_pencol(irgb(0, 0, 0))
    call gr_text(ix, iy, text, irgb(0, 0, 0) )!
    do 
      read(7, '(a)', end = 999) text
      select case(text(1:1))
        case ('0') ! LF
          ix = kx
          iy = iy + 2 * kdy
          text(1:1) = ' '
        case ('1') ! FF
          ic = ic + 1
          ix = kx
          iy = 500 * ic + ky
          text(1:1) = ' '
          if (MOD(ic, 2) == 0) exit
        case ('+') 
          ix = kx
          text(1:1) = ' '
        case default
          iy = iy + kdy
      end select
      call gr_text(ix, iy, text, irgb(0, 0, 0) )!
    end do
    call gr_show()
    call gr_off()
  end do 
999 continue 
  stop
 contains
  
end program snoopy