読者です 読者をやめる 読者になる 読者になる

fortran66のブログ

fortran について書きます。

文字ルーチン(仮

デバイスに依らないで同じ出力を得るにはフォントも自分で持っていると都合よいです。見栄えのいいのを作るのは面倒ですが、清書はちゃんとしたソフトでやるとして、作業用に使う分には適当で何とかなります。いま、英字とギリシア文字を用意しています。

またフォントルーチンで文字が書けるようになったとして、向きを回転させたり上付き下付きなどを実現するには、またフォントの上位のルーチンを書かねばなりません。これも面倒なのですが、ある程度割り切れば素朴に実現できます。グラフをプロットする目的には、文字列のセンタリングや右詰めが出来ると便利なので、一応作ってみましたが、まだ完全に機能していません。

自分用メモ帳として記録しておきます。

出力例

f:id:fortran66:20160504012931p:plain

プログラム

先日の低レベル・ルーチンの上で動きます。Intel Visual Fortran v16/v17 で動きました。v16の場合、コンパイラFortran Semantics を F2003 用にする必要があります。

Main program

文字列中に特殊文字を書くことで、上付き下付等を実現できます。\^の次の文字は上付きに、\_の次の文字は下付になります。\ (スペース)は半文字後退、\gは次の文字がギリシア文字になります。また \\ でバックスラッシュが出ます。

    program TestFont
      use m_plot
      implicit none
      type (t_fig) :: fig
      call fig%on(t_win32())
      call fig%window(0.0, 0.0, 640.0, 480.0)
      call fig%move( 20.0,  20.0)
      call fig%line( 20.0, 460.0)
      call fig%line(620.0, 460.0)
      call fig%line(620.0,  20.0)
      call fig%line( 20.0,  20.0)
      call fig%text( 55.0,  30.0, '\gA\gB\gC\gD\gE\gF\gG\gH\gI\gJ\gK\gL\gM\gN\gO\gP\gQ\gR\gS\gT\gU\gV\gW\gX\gY\gZ', 2.5)
      call fig%text( 55.0,  60.0, '\ga\gb\gc\gd\ge\gf\gg\gh\gi\gj\gk\gl\gm\gn\go\gp\gq\gr\gs\gt\gu\gv\gw\gx\gy\gz', 2.5)
      call fig%text( 20.0, 420.0, 'ABCDEFGHIJKLMNOPQRSTUVWXYZ', 3.5)
      call fig%text( 45.0,  18.0, '.,%*/+--=~(){}[]''"^\!?@:;<> ', 2.5, 90.0)
      call fig%text(590.0, 450.0, 'abcdefghijklmnopqrstuvwxyz',   2.5, -90.0)
      call fig%text(370.0, 330.0, 'Hankel function', 4.0, 0.0, 'center')
      call fig%text(640.0, 250.0, 'H\_\ga\ \^(\^1\^)(x)=J\_\ga(x)+iY\_\ga(x)', 4.0, 0.0, 'right')
      call fig%text(640.0, 150.0, 'H\_\ga\ \^(\^2\^)(x)=J\_\ga(x)-iY\_\ga(x)', 4.0, 0.0, 'right')
      call fig%off()
    end program TestFont
Module m_font
    module m_font  
      implicit none
      integer, parameter :: nsize_font_x = 8, nsize_font_y = 10
      type :: t_xyp
        integer :: ix, iy, ipen
      end type t_xyp
      type :: t_font 
         type (t_xyp), allocatable :: pen(:)
      end type t_font
      
      type (t_font) :: num(10), mark(28)
      type (t_font) :: alpha(52), greek(52)
      type (t_font) :: alphanum(0:90)
    contains
      function to_xyp(m) result(res)
        integer, intent(in) :: m(:)
        type (t_xyp) :: res(size(m) / 3)
        integer :: i
        do i = 1, size(m), 3
          res(i / 3 + 1) = t_xyp(m(i), m(i + 1), m(i + 2))
        end do  
      end function to_xyp  

      subroutine font_init()
        type :: t_tmp
          integer, allocatable :: m(:)
        end type
        type (t_tmp) :: numb(10), mrk(28), alpha_u(26), alpha_l(26), greek_u(26), greek_l(26)
        integer :: i
      !num
        numb( 1)%m = [[1,1,1],[4,0,0],[0,8,0],[-4,0,0],[0,-8,0],[4,8,0]]          ! 0
        numb( 2)%m = [[1,1,1],[4,0,0],[-2,0,1],[0,8,0],[-2,-4,0]]                 ! 1 
        numb( 3)%m = [[5,1,1],[-4,0,0],[0,4,0],[4,0,0],[0,4,0],[-4,0,0],[0,-2,0]] ! 2
        numb( 4)%m = [[1,1,1],[4,0,0],[0,4,0],[-4,0,0],[4,0,1],[0,4,0],[-4,0,0]]  ! 3
        numb( 5)%m = [[4,1,1],[0,8,0],[-4,0,1],[0,-4,0],[6,0,0]]                  ! 4
        numb( 6)%m = [[1,1,1],[4,0,0],[0,4,0],[-4,0,0],[0,4,0],[4,0,0]]           ! 5
        numb( 7)%m = [[5,9,1],[-4,0,0],[0,-8,0],[4,0,0],[0,4,0],[-4,0,0]]         ! 6
        numb( 8)%m = [[3,1,1],[1,4,0],[2,4,0],[-6,0,0]]                           ! 7 
        numb( 9)%m = [[1,5,1],[0,4,0],[4,0,0],[0,-8,0],[-4,0,0],[0,4,0],[4,0,0]]  ! 8
        numb(10)%m = [[1,1,1],[4,0,0],[0,8,0],[-4,0,0],[0,-4,0],[4,0,0]]          ! 9
      !mark
        mrk( 1)%m = [[1,0,1],[0,1,0],[1,0,0],[0,-1,0],[-1,0,0]]                   ! .
        mrk( 2)%m = [[2,0,1],[0,1,0],[1,0,0],[0,-1,0],[-2,-2,0],[1,2,0]]          ! ,
        mrk( 3)%m = [[1,2,1],[4,4,0],[-3,1,1],[1,-1,0],[-1,-1,0],[-1,1,0],[1,1,0],[2,-4,1],[1,-1,0],[-1,-1,0],[-1,1,0],[1,1,0]] ! %
        mrk( 4)%m = [[1,7,1],[4,-4,0],[-4,0,1],[4,4,0],[-2,1,1],[0,-6,0]]         ! *
        mrk( 5)%m = [[1,2,1],[4,6,0]]                                             ! /
        mrk( 6)%m = [[1,5,1],[4,0,0],[-2,3,1],[0,-6,0]]                           ! +
        mrk( 7)%m = [[1,5,1],[4,0,0]]                                             ! --
        mrk( 8)%m = [[2,5,1],[2,0,0]]                                             ! -
        mrk( 9)%m = [[1,6,1],[4,0,0],[-4,-2,1],[4,0,0]]                           ! =
        mrk(10)%m = [[0,5,1],[1,1,0],[1,0,0],[2,-2,0],[1,0,0],[1,1,0]]            ! ~
        mrk(11)%m = [[4,9,1],[-1,-1,0],[-1,-2,0],[0,-2,0],[1,-2,0],[1,-1,0]]      ! (
        mrk(12)%m = [[2,9,1],[1,-1,0],[1,-2,0],[0,-2,0],[-1,-2,0],[-1,-1,0]]      ! )
        mrk(13)%m = [[5,9,1],[-1,0,0],[-1,-1,0],[0,-2,0],[-1,-1,0],[1,-1,0],[0,-2,0],[1,-1,0],[1,0,0]] ! {
        mrk(14)%m = [[2,9,1],[1,0,0],[1,-1,0],[0,-2,0],[1,-1,0],[-1,-1,0],[0,-2,0],[-1,-1,0],[-1,0,0]] ! }
        mrk(15)%m = [[5,9,1],[-2,0,0],[0,-8,0],[2,0,0]]                           ! [
        mrk(16)%m = [[2,9,1],[2,0,0],[0,-8,0],[-2,0,0]]                           ! ]
        mrk(17)%m = [[3,9,1],[0,-3,0]]                                            ! ' 
        mrk(18)%m = [[3,9,1],[0,-3,0],[1,0,1],[0,3,0]]                            ! "
        mrk(19)%m = [[2,7,1],[2,2,0],[2,-2,0]]                                    ! ^
        mrk(20)%m = [[5,2,1],[-4,6,0]]                                            ! \
        mrk(21)%m = [[4,9,1],[0,-6,0],[0,-2,1],[0,-1,0]]                          ! !
        mrk(22)%m = [[1,7,1],[1,2,0],[2,0,0],[1,-2,0],[0,-1,0],[-3,-2,0],[0,-1,0],[0,-2,1],[0,-1,0]] ! ?
        mrk(23)%m = [[4,4,1],[0,3,0],[-2,0,0],[0,-3,0],[3,0,0],[0,4,0],[-1,1,0], [-2,0,0],&
                     [-1,-1,0],[0,-4,0],[1,-2,0],[3,0,0]]                         ! @
        mrk(24)%m = [[5,8,1],[0,-2,0],[0,-3,1],[0,-2,0]]                          ! :
        mrk(25)%m = [[5,8,1],[0,-2,0],[0,-3,1],[0,-2,0],[-1,-1,0]]                ! ;
        mrk(26)%m = [[6,7,1],[-5,-3,0],[ 5,-3,0]]                                 ! <
        mrk(27)%m = [[1,7,1],[ 5,-3,0],[-5,-3,0]]                                 ! >
        mrk(28)%m = [[0,0,1]]                                                     ! 
      !alpha1
        alpha_u( 1)%m = [[1,1,1],[0,4,0],[2,4,0],[2,-4,0],[0,-4,0],[0,3,1],[-4,0,0]]           ! A
        alpha_u( 2)%m = [[1,1,1],[0,8,0],[3,0,0],[0,-4,0],[-3,0,1],[4,0,0],[0,-4,0],[-4,0,0]]  ! B
        alpha_u( 3)%m = [[5,3,1],[-2,-2,0],[-2,2,0],[0,4,0],[2,2,0],[2,-2,0]]                  ! C
        alpha_u( 4)%m = [[3,1,1],[-2,0,0],[0,8,0],[2,0,0],[2,-2,0],[0,-4,0],[-2,-2,0]]         ! D
        alpha_u( 5)%m = [[5,1,1],[-4,0,0],[0,8,0],[4,0,0],[-4,-4,1],[4,0,0]]                   ! E
        alpha_u( 6)%m = [[1,1,1],[0,4,0],[4,0,0],[-4,0,1],[0,4,0],[4,0,0]]                     ! F
        alpha_u( 7)%m = [[3,5,1],[2,0,0],[0,-2,0],[-2,-2,0],[-2,2,0],[0,4,0],[2,2,0],[2,-2,0]] ! G
        alpha_u( 8)%m = [[1,1,1],[0,8,0],[0,-4,1],[4,0,0],[0,4,1],[0,-8,0]]                    ! H
        alpha_u( 9)%m = [[1,1,1],[4,0,0],[-2,0,1],[0,8,0],[-2,0,1],[4,0,0]]                    ! I
        alpha_u(10)%m = [[1,1,1],[0,2,0],[0,-2,1],[3,0,0],[0,8,0],[-2,0,1],[4,0,0]]            ! J
        alpha_u(11)%m = [[1,1,1],[0,8,0],[4,0,1],[-4,-4,0],[4,-4,0]]                           ! K
        alpha_u(12)%m = [[5,1,1],[-4,0,0],[0,8,0]]                                             ! L
        alpha_u(13)%m = [[1,1,1],[0,8,0],[2,-8,0],[2,8,0],[0,-8,0]]                            ! M
        alpha_u(14)%m = [[1,1,1],[0,8,0],[4,-8,0],[0,8,0]]                                     ! N
        alpha_u(15)%m = [[3,1,1],[-2,2,0],[0,4,0],[2,2,0],[2,-2,0],[0,-4,0],[-2,-2,0]]         ! O
        alpha_u(16)%m = [[1,1,1],[0,8,0],[2,0,0],[2,-2,0],[-2,-2,0],[-2,0,0]]                  ! P
        alpha_u(17)%m = [[3,1,1],[-2,2,0],[0,4,0],[2,2,0],[2,-2,0],[0,-4,0],[-2,-2,0],[3,0,1],[-3,3,0]] ! Q
        alpha_u(18)%m = [[1,1,1],[0,8,0],[2,0,0],[2,-2,0],[-2,-2,0],[-2,0,0],[2,0,1],[2,-4,0]] ! R
        alpha_u(19)%m = [[1,3,1],[2,-2,0],[2,2,0],[-4,4,0],[2,2,0],[2,-2,0]]  ! S
        alpha_u(20)%m = [[3,1,1],[0,8,0],[-2,0,0],[4,0,0],[-2,0,0]]                            ! T
        alpha_u(21)%m = [[1,1,1],[4,0,0],[0,8,0],[0,-8,0],[-4,8,1],[0,-8,0]]                   ! U
        alpha_u(22)%m = [[3,1,1],[-2,8,0],[2,-8,0],[2,8,0],[-2,-8,0]]                          ! V
        alpha_u(23)%m = [[2,1,1],[-1,8,0],[1,-8,0],[1,8,0],[1,-8,0],[1,8,0],[-1,-8,0]]         ! W
        alpha_u(24)%m = [[1,1,1],[4,8,0],[-4,-8,0],[0,8,1],[4,-8,0],[-4,8,0]]                  ! X
        alpha_u(25)%m = [[3,1,1],[0,4,0],[-2,4,0],[2,-4,0],[2,4,0],[-2,-4,0]]                  ! Y
        alpha_u(26)%m = [[5,1,1],[-4,0,0],[4,8,0],[-4,0,0],[4,0,0]]                            ! Z
      !alpha2
        alpha_l( 1)%m = [[4,3,1],[-3,0,0],[0,-2,0],[4,0,0],[-1,0,1],[0,4,0],[-3,0,0]]          ! a
        alpha_l( 2)%m = [[1,9,1],[0,-8,0],[4,0,0],[0,4,0],[-4,0,0]]                            ! b
        alpha_l( 3)%m = [[5,2,1],[0,-1,0],[-4,0,0],[0,4,0],[4,0,0],[0,-1,0]]                   ! c
        alpha_l( 4)%m = [[5,9,1],[0,-8,0],[-4,0,0],[0,4,0],[4,0,0]]                            ! d
        alpha_l( 5)%m = [[5,1,1],[-4,0,0],[0,4,0],[4,0,0],[0,-2,0],[-4,0,0]]                   ! e 
        alpha_l( 6)%m = [[5,7,1],[0,2,0],[-2,0,0],[0,-8,0],[-2,4,1],[4,0,0]]                   ! f 
        alpha_l( 7)%m = [[5,1,1],[-3,0,0],[0,4,0],[3,0,0],[0,-8,0],[-3,0,0],[0,2,0]]           ! g
        alpha_l( 8)%m = [[2,9,1],[0,-8,0],[3,0,1],[0,4,0],[-3,0,0]]                            ! h
        alpha_l( 9)%m = [[3,9,1],[0,-2,0],[0,-2,1],[0,-4,0]]                                   ! i
        alpha_l(10)%m = [[3,9,1],[0,-2,0],[0,-2,1],[0,-8,0],[-2,0,0],[0,2,0]]                  ! j
        alpha_l(11)%m = [[2,9,1],[0,-8,0],[3,5,1],[-3,-3,0],[1,1,1],[2,-3,0]]                  ! k 
        alpha_l(12)%m = [[1,9,1],[2,0,0],[0,-8,0],[-2,0,1],[4,0,0]]                            ! l
        alpha_l(13)%m = [[1,1,1],[0,5,0],[0,-1,1],[4,0,0],[0,-4,0],[-2,0,1],[0,4,0]]           ! m
        alpha_l(14)%m = [[1,1,1],[0,4,0],[0,-1,1],[1,1,0],[2,0,0],[1,-1,0],[0,-3,0]]           ! n 
        alpha_l(15)%m = [[1,5,1],[4,0,0],[0,-4,0],[-4,0,0],[0,4,0]]                            ! o
        alpha_l(16)%m = [[1,-3,1],[0,8,0],[4,0,0],[0,-4,0],[-4,0,0]]                           ! p
        alpha_l(17)%m = [[5,-3,1],[0,8,0],[-4,0,0],[0,-4,0],[4,0,0]]                           ! q
        alpha_l(18)%m = [[1,5,1],[0,-4,0],[0,2,1],[2,2,0],[2,-2,0]]                            ! r
        alpha_l(19)%m = [[5,5,1],[0,0,0],[-4,0,0],[0,-2,0],[4,0,0],[0,-2,0],[-4,0,0],[0,0,0]]  ! s
        alpha_l(20)%m = [[0,5,1],[5,0,0],[-3,2,1],[0,-6,0],[3,0,0],[-5,0,1]]                   ! t
        alpha_l(21)%m = [[1,4,1],[1,1,0],[0,-4,0],[2,0,0],[1,1,0],[0,3,1],[0,-4,0]]            ! u
        alpha_l(22)%m = [[1,5,1],[2,-4,0],[2,4,0]]                                             ! v
        alpha_l(23)%m = [[0,5,1],[1,-4,0],[2,4,0],[2,-4,0],[1,4,0]]                            ! w
        alpha_l(24)%m = [[1,5,1],[4,-4,0],[0,4,1],[-4,-4,0]]                                   ! x
        alpha_l(25)%m = [[1,5,1],[2,-4,0],[2,4,1],[-4,-8,0]]                                   ! y
        alpha_l(26)%m = [[1,5,1],[4,0,0],[-4,-4,0],[4,0,0],[-1,2,1]]                           ! z
      !greek1
        greek_u( 1)%m = [[0,0,1],[3,8,0],[3,-8,0],[-1,3,1],[-4,0,0]]                           ! ALPHA    
        greek_u( 2)%m = [[1,0,1],[0,8,0],[3,0,0],[1,-1,0],[0,-2,0],[-1,-1,0],[-3,0,1],[4,0,0], &
                         [1,-1,0],[0,-2,0],[-1,-1,0],[-4,0,0]]                                 ! BETA
        greek_u( 3)%m = [[1,0,1],[0,8,0],[5,0,0],[0,-1,0]]                                     ! GAMMA
        greek_u( 4)%m = [[0,0,1],[3,8,0],[3,-8,0],[-6,0,0]]                                    ! DELTA
        greek_u( 5)%m = [[6,0,1],[-5,0,0],[0,8,0],[5,0,0],[-5,-4,1],[4,0,0]]                   ! EPSILON
        greek_u( 6)%m = [[6,0,1],[-5,0,0],[5,8,0],[-5,0,0]]                                    ! ZETA
        greek_u( 7)%m = [[1,0,1],[0,8,0],[5,0,1],[0,-8,0],[0,4,1],[-5,0,0]]                    ! ETA
        greek_u( 8)%m = [[3,8,1],[-2,-2,0],[0,-4,0],[2,-2,0],[2,0,0],[2,2,0],[0,4,0],[-2,2,0],[-2,0,0], &
                         [0,-2,1],[0,-4,0],[2,0,1],[0,4,0],[0,-2,1],[-2,0,0]]                  ! THETA
        greek_u( 9)%m = [[1,8,1],[4,0,0],[0,-8,1],[-4,0,0],[2,0,1],[0,8,0]]                    ! IOTA
        greek_u(10)%m = [[1,8,1],[0,-8,0],[0,4,1],[4,4,0],[0,-8,1],[-4,4,0]]                   ! KAPPA
        greek_u(11)%m = [[0,0,1],[3,8,0],[3,-8,0]]                                             ! LAMBDA
        greek_u(12)%m = [[0,0,1],[0,8,0],[3,-8,0],[3,8,0],[0,-8,0]]                            ! MU
        greek_u(13)%m = [[1,0,1],[0,8,0],[4,-8,0],[0,8,0]]                                     ! NU
        greek_u(14)%m = [[0,7,1],[0,1,0],[6,0,0],[0,-1,0],[0,-6,1],[0,-1,0],[-6,0,0],[0,1,0],[1,4,1], &
                         [0,-2,0],[0,1,1],[4,0,0],[0,1,1],[0,-2,0]]                            ! XI
        greek_u(15)%m = [[2,8,1],[-2,-2,0],[0,-4,0],[2,-2,0],[2,0,0],[2,2,0],[0,4,0],[-2,2,0],[-2,0,0]] ! OMICRON
        greek_u(16)%m = [[0,8,1],[6,0,0],[-5,0,1],[0,-8,0],[4,0,1],[0,8,0]]                    ! PI
        greek_u(17)%m = [[1,0,1],[0,8,0],[4,0,0],[1,-1,0],[0,-2,0],[-1,-1,0],[-4,0,0]]         ! RHO
        greek_u(18)%m = [[6,8,1],[-6,0,0],[4,-4,0],[-4,-4,0],[6,0,0]]                          ! SIGMA
        greek_u(19)%m = [[0,8,1],[6,0,0],[-3,0,1],[0,-8,0]]                                    ! TAU
        greek_u(20)%m = [[0,8,1],[3,-3,0],[3,3,0],[-3,-3,1],[0,-5,0]]                          ! UPSILON 
        greek_u(21)%m = [[3,7,1],[-2,-1,0],[-1,-1,0],[0,-2,0],[1,-1,0],[2,-1,0],[2,1,0], &
                         [1,1,0],[0,2,0],[-1,1,0],[-2,1,0],[0,2,1],[0,-9,0]]                   ! PHI 
        greek_u(22)%m = [[3,7,1],[-2,-1,0],[-1,-1,0],[0,-2,0],[1,-1,0],[2,-1,0],[2,1,0], &
                         [1,1,0],[0,2,0],[-1,1,0],[-2,1,0],[0,2,1],[0,-9,0]]                   ! VARPHI 
        greek_u(23)%m = [[1,8,1],[4,-8,0],[0,8,1],[-4,-8,0]]                                   ! CHI/XI
        greek_u(24)%m = [[0,8,1],[0,-3,0],[2,-2,0],[2,0,0],[2,2,0],[0,3,0],[-3,0,1],[0,-8,0]]  ! PSI
        greek_u(25)%m = [[0,1,1],[0,-1,0],[2,0,0],[0,2,0],[-2,2,0],[0,2,0],[2,2,0],[2,0,0], &
                         [2,-2,0],[0,-2,0],[-2,-2,0],[0,-2,0],[2,0,0],[0,1,0]]                 ! OMEGA
        greek_u(26)%m = [[0,0,1]]                                                              !
      !greek2
        greek_l( 1)%m = [[5,7,1],[-2,-6,0],[-2,0,0],[-1,2,0],[1,3,0],[0,0,0],[2,0,0],[2,-5,0]] ! alpha
        greek_l( 2)%m = [[1,0,1],[2,8,0],[1,0,0],[1,-1,0],[0,-1,0],[-1,-1,0],[-2,0,0], &
                         [2,0,1],[1,-1,0],[0,-2,0],[-1,-1,0],[-2,0,0],[-2,1,0]]                ! beta
        greek_l( 3)%m = [[0,5,1],[1,1,0],[1,0,0],[1,-1,0],[-2,-4,0],[2,4,1],[2,1,0]]           ! gamma
        greek_l( 4)%m = [[5,7,1],[-2,1,0],[-1,-1,0],[0,-1,0],[2,-2,0],[0,-2,0],[-1,-1,0], & 
                         [-1,0,0],[-1,1,0],[0,1,0],[2,2,0]]                                    ! delta
        greek_l( 5)%m = [[5,6,1],[-1,1,0],[-1,0,0],[-1,-1,0],[0,-1,0],[1,-1,0],[1,0,1], &
                         [-2,0,0],[-1,-1,0],[0,-1,0],[1,-1,0],[2,0,0],[1,1,0]]                 ! epsilon
        greek_l( 6)%m = [[1,8,1],[1,-1,0],[1,0,0],[2,1,0],[-2,-1,0],[-1,-3,0],[0,-2,0], &
                         [1,-1,0],[1,0,0],[1,-1,0],[-1,-1,0],[-2,0,0]]                         ! zeta
        greek_l( 7)%m = [[0,6,1],[1,1,0],[1,-1,0],[-1,-4,0],[1,4,1],[1,1,0],[1,0,0], &
                         [1,-1,0],[-2,-6,0],[0,-1,0],[1,0,0],[1,1,0]]                          ! eta
        greek_l( 8)%m = [[5,8,1],[-2,0,0],[-1,-1,0],[-2,-6,0],[1,-1,0],[2,0,0],[1,1,0], &
                         [2,6,0],[-1,1,0],[0,-4,1],[-4,0,0]]                                   ! theta
        greek_l( 9)%m = [[3,6,1],[0,-2,0],[-1,-2,0],[1,-1,0],[1,1,0]]                          ! iota
        greek_l(10)%m = [[2,5,1],[-2,-4,0],[1,2,1],[2,0,0],[2,2,0],[-2,-2,1],[0,-1,0],[1,-1,0]]! kappa
        greek_l(11)%m = [[1,7,1],[1,0,0],[1,-2,0],[2,-4,0],[-2,4,1],[-1,-3,0],[-1,-1,0]]       ! lambda 
        greek_l(12)%m = [[0,-1,1],[2,6,0],[-1,-3,0],[2,-1,0],[2,1,0],[1,3,0],[-1,-3,1],[1,-1,0]]! mu
        greek_l(13)%m = [[2,5,1],[0,-1,0],[-1,-4,0],[2,1,0],[3,3,0]]                           ! nu
        greek_l(14)%m = [[6,9,1],[-1,0,0],[-2,-1,0],[1,-1,0],[2,0,0],[-2,0,1],[-2,-2,0], &
                         [3,0,0],[-3,0,1],[-1,-2,0],[1,-1,0],[2,0,0],[1,-1,0],[-1,-1,0],[-3,0,0]]! xi
        greek_l(15)%m = [[1,2,1],[1,-1,0],[2,0,0],[1,3,0],[-1,1,0],[-2,0,0],[-1,-3,0],[1,-1,0]] ! omicron
        greek_l(16)%m = [[0,5,1],[1,1,0],[4,0,0],[1,1,0],[-4,-1,1],[0,-3,0],[-1,-2,0], &
                         [3,5,1],[0,-4,0],[1,-1,0]]                                             ! pi
        greek_l(17)%m = [[0,0,1],[1,1,0],[1,2,0],[1,2,0],[1,0,0],[1,-1,0],[0,-2,0],  &
                         [-1,-1,0], [-1,0,0],[-1,1,0]]                                          ! rho
        greek_l(18)%m = [[6,6,1],[-1,-1,0],[-3,0,0],[-1,-1,0],[0,-2,0],[1,-1,0],[2,0,0], &
                         [1,1,0],[0,2,0],[-1,1,0],[-2,0,0]]                                     ! sigma
        greek_l(19)%m = [[1,5,1],[2,1,0],[2,0,0],[1,1,0],[-2,-1,1],[0,-1,0],[-1,-3,0],[1,-1,0],[1,1,0]] ! tau
        greek_l(20)%m = [[2,5,1],[0,-3,0],[1,-1,0],[1,0,0],[1,1,0],[0,2,0],[-1,1,0]]            ! upsilon
        greek_l(21)%m = [[4,6,1],[-2,0,0],[-1,-1,0],[0,-2,0],[1,-1,0],[2,0,0],[1,1,0], &
                         [0,2,0],[-1,1,0],[0,2,1],[-2,-8,0]]                                    ! phi
        greek_l(22)%m = [[2,6,1],[-1,-1,0],[0,-1,0],[1,-1,0],[3,0,0],[1,1,0],[0,1,0], &
                         [-1,1,0],[-1,0,0],[-2,-6,0]]                                           ! varphi
        greek_l(23)%m = [[1,7,1],[1,0,0],[1,-1,0],[1,-4,0],[1,-1,0],[1,0,0],[-1,6,1],[-3,-6,0]] ! chi/xi
        greek_l(24)%m = [[1,6,1],[0,-1,0],[0,-1,0],[1,-1,0],[2,0,0],[1,1,0],[0,2,0],[-1,2,1],[-2,-8,0]] ! psi
        greek_l(25)%m = [[2,6,1],[-1,-2,0],[1,-2,0],[1,0,0],[1,1,0],[0,2,0],[0,-2,1], &
                         [1,-1,0],[1,0,0],[1,2,0],[-1,2,0]]                                     ! omega
        greek_l(26)%m = [[0,0,1]]
        
        do i = 1, 10
          num     (i)%pen = to_xyp(numb(i)%m)
          alphanum(i)%pen = to_xyp(numb(i)%m)
        end do  
        do i = 1, 28
          mark(i)%pen          = to_xyp(mrk(i)%m)
          alphanum(i + 62)%pen = to_xyp(mrk(i)%m)
        end do    
        do i = 1, 26
          alpha(i)%pen      = to_xyp(alpha_l(i)%m)
          alpha(i + 26)%pen = to_xyp(alpha_u(i)%m)
          greek(i)%pen      = to_xyp(greek_l(i)%m)
          greek(i + 26)%pen = to_xyp(greek_u(i)%m)
          alphanum(i + 10)%pen = to_xyp(alpha_l(i)%m)
          alphanum(i + 36)%pen = to_xyp(alpha_u(i)%m)
        end do
        alphanum(0)%pen = to_xyp([0,0,1]) ! error
        
      end subroutine font_init

      integer pure elemental function to_alphanum(c)
        character, intent(in) :: c
        character(len=*), parameter :: tab = '0123456789'// &
                            'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ'// &
                            '.,%*/+--=~(){}[]''"^\!?@:;<> '
        to_alphanum = index(tab, c)
      end function to_alphanum
    
      integer pure elemental function to_greek(c)
        character, intent(in) :: c
        character(len=*), parameter :: tab = 'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ'
        to_greek = index(tab, c)
      end function to_greek
    end module m_font 
Module m_plot

実数座標系用ルーチンを加えています。 window サブルーチンで整数座標系の隅っこの座標を与えます。

    module m_plot
      use m_lowlevel
      use m_font
      implicit none
      real, parameter, private :: pi = 4 * atan(1.0)
      type :: t_fig
        class (t_device), allocatable :: fig
        real :: x0 = 0.0, y0 = 0.0, x1 = 1.0, y1 = 1.0
      contains
        generic   :: move => move_i, move_r
        generic   :: line => line_i, line_r
        generic   :: text => text_i, text_r
        procedure :: on
        procedure :: off
        procedure :: show
        procedure :: pen
        procedure :: move_i
        procedure :: line_i
        procedure :: window
        procedure :: move_r
        procedure :: line_r
        procedure :: font => font_sub 
        procedure :: text_i
        procedure :: text_r
      end type t_fig    
    contains
      subroutine on(self, device)
        class (t_fig), intent(in out) :: self
        class (t_device), intent(in), optional :: device
        if (present(device)) allocate(self%fig, source = device)
        if (.not. allocated(self%fig)) allocate(self%fig, source = t_win32())
        call self%fig%on()
        call font_init()
      end subroutine on 
      
      subroutine off(self, isec, keep)
        class (t_fig), intent(in out):: self
        integer, intent(in), optional :: isec
        logical, intent(in), optional :: keep 
        call self%fig%off(isec)
        if (present(keep)) then ; if (keep) return ; end if
        deallocate(self%fig)
      end subroutine off 
      
      subroutine show(self)
        class (t_fig), intent(in) :: self
        call self%fig%show()
      end subroutine show
      
      subroutine pen(self, iwidth, icolor)
        class (t_fig), intent(in out) :: self
        integer, intent(in), optional :: iwidth, icolor
        integer, save :: kwidth = 1, kcolor = 0
        if (present(iwidth)) kwidth = iwidth
        if (present(icolor)) kcolor = icolor
        call self%fig%pen(kwidth, kcolor)
      end subroutine pen 
      
      subroutine move_i(self, ix, iy)
        class (t_fig), intent(in out) :: self
        integer, intent(in) :: ix, iy
        call self%fig%move(ix, iy)
      end subroutine move_i 
      
      subroutine line_i(self, ix, iy)
        class (t_fig), intent(in out) :: self
        integer, intent(in) :: ix, iy
        call self%fig%line(ix, iy)
      end subroutine line_i 
      
      subroutine window(self, x0, y0, x1, y1)
        class (t_fig), intent(in out) :: self
        real, intent(in) :: x0, y0, x1, y1
        self%x0 = x0
        self%y0 = y0
        self%x1 = x1
        self%y1 = y1
      end subroutine window
      
      integer pure function ix_pos(self, x)
        type (t_fig), intent(in) :: self
        real, intent(in) :: x
        ix_pos = nint( (x - self%x0) / (self%x1 - self%x0) * self%fig%nsize_x )
      end function ix_pos  
        
      integer pure function iy_pos(self, y)
        type (t_fig), intent(in) :: self
        real, intent(in) :: y
        iy_pos = self%fig%nsize_y - nint( (y - self%y0) / (self%y1 - self%y0) * self%fig%nsize_y )
      end function iy_pos  
        
      subroutine move_r(self, x, y)
        class (t_fig), intent(in) :: self
        real, intent(in) :: x, y
        call self%fig%move(ix_pos(self, x), iy_pos(self, y))
      end subroutine move_r

      subroutine line_r(self, x, y)
        class (t_fig), intent(in) :: self
        real, intent(in) :: x, y
        call self%fig%line(ix_pos(self, x), iy_pos(self, y))
      end subroutine line_r
      
      subroutine font_sub(self, ix, iy, font, scale, angle)
        class (t_fig), intent(in) :: self
        integer, value :: ix, iy
        type (t_font), intent(in) :: font 
        real, intent(in) :: scale, angle 
        integer :: i, ix0, iy0
        real :: dx, dy, c, s
        s = sin(angle * pi / 180.0)
        c = cos(angle * pi / 180.0)
        do i = 1, size(font%pen)
          ix0 = ix
          iy0 = iy
          dx = font%pen(i)%ix * scale
          dy = font%pen(i)%iy * scale
          ix = ix + nint(dx * c - dy * s)
          iy = iy - nint(dx * s + dy * c)
          if ( font%pen(i)%ipen == 1 ) then ! pen up
            call self%fig%move(ix, iy)
          else ! pen down
            call self%fig%line(ix, iy)
            call self%fig%line(ix0, iy0) ! these lines are requird for win32 
            call self%fig%move(ix , iy ) ! win32 does not plot the end point ! [x0, x1)
          end if
        end do
      end subroutine font_sub
      
      subroutine text_i(self, ix, iy, text, scale, angle, adjust)
        class (t_fig), intent(in) :: self 
        integer, value :: ix, iy
        character (len = *), intent(in) :: text
        real, intent(in), optional :: scale, angle
        character (len = *), intent(in), optional :: adjust
        real :: rscale = 1.0, rangle = 0.0
        integer :: len_wo_bksl
        if (present(scale)) rscale = scale
        if (present(angle)) rangle = angle
        select case (trim(adjust))
          case('center') 
            len_wo_bksl = len_trim(text) - 2 * count(transfer(trim(text), ' ', len_trim(text)) == '\') ! miscounts \\ !
            ix = ix - nint(nsize_font_x * rscale * cos(rangle * pi / 180.0) * 1.0 / 2.5) * len_wo_bksl
            iy = iy + nint(nsize_font_x * rscale * sin(rangle * pi / 180.0) * 1.0 / 2.5) * len_wo_bksl
          case('right')
            len_wo_bksl = len_trim(adjustl(text)) - 2 * count(transfer(trim(text), ' ', len_trim(text)) == '\') ! miscounts \\ !
            ix = ix - nint(nsize_font_x * rscale * cos(rangle * pi / 180.0) * 0.8) * len_wo_bksl    
            iy = iy + nint(nsize_font_x * rscale * sin(rangle * pi / 180.0) * 0.8) * len_wo_bksl
        end select  
        call text_sub(self, ix, iy, text, rscale, rangle)
      end subroutine text_i

      subroutine text_r(self, x, y, text, scale, angle, adjust)
        class (t_fig), intent(in) :: self 
        real, intent(in) :: x, y
        character (len = *), intent(in) :: text
        real, intent(in), optional :: scale, angle
        character (len = *), intent(in), optional :: adjust
        integer :: ix, iy
        ix = ix_pos(self, x)
        iy = iy_pos(self, y)
        call text_i(self, ix, iy, text, scale, angle, adjust)
      end subroutine text_r
      
      subroutine text_sub(self, ix, iy, text, scale, angle)
        class (t_fig), intent(in) :: self 
        integer, value :: ix, iy
        character (len = *), intent(in) :: text
        real, intent(in) :: scale, angle
        real :: dx, dy, ex, ey, d(2), e(2)
        integer :: i, kx, ky
        d = nsize_font_x * scale * rotate(-angle, [1.0, 0.0], [0.0, 0.0]) * 0.8 ! spacing
        dx = d(1)
        dy = d(2)
        e = nsize_font_y * scale * rotate(-angle, [0.0, 1.0], [0.0, 0.0])
        ex = e(1)
        ey = e(2)
        i = 1
        do 
          if (i > len_trim(text)) exit
          select case (text(i:i))
            case (' ')  
              ix = ix + nint(dx * 0.5)
              iy = iy + nint(dy * 0.5)
            case ('\')
              i = i + 1
              if (scan(text(i:i), 'Gg') /= 0) then ! greek letter
                i = i + 1
                call self%font(ix, iy, greek(to_greek(text(i:i))), scale, angle)
                ix = ix + nint(dx * 1.3)
                iy = iy + nint(dy * 1.3)
              else if (text(i:i) == ' ') then ! subscript
                ix = ix - nint(dx * 0.5)
                iy = iy - nint(dy * 0.5) 
              else if (text(i:i) == '_') then ! subscript
                i = i + 1
                kx = nint(ex * 0.25)
                ky = nint(ey * 0.25) 
                if (text(i:i) == '\') then
                  if(scan(text(i+1:i+1), 'Gg') /= 0) then 
                    i = i + 2
                    call self%font(ix + kx, iy + ky,    greek(to_greek(text(i:i)))   , scale * 0.5, angle)
                  end if 
                else
                  call self%font(ix + kx, iy + ky, alphanum(to_alphanum(text(i:i))), scale * 0.5, angle)
                end if
                ix = ix + nint(dx * 0.5)
                iy = iy + nint(dy * 0.5)
              else if (text(i:i) == '^') then ! super script  
                i = i + 1
                kx = nint(ex * 0.7)
                ky = nint(ey * 0.7) 
                if (text(i:i) == '\') then
                  if(scan(text(i+1:i+1), 'Gg') /= 0) then 
                    i = i + 2
                    call self%font(ix - kx, iy - ky,    greek(to_greek(text(i:i)))   , scale * 0.5, angle)
                   end if  
                else
                  call self%font(ix - kx, iy - ky, alphanum(to_alphanum(text(i:i))), scale * 0.5, angle)
                end if
                ix = ix + nint(dx * 0.5)
                iy = iy + nint(dy * 0.5)
              else if (text(i:i) == '\') then ! super script  
                call self%font(ix, iy, alphanum(to_alphanum(text(i:i))), scale * 0.7, angle)
                ix = ix + dx
                iy = iy + dy
              else if (text(i:i) == 'h') then ! hbar  
                kx = nint(ex * 0.2 - dx * 0.15)
                ky = nint(ey * 0.2 + dy * 0.15)
                call self%font(ix, iy, alphanum(to_alphanum(text(i:i))), scale, angle)
                call self%font(ix + kx, iy + ky, alphanum(to_alphanum('-')), scale, angle)
                ix = ix + dx
                iy = iy + dy
              else
                ix = ix + nint(dx * 0.5)
                iy = iy + nint(dy * 0.5)
                !print *, 'error!'  
              end if    
            case default
              call self%font(ix, iy, alphanum(to_alphanum(text(i:i))), scale, angle)
              ix = ix + dx
              iy = iy + dy
          end select  
          i = i + 1  
        end do
      end subroutine text_sub
      
     function rotate(angle, pos, center) result(res)
        real, intent(in) :: angle, pos(2), center(2)
        real :: res(2)
        real, parameter  :: rad = pi / 180.0  ! degree to radian
        real :: rm(2, 2) 
        rm = reshape([[cos(angle * rad), sin(angle * rad)], [-sin(angle * rad), cos(angle * rad)]], [2, 2])
        res = matmul(rm, pos - center) +  center
      end function rotate
    end module m_plot