Merge branch 'labeled-systems' into development
This commit is contained in:
Sharan Roongta
commit
ccbcc0d010
232
src/lattice.f90
232
src/lattice.f90
|
|
@ -72,10 +72,6 @@ module lattice
|
||||||
0, 1,-1, 0, 1, 1 &
|
0, 1,-1, 0, 1, 1 &
|
||||||
],pReal),shape(LATTICE_FCC_SYSTEMSLIP)) !< Slip system <110>{111} directions. Sorted according to Eisenlohr & Hantcherli
|
],pReal),shape(LATTICE_FCC_SYSTEMSLIP)) !< Slip system <110>{111} directions. Sorted according to Eisenlohr & Hantcherli
|
||||||
|
|
||||||
character(len=*), dimension(2), parameter :: LATTICE_FCC_SLIPFAMILY_NAME = &
|
|
||||||
['<0 1 -1>{1 1 1}', &
|
|
||||||
'<0 1 -1>{0 1 1}']
|
|
||||||
|
|
||||||
real(pReal), dimension(3+3,LATTICE_FCC_NTWIN), parameter :: &
|
real(pReal), dimension(3+3,LATTICE_FCC_NTWIN), parameter :: &
|
||||||
LATTICE_FCC_SYSTEMTWIN = reshape(real( [&
|
LATTICE_FCC_SYSTEMTWIN = reshape(real( [&
|
||||||
-2, 1, 1, 1, 1, 1, &
|
-2, 1, 1, 1, 1, 1, &
|
||||||
|
|
@ -92,10 +88,6 @@ module lattice
|
||||||
-1, 1, 2, -1, 1,-1 &
|
-1, 1, 2, -1, 1,-1 &
|
||||||
],pReal),shape(LATTICE_FCC_SYSTEMTWIN)) !< Twin system <112>{111} directions. Sorted according to Eisenlohr & Hantcherli
|
],pReal),shape(LATTICE_FCC_SYSTEMTWIN)) !< Twin system <112>{111} directions. Sorted according to Eisenlohr & Hantcherli
|
||||||
|
|
||||||
character(len=*), dimension(1), parameter :: LATTICE_FCC_TWINFAMILY_NAME = &
|
|
||||||
['<-2 1 1>{1 1 1}']
|
|
||||||
|
|
||||||
|
|
||||||
integer, dimension(2,LATTICE_FCC_NTWIN), parameter, public :: &
|
integer, dimension(2,LATTICE_FCC_NTWIN), parameter, public :: &
|
||||||
LATTICE_FCC_TWINNUCLEATIONSLIPPAIR = reshape( [&
|
LATTICE_FCC_TWINNUCLEATIONSLIPPAIR = reshape( [&
|
||||||
2,3, &
|
2,3, &
|
||||||
|
|
@ -171,10 +163,6 @@ module lattice
|
||||||
1, 1, 1, 1, 1,-2 &
|
1, 1, 1, 1, 1,-2 &
|
||||||
],pReal),shape(LATTICE_BCC_SYSTEMSLIP))
|
],pReal),shape(LATTICE_BCC_SYSTEMSLIP))
|
||||||
|
|
||||||
character(len=*), dimension(2), parameter :: LATTICE_BCC_SLIPFAMILY_NAME = &
|
|
||||||
['<1 -1 1>{0 1 1}', &
|
|
||||||
'<1 -1 1>{2 1 1}']
|
|
||||||
|
|
||||||
real(pReal), dimension(3+3,LATTICE_BCC_NTWIN), parameter :: &
|
real(pReal), dimension(3+3,LATTICE_BCC_NTWIN), parameter :: &
|
||||||
LATTICE_BCC_SYSTEMTWIN = reshape(real([&
|
LATTICE_BCC_SYSTEMTWIN = reshape(real([&
|
||||||
! Twin system <111>{112}
|
! Twin system <111>{112}
|
||||||
|
|
@ -192,9 +180,6 @@ module lattice
|
||||||
1, 1, 1, 1, 1,-2 &
|
1, 1, 1, 1, 1,-2 &
|
||||||
],pReal),shape(LATTICE_BCC_SYSTEMTWIN))
|
],pReal),shape(LATTICE_BCC_SYSTEMTWIN))
|
||||||
|
|
||||||
character(len=*), dimension(1), parameter :: LATTICE_BCC_TWINFAMILY_NAME = &
|
|
||||||
['<1 1 1>{2 1 1}']
|
|
||||||
|
|
||||||
real(pReal), dimension(3+3,LATTICE_BCC_NCLEAVAGE), parameter :: &
|
real(pReal), dimension(3+3,LATTICE_BCC_NCLEAVAGE), parameter :: &
|
||||||
LATTICE_BCC_SYSTEMCLEAVAGE = reshape(real([&
|
LATTICE_BCC_SYSTEMCLEAVAGE = reshape(real([&
|
||||||
! Cleavage direction Plane normal
|
! Cleavage direction Plane normal
|
||||||
|
|
@ -269,14 +254,6 @@ module lattice
|
||||||
-2, 1, 1, 3, 2, -1, -1, 2 &
|
-2, 1, 1, 3, 2, -1, -1, 2 &
|
||||||
],pReal),shape(LATTICE_HEX_SYSTEMSLIP)) !< slip systems for hex, sorted by P. Eisenlohr CCW around <c> starting next to a_1 axis
|
],pReal),shape(LATTICE_HEX_SYSTEMSLIP)) !< slip systems for hex, sorted by P. Eisenlohr CCW around <c> starting next to a_1 axis
|
||||||
|
|
||||||
character(len=*), dimension(6), parameter :: LATTICE_HEX_SLIPFAMILY_NAME = &
|
|
||||||
['< 1 1 . 0>{ 0 0 . 1}', &
|
|
||||||
'< 1 1 . 0>{ 1 0 . 0}', &
|
|
||||||
'<-1 1 . 0>{ 1 1 . 0}', &
|
|
||||||
'< 1 1 . 0>{ 1 -1 . 1}', &
|
|
||||||
'< 1 1 . 3>{-1 0 . 1}', &
|
|
||||||
'< 1 1 . 3>{-1 -1 . 2}']
|
|
||||||
|
|
||||||
real(pReal), dimension(4+4,LATTICE_HEX_NTWIN), parameter :: &
|
real(pReal), dimension(4+4,LATTICE_HEX_NTWIN), parameter :: &
|
||||||
LATTICE_HEX_SYSTEMTWIN = reshape(real([&
|
LATTICE_HEX_SYSTEMTWIN = reshape(real([&
|
||||||
! Compression or Tension = f(twinning shear=f(c/a)) for each metal ! (according to Yoo 1981)
|
! Compression or Tension = f(twinning shear=f(c/a)) for each metal ! (according to Yoo 1981)
|
||||||
|
|
@ -309,12 +286,6 @@ module lattice
|
||||||
2, -1, -1, -3, 2, -1, -1, 2 &
|
2, -1, -1, -3, 2, -1, -1, 2 &
|
||||||
],pReal),shape(LATTICE_HEX_SYSTEMTWIN)) !< twin systems for hex, sorted by P. Eisenlohr CCW around <c> starting next to a_1 axis
|
],pReal),shape(LATTICE_HEX_SYSTEMTWIN)) !< twin systems for hex, sorted by P. Eisenlohr CCW around <c> starting next to a_1 axis
|
||||||
|
|
||||||
character(len=*), dimension(4), parameter :: LATTICE_HEX_TWINFAMILY_NAME = &
|
|
||||||
['<-1 0 . 1>{ 1 0 . 2}', &
|
|
||||||
'< 1 1 . 6>{-1 -1 . 1}', &
|
|
||||||
'< 1 0 . -2>{ 1 0 . 1}', &
|
|
||||||
'< 1 1 . -3>{ 1 1 . 2}']
|
|
||||||
|
|
||||||
real(pReal), dimension(4+4,LATTICE_HEX_NCLEAVAGE), parameter :: &
|
real(pReal), dimension(4+4,LATTICE_HEX_NCLEAVAGE), parameter :: &
|
||||||
LATTICE_HEX_SYSTEMCLEAVAGE = reshape(real([&
|
LATTICE_HEX_SYSTEMCLEAVAGE = reshape(real([&
|
||||||
! Cleavage direction Plane normal
|
! Cleavage direction Plane normal
|
||||||
|
|
@ -402,22 +373,6 @@ module lattice
|
||||||
1, 1, 1, 1,-2, 1 &
|
1, 1, 1, 1,-2, 1 &
|
||||||
],pReal),[ 3 + 3,LATTICE_BCT_NSLIP]) !< slip systems for bct sorted by Bieler
|
],pReal),[ 3 + 3,LATTICE_BCT_NSLIP]) !< slip systems for bct sorted by Bieler
|
||||||
|
|
||||||
character(len=*), dimension(13), parameter :: LATTICE_BCT_SLIPFAMILY_NAME = &
|
|
||||||
['{1 0 0)<0 0 1] ', &
|
|
||||||
'{1 1 0)<0 0 1] ', &
|
|
||||||
'{1 0 0)<0 1 0] ', &
|
|
||||||
'{1 1 0)<1 -1 1]', &
|
|
||||||
'{1 1 0)<1 -1 0]', &
|
|
||||||
'{1 0 0)<0 1 1] ', &
|
|
||||||
'{0 0 1)<0 1 0] ', &
|
|
||||||
'{0 0 1)<1 1 0] ', &
|
|
||||||
'{0 1 1)<0 1 -1]', &
|
|
||||||
'{0 1 1)<1 -1 1]', &
|
|
||||||
'{0 1 1)<1 0 0] ', &
|
|
||||||
'{2 1 1)<0 1 -1]', &
|
|
||||||
'{2 1 1)<-1 1 1]']
|
|
||||||
|
|
||||||
|
|
||||||
!--------------------------------------------------------------------------------------------------
|
!--------------------------------------------------------------------------------------------------
|
||||||
! isotropic
|
! isotropic
|
||||||
integer, dimension(1), parameter :: &
|
integer, dimension(1), parameter :: &
|
||||||
|
|
@ -527,7 +482,8 @@ module lattice
|
||||||
lattice_forestProjection_screw, &
|
lattice_forestProjection_screw, &
|
||||||
lattice_slip_normal, &
|
lattice_slip_normal, &
|
||||||
lattice_slip_direction, &
|
lattice_slip_direction, &
|
||||||
lattice_slip_transverse
|
lattice_slip_transverse, &
|
||||||
|
lattice_labels_slip
|
||||||
|
|
||||||
contains
|
contains
|
||||||
!--------------------------------------------------------------------------------------------------
|
!--------------------------------------------------------------------------------------------------
|
||||||
|
|
@ -841,9 +797,9 @@ function lattice_characteristicShear_Twin(Ntwin,structure,CoverA) result(charact
|
||||||
|
|
||||||
integer :: &
|
integer :: &
|
||||||
a, & !< index of active system
|
a, & !< index of active system
|
||||||
c, & !< index in complete system list
|
p, & !< index in potential system list
|
||||||
mf, & !< index of my family
|
f, & !< index of my family
|
||||||
ms !< index of my system in current family
|
s !< index of my system in current family
|
||||||
|
|
||||||
integer, dimension(LATTICE_HEX_NTWIN), parameter :: &
|
integer, dimension(LATTICE_HEX_NTWIN), parameter :: &
|
||||||
HEX_SHEARTWIN = reshape( [&
|
HEX_SHEARTWIN = reshape( [&
|
||||||
|
|
@ -877,8 +833,8 @@ function lattice_characteristicShear_Twin(Ntwin,structure,CoverA) result(charact
|
||||||
call IO_error(137,ext_msg='lattice_characteristicShear_Twin: '//trim(structure))
|
call IO_error(137,ext_msg='lattice_characteristicShear_Twin: '//trim(structure))
|
||||||
|
|
||||||
a = 0
|
a = 0
|
||||||
myFamilies: do mf = 1,size(Ntwin,1)
|
myFamilies: do f = 1,size(Ntwin,1)
|
||||||
mySystems: do ms = 1,Ntwin(mf)
|
mySystems: do s = 1,Ntwin(f)
|
||||||
a = a + 1
|
a = a + 1
|
||||||
select case(structure(1:3))
|
select case(structure(1:3))
|
||||||
case('fcc','bcc')
|
case('fcc','bcc')
|
||||||
|
|
@ -886,8 +842,8 @@ function lattice_characteristicShear_Twin(Ntwin,structure,CoverA) result(charact
|
||||||
case('hex')
|
case('hex')
|
||||||
if (cOverA < 1.0_pReal .or. cOverA > 2.0_pReal) &
|
if (cOverA < 1.0_pReal .or. cOverA > 2.0_pReal) &
|
||||||
call IO_error(131,ext_msg='lattice_characteristicShear_Twin')
|
call IO_error(131,ext_msg='lattice_characteristicShear_Twin')
|
||||||
c = sum(LATTICE_HEX_NTWINSYSTEM(1:mf-1))+ms
|
p = sum(LATTICE_HEX_NTWINSYSTEM(1:f-1))+s
|
||||||
select case(HEX_SHEARTWIN(c)) ! from Christian & Mahajan 1995 p.29
|
select case(HEX_SHEARTWIN(p)) ! from Christian & Mahajan 1995 p.29
|
||||||
case (1) ! <-10.1>{10.2}
|
case (1) ! <-10.1>{10.2}
|
||||||
characteristicShear(a) = (3.0_pReal-cOverA**2.0_pReal)/sqrt(3.0_pReal)/CoverA
|
characteristicShear(a) = (3.0_pReal-cOverA**2.0_pReal)/sqrt(3.0_pReal)/CoverA
|
||||||
case (2) ! <11.6>{-1-1.1}
|
case (2) ! <11.6>{-1-1.1}
|
||||||
|
|
@ -1960,6 +1916,91 @@ function slipProjection_transverse(Nslip,structure,cOverA) result(projection)
|
||||||
end function slipProjection_transverse
|
end function slipProjection_transverse
|
||||||
|
|
||||||
|
|
||||||
|
!--------------------------------------------------------------------------------------------------
|
||||||
|
!> @brief Labels for slip systems
|
||||||
|
!> details only active slip systems are considered
|
||||||
|
!--------------------------------------------------------------------------------------------------
|
||||||
|
function lattice_labels_slip(Nslip,structure) result(labels)
|
||||||
|
|
||||||
|
integer, dimension(:), intent(in) :: Nslip !< number of active slip systems per family
|
||||||
|
character(len=*), intent(in) :: structure !< lattice structure
|
||||||
|
|
||||||
|
character(len=:), dimension(:), allocatable :: labels
|
||||||
|
|
||||||
|
real(pReal), dimension(:,:), allocatable :: slipSystems
|
||||||
|
integer, dimension(:), allocatable :: NslipMax
|
||||||
|
|
||||||
|
if (len_trim(structure) /= 3) &
|
||||||
|
call IO_error(137,ext_msg='lattice_labels_slip: '//trim(structure))
|
||||||
|
|
||||||
|
select case(structure(1:3))
|
||||||
|
case('fcc')
|
||||||
|
NslipMax = LATTICE_FCC_NSLIPSYSTEM
|
||||||
|
slipSystems = LATTICE_FCC_SYSTEMSLIP
|
||||||
|
case('bcc')
|
||||||
|
NslipMax = LATTICE_BCC_NSLIPSYSTEM
|
||||||
|
slipSystems = LATTICE_BCC_SYSTEMSLIP
|
||||||
|
case('hex')
|
||||||
|
NslipMax = LATTICE_HEX_NSLIPSYSTEM
|
||||||
|
slipSystems = LATTICE_HEX_SYSTEMSLIP
|
||||||
|
case('bct')
|
||||||
|
NslipMax = LATTICE_BCT_NSLIPSYSTEM
|
||||||
|
slipSystems = LATTICE_BCT_SYSTEMSLIP
|
||||||
|
case default
|
||||||
|
call IO_error(137,ext_msg='lattice_labels_slip: '//trim(structure))
|
||||||
|
end select
|
||||||
|
|
||||||
|
if (any(NslipMax(1:size(Nslip)) - Nslip < 0)) &
|
||||||
|
call IO_error(145,ext_msg='Nslip '//trim(structure))
|
||||||
|
if (any(Nslip < 0)) &
|
||||||
|
call IO_error(144,ext_msg='Nslip '//trim(structure))
|
||||||
|
|
||||||
|
labels = getLabels(Nslip,NslipMax,slipSystems,structure)
|
||||||
|
|
||||||
|
end function lattice_labels_slip
|
||||||
|
|
||||||
|
|
||||||
|
!--------------------------------------------------------------------------------------------------
|
||||||
|
!> @brief Labels for twin systems
|
||||||
|
!> details only active twin systems are considered
|
||||||
|
!--------------------------------------------------------------------------------------------------
|
||||||
|
function lattice_labels_twin(Ntwin,structure) result(labels)
|
||||||
|
|
||||||
|
integer, dimension(:), intent(in) :: Ntwin !< number of active slip systems per family
|
||||||
|
character(len=*), intent(in) :: structure !< lattice structure
|
||||||
|
|
||||||
|
character(len=:), dimension(:), allocatable :: labels
|
||||||
|
|
||||||
|
real(pReal), dimension(:,:), allocatable :: twinSystems
|
||||||
|
integer, dimension(:), allocatable :: NtwinMax
|
||||||
|
|
||||||
|
if (len_trim(structure) /= 3) &
|
||||||
|
call IO_error(137,ext_msg='lattice_labels_twin: '//trim(structure))
|
||||||
|
|
||||||
|
select case(structure(1:3))
|
||||||
|
case('fcc')
|
||||||
|
NtwinMax = LATTICE_FCC_NTWINSYSTEM
|
||||||
|
twinSystems = LATTICE_FCC_SYSTEMTWIN
|
||||||
|
case('bcc')
|
||||||
|
NtwinMax = LATTICE_BCC_NTWINSYSTEM
|
||||||
|
twinSystems = LATTICE_BCC_SYSTEMTWIN
|
||||||
|
case('hex')
|
||||||
|
NtwinMax = LATTICE_HEX_NTWINSYSTEM
|
||||||
|
twinSystems = LATTICE_HEX_SYSTEMTWIN
|
||||||
|
case default
|
||||||
|
call IO_error(137,ext_msg='lattice_labels_twin: '//trim(structure))
|
||||||
|
end select
|
||||||
|
|
||||||
|
if (any(NtwinMax(1:size(Ntwin)) - Ntwin < 0)) &
|
||||||
|
call IO_error(145,ext_msg='Ntwin '//trim(structure))
|
||||||
|
if (any(Ntwin < 0)) &
|
||||||
|
call IO_error(144,ext_msg='Ntwin '//trim(structure))
|
||||||
|
|
||||||
|
labels = getLabels(Ntwin,NtwinMax,twinSystems,structure)
|
||||||
|
|
||||||
|
end function lattice_labels_twin
|
||||||
|
|
||||||
|
|
||||||
!--------------------------------------------------------------------------------------------------
|
!--------------------------------------------------------------------------------------------------
|
||||||
!> @brief Projection of the slip direction onto the slip plane
|
!> @brief Projection of the slip direction onto the slip plane
|
||||||
!> @details: This projection is used to calculate forest hardening for screw dislocations
|
!> @details: This projection is used to calculate forest hardening for screw dislocations
|
||||||
|
|
@ -2075,11 +2116,11 @@ end function buildInteraction
|
||||||
!> @brief build a local coordinate system on slip, twin, trans, cleavage systems
|
!> @brief build a local coordinate system on slip, twin, trans, cleavage systems
|
||||||
!> @details Order: Direction, plane (normal), and common perpendicular
|
!> @details Order: Direction, plane (normal), and common perpendicular
|
||||||
!--------------------------------------------------------------------------------------------------
|
!--------------------------------------------------------------------------------------------------
|
||||||
function buildCoordinateSystem(active,complete,system,structure,cOverA)
|
function buildCoordinateSystem(active,potential,system,structure,cOverA)
|
||||||
|
|
||||||
integer, dimension(:), intent(in) :: &
|
integer, dimension(:), intent(in) :: &
|
||||||
active, &
|
active, &
|
||||||
complete
|
potential
|
||||||
real(pReal), dimension(:,:), intent(in) :: &
|
real(pReal), dimension(:,:), intent(in) :: &
|
||||||
system
|
system
|
||||||
character(len=*), intent(in) :: &
|
character(len=*), intent(in) :: &
|
||||||
|
|
@ -2093,7 +2134,7 @@ function buildCoordinateSystem(active,complete,system,structure,cOverA)
|
||||||
direction, normal
|
direction, normal
|
||||||
integer :: &
|
integer :: &
|
||||||
a, & !< index of active system
|
a, & !< index of active system
|
||||||
c, & !< index in complete system matrix
|
p, & !< index in potential system matrix
|
||||||
f, & !< index of my family
|
f, & !< index of my family
|
||||||
s !< index of my system in current family
|
s !< index of my system in current family
|
||||||
|
|
||||||
|
|
@ -2108,21 +2149,21 @@ function buildCoordinateSystem(active,complete,system,structure,cOverA)
|
||||||
activeFamilies: do f = 1,size(active,1)
|
activeFamilies: do f = 1,size(active,1)
|
||||||
activeSystems: do s = 1,active(f)
|
activeSystems: do s = 1,active(f)
|
||||||
a = a + 1
|
a = a + 1
|
||||||
c = sum(complete(1:f-1))+s
|
p = sum(potential(1:f-1))+s
|
||||||
|
|
||||||
select case(trim(structure(1:3)))
|
select case(trim(structure(1:3)))
|
||||||
|
|
||||||
case ('fcc','bcc','iso','ort','bct')
|
case ('fcc','bcc','iso','ort','bct')
|
||||||
direction = system(1:3,c)
|
direction = system(1:3,p)
|
||||||
normal = system(4:6,c)
|
normal = system(4:6,p)
|
||||||
|
|
||||||
case ('hex')
|
case ('hex')
|
||||||
direction = [ system(1,c)*1.5_pReal, &
|
direction = [ system(1,p)*1.5_pReal, &
|
||||||
(system(1,c)+2.0_pReal*system(2,c))*sqrt(0.75_pReal), &
|
(system(1,p)+2.0_pReal*system(2,p))*sqrt(0.75_pReal), &
|
||||||
system(4,c)*cOverA ] ! direction [uvtw]->[3u/2 (u+2v)*sqrt(3)/2 w*(c/a)])
|
system(4,p)*cOverA ] ! direction [uvtw]->[3u/2 (u+2v)*sqrt(3)/2 w*(p/a)])
|
||||||
normal = [ system(5,c), &
|
normal = [ system(5,p), &
|
||||||
(system(5,c)+2.0_pReal*system(6,c))/sqrt(3.0_pReal), &
|
(system(5,p)+2.0_pReal*system(6,p))/sqrt(3.0_pReal), &
|
||||||
system(8,c)/cOverA ] ! plane (hkil)->(h (h+2k)/sqrt(3) l/(c/a))
|
system(8,p)/cOverA ] ! plane (hkil)->(h (h+2k)/sqrt(3) l/(p/a))
|
||||||
|
|
||||||
case default
|
case default
|
||||||
call IO_error(137,ext_msg='buildCoordinateSystem: '//trim(structure))
|
call IO_error(137,ext_msg='buildCoordinateSystem: '//trim(structure))
|
||||||
|
|
@ -2131,8 +2172,8 @@ function buildCoordinateSystem(active,complete,system,structure,cOverA)
|
||||||
|
|
||||||
buildCoordinateSystem(1:3,1,a) = direction/norm2(direction)
|
buildCoordinateSystem(1:3,1,a) = direction/norm2(direction)
|
||||||
buildCoordinateSystem(1:3,2,a) = normal /norm2(normal)
|
buildCoordinateSystem(1:3,2,a) = normal /norm2(normal)
|
||||||
buildCoordinateSystem(1:3,3,a) = math_cross(buildCoordinateSystem(1:3,1,a),&
|
buildCoordinateSystem(1:3,3,a) = math_cross(direction/norm2(direction),&
|
||||||
buildCoordinateSystem(1:3,2,a))
|
normal /norm2(normal))
|
||||||
|
|
||||||
enddo activeSystems
|
enddo activeSystems
|
||||||
enddo activeFamilies
|
enddo activeFamilies
|
||||||
|
|
@ -2266,4 +2307,61 @@ subroutine buildTransformationSystem(Q,S,Ntrans,cOverA,a_fcc,a_bcc)
|
||||||
|
|
||||||
end subroutine buildTransformationSystem
|
end subroutine buildTransformationSystem
|
||||||
|
|
||||||
|
|
||||||
|
!--------------------------------------------------------------------------------------------------
|
||||||
|
!> @brief select active systems as strings
|
||||||
|
!--------------------------------------------------------------------------------------------------
|
||||||
|
function getlabels(active,potential,system,structure) result(labels)
|
||||||
|
|
||||||
|
integer, dimension(:), intent(in) :: &
|
||||||
|
active, &
|
||||||
|
potential
|
||||||
|
real(pReal), dimension(:,:), intent(in) :: &
|
||||||
|
system
|
||||||
|
character(len=*), intent(in) :: structure !< lattice structure
|
||||||
|
|
||||||
|
character(len=:), dimension(:), allocatable :: labels
|
||||||
|
character(len=:), allocatable :: label
|
||||||
|
|
||||||
|
integer :: i,j
|
||||||
|
integer :: &
|
||||||
|
a, & !< index of active system
|
||||||
|
p, & !< index in potential system matrix
|
||||||
|
f, & !< index of my family
|
||||||
|
s !< index of my system in current family
|
||||||
|
|
||||||
|
i = 2*size(system,1) + (size(system,1) - 2) + 4 ! 2 letters per index + spaces + brackets
|
||||||
|
allocate(character(len=i) :: labels(sum(active)), label)
|
||||||
|
|
||||||
|
a = 0
|
||||||
|
activeFamilies: do f = 1,size(active,1)
|
||||||
|
activeSystems: do s = 1,active(f)
|
||||||
|
a = a + 1
|
||||||
|
p = sum(potential(1:f-1))+s
|
||||||
|
|
||||||
|
i = 1
|
||||||
|
label(i:i) = merge('[','<',structure(1:3) /= 'bct')
|
||||||
|
direction: do j = 1, size(system,1)/2
|
||||||
|
write(label(i+1:i+2),"(I2.1)") int(system(j,p))
|
||||||
|
label(i+3:i+3) = ' '
|
||||||
|
i = i + 3
|
||||||
|
enddo direction
|
||||||
|
label(i:i) = ']'
|
||||||
|
i = i +1
|
||||||
|
label(i:i) = merge('(','{',structure(1:3) /= 'bct')
|
||||||
|
normal: do j = size(system,1)/2+1, size(system,1)
|
||||||
|
write(label(i+1:i+2),"(I2.1)") int(system(j,p))
|
||||||
|
label(i+3:i+3) = ' '
|
||||||
|
i = i + 3
|
||||||
|
enddo normal
|
||||||
|
label(i:i) = ')'
|
||||||
|
|
||||||
|
labels(s) = label
|
||||||
|
|
||||||
|
enddo activeSystems
|
||||||
|
enddo activeFamilies
|
||||||
|
|
||||||
|
end function getlabels
|
||||||
|
|
||||||
|
|
||||||
end module lattice
|
end module lattice
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue