Changes in different parts of the library: trying to implement a more...

Changes in different parts of the library: trying to implement a more efficient and exhaustive search of subgroups, CFML_Geom, on cmake scripts, etc.

Cmake_help.inf

@@ -79,7 +79,7 @@ Building CrysFML08
 # Console Only for Ifort in debug mode
 cmake -G "NMake Makefiles"  -D ARCH32=OFF -D CMAKE_BUILD_TYPE=Debug -D CMAKE_Fortran_COMPILER=ifort -D CMAKE_INSTALL_PREFIX=%CRYSFML%\ifort64_debug -D CRYSFML_PREFIX=LibC08 -D CRYSFML08=ON ..\..\.
 # Console Only for Ifort in release mode
-cmake -G "NMake Makefiles"  -D ARCH32=OFF -D CMAKE_BUILD_TYPE=Release -D CMAKE_Fortran_COMPILER=ifort -D CMAKE_INSTALL_PREFIX=%CRYSFML%\ifort64 -D CRYSFML_PREFIX=LibC08 -D CRYSFML08=ON ..\..\.
+cmake -G "NMake Makefiles"  -D ARCH32=OFF GUI=OFF -D CMAKE_BUILD_TYPE=Release -D CMAKE_Fortran_COMPILER=ifort -D CMAKE_INSTALL_PREFIX=%CRYSFML%\ifort64 -D CRYSFML_PREFIX=LibC08 -D CRYSFML08=ON ..\..\.
 
  
 Building CrysFML for use with HDF5

Src08/CFML_Atoms.f90

@@ -39,11 +39,12 @@
 !!----    Update: 06/03/2011
 !!----
 !!
-Module CFML_Atoms
+ Module CFML_Atoms
 
     !---- Use Modules ----!
     Use CFML_GlobalDeps
     Use CFML_Maths,        only: modulo_lat, equal_vector
+    Use CFML_Metrics,      only: Cell_G_Type
     Use CFML_Strings,      only: u_case,l_case
     Use CFML_gSpaceGroups, only: spg_type, apply_op, SuperSpaceGroup_Type
 
@@ -53,8 +54,10 @@ Module CFML_Atoms
     private
 
     !---- List of public procedures ----!
-    public :: Allocate_Atom_List, Extend_List, Init_Atom_Type, Read_Bin_Atom_List, &
+    public :: Allocate_Atom_List, Extend_Atom_List, Init_Atom_Type, Read_Bin_Atom_List, &
               Write_Bin_atom_List, Write_Atom_List
+    public :: Equiv_Atm, Wrt_Lab
+
 
     !---- Parameters ----!
     real(kind=cp), parameter :: R_ATOM=1.1_cp      ! Average atomic radius
@@ -208,6 +211,34 @@ Module CFML_Atoms
        character (len=20),      dimension(:), allocatable :: ddlab          ! Labels of atoms at ddist (nat*idp)
     End Type Atm_Cell_Type
 
+    !!---- Type, Public :: Atom_Equiv_Type
+    !!----    integer                                        :: mult
+    !!----    character(len=2)                               :: ChemSymb
+    !!----    character(len=10),allocatable, dimension(:)    :: Lab
+    !!----    real(kind=sp),    allocatable, dimension(:,:)  :: x
+    !!---- End Type Atom_Equiv_Type
+    !!----
+    !!----  Updated: January 2014
+    !!
+    Type, Public :: Atom_Equiv_Type
+       integer                                        :: mult
+       character(len=2)                               :: ChemSymb
+       character(len=20),allocatable, dimension(:)    :: Lab
+       real(kind=cp),    allocatable, dimension(:,:)  :: x
+    End Type Atom_Equiv_Type
+
+    !!---- Type, Public :: Atom_Equiv_List_Type
+    !!----    integer                                           :: nauas
+    !!----    type (Atom_Equiv_Type), allocatable, dimension(:) :: atm
+    !!---- End Type Atom_Equiv_List_Type
+    !!----
+    !!----  Updated: January 2014
+    !!
+    Type, Public :: Atom_Equiv_List_Type
+       integer                                           :: nauas
+       type (Atom_Equiv_Type), allocatable, dimension(:) :: atm
+    End Type Atom_Equiv_List_Type
+
     !!----
     !!---- TYPE :: ALIST_TYPE
     !!--..
@@ -220,9 +251,30 @@ Module CFML_Atoms
        class(Atm_Type), dimension(:), allocatable :: Atom          ! Atoms
     End type AtList_Type
 
+    !Overload
+
+    Interface Extend_Atom_List
+      Module Procedure Extend_List              !Creating a new AtList_Type with all atoms in unit cell
+      Module Procedure Set_Atom_Equiv_List      !Creating a an Atom_Equiv_List_Type from AtList_Type in asymmetric unit
+    End Interface Extend_Atom_List
+
+
     !---- Interface Zone ----!
     Interface
 
+       Pure Module Function Equiv_Atm(Nam1,Nam2,NameAt) Result(Equiv_Atom)
+          !---- Arguments ----!
+          character (len=*), intent (in) :: nam1,nam2
+          character (len=*), intent (in) :: NameAt
+          logical                        :: equiv_atom
+       End Function Equiv_Atm
+
+       Pure Module Function Wrt_Lab(Nam1,Nam2) Result(Bilabel)
+          !---- Arguments ----!
+          character (len=*), intent (in) :: nam1,nam2
+          character (len=8)              :: bilabel
+       End Function Wrt_Lab
+
        Module Subroutine Init_Atom_Type(Atm,d)
           !---- Arguments ----!
           class(Atm_Type), intent(in out)   :: Atm
@@ -266,6 +318,14 @@ Module CFML_Atoms
           logical, optional,   intent(in)     :: Conven    ! If present and .true. using the whole conventional unit cell
        End Subroutine Extend_List
 
+       Module Subroutine Set_Atom_Equiv_List(SpG,cell,A,Ate,lun)
+         type(SpG_Type),             intent(in) :: SpG
+         type(Cell_G_Type),          intent(in) :: Cell
+         type(Atlist_Type),          intent(in) :: A
+         type(Atom_Equiv_List_Type), intent(out):: Ate
+         integer, optional,          intent(in) :: lun
+       End Subroutine Set_Atom_Equiv_List
+
     End Interface
 
-End Module CFML_Atoms
+ End Module CFML_Atoms

Src08/CFML_Atoms/Allocating_Atoms.f90

@@ -160,7 +160,7 @@ SubModule (CFML_Atoms) Init_Allocating_Atoms
       integer,             intent(in)       :: d    !Number of k-vectors
 
       !---- Local Variables ----!
-      integer :: i
+      integer :: i,ier
       ! Types :: Atm_Type, Atm_Std_Type, MAtm_Std_Type, Atm_Ref_Type, MAtm_Ref_Type
       type(Atm_Type)     , dimension(n)  :: Atm
       type(Atm_Std_Type) , dimension(n)  :: Atm_Std
@@ -180,18 +180,24 @@ SubModule (CFML_Atoms) Init_Allocating_Atoms
       !> Allocating variables
       Select Case(trim(l_case(Type_Atm)))
         Case("atm")
-           allocate (A%atom(n),source=Atm)
+           allocate (A%atom(n),source=Atm,stat=ier)
         Case("atm_std")
-           allocate (A%atom(n),source=Atm_Std)
+           allocate (A%atom(n),source=Atm_Std,stat=ier)
         Case("matm_std")
-           allocate (A%atom(n),source=MAtm_Std)
+           allocate (A%atom(n),source=MAtm_Std,stat=ier)
         Case("atm_ref")
-            allocate (A%atom(n),source=Atm_Ref)
+            allocate (A%atom(n),source=Atm_Ref,stat=ier)
        Case("matm_ref")
-           allocate (A%atom(n),source=MAtm_Ref)
+           allocate (A%atom(n),source=MAtm_Ref,stat=ier)
       End Select
 
-      allocate (A%active(n))
+      allocate (A%active(n),stat=ier)
+
+      if(ier /= 0) then
+        Err_CFML%Ierr=1
+        write(unit=Err_CFML%Msg,fmt="(a,i6,a)") "Error allocating atom List for N =",N," atoms"
+      end if
+
       A%active=.true.
       A%mcomp="crystal"
 

Src08/CFML_Atoms/ExtendList.f90

@@ -130,4 +130,91 @@ SubModule (CFML_Atoms) Generating_Atoms_inCell
       call allocate_atom_list(0,c_atm,Type_Atm,3)
 
    End Subroutine Extend_List
+
+   !!----
+   !!----    Module Subroutine Set_Atom_Equiv_List(SpG,cell,A,Ate,lun)
+   !!----      type(SpG_Type),             intent(in) :: SpG
+   !!----      type(Cell_G_Type),          intent(in) :: Cell
+   !!----      type(Atlist_Type),          intent(in) :: A
+   !!----      type(Atom_Equiv_List_Type), intent(out):: Ate
+   !!----      integer, optional,          intent(in) :: lun
+   !!----
+   !!---- Subroutine constructing the list of all atoms in the unit cell.
+   !!---- The atoms are in a structure of type "Atom_Equiv_List_Type" containing
+   !!---- just the fractional coordinates of all the atoms in the cell.
+   !!---- This a simplified version of the Extend_List Subroutine useful for geometric
+   !!---- calculations, using the type Atom_Equiv_List_Type, without the burden of
+   !!---- all components of Aton_Type
+   !!----
+   !!---- Updated: May 2020
+   !!
+   Module Subroutine Set_Atom_Equiv_List(SpG,cell,A,Ate,lun)
+     type(SpG_Type),             intent(in) :: SpG
+     type(Cell_G_Type),          intent(in) :: Cell
+     type(Atlist_Type),          intent(in) :: A
+     type(Atom_Equiv_List_Type), intent(out):: Ate
+     integer, optional,          intent(in) :: lun
+
+     ! local variables
+     real(kind=cp),  dimension(3)            :: xx,xo,v,xc
+     real(kind=cp),  dimension(3,SpG%Multip) :: u
+     character(len=20),dimension(SpG%Multip) :: label
+     integer                                 :: k,j,L,nt
+     character (len=6)                       :: fmm
+     character (len=20)                      :: nam
+     real(kind=cp), parameter                :: epsi = 0.002
+
+     if (.not. allocated (Ate%atm)) allocate(Ate%atm(A%natoms))
+     ate%nauas=A%natoms
+     if (present(lun))  then
+        write(unit=lun,fmt="(/,a)") "     LIST OF ATOMS INSIDE THE CONVENTIONAL UNIT CELL "
+        write(unit=lun,fmt="(a,/)") "     =============================================== "
+     end if
+     do k=1,A%natoms
+        ate%atm(k)%ChemSymb = A%atom(k)%ChemSymb
+        xo(:) =Modulo_Lat(A%atom(k)%x(:))
+        L=1
+        u(:,L)=xo(:)
+        xc =matmul(cell%Cr_Orth_cel,xo)
+        if (present(lun))then
+         write(unit=lun,fmt="(/,a,a)") " => Equivalent positions of atom: ",A%atom(k)%lab
+         write(unit=lun,fmt="(a)")  &
+         "                                    x         y         z          Xc        Yc        Zc"
+        end if
+        fmm="(a,i1)"
+        write(unit=label(L),fmt=fmm) trim(A%Atom(k)%lab)//"_",L
+        nam=label(L)
+        if (present(lun)) write(unit=lun,fmt="(3a,3f10.5,a,3f10.5)") "       ",nam,"  ", xo,"  ", xc
+
+        do_eq:DO j=2,SpG%multip
+           xx=Apply_OP(SpG%Op(j),xo)
+           xx=modulo_lat(xx)
+           do nt=1,L
+              v=u(:,nt)-xx(:)
+              if (sum(abs((v))) < epsi ) cycle do_eq
+           end do
+           L=L+1
+           u(:,L)=xx(:)
+           if ( L > 9 .and. L < 100)  fmm="(a,i2)"
+           if ( L >= 100 )  fmm="(a,i3)"
+           write(unit=label(L),fmt=fmm) trim(A%Atom(k)%lab)//"_",L
+           nam=Label(L)
+           xc=matmul(cell%Cr_Orth_cel,xx)
+           if (present(lun)) write(unit=lun,fmt="(3a,3f10.5,a,3f10.5)") "       ",nam,"  ", xx,"  ", xc
+        end do do_eq
+
+        if(allocated(Ate%Atm(k)%Lab)) deallocate(Ate%Atm(k)%Lab)
+        allocate(Ate%Atm(k)%lab(L))
+        if(allocated(Ate%Atm(k)%x)) deallocate(Ate%Atm(k)%x)
+        allocate(Ate%Atm(k)%x(3,L))
+
+        Ate%Atm(k)%mult=L
+        do j=1,Ate%Atm(k)%mult
+          Ate%Atm(k)%lab(j)=Label(j)
+          Ate%Atm(k)%x(:,j)=u(:,j)
+        end do
+     end do
+     if (present(lun))  write(unit=lun,fmt="(/)")
+   End Subroutine Set_Atom_Equiv_List
+
 End SubModule Generating_Atoms_inCell
