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

fortran66のブログ

fortran について書きます。

4次対称群の行列表現

4次の場合

計算結果

行列が転置されていなかったので修正。

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