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

fortran66のブログ

fortran について書きます。

3次対称群の行列表現

3次対称群の行列表現をヤング対称子を用いて計算します。

D.E.Littlewood の The Theory of Group Characters and Matrix Representations of Groups の Chap.5 に依って求めます。この本は記号の定義などが現代のものと逆さになっていたり色々トラップが多いのですが、できるだけ今風の定義を用いることにします。

ヤング対称子による対称群の行列表現は4次くらいまでならば手計算で求められますが、対称操作の数が階乗で増えてゆくので、5次から先は手計算でやる気になれません。一方で5次の場合から、ヤング対称子で作った基底が直交しなくなる場合が出るので、特別な直交化操作が必要になります。それは Littlewood の本に書いてありますが、実際の計算で確認するに計算機の力を借りることになります。

一応3,4,5次までプログラムを作って、力づくで行列表現を求めてみました。

3次対称群S_3に対して、プログラムを整理し直して、演算子 overload や構造体の user defined I/O ルーチンを用いてすっきりさせたのでのせておきます。

実行結果

ヤング図で表される各既約表現(基底は標準ヤング盤に対応するヤング対称子で求められる)とそれに対応する演算子、そして各対称操作に対応する行列表現を列挙しています。

STY [3]
+I +(12) +(13) +(23) +(123) +(132)
 I^-1
  1
 (12)^-1
  1
 (13)^-1
  1
 (23)^-1
  1
 (123)^-1
  1
 (132)^-1
  1

STY [21]
 irow = 1
+I -(13) +(12) -(132)
+(23) -(132) +(123) -(13)
 irow = 2
+(23) -(123) +(132) -(12)
+I -(12) +(13) -(123)
 I^-1
  1  0
  0  1
 (12)^-1
  1 -1
  0 -1
 (13)^-1
 -1  0
 -1  1
 (23)^-1
  0  1
  1  0
 (123)^-1
  0 -1
  1 -1
 (132)^-1
 -1  1
 -1  0

STY [1^3]
+I -(12) -(13) -(23) +(123) +(132)
 I^-1
  1
 (12)^-1
 -1
 (13)^-1
 -1
 (23)^-1
 -1
 (123)^-1
  1
 (132)^-1
  1

ソース・プログラム

Fortran2003 セマンティクス を有効にする必要があります。

f:id:fortran66:20131212021245g:plain

    module m_sub
      implicit none
      type :: t_Sn 
        integer :: itab(3) ! ! 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 :: sig3(:, :)   
      type(t_Sn_list), protected, allocatable :: sig21(:, :)
      type(t_Sn_list), protected, allocatable :: sig111(:, :) 

      interface operator (*)
        module procedure :: mul, mul_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(3)
        allocate( sn(n) )
        sn(1) = t_Sn([1, 2, 3], 'I')
        sn(2) = t_Sn([2, 1, 3], '(12)')
        sn(3) = t_Sn([3, 2, 1], '(13)')
        sn(4) = t_Sn([1, 3, 2], '(23)')
        sn(5) = t_Sn([2, 3, 1], '(123)')
        sn(6) = t_Sn([3, 1, 2], '(132)')
!
        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  
        !
        sig3   = reshape(['I'], [1, 1])
        sig21  = reshape(['I', '(23)', '(23)', 'I'], [2, 2])
        sig111 = 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
        
      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)') 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 icol = 1, size(matrix, 2)
            do irow = 1, size(matrix, 1)
              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  
    
    end module m_sub
  
    program sna
      use m_sub 
      implicit none
      type(t_Sn_list), allocatable :: p3(:), n3(:)
      type(t_Sn_list), allocatable :: p21(:), n21(:)
      type(t_Sn_list), allocatable :: p111(:), n111(:)
      integer :: irow, icol 
      
      type(t_Sn_list), allocatable :: matrix(:, :) 
      
      call init_Sn()
      p3   = ['I + (12) + (13) + (23) + (123) + (132)'] ! [1, 2, 3, 4, 5, 6]
      n3   = ['I']                                      ! [1]
      p21  = ['I + (12)', 'I + (13)']                   ! [[1,  2], [1,  3]]
      n21  = ['I - (13)', 'I - (12)']                   ! [[1, -3], [1, -2]]
      p111 = ['I']                                      ! [1]
      n111 = ['I - (12) - (13) - (23) + (123) + (132)'] ! [1, -2, -3, -4, 5, 6] 
      
      print '(/, a)', 'STY [3]'
      allocate(matrix(1, 1))
      matrix = p3(1) * sig3(1, 1) * n3(1)
      write(*, *) matrix(1, 1)
      call pr_mat(matrix)
      deallocate(matrix)
      !      
      print '(/, a)', 'STY [21]'
      allocate(matrix(2, 2))
      do irow = 1, size(sig21, 1)
        print *, 'irow =', irow  
        do icol = 1, size(sig21, 2)
          matrix(irow, icol) = p21(irow) * sig21(irow, icol) * n21(icol)
          write(*, *) matrix(irow, icol)       
        end do
      end do  
      call pr_mat(matrix)
      deallocate(matrix)
      !
      print '(/, a)', 'STY [1^3]'
      allocate(matrix(1, 1))
      matrix(1, 1) = p111(1) * sig111(1, 1) * n111(1)
      write(*, *) matrix(1, 1)
      call pr_mat(matrix)
      deallocate(matrix)
      !
      stop
    end program sna