\ No newline at end of file

Src08/CFML_Atoms/Write_AtmList.f90

@@ -2,8 +2,81 @@
 !!----
 !!----
 SubModule (CFML_Atoms)  Write_Atoms
-   implicit none
-   Contains
+  implicit none
+  Contains
+
+   !!----
+   !!---- Pure Module Function Function Equiv_Atm(Nam1,Nam2,NameAt) Result(Equiv_Atom)
+   !!----    character (len=*), intent (in) :: nam1       !  In -> Atom Nam1
+   !!----    character (len=*), intent (in) :: nam2       !  In -> Atom Nam2
+   !!----    character (len=*), intent (in) :: NameAt     !  In -> String containing atom names
+   !!----    logical                        :: equiv_atom !  Result .true. or .false.
+   !!----
+   !!----    Determine whether the atoms of names "nam1" and "nam2" are included in
+   !!----    the longer string "name" (constructed by function "wrt_lab").
+   !!----
+   !!---- Update: February - 2005
+   !!
+   Pure Module Function Equiv_Atm(Nam1,Nam2,NameAt) Result(Equiv_Atom)
+      !---- Arguments ----!
+      character (len=*), intent (in) :: nam1,nam2
+      character (len=*), intent (in) :: NameAt
+      logical                        :: equiv_atom
+
+      !---- Local variables ----!
+      integer :: i1,i2
+
+      equiv_atom = .false.
+
+      i1=index(nam1,"_")-1
+      i2=index(nam2,"_")-1
+      if (i1 < 0 .or. i2 < 0 ) return
+      if (nam1(1:i1) == nameat(1:i1) .and. nam2(1:i2) == nameat(5:4+i2) ) then
+         equiv_atom = .true.
+      else if(nam1(1:i1) == nameat(5:4+i1) .and. nam2(1:i2) == nameat(1:i2) ) then
+         equiv_atom = .true.
+      end if
+
+   End Function Equiv_Atm
+
+   !!----
+   !!---- Pure Module Function Wrt_Lab(Nam1,Nam2) Result(Bilabel)
+   !!----    character (len=*), intent (in) :: nam1     !  In -> Atom name 1
+   !!----    character (len=*), intent (in) :: nam2     !  In -> Atom name 2
+   !!----    character (len=8)              :: bilabel  ! Result -> Composed string with underscores
+   !!----
+   !!----    Character function merging the main part of the labels
+   !!----    (before underscore "_") of the atoms "nam1" and "nam2" into
+   !!----    the string "bilabel"
+   !!----
+   !!---- Update: February - 2005
+   !!
+   Pure Module Function Wrt_Lab(Nam1,Nam2) Result(Bilabel)
+      !---- Arguments ----!
+      character (len=*), intent (in) :: nam1,nam2
+      character (len=8)              :: bilabel
+
+      !---- Local variables ----!
+      integer :: i1,i2
+
+      bilabel=" "
+
+      i1=index(nam1,"_")-1
+      i2=index(nam2,"_")-1
+      if (i1 < 0 ) then
+         bilabel(1:4) = nam1(1:4)
+      else
+         bilabel(1:i1) = nam1(1:i1)
+      end if
+
+      if (i2 < 0 ) then
+         bilabel(5:8) = nam2(1:4)
+      else
+         bilabel(5:4+i2) = nam2(1:i2)
+      end if
+
+   End Function Wrt_Lab
+
    !!----
    !!---- WRITE_ATOM_LIST
    !!----    Write the atoms in the asymmetric unit

