Commit 92ee4758 authored by juan rodriguez-carvajal's avatar juan rodriguez-carvajal
Browse files

Changes to complete the treatment of non-standard (but common!) settings of...

Changes to complete the treatment of non-standard (but common!) settings of space groups. Correction of a bug in CFML_Reflections_Utilities.f90 that was outputting forbidden reflections in Shubnikov groups.
parent 63998740
Pipeline #13478 failed with stages
in 6 minutes and 26 seconds
......@@ -8544,7 +8544,6 @@
read(unit=spgm(j+1:j+2),fmt=*,iostat=ier) ic
if (ier /=0) ic=0
call getnum(spgm(:j-1),vet,ivet,iv)
spgm=spgm(:j-1)
else
call getnum(spgm,vet,ivet,iv)
end if
......@@ -8999,7 +8998,12 @@
end do
exit
end do
SpaceGroup%Spg_Symb(2:)=l_case(SpaceGroup%Spg_Symb(2:)) !Make lowercase the HM generators of the group
j=index(SpaceGroup%Spg_Symb,":")
if(j /= 0) then
SpaceGroup%Spg_Symb(2:j)=l_case(SpaceGroup%Spg_Symb(2:j)) !Make lowercase the HM generators of the group
else
SpaceGroup%Spg_Symb(2:)=l_case(SpaceGroup%Spg_Symb(2:)) !Make lowercase the HM generators of the group
end if
end if
!write(*,"(a)") " => Wyckoff done"
......
......@@ -2044,6 +2044,7 @@
np1=nline_ini
call Read_Key_Str(filevar,nline_ini,nline_end, &
"_symmetry_space_group_name_H-M",spgr_hm)
!write(*,"(a)") " From Read_Key_Str _symmetry_space_group_name_H-M: "//spgr_hm
!if (len_trim(spgr_hm) == 0 ) spgr_hm=adjustl(filevar(nline_ini+1))
!nline_ini=np1
! TR feb. 2015 .(re-reading the same item with another name)
......@@ -2052,6 +2053,7 @@
spgr_hm = " "
call Read_Key_Str(filevar,nline_ini,nline_end, "_space_group_name_H-M_alt",spgr_hm)
if (len_trim(spgr_hm) == 0 ) spgr_hm=adjustl(filevar(nline_ini+1))
!write(*,"(a)") " From Read_Key_Str _space_group_name_H-M_alt: "//spgr_hm
end if
if (spgr_hm == "?" .or. spgr_hm == "#") then
......@@ -2071,6 +2073,7 @@
end if
end if
end if
!write(*,"(a)") " After first processing: "//spgr_hm
!---- Adapting Nomenclature from ICSD to our model ----!
np1=len_trim(spgr_hm)
......@@ -2080,16 +2083,21 @@
case("1")
csym2=u_case(spgr_hm(np1-1:np1-1))
if (csym2 == "Z" .or. csym2 =="S") then
spgr_hm=spgr_hm(:np1-2)//":1"
spgr_hm=trim(spgr_hm(:np1-2))//":1"
else
np2=index(spgr_hm,":1")
if(np2 /= 0) then
spgr_hm=trim(spgr_hm(:np2-1))//":1"
end if
end if
case("S","Z")
csym2=u_case(spgr_hm(np1-1:np1-1))
select case (csym2)
case ("H")
spgr_hm=spgr_hm(:np1-2)
spgr_hm=trim(spgr_hm(:np1-2))
case ("R")
spgr_hm=spgr_hm(:np1-2)//":R"
spgr_hm=trim(spgr_hm(:np1-2))//":R"
case default
spgr_hm=spgr_hm(:np1-1)
end select
......@@ -2097,19 +2105,19 @@
case("R")
csym2=u_case(spgr_hm(np1-1:np1-1))
if (csym2 == "H" ) then
spgr_hm=spgr_hm(:np1-2)
spgr_hm=trim(spgr_hm(:np1-2))
else
spgr_hm=spgr_hm(:np1-1)//":R"
spgr_hm=trim(spgr_hm(:np1-2))//":R"
end if
case("H")
spgr_hm=spgr_hm(:np1-1)
spgr_hm=trim(spgr_hm(:np1-1))
csym2=u_case(spgr_hm(np1-1:np1-1))
if(csym2 == ":") spgr_hm=spgr_hm(:np1-2)
if(csym2 == ":") spgr_hm=trim(spgr_hm(:np1-2))
end select
end if
!write(*,"(a)") " After last processing: "//spgr_hm
return
End Subroutine Read_Cif_Hm
!!----
......@@ -5346,6 +5354,8 @@
n_end=ip(iph+1)
if (len_trim(Spp) == 0) call Read_Cif_Hall(file_dat,n_ini,n_end,Spp)
!write(*,"(a)") " Symbol before setting space group: "//Spp
if (len_trim(Spp) == 0) then
n_ini=ip(iph) !Updated values to handle non-conventional order
n_end=ip(iph+1)
......
......@@ -153,7 +153,7 @@
!---- List of public subroutines ----!
public :: Hkl_Equiv_List, Hkl_Gen, Hkl_Rp, Hkl_Uni, Init_Err_Refl, Init_RefList, &
Search_Extinctions, Write_Asu, Write_RefList_Info, Hkl_Gen_Sxtal, &
Hkl_Gen_Shub
Hkl_Gen_Shub, Hkl_Gen_General
!---- List of public overloaded procedures: subroutines ----!
......@@ -3190,7 +3190,7 @@
if(allocated(reflex)) deallocate(reflex)
allocate(reflex(num_ref))
do i=1,num_ref
hh=hkl(:,i)
hh=hklm(:,i)
reflex(i)%h = hh
reflex(i)%s = sm(i)
reflex(i)%mult = hkl_mult(hh,ShubG)
......@@ -3199,6 +3199,124 @@
return
End Subroutine Hkl_Gen_Shub
Subroutine Hkl_Gen_General(Crystalcell,SpG,Friedel,sintlmax,Num_Ref,Reflex)
!---- Arguments ----!
type (Crystal_Cell_Type), intent(in) :: crystalcell
type (Space_Group_Type) , intent(in) :: SpG
logical, intent(in) :: Friedel
real(kind=cp), intent(in) :: sintlmax
integer, intent(out) :: num_ref
type (Reflect_Type), dimension(:), allocatable,intent(out) :: reflex
!---- Local variables ----!
real(kind=cp) :: sval !,vmin,vmax
integer :: h,k,l,hmin,kmin,lmin,hmax,kmax,lmax, maxref,i,j,indp,indj, &
maxpos, mp, iprev
integer, dimension(3) :: hh,kk,nulo
integer, dimension(:,:), allocatable :: hkl,hklm
integer, dimension(:), allocatable :: indx,ini,fin,itreat
real, dimension(:), allocatable :: sv,sm
nulo=0
hmax=nint(CrystalCell%cell(1)*2.0*sintlmax+1.0)
kmax=nint(CrystalCell%cell(2)*2.0*sintlmax+1.0)
lmax=nint(CrystalCell%cell(3)*2.0*sintlmax+1.0)
hmin=-hmax; kmin=-kmax; lmin= -lmax
maxref= (2*hmax+1)*(2*kmax+1)*(2*lmax+1)
allocate(hkl(3,maxref),indx(maxref),sv(maxref))
num_ref=0
ext_do: do h=hmin,hmax
do k=kmin,kmax
do l=lmin,lmax
hh=(/h,k,l/)
if (hkl_equal(hh,nulo)) cycle
sval=hkl_s(hh,crystalcell)
if (sval > sintlmax) cycle
if (Hkl_Lat_Absent(hh,SpG%Latt_trans,SpG%NumLat)) cycle
num_ref=num_ref+1
if(num_ref > maxref) then
num_ref=maxref
exit ext_do
end if
sv(num_ref)=sval
hkl(:,num_ref)=hh
end do
end do
end do ext_do
call sort(sv,num_ref,indx)
allocate(hklm(3,num_ref),sm(num_ref),ini(num_ref),fin(num_ref),itreat(num_ref))
do i=1,num_ref
j=indx(i)
hklm(:,i)=hkl(:,j)
sm(i)=sv(j)
end do
deallocate(hkl,sv,indx)
itreat=0; ini=0; fin=0
indp=0
do i=1,num_ref !Loop over all reflections
!write(*,"(i6,3i5,i8)") i, hklm(:,i),itreat(i)
if(itreat(i) == 0) then !If not yet treated do the following
hh(:)=hklm(:,i)
indp=indp+1 !update the number of independent reflections
itreat(i)=i !Make this reflection treated
ini(indp)=i !put pointers for initial and final equivalent reflections
fin(indp)=i
do j=i+1,num_ref !look for equivalent reflections to the current (i) in the list
if(abs(sm(i)-sm(j)) > 0.000001) exit
kk=hklm(:,j)
if(hkl_equiv(hh,kk,SpG)) then ! if hh eqv kk
itreat(j) = i ! add kk to the list equivalent to i
fin(indp)=j
end if
end do
end if !itreat
end do
!Selection of the most convenient independent reflections
allocate(hkl(3,indp),sv(indp),indx(indp))
indx=0 !nuclear by default
do i=1,indp
maxpos=0
indj=ini(i)
iprev=itreat(indj)
do j=ini(i),fin(i)
if(iprev /= itreat(j)) cycle
hh=hklm(:,j)
mp=count(hh > 0)
if(mp > maxpos) then
indj=j
maxpos=mp
end if
end do !j
hkl(:,i)=hklm(:,indj)
if(hkl(1,i) < 0) hkl(:,i)=-hkl(:,i)
sv(i)=sm(indj)
end do
!Now apply systematic absences other than lattice type
num_ref=0
do i=1,indp
hh=hkl(:,i)
if(Hkl_Absent(hh,SpG)) cycle
num_ref=num_ref+1
hklm(:,num_ref)=hh
sm(num_ref) = sv(i)
end do
!Final assignments
if(allocated(reflex)) deallocate(reflex)
allocate(reflex(num_ref))
do i=1,num_ref
hh=hklm(:,i)
reflex(i)%h = hh
reflex(i)%s = sm(i)
reflex(i)%mult = hkl_mult(hh,SpG,Friedel)
reflex(i)%imag = indx(i)
end do
End Subroutine Hkl_Gen_General
!!----
!!---- Subroutine Hkl_Gen_Sxtal (Crystalcell,Spacegroup,stlmin,stlmax,Num_Ref,Reflex,ord,hlim)
!!---- Type (Crystal_Cell_Type), intent(in) :: CrystalCell !Unit cell object
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment