４次の場合
計算結果
行列が転置されていなかったので修正。
STY [4] irow = 1 icol = 1 +I +(12) +(13) +(14) +(23) +(24) +(34) +(123) +(132) +(124) +(142) +(134) +(143) +(234) +(243) +(1234) +(1432) +(1243) +(1342) +(132 4) +(1423) +(12)(34) +(13)(24) +(14)(23) I^-1 1 (12)^-1 1 (13)^-1 1 (14)^-1 1 (23)^-1 1 (24)^-1 1 (34)^-1 1 (123)^-1 1 (132)^-1 1 (124)^-1 1 (142)^-1 1 (134)^-1 1 (143)^-1 1 (234)^-1 1 (243)^-1 1 (1234)^-1 1 (1432)^-1 1 (1243)^-1 1 (1342)^-1 1 (1324)^-1 1 (1423)^-1 1 (12)(34)^-1 1 (13)(24)^-1 1 (14)(23)^-1 1 STY [31] irow = 1 icol = 1 +I -(14) +(12) -(142) +(13) -(143) +(23) -(14)(23) +(123) -(1423) +(132) -(1432) irow = 1 icol = 2 +(34) -(143) +(12)(34) -(1432) +(134) -(14) +(234) -(1423) +(1234) -(14)(23) +(1342) -(142) irow = 1 icol = 3 +(243) -(1432) +(1243) -(143) +(1324) -(14)(23) +(24) -(142) +(124) -(14) +(13)(24) -(1423) irow = 2 icol = 1 +(34) -(134) +(12)(34) -(1342) +(143) -(13) +(243) -(1324) +(1243) -(13)(24) +(1432) -(132) irow = 2 icol = 2 +I -(13) +(12) -(132) +(14) -(134) +(24) -(13)(24) +(124) -(1324) +(142) -(1342) irow = 2 icol = 3 +(23) -(132) +(123) -(13) +(14)(23) -(1324) +(234) -(1342) +(1234) -(134) +(1423) -(13)(24) irow = 3 icol = 1 +(234) -(1234) +(1342) -(12)(34) +(1423) -(123) +(24) -(124) +(13)(24) -(1243) +(142) -(12) irow = 3 icol = 2 +(23) -(123) +(132) -(12) +(14)(23) -(1234) +(243) -(1243) +(1324) -(124) +(1432) -(12)(34) irow = 3 icol = 3 +I -(12) +(13) -(123) +(14) -(124) +(34) -(12)(34) +(134) -(1234) +(143) -(1243) I^-1 1 0 0 0 1 0 0 0 1 (12)^-1 1 0 -1 0 1 -1 0 0 -1 (13)^-1 1 -1 0 0 -1 0 0 -1 1 (14)^-1 -1 0 0 -1 1 0 -1 0 1 (23)^-1 1 0 0 0 0 1 0 1 0 (24)^-1 0 0 1 0 1 0 1 0 0 (34)^-1 0 1 0 1 0 0 0 0 1 (123)^-1 1 0 -1 0 0 -1 0 1 -1 (132)^-1 1 -1 0 0 -1 1 0 -1 0 (124)^-1 0 0 -1 0 1 -1 1 0 -1 (142)^-1 -1 0 1 -1 1 0 -1 0 0 (134)^-1 0 -1 0 1 -1 0 0 -1 1 (143)^-1 -1 1 0 -1 0 0 -1 0 1 (234)^-1 0 0 1 1 0 0 0 1 0 (243)^-1 0 1 0 0 0 1 1 0 0 (1234)^-1 0 0 -1 1 0 -1 0 1 -1 (1432)^-1 -1 1 0 -1 0 1 -1 0 0 (1243)^-1 0 1 -1 0 0 -1 1 0 -1 (1342)^-1 0 -1 1 1 -1 0 0 -1 0 (1324)^-1 0 -1 0 0 -1 1 1 -1 0 (1423)^-1 -1 0 1 -1 0 0 -1 1 0 (12)(34)^-1 0 1 -1 1 0 -1 0 0 -1 (13)(24)^-1 0 -1 1 0 -1 0 1 -1 0 (14)(23)^-1 -1 0 0 -1 0 1 -1 1 0 STY [22] irow = 1 icol = 1 +I -(13) -(24) +(13)(24) +(12) -(132) -(124) +(1324) +(34) -(143) -(234) +(1423) +(12)(34) -(1432) -(1234) +(14)(23) irow = 1 icol = 2 +(23) -(132) -(234) +(1342) +(123) -(13) -(1234) +(134) +(243) -(1432) -(24) +(142) +(1243) -(143) -(124) +(14) irow = 2 icol = 1 +(23) -(123) -(243) +(1243) +(132) -(12) -(1324) +(124) +(234) -(1423) -(34) +(143) +(1342) -(142) -(134) +(14) irow = 2 icol = 2 +I -(12) -(34) +(12)(34) +(13) -(123) -(134) +(1234) +(24) -(142) -(243) +(1432) +(13)(24) -(1423) -(1324) +(14)(23) I^-1 1 0 0 1 (12)^-1 1 -1 0 -1 (13)^-1 -1 0 -1 1 (14)^-1 0 1 1 0 (23)^-1 0 1 1 0 (24)^-1 -1 0 -1 1 (34)^-1 1 -1 0 -1 (123)^-1 0 -1 1 -1 (132)^-1 -1 1 -1 0 (124)^-1 -1 1 -1 0 (142)^-1 0 -1 1 -1 (134)^-1 0 -1 1 -1 (143)^-1 -1 1 -1 0 (234)^-1 -1 1 -1 0 (243)^-1 0 -1 1 -1 (1234)^-1 -1 0 -1 1 (1432)^-1 -1 0 -1 1 (1243)^-1 0 1 1 0 (1342)^-1 0 1 1 0 (1324)^-1 1 -1 0 -1 (1423)^-1 1 -1 0 -1 (12)(34)^-1 1 0 0 1 (13)(24)^-1 1 0 0 1 (14)(23)^-1 1 0 0 1 STY [211] irow = 1 icol = 1 +I -(13) -(14) -(34) +(134) +(143) +(12) -(132) -(142) -(12)(34) +(1342) +(1432) irow = 1 icol = 2 +(23) -(132) -(14)(23) -(243) +(1324) +(1432) +(123) -(13) -(1423) -(1243) +(13)(24) +(143) irow = 1 icol = 3 +(234) -(1342) -(1423) -(24) +(13)(24) +(142) +(1234) -(134) -(14)(23) -(124) +(1324) +(14) irow = 2 icol = 1 +(23) -(123) -(14)(23) -(234) +(1234) +(1423) +(132) -(12) -(1432) -(1342) +(12)(34) +(142) irow = 2 icol = 2 +I -(12) -(14) -(24) +(124) +(142) +(13) -(123) -(143) -(13)(24) +(1243) +(1423) irow = 2 icol = 3 +(34) -(12)(34) -(143) -(243) +(1243) +(1432) +(134) -(1234) -(14) -(1324) +(124) +(14)(23) irow = 3 icol = 1 +(243) -(1243) -(1324) -(24) +(124) +(13)(24) +(1432) -(12)(34) -(132) -(142) +(12) +(1342) irow = 3 icol = 2 +(34) -(12)(34) -(134) -(234) +(1234) +(1342) +(143) -(1243) -(13) -(1423) +(123) +(13)(24) irow = 3 icol = 3 +I -(12) -(13) -(23) +(123) +(132) +(14) -(124) -(134) -(14)(23) +(1234) +(1324) I^-1 1 0 0 0 1 0 0 0 1 (12)^-1 1 -1 1 0 -1 0 0 0 -1 (13)^-1 -1 0 0 -1 1 -1 0 0 -1 (14)^-1 -1 0 0 0 -1 0 1 -1 1 (23)^-1 0 1 0 1 0 0 0 0 -1 (24)^-1 0 0 -1 0 -1 0 -1 0 0 (34)^-1 -1 0 0 0 0 1 0 1 0 (123)^-1 0 -1 0 1 -1 1 0 0 1 (132)^-1 -1 1 -1 -1 0 0 0 0 1 (124)^-1 0 0 1 0 1 0 -1 1 -1 (142)^-1 -1 1 -1 0 1 0 1 0 0 (134)^-1 1 0 0 0 0 -1 -1 1 -1 (143)^-1 1 0 0 1 -1 1 0 -1 0 (234)^-1 0 -1 0 0 0 -1 1 0 0 (243)^-1 0 0 1 -1 0 0 0 -1 0 (1234)^-1 0 1 0 0 0 1 1 -1 1 (1432)^-1 1 -1 1 1 0 0 0 1 0 (1243)^-1 0 0 -1 -1 1 -1 0 1 0 (1342)^-1 1 -1 1 0 0 1 -1 0 0 (1324)^-1 0 0 -1 1 0 0 1 -1 1 (1423)^-1 0 1 0 -1 1 -1 -1 0 0 (12)(34)^-1 -1 1 -1 0 0 -1 0 -1 0 (13)(24)^-1 0 0 1 1 -1 1 1 0 0 (14)(23)^-1 0 -1 0 -1 0 0 -1 1 -1 STY [1111] irow = 1 icol = 1 +I -(12) -(13) -(14) -(23) -(24) -(34) +(123) +(132) +(124) +(142) +(134) +(143) +(234) +(243) -(1234) -(1432) -(1243) -(1342) -(132 4) -(1423) +(12)(34) +(13)(24) +(14)(23) I^-1 1 (12)^-1 -1 (13)^-1 -1 (14)^-1 -1 (23)^-1 -1 (24)^-1 -1 (34)^-1 -1 (123)^-1 1 (132)^-1 1 (124)^-1 1 (142)^-1 1 (134)^-1 1 (143)^-1 1 (234)^-1 1 (243)^-1 1 (1234)^-1 -1 (1432)^-1 -1 (1243)^-1 -1 (1342)^-1 -1 (1324)^-1 -1 (1423)^-1 -1 (12)(34)^-1 1 (13)(24)^-1 1 (14)(23)^-1 1
ソース・プログラム
module m_sub implicit none type :: t_Sn integer :: itab(4) ! ! parameteric type character(len = :), allocatable :: label end type type(t_Sn), allocatable, protected :: sn(:) integer, allocatable, protected :: mul_tbl(:, :) type :: t_Sn_list integer, allocatable :: list(:) contains procedure :: prsn generic :: write(formatted) => prsn end type t_Sn_list type :: t_Sn_labels character(:), allocatable :: label(:) end type t_Sn_labels type(t_Sn_list), protected, allocatable :: sig4 (:, :) type(t_Sn_list), protected, allocatable :: sig31 (:, :) type(t_Sn_list), protected, allocatable :: sig22 (:, :) type(t_Sn_list), protected, allocatable :: sig211 (:, :) type(t_Sn_list), protected, allocatable :: sig1111(:, :) interface operator (*) module procedure :: mul, mul_list end interface interface operator (.t.) module procedure :: f_text_to_Sn_list end interface interface assignment (=) module procedure :: text_to_Sn_list, texts_to_Sn_lists_1D, texts_to_Sn_lists_2D end interface contains subroutine init_Sn() integer :: i, j, n type(t_Sn) :: s n = factorial(4) allocate( sn(n) ) sn( 1) = t_Sn([1, 2, 3, 4], 'I') sn( 2) = t_Sn([2, 1, 3, 4], '(12)') sn( 3) = t_Sn([3, 2, 1, 4], '(13)') sn( 4) = t_Sn([4, 2, 3, 1], '(14)') sn( 5) = t_Sn([1, 3, 2, 4], '(23)') sn( 6) = t_Sn([1, 4, 3, 2], '(24)') sn( 7) = t_Sn([1, 2, 4, 3], '(34)') sn( 8) = t_Sn([2, 3, 1, 4], '(123)') sn( 9) = t_Sn([3, 1, 2, 4], '(132)') sn(10) = t_Sn([2, 4, 3, 1], '(124)') sn(11) = t_Sn([4, 1, 3, 2], '(142)') sn(12) = t_Sn([3, 2, 4, 1], '(134)') sn(13) = t_Sn([4, 2, 1, 3], '(143)') sn(14) = t_Sn([1, 3, 4, 2], '(234)') sn(15) = t_Sn([1, 4, 2, 3], '(243)') sn(16) = t_Sn([2, 3, 4, 1], '(1234)') sn(17) = t_Sn([4, 1, 2, 3], '(1432)') sn(18) = t_Sn([2, 4, 1, 3], '(1243)') sn(19) = t_Sn([3, 1, 4, 2], '(1342)') sn(20) = t_Sn([3, 4, 2, 1], '(1324)') sn(21) = t_Sn([4, 3, 1, 2], '(1423)') sn(22) = t_Sn([2, 1, 4, 3], '(12)(34)') sn(23) = t_Sn([3, 4, 1, 2], '(13)(24)') sn(24) = t_Sn([4, 3, 2, 1], '(14)(23)') ! allocate( mul_tbl(n, n) ) do i = 1, n do j = 1, n s = sn(i) * sn(j) mul_tbl(i, j) = search(s) end do end do ! sig4 = reshape(['I'], [1, 1]) sig31 = reshape(['I', '(34)', '(234)', '(34)', 'I', '(23)', '(243)', '(23)', 'I'], [3, 3]) sig22 = reshape(['I', '(23)', '(23)', 'I'], [2, 2]) sig211 = reshape(['I', '(23)', '(243)', '(23)', 'I', '(34)', '(234)', '(34)', 'I'], [3, 3]) sig1111 = reshape(['I'], [1, 1]) return contains integer function factorial(n) integer :: i, n factorial = product([1:n])![(i, i = 1, n)]) ! non-standard return end function factorial end subroutine init_Sn pure elemental type(t_Sn) function mul(s1, s2) type(t_Sn), intent(in) :: s1, s2 mul%itab = s1%itab(s2%itab) mul%label = trim(s1%label) // trim(s2%label) return end function mul type(t_Sn_list) function mul_list(s1, s2) type(t_Sn_list), intent(in) :: s1, s2 integer :: i, j, k allocate( mul_list%list( size(s1%list) * size(s2%list) ) ) k = 0 do i = 1, size(s1%list) do j = 1, size(s2%list) k = k + 1 mul_list%list(k) = isign(1, s1%list(i) * s2%list(j)) * mul_tbl(abs(s1%list(i)), abs(s2%list(j))) end do end do return end function mul_list pure elemental integer function search(s) ! findloc type(t_Sn), intent(in) :: s do search = 1, size(sn) if (all(s%itab == sn(search)%itab)) exit end do return end function search pure elemental integer function search_label(label) character(len = *), intent(in) :: label if (label(1:1) == '+') then search_label = +search2(label(2:)) else if (label(1:1) == '-') then search_label = -search2(label(2:)) else search_label = search2(label) end if end function search_label pure elemental integer function search2(label) character(len = *), intent(in) :: label do search2 = 1, size(sn) if ( trim(sn(search2)%label) == adjustl(trim(label)) ) exit end do ! if (search2 == 7) print *, '***** Caution: label not found! *****' return end function search2 pure elemental function parse(text) result(res) character(len = *), intent(in) :: text type(t_Sn_labels) :: res character(len = 1), allocatable :: tmp(:) character(len = :), allocatable :: buf integer :: k, ip tmp = transfer(text, ' ', size = len(text)) tmp = pack(tmp, tmp /= ' ') buf = transfer(tmp, repeat(' ', size(tmp))) res%label = [character::] ip = 1 do k = scan(buf(ip + 1:), '+-') if (k == 0) exit res%label = [res%label, buf(ip:ip + k - 1)] ip = ip + k end do res%label = [res%label, buf(ip:)] return end function parse pure elemental subroutine text_to_Sn_list(snlst, text) type(t_Sn_list), intent(out) :: snlst character(len = *), intent(in) :: text type(t_Sn_labels) :: tmp tmp = parse(text) snlst%list = search_label(tmp%label) return end subroutine text_to_Sn_list pure subroutine texts_to_Sn_lists_1D(snlst, text) type(t_Sn_list), allocatable, intent(out) :: snlst(:) character(len = *), intent(in) :: text(:) type(t_Sn_labels) :: tmp integer :: i allocate(snlst(size(text))) do i = 1, size(text) tmp = parse(text(i)) snlst(i)%list = search_label(tmp%label) end do return end subroutine texts_to_Sn_lists_1D pure subroutine texts_to_Sn_lists_2D(snlst, text) type(t_Sn_list), allocatable, intent(out) :: snlst(:, :) character(len = *), intent(in) :: text(:, :) type(t_Sn_labels) :: tmp integer :: i, j allocate( snlst(size(text, 1), size(text, 1)) ) do i = 1, size(text, 1) do j = 1, size(text, 1) tmp = parse(text(i, j)) snlst(i, j)%list = search_label(tmp%label) end do end do return end subroutine texts_to_Sn_lists_2D pure elemental function f_text_to_Sn_list(text) result(snlst) type(t_Sn_list) :: snlst character(len = *), intent(in) :: text type(t_Sn_labels) :: tmp tmp = parse(text) snlst%list = search_label(tmp%label) return end function f_text_to_Sn_list subroutine prsn(ss, unit, iotype, vlist, iostat, iomsg) class(t_Sn_list) , intent(in) :: ss integer , intent(in) :: unit character (len = *), intent(in) :: iotype integer , intent(in) :: vlist(:) integer , intent(out) :: iostat character (len = *), intent(inout) :: iomsg integer :: i character(len = 2) :: sgn do i = 1, size(ss%list) write(sgn, '(sp, i2)') sign(1, ss%list(i)) write(unit, '(*(a1, a, 1x))', advance = 'no', iostat = iostat) sgn, trim(sn(abs(ss%list(i)))%label) end do write(*, *) return end subroutine prsn subroutine pr_mat(matrix) type(t_Sn_list), intent(in) :: matrix(:, :) integer :: k, m, irow, icol do k = 1, size(sn) print *, trim(sn(k)%label), '^-1' do irow = 1, size(matrix, 1) do icol = 1, size(matrix, 2) m = count( k == abs(matrix(irow, icol)%list) ) if ( m == count( k == matrix(irow, icol)%list) ) then write(*, '(ss, i3)', advance = 'no') +m else if ( m == count( k == -matrix(irow, icol)%list) ) then write(*, '(sp, i3)', advance = 'no') -m else write(*, '(ss, i3)', advance = 'no') 0 end if end do print * end do end do return end subroutine pr_mat subroutine mk_mat(name, p, sig, n) character(len = *), intent(in) :: name type(t_Sn_list), intent(in) :: p(:), sig(:, :), n(:) type(t_Sn_list), allocatable :: matrix(:, :) integer :: irow, icol, nn nn = size( p ) print '(/, 2a)', 'STY ', name allocate(matrix(nn, nn)) do irow = 1, size(sig, 1) do icol = 1, size(sig, 2) print *, 'irow =', irow, 'icol =', icol matrix(irow, icol) = p(irow) * sig(irow, icol) * n(icol) write(*, *) matrix(irow, icol) end do end do call pr_mat(matrix) deallocate(matrix) return end subroutine mk_mat end module m_sub program sna use m_sub implicit none type(t_Sn_list), allocatable :: p4(:), n4(:) type(t_Sn_list), allocatable :: p31(:), n31(:) type(t_Sn_list), allocatable :: p22(:), n22(:) type(t_Sn_list), allocatable :: p211(:), n211(:) type(t_Sn_list), allocatable :: p1111(:), n1111(:) call init_Sn() p4 = ['I +(12)+(13)+(14)+(23)+(24)+(34) +(123)+(132)+(124)+(142)+(134)+(143)+(234)+(243) & & +(1234)+(1432)+(1243)+(1342)+(1324)+(1423) +(12)(34)+(13)(24)+(14)(23)'] n4 = ['I'] p31 = ['I+(12)+(13)+(23)+(123)+(132)', 'I+(12)+(14)+(24)+(124)+(142)', 'I+(13)+(14)+(34)+(134)+(143)'] n31 = ['I - (14)', 'I - (13)', 'I - (12)'] p22 = ['I + (12) + (34) + (12)(34)', 'I + (13) + (24) + (13)(24)'] n22 = ['I - (13) - (24) + (13)(24)', 'I - (12) - (34) + (12)(34)'] p211 = ['I + (12)', 'I + (13)', 'I + (14)'] n211 = ['I-(13)-(14)-(34)+(134)+(143)', 'I-(12)-(14)-(24)+(124)+(142)', 'I-(12)-(13)-(23)+(123)+(132)'] p1111 = ['I'] n1111 = ['I -(12)-(13)-(14)-(23)-(24)-(34) +(123)+(132)+(124)+(142)+(134)+(143)+(234)+(243) & & -(1234)-(1432)-(1243)-(1342)-(1324)-(1423) +(12)(34)+(13)(24)+(14)(23)'] ! call mk_mat('[4]' , p4 , sig4 , n4 ) call mk_mat('[31]' , p31 , sig31 , n31 ) call mk_mat('[22]' , p22 , sig22 , n22 ) call mk_mat('[211]' , p211 , sig211 , n211 ) call mk_mat('[1111]', p1111, sig1111, n1111) ! stop end program sna