Src08/CFML_IOForm.f90

@@ -46,7 +46,7 @@ Module CFML_IOForm
                                       string_numstd, Number_Lines, Reading_Lines, FindFMT, &
                                       Init_FindFMT, String_Array_Type, File_type
     Use CFML_Atoms,             only: Atm_Type, Atm_Std_Type, Matm_std_type, Atm_Ref_Type, &
-                                      AtList_Type, Allocate_Atom_List
+                                      AtList_Type, Allocate_Atom_List, Init_Atom_Type
     Use CFML_Metrics,           only: Cell_Type, Cell_G_Type, Set_Crystal_Cell, U_equiv, &
                                       get_U_from_Betas, get_Betas_from_U, get_Betas_from_B
     Use CFML_gSpaceGroups,      only: SpG_Type, SuperSpaceGroup_Type, Kvect_Info_Type,   &
@@ -65,7 +65,7 @@ Module CFML_IOForm
 
     !---- Public subroutines ----!
     public :: Readn_Set_Xtal_Structure, Read_CFL_Cell, Read_CFL_SpG, Read_CFL_Atoms, &
-              Read_Kinfo, Check_Symmetry_Constraints
+              Read_Kinfo, Check_Symmetry_Constraints, Write_Cif_Template
     real(kind=cp), parameter :: EPSV=0.0001_cp     ! Small real value to be used for decisions
     !---- Definitions ----!
 
@@ -424,6 +424,16 @@ Module CFML_IOForm
        !   type(atlist_type),       intent(in) :: at_List
        !End Subroutine Write_Shx_Template
 
+       Module Subroutine Write_Cif_Template(filename, Cell, SpG, At_list, Type_data, Code)
+          !---- Arguments ----!
+          character(len=*),           intent(in) :: filename     ! Filename
+          class(Cell_G_Type),         intent(in) :: Cell         ! Cell parameters
+          class(SpG_Type),            intent(in) :: SpG          ! Space group information
+          Type (AtList_Type),         intent(in) :: At_List      ! Atoms
+          integer,                    intent(in) :: Type_data    ! 0,2:Single crystal diffraction; 1:Powder
+          character(len=*),           intent(in) :: Code         ! Code or name of the structure
+       End Subroutine Write_Cif_Template
+
     End Interface
 
     Contains

Src08/CFML_IOForm/Format_CFL.f90

@@ -55,7 +55,7 @@ SubModule (CFML_IOForm) IOF_CFL
              ip(ndata)=i
           end if
        end do
-
+       !write(*,"(a)") " => Reading Phase Information"
        !---- Reading Phase Information ----!
        iph=1
        if (present(nphase)) iph=nphase
@@ -65,6 +65,7 @@ SubModule (CFML_IOForm) IOF_CFL
           call Get_Job_Info(file_dat,n_ini,n_end,Job_info)
        end if
 
+       !write(*,"(a)") " => Reading Cell Parameters"
        !---- Reading Cell Parameters ----!
        n_ini=ip(iph)           !Updated values to handle non-conventional order
        n_end=ip(iph+1)
@@ -75,6 +76,7 @@ SubModule (CFML_IOForm) IOF_CFL
        end if
        if (err_CFML%Ierr /= 0) return
 
+       !write(*,"(a)") " => Reading Space Group Information"
        !---- Reading Space Group Information ----!
        n_ini=ip(iph)           !Updated values to handle non-conventional order
        n_end=ip(iph+1)
@@ -86,6 +88,7 @@ SubModule (CFML_IOForm) IOF_CFL
        n_ini=ip(iph)           !Updated values to handle non-conventional order
        n_end=ip(iph+1)
 
+       !write(*,"(a)") " => Calculating number of Atoms in the Phase"
        !---- Calculating number of Atoms in the Phase ----!
        do i=n_ini,n_end
           line=adjustl(file_dat(i))
@@ -93,6 +96,7 @@ SubModule (CFML_IOForm) IOF_CFL
        end do
 
        if (nauas > 0) then
