From 34db73b06856853d0c976f19047e7ce7bcc2c3ce Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 22 Nov 2023 20:22:05 +0100 Subject: [PATCH 1/4] more logical order --- src/crystal.f90 | 30 +++++++++++++++--------------- 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/src/crystal.f90 b/src/crystal.f90 index 8e820b515..8f0b0bfb7 100644 --- a/src/crystal.f90 +++ b/src/crystal.f90 @@ -444,16 +444,16 @@ function crystal_characteristicShear_Twin(Ntwin,lattice,CoverA) result(character ] !< indicator to formulas below - a = 0 - myFamilies: do f = 1,size(Ntwin,1) - mySystems: do s = 1,Ntwin(f) - a = a + 1 - select case(lattice) - case('cF','cI') - characteristicShear(a) = 0.5_pREAL*sqrt(2.0_pREAL) - case('hP') - if (cOverA < 1.0_pREAL .or. cOverA > 2.0_pREAL) & - call IO_error(131,ext_msg='crystal_characteristicShear_Twin') + select case(lattice) + case('cF','cI') + characteristicShear = 0.5_pREAL*sqrt(2.0_pREAL) + case('hP') + if (cOverA < 1.0_pREAL .or. cOverA > 2.0_pREAL) & + call IO_error(131,ext_msg='crystal_characteristicShear_Twin') + a = 0 + myFamilies: do f = 1,size(Ntwin,1) + mySystems: do s = 1,Ntwin(f) + a = a + 1 select case(HP_SHEARTWIN(f)) ! from Christian & Mahajan 1995 p.29 case (1) ! <-10.1>{10.2} characteristicShear(a) = (3.0_pREAL-cOverA**2)/sqrt(3.0_pREAL)/CoverA @@ -464,11 +464,11 @@ function crystal_characteristicShear_Twin(Ntwin,lattice,CoverA) result(character case (4) ! <11.-3>{11.2} characteristicShear(a) = 2.0_pREAL*(cOverA**2-2.0_pREAL)/3.0_pREAL/cOverA end select - case default - call IO_error(137,ext_msg='crystal_characteristicShear_Twin: '//trim(lattice)) - end select - end do mySystems - end do myFamilies + end do mySystems + end do myFamilies + case default + call IO_error(137,ext_msg='crystal_characteristicShear_Twin: '//trim(lattice)) + end select end function crystal_characteristicShear_Twin From eaf65e56658a15c7ebcd5b707c6d722117a885e1 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 22 Nov 2023 20:31:35 +0100 Subject: [PATCH 2/4] loop not needed --- src/crystal.f90 | 30 ++++++++++++++---------------- 1 file changed, 14 insertions(+), 16 deletions(-) diff --git a/src/crystal.f90 b/src/crystal.f90 index 8f0b0bfb7..6690955bf 100644 --- a/src/crystal.f90 +++ b/src/crystal.f90 @@ -431,9 +431,8 @@ function crystal_characteristicShear_Twin(Ntwin,lattice,CoverA) result(character real(pREAL), dimension(sum(Ntwin)) :: characteristicShear integer :: & - a, & !< index of active system f, & !< index of my family - s !< index of my system in current family + s, e integer, dimension(size(HP_NTWINSYSTEM)), parameter :: & HP_SHEARTWIN = [& @@ -450,21 +449,20 @@ function crystal_characteristicShear_Twin(Ntwin,lattice,CoverA) result(character case('hP') if (cOverA < 1.0_pREAL .or. cOverA > 2.0_pREAL) & call IO_error(131,ext_msg='crystal_characteristicShear_Twin') - a = 0 + myFamilies: do f = 1,size(Ntwin,1) - mySystems: do s = 1,Ntwin(f) - a = a + 1 - select case(HP_SHEARTWIN(f)) ! from Christian & Mahajan 1995 p.29 - case (1) ! <-10.1>{10.2} - characteristicShear(a) = (3.0_pREAL-cOverA**2)/sqrt(3.0_pREAL)/CoverA - case (2) ! <11.6>{-1-1.1} - characteristicShear(a) = 1.0_pREAL/cOverA - case (3) ! <10.-2>{10.1} - characteristicShear(a) = (4.0_pREAL*cOverA**2-9.0_pREAL)/sqrt(48.0_pREAL)/cOverA - case (4) ! <11.-3>{11.2} - characteristicShear(a) = 2.0_pREAL*(cOverA**2-2.0_pREAL)/3.0_pREAL/cOverA - end select - end do mySystems + s = sum(Ntwin(:f-1)) + 1 + e = sum(Ntwin(:f)) + select case(HP_SHEARTWIN(f)) ! from Christian & Mahajan 1995 p.29 + case (1) ! <-10.1>{10.2} + characteristicShear(s:e) = (3.0_pREAL-cOverA**2)/sqrt(3.0_pREAL)/CoverA + case (2) ! <11.6>{-1-1.1} + characteristicShear(s:e) = 1.0_pREAL/cOverA + case (3) ! <10.-2>{10.1} + characteristicShear(s:e) = (4.0_pREAL*cOverA**2-9.0_pREAL)/sqrt(48.0_pREAL)/cOverA + case (4) ! <11.-3>{11.2} + characteristicShear(s:e) = 2.0_pREAL*(cOverA**2-2.0_pREAL)/3.0_pREAL/cOverA + end select end do myFamilies case default call IO_error(137,ext_msg='crystal_characteristicShear_Twin: '//trim(lattice)) From f9c34e799eb4cbb79114c3699c9dd813141cf969 Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Wed, 22 Nov 2023 20:32:28 +0100 Subject: [PATCH 3/4] indicator not needed --- src/crystal.f90 | 18 +++++------------- 1 file changed, 5 insertions(+), 13 deletions(-) diff --git a/src/crystal.f90 b/src/crystal.f90 index 6690955bf..5aecb45e5 100644 --- a/src/crystal.f90 +++ b/src/crystal.f90 @@ -434,14 +434,6 @@ function crystal_characteristicShear_Twin(Ntwin,lattice,CoverA) result(character f, & !< index of my family s, e - integer, dimension(size(HP_NTWINSYSTEM)), parameter :: & - HP_SHEARTWIN = [& - 1, & ! <-10.1>{10.2} - 2, & ! <11.6>{-1-1.1} - 3, & ! <10.-2>{10.1} - 4 & ! <11.-3>{11.2} - ] !< indicator to formulas below - select case(lattice) case('cF','cI') @@ -453,14 +445,14 @@ function crystal_characteristicShear_Twin(Ntwin,lattice,CoverA) result(character myFamilies: do f = 1,size(Ntwin,1) s = sum(Ntwin(:f-1)) + 1 e = sum(Ntwin(:f)) - select case(HP_SHEARTWIN(f)) ! from Christian & Mahajan 1995 p.29 - case (1) ! <-10.1>{10.2} + select case(f) ! from Christian & Mahajan 1995 p.29 + case (1) ! <-10.1>{10.2} characteristicShear(s:e) = (3.0_pREAL-cOverA**2)/sqrt(3.0_pREAL)/CoverA - case (2) ! <11.6>{-1-1.1} + case (2) ! <11.6>{-1-1.1} characteristicShear(s:e) = 1.0_pREAL/cOverA - case (3) ! <10.-2>{10.1} + case (3) ! <10.-2>{10.1} characteristicShear(s:e) = (4.0_pREAL*cOverA**2-9.0_pREAL)/sqrt(48.0_pREAL)/cOverA - case (4) ! <11.-3>{11.2} + case (4) ! <11.-3>{11.2} characteristicShear(s:e) = 2.0_pREAL*(cOverA**2-2.0_pREAL)/3.0_pREAL/cOverA end select end do myFamilies From b9e41732d4cc60c553be077a7f36adfd70cd02eb Mon Sep 17 00:00:00 2001 From: Martin Diehl Date: Thu, 23 Nov 2023 11:29:18 +0100 Subject: [PATCH 4/4] documented --- src/crystal.f90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/crystal.f90 b/src/crystal.f90 index 5aecb45e5..f0dc1afcb 100644 --- a/src/crystal.f90 +++ b/src/crystal.f90 @@ -436,16 +436,16 @@ function crystal_characteristicShear_Twin(Ntwin,lattice,CoverA) result(character select case(lattice) - case('cF','cI') + case('cF','cI') ! 10.1016/0079-6425(94)00007-7, Table 1 characteristicShear = 0.5_pREAL*sqrt(2.0_pREAL) - case('hP') + case('hP') ! 10.1016/0079-6425(94)00007-7, Table 3 if (cOverA < 1.0_pREAL .or. cOverA > 2.0_pREAL) & call IO_error(131,ext_msg='crystal_characteristicShear_Twin') myFamilies: do f = 1,size(Ntwin,1) s = sum(Ntwin(:f-1)) + 1 e = sum(Ntwin(:f)) - select case(f) ! from Christian & Mahajan 1995 p.29 + select case(f) case (1) ! <-10.1>{10.2} characteristicShear(s:e) = (3.0_pREAL-cOverA**2)/sqrt(3.0_pREAL)/CoverA case (2) ! <11.6>{-1-1.1}