[fortran] 日本NAG社製 Fortran Builderのすごみ
OSの操作（ディレクトリ処理、ファイルリスト処理、外部プログラム実行など）をソース内で実現するコマンド群がおまけで実装されています。これは便利^^/ みんなで使いましょう
[fortran] 全角空白「 」を2個の半角空白「 」に変換するプログラム部品
全角空白「 」を２個の半角空白「 」に変換するプログラム部品です。
行のコラム数自体は変更しませんので列が崩れたりしないところがポイントです。
データ編集ではこの目に見えない「全角空白」というものが悪さをします。
このプログラム部品を用いて、まず最初に処理対象のデータファイル全体について
全角空白を半角空白に変換しておけば、
データ編集でのエラーを格段に減らすことができます。
応用編として2個ではなく1個の半角空白に変換したいなら
とある部分を書き直せばよいです。
なお、文字コードはWindowsを想定しています。
別のコンピュータの場合にはそれぞれ適切な文字コード表を 用いる必要があります。
!tm -------------------------------------------------------
subroutine chg_fs2hs(ifile, ofile)
!tm 「 」全角空白 -> 「 」半角空白
integer (8), parameter :: in_unit = 9917
integer (8), parameter :: out_unit = 9918
character (len=2), parameter :: moji_to_find = char(129) // char(64) ! full-width space「 」
character (len=2), parameter :: moji_to_replace_with = ' ' ! two half-width spaces「 」
character (len=2) :: moji
character (*) :: ifile, ofile
open (in_unit, file=ifile, access='stream', form='formatted', status='unknown')
open (out_unit, file=ofile, access='stream', form='formatted', status='unknown')
do
read (in_unit, '(a)', advance='no', eor=100, end=110) moji(1:1) ! read the first byte
if (ichar(moji(1:1))>127) then ! assume two-byte character if 1st byte is > 127
read (in_unit, '(a)', advance='no') moji(2:2) ! read the 2nd byte
if (moji==moji_to_find) then
write (out_unit, '(a)', advance='no') moji_to_replace_with ! output replaced char
else
write (out_unit, '(a)', advance='no') moji ! two-byte char output as is
end if
else
write (out_unit, '(a)', advance='no') moji(1:1) ! single byte char output as is
end if
cycle
100 write (out_unit, '()') ! new record
end do
110 continue
close (in_unit)
close (out_unit)
end subroutine chg_fs2hs
行のコラム数自体は変更しませんので列が崩れたりしないところがポイントです。
データ編集ではこの目に見えない「全角空白」というものが悪さをします。
このプログラム部品を用いて、まず最初に処理対象のデータファイル全体について
全角空白を半角空白に変換しておけば、
データ編集でのエラーを格段に減らすことができます。
応用編として2個ではなく1個の半角空白に変換したいなら
とある部分を書き直せばよいです。
なお、文字コードはWindowsを想定しています。
別のコンピュータの場合にはそれぞれ適切な文字コード表を 用いる必要があります。
!tm -------------------------------------------------------
subroutine chg_fs2hs(ifile, ofile)
!tm 「 」全角空白 -> 「 」半角空白
integer (8), parameter :: in_unit = 9917
integer (8), parameter :: out_unit = 9918
character (len=2), parameter :: moji_to_find = char(129) // char(64) ! full-width space「 」
character (len=2), parameter :: moji_to_replace_with = ' ' ! two half-width spaces「 」
character (len=2) :: moji
character (*) :: ifile, ofile
open (in_unit, file=ifile, access='stream', form='formatted', status='unknown')
open (out_unit, file=ofile, access='stream', form='formatted', status='unknown')
do
read (in_unit, '(a)', advance='no', eor=100, end=110) moji(1:1) ! read the first byte
if (ichar(moji(1:1))>127) then ! assume two-byte character if 1st byte is > 127
read (in_unit, '(a)', advance='no') moji(2:2) ! read the 2nd byte
if (moji==moji_to_find) then
write (out_unit, '(a)', advance='no') moji_to_replace_with ! output replaced char
else
write (out_unit, '(a)', advance='no') moji ! two-byte char output as is
end if
else
write (out_unit, '(a)', advance='no') moji(1:1) ! single byte char output as is
end if
cycle
100 write (out_unit, '()') ! new record
end do
110 continue
close (in_unit)
close (out_unit)
end subroutine chg_fs2hs
[fortran] 半角数字を整数実数に変換する（その逆も）
以下の部品を使うと、文字の半角数字を、整数や実数に変換できます。
とっても便利！^^
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! read(moji,'(f10.5)') suji !! moji -> suji (文字を数字に変換)
! write(moji,'(i2.2)') suji !! suji -> moji (数字を文字に変換)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
integer :: suji
character(10) :: moji
moji='1234'
read(moji, '(i10)') suji
write(*,'(i10)') ' suji: ',suji
とっても便利！^^
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! read(moji,'(f10.5)') suji !! moji -> suji (文字を数字に変換)
! write(moji,'(i2.2)') suji !! suji -> moji (数字を文字に変換)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
integer :: suji
character(10) :: moji
moji='1234'
read(moji, '(i10)') suji
write(*,'(i10)') ' suji: ',suji
[fortran] 全角数字を半角数字に変換するプログラム部品
全角数字「１２３」などを半角数字「123」などに変換するプログラム部品（Fortran90）です。
これを応用すれば、ある部分を変更するだけで他の文字などへも変更できます。
どうぞご利用ください。
!tm -------------------------------------------------------
subroutine chg_fd2hd(ifile, ofile)
!tm 全角数字 -> 半角数字
integer (8), parameter :: in_unit = 9917
integer (8), parameter :: out_unit = 9918
character (len=2) :: moji
character (*) :: ifile, ofile
open (in_unit, file=ifile, access='stream', form='formatted', status='unknown')
open (out_unit, file=ofile, access='stream', form='formatted', status='unknown')
do
read (in_unit, '(a)', advance='no', eor=100, end=110) moji(1:1) ! read the first byte
if (ichar(moji(1:1))>127) then ! assume two-byte character if 1st byte is > 127
read (in_unit, '(a)', advance='no') moji(2:2) ! read the 2nd byte
if (moji(1:1)==char(130) .and. moji(2:2)>=char(79) .and. moji(2:2)<=char(88)) then ! if moji is full-width digit
write (out_unit, '(a)', advance='no') char(48+ichar(moji(2:2))-79) ! convert to half-width digiti
else
write (out_unit, '(a)', advance='no') moji ! two-byte char output as is
end if
else
write (out_unit, '(a)', advance='no') moji(1:1) ! single byte char output as is
end if
cycle
100 write (out_unit, '()') ! new record
end do
110 continue
close (in_unit)
close (out_unit)
end subroutine chg_fd2hd
これを応用すれば、ある部分を変更するだけで他の文字などへも変更できます。
どうぞご利用ください。
!tm -------------------------------------------------------
subroutine chg_fd2hd(ifile, ofile)
!tm 全角数字 -> 半角数字
integer (8), parameter :: in_unit = 9917
integer (8), parameter :: out_unit = 9918
character (len=2) :: moji
character (*) :: ifile, ofile
open (in_unit, file=ifile, access='stream', form='formatted', status='unknown')
open (out_unit, file=ofile, access='stream', form='formatted', status='unknown')
do
read (in_unit, '(a)', advance='no', eor=100, end=110) moji(1:1) ! read the first byte
if (ichar(moji(1:1))>127) then ! assume two-byte character if 1st byte is > 127
read (in_unit, '(a)', advance='no') moji(2:2) ! read the 2nd byte
if (moji(1:1)==char(130) .and. moji(2:2)>=char(79) .and. moji(2:2)<=char(88)) then ! if moji is full-width digit
write (out_unit, '(a)', advance='no') char(48+ichar(moji(2:2))-79) ! convert to half-width digiti
else
write (out_unit, '(a)', advance='no') moji ! two-byte char output as is
end if
else
write (out_unit, '(a)', advance='no') moji(1:1) ! single byte char output as is
end if
cycle
100 write (out_unit, '()') ! new record
end do
110 continue
close (in_unit)
close (out_unit)
end subroutine chg_fd2hd
[fortran] 分子血縁行列作成プログラム部品
変量効果の推定とBLUP法 単行本 2007/2
佐々木 義之 (著)
ISBN-13: 978-4876987023
のp124にて掲載された内容を実装したFortran90プログラム部品です。自由にご利用ください。
!tm -------------------------------------------------------
subroutine create_a00
! numerator relatonship matrix subroutine by Fortran90
! 出典：
! 変量効果の推定とBLUP法 単行本 2007/2
! 佐々木 義之 (著)
! ISBN-13: 978-4876987023
! p124
!----------------------------
! a s d sex -> a s d renumbered!
! 1 0 0 m 1 0 0
! 2 1 0 m 2 1 0
! x 1 0 f 3 1 0
! y 1 0 f 4 1 0
! 3 1 0 m 5 2 0
! 4 1 0 m 6 1 0
! 5 3 0 m 7 5 0
! 6 0 x m 8 0 3
! 7 3 y m 9 5 4
!----------------------------
integer, parameter :: nanim = 9
integer :: i, j
real (8) :: amat(0:nanim, 0:nanim)
real (8) :: atmp
integer :: sid(nanim), did(nanim)
print *, '--- create_A00_sasaki ---'
!tm -------------------------
sid(1) = 0
sid(2) = 1
sid(3) = 1
sid(4) = 1
sid(5) = 2
sid(6) = 1
sid(7) = 5
sid(8) = 0
sid(9) = 5
!tm -------------------------
did(1) = 0
did(2) = 0
did(3) = 0
did(4) = 0
did(5) = 0
did(6) = 0
did(7) = 0
did(8) = 3
did(9) = 4
!tm -------------------------
do i = 1, nanim
if (sid(i)>0 .and. did(i)>0) then
amat(i, i) = 1.0d0 + 0.5d0*amat(sid(i), did(i))
else
amat(i, i) = 1.0d0
end if
do j = 1, i - 1
atmp = 0.0d0
if (sid(i)>0) atmp = atmp + 0.5d0*amat(j, sid(i))
if (did(i)>0) atmp = atmp + 0.5d0*amat(j, did(i))
amat(j, i) = atmp
amat(i, j) = atmp
end do
end do
write (*, *) '2016 blup sasaki book p124'
write (*, *) '* a s d sex -> a s d revnum'
write (*, *) '* 1 0 0 m 1 0 0'
write (*, *) '* 2 1 0 m 2 1 0'
write (*, *) '* x 1 0 f 3 1 0'
write (*, *) '* y 1 0 f 4 1 0'
write (*, *) '* 3 1 0 m 5 2 0'
write (*, *) '* 4 1 0 m 6 1 0'
write (*, *) '* 5 3 0 m 7 5 0'
write (*, *) '* 6 0 x m 8 0 3'
write (*, *) '* 7 3 y m 9 5 4'
write (*, *) ''
do i = 1, nanim
write (*, '(20f7.4)')(amat(i,j), j=1, nanim)
end do
! 1.0000 0.5000 0.5000 0.5000 0.2500 0.5000 0.1250 0.2500 0.3750
! 0.5000 1.0000 0.2500 0.2500 0.5000 0.2500 0.2500 0.1250 0.3750
! 0.5000 0.2500 1.0000 0.2500 0.1250 0.2500 0.0625 0.5000 0.1875
! 0.5000 0.2500 0.2500 1.0000 0.1250 0.2500 0.0625 0.1250 0.5625
! 0.2500 0.5000 0.1250 0.1250 1.0000 0.1250 0.5000 0.0625 0.5625
! 0.5000 0.2500 0.2500 0.2500 0.1250 1.0000 0.0625 0.1250 0.1875
! 0.1250 0.2500 0.0625 0.0625 0.5000 0.0625 1.0000 0.0313 0.2813
! 0.2500 0.1250 0.5000 0.1250 0.0625 0.1250 0.0313 1.0000 0.0938
! 0.3750 0.3750 0.1875 0.5625 0.5625 0.1875 0.2813 0.0938 1.0625
end subroutine create_a00
佐々木 義之 (著)
ISBN-13: 978-4876987023
のp124にて掲載された内容を実装したFortran90プログラム部品です。自由にご利用ください。
!tm -------------------------------------------------------
subroutine create_a00
! numerator relatonship matrix subroutine by Fortran90
! 出典：
! 変量効果の推定とBLUP法 単行本 2007/2
! 佐々木 義之 (著)
! ISBN-13: 978-4876987023
! p124
!----------------------------
! a s d sex -> a s d renumbered!
! 1 0 0 m 1 0 0
! 2 1 0 m 2 1 0
! x 1 0 f 3 1 0
! y 1 0 f 4 1 0
! 3 1 0 m 5 2 0
! 4 1 0 m 6 1 0
! 5 3 0 m 7 5 0
! 6 0 x m 8 0 3
! 7 3 y m 9 5 4
!----------------------------
integer, parameter :: nanim = 9
integer :: i, j
real (8) :: amat(0:nanim, 0:nanim)
real (8) :: atmp
integer :: sid(nanim), did(nanim)
print *, '--- create_A00_sasaki ---'
!tm -------------------------
sid(1) = 0
sid(2) = 1
sid(3) = 1
sid(4) = 1
sid(5) = 2
sid(6) = 1
sid(7) = 5
sid(8) = 0
sid(9) = 5
!tm -------------------------
did(1) = 0
did(2) = 0
did(3) = 0
did(4) = 0
did(5) = 0
did(6) = 0
did(7) = 0
did(8) = 3
did(9) = 4
!tm -------------------------
do i = 1, nanim
if (sid(i)>0 .and. did(i)>0) then
amat(i, i) = 1.0d0 + 0.5d0*amat(sid(i), did(i))
else
amat(i, i) = 1.0d0
end if
do j = 1, i - 1
atmp = 0.0d0
if (sid(i)>0) atmp = atmp + 0.5d0*amat(j, sid(i))
if (did(i)>0) atmp = atmp + 0.5d0*amat(j, did(i))
amat(j, i) = atmp
amat(i, j) = atmp
end do
end do
write (*, *) '2016 blup sasaki book p124'
write (*, *) '* a s d sex -> a s d revnum'
write (*, *) '* 1 0 0 m 1 0 0'
write (*, *) '* 2 1 0 m 2 1 0'
write (*, *) '* x 1 0 f 3 1 0'
write (*, *) '* y 1 0 f 4 1 0'
write (*, *) '* 3 1 0 m 5 2 0'
write (*, *) '* 4 1 0 m 6 1 0'
write (*, *) '* 5 3 0 m 7 5 0'
write (*, *) '* 6 0 x m 8 0 3'
write (*, *) '* 7 3 y m 9 5 4'
write (*, *) ''
do i = 1, nanim
write (*, '(20f7.4)')(amat(i,j), j=1, nanim)
end do
! 1.0000 0.5000 0.5000 0.5000 0.2500 0.5000 0.1250 0.2500 0.3750
! 0.5000 1.0000 0.2500 0.2500 0.5000 0.2500 0.2500 0.1250 0.3750
! 0.5000 0.2500 1.0000 0.2500 0.1250 0.2500 0.0625 0.5000 0.1875
! 0.5000 0.2500 0.2500 1.0000 0.1250 0.2500 0.0625 0.1250 0.5625
! 0.2500 0.5000 0.1250 0.1250 1.0000 0.1250 0.5000 0.0625 0.5625
! 0.5000 0.2500 0.2500 0.2500 0.1250 1.0000 0.0625 0.1250 0.1875
! 0.1250 0.2500 0.0625 0.0625 0.5000 0.0625 1.0000 0.0313 0.2813
! 0.2500 0.1250 0.5000 0.1250 0.0625 0.1250 0.0313 1.0000 0.0938
! 0.3750 0.3750 0.1875 0.5625 0.5625 0.1875 0.2813 0.0938 1.0625
end subroutine create_a00