+          !write(*,"(a)") " => Reading Atoms"
           call Read_CFL_Atoms(file_dat,n_ini,n_end,A,Type_Atm,SpG%D-1)
           if (err_CFML%Ierr /= 0) return
           if(allocated(vet)) deallocate(vet)
@@ -345,7 +349,7 @@ SubModule (CFML_IOForm) IOF_CFL
        call Cut_String(line,nlong1,label)
 
        if((U_case(label(1:1)) == "M" .or. U_case(label(1:1)) == "J" ) & !Magnetic atom
-          .and. index(digpm(1:10),label(4:4)) /= 0) then
+          .and. index(digpm(1:10),label(4:4)) /= 0 .and. index(label,"+") == 0) then
           atom%ChemSymb=U_case(label(2:2))//L_case(label(3:3))
           atom%Magnetic=.true.
        else

Src08/CFML_Maths.f90

@@ -55,7 +55,7 @@
               Gcd, Get_EPS_Math, Get_Cart_from_Cylin, Get_Cart_from_Spher,       &
               Get_Cylin_from_Cart, Get_Cylin_from_Spher, Get_Spher_from_Cart,    &
               Get_Spher_from_Cylin,          &
-              Inverse_Matrix, In_Limits, Is_Diagonal_Matrix, Is_Null_Vector,      &
+              Inverse_Matrix, In_Limits, Is_Diagonal_Matrix, Is_Null_Vector,     &
               Integral_Slater_Bessel,        &
               Lcm, Linear_Dependent, Linear_Interpol, Locate, Lower_Triangular,  &
               Mat_Cross, Modulo_Lat,         &

Src08/CFML_Maths/Determinant.f90

@@ -247,7 +247,7 @@ Submodule (CFML_Maths) Determinant
        real(kind=cp), dimension(3,3), intent(in) :: A   !! Matrix
        real(kind=cp)                             :: Det      !! Determinant
 
-       !> Calculate the inverse determinant of the matrix
+       !> Calculate the determinant of the matrix
        det = A(1,1)*A(2,2)*A(3,3) - A(1,1)*A(2,3)*A(3,2) &
            - A(1,2)*A(2,1)*A(3,3) + A(1,2)*A(2,3)*A(3,1) &
            + A(1,3)*A(2,1)*A(3,2) - A(1,3)*A(2,2)*A(3,1)
@@ -266,7 +266,7 @@ Submodule (CFML_Maths) Determinant
        complex(kind=cp), dimension(4,4), intent(in) :: A   !! Matrix
        complex(kind=cp)                             :: Det      !! Determinant
 
