gfortran-9 で parameterized derived type が使えるようになりました。そこで gfortran-9 でも動くように微修正しました。
すみません、色々手違いがあって parameterized derived type ではないプログラムになっていました。parameterized derived type 版は ifort v.19.0 では動きますが、gfortran-9 ではコンパイルできませんでした。お詫びして訂正します。プログラムは parameterized derived type 版にしておきます。
parameterized derived type とオブジェクト指向の仕組みは相性が悪く、メソッドの定義や extends がうまくゆきません。色々迂回措置が必要になります。parameterized derived type は、ほとんどいいとこなしの機能ですｗ
gfortran-9 で出るエラー
hp8@HP8:~/f2018$ gfortran-9 pbmp.f90
pbmp.f90:40:21:
40 | procedure :: wr => wr_bmp
| 1
Error: Argument ‘bmp’ of ‘wr_bmp’ with PASS(bmp) at (1) must be of the derived-type ‘t_bmp’
BMP 拡張
以前作った bmp 構造体を extends で拡張して、点を打ったり、直線を引いたり出来るようにしてみました。
とりあえず、直線で出来るものを描いて見ることにしました。円の塗りつぶしは直線で実現しています。
日輪の輝き！
ソース
module m_bmp
use, intrinsic :: iso_fortran_env
implicit none
type :: t_bmp_file_header
sequence
integer(int16) :: bfType = Z'4d42'!transfer('BM', 0_2, 1)!B=42 M=4d little endian BitMap
integer(int32) :: bfSize ! file size in bytes
integer(int16) :: bfReserved1 = 0 ! always 0
integer(int16) :: bfReserved2 = 0 ! always 0
integer(int32) :: bfOffBits
end type t_bmp_file_header
type :: t_bmp_info_header
sequence
integer(int32) :: biSize = Z'28' ! size of bmp_info_header ; 40bytes
integer(int32) :: biWidth
integer(int32) :: biHeight
integer(int16) :: biPlanes = 1 ! always 1
integer(int16) :: biBitCount
integer(int32) :: biCompression = 0 !0:nocompression,1:8bitRLE,2:4bitRLE,3:bitfield
integer(int32) :: biSizeImage
integer(int32) :: biXPelsPerMeter = 3780 ! 96dpi
integer(int32) :: biYPelsPerMeter = 3780 ! 96dpi
integer(int32) :: biClrUsed = 0
integer(int32) :: biClrImportant = 0
end type t_bmp_info_header
type :: t_rgb
sequence
character :: b = achar(0), g = achar(0), r = achar(0) ! char as uint
end type t_rgb
type :: t_bmp(nx, ny)
integer, len :: nx = 0, ny = 0
type (t_rgb) :: rgb(nx, ny)
contains
procedure :: wr => wr_bmp
end type
contains
subroutine wr_bmp(bmp, fn)
class (t_bmp(*, *)), intent(in) :: bmp
character (len = *), intent(in) :: fn
type (t_bmp_file_header) :: bmp_file_header
type (t_bmp_info_header) :: bmp_info_header
integer :: i, j, iw
associate(nx => bmp%nx, ny => bmp%ny)
bmp_file_header%bfSize = 14 + 40 + 0 + (3 * nx + mod(nx, 4)) * ny
bmp_file_header%bfOffBits = 14 + 40
bmp_info_header%biWidth = nx
bmp_info_header%biHeight = ny
bmp_info_header%biBitCount = 24
bmp_info_header%biSizeImage = (3 * nx + mod(nx, 4)) * ny
open(newunit = iw, file = fn//'.bmp', access = 'stream', status = 'unknown')
write(iw) bmp_file_header
write(iw) bmp_info_header
write(iw) (bmp%rgb(:, i), (achar(0), j = 1, mod(nx, 4)), i = 1, ny)
close(iw)
end associate
end subroutine wr_bmp
subroutine rd_bmp(bmp, fn)
type (t_bmp(:, :)) , intent(out), allocatable :: bmp
character (len = *), intent(in) :: fn
type (t_bmp_file_header) :: bmp_file_header
type (t_bmp_info_header) :: bmp_info_header
integer :: i, j, ir
character :: dummy
associate(nx => bmp_info_header%biWidth, ny => bmp_info_header%biHeight)
open(newunit = ir, file = fn//'.bmp', access = 'stream', status = 'old')
read(ir) bmp_file_header
read(ir) bmp_info_header
allocate(t_bmp(nx, ny)::bmp)
read(ir) (bmp%rgb(:, i), (dummy, j = 1, mod(nx, 4)), i = 1, ny)
close(ir)
end associate
end subroutine rd_bmp
end module m_bmp
module m_pic
use m_bmp
implicit none
type :: t_pic
type(t_bmp(:, :)), allocatable :: bmp
contains
procedure :: point, line, rd, wr
end type t_pic
interface t_pic
module procedure :: init_pic
end interface t_pic
contains
type (t_pic) function init_pic(nx, ny) result(pic)
integer, intent(in) :: nx, ny
allocate(t_bmp(nx, ny)::pic%bmp)
end function init_pic
subroutine wr(pic, fn)
class(t_pic), intent(in out) :: pic
character(*), intent(in) :: fn
call pic%bmp%wr(fn)
end subroutine wr
subroutine rd(pic, fn)
class(t_pic), intent(in out) :: pic
character(*), intent(in) :: fn
call rd_bmp(pic%bmp, fn)
end subroutine rd
subroutine point(pic, ix, iy, rgb)
class (t_pic), intent(in out) :: pic
integer , intent(in) :: ix, iy
type (t_rgb) , intent(in) :: rgb
pic%bmp%rgb(ix, iy) = rgb
end subroutine point
subroutine line(pic, ix0, iy0, ix1, iy1, rgb)
class (t_pic), intent(in out) :: pic
integer , intent(in) :: ix0, iy0, ix1, iy1
type (t_rgb) , intent(in) :: rgb
integer :: ix, iy, mx, my
real :: dx, dy, x, y
mx = ix1 - ix0
my = iy1 - iy0
if (mx == 0 .and. my == 0) return
if (abs(mx) > abs(my)) then
dy = my / real(mx)
y = iy0
do ix = 0, mx, sign(1, mx)
y = dy * ix
iy = nint(y)
call pic%point(ix0 + ix, iy0 + iy, rgb)
end do
else
dx = mx / real(my)
x = ix0
do iy = 0, my, sign(1, my)
x = dx * iy
ix = nint(x)
call pic%point(ix0 + ix, iy0 + iy, rgb)
end do
end if
end subroutine line
end module m_pic
program The_Sun
use m_pic
implicit none
type (t_rgb), parameter :: White = t_rgb(achar(255), achar(255), achar(255)), &
& Red = t_rgb(achar( 0), achar( 0), achar(255))
integer, parameter :: nx = 640, ny = 480
integer :: i, ix, iy, ix0, ix1, iy0, iy1, nr
real :: x, y
type (t_pic) :: pic1, pic2
pic2 = t_pic(nx, ny)
pic2%bmp%rgb = White
nr = 110
do iy = 0, nr
ix = sqrt(real(nr**2 - iy**2))
ix0 = nx / 2 - ix
ix1 = nx / 2 + ix
iy0 = ny / 2 - iy
iy1 = ny / 2 + iy
call pic2%line(ix0, iy0, ix1, iy0, Red)
call pic2%line(ix0, iy1, ix1, iy1, Red)
end do
do ix = 1, 3 * nx / 18
ix0 = 0 + ix
ix1 = nx - ix
iy0 = ny
iy1 = 1
call pic2%line(ix0, iy0, ix1, iy1, Red)
call pic2%line(ix1, iy0, ix0, iy1, Red)
end do
do ix = nx / 4, 6 * nx / 17
ix0 = 0 + ix
ix1 = nx - ix
iy0 = ny
iy1 = 1
call pic2%line(ix0, iy0, ix1, iy1, Red)
call pic2%line(ix1, iy0, ix0, iy1, Red)
end do
do ix = 7 * nx / 16, nx / 2
ix0 = 0 + ix
ix1 = nx - ix
iy0 = ny
iy1 = 1
call pic2%line(ix0, iy0, ix1, iy1, Red)
call pic2%line(ix1, iy0, ix0, iy1, Red)
end do
do iy = ny / 7, 5 * ny / 17
ix0 = 1
ix1 = nx
iy0 = 1 + iy
iy1 = ny - iy
call pic2%line(ix0, iy0, ix1, iy1, Red)
call pic2%line(ix1, iy0, ix0, iy1, Red)
end do
do iy = 8 * ny / 19, ny / 2
ix0 = 1
ix1 = nx
iy0 = 1 + iy
iy1 = ny - iy
call pic2%line(ix0, iy0, ix1, iy1, Red)
call pic2%line(ix1, iy0, ix0, iy1, Red)
end do
call pic2%wr('SUN')
end program The_Sun