デバイスに依らないで同じ出力を得るにはフォントも自分で持っていると都合よいです。見栄えのいいのを作るのは面倒ですが、清書はちゃんとしたソフトでやるとして、作業用に使う分には適当で何とかなります。いま、英字とギリシア文字を用意しています。
またフォントルーチンで文字が書けるようになったとして、向きを回転させたり上付き下付きなどを実現するには、またフォントの上位のルーチンを書かねばなりません。これも面倒なのですが、ある程度割り切れば素朴に実現できます。グラフをプロットする目的には、文字列のセンタリングや右詰めが出来ると便利なので、一応作ってみましたが、まだ完全に機能していません。
自分用メモ帳として記録しておきます。
出力例
プログラム
先日の低レベル・ルーチンの上で動きます。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