-       !> Calculate the inverse determinant of the matrix
+       !> Calculate the determinant of the matrix
        det = A(1,1)*(A(2,2)*(A(3,3)*A(4,4)-A(3,4)*A(4,3))+A(2,3)*(A(3,4)*A(4,2)-A(3,2)*A(4,4))+ &
              A(2,4)*(A(3,2)*A(4,3)-A(3,3)*A(4,2))) &
            - A(1,2)*(A(2,1)*(A(3,3)*A(4,4)-A(3,4)*A(4,3))+A(2,3)*(A(3,4)*A(4,1)-A(3,1)*A(4,4))+ &
@@ -290,7 +290,7 @@ Submodule (CFML_Maths) Determinant
        integer, dimension(4,4), intent(in) :: A   !! Matrix
        integer                             :: Det      !! Determinant
 
-       !> Calculate the inverse determinant of the matrix
+       !> Calculate the determinant of the matrix
        det = A(1,1)*(A(2,2)*(A(3,3)*A(4,4)-A(3,4)*A(4,3))+A(2,3)*(A(3,4)*A(4,2)-A(3,2)*A(4,4))+ &
              A(2,4)*(A(3,2)*A(4,3)-A(3,3)*A(4,2))) &
            - A(1,2)*(A(2,1)*(A(3,3)*A(4,4)-A(3,4)*A(4,3))+A(2,3)*(A(3,4)*A(4,1)-A(3,1)*A(4,4))+ &
@@ -314,7 +314,7 @@ Submodule (CFML_Maths) Determinant
        real(kind=cp), dimension(4,4), intent(in) :: A   !! Matrix
        real(kind=cp)                             :: Det      !! Determinant
 
-       !> Calculate the inverse determinant of the matrix
+       !> Calculate the determinant of the matrix
        det = A(1,1)*(A(2,2)*(A(3,3)*A(4,4)-A(3,4)*A(4,3))+A(2,3)*(A(3,4)*A(4,2)-A(3,2)*A(4,4))+ &
              A(2,4)*(A(3,2)*A(4,3)-A(3,3)*A(4,2))) &
            - A(1,2)*(A(2,1)*(A(3,3)*A(4,4)-A(3,4)*A(4,3))+A(2,3)*(A(3,4)*A(4,1)-A(3,1)*A(4,4))+ &

Src08/CFML_gSpaceGroups.f90

@@ -46,11 +46,11 @@
 !!
 Module CFML_gSpaceGroups
     !---- Use Modules ----!
+    Use CFML_GlobalDeps,        only: CP,DP, LI, EPS, err_cfml, clear_error, CFML_Debug,TPI
     Use CFML_Rational
     Use CFML_Symmetry_Tables
     Use CFML_Magnetic_Database
     Use CFML_SuperSpace_Database
-    Use CFML_GlobalDeps,        only: CP,DP, LI, EPS, err_cfml, clear_error, CFML_Debug,TPI
     Use CFML_Maths,             only: Set_eps_math, modulo_lat, determ3D, Get_eps_math, Zbelong,EPSS,Diagonalize_RGEN, &
                                       equal_vector,resolv_sist_3x3,trace
     Use CFML_Strings,           only: u_case, l_case, pack_string, get_separator_pos, get_num, &
@@ -79,7 +79,7 @@ Module CFML_gSpaceGroups
               Identify_Group, Init_SpaceGroup,  Is_OP_Inversion_Centre,           &
               Set_Conditions_NumOP_EPS, Set_SpaceGroup,Is_OP_Lattice_Centring,    &
               Write_SpaceGroup_Info, Get_Multip_Pos, Is_Lattice_Vec,Is_OP_Anti_Lattice, &
-              Get_SubGroups_full
+              Get_SubGroups_full, SearchOp, Write_SymTrans_Code, Read_SymTrans_Code
 
     !---- Types ----!
 
@@ -137,11 +137,14 @@ Module CFML_gSpaceGroups
        type(rational),dimension(:,:), allocatable :: aLat_tr           ! Anti-translations
     End Type SPG_Type
 
-    Type, public, extends(Spg_Type):: SuperSpaceGroup_Type
+    Type, public, extends(Spg_Type):: Spg_Oreal_Type
+       real(kind=cp), allocatable,dimension(:,:,:):: Om        ! Operator matrices (3+d+1,3+d+1,Multip) in real form to accelerate calculations
+    End Type Spg_Oreal_Type
+
+    Type, public, extends(Spg_Oreal_Type) :: SuperSpaceGroup_Type
        integer                                    :: nk=0      ! (nk=1,2,3, ...) number of k-vectors
        integer                                    :: nq=0      ! number of effective set of Q_coeff >= nk
        real,          allocatable,dimension(:,:)  :: kv        ! k-vectors (3,nk)
-       real(kind=cp), allocatable,dimension(:,:,:):: Om        ! Operator matrices (3+d+1,3+d+1,Multip) in real form to accelerate calculations
        real(kind=cp), allocatable,dimension(:)    :: sintlim   ! sintheta/lambda limits (nk)
        integer,       allocatable,dimension(:)    :: nharm     ! number of harmonics along each k-vector
        integer,       allocatable,dimension(:,:)  :: q_coeff   ! Q_coeff(nk,nq)
@@ -224,6 +227,7 @@ Module CFML_gSpaceGroups
     Interface Is_Lattice_Vec
        module procedure Is_Lattice_Vec_rat
        module procedure Is_Lattice_Vec_real
+       module procedure Is_Vec_Lattice_Centring
     End Interface Is_Lattice_Vec
 
     Interface Set_SpaceGroup
@@ -468,14 +472,16 @@ Module CFML_gSpaceGroups
           integer, dimension(:,:), allocatable, optional, intent(out)    :: table
        End Subroutine Get_OPS_from_Generators
 
-       Module Subroutine Get_Orbit(x,mom,Spg,Mult,orb,morb,ptr,convl)
+       Module Subroutine Get_Orbit(x,Spg,Mult,orb,mom,morb,ptr,convl)
           !---- Arguments ----!
-          real(kind=cp), dimension(:),                intent (in) :: x,mom
-          class(SpG_Type),                            intent (in) :: spg
-          integer,                                    intent(out) :: mult
-          real(kind=cp),dimension(:,:), allocatable,  intent(out) :: orb,morb
-          integer, dimension(:),allocatable, optional,intent(out) :: ptr
-          logical,                           optional,intent(in)  :: convl
+          real(kind=cp), dimension(:),                         intent(in)  :: x
+          class(SpG_Type),                                     intent(in)  :: spg
+          integer,                                             intent(out) :: mult
+          real(kind=cp),dimension(:,:), allocatable,           intent(out) :: orb
+          real(kind=cp), dimension(:),               optional, intent(in)  :: mom
+          real(kind=cp),dimension(:,:), allocatable, optional, intent(out) :: morb
+          integer, dimension(:),allocatable,         optional, intent(out) :: ptr
+          logical,                                   optional, intent(in)  :: convl
        End Subroutine Get_Orbit
 
        Module Subroutine Get_Origin_Shift(G, G_, ng, P_, origShift, shift)
@@ -543,6 +549,13 @@ Module CFML_gSpaceGroups
           type(rational), dimension(3,3)               :: S
        End Function Get_S_Matrix
 
+       Module Function SearchOp(Sim,I1,I2) Result(Isl)
+          !---- Arguments ----!
+          integer , dimension(3,3), Intent(in) :: sim
+          integer , Intent(in)                 :: i1,i2
+          integer                              :: Isl
+       End Function SearchOp
+
        Module Subroutine Get_Stabilizer(X, Spg,Order,Ptr,Atr)
           !---- Arguments ----!
           real(kind=cp), dimension(3),  intent (in)  :: x
@@ -561,13 +574,14 @@ Module CFML_gSpaceGroups
           logical, dimension(:,:), optional,intent(out) :: point
        End Subroutine Get_SubGroups
 
-       Module Subroutine Get_SubGroups_full(SpG, SubG, nsg, indexg, point)
+       Module Subroutine Get_SubGroups_full(SpG, SubG, nsg, indexg, point,printd)
           !---- Arguments ----!
           type(Spg_Type),                    intent( in) :: SpG
           type(Spg_Type),dimension(:),       intent(out) :: SubG
           integer,                           intent(out) :: nsg
           integer,                  optional,intent(in)  :: indexg
           logical, dimension(:,:),  optional,intent(out) :: point
+          logical,                  optional,intent(in)  :: printd
        End Subroutine Get_SubGroups_full
 
        Module Function Get_Symb_from_Mat_Tr(Mat, tr, oposite) Result(Str)
@@ -739,6 +753,14 @@ Module CFML_gSpaceGroups
           logical                                   :: Lattice
        End Function is_Lattice_vec_real
 
+       Pure Module Function Is_Vec_Lattice_Centring(vec,SpG,Prim) Result(Info)
+          !---- Arguments ----!
+          real(kind=cp), dimension(:), intent(in) :: Vec
+          Class(SpG_Type), optional,   intent(in) :: SpG
+          logical, optional,           intent(in) :: Prim
+          logical                                 :: info
+       End Function Is_Vec_Lattice_Centring
+
        Module Function Is_OP_Minus_1_Prime(Op) Result(Info)
           !---- Arguments ----!
           type(Symm_Oper_Type),intent(in) :: Op
@@ -770,6 +792,20 @@ Module CFML_gSpaceGroups
           logical                                     :: positive
        End Function Positive_SenseRot
 
+       Pure Module Function Write_SymTrans_Code(N,Tr) Result(Code)
+          !---- Arguments ----!
+          integer,                    intent(in)  :: N
+          real(kind=cp),dimension(3), intent(in)  :: Tr
+          character (len=:), allocatable          :: Code
+       End Function Write_SymTrans_Code
+
+       Module Subroutine Read_SymTrans_Code(Code,N,Tr)
+          !---- Arguments ----!
+          character (len=*),          intent( in) :: Code
+          integer,                    intent(out) :: N