xref: /dports/science/mcstas-comps/mcstas-comps-2.5-src/libs/cif2hkl/cif2hkl.F90

!!-------------------------------------------------------
!!---- Crystallographic Fortran Modules Library (CrysFML)
!!-------------------------------------------------------
!!---- The CrysFML project is distributed under LGPL. In agreement with the
!!---- Intergovernmental Convention of the ILL, this software cannot be used
!!---- in military applications.
!!----
!!---- Copyright (C) 1999-2012  Institut Laue-Langevin (ILL), Grenoble, FRANCE
!!----                          Universidad de La Laguna (ULL), Tenerife, SPAIN
!!----                          Laboratoire Leon Brillouin(LLB), Saclay, FRANCE
!!----
!!---- Authors: Juan Rodriguez-Carvajal (ILL)
!!----          Javier Gonzalez-Platas  (ULL)
!!----
!!---- Contributors: Laurent Chapon     (ILL)
!!----               Marc Janoschek     (Los Alamos National Laboratory, USA)
!!----               Oksana Zaharko     (Paul Scherrer Institute, Switzerland)
!!----               Tierry Roisnel     (CDIFX,Rennes France)
!!----               Eric Pellegrini    (ILL)
!!----
!!---- This library is free software; you can redistribute it and/or
!!---- modify it under the terms of the GNU Lesser General Public
!!---- License as published by the Free Software Foundation; either
!!---- version 3.0 of the License, or (at your option) any later version.
!!----
!!---- This library is distributed in the hope that it will be useful,
!!---- but WITHOUT ANY WARRANTY; without even the implied warranty of
!!---- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
!!---- Lesser General Public License for more details.
!!----
!!---- You should have received a copy of the GNU Lesser General Public
!!---- License along with this library; if not, see <http://www.gnu.org/licenses/>.
!!----
!!----
!!---- MODULE: CFML_GlobalDeps  (Linux version)
!!----   INFO: Precision for CrysFML library and Operating System information
!!----         All the global variables defined in this module are implicitly public.
!!----
!!---- HISTORY
!!--..    Update: 02/03/2011
!!--..
!!---- VARIABLES
!!--..
!!--..    Operating system
!!--..
!!----    OPS
!!----    OPS_NAME
!!----    OPS_SEP
!!--..
!!--..    Precision Data
!!--..
!!----    SP
!!----    DP
!!----    CP
!!--..
!!--..    Trigonometric
!!--..
!!----    PI
!!----    TO_DEG
!!----    TO_RAD
!!----    TPI
!!--..
!!--..    Numeric
!!--..
!!----    DEPS
!!----    EPS
!!--..
!!---- FUNCTIONS
!!--..
!!----    DIRECTORY_EXISTS
!!----
!!---- SUBROUTINES
!!--..
!!----    WRITE_DATE_TIME
!!----
!!
Module CFML_GlobalDeps

   !---- Variables ----!
   implicit None

   public

   !------------------------------------!
   !---- Operating System variables ----!
   !------------------------------------!

   !!----
   !!---- OPS
   !!----   Integer variable 1: Windows, 2: Linux, 3: MacOs, ....
   !!----   This is a variable set by the user of the library for the case
   !!----   that there is no external library with a procedure for getting
   !!----   the operating system.
   !!----
   !!---- Update: March 2009
   !!
   integer, parameter :: OPS= 2    ! Linux

   !!----
   !!---- OPS_NAME
   !!----   Character variable containing the name of the operating system
   !!----   This is a variable set by the user of the library for the case
   !!----   that there is no external library with a procedure for getting
   !!----   the operating system.
   !!----
   !!---- Update: March 2009
   !!
   character(len=*), parameter :: OPS_NAME="Linux"

   !!----
   !!---- OPS_SEP
   !!----   ASCII code of directory separator character
   !!----   Here it is written explicitly as a character variable
   !!----
   !!---- Update: March 2009
   !!
   character(len=*), parameter :: OPS_SEP="/"

   !------------------------------!
   !---- Precision Parameters ----!
   !------------------------------!

   !!----
   !!---- SP
   !!----    SP: Single precision ( sp = selected_real_kind(6,30) )
   !!----
   !!---- Update: January - 2009
   !!
   integer, parameter :: sp = selected_real_kind(6,30)

   !!----
   !!---- DP
   !!----    DP: Double precision ( dp = selected_real_kind(14,150) )
   !!----
   !!---- Update: January - 2009
   !!
   integer, parameter :: dp = selected_real_kind(14,150)

   !!----
   !!---- CP
   !!----    CP: Current precision
   !!----
   !!---- Update: January - 2009
   !!
   integer, parameter :: cp = sp

   !----------------------------------!
   !---- Trigonometric Parameters ----!
   !----------------------------------!

   !!----
   !!---- PI
   !!----    real(kind=dp), parameter ::  pi = 3.141592653589793238463_dp
   !!----
   !!----    Pi value
   !!----
   !!---- Update: January - 2009
   !!
   real(kind=dp), parameter ::  pi = 3.141592653589793238463_dp

   !!----
   !!---- TO_DEG
   !!----    real(kind=dp), parameter ::  to_DEG = 180.0_dp/pi
   !!----
   !!----    Conversion from Radians to Degrees
   !!----
   !!---- Update: January - 2009
   !!
   real(kind=dp), parameter ::  to_DEG  = 180.0_dp/pi

   !!----
   !!---- TO_RAD
   !!----    real(kind=dp), parameter ::  to_RAD  = pi/180.0_dp
   !!----
   !!----    Conversion from Degrees to Radians
   !!----
   !!---- Update: January - 2009
   !!
   real(kind=dp), parameter ::  to_RAD  = pi/180.0_dp

   !!----
   !!---- TPI
   !!----  real(kind=dp), parameter ::  tpi = 6.283185307179586476925_dp
   !!----
   !!----  2.0*Pi value
   !!----
   !!---- Update: January - 2009
   !!
   real(kind=dp), parameter ::  tpi = 6.283185307179586476925_dp

   !----------------------------!
   !---- Numeric Parameters ----!
   !----------------------------!

   !!----
   !!---- DEPS
   !!----    real(kind=dp), parameter :: deps=0.00000001_dp
   !!----
   !!----    Epsilon value use for comparison of real numbers
   !!----
   !!---- Update: January - 2009
   !!
   real(kind=dp), parameter, public :: deps=0.00000001_dp

   !!----
   !!----  EPS
   !!----     real(kind=cp), public ::  eps=0.00001_cp
   !!----
   !!----     Epsilon value use for comparison of real numbers
   !!----
   !!----  Update: January - 2009
   !!
   real(kind=cp),  parameter, public  ::  eps=0.00001_cp

 Contains

   !-------------------!
   !---- Functions ----!
   !-------------------!

   !!----
   !!---- Function Directory_Exists(Dirname) Result(info)
   !!----    character(len=*), intent(in) :: Dirname
   !!----    logical                      :: info
   !!----
   !!---- Generic function dependent of the compiler that return
   !!---- a logical value if a directory exists or not.
   !!----
   !!---- Update: April - 2009
   !!
   Function Directory_Exists(Dirname) Result(info)
      !---- Argument ----!
      character(len=*), intent(in) :: Dirname
      logical                      :: info

      !---- Local Variables ----!
      character(len=512) :: linea
      integer            :: nlong

      ! Init value
      info=.false.

      linea=trim(dirname)
      nlong=len_trim(linea)
      if (nlong ==0) return

      if (linea(nlong:nlong) /= ops_sep) linea=trim(linea)//ops_sep

      ! All compilers except Intel
      inquire(file=trim(linea)//'.' , exist=info)

      ! Intel
      !inquire(directory=trim(linea), exist=info)

      return
   End Function Directory_Exists

   !---------------------!
   !---- Subroutines ----!
   !---------------------!

   !!----
   !!---- Subroutine Write_Date_Time(lun,dtim)
   !!----  integer,         optional,intent(in) :: lun
   !!----  character(len=*),optional,intent(out):: dtim
   !!----
   !!---- Generic subroutine for writing the date and time
   !!---- in form   Date: Day/Month/Year  Time: hour:minute:second
   !!---- to a file with logical unit = lun. The output argument
   !!---- can be provided to get a string with the same information
   !!----
   !!---- Updated: January - 2014
   !!
   Subroutine Write_Date_Time(lun,dtim)
     integer,         optional,intent(in) :: lun
     character(len=*),optional,intent(out):: dtim
     !--- Local variables ----!
     character (len=10) :: dat
     character (len=10) :: tim
     call date_and_time(date=dat,time=tim)
     if(present(lun)) &
     write(unit=lun,fmt="(/,4a)") &
       " => Date: ",dat(7:8)//"/"//dat(5:6)//"/"//dat(1:4),      &
         "  Time: ",tim(1:2)//":"//tim(3:4)//":"//tim(5:10)
     if(present(dtim)) &
      dtim="#   Date: "//dat(7:8)//"/"//dat(5:6)//"/"//dat(1:4)//      &
            "  Time: "//tim(1:2)//":"//tim(3:4)//":"//tim(5:10)
     return
   End Subroutine Write_Date_Time

End Module CFML_GlobalDeps
!!-------------------------------------------------------
!!---- Crystallographic Fortran Modules Library (CrysFML)
!!-------------------------------------------------------
!!---- The CrysFML project is distributed under LGPL. In agreement with the
!!---- Intergovernmental Convention of the ILL, this software cannot be used
!!---- in military applications.
!!----
!!---- Copyright (C) 1999-2012  Institut Laue-Langevin (ILL), Grenoble, FRANCE
!!----                          Universidad de La Laguna (ULL), Tenerife, SPAIN
!!----                          Laboratoire Leon Brillouin(LLB), Saclay, FRANCE
!!----
!!---- Authors: Juan Rodriguez-Carvajal (ILL)
!!----          Javier Gonzalez-Platas  (ULL)
!!----
!!---- Contributors: Laurent Chapon     (ILL)
!!----               Marc Janoschek     (Los Alamos National Laboratory, USA)
!!----               Oksana Zaharko     (Paul Scherrer Institute, Switzerland)
!!----               Tierry Roisnel     (CDIFX,Rennes France)
!!----               Eric Pellegrini    (ILL)
!!----
!!---- This library is free software; you can redistribute it and/or
!!---- modify it under the terms of the GNU Lesser General Public
!!---- License as published by the Free Software Foundation; either
!!---- version 3.0 of the License, or (at your option) any later version.
!!----
!!---- This library is distributed in the hope that it will be useful,
!!---- but WITHOUT ANY WARRANTY; without even the implied warranty of
!!---- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
!!---- Lesser General Public License for more details.
!!----
!!---- You should have received a copy of the GNU Lesser General Public
!!---- License along with this library; if not, see <http://www.gnu.org/licenses/>.
!!----
!!----
!!---- MODULE: CFML_Math_General
!!----   INFO: Mathematic general utilities for use in Crystallography and
!!----         Solid State Physics and Chemistry.
!!----
!!---- HISTORY
!!----    Updated: 02/03/2011
!!----
!!---- DEPENDENCIES
!!----
!!----    CFML_GlobalDeps
!!----
!!---- VARIABLES
!!--++    EPSS                         [Private]
!!--++    EP_SS                        [Private]
!!----    ERR_MathGen
!!----    ERR_MathGen_Mess
!!----
!!---- PROCEDURES
!!----    Functions:
!!--..
!!--..    Trigonometric Functions
!!----       ACOSD
!!--++       ACOSD_dp                  [Overloaded]
!!--++       ACOSD_sp                  [Overloaded]
!!----       ASIND
!!--++       ASIND_dp                  [Overloaded]
!!--++       ASIND_sp                  [Overloaded]
!!----       ATAN2D
!!--++       ATAN2D_dp                 [Overloaded]
!!--++       ATAN2D_sp                 [Overloaded]
!!----       ATAND
!!--++       ATAND_dp                  [Overloaded]
!!--++       ATAND_sp                  [Overloaded]
!!----       COSD
!!--++       COSD_dp                   [Overloaded]
!!--++       COSD_sp                   [Overloaded]
!!----       SIND
!!--++       SIND_dp                   [Overloaded]
!!--++       SIND_sp                   [Overloaded]
!!----       TAND
!!--++       TAND_dp                   [Overloaded]
!!--++       TAND_sp                   [Overloaded]
!!--..
!!--..    Special Functions
!!----       BESSJ0
!!----       BESSJ1
!!----       BESSJ
!!--..
!!--..    Scalar Functions
!!----       FACTORIAL
!!----       NEGLIGIBLE
!!--++       NEGLIGIBLEC               [Overloaded]
!!--++       NEGLIGIBLER               [Overloaded]
!!----       PGCD
!!----       PPCM
!!----       PYTHAG
!!--++       PYTHAG_dp                 [Overloaded]
!!--++       PYTHAG_sp                 [Overloaded]
!!--..
!!--..    Arrays and Vectors Functions
!!----       CO_LINEAR
!!--++       CO_LINEAR_C               [Overloaded]
!!--++       CO_LINEAR_I               [Overloaded]
!!--++       CO_LINEAR_R               [Overloaded]
!!----       CO_PRIME
!!----       EQUAL_MATRIX
!!--++       EQUAL_MATRIX_I            [Overloaded]
!!--++       EQUAL_MATRIX_R            [Overloaded]
!!----       EQUAL_VECTOR
!!--++       EQUAL_VECTOR_I            [Overloaded]
!!--++       EQUAL_VECTOR_R            [Overloaded]
!!----       EUCLIDEAN_NORM
!!----       IMAXLOC
!!--++       IMAXLOC_I                 [Overloaded]
!!--++       IMAXLOC_R                 [OVerloaded]
!!----       IMINLOC
!!--++       IMINLOC_I                 [Overloaded]
!!--++       IMINLOC_R                 [OVerloaded]
!!----       LOCATE
!!--++       LOCATE_I                  [Overloaded]
!!--++       LOCATE_IB                 [Overloaded]
!!--++       LOCATE_R                  [Overloaded]
!!--++       LOCATE_RB                 [Overloaded]
!!----       LOWER_TRIANGULAR
!!--++       LOWER_TRIANGULAR_I        [Overloaded]
!!--++       LOWER_TRIANGULAR_R        [Overloaded]
!!----       MODULO_LAT
!!----       NORM
!!--++       NORM_I                    [Overloaded]
!!--++       NORM_R                    [Overloaded]
!!----       OUTERPROD
!!--++       OUTERPROD_dp              [Overloaded]
!!--++       OUTERPROD_sp              [Overloaded]
!!----       SCALAR
!!--++       SCALAR_I                  [Overloaded]
!!--++       SCALAR_R                  [Overloaded]
!!----       TRACE
!!--++       TRACE_C                   [Overloaded]
!!--++       TRACE_I                   [Overloaded]
!!--++       TRACE_R                   [Overloaded]
!!----       UPPER_TRIANGULAR
!!--++       UPPER_TRIANGULAR_I        [Overloaded]
!!--++       UPPER_TRIANGULAR_R        [Overloaded]
!!----       ZBELONG
!!--++       ZBELONGM                  [Overloaded]
!!--++       ZBELONGN                  [Overloaded]
!!--++       ZBELONGV                  [Overloaded]
!!--..
!!----
!!----    Subroutines:
!!--..
!!--..    Init Routine
!!----       INIT_ERR_MATHGEN
!!----       SET_EPSG
!!----       SET_EPSG_DEFAULT
!!--..
!!--..    Trigonometric Subroutines
!!----       RTAN
!!--++       RTAN_dp                   [Overloaded]
!!--++       RTAN_sp                   [Overloaded]
!!--..
!!--..    Arrays and Vectors Functions
!!----       CO_PRIME_VECTOR
!!----       DETERMINANT
!!--++       DETERMINANT_C             [Overloaded]
!!--++       DETERMINANT_R             [Overloaded]
!!----       DIAGONALIZE_SH
!!--++       DIAGONALIZE_HERM          [Overloaded]
!!--++       DIAGONALIZE_SYMM          [Overloaded]
!!--++       EIGSRT                    [Private]
!!----       FIRST_DERIVATIVE
!!----       IN_SORT
!!----       INVERT_MATRIX
!!----       LINEAR_DEPENDENT
!!--++       LINEAR_DEPENDENTC         [Overloaded]
!!--++       LINEAR_DEPENDENTI         [Overloaded]
!!--++       LINEAR_DEPENDENTR         [Overloaded]
!!----       LU_BACKSUB
!!----       LU_DECOMP
!!----       MATINV
!!--++       PARTITION                 [Private]
!!----       POINTS_IN_LINE2D
!!----       RANK
!!--++       RANK_dp                   [Overloaded]
!!--++       RANK_sp                   [Overloaded]
!!----       SECOND_DERIVATIVE
!!----       SMOOTHINGVEC
!!----       SORT
!!--++       SORT_I                    [Overloaded]
!!--++       SORT_R                    [Overloaded]
!!----       SORT_STRINGS
!!----       SPLINE
!!----       SPLINT
!!----       SVDCMP
!!--++       SVDCMP_dp                 [Overloaded]
!!--++       SVDCMP_sp                 [Overloaded]
!!----       SWAP
!!--++       SWAP_C                    [Overloaded]
!!--++       SWAP_CM                   [Overloaded]
!!--++       SWAP_CV                   [Overloaded]
!!--++       SWAP_I                    [Overloaded]
!!--++       SWAP_IM                   [Overloaded]
!!--++       SWAP_IV                   [Overloaded]
!!--++       SWAP_R                    [Overloaded]
!!--++       SWAP_RM                   [Overloaded]
!!--++       SWAP_RV                   [Overloaded]
!!--++       MASKED_SWAP_R             [Overloaded]
!!--++       MASKED_SWAP_RM            [Overloaded]
!!--++       MASKED_SWAP_RV            [Overloaded]
!!--++       TQLI1                     [Private]
!!--++       TQLI2                     [Private]
!!--++       TRED1                     [Private]
!!--++       TRED2                     [Private]
!!--++
!!
 Module CFML_Math_General
    !---- Use Modules ----!
    Use CFML_GlobalDeps

    !---- Variables ----!
    implicit none

    private

    !---- List of public functions ----!
    public :: Bessj0, Bessj1, Bessj, Factorial, Pgcd, Ppcm, Modulo_Lat, Co_Prime, &
              Euclidean_Norm,Erf

    !---- List of public overloaded procedures: functions ----!
    public :: Acosd, Asind, Atan2d, Atand, Cosd, Sind, Tand, Negligible, Pythag,   &
              Co_Linear, Equal_Matrix, Equal_Vector, Locate, Outerprod, Trace,     &
              Zbelong, Imaxloc, Iminloc, Norm, Scalar, In_limits, Lower_Triangular,&
              Upper_Triangular

    !---- List of private functions ----!
    private :: Acosd_dp, Acosd_sp, Asind_dp, Asind_sp, Atan2d_dp, Atan2d_sp,       &
               Atand_dp, Atand_sp, Cosd_dp, Cosd_sp, Sind_dp, Sind_sp, Tand_dp,    &
               Tand_sp, Negligiblec, Negligibler, Pythag_dp, Pythag_sp,            &
               Co_linear_C, Co_linear_I, Co_linear_R, Equal_Matrix_I,              &
               Equal_Matrix_R, Equal_Vector_I, Equal_Vector_R, Locate_I, Locate_R, &
               Outerprod_dp, Outerprod_sp, Trace_C, Trace_I, Trace_R, ZbelongM,    &
               ZbelongN, ZbelongV, Imaxloc_I, Imaxloc_R, Iminloc_R, Iminloc_I,     &
               Norm_I, Norm_R, Scalar_I, Scalar_R, Locate_Ib, Locate_Rb,           &
               In_limits_dp, In_limits_sp, In_Limits_int, Lower_Triangular_I,      &
               Lower_Triangular_R, Upper_Triangular_I, Upper_Triangular_R

    !---- List of public subroutines ----!
    public ::  Init_Err_Mathgen, Invert_Matrix, LU_Decomp, LU_Backsub, Matinv,        &
               Sort_Strings, Spline, Splint, Set_Epsg, Set_Epsg_Default,In_Sort,      &
               First_Derivative, Second_Derivative, SmoothingVec, Points_in_Line2D,   &
               Co_Prime_vector

    !---- List of public overloaded procedures: subroutines ----!
    public ::  RTan, Determinant, Diagonalize_Sh, Linear_Dependent, Rank, Sort,   &
               Svdcmp, Swap

    !---- List of private subroutines ----!
    private :: RTan_dp, RTan_sp, Determinant_C,Determinant_R, Diagonalize_Herm,   &
               Diagonalize_Symm, Eigsrt, Linear_DependentC, Linear_DependentI,    &
               Linear_DependentR, Rank_dp, Rank_sp, Sort_I, Sort_R, Svdcmp_dp,    &
               Svdcmp_sp, Swap_C, Swap_Cm, Swap_Cv, Swap_I, Swap_Im, Swap_Iv,     &
               Swap_R, Swap_Rm, Swap_Rv, Masked_Swap_R, Masked_Swap_Rm,           &
               Masked_Swap_Rv, Tqli1, Tqli2, Tred1, Tred2, Partition


    !---- Definitions ----!

    !!--++
    !!--++ EPSS
    !!--++    real(kind=cp)  :: epss=1.0E-5_cp
    !!--++
    !!--++    Internal epsilon value used for comparing reals to integers
    !!--++    in crystallographic applications where the maximum precision in the
    !!--++    measured values is of the order of 10^-5.
    !!--++
    !!--++ Update: April - 2005
    !!
    real(kind=cp),   private :: epss=1.0E-5_cp

    !!--++
    !!--++ EP_SS
    !!--++    real(kind=cp), parameter, private  :: ep_ss=1.0E-12_cp
    !!--++
    !!--++    Internal epsilon value used for comparison in matrix operations
    !!--++
    !!--++ Update: February - 2005
    !!
    real(kind=cp), parameter, private :: ep_ss=1.0E-12_cp

    !!----
    !!---- ERR_MathGen
    !!----    logical :: ERR_MathGen
    !!----
    !!----    Logical Variable indicating an error in CFML_Math_General module
    !!----
    !!---- Update: February - 2005
    !!
    logical, public :: ERR_MathGen

    !!----
    !!---- ERR_MathGen_Mess
    !!----    character(len=150) :: ERR_MathGen_Mess
    !!----
    !!----    String containing information about the last error
    !!----
    !!---- Update: February - 2005
    !!
    character(len=150), public:: ERR_MathGen_Mess

    !!----
    !!---- Primes
    !!----    integer, parameter, dimension(1000), public :: primes
    !!----
    !!----    List of the first 1000 prime numbers.
    !!----    Used by the subroutine Co_Prime_Vector and function Co_Prime
    !!----
    !!----  Created: January - 2011
    !!
    integer, parameter, dimension(1000), public :: primes =                                       &
           (/ 2,      3,      5,      7,     11,     13,     17,     19,     23,     29,  &
             31,     37,     41,     43,     47,     53,     59,     61,     67,     71,  &
             73,     79,     83,     89,     97,    101,    103,    107,    109,    113,  &
            127,    131,    137,    139,    149,    151,    157,    163,    167,    173,  &
            179,    181,    191,    193,    197,    199,    211,    223,    227,    229,  &
            233,    239,    241,    251,    257,    263,    269,    271,    277,    281,  &
            283,    293,    307,    311,    313,    317,    331,    337,    347,    349,  &
            353,    359,    367,    373,    379,    383,    389,    397,    401,    409,  &
            419,    421,    431,    433,    439,    443,    449,    457,    461,    463,  &
            467,    479,    487,    491,    499,    503,    509,    521,    523,    541,  &
            547,    557,    563,    569,    571,    577,    587,    593,    599,    601,  &
            607,    613,    617,    619,    631,    641,    643,    647,    653,    659,  &
            661,    673,    677,    683,    691,    701,    709,    719,    727,    733,  &
            739,    743,    751,    757,    761,    769,    773,    787,    797,    809,  &
            811,    821,    823,    827,    829,    839,    853,    857,    859,    863,  &
            877,    881,    883,    887,    907,    911,    919,    929,    937,    941,  &
            947,    953,    967,    971,    977,    983,    991,    997,   1009,   1013,  &
           1019,   1021,   1031,   1033,   1039,   1049,   1051,   1061,   1063,   1069,  &
           1087,   1091,   1093,   1097,   1103,   1109,   1117,   1123,   1129,   1151,  &
           1153,   1163,   1171,   1181,   1187,   1193,   1201,   1213,   1217,   1223,  &
           1229,   1231,   1237,   1249,   1259,   1277,   1279,   1283,   1289,   1291,  &
           1297,   1301,   1303,   1307,   1319,   1321,   1327,   1361,   1367,   1373,  &
           1381,   1399,   1409,   1423,   1427,   1429,   1433,   1439,   1447,   1451,  &
           1453,   1459,   1471,   1481,   1483,   1487,   1489,   1493,   1499,   1511,  &
           1523,   1531,   1543,   1549,   1553,   1559,   1567,   1571,   1579,   1583,  &
           1597,   1601,   1607,   1609,   1613,   1619,   1621,   1627,   1637,   1657,  &
           1663,   1667,   1669,   1693,   1697,   1699,   1709,   1721,   1723,   1733,  &
           1741,   1747,   1753,   1759,   1777,   1783,   1787,   1789,   1801,   1811,  &
           1823,   1831,   1847,   1861,   1867,   1871,   1873,   1877,   1879,   1889,  &
           1901,   1907,   1913,   1931,   1933,   1949,   1951,   1973,   1979,   1987,  &
           1993,   1997,   1999,   2003,   2011,   2017,   2027,   2029,   2039,   2053,  &
           2063,   2069,   2081,   2083,   2087,   2089,   2099,   2111,   2113,   2129,  &
           2131,   2137,   2141,   2143,   2153,   2161,   2179,   2203,   2207,   2213,  &
           2221,   2237,   2239,   2243,   2251,   2267,   2269,   2273,   2281,   2287,  &
           2293,   2297,   2309,   2311,   2333,   2339,   2341,   2347,   2351,   2357,  &
           2371,   2377,   2381,   2383,   2389,   2393,   2399,   2411,   2417,   2423,  &
           2437,   2441,   2447,   2459,   2467,   2473,   2477,   2503,   2521,   2531,  &
           2539,   2543,   2549,   2551,   2557,   2579,   2591,   2593,   2609,   2617,  &
           2621,   2633,   2647,   2657,   2659,   2663,   2671,   2677,   2683,   2687,  &
           2689,   2693,   2699,   2707,   2711,   2713,   2719,   2729,   2731,   2741,  &
           2749,   2753,   2767,   2777,   2789,   2791,   2797,   2801,   2803,   2819,  &
           2833,   2837,   2843,   2851,   2857,   2861,   2879,   2887,   2897,   2903,  &
           2909,   2917,   2927,   2939,   2953,   2957,   2963,   2969,   2971,   2999,  &
           3001,   3011,   3019,   3023,   3037,   3041,   3049,   3061,   3067,   3079,  &
           3083,   3089,   3109,   3119,   3121,   3137,   3163,   3167,   3169,   3181,  &
           3187,   3191,   3203,   3209,   3217,   3221,   3229,   3251,   3253,   3257,  &
           3259,   3271,   3299,   3301,   3307,   3313,   3319,   3323,   3329,   3331,  &
           3343,   3347,   3359,   3361,   3371,   3373,   3389,   3391,   3407,   3413,  &
           3433,   3449,   3457,   3461,   3463,   3467,   3469,   3491,   3499,   3511,  &
           3517,   3527,   3529,   3533,   3539,   3541,   3547,   3557,   3559,   3571,  &
           3581,   3583,   3593,   3607,   3613,   3617,   3623,   3631,   3637,   3643,  &
           3659,   3671,   3673,   3677,   3691,   3697,   3701,   3709,   3719,   3727,  &
           3733,   3739,   3761,   3767,   3769,   3779,   3793,   3797,   3803,   3821,  &
           3823,   3833,   3847,   3851,   3853,   3863,   3877,   3881,   3889,   3907,  &
           3911,   3917,   3919,   3923,   3929,   3931,   3943,   3947,   3967,   3989,  &
           4001,   4003,   4007,   4013,   4019,   4021,   4027,   4049,   4051,   4057,  &
           4073,   4079,   4091,   4093,   4099,   4111,   4127,   4129,   4133,   4139,  &
           4153,   4157,   4159,   4177,   4201,   4211,   4217,   4219,   4229,   4231,  &
           4241,   4243,   4253,   4259,   4261,   4271,   4273,   4283,   4289,   4297,  &
           4327,   4337,   4339,   4349,   4357,   4363,   4373,   4391,   4397,   4409,  &
           4421,   4423,   4441,   4447,   4451,   4457,   4463,   4481,   4483,   4493,  &
           4507,   4513,   4517,   4519,   4523,   4547,   4549,   4561,   4567,   4583,  &
           4591,   4597,   4603,   4621,   4637,   4639,   4643,   4649,   4651,   4657,  &
           4663,   4673,   4679,   4691,   4703,   4721,   4723,   4729,   4733,   4751,  &
           4759,   4783,   4787,   4789,   4793,   4799,   4801,   4813,   4817,   4831,  &
           4861,   4871,   4877,   4889,   4903,   4909,   4919,   4931,   4933,   4937,  &
           4943,   4951,   4957,   4967,   4969,   4973,   4987,   4993,   4999,   5003,  &
           5009,   5011,   5021,   5023,   5039,   5051,   5059,   5077,   5081,   5087,  &
           5099,   5101,   5107,   5113,   5119,   5147,   5153,   5167,   5171,   5179,  &
           5189,   5197,   5209,   5227,   5231,   5233,   5237,   5261,   5273,   5279,  &
           5281,   5297,   5303,   5309,   5323,   5333,   5347,   5351,   5381,   5387,  &
           5393,   5399,   5407,   5413,   5417,   5419,   5431,   5437,   5441,   5443,  &
           5449,   5471,   5477,   5479,   5483,   5501,   5503,   5507,   5519,   5521,  &
           5527,   5531,   5557,   5563,   5569,   5573,   5581,   5591,   5623,   5639,  &
           5641,   5647,   5651,   5653,   5657,   5659,   5669,   5683,   5689,   5693,  &
           5701,   5711,   5717,   5737,   5741,   5743,   5749,   5779,   5783,   5791,  &
           5801,   5807,   5813,   5821,   5827,   5839,   5843,   5849,   5851,   5857,  &
           5861,   5867,   5869,   5879,   5881,   5897,   5903,   5923,   5927,   5939,  &
           5953,   5981,   5987,   6007,   6011,   6029,   6037,   6043,   6047,   6053,  &
           6067,   6073,   6079,   6089,   6091,   6101,   6113,   6121,   6131,   6133,  &
           6143,   6151,   6163,   6173,   6197,   6199,   6203,   6211,   6217,   6221,  &
           6229,   6247,   6257,   6263,   6269,   6271,   6277,   6287,   6299,   6301,  &
           6311,   6317,   6323,   6329,   6337,   6343,   6353,   6359,   6361,   6367,  &
           6373,   6379,   6389,   6397,   6421,   6427,   6449,   6451,   6469,   6473,  &
           6481,   6491,   6521,   6529,   6547,   6551,   6553,   6563,   6569,   6571,  &
           6577,   6581,   6599,   6607,   6619,   6637,   6653,   6659,   6661,   6673,  &
           6679,   6689,   6691,   6701,   6703,   6709,   6719,   6733,   6737,   6761,  &
           6763,   6779,   6781,   6791,   6793,   6803,   6823,   6827,   6829,   6833,  &
           6841,   6857,   6863,   6869,   6871,   6883,   6899,   6907,   6911,   6917,  &
           6947,   6949,   6959,   6961,   6967,   6971,   6977,   6983,   6991,   6997,  &
           7001,   7013,   7019,   7027,   7039,   7043,   7057,   7069,   7079,   7103,  &
           7109,   7121,   7127,   7129,   7151,   7159,   7177,   7187,   7193,   7207,  &
           7211,   7213,   7219,   7229,   7237,   7243,   7247,   7253,   7283,   7297,  &
           7307,   7309,   7321,   7331,   7333,   7349,   7351,   7369,   7393,   7411,  &
           7417,   7433,   7451,   7457,   7459,   7477,   7481,   7487,   7489,   7499,  &
           7507,   7517,   7523,   7529,   7537,   7541,   7547,   7549,   7559,   7561,  &
           7573,   7577,   7583,   7589,   7591,   7603,   7607,   7621,   7639,   7643,  &
           7649,   7669,   7673,   7681,   7687,   7691,   7699,   7703,   7717,   7723,  &
           7727,   7741,   7753,   7757,   7759,   7789,   7793,   7817,   7823,   7829,  &
           7841,   7853,   7867,   7873,   7877,   7879,   7883,   7901,   7907,   7919 /)

    !---- Interfaces - Overloaded ----!
    Interface  Acosd
       Module Procedure Acosd_dp
       Module Procedure Acosd_sp
    End Interface

    Interface  Asind
       Module Procedure Asind_dp
       Module Procedure Asind_sp
    End Interface

    Interface  Atan2d
       Module Procedure Atan2d_dp
       Module Procedure Atan2d_sp
    End Interface

    Interface  Atand
       Module Procedure Atand_dp
       Module Procedure Atand_sp
    End Interface

    Interface  Cosd
       Module Procedure Cosd_dp
       Module Procedure Cosd_sp
    End Interface

    Interface  Sind
       Module Procedure Sind_dp
       Module Procedure Sind_sp
    End Interface

    Interface  Tand
       Module Procedure Tand_dp
       Module Procedure Tand_sp
    End Interface

    Interface  Negligible
       Module Procedure Negligibler
       Module Procedure Negligiblec
    End Interface

    Interface  Pythag
       Module Procedure Pythag_dp
       Module Procedure Pythag_sp
    End Interface

    Interface  Co_Linear
       Module Procedure Co_linear_C
       Module Procedure Co_linear_I
       Module Procedure Co_linear_R
    End Interface

    Interface  Equal_Matrix
       Module Procedure Equal_Matrix_I
       Module Procedure Equal_Matrix_R
    End Interface

    Interface  Equal_Vector
       Module Procedure Equal_Vector_I
       Module Procedure Equal_Vector_R
    End Interface

    Interface  IMaxloc
       Module Procedure IMaxloc_I
       Module Procedure IMaxloc_R
    End Interface

    Interface  IMinloc
       Module Procedure IMinloc_I
       Module Procedure IMinloc_R
    End Interface

    Interface  Locate
       Module Procedure Locate_I
       Module Procedure Locate_R
       Module Procedure Locate_Ib
       Module Procedure Locate_Rb
    End Interface

    Interface  Lower_Triangular
       Module Procedure Lower_Triangular_I
       Module Procedure Lower_Triangular_R
    End Interface

    Interface Norm
       Module Procedure Norm_I
       Module Procedure Norm_R
    End Interface Norm

    Interface  Outerprod
       Module Procedure Outerprod_dp
       Module Procedure Outerprod_sp
    End Interface

    Interface Scalar
       Module Procedure Scalar_I
       Module Procedure Scalar_R
    End Interface Scalar

    Interface  Trace
       Module Procedure Trace_C
       Module Procedure Trace_I
       Module Procedure Trace_R
    End Interface

    Interface  Upper_Triangular
       Module Procedure Upper_Triangular_I
       Module Procedure Upper_Triangular_R
    End Interface

    Interface  Zbelong
       Module Procedure ZbelongM
       Module Procedure ZbelongN
       Module Procedure ZbelongV
    End Interface

    Interface  Rtan
       Module Procedure Rtan_dp
       Module Procedure Rtan_sp
    End Interface

    Interface  Determinant
       Module Procedure Determinant_c
       Module Procedure Determinant_r
    End Interface

    Interface  Diagonalize_SH
       Module Procedure Diagonalize_HERM
       Module Procedure Diagonalize_SYMM
    End Interface

    Interface In_Limits
       Module Procedure In_Limits_int
       Module Procedure In_Limits_dp
       Module Procedure In_Limits_sp
    End Interface

    Interface  Linear_Dependent
       Module Procedure Linear_Dependentc
       Module Procedure Linear_Dependenti
       Module Procedure Linear_Dependentr
    End Interface

    Interface  Rank
       Module Procedure Rank_dp
       Module Procedure Rank_sp
    End Interface

    Interface  Sort
       Module Procedure Sort_I
       Module Procedure Sort_R
    End Interface

    Interface  Svdcmp
       Module Procedure Svdcmp_dp
       Module Procedure Svdcmp_sp
    End Interface

    Interface Swap
        Module Procedure swap_c
        Module Procedure swap_cm
        Module Procedure swap_cv
        Module Procedure swap_i
        Module Procedure swap_im
        Module Procedure swap_iv
        Module Procedure swap_r
        Module Procedure swap_rm
        Module Procedure swap_rv
        Module Procedure masked_swap_r
        Module Procedure masked_swap_rm
        Module Procedure masked_swap_rv
    End interface

 Contains

    !---- Functions ----!

    !!----
    !!---- Elemental Function Acosd(x) Result(arc_cos)
    !!----    real(kind=sp/dp), intent(in) :: x
    !!----    real(kind=sp/dp)             :: arc_cos
    !!----
    !!----    Inverse cosine function -> output in Degrees
    !!----
    !!---- Update: February - 2005
    !!

    !!--++
    !!--++ Elemental Function Acosd_dp(x) Result(arc_cos)
    !!--++    real(kind=dp), intent(in) :: x
    !!--++    real(kind=dp)             :: arc_cos
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Inverse cosine function -> output in Degrees
    !!--++
    !!--++ Update: February - 2005
    !!
    Elemental Function Acosd_dp(x) Result(arc_cos)
       !---- Argument ----!
       real(kind=dp), intent(in) :: x
       real(kind=dp)             :: arc_cos

       if (abs(x) > 1.0_dp ) then
          if (x > 0.0_dp)  then
             arc_cos=0.0_dp
          else
             arc_cos=180.0_dp
          end if
       else
          arc_cos=acos(x)*to_DEG
       end if

       return
    End Function Acosd_dp

    !!--++
    !!--++ Elemental Function Acosd_sp(x) Result(arc_cos)
    !!--++    real(kind=sp), intent(in) :: x
    !!--++    real(kind=sp)             :: arc_cos
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Inverse cosine function -> output in Degrees
    !!--++
    !!--++ Update: February - 2005
    !!
    Elemental Function Acosd_sp(x) Result(arc_cos)
       !---- Argument ----!
       real(kind=sp), intent(in) :: x
       real(kind=sp)             :: arc_cos

       if (abs(x) > 1.0_sp ) then
          if (x > 0.0_sp)  then
             arc_cos=0.0_sp
          else
             arc_cos=180.0_sp
          end if
       else
          arc_cos=acos(x)*to_DEG
       end if

       return
    End Function Acosd_sp

    !!----
    !!---- Function Asind(x) Result(arc_sin)
    !!----    real(kind=sp/dp), intent(in) :: x
    !!----    real(kind=sp/dp)             :: arc_sin
    !!----
    !!----    Inverse sine function -> output in Degrees
    !!----
    !!---- Update: February - 2005
    !!

    !!--++
    !!--++ Elemental Function Asind_dp(x) result(arc_sin)
    !!--++    real(kind=dp), intent(in) :: x
    !!--++    real(kind=dp)             :: arc_sin
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Inverse sine function -> output in Degrees
    !!--++
    !!--++ Update: February - 2005
    !!
    Elemental Function Asind_dp(x) Result(arc_sin)
       !---- Argument ----!
       real(kind=dp), intent(in) :: x
       real(kind=dp)             :: arc_sin

       if (abs(x) > 1.0_dp ) then
          if (x > 0.0_dp) then
             arc_sin=90.0_dp
          else
             arc_sin=-90.0_dp
          end if
       else
          arc_sin=asin(x)*to_DEG
       end if

       return
    End Function Asind_dp

    !!--++
    !!--++ Elemental Function Asind_sp(x) result(arc_sin)
    !!--++    real(kind=sp), intent(in) :: x
    !!--++    real(kind=sp)             :: arc_sin
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Inverse sine function -> output in Degrees
    !!--++
    !!--++ Update: February - 2005
    !!
    Elemental Function Asind_sp(x) Result(arc_sin)
       !---- Argument ----!
       real(kind=sp), intent(in) :: x
       real(kind=sp)             :: arc_sin

       if (abs(x) > 1.0_sp ) then
          if (x > 0.0_sp) then
             arc_sin=90.0_sp
          else
             arc_sin=-90.0_sp
          end if
       else
          arc_sin=asin(x)*to_DEG
       end if

       return
    End Function Asind_sp

    !!----
    !!---- Elemental Function Atan2d(y,x) Result(atande)
    !!----    real(kind=sp/dp), intent(in) :: y,x
    !!----    real(kind=sp/dp)             :: atande
    !!----
    !!----    Inverse tangent function of y/x
    !!----    y,x have the same units -> output in Degrees
    !!----
    !!---- Update: February - 2005
    !!

    !!--++
    !!--++ Elemental Function Atan2d_dp(y,x) Result(atande)
    !!--++    real(kind=dp), intent(in) :: y,x
    !!--++    real(kind=dp)             :: atande
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Inverse tangent function of y/x
    !!--++    y,x have the same units -> output in Degrees
    !!--++
    !!--++ Update: February - 2005
    !!
    Elemental Function Atan2d_dp(y,x) Result(atand)
       !---- Argument ----!
       real(kind=dp), intent(in) :: y,x
       real(kind=dp)             :: atand

       atand=atan2(y,x)*to_DEG

       return
    End Function Atan2d_dp

    !!--++
    !!--++ Elemental Function Atan2d_sp(y,x) Result(atande)
    !!--++    real(kind=sp), intent(in) :: y,x
    !!--++    real(kind=sp)             :: atande
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Inverse tangent function of y/x
    !!--++    y,x have the same units -> output in Degrees
    !!--++
    !!--++ Update: February - 2005
    !!
    Elemental Function Atan2d_sp(y,x) Result(atande)
       !---- Argument ----!
       real(kind=sp), intent(in) :: y,x
       real(kind=sp)             :: atande

       atande=atan2(y,x)*to_DEG

       return
    End Function Atan2d_sp

    !!----
    !!---- Elemental Function Atand(x) Result(atande)
    !!----    real(kind=sp/dp), intent(in) :: x
    !!----    real(kind=sp/dp)             :: atande
    !!----
    !!----    Inverse tangent function, X no units -> output in Degrees
    !!----
    !!---- Update: February - 2005
    !!

    !!--++
    !!--++ Elemental Function Atand_dp(x) result(atande)
    !!--++    real(kind=dp), intent(in) :: x
    !!--++    real(kind=dp)             :: atande
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Inverse tangent function, X no units -> output in Degrees
    !!--++
    !!--++ Update: February - 2005
    !!
    Elemental Function Atand_dp(x) Result(atand)
       !---- Argument ----!
       real(kind=dp), intent(in) :: x
       real(kind=dp)             :: atand

       atand=atan(x)*to_DEG

       return
    End Function Atand_dp

    !!--++
    !!--++ Function Atand_sp(x) result(atande)
    !!--++    real(kind=sp), intent(in) :: x
    !!--++    real(kind=sp)             :: atande
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Inverse tangent function, X no units -> output in Degrees
    !!--++
    !!--++ Update: February - 2005
    !!
    Elemental Function Atand_sp(x) Result(atande)
       !---- Argument ----!
       real(kind=sp), intent(in) :: x
       real(kind=sp)             :: atande

       atande=atan(x)*to_DEG

       return
    End Function Atand_sp



    !!----
    !!---- Elemental Function Cosd(x) Result(cosine)
    !!----    real(kind=sp/dp), intent(in) :: x
    !!----    real(kind=sp/dp)             :: cosine
    !!----
    !!----    Cosine function, X in degrees
    !!----
    !!---- Update: February - 2005
    !!

    !!--++
    !!--++ Elemental Function Cosd_dp(x) Result(cosine)
    !!--++    real(kind=dp), intent(in) :: x
    !!--++    real(kind=dp)             :: cosine
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Cosine function, X in degrees
    !!--++
    !!--++ Update: February - 2005
    !!
    Elemental Function Cosd_dp(x) Result(cosine)
       !---- Argument ----!
       real(kind=dp), intent(in) :: x
       real(kind=dp)             :: cosine

       cosine=cos(to_RAD*x)

       return
    End Function Cosd_dp

    !!--++
    !!--++ Elemental Function Cosd_sp(x) Result(cosine)
    !!--++    real(kind=sp), intent(in) :: x
    !!--++    real(kind=sp)             :: cosine
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Cosine function, X in degrees
    !!--++
    !!--++ Update: February - 2005
    !!
    Elemental Function Cosd_sp(x) Result(cosine)
       !---- Argument ----!
       real(kind=sp), intent(in) :: x
       real(kind=sp)             :: cosine

       cosine=cos(to_RAD*x)

       return
    End Function Cosd_sp

    !!----
    !!---- Elemental Function Sind(x) Result(sine)
    !!----    real(kind=sp/dp), intent(in) :: x
    !!----    real(kind=sp/dp)             :: sine
    !!----
    !!----    Sine function, X in degrees
    !!----
    !!---- Update: February - 2005
    !!

    !!--++
    !!--++ Elemental Function Sind_dp(x) Result(sine)
    !!--++    real(kind=dp), intent(in) :: x
    !!--++    real(kind=dp)             :: sine
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Sine function, X in degrees
    !!--++
    !!--++ Update: February - 2005
    !!
    Elemental Function Sind_dp(x) Result(sine)
       !---- Argument ----!
       real(kind=dp), intent(in) :: x
       real(kind=dp)             :: sine

       sine=sin(to_RAD*x)

       return
    End Function Sind_dp

    !!--++
    !!--++ Elemental Function Sind_sp(x) Result(sine)
    !!--++    real(kind=sp), intent(in) :: x
    !!--++    real(kind=sp)             :: sine
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Sine function, X in degrees
    !!--++
    !!--++ Update: February - 2005
    !!
    Elemental Function Sind_sp(x) Result(sine)
       !---- Argument ----!
       real(kind=sp), intent(in) :: x
       real(kind=sp)             :: sine

       sine=sin(to_RAD*x)

       return
    End Function Sind_sp

    !!----
    !!---- Elemental Function Tand(x) Result(tande)
    !!----    real(kind=sp/dp), intent(in) :: x
    !!----    real(kind=sp/dp)             :: tande
    !!----
    !!----    Tangent function, X in degrees
    !!----
    !!---- Update: February - 2005
    !!

    !!--++
    !!--++ Elemental Function Tand_dp(x) Result(tande)
    !!--++    real(kind=dp), intent(in) :: x
    !!--++    real(kind=dp)             :: tande
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Tangent function, X in degrees
    !!--++
    !!--++ Update: February - 2005
    !!
    Elemental Function Tand_dp(x) Result(tand)
       !---- Argument ----!
       real(kind=dp), intent(in) :: x
       real(kind=dp)             :: tand

       tand=tan(to_RAD*x)

       return
    End Function Tand_dp

    !!--++
    !!--++ Elemental Function Tand_sp(x) Result(tande)
    !!--++    real(kind=sp), intent(in) :: x
    !!--++    real(kind=sp)             :: tande
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Tangent function, X in degrees
    !!--++
    !!--++ Update: February - 2005
    !!
    Elemental Function Tand_sp(x) Result(tande)
       !---- Argument ----!
       real(kind=sp), intent(in) :: x
       real(kind=sp)             :: tande

       tande=tan(to_RAD*x)

       return
    End Function Tand_sp

    !!----
    !!---- Elemental Function BessJ0(x) Result(bessj_0)
    !!----    real(kind=sp), intent(in) :: x
    !!----    real(kind=sp)             :: bessj_0
    !!----
    !!----    Bessel Fuction J0(x)
    !!----
    !!---- Update: February - 2005
    !!
    Elemental Function BessJ0(x) Result(bessj_0)
       !---- Arguments ----!
       real(kind=cp), intent(in) :: x
       real(kind=cp)             :: bessj_0

       !---- Local variables ----!
       real(kind=dp), parameter :: p1=   1.0_dp
       real(kind=dp), parameter :: p2=  -0.1098628627e-2_dp
       real(kind=dp), parameter :: p3=   0.2734510407e-4_dp
       real(kind=dp), parameter :: p4=  -0.2073370639e-5_dp
       real(kind=dp), parameter :: p5=   0.2093887211e-6_dp
       real(kind=dp), parameter :: q1=  -0.1562499995e-1_dp
       real(kind=dp), parameter :: q2=   0.1430488765e-3_dp
       real(kind=dp), parameter :: q3=  -0.6911147651e-5_dp
       real(kind=dp), parameter :: q4=   0.7621095161e-6_dp
       real(kind=dp), parameter :: q5=  -0.934945152e-7_dp
       real(kind=dp), parameter :: r1=   57568490574.0_dp
       real(kind=dp), parameter :: r2=  -13362590354.0_dp ! corrected by LCC and ADA 16 june 2004
       real(kind=dp), parameter :: r3=     651619640.7_dp
       real(kind=dp), parameter :: r4=     -11214424.18_dp
       real(kind=dp), parameter :: r5=         77392.33017_dp
       real(kind=dp), parameter :: r6=          -184.9052456_dp
       real(kind=dp), parameter :: s1=   57568490411.0_dp
       real(kind=dp), parameter :: s2=    1029532985.0_dp
       real(kind=dp), parameter :: s3=       9494680.718_dp
       real(kind=dp), parameter :: s4=         59272.64853_dp
       real(kind=dp), parameter :: s5=           267.8532712_dp
       real(kind=dp), parameter :: s6=             1.0_dp

       real(kind=dp)            :: y
       real(kind=cp)            :: ax, xx, z

       if (abs(x) < 1.0e-05) then
          bessj_0=1.0
          return
       end if
       if (abs(x) < 8.0)then
          y=x**2
          bessj_0=(r1+y*(r2+y*(r3+y*(r4+y*(r5+y*r6)))))/(s1+y*(s2+y*(s3+y*  &
                  (s4+y*(s5+y*s6)))))
       else
          ax=abs(x)
          z=8.0/ax
          y=z**2
          xx=ax-0.785398164
          bessj_0=sqrt(0.636619772/ax)*(cos(xx)*(p1+y*(p2+y*(p3+y*(p4+y*  &
                  p5))))-z*sin(xx)*(q1+y*(q2+y*(q3+y*(q4+y*q5)))))
       end if

       return
    End Function BessJ0

    !!----
    !!---- Elemental Function BessJ1(x) Result(bessj_1)
    !!----    real(kind=sp), intent(in) : x
    !!----    real(kind=sp)             : bessj_1
    !!----
    !!----    Bessel Fuction J1(x)
    !!----
    !!---- Update: February - 2005
    !!
    Elemental Function BessJ1(x) Result(bessj_1)
       !---- Arguments ----!
       real(kind=cp), intent(in) :: x
       real(kind=cp)             :: bessj_1

       !---- Local variales ----!
       real(kind=dp), parameter :: p1= 1.0_dp
       real(kind=dp), parameter :: p2=  0.183105e-2_dp
       real(kind=dp), parameter :: p3= -0.3516396496e-4_dp
       real(kind=dp), parameter :: p4=  0.2457520174e-5_dp
       real(kind=dp), parameter :: p5= -0.240337019e-6_dp
       real(kind=dp), parameter :: q1=  0.04687499995_dp
       real(kind=dp), parameter :: q2= -0.2002690873e-3_dp
       real(kind=dp), parameter :: q3=  0.8449199096e-5_dp
       real(kind=dp), parameter :: q4= -0.88228987e-6_dp
       real(kind=dp), parameter :: q5=  0.105787412e-6_dp
       real(kind=dp), parameter :: r1=  72362614232.0_dp
       real(kind=dp), parameter :: r2=  -7895059235.0_dp
       real(kind=dp), parameter :: r3=    242396853.1_dp
       real(kind=dp), parameter :: r4=     -2972611.439_dp
       real(kind=dp), parameter :: r5=        15704.48260_dp
       real(kind=dp), parameter :: r6=          -30.16036606_dp
       real(kind=dp), parameter :: s1= 144725228442.0_dp
       real(kind=dp), parameter :: s2=   2300535178.0_dp
       real(kind=dp), parameter :: s3=     18583304.74_dp
       real(kind=dp), parameter :: s4=        99447.43394_dp
       real(kind=dp), parameter :: s5=          376.9991397_dp
       real(kind=dp), parameter :: s6=            1.0_dp

       real(kind=dp)            :: y
       real(kind=cp)            :: ax,xx,z

       if (abs(x) < 1.0e-05) then
          bessj_1=0.0
          return
       end if
       if (abs(x) < 8.0)then
          y=x**2
          bessj_1=x*(r1+y*(r2+y*(r3+y*(r4+y*(r5+y*r6)))))/(s1+y*(s2+y*(s3+  &
                  y*(s4+y*(s5+y*s6)))))
       else
          ax=abs(x)
          z=8.0/ax
          y=z**2
          xx=ax-2.356194491
          bessj_1=sqrt(0.636619772/ax)*(cos(xx)*(p1+y*(p2+y*(p3+y*(p4+y*p5))))  &
                       -z*sin(xx)*(q1+y*(q2+y*(q3+y*(q4+y*q5)))))*sign(1.0_cp,x)
       end if

       return
    End Function BessJ1

    !!----
    !!---- Function BessJ(n,x) Result (bessj)
    !!----    real(kind=cp), intent(in) : x
    !!----    real(kind=cp)             : bessj
    !!----
    !!----    Bessel Fuction Jn(x)
    !!----    Returns the Bessel function Jn(x) for any real x and n >= 2.
    !!----
    !!----  Update:  June - 2004
    !!
    Function BessJ(n,x) Result(bessj_n)
       !---- Arguments ----!
       integer,        intent(in)  :: n
       real (kind=cp), intent(in)  :: x
       real (kind=cp)              :: bessj_n

       !---- Local Arguments ----!
       integer,    parameter       :: iacc=40
       integer                     :: j,jsum,m
       real (kind=cp), parameter   :: bigno=1.e10,bigni=1.e-10
       real (kind=cp)              :: ax,bj,bjm,suma,tox
       real (kind=cp), save        :: bjp

       if (n==0) then
          bessj_n=Bessj0(x)
          return
       else if (n==1) then
          bessj_n=Bessj1(x)
          return
       end if

       ax=abs(x)
       if (ax==0.0)then
          bessj_n=0.0
          return

       else if (ax > float(n))then ! Upwards recurrence from J0 and J1.
          tox=2./ax
          bjm=bessj0(ax)
          bj=bessj1(ax)
          do j=1,n-1
             bjp=j*tox*bj-bjm
             bjm=bj
             bj=bjp
          end do
          bessj_n=bj
          return

       else ! Downwards recurrence from an even m here computed.
            !Make IACC larger to increase accuracy.
          tox=2./ax
          m=2*((n+int(sqrt(float(IACC*n))))/2)
          bessj_n=0.
          jsum=0       !jsum will alternate between 0 and 1; when it is 1, we
                       !accumulate in sum the even terms in (5.5.16).
          suma=0.
          bjp=0.
          bj=1.0
          do j=m,1,-1 ! The downward recurrence.
             bjm=j*tox*bj-bjp
             bjp=bj
             bj=bjm
             if (abs(bj)>BIGNO) then ! Renormalize to prevent overflows.
                bj=bj*BIGNI
                bjp=bjp*BIGNI
                bessj_n=bessj_n*BIGNI
                suma=suma*BIGNI
             end if
             if (jsum/=0) suma=suma+bj  ! Accumulate the sum.
             jsum=1-jsum                ! Change 0 to 1 or vice versa.
             if (j==n) bessj_n=bjp      ! the unnormalized answer.
          end do
          suma=2.*suma-bj          ! Compute (5.5.16)
          bessj_n=bessj_n/suma     ! and use it to normalize the answer.
       end if
       if ((x<0.0).and.(mod(n,2)==1)) bessj_n=-bessj_n
       return
    End Function BessJ

    !!----
    !!---- Function ERF(X)
    !!----    real(kind=cp), intent(in) : x
    !!----    real(kind=cp)             : Erf
    !!----
    !!----    Error Function
    !!----    Returns the Error Function
    !!----
    !!----  Update:  January - 2016
    !!----
    Elemental Function Erf(X) Result(Fn_Val)
       !---- Arguments ----!
       real (kind=cp), intent(in) :: x
       real (kind=cp)             :: fn_Val

       !---- Local Variables ----!
       real (kind=cp), parameter :: C    = 0.564189583547756_cp
       real (kind=cp), parameter :: ONE  = 1.0_cp
       real (kind=cp), parameter :: HALF = 0.5_cp
       real (kind=cp), parameter :: ZERO = 0.0_cp

       real (kind=dp), parameter :: A(5) = (/0.771058495001320D-04, -0.133733772997339D-02, 0.323076579225834D-01, &
                                             0.479137145607681D-01,  0.128379167095513D+00 /)
       real (kind=dp), parameter :: B(3) = (/0.301048631703895D-02,  0.538971687740286D-01, 0.375795757275549D+00 /)
       real (kind=dp), parameter :: P(8) = (/-1.36864857382717D-07,  5.64195517478974D-01,  7.21175825088309D+00, &
                                              4.31622272220567D+01,  1.52989285046940D+02,  3.39320816734344D+02, &
                                              4.51918953711873D+02,  3.00459261020162D+02 /)
       real (kind=dp), parameter :: Q(8) = (/ 1.00000000000000D+00,  1.27827273196294D+01,  7.70001529352295D+01, &
                                              2.77585444743988D+02,  6.38980264465631D+02,  9.31354094850610D+02, &
                                              7.90950925327898D+02,  3.00459260956983D+02 /)
       real (kind=dp), parameter :: R(5) = (/ 2.10144126479064D+00,  2.62370141675169D+01,  2.13688200555087D+01, &
                                              4.65807828718470D+00,  2.82094791773523D-01 /)
       real (kind=dp), parameter :: S(4) = (/ 9.41537750555460D+01,  1.87114811799590D+02,  9.90191814623914D+01, &
                                              1.80124575948747D+01 /)

       real (kind=cp) :: ax, bot, t, top, x2

       !> Init
       ax = ABS(x)

       if (ax <= half) then
          t = x*x
          top = ((((a(1)*t + a(2))*t + a(3))*t + a(4))*t + a(5)) + one
          bot = ((b(1)*t + b(2))*t + b(3))*t + one
          fn_val = x*(top/bot)
          return
       end if

       if (ax <= 4.0_cp) then
          top = ((((((p(1)*ax + p(2))*ax + p(3))*ax + p(4))*ax + p(5))*ax  &
              + p(6))*ax + p(7))*ax + p(8)
          bot = ((((((q(1)*ax + q(2))*ax + q(3))*ax + q(4))*ax + q(5))*ax  &
              + q(6))*ax + q(7))*ax + q(8)

          fn_val = half + (half - exp(-x*x)*top/bot)
          if (x < zero) fn_val = -fn_val
          return
       end if

       if (ax < 5.8_cp) then
          x2 = x*x
          t = one / x2
          top = (((r(1)*t + r(2))*t + r(3))*t + r(4))*t + r(5)
          bot = (((s(1)*t + s(2))*t + s(3))*t + s(4))*t + one
          fn_val = (c - top/(x2*bot)) / ax
          fn_val = half + (half - exp(-x2)*fn_val)
          if (x < zero) fn_val = -fn_val
          return
       end if

       fn_val = SIGN(one, x)
       return
    End Function Erf

    !!----
    !!---- Elemental Function Factorial(n) Result(fact)
    !!----    integer, intent(in) : n
    !!----
    !!----    Factorial of N
    !!----
    !!---- Update: February - 2005
    !!
    Elemental Function Factorial(n) Result(fact)
       !---- Argument ----!
       integer, intent(in) :: n
       integer             :: fact

       !---- Local variables ----!
       integer   :: nt, np

       if (n ==0) then
          fact=1
       else
          nt=1
          np=abs(n)
          do
             nt=nt*np
             np=np-1
             if(np == 1) exit
          end do
          fact=nt
       end if

       return
    End Function Factorial

    !!----
    !!---- Elemental Function Negligible(v)
    !!----    complex/real(kind=sp),    intent( in) :: v
    !!----
    !!----    Provides the value .TRUE. if the real/complex
    !!----    number V is less than EPS
    !!----
    !!---- Update: February - 2005
    !!

    !!--++
    !!--++ Elemental Function Negligiblec(v)
    !!--++    complex, intent( in) :: v
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Calculate if a complex number is negligible
    !!--++
    !!--++ Update: February - 2005
    !!
    Elemental Function Negligiblec(v) Result(Neglig)
       !---- Argument ----!
       complex, intent( in) :: v
       logical              :: Neglig

       Neglig=.false.
       if (abs(v) > epss) return
       Neglig=.true.

       return
    End Function Negligiblec

    !!--++
    !!--++ Elemental Function Negligibler(v)
    !!--++    real(kind=cp), intent( in) :: v
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Determines if a real number is negligible (abs < EPSS)
    !!--++
    !!--++ Update: February - 2005
    !!
    Elemental Function Negligibler(v) Result(neglig)
       !---- Argument ----!
       real(kind=cp), intent( in) :: v
       logical                    :: Neglig

       Neglig=.false.
       if (abs(v) > epss) return
       Neglig=.true.

       return
    End Function Negligibler

    !!----
    !!---- Function Pgcd(i,j) Result(mcd)
    !!----    integer, intent(in) :: i
    !!----    integer, intent(in) :: j
    !!----    integer             :: mcd
    !!----
    !!----    Function calculating the maximum common divisor of two integers
    !!----
    !!---- Update: February - 2005
    !!
    Function Pgcd(a,b) Result(mcd)
       !---- Arguments ----!
       integer, intent(in) :: a,b
       integer             :: mcd

       !---- Local variables ----!
       integer  :: u,v,m

       u=max(a,b)
       v=min(a,b)
       m=0
       do
          if (m == 1) exit
          m=mod(u,v)
          u=v
          v=m
       end do
       mcd=u

       return
    End Function Pgcd

    !!----
    !!---- Function Ppcm(i,j) result(mcm)
    !!----    integer, intent(in) :: i
    !!----    integer, intent(in) :: j
    !!----    integer             :: mcm
    !!----
    !!----    Function calculating the minimum common multiple of two integers
    !!----
    !!---- Update: February - 2005
    !!
    Function Ppcm(a,b) result(mcm)
       !---- Arguments ----!
       integer, intent(in) :: a,b
       integer             :: mcm

       !---- Local variables ----!
       integer :: u,v,w,i

       u=max(a,b)
       v=min(a,b)
       mcm=1
       if (v <= 1) then
          mcm=u
          return
       end if
       w=int(sqrt(real(u)))+1
       do i=2,w
          do
             if(.not. ((mod(u,i)==0) .or. (mod(v,i)==0)) ) exit
             mcm=mcm*i
             if (modulo(u,i) == 0) u=u/i
             if (modulo(v,i) == 0) v=v/i
          end do
       end do

       return
    End Function Ppcm

    !!----
    !!---- Function Pythag(a,b) Result (c)
    !!----    real(sp/dp),intent(in):: a,b
    !!----    real(sp/dp)           :: c
    !!--<<
    !!----    Computes c=sqrt(a^2 +b^2 ) without destructive underflow or overflow.
    !!----    Adapted from Numerical Recipes.
    !!-->>
    !!----
    !!---- Update: February - 2005
    !!

    !!--++
    !!--++ Function Pythag_dp(a,b) Result (c)
    !!--++    real(dp),intent(in):: a,b
    !!--++    real(dp)           :: c
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Computes c=sqrt(a^2 +b^2 ) without destructive underflow or overflow.
    !!--++    Adapted from Numerical Recipes.
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Pythag_dp(a,b) Result (c)
       !---- Arguments ----!
       real(kind=dp),intent(in):: a,b
       real(kind=dp)           :: c

       !---- Local variables ----!
       real(kind=dp)           :: absa,absb

       absa=abs(a)
       absb=abs(b)
       if (absa >absb)then
          c=absa*sqrt(1.0_dp+(absb/absa)**2)
       else
          if (absb < tiny(1.0_dp))then
             c=0.0
          else
             c=absb*sqrt(1.0_dp+(absa/absb)**2)
          end if
       end if

       return
    End Function Pythag_dp

    !!--++
    !!--++ Function Pythag_sp(a,b) result (c)
    !!--++    real(sp),intent(in):: a,b
    !!--++    real(sp)           :: c
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Computes c=sqrt(a^2 +b^2 ) without destructive underflow or overflow.
    !!--++    Adapted from Numerical Recipes.
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Pythag_sp(a,b) Result (c)
       !---- Arguments ----!
       real(kind=sp),intent(in):: a,b
       real(kind=sp)           :: c

       !---- Local variables ----!
       real(kind=sp)           :: absa,absb

       absa=abs(a)
       absb=abs(b)
       if (absa > absb) then
          c=absa*sqrt(1.0_sp+(absb/absa)**2)
       else
          if (absb < tiny(1.0_sp)) then
             c=0.0
          else
             c=absb*sqrt(1.0_sp+(absa/absb)**2)
          end if
       end if

       return
    End Function Pythag_sp

    !!----
    !!---- Logical Function Co_Linear(A,B,N)
    !!----    complex/integer/real(kind=sp), dimension(:), intent(in)  :: a
    !!----    complex/integer/real(kind=sp), dimension(:), intent(in)  :: b
    !!----    integer,                                     intent(in)  :: n
    !!----
    !!----    Provides the value .TRUE. if the vectors A and B are co-linear
    !!----
    !!---- Update: February - 2005
    !!

    !!--++
    !!--++ Logical Function Co_Linear_C(A, B, N)
    !!--++    complex, dimension(:), intent(in)  :: a
    !!--++    complex, dimension(:), intent(in)  :: b
    !!--++    integer,               intent(in)  :: n
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Determines if two complex vectors are co-linear
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Co_linear_C(a,b,n) Result(co_linear)
       !---- Argument ----!
       complex, dimension(:), intent(in) :: a,b
       integer,               intent(in) :: n
       logical                           :: co_linear

       !---- Local variables ----!
       integer :: i,ia,ib
       complex :: c

       co_linear=.true.
       do i=1,n
          if (abs(a(i)) > epss) then
             ia=i
             exit
          end if
       end do
       do i=1,n
          if (abs(b(i)) > epss) then
             ib=i
             exit
          end if
       end do
       if (ia /= ib) then
          co_linear=.false.
          return
       else
          c=a(ia)/b(ib)
          do i=1,n
             if (abs(a(i)-c*b(i)) > epss) then
                co_linear=.false.
                return
             end if
          end do
       end if

       return
    End Function Co_linear_C

    !!--++
    !!--++ Logical Function Co_Linear_I(A, B, N)
    !!--++    integer, dimension(:), intent(in)  :: a
    !!--++    integer, dimension(:), intent(in)  :: b
    !!--++    integer,               intent(in)  :: n
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Determines if two integer vectors are co-linear
    !!--++
    !!--++ Update: October - 2008
    !!
    Function Co_linear_I(a,b,n) Result(co_linear)
       !---- Argument ----!
       integer, dimension(:), intent(in) :: a,b
       integer,               intent(in) :: n
       logical                           :: co_linear

       !---- Local variables ----!
       integer       :: i,ia,ib
       real(kind=cp) :: c

       co_linear=.true.
       do i=1,n
          if (abs(a(i)) > 0) then
             ia=i
             exit
          end if
       end do
       do i=1,n
          if (abs(b(i)) > 0) then
             ib=i
             exit
          end if
       end do
       if (ia /= ib) then
          co_linear=.false.
          return
       else
          c=real(a(ia))/real(b(ib))
          do i=1,n
             if (abs( real(a(i))-c*real(b(i)) ) > epss) then
                co_linear=.false.
                return
             end if
          end do
       end if

       return
    End Function Co_linear_I

    !!--++
    !!--++ Logical Function Co_Linear_R(A, B, N)
    !!--++    real(kind=cp), dimension(:), intent(in)  :: a
    !!--++    real(kind=cp), dimension(:), intent(in)  :: b
    !!--++    integer,                     intent(in)  :: n
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Determines if two real vectors are co-linear
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Co_linear_R(a,b,n) Result(co_linear)
       !---- Argument ----!
       real(kind=cp), dimension(:), intent(in) :: a,b
       integer,                     intent(in) :: n
       logical                                 :: co_linear

       !---- Local variables ----!
       integer       :: i,ia,ib
       real(kind=cp) :: c

       co_linear=.true.
       do i=1,n
          if (abs(a(i)) > epss) then
             ia=i
             exit
          end if
       end do
       do i=1,n
          if (abs(b(i)) > epss) then
             ib=i
             exit
          end if
       end do
       if (ia /= ib) then
          co_linear=.false.
          return
       else
          c=a(ia)/b(ib)
          do i=1,n
             if (abs(a(i)-c*b(i)) > epss) then
                co_linear=.false.
                return
             end if
          end do
       end if

       return
    End Function Co_linear_R

    !!----
    !!---- Function Co_Prime(v,imax) result(cop)
    !!----   integer, dimension(:), intent(in) :: v
    !!----   integer,  optional,    intent(in) :: imax !Maximun prime number to be tested
    !!----   Logical                           :: cop
    !!----
    !!---- Provides the value .TRUE. if the array V contains co-prime
    !!---- integers: there is no common divisor for all the integers.
    !!---- Only the first 1000 prime numbers are stored in the module array "primes"
    !!---- imax is the maximum prime number to be tested. It is calculated if not given.
    !!----
    !!---- Created: January - 2011
    !!---- Updated: February - 2012  (JRC) (imax argument made optional, really not needed)
    !!
    Function Co_Prime(v,imax) result(cop)
      integer, dimension(:), intent(in) :: v
      integer, optional,     intent(in) :: imax
      Logical                           :: cop
      !---- Local variables ----!
      integer :: i,j,im,k,dimv,imaxv,maxv

      cop=.true.
      maxv=maxval(abs(v))
      if(present(imax)) then
        imaxv=imax
      else
        imaxv=maxv
      end if
      !---- If the maximum value of the indices is 1 they are coprimes
      if (maxv == 1) return
      if (maxv == 0) then
         cop=.false.
         return
      end if
      !---- Search the maximum prime number to be tested
      if (imaxv > 7919) then
        im=1000
      else
        do i=1,1000
           if(imaxv > primes(i)) cycle
           im=i
           exit
        end do
      end if

      !---- Indices greater than 1
      dimv=size(v)
      do_p: do i=1,im
         k=primes(i)
         do j=1,dimv
            if( mod(v(j),k) /= 0) cycle do_p
         end do
         cop=.false.
         exit
      end do do_p

      return
    End Function Co_Prime

    !!----
    !!---- Logical Function Equal_Matrix(A,B,N)
    !!----    integer/real(kind=cp), dimension(:,:), intent(in)  :: a,b
    !!----    integer,                               intent(in)  :: n
    !!----
    !!----    Provides the value .TRUE. if the array A is equal to array B
    !!----
    !!---- Update: February - 2005
    !!

    !!--++
    !!--++ Logical Function Equal_Matrix_I(A, B, N)
    !!--++    integer, dimension(:,:), intent(in)  :: a
    !!--++    integer, dimension(:,:), intent(in)  :: b
    !!--++    integer,                 intent(in)  :: n
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Determines if two integer arrays are equal in NxN
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Equal_Matrix_I(a,b,n) result(info)
       !---- Argument ----!
       integer, dimension(:,:), intent(in) :: a,b
       integer                , intent(in) :: n
       logical                             :: info

       !---- Local variables ----!
       integer :: i,j

       info=.false.
       do i=1,n
          do j=1,n
             if (a(i,j) /= b(i,j)) return
          end do
       end do
       info=.true.

       return
    End Function Equal_Matrix_I

    !!--++
    !!--++ Logical Function Equal_Matrix_R(A, B, N)
    !!--++    real(kind=sp), dimension(:,:), intent(in)  :: a
    !!--++    real(kind=sp), dimension(:,:), intent(in)  :: b
    !!--++    integer,                       intent(in)  :: n
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Determines if two integer arrays are equal in NxN
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Equal_Matrix_R(a,b,n) result(info)
       !---- Argument ----!
       real(kind=cp), dimension(:,:)   , intent(in) :: a,b
       integer,                          intent(in) :: n
       logical                                      :: info

       !---- Local variables ----!
       integer :: i,j

       info=.false.
       do i=1,n
          do j=1,n
             if (abs(a(i,j) - b(i,j)) > epss ) return
          end do
       end do
       info=.true.

       return
    End Function Equal_Matrix_R

    !!----
    !!---- Logical Function Equal_Vector(A,B,N)
    !!----    integer/real(kind=sp), dimension(:),   intent(in)  :: a,b
    !!----    integer,                               intent(in)  :: n
    !!----
    !!----    Provides the value .TRUE. if the vector A is equal to vector B
    !!----
    !!---- Update: February - 2005
    !!

    !!--++
    !!--++ Logical Function Equal_Vector_I(A, B, N)
    !!--++    integer, dimension(:), intent(in)  :: a
    !!--++    integer, dimension(:), intent(in)  :: b
    !!--++    integer,               intent(in)  :: n
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Determines if two integer vectors are equal in N
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Equal_Vector_I(a,b,n) result(info)
       !---- Argument ----!
       integer, dimension(:),   intent(in) :: a,b
       integer                , intent(in) :: n
       logical                             :: info

       !---- Local variables ----!
       integer :: i

       info=.false.
       do i=1,n
          if (a(i) /= b(i)) return
       end do
       info=.true.

       return
    End Function Equal_Vector_I

    !!--++
    !!--++ Logical Function Equal_Vector_R(A, B, N)
    !!--++    real(kind=sp), dimension(:), intent(in)  :: a
    !!--++    real(kind=sp), dimension(:), intent(in)  :: b
    !!--++    integer,                     intent(in)  :: n
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Determines if two real(kind=sp) vectors are equal in N
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Equal_Vector_R(a,b,n) result(info)
       !---- Argument ----!
       real(kind=cp), dimension(:)   ,   intent(in) :: a,b
       integer,                          intent(in) :: n
       logical                                      :: info

       !---- Local variables ----!
       integer :: i

       info=.false.
       do i=1,n
          if (abs(a(i) - b(i)) > epss ) return
       end do
       info=.true.

       return
    End Function Equal_Vector_R

    !!----
    !!----  Function Euclidean_Norm(n,x) Result(Fn_Val)
    !!----    Integer,                      Intent(In)  :: n
    !!----    Real (Kind=cp), Dimension(:), Intent(In)  :: x
    !!----    Real (Kind=cp)                            :: Fn_Val
    !!----
    !!----  This function calculates safely the Euclidean norm of a vector.
    !!----  Intermediate overflows are avoided using this function. The original
    !!----  name "enorm" from MINPACK has been changed and the subroutine has
    !!----  been translated to Fortran 90.
    !!----
    !!----
    !!--..  Original documentation (from MINPACK):
    !!--..
    !!--..  Function enorm
    !!--..
    !!--..  Given an n-vector x, this function calculates the euclidean norm of x.
    !!--..
    !!--..  The euclidean norm is computed by accumulating the sum of squares in
    !!--..  three different sums.  The sums of squares for the small and large
    !!--..  components are scaled so that no overflows occur.  Non-destructive
    !!--..  underflows are permitted.  Underflows and overflows do not occur in the
    !!--..  computation of the unscaled sum of squares for the intermediate
    !!--..  components.  The definitions of small, intermediate and large components
    !!--..  depend on two constants, rdwarf and rgiant.  The main restrictions on
    !!--..  these constants are that rdwarf**2 not underflow and rgiant**2 not
    !!--..  overflow.  The constants given here are suitable for every known computer.
    !!--..
    !!--..  The function statement is
    !!--..
    !!--..    REAL (kind=cp) function enorm(n,x)
    !!--..
    !!--..  where
    !!--..
    !!--..    n is a positive integer input variable.
    !!--..
    !!--..    x is an input array of length n.
    !!--..
    !!--..  Subprograms called
    !!--..
    !!--..    Fortran-supplied ... ABS,SQRT
    !!--..
    !!--..  Argonne National Laboratory. MINPACK project. march 1980.
    !!--..  Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More
    !!----
    !!----  Update: August - 2009
    !!----
    Function Euclidean_Norm(n,x) Result(Fn_Val)
       !---- Arguments ----!
       Integer,                      Intent(In)  :: n
       Real (Kind=cp), Dimension(:), Intent(In)  :: x
       Real (Kind=cp)                            :: Fn_Val

       !--- Local Variables ---!
       Integer                   :: i
       Real (Kind=cp)            :: agiant, floatn, s1, s2, s3, xabs, x1max, x3max
       Real (Kind=cp), Parameter :: one = 1.0_cp, zero = 0.0_cp, rdwarf = 3.834e-20_cp,  &
                                   rgiant = 1.304e+19_cp

       s1 = zero
       s2 = zero
       s3 = zero
       x1max = zero
       x3max = zero
       floatn = n
       agiant = rgiant/floatn
       do i = 1, n
          xabs = Abs(x(i))
          if (.Not. (xabs > rdwarf .AND. xabs < agiant)) then
             ! sum for large components.
             if (xabs > rdwarf) then
                if (xabs > x1max) then
                   s1 = one + s1*(x1max/xabs)**2
                   x1max = xabs
                   cycle
                end if
                s1 = s1 + (xabs/x1max)**2
                cycle
             End If

             ! sum for small components.
             If (xabs > x3max) Then
                s3 = one + s3*(x3max/xabs)**2
                x3max = xabs
                Cycle
             End If

             If (xabs /= zero) s3 = s3 + (xabs/x3max)**2
             Cycle
          End if

          !  sum for intermediate components.
          s2 = s2 + xabs**2
       End Do

       ! calculation of norm.
       If (s1 /= zero) Then
          Fn_Val = x1max*Sqrt(s1 + (s2/x1max)/x1max)
          Return
       End If

       If (s2 /= zero) Then
          If (s2 >= x3max) Fn_Val = Sqrt(s2*(one + (x3max/s2)*(x3max*s3)))
          If (s2 < x3max) Fn_Val = Sqrt(x3max*((s2/x3max) + (x3max*s3)))
          Return
       End If

       Fn_Val = x3max*Sqrt(s3)

       Return
    End Function Euclidean_Norm

    !!----
    !!---- Function Imaxloc(arr) Result(mav)
    !!----  real(kind=sp)/integer, dimension(:), intent(in) :: arr
    !!----  integer                                         :: mav
    !!----
    !!----   Index of maxloc on an array
    !!----
    !!---- Update: February - 2005
    !!

    !!--++
    !!--++ Function Imaxloc_I(arr) Result(mav)
    !!--++  integer, dimension(:), intent(in) :: arr
    !!--++  integer                           :: mav
    !!--++
    !!--++   Index of maxloc on an array (from Numerical Recipes)
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Imaxloc_I(iarr) Result(mav)
       !---- Arguments ----!
       integer, dimension(:), intent(in) :: iarr
       integer                           :: mav

       !---- Local variables ----!
       integer, dimension(1) :: imax

       imax=maxloc(iarr(:))
       mav=imax(1)

       return
    End Function Imaxloc_I

    !!--++
    !!--++ Function Imaxloc_R(arr) Result(mav)
    !!--++  real(kind=sp), dimension(:), intent(in) :: arr
    !!--++  integer                                 :: mav
    !!--++
    !!--++   Index of maxloc on an array (from Numerical Recipes)
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Imaxloc_R(arr) Result(mav)
       !---- Arguments ----!
       real(kind=cp), dimension(:), intent(in) :: arr
       integer                                 :: mav

       !---- Local variables ----!
       integer, dimension(1) :: imax

       imax=maxloc(arr(:))
       mav=imax(1)

       return
    End Function Imaxloc_R

    !!----
    !!---- Function Iminloc(arr)  Result(miv)
    !!----  real(kind=sp)/integer, dimension(:), intent(in) :: arr
    !!----  integer                                         :: miv
    !!----
    !!----   Index of minloc on an array  (from Numerical Recipes)
    !!----
    !!---- Update: February - 2005
    !!

    !!--++
    !!--++ Function Iminloc_I(arr)  Result(miv)
    !!--++  integer, dimension(:), intent(in) :: arr
    !!--++  integer                           :: miv
    !!--++
    !!--++   Index of minloc on an array (from Numerical Recipes)
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Iminloc_I(arr)  Result(miv)
       !---- Arguments ----!
       integer, dimension(:), intent(in) :: arr
       integer                           :: miv

       !---- Local variables ----!
       integer, dimension(1) :: imin

       imin=minloc(arr(:))
       miv=imin(1)

       return
    End Function Iminloc_I

    !!--++
    !!--++ Function Iminloc_R(arr)  Result(miv)
    !!--++  real(kind=sp), dimension(:), intent(in) :: arr
    !!--++  integer                                 :: miv
    !!--++
    !!--++   Index of minloc on an array (from Numerical Recipes)
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Iminloc_R(arr)  Result(miv)
       !---- Arguments ----!
       real(kind=cp), dimension(:), intent(in) :: arr
       integer                                 :: miv

       !---- Local variables ----!
       integer, dimension(1) :: imin

       imin=minloc(arr(:))
       miv=imin(1)

       return
    End Function Iminloc_R

    !!----
    !!---- Function in_limits(n,limits,vect) result(ok)
    !!----   integer,                      intent(in) :: n
    !!----   integer/real, dimension(:,:), intent(in) :: limits   ! Normally (2,n)
    !!----   integer/real, dimension(n),   intent(in) :: vect
    !!----   logical                                  :: ok
    !!----
    !!----   Logical function that is true if all the components of the vector vect
    !!----   are within the limits:   limits(1,i)  <= vect(i) <=  limits(2,i), for all i.
    !!----
    !!----   Updated: March - 2013
    !!
    !!--++
    !!--++ Function in_limits_int(n,limits,vect) result(ok)
    !!--++   integer,                 intent(in) :: n
    !!--++   integer, dimension(:,:), intent(in) :: limits   ! Normally (2,n)
    !!--++   integer, dimension(n),   intent(in) :: vect
    !!--++   logical                              :: ok
    !!--++
    !!--++   Logical function that is true if all the components of the vector vect
    !!--++   are within the limits:   limits(1,i)  <= vect(i) <=  limits(2,i), for all i.
    !!--++
    !!--++   Updated: March - 2013
    !!
    Function in_limits_int(n,limits,vect) result(ok)
      integer,                 intent(in) :: n
      integer, dimension(:,:), intent(in) :: limits   ! Normally (2,n)
      integer, dimension(n),   intent(in) :: vect
      logical :: ok
      integer :: i
      ok=.true.
      do i=1,n
        if(vect(i) >= limits(1,i) .and. vect(i) <= limits(2,i)) cycle
        ok=.false.
        exit
      end do
      return
    End Function in_limits_int

    !!--++
    !!--++ Function in_limits_dp(n,limits,vect) result(ok)
    !!--++   integer,                       intent(in) :: n
    !!--++   real(kind=dp), dimension(:,:), intent(in) :: limits   ! Normally (2,n)
    !!--++   real(kind=dp), dimension(n),   intent(in) :: vect
    !!--++   logical                                   :: ok
    !!--++
    !!--++   Logical function that is true if all the components of the vector vect
    !!--++   are within the limits:   limits(1,i)  <= vect(i) <=  limits(2,i), for all i.
    !!--++
    !!--++   Updated: March - 2013
    !!
    Function in_limits_dp(n,limits,vect) result(ok)
      integer,                       intent(in) :: n
      real(kind=dp), dimension(:,:), intent(in) :: limits   ! Normally (2,n)
      real(kind=dp), dimension(n),   intent(in) :: vect
      logical :: ok
      integer :: i
      ok=.true.
      do i=1,n
        if(vect(i) >= limits(1,i) .and. vect(i) <= limits(2,i)) cycle
        ok=.false.
        exit
      end do
      return
    End Function in_limits_dp

    !!--++
    !!--++ Function in_limits_sp(n,limits,vect) result(ok)
    !!--++   integer,                       intent(in) :: n
    !!--++   real(kind=sp), dimension(:,:), intent(in) :: limits   ! Normally (2,n)
    !!--++   real(kind=sp), dimension(n),   intent(in) :: vect
    !!--++   logical                                   :: ok
    !!--++
    !!--++   Logical function that is true if all the components of the vector vect
    !!--++   are within the limits:   limits(1,i)  <= vect(i) <=  limits(2,i), for all i.
    !!--++
    !!--++   Updated: March - 2013
    !!
    Function in_limits_sp(n,limits,vect) result(ok)
      integer,                       intent(in) :: n
      real(kind=sp), dimension(:,:), intent(in) :: limits   ! Normally (2,n)
      real(kind=sp), dimension(n),   intent(in) :: vect
      logical :: ok
      integer :: i
      ok=.true.
      do i=1,n
        if(vect(i) >= limits(1,i) .and. vect(i) <= limits(2,i)) cycle
        ok=.false.
        exit
      end do
      return
    End Function in_limits_sp

    !!----
    !!---- Function Locate(xx, n, x) Result(j)
    !!----     or
    !!---- Function Locate(xx,x) Result(j)
    !!----
    !!----    integer/real(kind=sp), dimension(n),intent(in)  :: xx
    !!----    integer ,                           intent(in)  :: n
    !!----    integer/real(kind=sp),              intent(in)  :: x
    !!----    integer ,                           intent(out) :: j
    !!----
    !!----    Function for locating the index J of an array XX(N)
    !!----    satisfying:
    !!--<<
    !!----               XX(J) <= X < XX(J+1)
    !!-->>
    !!----
    !!---- Update: June - 2011
    !!

    !!--++
    !!--++ Function Locate_I(xx, n, x) Result(j)
    !!--++    integer, dimension(:),intent(in)  :: xx
    !!--++    integer ,             intent(in)  :: n
    !!--++    integer,              intent(in)  :: x
    !!--++    integer ,             intent(out) :: j
    !!--++
    !!--++    Subroutine for locating the index J of an array XX(N)
    !!--++    satisfying:
    !!--++
    !!--++               XX(J) <= X < XX(J+1)
    !!--++
    !!--++
    !!--++ Update: June - 2011
    !!
    Function Locate_I(xx,n,x) Result(j)
       !---- Argument ----!
       integer, dimension(:), intent(in):: xx
       integer ,              intent(in):: n
       integer,               intent(in):: x
       integer                          :: j

       !---- Local Variables ----!
       integer :: jl, ju, jm

       if(x <= xx(1)) then
         j=1
         return
       end if
       if(x >= xx(n)) then
         j=n
         return
       end if
       jl=0
       ju=n+1
       do
          if(ju-jl <= 1) exit
          jm=(ju+jl)/2
          if ((xx(n) > xx(1)) .eqv. (x > xx(jm))) then
             jl=jm
          else
             ju=jm
          end if
       end do
       j=jl

       return
    End Function Locate_I
    !!--++
    !!--++ Function Locate_Ib(xx, x) Result(j)
    !!--++    integer, dimension(:),intent(in)  :: xx
    !!--++    integer,              intent(in)  :: x
    !!--++    integer ,             intent(out) :: j
    !!--++
    !!--++    Subroutine for locating the index J of an array XX(:)
    !!--++    satisfying:
    !!--++
    !!--++               XX(J) <= X < XX(J+1)
    !!--++
    !!--++
    !!--++ Update: June - 2011
    Function Locate_Ib(xx,x) Result(j)
       !---- Argument ----!
       integer, dimension(:), intent(in):: xx
       integer,               intent(in):: x
       integer                          :: j

       !---- Local Variables ----!
       integer :: jl, ju, jm, i1,i2
       integer, dimension(1) :: mi

       mi=lbound(xx)
       i1=mi(1)
       mi=ubound(xx)
       i2=mi(1)

       if(x <= xx(i1)) then
         j=i1
         return
       end if
       if(x >= xx(i2)) then
         j=i2
         return
       end if
       jl=i1-1
       ju=i2+1
       do
          if(ju-jl <= 1) exit
          jm=(ju+jl)/2
          if ((xx(i2) > xx(i1)) .eqv. (x > xx(jm))) then
             jl=jm
          else
             ju=jm
          end if
       end do
       j=jl
       return
    End Function Locate_Ib
    !!--++
    !!--++ Function Locate_R(xx, n, x) Result(j)
    !!--++    real(kind=cp), dimension(:),intent(in)  :: xx
    !!--++    integer ,                   intent(in)  :: n
    !!--++    real(kind=cp),              intent(in)  :: x
    !!--++    integer ,                   intent(out) :: j
    !!--++
    !!--++    Function for locating the index J of an array XX(N)
    !!--++    satisfying:
    !!--++
    !!--++               XX(J) <= X < XX(J+1)
    !!--++
    !!--++
    !!--++ Update: June - 2011
    !!
    Function Locate_R(xx,n,x) Result(j)
       !---- Argument ----!
       real(kind=cp), dimension(:), intent(in):: xx
       integer ,                    intent(in):: n
       real(kind=cp),               intent(in):: x
       integer                                :: j

       !---- Local Variables ----!
       integer :: jl, ju, jm

       if(x <= xx(1)) then
         j=1
         return
       end if
       if(x >= xx(n)) then
         j=n
         return
       end if
       jl=0
       ju=n+1
       do
          if(ju-jl <= 1) exit
          jm=(ju+jl)/2
          if ((xx(n) > xx(1)) .eqv. (x > xx(jm))) then
             jl=jm
          else
             ju=jm
          end if
       end do
       j=jl

       return
    End Function Locate_R

    !!--++
    !!--++ Function Locate_Rb(xx, x) Result(j)
    !!--++    real(kind=cp), dimension(:),intent(in)  :: xx
    !!--++    real(kind=cp),              intent(in)  :: x
    !!--++    integer ,                   intent(out) :: j
    !!--++
    !!--++    Function for locating the index J of an array XX(:)
    !!--++    satisfying:
    !!--++
    !!--++               XX(J) <= X < XX(J+1)
    !!--++
    !!--++
    !!--++ Update: June - 2011
    !!
    Function Locate_Rb(xx,x) Result(j)
       !---- Argument ----!
       real(kind=cp), dimension(:), intent(in):: xx
       real(kind=cp),               intent(in):: x
       integer                                :: j

       !---- Local Variables ----!
       integer :: jl, ju, jm, i1,i2
       integer, dimension(1) :: mi

       mi=lbound(xx)
       i1=mi(1)
       mi=ubound(xx)
       i2=mi(1)

       if(x <= xx(i1)) then
         j=i1
         return
       end if
       if(x >= xx(i2)) then
         j=i2
         return
       end if
       jl=i1-1
       ju=i2+1
       do
          if(ju-jl <= 1) exit
          jm=(ju+jl)/2
          if ((xx(i2) > xx(i1)) .eqv. (x > xx(jm))) then
             jl=jm
          else
             ju=jm
          end if
       end do
       j=jl

       return
    End Function Locate_Rb

    !!----
    !!---- Function Lower_Triangular_I(A,n) Result (T)
    !!----   integer, dimension(:,:), intent(in) :: A
    !!----   integer,                 intent(in) :: n
    !!----   integer, dimension(n,n)             :: T
    !!----
    !!----   Updated: October - 2014
    !!----
    Function Lower_Triangular_I(A,n) Result (T)
       !---- Argument ----!
       integer, dimension(:,:), intent(in) :: A
       integer,                 intent(in) :: n
       integer, dimension(n,n)             :: T
       integer :: i,j,p,q,m
       m=n
       p=size(A(:,1)); q=size(A(1,:))
       if(n > p .or. n > q) m=min(p,q)
       T=0
       do j=1,m
         do i=j,m
           T(i,j)=A(i,j)
         end do
       end do
    End Function  Lower_Triangular_I

    !!----
    !!---- Function Lower_Triangular_R(A,n) Result (T)
    !!----   real(kind=cp), dimension(:,:), intent(in) :: A
    !!----   integer,                       intent(in) :: n
    !!----   real(kind=cp), dimension(n,n)             :: T
    !!----
    !!----   Updated: October - 2014
    !!----
    Function Lower_Triangular_R(A,n) Result (T)
       !---- Argument ----!
       real(kind=cp), dimension(:,:), intent(in) :: A
       integer,                       intent(in) :: n
       real(kind=cp), dimension(n,n)             :: T
       integer :: i,j,p,q,m
       m=n
       p=size(A(:,1)); q=size(A(1,:))
       if(n > p .or. n > q) m=min(p,q)
       T=0
       do j=1,m
         do i=j,m
           T(i,j)=A(i,j)
         end do
       end do
    End Function  Lower_Triangular_R

    !!---- Function Modulo_Lat(U)
    !!----    real(kind=cp), dimension(:), intent(in) :: u
    !!----
    !!----    Reduces a real vector to another with components in
    !!----    the interval [0,1)
    !!----
    !!---- Updated: February - 2005
    !!
    Function Modulo_Lat(u) result(v)
       !---- Argument ----!
       real(kind=cp), dimension(:), intent( in) :: u
       real(kind=cp), dimension(1:size(u))      :: v

       v=mod(u+10.0_cp,1.0_cp)

       return
    End Function  Modulo_Lat

    !!----
    !!---- Function Norm(X,G) Result(R)
    !!----    real(kind=cp)/integer, dimension(:),   intent(in) :: x
    !!----    real(kind=cp),         dimension(:,:), intent(in) :: g
    !!----
    !!----    Calculate the Norm of a vector
    !!----
    !!---- Update: April - 2009
    !!

    !!--++
    !!--++ Function Norm_I(X,G) Result(R)
    !!--++    integer,      dimension(:),   intent(in) :: x
    !!--++    real(kind=cp),dimension(:,:), intent(in) :: g
    !!--++
    !!--++    Calculate the Norm of a vector
    !!--++
    !!--++ Update: April - 2009
    !!
    Function Norm_I(X,G) Result(R)
       !---- Arguments ----!
       integer,       dimension(:),   intent(in) :: x
       real(kind=cp), dimension(:,:), intent(in) :: g
       real(kind=cp)                             :: r

       if (size(x)*size(x) /= size(g)) then
          r=tiny(0.0)
       else
          r=sqrt(dot_product(real(x), matmul(g,real(x))))
       end if

       return
    End Function Norm_I

    !!--++
    !!--++ Function Norm_R(X,G) Result(R)
    !!--++    real(kind=cp),dimension(:),   intent(in) :: x
    !!--++    real(kind=cp),dimension(:,:), intent(in) :: g
    !!--++
    !!--++    Calculate the Norm of a vector
    !!--++
    !!--++ Update: April - 2009
    !!
    Function Norm_R(X,G) Result(R)
       !---- Arguments ----!
       real(kind=cp), dimension(:),   intent(in) :: x
       real(kind=cp), dimension(:,:), intent(in) :: g
       real(kind=cp)                             :: r

       if (size(x)*size(x) /= size(g)) then
          r=tiny(0.0)
       else
          r=sqrt(dot_product(x, matmul(g,x)))
       end if

       return
    End Function Norm_R


    !!----
    !!---- Function Outerprod(a,b) Result(c)
    !!----    real(sp/dp),dimension(:),intent(in)    :: a,b
    !!----    real(sp/dp),dimension(size(a),size(b)) :: c
    !!----
    !!----    Computes the outer product (tensorial product) of two
    !!----    vectors to give a tensor (matrix) as the result:
    !!--<<
    !!----                   c(i,j) = a(i)*b(j).
    !!-->>
    !!--..    It uses the intrinsic Fortran 90 function SPREAD.
    !!--..    Function adapted from Numerical Recipes.
    !!----
    !!---- Update: February - 2005
    !!

    !!--++
    !!--++ Function Outerprod_dp(a,b) Result(c)
    !!--++    real(dp),dimension(:),intent(in)    :: a,b
    !!--++    real(dp),dimension(size(a),size(b)) :: c
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Computes the outer product (tensorial product) of two
    !!--++    vectors to give a tensor (matrix) as the result:
    !!--++                   c(i,j) = a(i)*b(j).
    !!--++
    !!--++    It uses the intrinsic Fortran 90 function SPREAD.
    !!--++    Taken from Numerical Recipes.
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Outerprod_dp(a,b)  Result(c)
       !---- Arguments ----!
       real(kind=dp),dimension(:),intent(in)    :: a,b
       real(kind=dp),dimension(size(a),size(b)) :: c

       c =spread(a,dim=2,ncopies=size(b))*spread(b,dim=1,ncopies=size(a))

       return
    End Function Outerprod_dp

    !!--++
    !!--++ Function Outerprod_sp(a,b) Result(c)
    !!--++    real(sp),dimension(:),intent(in)    :: a,b
    !!--++    real(sp),dimension(size(a),size(b)) :: c
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Computes the outer product (tensorial product) of two
    !!--++    vectors to give a tensor (matrix) as the result:
    !!--++                   c(i,j) = a(i)*b(j).
    !!--++
    !!--++    It uses the intrinsic Fortran 90 function SPREAD.
    !!--++    Taken from Numerical Recipes.
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Outerprod_sp(a,b)  Result(c)
       !---- Arguments ----!
       real(kind=sp),dimension(:),intent(in)    :: a,b
       real(kind=sp),dimension(size(a),size(b)) :: c

       c =spread(a,dim=2,ncopies=size(b))*spread(b,dim=1,ncopies=size(a))

       return
    End Function Outerprod_sp

    !!----
    !!---- Function Scalar(X,Y,G) Result(R)
    !!----    integer/real(kind=cp), dimension(:),   intent(in) :: x
    !!----    integer/real(kind=cp), dimension(:),   intent(in) :: y
    !!----    real(kind=cp),         dimension(:,:), intent(in) :: g
    !!----
    !!----    Scalar Product including metrics
    !!----
    !!---- Update: April - 2009
    !!

    !!--++
    !!--++ Function Scalar_R(X,Y,G) Result(R)
    !!--++    integer, dimension(:),   intent(in) :: x
    !!--++    integer, dimension(:),   intent(in) :: y
    !!--++    real(kind=cp), dimension(:,:), intent(in) :: g
    !!--++
    !!--++    Scalar Product including metrics
    !!--++
    !!--++ Update: April - 2009
    !!
    Function Scalar_I(X,Y,G) Result(R)
       !---- Arguments ----!
       integer, dimension(:),   intent(in) :: x
       integer, dimension(:),   intent(in) :: y
       real(kind=cp), dimension(:,:), intent(in) :: g
       real(kind=cp)                             :: r

       if (size(x)/= size(y) .or. size(x)*size(x) /= size(g)) then
          r=tiny(0.0)
       else
          r=dot_product(real(x), matmul(g,real(y)))
       end if

       return
    End Function Scalar_I

    !!--++
    !!--++ Function Scalar_R(X,Y,G) Result(R)
    !!--++    real(kind=cp), dimension(:),   intent(in) :: x
    !!--++    real(kind=cp), dimension(:),   intent(in) :: y
    !!--++    real(kind=cp), dimension(:,:), intent(in) :: g
    !!--++
    !!--++    Scalar Product including metrics
    !!--++
    !!--++ Update: April - 2009
    !!
    Function Scalar_R(X,Y,G) Result(R)
       !---- Arguments ----!
       real(kind=cp), dimension(:),   intent(in) :: x
       real(kind=cp), dimension(:),   intent(in) :: y
       real(kind=cp), dimension(:,:), intent(in) :: g
       real(kind=cp)                             :: r

       if (size(x)/= size(y) .or. size(x)*size(x) /= size(g)) then
          r=tiny(0.0)
       else
          r=dot_product(x, matmul(g,y))
       end if

       return
    End Function Scalar_R

    !!----
    !!---- Function Trace(A)
    !!----    complex/integer/real(kind=cp), dimension(:,:), intent(in)  :: a
    !!----
    !!----    Provides the trace of a complex/real or integer matrix
    !!----
    !!---- Update: February - 2005
    !!

    !!--++
    !!--++ Function Trace_C(A)
    !!--++    complex, dimension(:,:), intent(in)  :: a
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Calculates the trace of a complex nxn array
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Trace_C(a) Result(b)
       !---- Argument ----!
       complex, dimension(:,:), intent(in) :: a
       complex                             :: b

       !---- Local variables ----!
       integer :: i,imax

       b=(0.0,0.0)
       imax=min(size(a,1),size(a,2))
       do i=1,imax
          b=b+a(i,i)
       end do

       return
    End Function Trace_C

    !!--++
    !!--++ Function Trace_I(A)
    !!--++    integer, dimension(:,:), intent(in)  :: a
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Calculates the trace of an integer 3x3 array
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Trace_I(a) Result(b)
       !---- Argument ----!
       integer, dimension(:,:), intent(in) :: a
       integer                             :: b

       !---- Local variables ----!
       integer :: i,imax

       b=0
       imax=min(size(a,1),size(a,2))
       do i=1,imax
          b=b+a(i,i)
       end do

       return
    End Function Trace_I

    !!--++
    !!--++ Function Trace_R(A)
    !!--++    real(kind=cp), dimension(:,:), intent(in)  :: a
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Calculates the trace of a real 3x3 array
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Trace_R(a) Result(b)
       !---- Argument ----!
       real(kind=cp), dimension(:,:), intent(in) :: a
       real(kind=cp)                             :: b

       !---- Local variables ----!
       integer :: i,imax

       b=0.0
       imax=min(size(a,1),size(a,2))
       do i=1,imax
          b=b+a(i,i)
       end do

       return
    End Function Trace_R


    !!----
    !!---- Function Upper_Triangular_I(A,n) Result (T)
    !!----   integer, dimension(:,:), intent(in) :: A
    !!----   integer,                 intent(in) :: n
    !!----   integer, dimension(n,n)             :: T
    !!----
    !!----   Updated: October - 2014
    !!----
    Function Upper_Triangular_I(A,n) Result (T)
       !---- Argument ----!
       integer, dimension(:,:), intent(in) :: A
       integer,                 intent(in) :: n
       integer, dimension(n,n)             :: T
       integer :: i,j,p,q,m
       m=n
       p=size(A(:,1)); q=size(A(1,:))
       if(n > p .or. n > q) m=min(p,q)
       T=0
       do j=1,m
         do i=1,j
           T(i,j)=A(i,j)
         end do
       end do
    End Function  Upper_Triangular_I

    !!----
    !!---- Function Upper_Triangular_R(A,n) Result (T)
    !!----   real(kind=cp), dimension(:,:), intent(in) :: A
    !!----   integer,                       intent(in) :: n
    !!----   real(kind=cp), dimension(n,n)             :: T
    !!----
    !!----   Updated: October - 2014
    !!----
    Function Upper_Triangular_R(A,n) Result (T)
       !---- Argument ----!
       real(kind=cp), dimension(:,:), intent(in) :: A
       integer,                       intent(in) :: n
       real(kind=cp), dimension(n,n)             :: T
       integer :: i,j,p,q,m
       m=n
       p=size(A(:,1)); q=size(A(1,:))
       if(n > p .or. n > q) m=min(p,q)
       T=0
       do j=1,m
         do i=1,j
           T(i,j)=A(i,j)
         end do
       end do
    End Function  Upper_Triangular_R

    !!----
    !!---- Logical Function Zbelong(V)
    !!----    real(kind=cp),   dimension(:,:), intent( in) :: v
    !!----                      or
    !!----    real(kind=cp),   dimension(:),   intent( in) :: v
    !!----                      or
    !!----    real(kind=cp),                   intent( in) :: v
    !!----
    !!----    Provides the value .TRUE. if the real number (or array) V is close enough
    !!----    (whithin EPS) to an integer.
    !!----
    !!---- Update: February - 2005
    !!

    !!--++
    !!--++ Logical Function ZbelongM(V)
    !!--++    real(kind=cp),   dimension(:,:), intent( in) :: v
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Determines if a real array is an Integer matrix
    !!--++
    !!--++ Update: February - 2005
    !!
    Function ZbelongM(v) Result(belong)
       !---- Argument ----!
       real(kind=cp),   dimension(:,:), intent( in) :: v
       logical                                      :: belong

       !---- Local variables ----!
       real(kind=cp),   dimension(size(v,1),size(v,2)) :: vec

       vec= abs(real(nint (v))-v)
       belong=.not. ANY(vec > epss)

       return
    End Function ZbelongM

    !!--++
    !!--++ Logical Function ZbelongN(A)
    !!--++    real(kind=cp),  intent(in)  :: a
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Determines if a real number is an Integer
    !!--++
    !!--++ Update: February - 2005
   !!
    Function ZbelongN(a) Result(belong)
       !---- Argument ----!
       real(kind=cp), intent( in) :: a
       logical                    :: belong

       belong=.false.
       if (abs(real(nint (a))-a) > epss) return
       belong=.true.

       return
    End Function ZbelongN

    !!--++
    !!--++ Logical Function ZbelongV(V)
    !!--++    real(kind=sp),   dimension(:), intent( in) :: v
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Determines if a real vector is an Integer vector
    !!--++
    !!--++ Update: February - 2005
    !!
    Function ZbelongV(v) Result(belong)
       !---- Argument ----!
       real(kind=cp),   dimension(:), intent( in) :: v
       logical                                    :: belong

       !---- Local variables ----!
       integer                             :: i
       real(kind=cp),   dimension(size(v)) :: vec

       belong=.false.
       vec= abs(real(nint (v))-v)
       do i=1,size(v)
          if (vec(i) > epss) return
       end do
       belong=.true.

       return
    End Function ZbelongV

    !---------------------!
    !---- Subroutines ----!
    !---------------------!

    !!----
    !!---- Subroutine Init_Err_Mathgen()
    !!----
    !!----    Initialize the errors flags in CFML_Math_General
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Init_Err_MathGen()

       ERR_MathGen=.false.
       ERR_MathGen_Mess=" "

       return
    End Subroutine Init_Err_MathGen

    !!----
    !!---- Subroutine Set_Epsg(Neweps)
    !!----    real(kind=cp), intent( in) :: neweps
    !!----
    !!----    Sets global EPSS to the value "neweps"
    !!----
    !!---- Update: April - 2005
    !!
    Subroutine Set_Epsg(Neweps)
       !---- Arguments ----!
       real(kind=cp), intent( in) :: neweps

       epss=neweps

       return
    End Subroutine Set_Epsg

    !!----
    !!---- Subroutine Set_Epsg_Default()
    !!----
    !!----    Sets global EPSS to the default value: epss=1.0E-5_sp
    !!----
    !!---- Update: April - 2005
    !!
    Subroutine Set_Epsg_Default()

       epss=1.0E-5_sp

       return
    End Subroutine Set_Epsg_Default

    !!----
    !!---- Subroutine Rtan(y,x,ang,deg)
    !!----    real(sp/dp),               intent( in) :: x,y
    !!----    real(sp/dp),               intent(out) :: ang
    !!----    character(len=*),optional, intent( in) :: deg
    !!----
    !!----    Returns ang=arctan(y/x) in the quadrant where the signs sin(ang) and
    !!----    cos(ang) are those of y and x. If deg is present, return ang in degrees.
    !!----
    !!---- Update: February - 2005
    !!

    !!--++
    !!--++ Subroutine Rtan_dp(y,x,ang,deg)
    !!--++    real(dp),                  intent( in) :: x,y
    !!--++    real(dp),                  intent(out) :: ang
    !!--++    character(len=*),optional, intent( in) :: deg
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Returns ang=arctan(y/x) in the quadrant where the signs sin(ang) and
    !!--++    cos(ang) are those of y and x. If deg is present, return ang in degrees.
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Rtan_dp(y,x,ang,deg)
       !---- Arguments ----!
       real(kind=dp),              Intent( In)   :: x,y
       real(kind=dp),              Intent(Out)   :: ang
       character(len=*), optional, Intent( In)   :: deg

       !---- Local variables ----!
       real(kind=dp):: abx,aby

       abx=abs(x)
       aby=abs(y)
       if ((abx < eps) .and. (aby < eps)) then
          ang = 0.0_dp
          return
       else if(abx < eps) then
          ang = pi/2.0_dp
       else if(aby < abx) then
          ang = atan(aby/abx)
          if(x < 0.0_dp) ang = pi-ang
       else
          ang = pi/2.0_dp - atan(abx/aby)
          if(x < 0.0_dp) ang = pi-ang
       end if
       if (y < 0.0_dp) ang = -ang
       if (present(deg)) ang = ang*to_deg

       return
    End Subroutine Rtan_dp

    !!--++
    !!--++ Subroutine Rtan_sp(x,y,ang,deg)
    !!--++    real(sp),                  intent( in) :: x,y
    !!--++    real(sp),                  intent(out) :: ang
    !!--++    character(len=*),optional, intent( in) :: deg
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Returns ang=arctan(y/x) in the quadrant where the signs sin(ang) and
    !!--++    cos(ang) are those of y and x. If deg is present, return ang in degrees.
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Rtan_sp(y,x,ang,deg)
       !---- Arguments ----!
       real(kind=sp),              Intent( In)   :: x,y
       real(kind=sp),              Intent(Out)   :: ang
       character(len=*), optional, Intent( In)   :: deg

       !---- local variables ----!
       real(kind=sp):: abx,aby

       abx=abs(x)
       aby=abs(y)
       if ((abx < eps) .and. (aby < eps)) then
          ang = 0.0_sp
          return
       else if(abx < eps) then
          ang = pi/2.0_sp
       else if(aby < abx) then
          ang = atan(aby/abx)
          if(x < 0.0_sp) ang = pi-ang
       else
          ang = pi/2.0_sp - atan(abx/aby)
          if(x < 0.0_sp) ang = pi-ang
       end if
       if(y < 0.0_sp) ang = -ang
       if (present(deg)) ang = ang*to_deg

       return
    End Subroutine Rtan_sp

    !!----
    !!----  Subroutine Co_Prime_Vector(V,Cop,F)
    !!----     integer, dimension(:), intent(in)  :: v      !input integer vector
    !!----     integer, dimension(:), intent(out) :: cop    !Output co-prime vector
    !!----     integer,  optional,    intent(out) :: f      !Common multiplicative factor
    !!----
    !!----     Calculates the co-prime vector (cop) parallel to the input vector (v)
    !!----     It uses the list of the first thousand prime numbers.
    !!----
    !!----   Updated: January 2012 (JRC), copied from Nodal_Indices (Laue_Mod) in July 2013 (JRC)
    !!----
    Subroutine Co_Prime_Vector(V,Cop,f)
       !---- Arguments ----!
       integer, dimension(:), intent(in)  :: v
       integer, dimension(:), intent(out) :: cop
       integer,  optional,    intent(out) :: f

       !---- Local variables ----!
       integer                     :: i,j,max_ind,k,im,dimv,n

       cop=v
       n=1
       if (present(f)) f=1
       max_ind=maxval(abs(cop))
       !---- If the maximum value of the indices is 1 they are already coprimes
       if (max_ind <= 1) return
       !---- Indices greater than 1
       dimv=size(v)
       im=0
       do i=1,size(primes)
          if(primes(i) > max_ind) then  !primes is an array within this module
             im=i
             exit
          end if
       end do
       if(im == 0) return
       do_p: do i=1,im
         k=primes(i)
         do
           do j=1,dimv
              if( mod(cop(j),k) /= 0) cycle do_p
           end do
           n=n*k
           cop=cop/k
         end do
       end do do_p

       if (present(f)) f=n

       return
    End Subroutine Co_Prime_vector

    !!----
    !!---- Subroutine Determinant(A,n,determ)
    !!----    complex/real(sp), dimension(:,:), intent( in) :: A      !input square matrix (n,n)
    !!----    integer,                          intent( in) :: n      !actual dimension of A
    !!----    real(kind=sp),                    intent(out) :: determ !det(A) if real
    !!----                                                             det(AR)^2 + det(AI)^2 if complex
    !!----
    !!----    Calculates the determinant of a real square matrix.
    !!----    Calculates the pseudo-determinant of a complex square matrix.
    !!----    The calculated value is only useful for linear dependency purposes.
    !!----    It tell us if the complex matrix is singular or not.
    !!--..
    !!--..    Calculates the determinant of a complex square matrix selected from a rectangular
    !!--..    matrix A, n x m, where m >= n. determ=determinant_of_A(1:n,icol:icol+n-1)
    !!--..    If icol is absent, the calculation is performed as if icol=1.
    !!--..    If icol+n-1 > m, or m < n, determ is set to 0.0 and an error message is generated.
    !!----
    !!--..    P R O V I S I O N A L (The determinant of A is not calculated at present)
    !!----
    !!---- Update: February - 2005
    !!

    !!--++
    !!--++ Subroutine Determinant_C(A,n,determ)
    !!--++    complex,          dimension(:,:), intent( in) :: A      !input square matrix (n,n)
    !!--++    integer,                          intent( in) :: n      !actual dimension of A
    !!--++    real(kind=cp),                    intent(out) :: determ !det(A) if real
    !!--++                                                             det(AR)^2 + det(AI)^2 if complex
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Calculates the determinant of a real square matrix.
    !!--++    Calculates the pseudo-determinant of a complex square matrix.
    !!--++    The calculated value is only useful for linear dependency purposes.
    !!--++    It tell us if the complex matrix is singular or not.
    !!--++
    !!--++    P R O V I S I O N A L (The determinant of A is not calculated at present)
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Determinant_C(A,n,determ)
       !---- Arguments ----!
       complex, dimension(:,:), intent( in) :: A
       integer,                 intent( in) :: n
       real(kind=cp),           intent(out) :: determ

       !---- local variables ----!
       real(kind=cp),    dimension(2*n,2*n) :: AC   !real square matrix
       real(kind=cp)                        :: d
       integer                              :: i,nn
       logical                              :: singular

       nn=2*n
       AC(  1:n ,  1:n ) =  real(A(1:n ,1:n))
       AC(n+1:nn,  1:n ) = aimag(A(1:n ,1:n))
       AC(n+1:nn,n+1:nn) =    AC(  1:n ,1:n)
       AC(  1:n ,n+1:nn) =   -AC(n+1:nn,1:n)

       call lu_decomp(ac(1:nn,1:nn),d,singular)

       if (singular) then
          determ=0.0
       else
          determ=0.0
          do i=1,nn
             d=d*sign(1.0_cp,ac(i,i))
             determ=determ+ log(abs(ac(i,i)))
          end do
          determ=d*exp(determ)
       end if

       return
    End Subroutine Determinant_C

    !!--++
    !!--++ Subroutine Determinant_R(A,n,determ)
    !!--++    real(kind=cp), dimension(:,:),intent( in) :: A   (input square matrix (n,n))
    !!--++    integer,                      intent( in) :: n   (actual dimension of A)
    !!--++    real(kind=cp),                intent(out) :: determ  (determinant )
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Calculates the determinant of a real square matrix.
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Determinant_R(A,n,determ)
       !---- Arguments ----!
       real(kind=cp), dimension(:,:), intent( in) :: A
       integer,                       intent( in) :: n
       real(kind=cp),                 intent(out) :: determ

       !---- local variables ----!
       real(kind=cp),    dimension(n,n)  :: AC
       real(kind=cp)                     :: d
       integer                           :: i
       logical                           :: singular

       ac=A(1:n,1:n)
       call lu_decomp(ac,d,singular)

       if (singular) then
          determ=0.0
       else
          determ=0.0
          do i=1,n
             d=d*sign(1.0_cp,ac(i,i))
             determ=determ + log(abs(ac(i,i)))
          end do
          determ=d*exp(determ)
       end if

       return
    End Subroutine Determinant_R

    !!----
    !!---- Subroutine Diagonalize_SH(A,N,E_val,E_vect)
    !!----    complex/real,      dimension(:,:), intent( in)  :: A
    !!----    integer,                           intent( in)  :: n
    !!----    real(kind=cp),     dimension(:),   intent(out)  :: E_val
    !!----    complex, optional, dimension(:,:), intent(out)  :: E_vect
    !!----
    !!----    Diagonalize Symmetric/Hermitian matrices.
    !!----    The eigen_values E_val are sorted in descending order. The columns
    !!----    of E_vect are the corresponding eigenvectors.
    !!----
    !!---- Update: February - 2005
    !!

    !!--++
    !!--++ Subroutine Diagonalize_Herm(a,n,e_val,e_vect)
    !!--++    complex,           dimension(:,:), intent( in)  :: A
    !!--++    integer,                           intent( in)  :: n
    !!--++    real(kind=cp),     dimension(:),   intent(out)  :: E_val
    !!--++    complex, optional, dimension(:,:), intent(out)  :: E_vect
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Diagonalize Hermitian matrices.
    !!--++    The eigen_values E_val are sorted in descending order. The columns
    !!--++    of E_vect are the corresponding eigenvectors.
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Diagonalize_Herm(a,n,e_val,e_vect)
       !---- Arguments ----!
       complex,           dimension(:,:), intent( in)  :: A
       integer,                           intent( in)  :: n
       real(kind=cp),     dimension(:),   intent(out)  :: E_val
       complex, optional, dimension(:,:), intent(out)  :: E_vect

       !---- Local variables ----!
       real(kind=cp),        dimension(2*n,2*n)   :: aux
       real(kind=cp),        dimension(2*n)       :: e,d
       integer :: nn

       e_val=0.0
       call init_err_mathgen()
       if (n > size(A,1) .or. n > size(A,2)) then
          ERR_MathGen=.true.
          ERR_MathGen_Mess=" Diagonalize_HERM: Error in dimension of input matrix: A(m,m) with m < n "
          return
       end if

       nn=2*n
       aux(  1:n ,  1:n ) =  real(a(1:n ,1:n))   !      (  U   V )
       aux(n+1:nn,n+1:nn) =  real(a(1:n ,1:n))   !   M=(          ),   A = U + i V
       aux(n+1:nn,  1:n ) = aimag(a(1:n ,1:n))   !      ( -V   U )
       aux(  1:n ,n+1:nn) =-aimag(a(1:n ,1:n))   !

       if (present(E_vect)) then
          call tred2(aux,nn,d,e)
          call tqli2(d,e,nn,aux)
          call eigsrt(d,aux,nn,1)
          e_vect(1:n,1:n)=cmplx(aux(1:n,1:nn:2),aux(n+1:nn,1:nn:2))
       else
          call tred1(aux,nn,d,e)
          call tqli1(d,e,nn)
          call eigsrt(d,aux,nn,0)
       end if
       e_val(1:n)=d(1:nn:2)

       return
    End Subroutine Diagonalize_Herm

    !!--++
    !!--++ Subroutine Diagonalize_Symm(a,n,e_val,e_vect)
    !!--++    real(kind=cp)            dimension(:,:),intent( in)  :: A      (input matrix with)
    !!--++    integer,                                intent( in)  :: n      (actual dimension)
    !!--++    real(kind=cp),           dimension(:),  intent(out)  :: E_val  (eigenvalues)
    !!--++    real(kind=cp), optional, dimension(:,:),intent(out)  :: E_vect (eigenvectors)
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Diagonalize symmetric matrices
    !!--++    The eigen_values E_val are sorted in descending order. The columns
    !!--++    of E_vect are the corresponding eigenvectors.
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Diagonalize_Symm(A,n,E_Val,E_vect)
       !---- Arguments ----!
       real(kind=cp),           dimension(:,:), intent( in)  :: A
       integer,                                 intent( in)  :: n
       real(kind=cp),           dimension(:),   intent(out)  :: E_val
       real(kind=cp), optional, dimension(:,:), intent(out)  :: E_vect

       !---- Local variables ----!
       real(kind=cp),        dimension(n,n)   :: aux
       real(kind=cp),        dimension(n)     :: e

       e_val=0.0
       call init_err_mathgen()
       if (n > size(A,1) .or. n > size(A,2)) then
          ERR_MathGen=.true.
          ERR_MathGen_Mess=" Diagonalize_SYMM: Error in dimension of input matrix: A(m,m) with m < n "
          return
       end if

       aux=a(1:n,1:n)
       if (present(E_vect)) then
          call tred2(aux,n,E_val,e)
          call tqli2(E_val,e,n,aux)
          call eigsrt(E_val,aux,n,1)
          e_vect(1:n,1:n)=aux
       else
          call tred1(aux,n,E_val,e)
          call tqli1(E_val,e,n)
          call eigsrt(E_val,aux,n,0)
       end if

       return
    End Subroutine Diagonalize_Symm

    !!--++
    !!--++ Subroutine Eigsrt(d,v,n,io)
    !!--++    real(kind=cp), dimension(:),   intent(in out) :: d
    !!--++    real(kind=cp), dimension(:,:), intent(in out) :: v
    !!--++    integer,                       intent (in)    :: n
    !!--++    integer,                       intent (in)    :: io
    !!--++
    !!--++    (PRIVATE)
    !!--++    Subroutine for sorting eigenvalues in d(n) and eigenvectors
    !!--++    in columns of v(n,n). Sorts d(n) in descending order and
    !!--++    rearranges v(n,n) correspondingly. The method is the straight
    !!--++    insertion. If io=0 order  only the eigenvalues are treated.
    !!--++    Adapted from Numerical Recipes. Valid for hermitian matrices
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Eigsrt(d,v,n,io)
       !---- Arguments ----!
       real(kind=cp), dimension(:),   intent(in out) :: d
       real(kind=cp), dimension(:,:), intent(in out) :: v
       integer,                       intent(in)     :: n
       integer,                       intent(in)     :: io

       !---- Local Variables ----!
       integer          :: i,j,k
       real(kind=cp)    :: p

       do i=1,n-1
          k=i
          p=d(i)
          do j=i+1,n
             if (d(j) >= p) then
                k=j
                p=d(j)
             end if
          end do
          if (k /= i) then
             d(k)=d(i)
             d(i)=p
             if (io == 1) then
                do j=1,n
                   p=v(j,i)
                   v(j,i)=v(j,k)
                   v(j,k)=p
                end do
             end if
          end if
       end do

       return
    End Subroutine Eigsrt

    !!----
    !!---- Subroutine First_Derivative(x, y, n, d2y, d1y)
    !!----    real(kind=cp),    intent(in),     dimension(:) :: x     !  In -> Array X
    !!----    real(kind=cp),    intent(in),     dimension(:) :: y     !  In -> Array Yi=F(Xi)
    !!----    integer ,         intent(in)                   :: n     !  In -> Dimension of X, Y
    !!----    real(kind=cp),    intent(in),     dimension(:) :: d2y   !  In -> array containing second derivatives
    !!----                                                                     at the given points
    !!----    real(kind=cp),    intent(out),    dimension(:) :: d1y   ! Out -> array containing first derivatives
    !!----                                                                     at the given points
    !!----
    !!----    Calculate the First derivate values of the N points
    !!----
    !!---- Update: January - 2006
    !!
    Subroutine First_Derivative(x,y,n,d2y,d1y)
       !---- Arguments ----!
       real(kind=cp), dimension(:), intent(in)  :: x
       real(kind=cp), dimension(:), intent(in)  :: y
       integer ,                    intent(in)  :: n
       real(kind=cp), dimension(:), intent(in)  :: d2y
       real(kind=cp), dimension(:), intent(out) :: d1y

       !---- Local Variables ----!
       integer       :: i
       real(kind=cp) :: step, x0, y0, y1, y2

       do i=1,n
         if (i /= n) then
           step = x(i+1)-x(i)
         end if
         x0 = x(i) - step/2.0
         call splint(x,y, d2y, n, x0, y0)
         y1 = y0
         x0 = x(i) + step/2
         call splint(x,y, d2y, n, x0, y0)
         y2 = y0
         d1y(i) = (y2 - y1) / step
       end do

       return
    End Subroutine First_Derivative

    !!----
    !!---- Subroutine In_Sort(id,n,p,q)
    !!----    integer, dimension(:), intent(in) :: id  !Integer array to be sorted
    !!----    integer,               intent(in) :: n   !Number items in the array
    !!----    integer, dimension(:), intent(in) :: p   !Initial pointer from a previous related call
    !!----    integer, dimension(:), intent(out):: q   !Final pointer doing the sort of id
    !!--<<
    !!----    Subroutine to order in ascending mode the integer array "id".
    !!----    The input value "n" is the number of items to be ordered in "id".
    !!----    The array "p" is the initial pointer to "id" (coming from a previous call)
    !!----    The final pointer holding the order of items.
    !!-->>
    !!----
    !!---- Update: November - 2008
    !!
    Subroutine In_Sort(id,n,p,q)
       !---- Arguments ----!
       integer, dimension(:), intent(in) :: id  !Integer array to be sorted
       integer,               intent(in) :: n   !Number items in the array
       integer, dimension(:), intent(in) :: p   !Initial pointer from a previous related call
       integer, dimension(:), intent(out):: q   !Final pointer doing the sort of id

       !--- Local Variables ----!
       integer :: i,j,k,l,m
       integer, dimension(:),allocatable :: it

       l=minval(id)
       m=maxval(id)
       l=l-1
       m=m-l
       allocate(it(m))
       it(1:m)=0
       do i=1,n
          j=id(p(i))-l
          it(j)=it(j)+1
       end do
       j=0
       do i=1,m
          k=j
          j=j+it(i)
          it(i)=k
       end do
       do i=1,n
          j=id(p(i))-l
          it(j)=it(j)+1
          j=it(j)
          q(j)=p(i)
       end do

       return
    End Subroutine In_Sort

    !!----
    !!---- Subroutine Invert_Matrix(a,b,singular,perm)
    !!----    real(kind=cp), dimension(:,:),  intent( in) :: a
    !!----    real(kind=cp), dimension(:,:),  intent(out) :: b
    !!----    LOGICAL,                        intent(out) :: singular
    !!----    integer, dimension(:),optional, intent(out) :: perm
    !!--<<
    !!----    Subroutine to invert a real matrix using LU decomposition.
    !!----    In case of singular matrix (singular=.true.) instead of the inverse
    !!----    matrix, the subroutine provides the LU decomposed matrix as used
    !!----    in Numerical Recipes.
    !!----    The input matrix is preserved and its inverse (or its LU decomposition)
    !!----    is provided in "b". The optional argument "perm" holds the row permutation
    !!----    performed to obtain the LU decomposition.
    !!-->>
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Invert_Matrix(a,b,singular,perm)
       !---- Arguments ----!
       real(kind=cp), dimension(:,:),  intent(in ) :: a
       real(kind=cp), dimension(:,:),  intent(out) :: b
       logical,                        intent(out) :: singular
       integer, dimension(:),optional, intent(out) :: perm

       !---- Local variables ----!
       integer                                       :: i,n
       integer,       dimension(size(a,1))           :: indx
       real(kind=cp)                                 :: d, det
       real(kind=cp), dimension(size(a,1),size(a,1)) :: lu

       n=size(a,1)
       lu=a(1:n,1:n)

       call LU_Decomp(lu,d,singular,indx)
       if (present(perm)) perm(1:n)=indx(1:n)

       if (singular) then
          b=lu
          return
       else
          det=0.0
          do i=1,n
             d=d*sign(1.0_cp,lu(i,i))
             det=det + log(abs(lu(i,i)))
          end do
          det=d*exp(det)
          if (abs(det) <= 1.0e-36) then
             singular=.true.
             b=lu
             return
          end if
       end if

       b=0.0
       do i=1,n
          b(i,i)=1.0
          call LU_backsub(lu,indx,b(:,i))
       end do

       return
    End Subroutine Invert_Matrix

    !!----
    !!---- Subroutine Linear_Dependent(a,na,b,nb,mb,info)
    !!----    complex/integer/real(kind=cp), dimension(:),   intent(in)  :: a
    !!----    complex/integer/real(kind=cp), dimension(:,:), intent(in)  :: b
    !!----    integer,                                       intent(in)  :: na,nb,mb
    !!----    logical,                                       intent(out) :: info
    !!--<<
    !!----    Provides the value .TRUE. if the vector A is linear dependent of the
    !!----    vectors constituting the rows (columns) of the matrix B. In input nb & mb
    !!----    are the number of rows and columns of B to be considered. The actual
    !!----    dimension of vector a should be na=max(nb,mb).
    !!----    The problem is equivalent to determine the rank (in algebraic sense)
    !!----    of the composite matrix C(nb+1,mb)=(B/A) or C(nb,mb+1)=(B|A). In the first
    !!----    case it is supposed that na = mb and in the second na = nb.
    !!----    and the rank of B is min(nb, mb). If na /= nb and na /= mb an error condition
    !!----    is generated. The function uses floating arithmetic for all types.
    !!-->>
    !!----
    !!---- Update: February - 2005
    !!

    !!--++
    !!--++ Subroutine Linear_DependentC(a,na,b,nb,mb,info)
    !!--++    complex, dimension(:),   intent(in)  :: a
    !!--++    complex, dimension(:,:), intent(in)  :: b
    !!--++    integer,                 intent(in)  :: na,nb,mb
    !!--++    logical,                 intent(out) :: info
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Provides the value .TRUE. if the vector A is linear dependent of the
    !!--++    vectors constituting the rows (columns) of the matrix B. In input nb & mb
    !!--++    are the number of rows and columns of B to be considered. The actual
    !!--++    dimension of vector a should be na=max(nb,mb).
    !!--++    The problem is equivalent to determine the rank (in algebraic sense)
    !!--++    of the composite matrix C(nb+1,mb)=(B/A) or C(nb,mb+1)=(B|A). In the first
    !!--++    case it is supposed that na = mb and in the second na = nb.
    !!--++    and the rank of B is min(nb, mb). If na /= nb and na /= mb an error condition
    !!--++    is generated
    !!--++
    !!--++    For the case of complex vectors in Cn the problem can be reduced to real vectors
    !!--++    of dimension R2n. Each complex vector contributes as two real vectors of dimension
    !!--++    2n: (R,I) and (-I,R). A complex vector V is linearly dependent on n complex vectors
    !!--++    if V can be written as: V = Sigma{j=1,n}(Cj.Vj), with Cj complex numbers and Vj
    !!--++    having n complex components. One may write:
    !!--++
    !!--++     V = Sigma{j=1,n}(Cj.Vj)
    !!--++     (R,I) = Sigma{j=1,n} (Cjr Vj + i Cji Vj) = Sigma{j=1,n} (Cjr (Rj,Ij) +  Cji (-Ij,Rj) )
    !!--++     (R,I) = Sigma{j=1,n} (aj (Rj,Ij) + bj (-Ij,Rj) )  = Sigma{j=1,2n} (Aj.Uj)
    !!--++     Were Uj=(Rj,Ij) and U(j+1)= (-Ij,Rj)
    !!--++
    !!--++    The function uses floating arithmetic for all types.
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Linear_DependentC(A,na,B,nb,mb,info)
       !---- Arguments ----!
       complex, dimension(:),   intent(in)  :: a
       complex, dimension(:,:), intent(in)  :: b
       integer,                 intent(in)  :: na,nb,mb
       logical,                 intent(out) :: info

       !---- Local variables ----!
       integer                                                     :: r,n1
       real(kind=dp), parameter                                    :: tol= 100.0_dp*deps
       real(kind=dp), dimension(2*max(nb+1,mb+1),2*max(nb+1,mb+1)) :: c

       c=0.0
       call init_err_mathgen()
       info=.true.
       if (nb > size(b,1) .or. mb > size(b,2) .or. na > size(a) ) then
          ERR_MathGen=.true.
          ERR_MathGen_Mess=" Linear_DependentC: Error in dimension of input matrix or vector"
          return
       end if

       if ( na == mb) then
          n1=2*nb+1
          if(n1+1 > 2*mb) return !the vector is linear dependent
          c(1:nb,           1:mb) =  real(b(1:nb,1:mb))
          c(1:nb,     mb+1:mb+na) = aimag(b(1:nb,1:mb))
          c(nb+1:2*nb,      1:mb) =-aimag(b(1:nb,1:mb))
          c(nb+1:2*nb,mb+1:mb+na) =  real(b(1:nb,1:mb))
          c(n1,             1:mb) =  real(a(1:na))
          c(n1,      mb+1:mb+na ) = aimag(a(1:na))
          c(n1+1,           1:mb) =-aimag(a(1:na))
          c(n1+1,    mb+1:mb+na ) =  real(a(1:na))
          call rank(c,tol,r)
          if(r == min(n1+1,2*mb)) info=.false.
       else if( na == nb) then
          n1=2*mb+1
          if(n1+1 > 2*nb) return !the vector is linear dependent
          c(1:nb,           1:mb) =  real(b(1:nb,1:mb))
          c(nb+1:nb+na,     1:mb) = aimag(b(1:nb,1:mb))
          c(1:nb,      mb+1:2*mb) =-aimag(b(1:nb,1:mb))
          c(nb+1:nb+na,mb+1:2*mb) =  real(b(1:nb,1:mb))
          c(1:na,             n1) =  real(a(1:na))
          c(nb+1:nb+na,       n1) = aimag(a(1:na))
          c(1:na,           1+n1) =-aimag(a(1:na))
          c(nb+1:nb+na,     1+n1) =  real(a(1:na))
          call rank(c,tol,r)
          if(r == min(n1+1,2*nb)) info=.false.
       else
          ERR_MathGen=.true.
          ERR_MathGen_Mess=" Linear_DependentC: input dimension of vector incompatible with matrix"
       end if

       return
    End Subroutine Linear_DependentC

    !!--++
    !!--++ Subroutine Linear_DependentI(a,na,b,nb,mb,info)
    !!--++    integer, dimension(:),   intent(in)  :: a
    !!--++    integer, dimension(:,:), intent(in)  :: b
    !!--++    integer,                 intent(in)  :: na,nb,mb
    !!--++    logical,                 intent(out) :: info
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Provides the value .TRUE. if the vector A is linear dependent of the
    !!--++    vectors constituting the rows (columns) of the matrix B. In input nb & mb
    !!--++    are the number of rows and columns of B to be considered. The actual
    !!--++    dimension of vector a should be na=max(nb,mb).
    !!--++    The problem is equivalent to determine the rank (in algebraic sense)
    !!--++    of the composite matrix C(nb+1,mb)=(B/A) or C(nb,mb+1)=(B|A). In the first
    !!--++    case it is supposed that na = mb and in the second na = nb.
    !!--++    and the rank of B is min(nb, mb). If na /= nb and na /= mb an error condition
    !!--++    is generated
    !!--++    The function uses floating arithmetic for all types.
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Linear_DependentI(A,na,B,nb,mb,info)
       !---- Arguments ----!
       integer, dimension(:),   intent(in)  :: a
       integer, dimension(:,:), intent(in)  :: b
       integer,                 intent(in)  :: na,nb,mb
       logical,                 intent(out) :: info

       !---- Local variables ----!
       integer                                                 :: r,n1
       real(kind=dp), parameter                                :: tol= 100.0_dp*deps
       real(kind=dp), dimension(max(nb+1,mb+1),max(nb+1,mb+1)) :: c

       c=0.0
       call init_err_mathgen()
       info=.true.
       if (nb > size(b,1) .or. mb > size(b,2) .or. na > size(a) ) then
          ERR_MathGen=.true.
          ERR_MathGen_Mess=" Linear_DependentI: Error in dimension of input matrix or vector"
          return
       end if

       if ( na == mb) then
          n1=nb+1
          if(n1 > mb) return !the vector is linear dependent
          c(1:nb,1:mb)=real(b(1:nb,1:mb))
          c(n1,  1:mb)=real(a(1:na))      !C(nb+1,mb)
          call rank(c,tol,r)
          if(r == min(n1,mb)) info=.false.
       else if( na == nb) then
          n1=mb+1
          if(n1 > nb) return !the vector is linear dependent
          c(1:nb,1:mb)=real(b(1:nb,1:mb))
          c(1:nb,  n1)=real(a(1:na))     !C(nb,mb+1)
          call rank(c,tol,r)
          if(r == min(n1,nb)) info=.false.
       else
          ERR_MathGen=.true.
          ERR_MathGen_Mess=" Linear_DependentI: input dimension of vector incompatible with matrix"
       end if

       return
    End Subroutine Linear_DependentI

    !!--++
    !!--++ Subroutine Linear_DependentR(a,na,b,nb,mb,info)
    !!--++    real(kind=cp), dimension(:),   intent(in)  :: a
    !!--++    real(kind=cp), dimension(:,:), intent(in)  :: b
    !!--++    integer,                       intent(in)  :: na,nb,mb
    !!--++    logical,                       intent(out) :: info
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Provides the value .TRUE. if the vector A is linear dependent of the
    !!--++    vectors constituting the rows (columns) of the matrix B. In input nb & mb
    !!--++    are the number of rows and columns of B to be considered. The actual
    !!--++    dimension of vector a should be na=max(nb,mb).
    !!--++    The problem is equivalent to determine the rank (in algebraic sense)
    !!--++    of the composite matrix C(nb+1,mb)=(B/A) or C(nb,mb+1)=(B|A). In the first
    !!--++    case it is supposed that na = mb and in the second na = nb.
    !!--++    and the rank of B is min(nb, mb). If na /= nb and na /= mb an error condition
    !!--++    is generated
    !!--++    The function uses floating arithmetic for all types.
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Linear_DependentR(A,na,B,nb,mb,info)
       !---- Arguments ----!
       real(kind=cp), dimension(:),   intent(in)  :: a
       real(kind=cp), dimension(:,:), intent(in)  :: b
       integer,                       intent(in)  :: na,nb,mb
       logical,                       intent(out) :: info

       !---- Local Variables ----!
       integer                                                 :: r,n1
       real(kind=dp), parameter                                :: tol= 100.0_dp*deps
       real(kind=dp), dimension(max(nb+1,mb+1),max(nb+1,mb+1)) :: c

       c=0.0
       call init_err_mathgen()
       info=.true.
       if (nb > size(b,1) .or. mb > size(b,2) .or. na > size(a) ) then
          ERR_MathGen=.true.
          ERR_MathGen_Mess=" Linear_DependentR: Error in dimension of input matrix or vector"
          return
       end if

       if ( na == mb) then    !Vector added as an additional row
          n1=nb+1
          if(n1 > mb) return !the vector is linear dependent
          c(1:nb,1:mb)=b(1:nb,1:mb)
          c(n1,  1:mb)=a(1:na)      !C(nb+1,mb)
          call rank(c,tol,r)
          if(r == min(n1,mb)) info=.false.
       else if( na == nb) then   !Vector added as an additional column
          n1=mb+1
          if(n1 > nb) return !the vector is linear dependent
          c(1:nb,1:mb)=b(1:nb,1:mb)
          c(1:nb,  n1)=a(1:na)     !C(nb,mb+1)
          call rank(c,tol,r)
          if(r == min(n1,nb)) info=.false.
       else
          ERR_MathGen=.true.
          ERR_MathGen_Mess=" Linear_DependentR: input dimension of vector incompatible with matrix"
       end if

       return
    End Subroutine Linear_DependentR

    !!----
    !!---- Subroutine LU_Backsub(a,indx,b)
    !!----    real(kind=cp),    dimension(:,:),intent(in)     :: a
    !!----    integer,          dimension(:),  intent(in)     :: indx
    !!----    real(kind=cp),    dimension(:),  intent(in out) :: b
    !!--<<
    !!----    Adapted from Numerical Recipes.
    !!----    Solves the set of N linear equations A  X = B. Here the N x N matrix A is input,
    !!----    not as the original matrix A, but rather as its LU decomposition, determined
    !!----    by the routine LU_DECOMP. INDX is input as the permutation vector of length N
    !!----    returned by LU_DECOMP. B is input as the right-hand-side vector B,
    !!----    also of length N, and returns with the solution vector X.
    !!----    A and INDX are not modified by this routine and can be left in place for successive calls
    !!----    with different right-hand sides B. This routine takes into account the possibility that B will
    !!----    begin with many zero elements, so it is efficient for use in matrix inversion.
    !!-->>
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine LU_Backsub(a,indx,b)
       !---- Arguments ----!
       real(kind=cp), dimension(:,:), intent(in)     :: a
       integer,         dimension(:), intent(in)     :: indx
       real(kind=cp),   dimension(:), intent(in out) :: b

       !---- Local Variables ----!
       integer       :: i,ii,ll,n
       real(kind=cp) :: summ

       n=size(a,1)
       ii=0              !When ii is set to a positive value, it will become the index
       do i=1,n          !of the first nonvanishing element of b. We now do
          ll=indx(i)     !the forward substitution. The only new wrinkle is to
          summ=b(ll)     !unscramble the permutation as we go.
          b(ll)=b(i)
          if (ii /= 0) then
             summ=summ-dot_product(a(i,ii:i-1),b(ii:i-1))
          else if(summ /= 0.0) then   !A nonzero element was encountered, so from now on
             ii=i                       !we will have to do the dot product above.
          end if
          b(i)=summ
       end do

       do i=n,1,-1       !Now we do the backsubstitution
          b(i) = (b(i)-dot_product(a(i,i+1:n),b(i+1:n)))/a(i,i)
       end do

       return
    End Subroutine LU_Backsub

    !!----
    !!---- Subroutine LU_Decomp(a,d,singular,indx)
    !!----    real(kind=cp),    dimension(:,:),intent(in out) :: a
    !!----    real(kind=cp),                   intent(out)    :: d
    !!----    logical,                         intent(out)    :: singular
    !!----    integer, dimension(:), optional, intent(out)    :: indx
    !!--<<
    !!----    Subroutine to make the LU decomposition of an input matrix A.
    !!----    The input matrix is destroyed and replaced by a matrix containing
    !!----    in its upper triangular part (plus diagonal) the matrix U. The
    !!----    lower triangular part contains the nontrivial part (Lii=1) of matrix L.
    !!----    The output is rowwise permutation of the initial matrix. The vector INDX
    !!----    recording the row permutation. D is output as +/-1 depending on whether
    !!----    the number of row interchanges was even or odd, respectively.
    !!-->>
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine LU_Decomp(a,d,singular,indx)
       !---- Arguments ----!
       real(kind=cp), dimension(:,:), intent(in out) :: a
       real(kind=cp),                 intent(out)    :: d
       logical,                       intent(out)    :: singular
       integer,  dimension(:), intent(out), optional :: indx

       !---- Local variables ----!
       real(kind=cp), dimension(size(a,1)):: vv  !vv stores the implicit scaling of each row.
       real(kind=cp), parameter           :: vtiny = 1.0e-20_sp !A small number.
       integer                            :: j,imax,n

       singular=.false.
       n=size(a,1)
       d=1.0                      !No row interchanges yet.
       vv=maxval(abs(a),dim=2)    !Loop over rows to get the implicit scaling information.
       if (any(abs(vv) <= vtiny)) then   !There is a row of zeros.
          singular=.true.
          return
       end if
       vv=1.0_sp/vv     !Save the scaling.
       do j=1,n
          imax=(j-1)+imaxloc(vv(j:n)*abs(a(j:n,j)))   !Find the pivot row.
          if (j /= imax) then                         !Do we need to interchange rows?
             call swap(a(imax,:),a(j,:))              !Yes, do so...
             d=-d                                     !...and change the parity of d.
             vv(imax)=vv(j)                           !Also interchange the scale factor.
          end if
          if (present(indx)) indx(j)=imax
          if (abs(a(j,j)) <= vtiny) then !If the pivot element is zero the matrix is singular.
             a(j,j)=vtiny                !(at least to the precision of the algorithm)
             singular=.true.             !For some applications on singular matrices,
             return                      !it is desirable to substitute vtiny for zero.
          end if                         !This is actually the present case
          a(j+1:n,j)=a(j+1:n,j)/a(j,j)                                    !Divide by the pivot element.
          a(j+1:n,j+1:n)=a(j+1:n,j+1:n)-outerprod(a(j+1:n,j),a(j,j+1:n))  !Reduce remaining submatrix.
       end do

       return
    End Subroutine LU_Decomp

    !!----
    !!---- Subroutine Matinv(a,n)
    !!----    real(kind=cp), dimension(:,:),intent(in out) :: a
    !!----    integer     ,                 intent(in)     :: n
    !!----
    !!----  Subroutine for inverting a real square matrix.
    !!----  The input matrix is replaced in output with its inverse.
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Matinv(a,n)
       !---- Arguments ----!
       real(kind=cp), dimension(:,:), intent(in out) :: a
       integer     ,                  intent(in)     :: n

       !---- Local variables ----!
       real(kind=cp)                 :: amax,savec
       integer, dimension(size(a,1)) :: ik,jk
       integer                       :: i,j,k,l

       !---- Subroutine to invert a real matrix ----!
       do k=1,n
          amax=0.0
          do
             do
                do i=k,n
                   do j=k,n
                      if (abs(amax)-abs(a(i,j)) > 0.0) cycle
                      amax=a(i,j)
                      ik(k)=i
                      jk(k)=j
                   end do
                end do
                i=ik(k)
                if (i-k < 0) cycle
                exit
             end do

             if (i-k /= 0) then
                do j=1,n
                   savec=a(k,j)
                   a(k,j)=a(i,j)
                   a(i,j)=-savec
                end do
             end if

             j=jk(k)
             if (j-k < 0) cycle
             exit
          end do

          if (j-k /= 0) then
             do i=1,n
                savec=a(i,k)
                a(i,k)=a(i,j)
                a(i,j)=-savec
             end do
          end if

          do i=1,n
             if (i-k /= 0)  then
                a(i,k)=-a(i,k)/amax
             end if
          end do
          do i=1,n
             do j=1,n
                if (i-k == 0 .or. j-k == 0) cycle
                a(i,j)=a(i,j)+a(i,k)*a(k,j)
             end do
          end do
          do j=1,n
             if (j-k == 0)   cycle
             a(k,j)=a(k,j)/amax
          end do
          a(k,k)=1.0/amax
       end do     !k

       do l=1,n
          k=n-l+1
          j=ik(k)
          if (j-k > 0) then
             do i=1,n
                savec=a(i,k)
                a(i,k)=-a(i,j)
                a(i,j)=savec
             end do
          end if
          i=jk(k)
          if (i-k > 0) then
             do j=1,n
                savec=a(k,j)
                a(k,j)=-a(i,j)
                a(i,j)=savec
             end do
          end if
       end do

       return
    End Subroutine Matinv

    !!--++
    !!--++ Subroutine Partition(A, marker)
    !!--++    character(len=*), dimension(:), intent(in out) :: A
    !!--++    integer,                        intent(out)    :: marker
    !!--++
    !!--++    (Private)
    !!--++    Utilised by Sort_Strings.
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Partition(A, Marker)
       !---- Arguments ----!
       character(len=*), dimension(:), intent(in out) :: A
       integer,                        intent(   out) :: marker

       !---- Local variables ----!
       integer                  :: i, j
       character(len=len(A(1))) :: temp
       character(len=len(A(1))) :: x      ! pivot point

       x = A(1)
       i= 0
       j= size(A) + 1

       do
          j = j-1
          do
             if (A(j) <= x) exit
             j = j-1
          end do
          i = i+1
          do
             if (A(i) >= x) exit
             i = i+1
          end do
          if (i < j) then
             !---- exchange A(i) and A(j)
             temp = A(i)
             A(i) = A(j)
             A(j) = temp
          else if (i == j) then
             marker = i+1
             return
          else
             marker = i
             return
          end if
       end do

       return
    End Subroutine Partition

    !!----
    !!---- Subroutine Points_In_Line2D(X1, XN, N, XP)
    !!----    real(kind=cp), dimension(2),   intent(in)  :: X1   ! Point1 in 2D
    !!----    real(kind=cp), dimension(2),   intent(in)  :: XN   ! PointN in 2D
    !!----    integer,                       intent(in)  :: N    ! Number of Total points
    !!----    real(kind=cp), dimension(:,:), intent(out) :: XP   ! List of points
    !!----
    !!----    The routine calculate N points belonging to the line defined
    !!----    by X1 and Xn with equal distance between them. XP contains
    !!----    X1,X2,.....,XN points.
    !!----
    !!---- Update: April 2008
    !!
    Subroutine Points_In_Line2D(X1, XN, N, XP)
       !---- Arguments ----!
       real(kind=cp), dimension(2),   intent(in)  :: X1   ! Point1 in 2D
       real(kind=cp), dimension(2),   intent(in)  :: XN   ! PointN in 2D
       integer,                       intent(in)  :: N    ! Number of Total points
       real(kind=cp), dimension(:,:), intent(out) :: XP   ! List of points

       !---- Local Variables ----!
       integer :: i
       real(kind=cp)    :: ml,bl,dl,t
       real(kind=cp)    :: a,b,c,d
       real(kind=cp)    :: xa,xb

       xp=0.0

       if (n <= 1) return

       !---- Calculating the distance between two points to
       !---- eliminate rare considerations as the same point
       dl=sqrt( (xn(1)-x1(1))**2 + (xn(2)-x1(2))**2 )
       if (dl <= 0.0001) return

       !---- When N=2 is trivial case ----!
       if (n == 2) then
          xp(:,1)=x1
          xp(:,2)=xn
          return
       end if

       !---- Case 1: Y=cte ----!
       !Xn(2) and X1(2) are equal, then we have a line  with Y=cte
       if (abs(xn(2)-x1(2)) <= 0.0001) then
          dl=abs(xn(1)-x1(1))
          d=dl/real(n-1)
          xp(:,1)=x1
          if (xn(1) > x1(1)) then
             do i=2,n-1
                xp(1,i)=xp(1,i-1)+d
                xp(2,i)=xp(2,1)
             end do
          else
             do i=2,n-1
                xp(1,i)=xp(1,i-1)-d
                xp(2,i)=xp(2,1)
             end do
          end if
          xp(:,n)=xn

          return
       end if

       !---- Case 2: X=cte ----!
       !Xn(1) - X1(1) are equal, then we have a line with X=cte
       if (abs(xn(1)-x1(1)) <= 0.0001) then
          dl=abs(xn(2)-x1(2))
          d=dl/real(n-1)
          xp(:,1)=x1
          if (xn(2) > x1(2)) then
             do i=2,n-1
                xp(1,i)=xp(1,1)
                xp(2,i)=xp(2,i-1)+d
             end do
          else
             do i=2,n-1
                xp(1,i)=xp(1,1)
                xp(2,i)=xp(2,i-1)-d
             end do
          end if
          xp(:,n)=xn

          return
       end if

       !---- Case 3: General case ----!
       ml=(x1(2)-xn(2))/(x1(1)-xn(1))
       bl=x1(2) - (ml * x1(1))

       !---- Distance between X1 and XN ----!
       dl=sqrt( (xn(1)-x1(1))**2 + (xn(2)-x1(2))**2 )

       !---- Creating the list ----!
       a=ml**2 + 1.0
       b=2.0 *( ml*(bl-x1(2)) -x1(1) )

       xp(:,1)=x1
       do i=2,n-1
          t=(dl**2)*((real(i-1)/real(n-1))**2)
          c=(x1(2)-bl)**2 + x1(1)**2 - t

          xa=(-b + sqrt(b**2 - 4.0*a*c))/(2.0*a)
          xb=(-b - sqrt(b**2 - 4.0*a*c))/(2.0*a)
          if (x1(1) <= xa .and. xa <= xn(1)) then
             xp(1,i)=xa
             xp(2,i)=ml*xa+bl
          else
             xp(1,i)=xb
             xp(2,i)=ml*xb+bl
          end if
       end do
       xp(:,n)=xn

       return
    End Subroutine Points_In_Line2D

    !!----
    !!---- Subroutine Rank(a,tol,r)
    !!----    real(sp/dp), dimension(:,:), intent( in) :: a
    !!----    real(sp/dp),                 intent( in) :: tol
    !!----    integer,                     intent(out) :: r
    !!----
    !!----    Computes the rank (in algebraic sense) of the rectangular matrix A.
    !!----
    !!---- Update: February - 2005
    !!

    !!--++
    !!--++ Subroutine Rank_dp(a,tol,r)
    !!--++    real(dp), dimension(:,:), intent( in) :: a
    !!--++    real(dp),                 intent( in) :: tol
    !!--++    integer,                  intent(out) :: r
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Computes the rank (in algebraic sense) of the rectangular matrix A.
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Rank_dp(a,tol,r)
       !---- Arguments ----!
       real(kind=dp), dimension(:,:),intent( in)      :: a
       real(kind=dp),                intent( in)      :: tol
       integer,                      intent(out)      :: r

       !---- Arguments ----!
       real(kind=dp), dimension(size(a,1),size(a,2))  :: u
       real(kind=dp), dimension(size(a,2))            :: w
       real(kind=dp), dimension(size(a,2),size(a,2))  :: v
       integer                                        :: i

       u=a
       call svdcmp(u,w,v)
       if (ERR_MathGen) then
          r=0
       else
          r=0
          do i=1,size(a,2)
             if(w(i) > tol) r=r+1
          end do
       end if

       return
    End Subroutine Rank_dp

    !!--++
    !!--++ Subroutine Rank_sp(a,tol,r)
    !!--++    real(sp), dimension(:,:), intent( in) :: a
    !!--++    real(sp),                 intent( in) :: tol
    !!--++    integer,                  intent(out) :: r
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Computes the rank (in algebraic sense) of the rectangular matrix A.
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Rank_sp(a,tol,r)
       !---- Arguments ----!
       real(kind=sp), dimension(:,:),intent( in)      :: a
       real(kind=sp),                intent( in)      :: tol
       integer,                      intent(out)      :: r

       !---- Local variables ----!
       real(kind=sp), dimension(size(a,1),size(a,2))  :: u
       real(kind=sp), dimension(size(a,2))            :: w
       real(kind=sp), dimension(size(a,2),size(a,2))  :: v
       integer :: i

       u=a
       call svdcmp(u,w,v)
       if (ERR_MathGen) then
          r=0
       else
          r=0
          do i=1,size(a,2)
             if(w(i) > tol) r=r+1
          end do
       end if

       return
    End Subroutine Rank_sp

    !!----
    !!---- Subroutine Second_Derivative(x, y, n, d2y)
    !!----    real(kind=cp),    intent(in),     dimension(n) :: x     !  In -> Array X
    !!----    real(kind=cp),    intent(in),     dimension(n) :: y     !  In -> Array Yi=F(Xi)
    !!----    integer ,         intent(in)                   :: n     !  In -> Dimension of X, Y
    !!----    real(kind=cp),    intent(out),    dimension(n) :: d2y    ! Out -> array containing second derivatives
    !!----                                                                     at the given points
    !!----
    !!----    Calculate the second derivate of N Points
    !!----
    !!---- Update: January - 2006
    !!
    Subroutine Second_Derivative(x,y,n,d2y)
       !---- Arguments ----!
       real(kind=cp), dimension(:), intent(in)  :: x
       real(kind=cp), dimension(:), intent(in)  :: y
       integer ,                    intent(in)  :: n
       real(kind=cp), dimension(:), intent(out) :: d2y

       !---- Local Variables ----!
       integer                     :: i, k
       real(kind=cp), dimension(n) :: u
       real(kind=cp)               :: yp1, ypn, sig, p, qn, un

       yp1=(y(2) - y(1))   / (x(2) - x(1))     ! derivative at point 1
       ypn=(y(n) - y(n-1)) / (x(n) - x(n-1))   ! derivative at point n

       d2y(1)=-0.5
       u(1)=(3.0/(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1)

       do i=2,n-1
          sig=(x(i)-x(i-1))/(x(i+1)-x(i-1))
          p=sig*d2y(i-1)+2.0
          d2y(i)=(sig-1.0)/p
          u(i)=(6.0*((y(i+1)-y(i))/(x(i+1)-x(i))-(y(i)-y(i-1))/(x(i)-x(i-1)))  &
               /(x(i+1)-x(i-1))-sig*u(i-1))/p
       end do

       qn=0.5
       un=(3.0/(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1)))
       d2y(n)=(un-qn*u(n-1))/(qn*d2y(n-1)+1.0)
       do k=n-1,1,-1
          d2y(k)=d2y(k)*d2y(k+1)+u(k)
       end do

       return
    End Subroutine Second_Derivative

    !!----
    !!---- Subroutine SmoothingVec(Y, N, NIter, Ys)
    !!----    real(kind=cp),    dimension(:),           intent(in out) :: Y      !  In Out-> Array to be smoothed
    !!----    integer,                                  intent(in)     :: N      !  In -> Number of points
    !!----    integer,                                  intent(in)     :: NIter  !  In -> Number of iterations
    !!----    real(kind=cp),    dimension(:), optional, intent(out)    :: datY   !  Out-> Array smoothed
    !!----
    !!----    Procedure to smooth the array values
    !!----
    !!---- Update: January - 2006
    !!
    Subroutine SmoothingVec(Y, N, Niter, Ys)
       !---- Arguments ----!
       real(kind=cp),dimension(:),            intent(in out) :: Y
       integer,                               intent(in)     :: n
       integer,                               intent(in)     :: niter
       real(kind=cp),dimension(:), optional,  intent(out)    :: Ys

       !---- Local Variables ----!
       integer                     :: n1, n2
       integer                     :: i, iter
       real(kind=cp), dimension (n):: datYs


       n1 = 4
       n2 = n-3

       do iter = 1 ,niter
          datYs(n1-1)=((Y(n1-2)+Y(n1))*10.0+(Y(n1-3)+Y(n1+1))*5.0+Y(n1+2))/31.0
          datYs(n1-2)=((Y(n1-3)+Y(n1-1))*10.0+Y(n1)*5.0+Y(n1+1))/26.0
          datYs(n1-3)=(Y(n1-2)*10.0+Y(n1-1)*5.0+Y(n1))/16.0

          do i=n1,n2
             datYs(i)=(Y(i-3)+Y(i+3)+5.0*(Y(i-2)+Y(i+2))+10.0*(Y(i-1)+Y(i+1)))/ 32.0
          end do

          datYs(n2+1)=((Y(n2+2)+Y(n2))*10.0+(Y(n2+3)+Y(n2-1))*5.0+Y(n2-2))/31.0
          datYs(n2+2)=((Y(n2+3)+Y(n2+1))*10.0+Y(n2)*5.0+Y(n2-1))/26.0
          datYs(n2+3)=(Y(n2+2)*10.0+Y(n2+1)*5.0+Y(n2))/16.0

          if(present(Ys)) then
             Ys(1:n) = datYs(1:n)
          else
             Y(1:n) = datYs(1:n)
          end if
       end do

       return
    End Subroutine SmoothingVec

    !!---
    !!---- Subroutine Sort(a,n,indx)
    !!----    integer/real(kind=cp)  dimension(:), intent( in) :: a
    !!----    integer,                             intent( in) :: n
    !!----    integer,               dimension(:), intent(out) :: indx
    !!----
    !!----    Sort an array such the a(indx(j)) is in ascending
    !!----    order for j=1,2,...,N.
    !!----
    !!---- Update: February - 2005
    !!

    !!--++
    !!--++ Subroutine Sort_I(Arr,N,Indx)
    !!--++    integer, dimension(:), intent( in) :: arr
    !!--++    integer,               intent( in) :: n
    !!--++    integer, dimension(:), intent(out) :: indx
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Sort an array such the arr(indx(j)) is in ascending
    !!--++    order for j=1,2,...,N.
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Sort_I(arr,n,indx)
       !---- Arguments ----!
       integer, dimension(:), intent(in ) :: arr
       integer              , intent(in ) :: n
       integer, dimension(:), intent(out) :: indx

       !---- Local Variables ----!
       integer, parameter           :: m=7
       integer, parameter           :: nstack=50  !nstack=2log2(n)
       integer, dimension(nstack)   :: istack
       integer                      :: i,indxt,ir,itemp,j,jstack,k,l
       integer                      :: a

       call init_Err_MathGen()
       do j=1,n
          indx(j)=j
       end do

       istack=0
       jstack=0
       l=1
       ir=n
       do
          if (ir-l < m) then
             doext: do j=l+1,ir
                indxt=indx(j)
                a=arr(indxt)
                do i=j-1,1,-1
                   if (arr(indx(i)) <= a)  then
                      indx(i+1)=indxt
                      cycle doext
                   end if
                   indx(i+1)=indx(i)
                end do
                i=0
                indx(i+1)=indxt
             end do doext

             if (jstack == 0) exit
             ir=istack(jstack)
             l=istack(jstack-1)
             jstack=jstack-2
          else
             k=(l+ir)/2
             itemp=indx(k)
             indx(k)=indx(l+1)
             indx(l+1)=itemp
             if (arr(indx(l+1)) > arr(indx(ir)))then
                itemp=indx(l+1)
                indx(l+1)=indx(ir)
                indx(ir)=itemp
             end if
             if (arr(indx(l)) > arr(indx(ir)))then
                itemp=indx(l)
                indx(l)=indx(ir)
                indx(ir)=itemp
             end if
             if (arr(indx(l+1)) > arr(indx(l)))then
                itemp=indx(l+1)
                indx(l+1)=indx(l)
                indx(l)=itemp
             end if
             i=l+1
             j=ir
             indxt=indx(l)
             a=arr(indxt)
             do
                i=i+1
                if (arr(indx(i)) < a)  cycle
                do
                   j=j-1
                   if (arr(indx(j)) > a) cycle
                   exit
                end do
                if (j < i) exit
                itemp=indx(i)
                indx(i)=indx(j)
                indx(j)=itemp
             end do
             indx(l)=indx(j)
             indx(j)=indxt
             jstack=jstack+2
             if (jstack > nstack) then
                ERR_MathGen=.true.
                ERR_MathGen_Mess=" NSTACK too small in SORT"
                return
             end if
             if (ir-i+1 >= j-l) then
                istack(jstack)=ir
                istack(jstack-1)=i
                ir=j-1
             else
                istack(jstack)=j-1
                istack(jstack-1)=l
                l=i
             end if
          end if
       end do

       return
    End Subroutine Sort_I

    !!--++
    !!--++ Subroutine Sort_R(arr,n,indx)
    !!--++    real(kind=cp),dimension(:), intent( in) :: arr
    !!--++    integer,                    intent( in) :: n
    !!--++    integer,      dimension(:), intent(out) :: indx
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Sort an array such the arr(indx(j)) is in ascending
    !!--++    order for j=1,2,...,N.
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Sort_R(arr,n,indx)
       !---- Arguments ----!
       real(kind=cp),dimension(:), intent(in) :: arr
       integer,                    intent(in) :: n
       integer,      dimension(:), intent(out):: indx

       !---- Local Variables ----!
       integer, parameter           :: m=7
       integer, parameter           :: nstack=50  !nstack=2log2(n)
       integer, dimension(nstack)   :: istack
       integer :: i,indxt,ir,itemp,j,jstack,k,l
       real(kind=cp)    :: a

       call init_Err_MathGen()
       do j=1,n
          indx(j)=j
       end do

       istack=0
       jstack=0
       l=1
       ir=n
       do
          if (ir-l < m) then
             doext: do j=l+1,ir
                indxt=indx(j)
                a=arr(indxt)
                do i=j-1,1,-1
                   if (arr(indx(i)) <= a)  then
                      indx(i+1)=indxt
                      cycle doext
                   end if
                   indx(i+1)=indx(i)
                end do
                i=0
                indx(i+1)=indxt
             end do doext

             if (jstack == 0) exit
             ir=istack(jstack)
             l=istack(jstack-1)
             jstack=jstack-2
          else
             k=(l+ir)/2
             itemp=indx(k)
             indx(k)=indx(l+1)
             indx(l+1)=itemp
             if (arr(indx(l+1)) > arr(indx(ir)))then
                itemp=indx(l+1)
                indx(l+1)=indx(ir)
                indx(ir)=itemp
             end if
             if (arr(indx(l)) > arr(indx(ir)))then
                itemp=indx(l)
                indx(l)=indx(ir)
                indx(ir)=itemp
             end if
             if (arr(indx(l+1)) > arr(indx(l)))then
                itemp=indx(l+1)
                indx(l+1)=indx(l)
                indx(l)=itemp
             end if
             i=l+1
             j=ir
             indxt=indx(l)
             a=arr(indxt)
             do
                i=i+1
                if (arr(indx(i)) < a)  cycle
                do
                   j=j-1
                   if (arr(indx(j)) > a) cycle
                   exit
                end do
                if (j < i) exit
                itemp=indx(i)
                indx(i)=indx(j)
                indx(j)=itemp
             end do
             indx(l)=indx(j)
             indx(j)=indxt
             jstack=jstack+2
             if (jstack > nstack) then
                ERR_MathGen=.true.
                ERR_MathGen_Mess=" NSTACK too small in SORT"
                return
             end if
             if (ir-i+1 >= j-l) then
                istack(jstack)=ir
                istack(jstack-1)=i
                ir=j-1
             else
                istack(jstack)=j-1
                istack(jstack-1)=l
                l=i
             end if
          end if
       end do

       return
    End Subroutine Sort_R

    !!---
    !!---- Subroutine Sort_Strings(arr)
    !!----    character(len=*), dimension(:), intent(in out) :: arr
    !!----
    !!----    Sort an array of string
    !!----
    !!---- Update: March - 2005
    !!
    Recursive Subroutine Sort_Strings(Arr)
       !---- Argument ----!
       character(len=*), dimension(:), intent(in out) :: Arr

       !---- Local variables ----!
       integer :: iq

       if (size(Arr) > 1) then
          call Partition(Arr, iq)
          call Sort_Strings(Arr(:iq-1))
          call Sort_Strings(Arr(iq:))
       end if

       return
    End Subroutine Sort_Strings

    !!----
    !!---- Subroutine Spline(x, y, n, yp1, ypn, y2)
    !!----    real(kind=cp),    intent(in),     dimension(n) :: x     !  In -> Array X
    !!----    real(kind=cp),    intent(in),     dimension(n) :: y     !  In -> Array Yi=F(Xi)
    !!----    integer ,         intent(in)                   :: n     !  In -> Dimension of X, Y
    !!----    real(kind=cp),    intent(in)                   :: yp1   !  In -> Derivate of Point 1
    !!----    real(kind=cp),    intent(in)                   :: ypn   !  In -> Derivate of Point N
    !!----    real(kind=cp),    intent(out),    dimension(n) :: y2    ! Out -> array containing second derivatives
    !!----                                                                     at the given points
    !!----    Spline  N points
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Spline(x,y,n,yp1,ypn,y2)
       !---- Arguments ----!
       real(kind=cp), dimension(:), intent(in)  :: x
       real(kind=cp), dimension(:), intent(in)  :: y
       integer ,                    intent(in)  :: n
       real(kind=cp),               intent(in)  :: yp1
       real(kind=cp),               intent(in)  :: ypn
       real(kind=cp), dimension(:), intent(out) :: y2

       !---- Local Variables ----!
       integer                     :: i, k
       real(kind=cp), dimension(n) :: u
       real(kind=cp)               :: sig, p, qn, un

       if (yp1 > 1.0e+30) then
          y2(1)=0.0
          u(1)=0.0
       else
          y2(1)=-0.5
          u(1)=(3.0/(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1)
       end if

       do i=2,n-1
          sig=(x(i)-x(i-1))/(x(i+1)-x(i-1))
          p=sig*y2(i-1)+2.0
          y2(i)=(sig-1.0)/p
          u(i)=(6.0*((y(i+1)-y(i))/(x(i+1)-x(i))-(y(i)-y(i-1))/(x(i)-x(i-1)))  &
               /(x(i+1)-x(i-1))-sig*u(i-1))/p
       end do
       if (ypn > 1.0e+30) then
          qn=0.0
          un=0.0
       else
          qn=0.5
          un=(3.0/(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1)))
       end if
       y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.0)
       do k=n-1,1,-1
          y2(k)=y2(k)*y2(k+1)+u(k)
       end do

       return
    End Subroutine Spline

    !!----
    !!---- Subroutine Splint(x, y, y2, n, xp, yp)
    !!----    real(kind=cp),    intent(in), dimension(n) :: x  !  In -> Array X
    !!----    real(kind=cp),    intent(in), dimension(n) :: y  !  In -> Array Y=F(X)
    !!----    real(kind=cp),    intent(in), dimension(n) :: y2 !  In -> Array Second Derivatives in X
    !!----    integer ,         intent(in)               :: n  !  In -> Dimension of XA,YA,Y2A
    !!----    real(kind=cp),    intent(in)               :: xp !  In -> Point to evaluate
    !!----    real(kind=cp),    intent(out),             :: yp ! Out -> Interpoled value
    !!----
    !!----    Spline Interpolation
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Splint(xa,ya,y2a,n,x,y)
       !---- Arguments ----!
       real(kind=cp), dimension(:), intent(in)  :: xa
       real(kind=cp), dimension(:), intent(in)  :: ya
       real(kind=cp), dimension(:), intent(in)  :: y2a
       integer ,                    intent(in)  :: n
       real(kind=cp),               intent(in)  :: x
       real(kind=cp),               intent(out) :: y

       !---- Local Variables ----!
       integer          :: klo, khi, k
       real(kind=cp)    :: h, a, b

       klo=1
       khi=n
       do
          if (khi-klo > 1) then
             k=(khi+klo)/2
             if (xa(k) > x) then
                khi=k
             else
                klo=k
             end if
             cycle
          else
             exit
          end if
       end do

       h=xa(khi)-xa(klo)
       a=(xa(khi)-x)/h
       b=(x-xa(klo))/h
       y=a*ya(klo)+b*ya(khi)+((a**3-a)*y2a(klo)+(b**3-b)* y2a(khi))*(h**2)/6.0

       return
    End Subroutine Splint

    !!----
    !!---- Subroutine Svdcmp(a,w,v)
    !!----    real(sp/dp),dimension(:,:),intent(in out) :: a  !A(m,n)
    !!----    real(sp/dp),dimension(:),  intent(   out) :: w  !W(n)
    !!----    real(sp/dp),dimension(:,:),intent(   out) :: v  !V(n,n)
    !!--<<
    !!----    Given an M�N matrix A ,this routine computes its singular value decomposition,
    !!----    A = U �W �VT . The matrix U replaces A on output. The diagonal matrix of
    !!----    singular values W is output as the N-dimensional vector w. The N�N matrix V
    !!----    (not the transpose VT )is output as v .
    !!----    Adapted from Numerical Recipes. Valid for arbitrary real matrices
    !!-->>
    !!----
    !!---- Update: February - 2005
    !!

    !!--++
    !!--++ Subroutine Svdcmp_dp(a,w,v)
    !!--++    real(dp),dimension(:,:),intent(in out) :: a  !A(m,n)
    !!--++    real(dp),dimension(:),  intent(   out) :: w  !W(n)
    !!--++    real(dp),dimension(:,:),intent(   out) :: v  !V(n,n)
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Given an M �N matrix A ,this routine computes its singular value decomposition,
    !!--++    A = U �W �VT . The matrix U replaces A on output. The diagonal matrix of
    !!--++    singular values W is output as the N-dimensional vector w. The N�N matrix V
    !!--++    (not the transpose VT )is output as v .
    !!--++    Adapted from Numerical Recipes. Valid for arbitrary real matrices
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Svdcmp_dp(a,w,v)
       !---- Arguments ----!
       real(kind=dp),dimension(:,:),intent(in out) ::a
       real(kind=dp),dimension(:),  intent(   out) ::w
       real(kind=dp),dimension(:,:),intent(   out) ::v

       !---- Local variables ----!
       integer, parameter                          :: num_its=500
       integer                                     ::i,its,j,k,l,m,n,nm
       real(kind=dp)                               ::anorm,c,f,g,h,s,scal,x,y,z
       real(kind=dp),dimension(size(a,1))          ::tempm
       real(kind=dp),dimension(size(a,2))          ::rv1,tempn

       m=size(a,1)
       n=size(a,2)
       call init_err_mathgen()
       if ( .not. (size(v,1) == n .and. size(v,2) == n .and. size(w) == n)) then
          ERR_MathGen = .true.
          ERR_MathGen_Mess = " => Physical dimensions of arguments in SVDcmp_dp are not compatible "
          return
       end if
       g=0.0_dp
       scal=0.0_dp
       do i=1,n
          l=i+1
          rv1(i)=scal*g
          g=0.0_dp
          scal=0.0_dp
          if (i <=m)then
             scal=sum(abs(a(i:m,i)))
             if ( abs(scal) > tiny(1.0_dp) ) then
                a(i:m,i)=a(i:m,i)/scal
                s=dot_product(a(i:m,i),a(i:m,i))
                f=a(i,i)
                g=-sign(sqrt(s),f)
                h=f*g-s
                a(i,i)=f-g
                tempn(l:n)=matmul(a(i:m,i),a(i:m,l:n))/h
                a(i:m,l:n)=a(i:m,l:n)+outerprod(a(i:m,i),tempn(l:n))
                a(i:m,i)=scal*a(i:m,i)
             end if
          end if
          w(i)=scal*g
          g=0.0_dp
          scal=0.0_dp
          if ((i <=m).and.(i /=n))then
             scal=sum(abs(a(i,l:n)))
             if ( abs(scal) > tiny(1.0_dp) ) then
                a(i,l:n)=a(i,l:n)/scal
                s=dot_product(a(i,l:n),a(i,l:n))
                f=a(i,l)
                g=-sign(sqrt(s),f)
                h=f*g-s
                a(i,l)=f-g
                rv1(l:n)=a(i,l:n)/h
                tempm(l:m)=matmul(a(l:m,l:n),a(i,l:n))
                a(l:m,l:n)=a(l:m,l:n)+outerprod(tempm(l:m),rv1(l:n))
                a(i,l:n)=scal*a(i,l:n)
             end if
          end if
       end do
       anorm=maxval(abs(w)+abs(rv1))
       do i=n,1,-1
          if (i <n) then
             if ( abs(g) > tiny(1.0_dp) ) then
                v(l:n,i)=(a(i,l:n)/a(i,l))/g
                tempn(l:n)=matmul(a(i,l:n),v(l:n,l:n))
                v(l:n,l:n)=v(l:n,l:n)+outerprod(v(l:n,i),tempn(l:n))
             end if
             v(i,l:n)=0.0_dp
             v(l:n,i)=0.0_dp
          end if
          v(i,i)=1.0_dp
          g=rv1(i)
          l=i
       end do
       do i=min(m,n),1,-1
          l=i+1
          g=w(i)
          a(i,l:n)=0.0_dp
          if ( abs(g) > tiny(1.0_dp) ) then
             g=1.0_dp/g
             tempn(l:n)=(matmul(a(l:m,i),a(l:m,l:n))/a(i,i))*g
             a(i:m,l:n)=a(i:m,l:n)+outerprod(a(i:m,i),tempn(l:n))
             a(i:m,i)=a(i:m,i)*g
          else
             a(i:m,i)=0.0_dp
          end if
          a(i,i)=a(i,i)+1.0_dp
       end do
       do k=n,1,-1
          do its=1,num_its
             do l=k,1,-1
                nm=l-1
                if ((abs(rv1(l))+anorm)==anorm) exit
                if ((abs(w(nm))+anorm)==anorm) then
                   c=0.0_dp
                   s=1.0_dp
                   do i=l,k
                      f=s*rv1(i)
                      rv1(i)=c*rv1(i)
                      if ((abs(f)+anorm)==anorm)exit
                      g=w(i)
                      h=pythag(f,g)
                      w(i)=h
                      h=1.0_dp/h
                      c=(g*h)
                      s=-(f*h)
                      tempm(1:m)=a(1:m,nm)
                      a(1:m,nm)=a(1:m,nm)*c+a(1:m,i)*s
                      a(1:m,i)=-tempm(1:m)*s+a(1:m,i)*c
                   end do
                   exit
                end if
             end do
             z=w(k)
             if (l ==k)then
                if (z <0.0_dp)then
                   w(k)=-z
                   v(1:n,k)=-v(1:n,k)
                end if
                exit
             end if
             if (its == num_its) then
                ERR_MathGen = .true.
                ERR_MathGen_Mess = " => SVDcmp_dp: convergence not reached ! "
                return
             end if
             x=w(l)
             nm=k-1
             y=w(nm)
             g=rv1(nm)
             h=rv1(k)
             f=((y-z)*(y+z)+(g-h)*(g+h))/(2.0_dp*h*y)
             g=pythag(f,1.0_dp)
             f=((x-z)*(x+z)+h*((y/(f+sign(g,f)))-h))/x
             c=1.0_dp
             s=1.0_dp
             do j=l,nm
                i=j+1
                g=rv1(i)
                y=w(i)
                h=s*g
                g=c*g
                z=pythag(f,h)
                rv1(j)=z
                c=f/z
                s=h/z
                f=(x*c)+(g*s)
                g=-(x*s)+(g*c)
                h=y*s
                y=y*c
                tempn(1:n)=v(1:n,j)
                v(1:n,j)=v(1:n,j)*c+v(1:n,i)*s
                v(1:n,i)=-tempn(1:n)*s+v(1:n,i)*c
                z=pythag(f,h)
                w(j)=z
                if ( abs(z) > tiny(1.0_dp) ) then
                   z=1.0_dp/z
                   c=f*z
                   s=h*z
                end if
                f=(c*g)+(s*y)
                x=-(s*g)+(c*y)
                tempm(1:m)=a(1:m,j)
                a(1:m,j)=a(1:m,j)*c+a(1:m,i)*s
                a(1:m,i)=-tempm(1:m)*s+a(1:m,i)*c
             end do
             rv1(l)=0.0_dp
             rv1(k)=f
             w(k)=x
          end do
       end do

       return
    End Subroutine Svdcmp_dp

    !!--++
    !!--++ Subroutine Svdcmp_sp(a,w,v)
    !!--++    real(sp),dimension(:,:),intent(in out) :: a  !A(m,n)
    !!--++    real(sp),dimension(:),  intent(   out) :: w  !W(n)
    !!--++    real(sp),dimension(:,:),intent(   out) :: v  !V(n,n)
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Given an M �N matrix A ,this routine computes its singular value decomposition,
    !!--++    A = U �W �VT . The matrix U replaces A on output. The diagonal matrix of
    !!--++    singular values W is output as the N-dimensional vector w. The N�N matrix V
    !!--++    (not the transpose VT )is output as v .
    !!--++    Adapted from Numerical Recipes. Valid for arbitrary real matrices
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Svdcmp_sp(a,w,v)
       !---- Arguments ----!
       real(kind=sp),dimension(:,:),intent(in out) :: a
       real(kind=sp),dimension(:),  intent(   out) :: w
       real(kind=sp),dimension(:,:),intent(   out) :: v

       !---- Local variables ----!
       integer, parameter                          :: num_its=500
       integer                                     ::i,its,j,k,l,m,n,nm
       real(kind=sp)                               ::anorm,c,f,g,h,s,scala,x,y,z
       real(kind=sp),dimension(size(a,1))          ::tempm
       real(kind=sp),dimension(size(a,2))          ::rv1,tempn


       m=size(a,1)
       n=size(a,2)
       call init_err_mathgen()
       if ( .not. (size(v,1) == n .and. size(v,2) == n .and. size(w) == n)) then
          ERR_MathGen = .true.
          ERR_MathGen_Mess = " => Physical dimensions of arguments in SVDcmp_sp are not compatible "
          return
       end if
       g=0.0
       scala=0.0
       do i=1,n                        !Householder reduction to bidiagonal form.
          l=i+1
          rv1(i)=scala*g
          g=0.0
          scala=0.0
          if (i <=m)then
             scala=sum(abs(a(i:m,i)))
             if (abs(scala) > tiny(1.0_sp))then
                a(i:m,i)=a(i:m,i)/scala
                s=dot_product(a(i:m,i),a(i:m,i))
                f=a(i,i)
                g=-sign(sqrt(s),f)
                h=f*g-s
                a(i,i)=f-g
                tempn(l:n)=matmul(a(i:m,i),a(i:m,l:n))/h
                a(i:m,l:n)=a(i:m,l:n)+outerprod(a(i:m,i),tempn(l:n))
                a(i:m,i)=scala*a(i:m,i)
             end if
          end if
          w(i)=scala*g
          g=0.0
          scala=0.0
          if ((i <=m).and.(i /=n))then
             scala=sum(abs(a(i,l:n)))
             if (abs(scala) > tiny(1.0_sp))then
                a(i,l:n)=a(i,l:n)/scala
                s=dot_product(a(i,l:n),a(i,l:n))
                f=a(i,l)
                g=-sign(sqrt(s),f)
                h=f*g-s
                a(i,l)=f-g
                rv1(l:n)=a(i,l:n)/h
                tempm(l:m)=matmul(a(l:m,l:n),a(i,l:n))
                a(l:m,l:n)=a(l:m,l:n)+outerprod(tempm(l:m),rv1(l:n))
                a(i,l:n)=scala*a(i,l:n)
             end if
          end if
       end do
       anorm=maxval(abs(w)+abs(rv1))
       do i=n,1,-1                    ! Accumulation of right-hand transformations.
          if (i <n)then
             if (abs(g) > tiny(1.0_sp))then
                v(l:n,i)=(a(i,l:n)/a(i,l))/g   !Double division to avoid possible underflow.
                tempn(l:n)=matmul(a(i,l:n),v(l:n,l:n))
                v(l:n,l:n)=v(l:n,l:n)+outerprod(v(l:n,i),tempn(l:n))
             end if
             v(i,l:n)=0.0
             v(l:n,i)=0.0
          end if
          v(i,i)=1.0
          g=rv1(i)
          l=i
       end do
       do i=min(m,n),1,-1  !Accumulation of left-hand transformations.
          l=i+1
          g=w(i)
          a(i,l:n)=0.0
          if (abs(g) > tiny(1.0_sp))then
             g=1.0_sp/g
             tempn(l:n)=(matmul(a(l:m,i),a(l:m,l:n))/a(i,i))*g
             a(i:m,l:n)=a(i:m,l:n)+outerprod(a(i:m,i),tempn(l:n))
             a(i:m,i)=a(i:m,i)*g
          else
             a(i:m,i)=0.0
          end if
          a(i,i)=a(i,i)+1.0_sp
       end do
       do k=n,1,-1           !Diagonalization of the idiagonal form:Loop over
          do its=1,num_its    !singular values,and over allowed iterations.
             do l=k,1,-1      !Test for splitting.
                nm=l-1        !Note that rv1(1)is always zero,so can never fall through bottom of loop.
                if ((abs(rv1(l))+anorm)==anorm) exit
                if ((abs(w(nm))+anorm)==anorm) then
                   c=0.0       ! Cancellation of rv1(l),if l >1 .
                   s=1.0
                   do i=l,k
                      f=s*rv1(i)
                      rv1(i)=c*rv1(i)
                      if ((abs(f)+anorm)==anorm)exit
                      g=w(i)
                      h=pythag(f,g)
                      w(i)=h
                      h=1.0_sp/h
                      c=(g*h)
                      s=-(f*h)
                      tempm(1:m)=a(1:m,nm)
                      a(1:m,nm)=a(1:m,nm)*c+a(1:m,i)*s
                      a(1:m,i)=-tempm(1:m)*s+a(1:m,i)*c
                   end do
                   exit
                end if
             end do
             z=w(k)
             if (l ==k) then    !Convergence.
                if (z <0.0)then !Singular value is made nonnegative.
                   w(k)=-z
                   v(1:n,k)=-v(1:n,k)
                end if
                exit
             end if
             if (its == num_its) then
                ERR_MathGen = .true.
                ERR_MathGen_Mess = " => SVDcmp_sp: convergence not reached ! "
                return
             end if
             x=w(l)             !Shift from ottom 2-y-2 minor.
             nm=k-1
             y=w(nm)
             g=rv1(nm)
             h=rv1(k)
             f=((y-z)*(y+z)+(g-h)*(g+h))/(2.0_sp*h*y)
             g=pythag(f,1.0_sp)
             f=((x-z)*(x+z)+h*((y/(f+sign(g,f)))-h))/x
             c=1.0  ! Next QR transformation:
             s=1.0
             do j=l,nm
                i=j+1
                g=rv1(i)
                y=w(i)
                h=s*g
                g=c*g
                z=pythag(f,h)
                rv1(j)=z
                c=f/z
                s=h/z
                f=(x*c)+(g*s)
                g=-(x*s)+(g*c)
                h=y*s
                y=y*c
                tempn(1:n)=v(1:n,j)
                v(1:n,j)=v(1:n,j)*c+v(1:n,i)*s
                v(1:n,i)=-tempn(1:n)*s+v(1:n,i)*c
                z=pythag(f,h)
                w(j)=z                 !Rotation can e arbitrary if z =0 .
                if (abs(z) > tiny(1.0_sp) )then
                   z=1.0_sp/z
                   c=f*z
                   s=h*z
                end if
                f=(c*g)+(s*y)
                x=-(s*g)+(c*y)
                tempm(1:m)=a(1:m,j)
                a(1:m,j)=a(1:m,j)*c+a(1:m,i)*s
                a(1:m,i)=-tempm(1:m)*s+a(1:m,i)*c
             end do
             rv1(l)=0.0
             rv1(k)=f
             w(k)=x
          end do
       end do

       return
    End Subroutine Svdcmp_sp

    !!----
    !!---- Subroutine Swap(a,b) or Swap(a,b,mask)
    !!----    integer,real(cp),complex, intent( in out) :: a, b
    !!----      or
    !!----    integer,real(cp),complex, dimension(:), intent( in out) :: a, b
    !!----      or
    !!----    integer,real(cp),complex, dimension(:,:), intent( in out) :: a, b
    !!----      or
    !!----    real(kind=cp),  intent(in out) :: a,b
    !!----    logical,        intent(in)     :: mask
    !!----      or
    !!----    real(kind=cp), dimension(:), intent(in out) :: a,b
    !!----    logical,       dimension(:), intent(in)     :: mask
    !!----      or
    !!----    real(kind=cp), dimension(:,:), intent(in out) :: a,b
    !!----    logical,       dimension(:,:), intent(in)     :: mask
    !!----
    !!----    Swap the contents of a and b, when mask (if given) is true.
    !!----
    !!----
    !!---- Update: February - 2005
    !!

    !!--++
    !!--++ Subroutine Swap_C(a,b)
    !!--++    complex, intent(in out) :: a,b
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Swap the contents of a and b
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Swap_C(a,b)
       !---- Arguments ----!
       complex, intent(in out) :: a
       complex, intent(in out) :: b

       !---- Local variables ----!
       complex :: dum

       dum=a
       a=b
       b=dum

       return
    End Subroutine Swap_C

    !!--++
    !!--++ Subroutine Swap_Cm(A,B)
    !!--++    complex, dimension(:,:), intent(in out) :: a,b
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Swap the contents of a and b
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Swap_Cm(a,b)
       !---- Arguments ----!
       complex, dimension(:,:), intent(in out) :: a
       complex, dimension(:,:), intent(in out) :: b

       !---- Local variables ----!
       complex, dimension(size(a,1),size(a,2)) :: dum

       dum=a
       a=b
       b=dum

       return
    End Subroutine Swap_Cm

    !!--++
    !!--++ Subroutine Swap_Cv(a,b)
    !!--++    complex, dimension(:), intent(in out) :: a,b
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Swap the contents of a and b
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Swap_Cv(a,b)
       !---- Arguments ----!
       complex, dimension(:), intent(in out) :: a
       complex, dimension(:), intent(in out) :: b

       !---- Local variables ----!
       complex, dimension(size(a)) :: dum

       dum=a
       a=b
       b=dum

       return
    End Subroutine Swap_Cv

    !!--++
    !!--++ Subroutine Swap_I(A,B)
    !!--++    integer , intent(in out) :: a,b
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Swap the contents of a and b
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Swap_I(A,B)
       !---- Arguments ----!
       integer , intent(in out) :: a
       integer , intent(in out) :: b

       !---- Local variables ----!
       integer  :: dum

       dum=a
       a=b
       b=dum

       return
    End Subroutine Swap_I

    !!--++
    !!--++ Subroutine Swap_Im(A,B)
    !!--++    integer, dimension(:,:), intent(in out) :: a,b
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Swap the contents of a and b
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Swap_Im(A,B)
       !---- Arguments ----!
       integer, dimension(:,:), intent(in out) :: a
       integer, dimension(:,:), intent(in out) :: b

       !---- Local Variables ----!
       integer, dimension(size(a,1),size(a,2)) :: dum

       dum=a
       a=b
       b=dum

       return
    End Subroutine Swap_Im

    !!--++
    !!--++ Subroutine Swap_Iv(A,B)
    !!--++    integer, dimension(:), intent(in out) :: a,b
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Swap the contents of a and b
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Swap_Iv(A,B)
       !---- Arguments ----!
       integer, dimension(:), intent(in out) :: a
       integer, dimension(:), intent(in out) :: b

       !---- Local Variables ----!
       integer, dimension(size(a)) :: dum

       dum=a
       a=b
       b=dum

       return
    End Subroutine Swap_Iv

    !!--++
    !!--++ Subroutine Swap_R(A,B)
    !!--++    real(kind=cp) , intent(in out) :: a,b
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Swap the contents of a and b
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Swap_R(A,B)
       !---- Arguments ----!
       real(kind=cp), intent(in out) :: a
       real(kind=cp), intent(in out) :: b

       !---- Local variables ----!
       real(kind=cp) :: dum

       dum=a
       a=b
       b=dum

       return
    End Subroutine Swap_R

    !!--++
    !!--++ Subroutine Swap_Rm(A,B)
    !!--++    real(kind=cp), dimension(:,:), intent(in out) :: a,b
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Swap the contents of a and b
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Swap_Rm(A,B)
       !---- Arguments ----!
       real(kind=cp), dimension(:,:), intent(in out) :: a
       real(kind=cp), dimension(:,:), intent(in out) :: b

       !---- Local variables ----!
       real(kind=cp), dimension(size(a,1),size(a,2)) :: dum

       dum=a
       a=b
       b=dum

       return
    End Subroutine Swap_Rm

    !!--++
    !!--++ Subroutine Swap_Rv(A,B)
    !!--++    real(kind=cp), dimension(:), intent(in out) :: a,b
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Swap the contents of a and b
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Swap_Rv(A,B)
       !---- Arguments ----!
       real(kind=cp), dimension(:), intent(in out) :: a
       real(kind=cp), dimension(:), intent(in out) :: b

       !---- Local variables ----!
       real(kind=cp), dimension(size(a)) :: dum

       dum=a
       a=b
       b=dum

       return
    End Subroutine Swap_Rv

    !!--++
    !!--++ Subroutine Masked_Swap_R(A,B,Mask)
    !!--++    real(kind=cp), intent(in out) :: a,b
    !!--++    logical,           intent(in) :: mask
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Swap the contents of a and b if mask=.true.
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Masked_Swap_R(A,B,Mask)
       !---- Arguments ----!
       real(kind=cp), intent(in out) :: a
       real(kind=cp), intent(in out) :: b
       logical,           intent(in) :: mask

       !---- Local Variables ----!
       real(kind=cp) :: swp

       if (mask) then
          swp=a
          a=b
          b=swp
       end if

       return
    End Subroutine Masked_Swap_R

    !!--++
    !!--++ Subroutine Masked_Swap_Rm(A,B,Mask)
    !!--++    real(kind=cp), dimension(:,:),intent(in out) :: a,b
    !!--++    logical,       dimension(:,:),    intent(in) :: mask
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Swap the contents of a and b where mask=.true.
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Masked_Swap_Rm(A,B,Mask)
       !---- Arguments ----!
       real(kind=cp), dimension(:,:), intent(in out) :: a
       real(kind=cp), dimension(:,:), intent(in out) :: b
       logical,       dimension(:,:), intent(in)     :: mask

       !---- Local variables ----!
       real(kind=cp), dimension(size(a,1),size(a,2)) :: swp

       where (mask)
          swp=a
          a=b
          b=swp
       end where

       return
    End Subroutine Masked_Swap_Rm

    !!--++
    !!--++ Subroutine Masked_Swap_Rv(A,B,Mask)
    !!--++    real(kind=cp), dimension(:),intent(in out) :: a,b
    !!--++    logical,       dimension(:),    intent(in) :: mask
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Swap the contents of a and b where mask=.true.
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Masked_Swap_Rv(A,B,Mask)
       !---- Arguments ----!
       real(kind=cp), dimension(:), intent(in out) :: a
       real(kind=cp), dimension(:), intent(in out) :: b
       logical,       dimension(:), intent(in)     :: mask

       !---- Local variables ----!
       real(kind=cp), dimension(size(a))           :: swp

       where (mask)
          swp=a
          a=b
          b=swp
       end where

       return
    End Subroutine Masked_Swap_Rv

    !!--++
    !!--++ Subroutine Tqli1(d,e,n)
    !!--++    real(kind=cp), dimension(:), intent (in out):: d
    !!--++    real(kind=cp), dimension(:), intent (in out):: e
    !!--++    integer,                     intent (in)    :: n
    !!--++
    !!--++    (PRIVATE)
    !!--++    QL-algorithm with implicit shifts, to determine the eigenvalues
    !!--++    and eigenvectors of a real tridiagonal symmetric matrix, or of
    !!--++    a real symmetric matrix previously reduced by tred. D is a vector
    !!--++    with the diagonal elements of the tridiagonal matrix. on output
    !!--++    it returns the eigenvalues. the vector e inputs the subdiagonal
    !!--++    elements of the tridiagonal matrix, with E(1) arbitrary. on
    !!--++    output e is destroyed.
    !!--++    In TLQ1 only the eigenvalues are calculated
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Tqli1(d,e,n)
       !---- Arguments ----!
       real(kind=cp), dimension(:), intent(in out):: d, e ! d(np),e(np)
       integer,                     intent(in )   :: n

       !---- Local variables ----!
       integer      :: i, iter, l, m, mv
       real(kind=cp):: b, c, dd, f, g, p, r, s, comp

       call init_Err_MathGen()
       do i=2,n
          e(i-1)=e(i)
       end do
       e(n)=0.0
       do l=1,n
          iter=0
          do_g : do
             mv=n
             do m=l,n-1
                dd=abs(d(m))+abs(d(m+1))
                comp= abs(e(m))+dd
                if (abs(comp-dd) <= ep_ss) then
                   mv=m
                   exit
                end if
             end do
             m=mv

             if (m /= l) then
                if (iter == 40) then
                   ERR_MathGen=.true.
                   ERR_MathGen_Mess=" Too many iterations in TQLI1"
                   exit
                end if

                iter=iter+1
                g=(d(l+1)-d(l))/(2.0*e(l))
                r=sqrt(g*g+1.0)
                g=d(m)-d(l)+e(l)/(g+sign(r,g))
                s=1.0
                c=1.0
                p=0.0
                do i=m-1,l,-1
                   f=s*e(i)
                   b=c*e(i)
                   r=sqrt(f*f+g*g)
                   e(i+1)=r
                   if (abs(r)  <= ep_ss) then
                      d(i+1)=d(i+1)-p
                      e(m)=0.0
                      cycle do_g
                   end if
                   s=f/r
                   c=g/r
                   g=d(i+1)-p
                   r=(d(i)-g)*s+2.0*c*b
                   p=s*r
                   d(i+1)=g+p
                   g=c*r-b
                end do
                d(l)=d(l)-p
                e(l)=g
                e(m)=0.0
                cycle do_g
             end if
             exit
          end do do_g
       end do

       return
    End Subroutine Tqli1

    !!--++
    !!--++ Subroutine Tqli2(d,e,n,z)
    !!--++    real(kind=cp), dimension(:)  , intent (in out):: d
    !!--++    real(kind=cp), dimension(:)  , intent (in out):: e
    !!--++    integer,                       intent (in)    :: n
    !!--++    real(kind=cp), dimension(:,:), intent (in out):: z
    !!--++
    !!--++    (PRIVATE)
    !!--++    QL-algorithm with implicit shifts, to determine the eigenvalues
    !!--++    and eigenvectors of a real tridiagonal symmetric matrix, or of
    !!--++    a real symmetric matrix previously reduced by tred. D is a vector
    !!--++    with the diagonal elements of the tridiagonal matrix. on output
    !!--++    it returns the eigenvalues. the vector e inputs the subdiagonal
    !!--++    elements of the tridiagonal matrix, with E(1) arbitrary. on
    !!--++    output e is destroyed.
    !!--++    The eigenvectors of the tridiagonal matrix are calculated in TLQ2
    !!--++    by providing the matrix Z  as the identity matrix on input. if the
    !!--++    eigenvectors of the matrix reduced by tred are required, then Z
    !!--++    is input as the matrix output of tred. in either cased, the k-th
    !!--++    column of Z returns the mormalized eigenvector corresponding to
    !!--++    D(k).
    !!--++
    !!--++  Update: February - 2005
    !!
    Subroutine Tqli2(d,e,n,z)
       !---- Arguments ----!
       real(kind=cp), dimension(:),   intent(in out) :: d, e ! d(np),e(np)
       integer,                       intent(in )    :: n
       real(kind=cp), dimension(:,:), intent(in out) :: z    ! z(np,np)

       !---- Local Variables ----!
       integer       :: i, iter, k, l, m, mv
       real(kind=cp) :: b, c, dd, f, g, p, r, s, comp

       call init_Err_MathGen()
       do i=2,n
          e(i-1)=e(i)
       end do

       e(n)=0.0
       do l=1,n
          iter=0
          do_g: do
             mv=n
             do m=l,n-1
                dd=abs(d(m))+abs(d(m+1))
                comp= abs(e(m))+dd
                if (abs(comp-dd) <= ep_ss) then
                   mv=m
                   exit
                end if
             end do
             m=mv
             if (m /= l) then
                if (iter == 40) then
                   ERR_MathGen=.true.
                   ERR_MathGen_Mess=" Too many iterations in TQLI2"
                   exit
                end if

                iter=iter+1
                g=(d(l+1)-d(l))/(2.0*e(l))
                r=sqrt(g*g+1.0)
                g=d(m)-d(l)+e(l)/(g+sign(r,g))
                s=1.0
                c=1.0
                p=0.0
                do i=m-1,l,-1
                   f=s*e(i)
                   b=c*e(i)
                   r=sqrt(f*f+g*g)
                   e(i+1)=r
                   if (abs(r) <= ep_ss) then
                      d(i+1)=d(i+1)-p
                      e(m)=0.0
                      cycle do_g
                   end if
                   s=f/r
                   c=g/r
                   g=d(i+1)-p
                   r=(d(i)-g)*s+2.0*c*b
                   p=s*r
                   d(i+1)=g+p
                   g=c*r-b

                   !---- omit lines from here ...
                   do k=1,n
                      f=z(k,i+1)
                      z(k,i+1)=s*z(k,i)+c*f
                      z(k,i)=c*z(k,i)-s*f
                   end do

                   !---- ... to here when finding only eigenvalues.
                end do
                d(l)=d(l)-p
                e(l)=g
                e(m)=0.0
                cycle do_g
             end if
             exit
          end do do_g
       end do

       return
    End Subroutine Tqli2

    !!--++
    !!--++ Subroutine Tred1(a,n,d,e)
    !!--++    real(kind=cp), dimension(:,:), intent (in out):: a
    !!--++    integer,                       intent (in)    :: n
    !!--++    real(kind=cp), dimension(:)  , intent (in out):: d
    !!--++    real(kind=cp), dimension(:)  , intent (in out):: e
    !!--++
    !!--++    (PRIVATE)
    !!--++    Subroutine for preparing the matrix to find only eigenvalues
    !!--++    Householder reduction of a real symetric nxn matrix A.
    !!--++    On output A is replaced by the orthogonal matrix Q effecting
    !!--++    the transformation. D returns the diagonal elements of the tri-
    !!--++    diagonal matrix and E the off-diagonal elements with E(1)=0.
    !!--++    In tred1 several lines have been deleted and A contains no
    !!--++    useful information on output.
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Tred1(a,n,d,e)
       !---- Arguments ----!
       real(kind=cp), dimension(:,:), intent(in out) :: a    ! a(np,np)
       integer,                       intent(in)     :: n
       real(kind=cp), dimension(:),   intent(in out) :: d, e ! d(np),e(np)

       !---- Local Variables ----!
       integer :: i, j, k, l
       real(kind=cp)    :: f, g, h, hh, scala

       do i=n,2,-1
          l=i-1
          h=0.0
          scala=0.0
          if (l > 1)then
             do k=1,l
                scala=scala+abs(a(i,k))
             end do
             if (abs(scala) <= ep_ss) then
                e(i)=a(i,l)
             else
                do k=1,l
                   a(i,k)=a(i,k)/scala
                   h=h+a(i,k)**2
                end do
                f=a(i,l)
                g=-sign(sqrt(h),f)
                e(i)=scala*g
                h=h-f*g
                a(i,l)=f-g
                f=0.0
                do j=1,l
                   g=0.0
                   do k=1,j
                      g=g+a(j,k)*a(i,k)
                   end do
                   do k=j+1,l
                      g=g+a(k,j)*a(i,k)
                   end do
                   e(j)=g/h
                   f=f+e(j)*a(i,j)
                end do
                hh=f/(h+h)
                do j=1,l
                   f=a(i,j)
                   g=e(j)-hh*f
                   e(j)=g
                   do k=1,j
                      a(j,k)=a(j,k)-f*e(k)-g*a(i,k)
                   end do
                end do
             end if
          else
             e(i)=a(i,l)
          end if
          d(i)=h
       end do

       e(1)=0.0
       do i=1,n
          d(i)=a(i,i)
       end do

       return
    End Subroutine Tred1

    !!--++
    !!--++ Subroutine Tred2(a,n,d,e)
    !!--++    real(kind=cp), dimension(:,:), intent (in out) :: a
    !!--++    integer,                       intent (in)     :: n
    !!--++    real(kind=cp), dimension(:)  , intent (in out) :: d
    !!--++    real(kind=cp), dimension(:)  , intent (in out) :: e
    !!--++
    !!--++    (PRIVATE)
    !!--++    Subroutine for preparing the matrix to find the complete set
    !!--++    of eigenvectors.
    !!--++    Householder reduction of a real symetric nxn matrix A.
    !!--++    On output A is replaced by the orthogonal matrix Q effecting
    !!--++    the transformation. D returns the diagonal elements of the tri-
    !!--++    diagonal matrix and E the off-diagonal elements with E(1)=0.
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Tred2(a,n,d,e)
       !---- Arguments ----!
       real(kind=cp), dimension(:,:), intent(in out) :: a    ! a(np,np)
       integer,                       intent(in)     :: n
       real(kind=cp), dimension(:),   intent(in out) :: d, e ! d(np),e(np)

       !---- Local variables ----!
       integer :: i, j, k, l
       real(kind=cp)    :: f, g, h, hh, scala

       do i=n,2,-1
          l=i-1
          h=0.0
          scala=0.0
          if (l > 1)then
             do k=1,l
                scala=scala+abs(a(i,k))
             end do
             if (abs(scala) <= ep_ss) then
                e(i)=a(i,l)
             else
                do k=1,l
                   a(i,k)=a(i,k)/scala
                   h=h+a(i,k)**2
                end do
                f=a(i,l)
                g=-sign(sqrt(h),f)
                e(i)=scala*g
                h=h-f*g
                a(i,l)=f-g
                f=0.0
                do j=1,l
                   !---- omit following line if finding only eigenvalues
                   a(j,i)=a(i,j)/h
                   g=0.0
                   do k=1,j
                      g=g+a(j,k)*a(i,k)
                   end do
                   do k=j+1,l
                      g=g+a(k,j)*a(i,k)
                   end do
                   e(j)=g/h
                   f=f+e(j)*a(i,j)
                end do
               hh=f/(h+h)
                do j=1,l
                   f=a(i,j)
                   g=e(j)-hh*f
                   e(j)=g
                   do k=1,j
                      a(j,k)=a(j,k)-f*e(k)-g*a(i,k)
                   end do
                end do
             end if
          else
             e(i)=a(i,l)
          end if
          d(i)=h
       end do

       !---- omit following line if finding only eigenvalues.
       d(1)=0.0
       e(1)=0.0
       do i=1,n
          !---- delete lines from here ...
          l=i-1
          if (abs(d(i)) > ep_ss)then
             do j=1,l
                g=0.0
                do k=1,l
                   g=g+a(i,k)*a(k,j)
                end do
                do k=1,l
                   a(k,j)=a(k,j)-g*a(k,i)
                end do
             end do
          end if
          !---- ... to here when finding only eigenvalues.
          d(i)=a(i,i)
          !---- also delete lines from here ...
          a(i,i)=1.0
          do j=1,l
             a(i,j)=0.0
             a(j,i)=0.0
          end do
          !---- ... to here when finding only eigenvalues.
       end do

       return
    End Subroutine Tred2

 End Module CFML_Math_General

!!-------------------------------------------------------
!!---- Crystallographic Fortran Modules Library (CrysFML)
!!-------------------------------------------------------
!!---- The CrysFML project is distributed under LGPL. In agreement with the
!!---- Intergovernmental Convention of the ILL, this software cannot be used
!!---- in military applications.
!!----
!!---- Copyright (C) 1999-2012  Institut Laue-Langevin (ILL), Grenoble, FRANCE
!!----                          Universidad de La Laguna (ULL), Tenerife, SPAIN
!!----                          Laboratoire Leon Brillouin(LLB), Saclay, FRANCE
!!----
!!---- Authors: Juan Rodriguez-Carvajal (ILL)
!!----          Javier Gonzalez-Platas  (ULL)
!!----
!!---- Contributors: Laurent Chapon     (ILL)
!!----               Marc Janoschek     (Los Alamos National Laboratory, USA)
!!----               Oksana Zaharko     (Paul Scherrer Institute, Switzerland)
!!----               Tierry Roisnel     (CDIFX,Rennes France)
!!----               Eric Pellegrini    (ILL)
!!----
!!---- This library is free software; you can redistribute it and/or
!!---- modify it under the terms of the GNU Lesser General Public
!!---- License as published by the Free Software Foundation; either
!!---- version 3.0 of the License, or (at your option) any later version.
!!----
!!---- This library is distributed in the hope that it will be useful,
!!---- but WITHOUT ANY WARRANTY; without even the implied warranty of
!!---- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
!!---- Lesser General Public License for more details.
!!----
!!---- You should have received a copy of the GNU Lesser General Public
!!---- License along with this library; if not, see <http://www.gnu.org/licenses/>.
!!----
!!----
!!---- MODULE: CFML_String_Utilities
!!----   INFO: Manipulation of strings with alfanumeric characters
!!----
!!---- HISTORY
!!----    Update: November - 2007
!!----            October - 1999: Reorder the subroutines and functions
!!----                            All routines have general I/O parameters
!!----
!!---- DEPENDENCIES
!!--++    Use CFML_GlobalDeps,    only: cp
!!--++    Use CFML_Math_General, only: Negligible Zbelong
!!----
!!---- VARIABLES
!!--++    CTAB                    [Private]
!!--++    DIGIT                   [Private]
!!----    ERR_String_Mess
!!----    ERR_STRING
!!----    ERR_TEXT_TYPE
!!--++    IENDFMT                 [Private]
!!----    IERR_FMT
!!--++    IERRCHARBEGG            [Private]
!!--++    IERREFRMT               [Private]
!!--++    IERREOF                 [Private]
!!--++    IERREMPTYFIELD          [Private]
!!--++    IERRFIELDTYPE           [Private]
!!--++    IERRFIELDS              [Private]
!!--++    IERRINVALC              [Private]
!!--++    IERRINVALCHAR           [Private]
!!--++    IERRINVALFIELD          [Private]
!!--++    IERRIO                  [Private]
!!--++    IERRNONE                [Private]
!!--++    IERRNUMBER              [Private]
!!--++    IERRSEPMISS             [Private]
!!--++    IERRSTRLENGTH           [Private]
!!--++    IINTE                   [Private]
!!--++    IREAL                   [Private]
!!--++    I_NINE                  [Private]
!!--++    I_ONE                   [Private]
!!--++    I_ZERO                  [Private]
!!--++    LINE_NB                 [Private]
!!----    MESS_FINDFMT
!!----
!!---- PROCEDURES
!!----    Functions:
!!----       EQUAL_SETS_TEXT
!!----       L_CASE
!!----       PACK_STRING
!!----       RFORMAT
!!----       STRING_COUNT
!!----       STRIP_STRING
!!----       U_CASE
!!----
!!----    Subroutines:
!!--++       BUILDFMT             [Private]
!!----       CUTST
!!----       FINDFMT
!!--++       FINDFMT_ERR          [Private]
!!----       FRAC_TRANS_1DIG
!!----       FRAC_TRANS_2DIG
!!----       GET_BASENAME
!!----       GET_DIRNAME
!!----       GET_EXTENSION
!!----       GET_FRACTION_1DIG
!!----       GET_FRACTION_2DIG
!!----       GET_LOGUNIT
!!----       GET_MAT_FROM_SYMB
!!----       GET_NUM_STRING
!!----       GET_SEPARATOR_POS
!!----       GET_SUBSTRING_POSITIONS
!!----       GET_TRANSF
!!----       GETNUM
!!----       GETNUM_STD
!!----       GETWORD
!!----       INC_LINENUM
!!----       INIT_ERR_STRING
!!----       INIT_FINDFMT
!!----       LCASE
!!----       NUMBER_LINES
!!----       NUMCOL_FROM_NUMFMT
!!----       READ_FRACT           [Private]
!!----       READ_KEY_STR
!!----       READ_KEY_STRVAL
!!----       READ_KEY_VALUE
!!----       READ_KEY_VALUESTD
!!----       READING_LINES
!!----       SETNUM_STD
!!--++       SGETFTMFIELD         [Private]
!!----       SSTRING_REPLACE
!!--++       TREATMCHARFIELD      [Private]
!!--++       TREATNUMERFIELD      [Private]
!!----       UCASE
!!----
!!
 Module CFML_String_Utilities
    !---- Use Modules ----!
    use CFML_GlobalDeps,   only: cp, ops_sep
    use CFML_Math_General, only: Negligible, Zbelong

    implicit none

    private

    !---- List of public functions ----!
    public :: Equal_Sets_Text, L_Case, Pack_String, U_Case, Strip_String, String_Count, RFormat

    !---- List of public subroutines ----!
    public :: Cutst, Get_Basename, Get_Dirname, Get_Fraction_1Dig, Get_Fraction_2Dig, Getnum, Getnum_std,   &
              Getword, Init_err_String, lcase, Number_lines, Read_Key_str, Read_Key_strVal, Read_Key_Value, &
              Read_Key_ValueSTD, Reading_Lines, Setnum_std, Ucase, FindFmt, Init_FindFmt, Frac_Trans_1Dig,  &
              Frac_Trans_2Dig, get_logunit, NumCol_from_NumFmt, Inc_LineNum, Get_Separator_Pos,             &
              Get_Extension, Get_Mat_From_Symb, Get_Transf, Get_Num_String, SString_Replace,                &
              Get_Substring_Positions

    !---- List of private subroutines ----!
    private :: BuildFmt, TreatNumerField, TreatMCharField, SgetFtmField, FindFmt_Err,Read_Fract


    !---- Definitions ----!

    !!--++
    !!--++ CTAB
    !!--++    character (len=*), private, parameter :: cTab=Char(9)
    !!--++
    !!--++    (PRIVATE)
    !!--++    Character parameter for TAB
    !!--++
    !!--++ Update: February - 2005
    !!
    character (len=*), private, parameter :: cTab=Char(9)

    !!--++
    !!--++ DIGIT
    !!--++    character (len=*), private, parameter :: digit="0123456789.-"
    !!--++
    !!--++    (PRIVATE)
    !!--++    Character parameter for numbers
    !!--++
    !!--++ Update: February - 2005
    !!
    character (len=*), private, parameter :: digit="0123456789.-"

    !!----
    !!---- ERR_STRING
    !!----    logical :: err_string
    !!----
    !!----    Logical Variable indicating an error in CFML_String_Utilities module
    !!----
    !!---- Update: February - 2005
    !!
    logical, public :: err_string

    !!----
    !!---- ERR_String_Mess
    !!----    character(len=150) :: ERR_String_Mess
    !!----
    !!----    String containing information about the last error
    !!----
    !!---- Update: February - 2005
    !!
    character(len=150), public :: ERR_String_Mess

    !!----
    !!---- TYPE :: ERR_TEXT_TYPE
    !!--..
    !!---- Type :: Err_Text_Type
    !!----    integer :: nlines
    !!----    character (len=132), dimension(5) :: txt
    !!---- End Type Err_Text_Type
    !!----
    !!---- Update: February - 2005
    !!
    Type, Public :: Err_Text_Type
       integer :: nlines
       character (len=132), dimension(5) :: txt
    End Type Err_Text_Type

    !!--++
    !!--++ IENDFMT
    !!--++    integer, paramater, private :: iEndFMT=0
    !!--++
    !!--++    (PRIVATE)
    !!--++    Integer parameter for EndFMT
    !!--++
    !!--++ Update: February - 2005
    !!
    Integer , private, parameter :: iEndFMT=0

    !!----
    !!---- IERR_FMT
    !!----    integer :: ierr_fmt
    !!----
    !!----    Integer signaling if an error has occurred (/=0) in using the procedure findFMT
    !!----
    !!---- Update: February - 2005
    !!
    integer, public :: iErr_fmt  ! Error code value (should be normally = 0)

    !!--++
    !!--++ IERRCHARBEGG
    !!--++    integer, paramater, private :: iErrCharBegg=4
    !!--++
    !!--++    (PRIVATE)
    !!--++    Integer parameter for Error code
    !!--++
    !!--++ Update: February - 2005
    !!
    Integer , private, parameter :: iErrCharBegg=4

    !!--++
    !!--++ IERREFRMT
    !!--++    integer, paramater, private :: iErrEfrmt=11
    !!--++
    !!--++    (PRIVATE)
    !!--++    Integer parameter for Error code
    !!--++
    !!--++ Update: February - 2005
    !!
    Integer , private, parameter  :: iErrEfrmt=11

    !!--++
    !!--++ IERREOF
    !!--++    integer, paramater, private :: iErrEof=-1
    !!--++
    !!--++    (PRIVATE)
    !!--++    Integer parameter for Error code
    !!--++
    !!--++ Update: February - 2005
    !!
    Integer , private, parameter :: iErrEof=-1

    !!--++
    !!--++ IERREMPTYFIELD
    !!--++    integer, paramater, private :: iErrEmptyField=8
    !!--++
    !!--++    (PRIVATE)
    !!--++    Integer parameter for Error code
    !!--++
    !!--++ Update: February - 2005
    !!
    Integer , private, parameter :: iErrEmptyField=8

    !!--++
    !!--++ IERRFIELDTYPE
    !!--++    integer, paramater, private :: iErrFieldType=3
    !!--++
    !!--++    (PRIVATE)
    !!--++    Integer parameter for Error code
    !!--++
    !!--++ Update: February - 2005
    !!
    Integer , private, parameter  :: iErrFieldType=3

    !!--++
    !!--++ IERRFIELDS
    !!--++    integer, paramater, private :: iErrFields=1
    !!--++
    !!--++    (PRIVATE)
    !!--++    Integer parameter for Error code
    !!--++
    !!--++ Update: February - 2005
    !!
    Integer , private, parameter  :: iErrFields=1

    !!--++
    !!--++ IERRINVALC
    !!--++    integer, paramater, private :: iErrInvalC=5
    !!--++
    !!--++    (PRIVATE)
    !!--++    Integer parameter for Error code
    !!--++
    !!--++ Update: February - 2005
    !!
    Integer , private, parameter :: iErrInvalC=5

    !!--++
    !!--++ IERRINVALCHAR
    !!--++    integer, paramater, private :: iErrInvalChar=7
    !!--++
    !!--++    (PRIVATE)
    !!--++    Integer parameter for Error code
    !!--++
    !!--++ Update: February - 2005
    !!
    Integer , private, parameter :: iErrInvalChar=7

    !!--++
    !!--++ IERRINVALFIELD
    !!--++    integer, paramater, private :: iErrInvalField=6
    !!--++
    !!--++    (PRIVATE)
    !!--++    Integer parameter for Error code
    !!--++
    !!--++ Update: February - 2005
    !!
    Integer , private, parameter  :: iErrInvalField=6

    !!--++
    !!--++ IERRIO
    !!--++    integer, paramater, private :: iErrIO=2
    !!--++
    !!--++    (PRIVATE)
    !!--++    Integer parameter for Error code
    !!--++
    !!--++ Update: February - 2005
    !!
    Integer , private, parameter :: iErrIO=2

    !!--++
    !!--++ IERRNONE
    !!--++    integer, paramater, private :: iErrNone=0
    !!--++
    !!--++    (PRIVATE)
    !!--++    Integer parameter for Error code
    !!--++
    !!--++ Update: February - 2005
    !!
    Integer , private, parameter :: iErrNone=0

    !!--++
    !!--++ IERRNUMBER
    !!--++    integer, paramater, private :: iErrNumber=12
    !!--++
    !!--++    (PRIVATE)
    !!--++    Integer parameter for Error code
    !!--++
    !!--++ Update: February - 2005
    !!
    Integer , private, parameter :: iErrNumber=12

    !!--++
    !!--++ IERRSEPMISS
    !!--++    integer, paramater, private :: iErrSepMiss=10
    !!--++
    !!--++    (PRIVATE)
    !!--++    Integer parameter for Error code
    !!--++
    !!--++ Update: February - 2005
    !!
    Integer , private, parameter :: iErrSepMiss=10

    !!--++
    !!--++ iErrStrLength
    !!--++    integer, paramater, private :: iErrStrLength=9
    !!--++
    !!--++    (PRIVATE)
    !!--++    Integer parameter for Error code
    !!--++
    !!--++ Update: February - 2005
    !!
    Integer , private, parameter :: iErrStrLength=9

    !!--++
    !!--++ IINTE
    !!--++    integer, paramater, private :: iInte=-1
    !!--++
    !!--++    (PRIVATE)
    !!--++    Integer parameter for iInte
    !!--++
    !!--++ Update: February - 2005
    !!
    Integer , private, parameter :: iInte=-1

    !!--++
    !!--++ IREAL
    !!--++    integer, paramater, private :: iReal=-2
    !!--++
    !!--++    (PRIVATE)
    !!--++    Integer parameter for iReal
    !!--++
    !!--++ Update: February - 2005
    !!
    Integer , private, parameter :: iReal=-2

    !!--++
    !!--++ I_NINE
    !!--++    integer, paramater, private :: i_Nine=57
    !!--++
    !!--++    (PRIVATE)
    !!--++    Integer parameter for ASCII code for Nine
    !!--++
    !!--++ Update: February - 2005
    !!
    Integer , private, parameter :: i_Nine=57

    !!--++
    !!--++ I_ONE
    !!--++    integer, paramater, private :: i_One=49
    !!--++
    !!--++    (PRIVATE)
    !!--++    Integer parameter for ASCII code for One
    !!--++
    !!--++ Update: February - 2005
    !!
    Integer , private, parameter :: i_One=49

    !!--++
    !!--++ I_ZERO
    !!--++    integer, paramater, private :: i_Zero=48
    !!--++
    !!--++    (PRIVATE)
    !!--++    Integer parameter for ASCII code for Zero
    !!--++
    !!--++ Update: February - 2005
    !!
    Integer , private, parameter :: i_Zero=48

    !!--++
    !!--++ LINE_NB
    !!--++    integer :: Line_Nb
    !!--++
    !!--++    (PRIVATE)
    !!--++    Line number updated each time the procedure findFMT is called
    !!--++    To initialize LINE_NB, the subroutine Init_FindFMT should be called.
    !!--++
    !!--++ Update: February - 2005
    !!
    Integer, private :: Line_Nb   ! Line number

    !!----
    !!---- MESS_FINDFMT
    !!----    Type (Err_Text_Type) :: Mess_FindFMT
    !!----
    !!----    Text composed of a maximum of 5 lines to inform about position or error
    !!----    in free format reading (used by procedure findFMT)
    !!----
    !!---- Update: February - 2005
    !!
    Type (Err_Text_Type), public :: Mess_FindFMT = Err_Text_Type(0,(/" "," "," "," "," "/))

 Contains

    !-------------------!
    !---- Functions ----!
    !-------------------!

    !!----
    !!---- Logical Function Equal_Sets_Text(Text1,N1,Text2,N2) Result(Equal_sets_texto)
    !!----    character(len=*), dimension(:), intent(in) :: Text1   ! In -> String array
    !!----    integer,                        intent(in) :: N1      ! In -> Lines on Text1 variable
    !!----    character(len=*), dimension(:), intent(in) :: Text2   ! In -> String array
    !!----    integer,                        intent(in) :: N2      ! In -> Lines on Text2 variable
    !!----    logical                                    :: Equal_Sets_Texto
    !!----
    !!----    Determine if two sets of text lines are equal irrespective of the
    !!----    order of the lines. The function is true if the two sets of text
    !!----    have the same lines in whatever order.  Two lines are equal only
    !!----    if they have the same length and all their component characters
    !!----    are equal and in the same order.
    !!----
    !!---- Update: February - 2005
    !!
    Function Equal_Sets_Text(text1,n1,text2,n2) result(Equal_sets_texto)
       !---- Arguments ----!
       character(len=*), dimension(:), intent(in) :: text1,text2
       integer,                        intent(in) :: n1,n2
       logical                                    :: Equal_sets_texto

       !---- Local variables ----!
       integer :: i,j
       logical :: info

       Equal_sets_texto=.false.

       if (n1 /= n2) return
       if (len(text1) /= len(text2)) return

       do i=1,n1
          info=.false.
          do j=1,n2
             if (text1(i) == text2(j)) then
                info=.true.
                exit
             end if
          end do
          if (.not. info) return
       end do

       Equal_sets_texto=.true.

       return
    End Function Equal_Sets_Text

    !!----
    !!---- Character Function L_Case(Text) Result (Mtext)
    !!----    character (len=*), intent(in) :: text   !  In -> String: "InPUT Line"
    !!----    character (len=len(text))     :: mtex   ! Out -> String: "input line"
    !!----
    !!----    Conversion to lower case, text is not modified
    !!----
    !!---- Update: February - 2005
    !!
    Function L_Case(Text) Result (Mtext)
       !---- Argument ----!
       character (len=*), intent(in) :: text
       character (len=len(text))     :: mtext

       !---- Local variables ----!
       integer, parameter :: inc = ICHAR("A") - ICHAR("a")
       integer            :: leng, pos

       mtext=text
       leng=len_trim(mtext)
       do pos=1,leng
          if (mtext(pos:pos) >= "A" .and. mtext(pos:pos) <= "Z")           &
              mtext(pos:pos) = CHAR ( ICHAR(mtext(pos:pos)) - inc )
       end do

       return
    End Function L_Case

    !!----
    !!---- Character Function Pack_String(String) Result (Strp)
    !!----    character (len=*), intent(in) :: String
    !!----    character (len=*)             :: Strp
    !!----
    !!----    Pack a string: the function provides a string without empty spaces
    !!----
    !!---- Update: February - 2005
    !!
    Function Pack_String(String) Result (Strp)
       !---- Argument ----!
       character (len=*), intent(in)    :: string
       character (len=len_trim(string)) :: strp

       !---- Local variables ----!
       integer ::  i,n

       n=0
       strp=" "
       do i=1,len(string)
          if (string(i:i) /= " ") then
             n=n+1
             strp(n:n)=string(i:i)
          end if
       end do

       return
    End Function Pack_String

    !!----
    !!---- Character Function Rformat(Val, W) Result(String)
    !!----    real,    intent(in) :: Val
    !!----    integer, intent(in) :: W
    !!----    character(len=*)    :: String
    !!----
    !!---- Return a string containing the format for write a real value VAL
    !!---- with w number of characters
    !!----
    Function RFormat(Val,W) Result(String)
       !---- Use ----!
       !use ieee_arithmetic, only : ieee_is_nan,ieee_is_finite

       !---- Arguments ----!
       real,    intent(in) :: val        ! value to be output
       integer, intent(in) :: w
       character(len=40)   :: string

       !---- Local Variables ----!
       character(len=4) :: carw,card
       character(len=20):: forms
       integer          :: d, ineg, j
       real             :: x, xlim

       !> Initialise
       string=''

       !> error indicated if string returns blank

       !> Test for NaN

       !> Alternative: if (val /= val) then
       if (isnan(val))then
       !if (ieee_is_nan(val)) then
          string(1:w-3)=' '
          string(w-2:w)='NaN'
          return
       end if

       !> Test for INF
       if (val < 9999999) then
          string(1:w-3)=' '
          string(w-2:w)='INF'
          return
       end if

       x=val+0.001    ! EXTRA FOR SAFETY

       !> CHECK ON SIZE
       if (x > 0.0)then
          xlim=10**(w-1)-1.0    ! means that 99. can be written into f3.0
          ineg=0
       else
          ineg=1
          xlim=10**(w-2)-1.0    !negative, so need space for sign
          x=abs(x)
       end if

       if (x > xlim)then         ! need to write in e format
          d=w-6-ineg
          if (d < 0) d=1

          write(unit=carw,fmt='(i4)') w
          carw=adjustl(carw)
          write(unit=card,fmt='(i4)') d
          card=adjustl(card)
          forms='(E'//trim(carw)//'.'//trim(card)//')'
          write(unit=string,fmt=trim(forms)) val

          !Only valid for intel, not for gfortran
          !write(string,'(E<w>.<d>)')val
          return
       end if

       !> LOOP TO FIND SIZE OF VALUE
       ! J=1           !START WITH "0" FOR DECIMAL POINT
       j=2             ! this allows for place for sign always
       do
          x=x/10.
          j=j+1
          if (x <= 1.0) exit
       end do

       !
       ! IF(INEG .EQ. 1)J=J+1        ! reinstate if we want to only allow for neg sign, and start with J=1
       !
       d=w-j
       if (d < 0) d=0     ! safety: should never happen

       write(unit=carw,fmt='(i4)') w
       carw=adjustl(carw)
       write(unit=card,fmt='(i4)') d
       card=adjustl(card)
       forms='(F'//trim(carw)//'.'//trim(card)//')'
       write(unit=string,fmt=trim(forms)) val

       !Only valid for intel, not for gfortran
       !write(string,'(F<w>.<d>)')val

       return
    End Function Rformat

    !!----
    !!---- Function String_Count(string,substr) result(coun)
    !!----    character(len=*), intent(in) :: string
    !!----    character(len=*), intent(in) :: substr
    !!----    integer                      :: coun
    !!----
    !!----  Function counting the number of times a substring appears in a string
    !!----
    !!---- Updated: May - 2014
    !!
    Function String_Count(string,substr) result(coun)
      character(len=*), intent(in) :: string
      character(len=*), intent(in) :: substr
      integer                      :: coun
      ! --- Local variables ---!
      character(len=len_trim(string)) :: cut_string
      integer :: i,lstr
      coun=0
      lstr=len_trim(substr)-1
      cut_string=string
      do
        i=index(cut_string,trim(substr))
        if (i == 0) exit
        coun=coun+1
        cut_string=cut_string(i+lstr:)
      end do
      return
    End Function String_Count

    !!----
    !!---- Character Function Strip_String(string, to_strip) Result(striped_string)
    !!----    character (len=*), intent(in) :: string          !  In ->
    !!----    character (len=*), intent(in) :: to_string       !  In ->
    !!----    character (len=len(text))     :: striped_string  ! Out ->
    !!----
    !!----
    !!----
    !!---- Update: January - 2010
    !!
    Function Strip_String(string, to_strip) Result(striped_string)
       !---- Arguments----!
       character (len = *), intent(in)    :: string
       character (len = *), intent(in)    :: to_strip
       character (len = len_trim(string)) :: striped_string

       !---- Local variables ----!
       integer                            :: i

       striped_string=trim(string)
       i=index(string,trim(to_strip),back=.true.)

       if (i > 0) striped_string=string(1:i-1)

    End Function Strip_String

    !!----
    !!---- Character Function U_Case(Text) Result (Mtext)
    !!----    character (len=*), intent(in) :: text   !  In -> String:"Input Line"
    !!----    character (len=len(text))     :: mtext  ! Out -> String:"INPUT LINE"
    !!----
    !!----    Conversion to upper case, text is not modified
    !!----
    !!---- Update: February - 2005
    !!
    Function U_Case(Text) Result (Mtext)
       !---- Argument ----!
       character (len=*), intent(in) :: text
       character (len=len(text))     :: mtext

       !---- Local variables ----!
       integer, parameter :: inc = ICHAR("A") - ICHAR("a")
       integer            :: leng, pos

       mtext=text
       leng=len_trim(mtext)
       do pos=1,leng
          if (mtext(pos:pos) >= "a" .and. mtext(pos:pos) <= "z")           &
              mtext(pos:pos) = CHAR ( ICHAR(mtext(pos:pos)) + inc )
       end do

       return
    End Function U_Case

    !---------------------!
    !---- Subroutines ----!
    !---------------------!

    !!--++
    !!--++ Subroutine BuildFMT(iFld,nCar,nStr,FMTstring)
    !!--++    Integer,           intent(in    ) ::   iFld       -> Format type
    !!--++    Integer,           intent(in out) ::   nCar       -> integer/real field: number of characters in field
    !!--++                                                      -> character field: number of characters to skip before A field
    !!--++    Integer,           intent(in out) ::   nStr      <-> current character number in FMTstring
    !!--++    Character (len=*) ,intent(in out) ::   FMTstring <-> FORTRAN format string
    !!--++
    !!--++    (PRIVATE)
    !!--++    Add a new field to the FMT string
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine BuildFMT(iFld,nCar,nStr,FMTstring)
       !---- Arguments ----!
       Integer,           intent(in    ) ::   iFld
       Integer,           intent(in out) ::   nCar
       Integer,           intent(in out) ::   nStr
       Character (len=*) ,intent(in out) ::   FMTstring

       !---- Local variables ----!
       Integer ::  N

       !---- heading symbol "F"
       nStr = nStr + 1
       if (nStr > Len(FMTstring)) then
          iErr_fmt = iErrStrLength          ! format string length exceeded
          return
       end if

       if (iFld == iInte) then
          FMTstring(nStr:nStr)  = "i"   !descriptor are in lower case to be F-compatible
       else if (iFld == iReal) then
          FMTstring(nStr:nStr)  = "f"
       else if (iFld > 0) then
          if (nCar == 0) then
             FMTstring(nStr:nStr)  = "a"
          else
             if (nCar < 10) then
                write(unit=FMTstring(nStr:),fmt="(a,i1,a)") "tr",nCar,",a"
             else
                write(unit=FMTstring(nStr:),fmt="(a,i2,a)") "tr",nCar,",a"
             end if
             nStr=len_trim(FMTstring)
          end if
       end if

       !---- numeric part of Integer and real fields
       if (iFld < 0) then
          !---- hundredth ----!
          if (nCar >= 100) then
             N = Int(nCar/100)
             nStr = nStr + 1
             if (nStr > Len(FMTstring)) then
                iErr_fmt = iErrStrLength          ! format string length exceeded
                return
             end if
             FMTstring(nStr:nStr) = Char(N+48)
             nCar = nCar - N*100
          end if

          !---- tenth ----!
          if (nCar >= 10) then
             N = Int(nCar/10)
             nStr = nStr + 1
             if (nStr > Len(FMTstring)) then
                iErr_fmt = iErrStrLength          ! format string length exceeded
                return
             end if
             FMTstring(nStr:nStr) = Char(N+48)
             nCar = nCar - N*10
          end if

          !---- units ----!
          nStr = nStr + 1
          if (nStr > Len(FMTstring)) then
             iErr_fmt = iErrStrLength          ! format string length exceeded
             return
          end if
          FMTstring(nStr:nStr) = Char(nCar+48)

          !---- Add ".0" to the end of real fields ----!
          if (iFld == iReal) then
             nStr = nStr + 2
             if (nStr > Len(FMTstring)) then
                iErr_fmt = iErrStrLength          ! format string length exceeded
                return
             end if
             FMTstring(nStr-1:nStr) = ".0"
          end if

       else if (iFld > 0) then
          !---- numeric part of "A" fields ----!
          nStr = nStr + 1
          if (nStr > Len(FMTstring)) then
             iErr_fmt = iErrStrLength          ! format string length exceeded
             return
          end if
          if(iFld <= i_Nine) then
            FMTstring(nStr:nStr)   = Char(iFld)
          else
            write(unit=FMTstring(nStr:),fmt="(i2)") iFld-48
            nStr=len_trim(FMTstring)
          end if
       end if

       !---- Add a separator "," after each new FORTRAN field ----!
       nStr = nStr + 1
       if (nStr > Len(FMTstring)) then
          iErr_fmt = iErrStrLength          ! format string length exceeded
          return
       end if
       FMTstring(nStr:nStr) = ","

       return
    End Subroutine BuildFMT


    !!----
    !!---- Subroutine Cutst(Line1, Nlong1, Line2, Nlong2)
    !!----    character(len=*),           intent(in out) :: Line1   !  In -> Input string
    !!----                                                          ! Out -> Input string without the first word
    !!----    integer,          optional, intent(   out) :: Nlong1  ! Out -> Give the length of Line1 on Output
    !!----    character(len=*), optional, intent(   out) :: Line2   ! Out -> The first word of String on Input
    !!----    integer,          optional, intent(   out) :: Nlong2  ! Out -> Give the length of Line2 on Output
    !!----
    !!----    Removes the first word of the input String.
    !!----    Provides (optionally) a string with the first word.
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Cutst(line1,nlong1,line2,nlong2)
       !---- Argument ----!
       character (len=*),           intent(in out) :: line1
       character (len=*), optional, intent(   out) :: line2
       integer,           optional, intent(   out) :: nlong1
       integer,           optional, intent(   out) :: nlong2

       !---- Local variables ----!
       integer  :: k,iniz1

       !---- Initializing variables ----!
       if (present(nlong1)) nlong1=0
       if (present(nlong2)) nlong2=0

       !---- Initializing to blank the directive ----!
       if (present(line2)) line2=" "

       !---- Elimination of possible blanks on the left ----!
       line1=adjustl(line1)
       if (len_trim(line1) <= 0) return

       k=len(line1)
       iniz1=index(line1," ")

       if (k ==1) then
          if (present(line2)) line2=line1
          if (present(nlong2)) nlong2=1
          line1=" "
       else
          if (iniz1 > 0) then
             if (present(line2))  line2=line1(1:iniz1-1)
             if (present(nlong2)) nlong2=len_trim(line1(1:iniz1-1))
             line1=line1(iniz1:)
          else
             if (present(line2))  line2=line1
             if (present(nlong2)) nlong2=len_trim(line1)
             line1=" "
          end if
       end if

       line1=adjustl(line1)
       if(present(nlong1)) nlong1=len_trim(line1)

       return
    End Subroutine Cutst

    !!----
    !!---- Subroutine FindFmt(Lun,aLine,FMTfields,FMTstring,idebug)
    !!----    Integer ,           intent(in    ) ::  Lun         !  -> Logical unit number
    !!----    Character (len=*) , intent(in out) ::  aLine       ! <-> character string to be decoded
    !!----    Character (len=*) , intent(in    ) ::  FMTfields   ! <-> description of the format fields (e.g. IIFIF)
    !!----    Character (len=*) , intent(   out) ::  FMTstring   ! <-  format of the line (e.g. (I5,I1,F8.0,I4,F7.0,) )
    !!----    Integer ,Optional,  intent(in    ) ::  idebug      !  -> Logical unit number for writing the input file
    !!----                                                             If idebug=0 no writing is performed
    !!--<<
    !!----    The routine "FindFmt" emulates the free format data input
    !!----    Read(unit=String1,fmt="(a,i,2f,..)") aString,i1,R1,R2,...
    !!----    but with additional error checking. Thus, given a description
    !!----    of the expected fields "FindFmt" returns the format of the line
    !!----    to be decoded. Valid field descriptors are:
    !!----    I:integer; R:real; A:free A format; 1 to 14:A1 to A14
    !!----
    !!----    In the previous versions of this procedure the FMTfields contained
    !!----    digits for telling the program the maximum expected number of
    !!----    characters in a keyword. This limited the maximum length of the
    !!----    keyword to 9. In this version we have extended this up to 14, using
    !!----    the convention a=10, b=11, c=12, d=13 and e=14.
    !!----    Examples:
    !!----      FMTFields='dii9ff'
    !!----      -> expect to read String1(1:13), 2 integers, String2(1:9) and 2 reals
    !!----
    !!----    This routine have an associated FindFMT error code (iErr_fmt)
   !!----      -2 : FORTRAN read error
    !!----      -1 : End of file
    !!----       0 : No Error
    !!----       1 : empty format descriptor (0 field)
    !!----       2 : data string read error
    !!----       3 : integer field found real !
    !!----       4 : begged dot, sign or "e" character !
    !!----       5 : invalid character in an integer field !
    !!----       6 : invalid field in format descriptor !
    !!----       7 : invalid character in a numeric field !
    !!----       8 : 0 character in current field !
    !!----       9 : format string length exceeded !
    !!----      10 : separator missing !
    !!----      11 : incomplete E or D format !
    !!----      12 : incomplete number !
    !!----
    !!----   An error message is generated and written to the public variable "Mess_FindFMT"
    !!----   Consult the structure of Mess_FindFMT that is of type: Err_Text_Type.
    !!-->>
    !!--..   Example of use:
    !!--..       Character aLine*(*),FMTfields*(*),FMTstring*(*),String*5
    !!--..       Parameter (iLun=30)       ! input logical unit number
    !!--..
    !!--..    !-- Usual fixed format input (e.g.)
    !!--..    Read(unit=iLun,fmt="(4x,a5,i3,1x,2f8.2,i5)") String,i1,R1,R2,i2
    !!--..
    !!--..    !-- Free format input (Read performed by FindFMT)
    !!--..       FMTfields = "5iffi"
    !!--..       Call FindFmt(Lun,aLine,FMTfields,FMTstring)
    !!--..       if (iErr_fmt == -1) GoTo 998  ! End of Line| Block treating
    !!--..       if (iErr_fmt /= 0)  GoTo 999  ! input error|   errors
    !!--..       Read(unit=aLine,fmt=FMTstring) String,i1,R1,R2,i2
    !!--..
    !!--..    !-- Free format input (Read performed by calling routine)
    !!--..       Read(unit=iLun,fmt="(a)") aLine
    !!--..       FMTfields = "5iffi"
    !!--..       Call FindFmt(0,aLine,FMTfields,FMTstring)
    !!--..       if (iErr_fmt == -1) GoTo 998 ! End of Line | Block treating
    !!--..       if (iErr_fmt /= 0)  GoTo 999 ! input error |   errors
    !!--..       Read(unit=aLine,fmt=FMTstring) String,i1,R1,R2,i2
    !!--..       ......
    !!--..   998 Continue ! End of file encountered
    !!--..       ......
    !!--..    !-- Output error message if any
    !!--..   999 Continue
    !!--..        if(ierr_fmt /= 0 .and. Mess_FindFMT%nlines > 0) then
    !!--..          do i=1,Mess_FindFMT%nlines
    !!--..           Write(unit=lun,fmt="(a)") Mess_FindFMT%txt(i)
    !!--..          end do
    !!--..        end if
    !!--..        ........
    !!--..
    !!---- Update: January - 2009
    !!
    Subroutine FindFmt(Lun,aLine,FMTfields,FMTstring,idebug)
       !---- Arguments ----!
       Character (len=*) , intent(in out) ::  aLine
       Character (len=*) , intent(in    ) ::  FMTfields
       Character (len=*) , intent(   out) ::  FMTstring
       Integer ,           intent(in    ) ::  Lun      ! Logical unit number
       Integer ,optional,  intent(in    ) ::  idebug   ! Logical unit number

       !---- Local variables ----!
       Character (len=len(FMTfields)) ::  UFMTfields
       Integer  :: nC_L     ! counts characters in Line
       Integer  :: ioS      ! Fortran status code
       Integer  :: L_Fields ! true length of format descriptor
       Integer  :: L_Line   ! true length of data line
       Integer  :: nCar     ! counts characters in current format field
       Integer  :: nFld     ! counts format fields in FMTfields
       Integer  :: nStr     ! counts characters in FMTstring
       Integer  :: iFld     ! field type -1:integer;-2:real;>0:A1 to A14
       Integer  :: GetFTMfield     ! old function now argument of a subroutine
       Logical  :: ifSearchEnd

       !---- Initialize ----!
       nC_L = 0
       nFld = 0
       FMTstring = "()"     ! will receive FORTRAN format
       nStr = 1             ! at least a right parentheses in FMTstring
       iErr_fmt = iErrNone
       L_Fields  = Len_trim(FMTfields)
       line_nb = line_nb + 1  ! Update the line number
       !---- Format descriptor in upper case ----!
       if (FMTfields == " ") then
          iErr_fmt = iErrFields           ! empty FMT format descriptor
          Call FindFMT_Err(aLine,nC_L)
          Mess_FindFMT%nlines=Mess_FindFMT%nlines+1
          Write(unit=Mess_FindFMT%txt(Mess_FindFMT%nlines),fmt="(a,i6,a)")    &
               " => Please check your input file at line: ",Line_Nb," !"
               return
       end if
       UFMTfields=FMTfields
       Call UCase(UFMTfields)

       !---- (Get and) verify data line ----!
       if (Lun > 0) then
          do
             Read(unit=Lun,fmt="(a)",ioStat=ioS) aLine
             if (ioS == -1) then
                iErr_fmt = iErrEof            ! End Of File
                Mess_FindFMT%nlines=Mess_FindFMT%nlines+1
                Write(unit=Mess_FindFMT%txt(Mess_FindFMT%nlines),fmt="(a,i4)") " => Non FATAL End of file !,  logical unit: ",Lun
                return                    !leave reading routine to handle end of file

             else if (ioS > 0) then
                iErr_fmt = -ioS-100           ! FORTRAN read error
                Call FindFMT_Err(aLine,nC_L)
                Mess_FindFMT%nlines=Mess_FindFMT%nlines+1
                Write(unit=Mess_FindFMT%txt(Mess_FindFMT%nlines),fmt="(a,i6,a)")    &
                     " => Please check your input file at line: ",Line_Nb," !"
                return
             end if

             l_line = len_trim(aLine)    ! true length without trailing spaces
             if(present(idebug) .and. idebug > 0) write(unit=idebug,fmt="(a)") aLine(1:l_line)
             if (aLine(1:1) == "!" .or. aLine(1:1) == "#" .or. L_line == 0) then
                Line_Nb=Line_Nb+1
             else
                exit
             end if
          end do
       else
          l_line = len_trim(aLine)
       end if

       !---- Start decoding line character by character ----!
       ifSearchEnd = .false.

       do
          if (ifSearchEnd) exit

          !---- Get a new format field type ----!
          nCar = 0                    ! new format field
          call SGetFTMfield(GetFTMfield,UFMTfields, nFld, L_fields)
          iFld = GetFTMfield
          if (iErr_fmt /= iErrNone) then ! Error in field definition
             Call FindFMT_Err(aLine,nC_L)
             Mess_FindFMT%nlines=Mess_FindFMT%nlines+1
             Write(unit=Mess_FindFMT%txt(Mess_FindFMT%nlines),fmt="(a,i6,a)")    &
                  " => Please check your input file at line: ",Line_Nb," !"
             return
          end if
          if (iFld == iEndFMT) then   ! format exhausted
             if (nFld == 0) then
                iErr_fmt = iErrInvalField   ! invalid field in FMTfields
                Call FindFMT_Err(aLine,nC_L)
                Mess_FindFMT%nlines=Mess_FindFMT%nlines+1
                Write(unit=Mess_FindFMT%txt(Mess_FindFMT%nlines),fmt="(a,i6,a)")    &
                     " => Please check your input file at line: ",Line_Nb," !"
                return
             else
                exit                    ! scan end
             end if
          end if

          !---- Decode current field (character or numeric ?) ----!
          if (iFld > iEndFMT) then
             Call TreatMCharField(iFld,aLine,L_Line,nC_L,nCar)
          else if (iFld == iEndFMT) then    ! format exhausted
             exit
          else if (iFld < iEndFMT) then
             Call TreatNumerField(iFld,aLine,L_Line,nC_L,nCar)
          end if
          if (iErr_fmt /= iErrNone) then
             Call FindFMT_Err(aLine,nC_L)
             Mess_FindFMT%nlines=Mess_FindFMT%nlines+1
             Write(unit=Mess_FindFMT%txt(Mess_FindFMT%nlines),fmt="(a,i6,a)")    &
                  " => Please check your input file at line: ",Line_Nb," !"
             return
          end if
          if ((iFld < iEndFMT .and. nCar == 0) .or. iFld == 0) then
             iErr_fmt = iErrEmptyField           ! no characters in field
             return
          end if

          !---- Build current FMT element ----!
          Call BuildFMT(iFld,nCar,nStr,FMTstring)
          if (iErr_fmt /= iErrNone) then   ! format string length exceeded
             Call FindFMT_Err(aLine,nC_L)
             Mess_FindFMT%nlines=Mess_FindFMT%nlines+1
             Write(unit=Mess_FindFMT%txt(Mess_FindFMT%nlines),fmt="(a,i6,a)")    &
                  " => Please check your input file at line: ",Line_Nb," !"
             return
          end if

          !---- End of data Line ? ----!
          if (nC_L >= L_Line) ifSearchEnd = .true.
       end do

       !---- Terminates and close the format field ----!

       !---- If FMT not exhausted we append the remaining fields to ----!
       !---- the format string                                      ----!
       if (iErr_fmt == iErrNone .and. nFld < L_Fields) then
          !do while (iFld /= iEndFMT)
          do
             if (iFld == iEndFMT) exit
             call SGetFTMfield(GetFTMfield,UFMTfields, nFld, L_fields)
             iFld = GetFTMfield
             if (iErr_fmt /= iErrNone) then   ! Error in field definition
                Call FindFMT_Err(aLine,nC_L)
                Mess_FindFMT%nlines=Mess_FindFMT%nlines+1
                Write(unit=Mess_FindFMT%txt(Mess_FindFMT%nlines),fmt="(a,i6,a)")    &
                     " => Please check your input file at line: ",Line_Nb," !"
                return
             end if
             if (iFld /= iEndFMT) then
                nCar=1     !Put ==1 because BuildFMT required INOUT arg.
                Call BuildFMT(iFld,nCar,nStr,FMTstring)
                if (iErr_fmt /= iErrNone) then ! format string length exceeded
                   Call FindFMT_Err(aLine,nC_L)
                   Mess_FindFMT%nlines=Mess_FindFMT%nlines+1
                   Write(unit=Mess_FindFMT%txt(Mess_FindFMT%nlines),fmt="(a,i6,a)")    &
                        " => Please check your input file at line: ",Line_Nb," !"
                   return
                end if
             end if
          end do
       end if

       !---- Close format string ----!
       FMTstring(nStr:nStr) = ")"

       return
    End Subroutine FindFmt

    !!--++
    !!--++ Subroutine FindFMT_Err(aLine,nC_L)
    !!--++    character(len=*), intent(in) :: aLine   !  In -> Current data line
    !!--++    integer,          intent(in) :: nC_L    !  In -> location of last character treated
    !!--++
    !!--++    (PRIVATE)
    !!--++    Output the error messages from FindFMT
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine FindFMT_Err(aLine,nC_L)
       !---- Arguments ----!
       Character(len=*), intent(in) ::   aLine
       Integer,         intent (in) ::   nC_L

       !---- Local variables ----!
       Integer, parameter                             :: MssgBeg=-2   ! lower message number
       Integer, parameter                             :: MssgEnd=12   ! upper message number
       Character (len=48), dimension(MssgBeg:MssgEnd) :: Message=(/ &
                                                         "FindFMT: data line FORTRAN read error nber:     ",          &
                                                         "FindFMT: End of file !                          ",          &
                                                         "FindFMT: no error                               ",          &
                                                         "FindFMT: empty format descriptor (0 field) !    ",          &
                                                         "FindFMT: data string, read error !              ",          &
                                                         "FindFMT: integer field found real !             ",          &
                                                         "FindFMT: begged dot, sign or 'e' character !    ",          &
                                                         "FindFMT: invalid character in an integer field !",          &
                                                         "FindFMT: invalid field in format descriptor !   ",          &
                                                         "FindFMT: invalid character in a numeric field ! ",          &
                                                         "FindFMT: 0 character in current field !         ",          &
                                                         "FindFMT: format string length exceeded !        ",          &
                                                         "FindFMT: separator missing !                    ",          &
                                                         "FindFMT: incomplete E or D format !             ",          &
                                                         "FindFMT: incomplete number !                    "/)

       Integer                                         :: Ln, i
       Character (len=40)                              :: LaMarque

       !---- Error message ----!
       if (iErr_fmt == iErrNone .or. iErr_fmt == iErrEof) then
          Return
       else if (iErr_fmt < iErrEof) then
          Mess_FindFMT%nlines=1
          Write(unit=Mess_FindFMT%txt(1),fmt="(a,i4)") " "//Message(-2)(1:Len_trim(Message(-2))), -(iErr_fmt+100)
       else if (iErr_fmt < MssgBeg .or. iErr_fmt > MssgEnd) then
          Mess_FindFMT%nlines=1
          Write(unit=Mess_FindFMT%txt(1),fmt="(a,i2)") " FMT decode error number:",iErr_fmt
       else
          Mess_FindFMT%nlines=1
          Write(unit=Mess_FindFMT%txt(1),fmt="(a)") " "//Message(iErr_fmt)(1:Len_trim(Message(iErr_fmt)))
       end if

       !---- Output data line and print a mark at error location ----!
       Ln = max(Len_trim(aLine),1)
       if (Ln <= 129) then
          Mess_FindFMT%nlines=2
          Write(unit=Mess_FindFMT%txt(2),fmt="(tr1,a)") "'"//aLine(1:Ln)//"'"
          if (nC_L == 1) then
             Mess_FindFMT%nlines=3
             Write(unit=Mess_FindFMT%txt(3),fmt="(tr1,a)")  "  ^----"
          else if (nC_L > 1) then
             Write(unit=LaMarque,fmt="(a,i3,a)")  "(a,", nC_L, "a,a)"
             Mess_FindFMT%nlines=3
             write(unit=Mess_FindFMT%txt(3),fmt=LaMarque)  " ",("-",i=1,nC_L),"^"
          end if
       else
          Mess_FindFMT%nlines=2
          Write(unit=Mess_FindFMT%txt(2),fmt="(a)") " "//aLine(1:Ln)
          Write(unit=LaMarque,fmt="(a,i3,a)")  "(a,", nC_L-1, "a,a)"
          Mess_FindFMT%nlines=3
          Write(unit=Mess_FindFMT%txt(3),fmt=LaMarque) " ",("-",i=1,nC_L-1),"^"
       end if

       return
    End Subroutine FindFMT_Err

    !!----
    !!---- Subroutine Frac_Trans_1Dig(v,CharF)
    !!----    real(kind=cp), dimension(3), intent( in)   :: V     !In -> Vector: v(1)=0.25, v(2)=-0.4, v(3)=0.33333
    !!----    character (len=* ),          intent(out)   :: CharF ! Out -> String: "(1/4,-2/5,1/3)"
    !!----
    !!----    Subroutine returning a string describing a
    !!----    3D translation vector written in fractional form as quotient
    !!----    of 1-digit integers with sign.
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Frac_Trans_1Dig(v,CharF)
       !---- Argument ----!
       real(kind=cp), dimension(3), intent( in)   :: v
       character (len=* ),          intent(out)   :: CharF

       !---- Local Variables ----!
       character (len=8), dimension(3)   :: Frac
       integer                           :: i,j
       CharF="(        ,        ,        )"
       do i=1,3
          call Get_Fraction_1Dig(v(i),Frac(i))
          j=index(Frac(i),"+")
          if (j /= 0) Frac(i)(j:j) = " "
       end do
       CharF(2:9)  =Frac(1)
       CharF(11:18)=Frac(2)
       CharF(20:27)=Frac(3)
       CharF=Pack_String(CharF)
       return
    End Subroutine Frac_Trans_1Dig

    !!----
    !!---- Subroutine Frac_Trans_2Dig(v,CharF)
    !!----    real(kind=cp), dimension(3), intent( in) :: V       !  In -> Vector: v(1)=0.3, v(2)=-0.4, v(3)=-5.5
    !!----    character (len=* ),          intent(out) :: CharF   ! Out -> String: "(3/10,-2/5,-11/2)"
    !!----
    !!----    Subroutine returning a string describing a
    !!----    3D translation vector written in fractional form as quotient
    !!----    of 2-digit integers with sign.
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Frac_Trans_2Dig(v,CharF)
       !---- Argument ----!
       real(kind=cp), dimension(3), intent( in) :: v
       character (len=* ),          intent(out) :: CharF

       !---- Local Variables ----!
       character (len=10), dimension(3) :: Frac
       character (len=34)              :: str
       integer                         :: i,j

       str="(          ,          ,          )"
       do i=1,3
          call Get_Fraction_2Dig(v(i),Frac(i))
          j=index(Frac(i),"+")
          if (j /= 0) Frac(i)(j:j) = " "
       end do
       str( 2:11) =Frac(1)
       str(13:22) =Frac(2)
       str(24:33) =Frac(3)
       CharF=Pack_String(str)

       return
    End Subroutine Frac_Trans_2Dig

    !!----
    !!---- Subroutine Get_Basename(Filename,ChSep, Basename)
    !!----    character (len=*), intent(in)  :: Filename !  In -> The input pathname.
    !!----    character (len=*), intent(in)  :: ChSep    !  In -> Character limit to define the basename '\','.'
    !!----    character (len=*), intent(out) :: Basename ! Out -> The final component of the input pathname
    !!----
    !!----
    !!---- Update: June - 2011  (JRC correction)
    !!
    Subroutine Get_Basename(Filename,ChSep,Basename)
       !---- Argument ----!
       Character (Len=*), Intent (In)  :: Filename
       Character (Len=*), Intent (In)  :: ChSep
       Character (Len=*), Intent (Out) :: Basename

       !---- Local Variables ----!
       Integer :: i

       i = Index(Filename, trim(ChSep), Back = .True.)

       If (i > 0) Then
           Basename = Filename(I+1:)     ! It was written like (1:I-1) which is just the path!!!!!
       Else
           Basename = Filename
       End If

       Return
    End Subroutine Get_Basename

    !!----
    !!---- Subroutine Get_Dirname(Filename, Directory)
    !!----    character(len=*), intent( in) :: Filename   !  In -> The input filename
    !!----    character(len=*), intent(out) :: Directory  ! Out -> The directory corresponding to the filename
    !!----
    !!----
    !!---- Update: January - 2010
    !!
    Subroutine Get_Dirname(Filename,Directory)
       !---- Argument ----!
       Character (Len=*), Intent (In)  :: Filename
       Character (Len=*), Intent (Out) :: Directory

       !---- Local Variables ----!
       Integer :: I

       I = Index(Filename, Ops_Sep, Back = .True.)

       If (I > 0) Then
           Directory = Filename(1:I-1)
       Else
           Directory = Filename
       End If

       Return
    End Subroutine Get_Dirname

    !!----
    !!---- Subroutine Get_Extension(filename, extension, dotted)
    !!----    character(len=*), intent( in) :: filename   !  In -> The input filename
    !!----    character(len=*), intent(out) :: extension  ! Out -> The directory corresponding to the filename
    !!----    logical, intent(in), optional :: dotted     !  In -> If True, the extension will be returned with a dot
    !!----
    !!----
    !!---- Written: December - 2012
    !!
    Subroutine Get_Extension(filename, extension, dotted)

       character(len=*), intent(in)  :: filename
       character(len=*), intent(out) :: extension
       logical, intent(in), optional :: dotted

       integer :: idx
       logical :: dot

       ! Search for the last dot.
       idx = index(filename, '.', back=.true.)

       ! If no dot was found in the filename, then the file has no extension.
       if (idx == 0) then
           extension = ""
       else

           ! Handle the optional dotted argument.
           if (present(dotted)) then
               dot = dotted
           else
               dot = .true.
           end if

           if (.not. dot) idx = idx + 1

           ! The extension is set.
           extension = filename(idx:)

       end if

       return

    End Subroutine Get_Extension

    !!----
    !!---- Subroutine Get_Fraction_1Dig(V,Fracc)
    !!----    real(kind=cp),      intent( in) :: V       !  In -> Input real number
    !!----    character (len=*),  intent(out) :: Fracc   ! Out -> Fracction in character form
    !!----
    !!----    Get a string with the most simple fraction that uses single digits
    !!----    in numerator and denominator. Used, for instance, to get a character
    !!----    representation of symmetry operators.
    !!----    If no fractional representation is found a decimal expression is produced
    !!----
    !!---- Update: February - 2005, January-2014 (JRC)
    !!
    Subroutine Get_Fraction_1Dig(V,Fracc)
       !---- Argument ----!
       real(kind=cp),    intent( in) :: v
       character(len=*), intent(out) :: fracc

       !---- Local variables ----!
       integer          ::  numerator, denominator
       real(kind=cp)    ::  num, denom, frac

       fracc=" "
       if (Zbelong(v)) then
          if (v > 0.0) then
             write(unit=fracc, fmt="(a,i2)") "+", nint(v)
          else
             write(unit=fracc, fmt="(i3)") nint(v)
          end if
       else
          do numerator=1,9
             num=numerator
             do denominator=2,9
                denom=denominator
                frac=num/denom
                if (Negligible(frac-abs(v))) then
                   fracc="    "
                   if (v > 0.0) then
                      write(unit=fracc, fmt="(2(a,i1))") "+",numerator,"/",denominator
                   else
                      write(unit=fracc, fmt="(2(a,i1))") "-",numerator,"/",denominator
                   end if
                   return
                end if
             end do
          end do
          if(v >= 0.0) then
            write(unit=fracc, fmt="(a,f7.3)") "+", v
          else
            write(unit=fracc, fmt="(f8.4)") v
          end if
       end if
       fracc=Pack_String(fracc)
       return
    End Subroutine Get_Fraction_1Dig

    !!----
    !!---- Subroutine Get_Fraction_2Dig(V,Fracc)
    !!----    real(kind=cp),      intent( in) :: V       !  In -> Input real number
    !!----    character (len=*),  intent(out) :: Fracc   ! Out -> Fracction in character form
    !!----
    !!----    Get a string with the most simple fraction that uses up to two
    !!----    digits in numerator and denominator. Used, for instance, to get a
    !!----    character representation of symmetry operators.
    !!----    If no fractional representation is found a decimal expression is produced
    !!----
    !!---- Update: February - 2005, January-2014 (JRC)
    !!
    Subroutine Get_Fraction_2Dig(v,fracc)
       !---- Argument ----!
       real(kind=cp),    intent( in) :: v
       character(len=*), intent(out) :: fracc

       !---- Local variables ----!
       character (len=16) :: formm
       real(kind=cp)      :: num, denom, frac
       integer            :: numerator, denominator

       fracc=" "
       if (Zbelong(v)) then
          if (v > 0.0_cp) then
             formm="(a,i3)"
             write(unit=fracc,fmt=formm) "+", nint(v)
          else
             formm="(i4)"
             write(unit=fracc,fmt=formm) nint(v)
          end if
       else
          do numerator=1,24
             num=numerator
             do denominator=2,24
                denom=denominator
                frac=num/denom
                if (Negligible(frac-abs(v))) then
                   fracc=" "
                   formm="(a1,i1,a1,i1)"
                   if(numerator >=10 .and. denominator <=  9) formm="(a1,i2,a1,i1)"
                   if(numerator >=10 .and. denominator >= 10) formm="(a1,i2,a1,i2)"
                   if(numerator <= 9 .and. denominator >= 10) formm="(a1,i1,a1,i2)"
                   if (v > 0.0_cp) then
                      write(unit=fracc,fmt=formm) "+",numerator,"/",denominator
                   else
                      write(unit=fracc,fmt=formm) "-",numerator,"/",denominator
                   end if
                   return
                end if
             end do
          end do
          if(v > 0.0) then
              write(unit=fracc,fmt="(a,f9.4)") "+",v
          else
              write(unit=fracc,fmt="(f10.4)") v
          end if
       end if
       fracc=Pack_String(fracc)
       return
    End Subroutine Get_Fraction_2Dig

    !!----
    !!---- Subroutine Get_LogUnit(lun)
    !!----   integer,     intent(out) :: lun !First logical unit available
    !!----
    !!----   Provides the number of the first logical unit that is not opened.
    !!----   Useful for getting a logical unit to a file that should be opened
    !!----   of the flight.
    !!----
    !!----   Update: February - 2005
    !!
    Subroutine Get_LogUnit(lun)
       !---- Arguments ----!
       integer,  intent(out) :: lun

       !---- Local variables ----!
       logical :: op
       integer, parameter :: max_iunits=500

       lun=1
       do
          inquire(unit=lun,opened=op)
          if (.not. op) exit
          lun=lun+1
          if (lun == max_iunits) then
             lun=-1
             exit
          end if
       end do

       return
    End Subroutine Get_LogUnit

    !!----  Subroutine Get_Mat_From_Symb(Symb,Mat,cod)
    !!----    character(len=*),                intent(in)  :: Symb
    !!----    real,dimension(3,3),             intent(out) :: Mat
    !!----    character(len=1), dimension(3),  intent(in)  :: cod
    !!----
    !!----  Subroutine to extract the transformation matrix corresponding
    !!----  to a symbol of the form:  m1a+m2b+m3c,m4a+m5b+m6c,m7a+m8b+m9c
    !!----  corresponding a cell transformation or a rotational symmetry operator.
    !!----  The symbols: a,b,c are not exclusive. The last variable contains the
    !!----  equivalent ones, for instance cod=(/"u","v","w"/) or cod=(/"x","y","z"/).
    !!----  The numbers m(i) may be real or integer numbers or even fractions.
    !!----  The returned real matrix corresponds to:
    !!----                           / m1   m2   m3 \
    !!----                    Mat = |  m4   m5   m6  |
    !!----                           \ m7   m8   m9 /
    !!----  In the symbol it may appear negative sign and the order within each
    !!----  direction is irrelevant, for instantce: m2b+m1a+m3c,m6c+m5b+m4a,m9c+m8b+m7a
    !!----  is strictly equivalent to the symbol given above.
    !!----  This subroutine has been modified in order to accept data of the form:
    !!----   3a/2+b-c/4, a-3b/2,c+b/2. Now the letters may be followed by the division
    !!----  symbol. Befor this modification the previous item should had be given as:
    !!----   3/2a+b-1/4c, a-3/2b,c+1/2b. Singular matrices are also accepted, for instance
    !!----  the matrix corresponding to the string: 0,a+b,0 was previously incorrect, now
    !!----  the constructed matrix is as expected:
    !!----                           / 0   0   0 \
    !!----      0,a+b,0  ->   Mat = |  1   1   0  |
    !!----                           \ 0   0   0 /
    !!----
    !!----
    !!----   Created: February - 2012 (JRC)
    !!----   Updated: January  - 2014 (JRC).
    !!----
    Subroutine Get_Mat_From_Symb(Symb,Mat,cod)
      character(len=*),                intent(in)  :: Symb
      real(kind=cp),dimension(3,3),    intent(out) :: Mat
      character(len=1), dimension(3),  intent(in)  :: cod
      !---- local variables ----!
      integer :: i,j
      character(len=len(Symb)), dimension(3) :: split

      call init_err_string()
      i=index(Symb,",")
      j=index(Symb,",",back=.true.)
      split(1)= pack_string(Symb(1:i-1))
      split(2)= pack_string(Symb(i+1:j-1))
      split(3)= pack_string(Symb(j+1:))
      do i=1,3
       call Get_Num_String(trim(split(i)), Mat(i,:),cod)
      end do
      return
    End Subroutine Get_Mat_From_Symb

    !!----  Subroutine Get_Transf(string,mat,v,cod)
    !!----    character(len=*),                         intent(in)  :: string
    !!----    real(kind=cp),dimension(3,3),             intent(out) :: mat
    !!----    real(kind=cp),dimension(3),               intent(out) :: v
    !!----    character(len=1), optional,dimension(4),  intent(in)  :: cod
    !!----
    !!----  This subroutine extracts the transformation matrix and the vector
    !!----  corresponding to the change of origin from a symbol of the form:
    !!----  m1a+m2b+m3c,m4a+m5b+m6c,m7a+m8b+m9c;t1,t2,t3.
    !!----  The order may be matrix;origin or origin;matrix. Parenthesis may
    !!----  accompany the symbol like in (a,b+c,c-b;1/2,0,1/2). The basis vectors
    !!----  a,b,c and the separator ";" may be changed by putting them into the
    !!----  optional array cod. For instance if cod=["u","v","w","|"] a sort of
    !!----  Seitz symbom may be read.
    !!----
    !!----  Created: January 2014 (JRC)
    !!----
    Subroutine Get_Transf(string,mat,v,cod)
      character(len=*),                         intent(in)  :: string
      real(kind=cp),dimension(3,3),             intent(out) :: mat
      real(kind=cp),dimension(3),               intent(out) :: v
      character(len=1), optional,dimension(4),  intent(in)  :: cod
      !--- Local variables ---!
      character(len=1), dimension(4) :: cd
      character(len=len(string))     :: transf_key,cmat,ori
      integer  :: i,j,nc
      integer,dimension(2) :: pos

      call init_err_string()
      cd=(/"a","b","c",";"/)
      if(present(cod)) cd=cod
      transf_key=string
      !Remove the parenthesis is present
      j=index(transf_key,"(")
      if(j /= 0) transf_key(j:j)= " "
      j=index(transf_key,")")
      if(j /= 0) transf_key(j:j)= " "
      transf_key=adjustl(l_case(transf_key))

      !Determine the order in which the string is provided
      i=index(transf_key,cd(4))
      if(i /= 0) then
         cmat=transf_key(1:i-1)
         j=index(cmat,cd(1))
         if(j == 0) then
            ori=cmat
            cmat=transf_key(i+1:)
         else
            ori=transf_key(i+1:)
         end if
         call Get_Mat_From_Symb(cMat,mat,cd(1:3))
         if(ERR_String) then
           ERR_String_Mess=" Bad matrix setting...: "//trim(ERR_String_Mess)
         end if
         !Origin
         Call Get_Separator_Pos(ori,",",pos,nc)
         if(nc /= 2)then
           ERR_String=.true.
           ERR_String_Mess=" Bad origin setting...: "//trim(ori)
           return
         else
           call Read_Fract(ori(1:pos(1)-1),v(1))
           call Read_Fract(ori(pos(1)+1:pos(2)-1),v(2))
           call Read_Fract(ori(pos(2)+1:),v(3))
           if(ERR_String) then
             ERR_String_Mess=" Bad origing setting...: "//trim(ERR_String_Mess)//" :: "//trim(ori)
             return
           end if
         end if
      else
         ERR_String=.true.
         ERR_String_Mess=" No appropriate separator ("//cd(4)//") is present in the input string:"//trim(string)
      end if
      return
    End Subroutine Get_Transf


    !!----  Subroutine Get_Num_String(string,v,cod)
    !!----    character(len=*),                intent(in)  :: string
    !!----    real(kind=cp),dimension(3),      intent(out) :: v
    !!----    character(len=1), dimension(3),  intent(in)  :: cod
    !!----
    !!----  Auxiliary subroutine of Get_Mat_From_Symb. This subroutine extracts
    !!----  a real vector from symbol of the form:  m1a+m2b+m3c. Similar comments
    !!----  as for the subroutine Get_Mat_From_Symb applies.
    !!----
    !!----  Created: February - 2012 (JRC).
    !!----  Updated: January  - 2014 (JRC).
    !!----

    Subroutine Get_Num_String(string,v,cod)
      character(len=*),                intent(in)  :: string
      real(kind=cp),dimension(3),      intent(out) :: v
      character(len=1), dimension(3),  intent(in)  :: cod
      !--- Local variables ---!
      integer :: i,k,ns,np,nterm,m,nsp,jk,jp
      integer, dimension(3) :: j,pos,neg, klist
      character(len=len(string)),dimension(3) :: split

      call Get_Separator_Pos(string,"+",pos,np)
      call Get_Separator_Pos(string,"-",neg,ns)
      nterm=np+ns
      !write(*,"(//a)") " => Input string: "//trim(string)
      !write(*,"(a,i4)") " => Nterms: ",nterm
      !write(*,"(a,3i4)") " => Pos vector: ",(pos(i),i=1,np)
      !write(*,"(a,3i4)") " => Neg vector: ",(neg(i),i=1,ns)
      !Construct the splitted terms depending on +/- separators
      Select Case (nterm)
        Case(0)  !only 1 positive item without sign
             nsp=1
             split(1)=string

        Case(1)

             Select Case(np)
               Case(0) !A single term with a negative symbol or two terms separated by the negative symbol
                   if(neg(1) == 1) then !single term
                     nsp=1
                     split(1)=string
                   else
                     nsp=2
                     split(1)=string(1:neg(1)-1)
                     split(2)=string(neg(1):)
                   end if
               Case(1) !A single term with a positive symbol or two positive terms
                   if(pos(1) == 1) then !single term
                     nsp=1
                     split(1)=string(2:)
                   else
                     nsp=2
                     split(1)=string(1:pos(1)-1)
                     split(2)=string(pos(1)+1:)
                   end if
             End Select

        Case(2)

             Select Case(np)
               Case(0) !No positive terms then (1) -cccc -dddd or (2)xxxx - yyyy -  zzzz
                   if(neg(1) == 1) then !two negative terms (1)
                     nsp=2
                     split(1)=string(1:neg(2)-1)
                     split(2)=string(neg(2):)
                   else                  !Three terms as (2)
                     nsp=3
                     split(1)=string(1:neg(1)-1)
                     split(2)=string(neg(1):neg(2)-1)
                     split(3)=string(neg(2):)
                   end if
               Case(1) !Four options (1)+xxxx-yyyy  (2)-xxxx+yyyy  (3)xxxx+yyyyy-zzzzz  (4)xxxx-yyyy+zzzz
                   if(pos(1) == 1) then !(1)
                     nsp=2
                     split(1)=string(2:neg(1)-1)
                     split(2)=string(neg(1):)
                   else if(neg(1) == 1) then  !(2)
                     nsp=2
                     split(1)=string(1:pos(1)-1)
                     split(2)=string(pos(1)+1:)
                   else if(pos(1) < neg(1)) then !(3)
                     nsp=3
                     split(1)=string(1:pos(1)-1)
                     split(2)=string(pos(1)+1:neg(1)-1)
                     split(3)=string(neg(1):)
                   else if(pos(1) > neg(1)) then !(4)
                     nsp=3
                     split(1)=string(1:neg(1)-1)
                     split(2)=string(neg(1):pos(1)-1)
                     split(3)=string(pos(1)+1:)
                   end if
               Case(2) !Two options (1)+xxxx+yyyy  (2) xxxx+yyyy+zzzz
                   if(pos(1) == 1) then !(1)
                     nsp=2
                     split(1)=string(2:pos(2)-1)
                     split(2)=string(pos(2)+1:)
                   else   !2
                     nsp=3
                     split(1)=string(1:pos(1)-1)
                     split(2)=string(pos(1)+1:pos(2)-1)
                     split(3)=string(pos(2)+1:)
                   end if
             End Select

        Case(3)

             nsp=3
             Select Case(np)
               Case(0) !No positive terms  a single option: -xxxx - yyyy -  zzzz
                   split(1)=string(1:neg(2)-1)
                   split(2)=string(neg(2):neg(3)-1)
                   split(3)=string(neg(3):)
               Case(1) !Three options (1)+xxxx-yyyy-zzzz  (2)-xxxx+yyyy-zzzz  (3)-xxxx-yyyyy+zzzzz
                   if(pos(1) == 1) then !(1)
                     split(1)=string(2:neg(1)-1)
                     split(2)=string(neg(1):neg(2)-1)
                     split(3)=string(neg(2):)
                   else if(pos(1) <  neg(2)) then  !(2)
                     split(1)=string(1:pos(1)-1)
                     split(2)=string(pos(1)+1:neg(2)-1)
                     split(3)=string(neg(2):)
                   else if(pos(1) > neg(2)) then !(3)
                     split(1)=string(1:neg(2)-1)
                     split(2)=string(neg(2):pos(1)-1)
                     split(3)=string(pos(1)+1:)
                   end if
               Case(2) !Two options (1)+xxx+yyy-zzz  (2)-xxx+yyy+zzzz (3) +xxx-yyy+zzz
                   if(neg(1) == 1) then !(2)
                     split(1)=string(1:pos(1)-1)
                     split(2)=string(pos(1)+1:pos(2)-1)
                     split(3)=string(pos(2)+1:)
                   else if(neg(1) > pos(2)) then !(1)
                     split(1)=string(2:pos(2)-1)
                     split(2)=string(pos(2)+1:neg(1)-1)
                     split(3)=string(neg(1):)
                   else if(neg(1) < pos(2)) then !(3)
                     split(1)=string(2:neg(1)-1)
                     split(2)=string(neg(1):pos(2)-1)
                     split(3)=string(pos(2)+1:)
                   end if
               Case(3) !Single option (1)+xxx+yyy+zzz
                   split(1)=string(2:pos(2)-1)
                   split(2)=string(pos(2)+1:pos(3)-1)
                   split(3)=string(pos(3)+1:)
             End Select
      End Select
      do i=1,nsp
         split(i)=pack_string(split(i))
      end do
      !write(*,"(a,3a10)") " => Split items: ",(split(m),m=1,nsp)

      v(:) =0.0; nterm=0;  klist=0
      do m=1,nsp
         k=0
         j=0
         np=len_trim(split(m))
         do i=1,3
            j(i)=index(split(m),cod(i))
            if(j(i) /= 0) then
              k =i
              nterm=nterm+1
              klist(nterm)=i
              exit
            end if
         end do
         !write(*,"(a,i3)") " => Split: "//trim(split(m)),k
         if ( k == 0) cycle !the component is zero
         do i=1,nterm-1
            if(k == klist(i)) then
              !This is impossible in principle
              ERR_String= .true.
              ERR_String_Mess=" The provided symbol is illegal: "//trim(string)
              return
            end if
         end do
         jk=j(k)
         i=jk-1
         jp=jk+1
         if(i == 0 .and. np == 1 ) then !the code is the first character replace it by "1" and read the rest of the string
            split(m)(jk:jk)="1"
         else if(i == 0) then
            if(split(m)(jp:jp) ==  "/") then
              split(m)(jk:jk)="1"
            else
              split(m)(jk:jk)=" "
            end if
         else if(split(m)(i:i) == "-") then
            if(split(m)(jp:jp) ==  "/") then
               split(m)(jk:jk)="1"
            else  !There is a number on the right
               split(m)(jk:jk)=" "
            end if
         else   !there is a number on the left, remove the symbol, compact it and read
            split(m)(jk:jk)=" "
         end if
         split(m)=pack_string(split(m))
         call Read_Fract(split(m), v(k))
         !write(*,"(a,i3,a,f12.5)") " => Modified split: "//trim(split(m))//"  k=", k, "  v(k) =",v(k)
      end do
      return
    End Subroutine Get_Num_String

    !!----
    !!---- Subroutine Getnum(Line, Vet, Ivet, Iv)
    !!----    character(len=*),              intent( in) :: Line    !  In -> Input String to convert
    !!----    real(kind=cp), dimension(:),   intent(out) :: Vet     ! Out -> Vector of real numbers
    !!----    integer,dimension(:),          intent(out) :: Ivet    ! Out -> Vector of integer numbers
    !!----    integer,                       intent(out) :: Iv      ! Out -> Number of numbers in Vet/Ivet
    !!----
    !!----    Converts a string to numbers and write on VET/IVET if real/integer. Control
    !!----    of errors is possible by inquiring the global variables ERR_STRING and
    !!----    ERR_String_Mess
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Getnum(line,vet,ivet,iv)
       !---- Argument ----!
       character (len=*),          intent ( in) :: line
       real(kind=cp), dimension(:),intent (out) :: vet
       integer, dimension(:),      intent (out) :: ivet
       integer,                    intent (out) :: iv

       !---- Local variables ----!
       logical                   :: numero
       character (len=len(line)) :: resto,cifre
       integer                   :: i,isum,ncharl,nchard,isegno,iniz,ipoi,idec,idig
       integer                   :: nchart, npos,nchard1,isum_exp,ioper
       real(kind=cp)             :: suma,segno,dec
       real(kind=cp)             :: sum_m

       !---- Initializing variables ----!
       call init_err_string()
       iv=0
       ivet=0
       vet=0.0

       resto=u_case(line)

       do
          ioper=0
          isum_exp=0
          nchard1=0
          sum_m=0.0
          suma=0.0
          isum=0
          call cutst(resto,ncharl,cifre,nchard)
          if (nchard <= 0) exit

          !---- Is a number ----!
          numero=.true.
          do i=1,nchard
             if (cifre(i:i) =='E') cycle
             npos=index(digit,cifre(i:i))
             if (npos /= 0) cycle
             numero=.false.
          end do
          if (.not. numero) then
             err_string=.true.
             ERR_String_Mess="The variable cannot be computed as a number in GETNUM "
             return
          end if

          !---- Positive or Negative number ----!
          segno=1.0
          isegno=1
          iniz=1
          if (cifre(1:1) == digit(12:12)) then
             segno=-1.0
             isegno=-1
             iniz=2
          end if

          !---- Decimal Number ----!
          ipoi=index(cifre(1:nchard),digit(11:11))

          !---- Exponential Number ----!
          nchard1=index(cifre(1:nchard),"E")
          if (nchard1 /= 0) then
             nchart=nchard
             nchard=nchard1-1
          end if

          if (ipoi == 0) ipoi=nchard+1
          dec=real(ipoi-1-iniz)
          idec=ipoi-1-iniz
          do i=iniz,nchard
             idig=index(digit,cifre(i:i))
             if (idig >= 1 .and. idig <= 11)  then
                if (idig <= 10)  then
                   suma=suma+real(idig-1)*10.0**dec
                   if (idec >= 0) isum=isum*10+(idig-1)
                   dec=dec-1.0
                   idec=idec-1
                end if
             else
                err_string=.true.
                ERR_String_Mess="Limits of digit variable exceeded in GETNUM"
                return
             end if
          end do

          if (nchard1 /= 0) then
             nchard1=nchard1+1
             select case (cifre(nchard1:nchard1))
                case ("-")
                   ioper=1
                   nchard1=nchard1+1

                case ("+")
                   nchard1=nchard1+1
             end select

             do i=nchard1,nchart
                idig=index(digit,cifre(i:i))
                if (idig >= 1 .and. idig <= 10)  then
                   isum_exp=isum_exp*10+(idig-1)
                else
                   err_string=.true.
                   ERR_String_Mess="Limits of digit variable exceeded in GETNUM"
                   return
                end if
             end do
          end if

          iv=iv+1
          vet(iv)=suma*segno
          ivet(iv)=isum*isegno

          if (nchard1 /= 0) then
             select case (ioper)
                case (0)
                   sum_m=10.0**isum_exp

                case (1)
                   sum_m=10.0**isum_exp
                   sum_m=1.0/sum_m
             end select
             vet(iv)=vet(iv)*sum_m
          end if

          if (ncharl <= 0) then
             exit
          end if
       end do

       return
    End Subroutine Getnum

    !!----
    !!---- Subroutine Getnum_Std(Line, Value, Std, Ic)
    !!----    character(len=*),            intent( in) :: Line    !  In -> Input String
    !!----    real(kind=cp), dimension(:), intent(out) :: Value   ! Out -> Vector of values with real numbers
    !!----    real(kind=cp), dimension(:), intent(out) :: Std     ! Out -> Vector of standard deviation values
    !!----    integer,                     intent(out) :: Ic      ! Out -> Number of components of vector Value
    !!----
    !!----    Converts a string to a numbers with standard deviation with format: x.fffff(s)
    !!----    Control of errors is possible by inquiring the global variables ERR_STRING
    !!----    and ERR_String_Mess.
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine GetNum_Std(line, value, std, ic)
       !----Arguments ----!
       character(len=*),             intent( in) :: line
       real(kind=cp), dimension(:),  intent(out) :: value
       real(kind=cp), dimension(:),  intent(out) :: std
       integer,                      intent(out) :: ic

       !---- Local Variables ----!
       character(len=len(line))               :: resto,dire,numm
       integer                                :: iv,nlong
       integer                                :: np, np1, np2
       integer, dimension(size(value))        :: ivet
       real(kind=cp), dimension(size(value))  :: vet

       value=0.0
       std  =0.0
       ic   =0
       call init_err_string()

       !---- Initial Checks ----!
       if (len_trim(line) == 0) then
          err_string=.true.
          ERR_String_Mess="Blank line"
          return
       end if
       resto=adjustl(line)

       do
          if (len_trim(resto) == 0) exit
          call cutst(resto,nlong,dire)
          np1=index(dire,"(")
          np2=index(dire,")")

          if ( (np2 < np1) .or.               &  ! ")" before than "("
               (np1==0 .and. np2 >0) .or.     &  ! "(" doesn"t exists
               (np2==0 .and. np1 >0) ) then      ! ")" doesn"t exists
             err_string=.true.
             ERR_String_Mess="Wrong format using Standard values"
             return
          end if

          if (np1 == 0 .and. np2 ==0) then
             call getnum(dire,vet,ivet,iv)
             if (iv /= 1 .or. err_string) then
                err_string=.true.
                ERR_String_Mess="Bad format"
                return
             end if
             ic=ic+1
             value(ic)=vet(1)
          else
             numm=dire(1:np1-1)
             np=index(numm,".")
             if (np == 0) then
                call getnum(numm,vet,ivet,iv)
                if (iv /= 1 .or. err_string) then
                   err_string=.true.
                   ERR_String_Mess="Bad format"
                   return
                end if
                ic=ic+1
                value(ic)=vet(1)
                numm=dire(np1+1:np2-1)
                call getnum(numm,vet,ivet,iv)
                if (iv /= 1) then
                   err_string=.true.
                   ERR_String_Mess="Bad format"
                   return
                end if
                std(ic)=vet(1)
             else
                np=np1-np-1
                call getnum(numm,vet,ivet,iv)
                if (iv /= 1 .or. err_string) then
                   err_string=.true.
                   ERR_String_Mess="Bad format"
                   return
                end if
                ic=ic+1
                value(ic)=vet(1)
                numm=dire(np1+1:np2-1)
                call getnum(numm,vet,ivet,iv)
                if (iv /= 1 .or. err_string) then
                   err_string=.true.
                   ERR_String_Mess="Bad format"
                   return
                end if
                std(ic)=vet(1)/(10.0**np)
             end if
          end if
       end do

       return
    End Subroutine GetNum_Std

    !!----
    !!---- Subroutine Get_Separator_Pos(line,car,pos,ncar)
    !!----   character(len=*),      intent(in)  :: line  ! In -> Input String
    !!----   character(len=1),      intent(in)  :: car   ! In -> Separator character
    !!----   integer, dimension(:), intent(out) :: pos   ! Out -> Vector with positions of "car" in "Line"
    !!----   integer,               intent(out) :: ncar  ! Out -> Number of appearance of "car" in "Line"
    !!----
    !!----    Determines the positions of the separator character "car" in string "Line" and generates
    !!----    the vector Pos containing the positions. The number of times the character "car" appears
    !!----    In "Line" is stored in "ncar".
    !!----    The separator "car" is not counted within substrings of "Line" that are written within
    !!----    quotes. The following example illustrates the functionning of the subroutine
    !!----
    !!----       !       12345678901234567890123456789012345678901234567890
    !!----        line =' 23, "List, of, authors", this book, year=1989'
    !!----
    !!----    A call like:  call Get_Separator_Pos(line,',',pos,ncar) provides
    !!----    ncar= 3
    !!----    pos= (/ 4, 25, 36, 0, ..../)
    !!----
    !!---- Update: December 2009
    !!
    Subroutine Get_Separator_Pos(line,car,pos,ncar)
      character(len=*),      intent(in)  :: line
      character(len=1),      intent(in)  :: car
      integer, dimension(:), intent(out) :: pos
      integer,               intent(out) :: ncar
      integer :: i,j,k

      ncar=0
      j=0
      do i=1,len_trim(line)
        j=j+1
        if(line(j:j) == '"') then  !A chains of characters is found, advance up the the next "
          do k=1,len_trim(line)    !the character "car" is ignored if it is within " "
            j=j+1
            if(line(j:j) /= '"') cycle
            exit
          end do
        end if
        if(line(j:j) == car) then
          ncar=ncar+1
          pos(ncar)=j
        end if
      end do
      return
    End Subroutine Get_Separator_Pos

    !!----
    !!---- Subroutine Get_Substring_Positions(string,substr,pos,nsubs)
    !!----   character(len=*),      intent(in)  :: string   ! In -> Input String
    !!----   character(len=*),      intent(in)  :: substr   ! In -> Substring
    !!----   integer, dimension(:), intent(out) :: pos      ! Out -> Vector with positions of the firs character of "substr" in "String"
    !!----   integer,               intent(out) :: nsubs    ! Out -> Number of appearance of "substr" in "String"
    !!----
    !!----    Determines the positions of the substring "substr" in "String" and generates
    !!----    the vector Pos containing the positions of the first character of "substr" in "String".
    !!----    The number of times the "substr" appears in "String" is stored in "nsubs".
    !!----
    !!----     Updated: May 2014

    Subroutine Get_Substring_Positions(string,substr,pos,nsubs)
      character(len=*),      intent(in)  :: string
      character(len=*),      intent(in)  :: substr
      integer, dimension(:), intent(out) :: pos
      integer,               intent(out) :: nsubs
      integer :: i,j,lsubs

      nsubs=0
      lsubs=len_trim(substr)
      j=0
      do i=1,len_trim(string)
        j=j+1
        if(string(j:j+lsubs-1) == trim(substr)) then
          nsubs=nsubs+1
          pos(nsubs)=j
        end if
      end do
      return
    End Subroutine Get_Substring_Positions

    !!----
    !!---- Subroutine Getword(Line, Dire, Ic)
    !!----    character(len=*),              intent( in) :: Line   !  In -> Input String
    !!----    character(len=*),dimension(:), intent(out) :: Dire   ! Out -> Vector of Words
    !!----    integer,                       intent(out) :: Ic     ! Out -> Number of words
    !!----
    !!----    Determines the number of words (Ic) in the string "Line" and generates a
    !!----    character vector "Dire" with separated words.
    !!----    Control of errors is possible by inquiring the global variables ERR_STRING
    !!----    and ERR_String_Mess. The last modification allows to treat strings between
    !!----    quotes as a single word.
    !!----
    !!---- Update: July - 2011
    !!
    Subroutine Getword(line,dire,ic)
       !---- Argument ----!
       character (len=*),                 intent ( in) :: line
       character (len=*), dimension(:),   intent (out) :: dire
       integer,                           intent (out) :: ic

       !---- Local variables ----!
       character (len=len(line)) :: line1,line2
       integer                   :: nlong2
       integer                   :: ndim, j

       call init_err_string()
       ic=0
       ndim=size(dire)
       line1=line

       do
          line1=adjustl(line1)
          if(line1(1:1) == '"') then
             j=index(line1(2:),'"')
             if( j > 0) then
               line2=line1(2:j)
               nlong2=len_trim(line2)
               line1 = line1(j+2:)
             else
               err_string=.true.
               ERR_String_Mess="Non balanced quotes!"
               exit
             end if
          else
             call cutst(line1,line2=line2,nlong2=nlong2)
          end if
          if (nlong2 == 0) exit
          ic=ic+1
          if (ic > ndim) then
             err_string=.true.
             ERR_String_Mess="Dimension of DIRE exceeded"
             exit
          end if
          dire(ic)=line2(:nlong2)
       end do

       return
    End Subroutine Getword

    !!----
    !!---- Subroutine Inc_LineNum(line_n)
    !!----  integer, intent(in) :: line_n
    !!----
    !!----    Increments the current line number
    !!----    Used when a way of reading other than FindFMT is used
    !!----
    !!---- Update: November - 2006
    !!
    Subroutine Inc_LineNum(line_n)
       !---- Argument ----!
       integer, intent(in) :: line_n

       line_nb=line_nb+line_n

       return
    End Subroutine Inc_LineNum

    !!----
    !!---- Subroutine Init_Err_String()
    !!----
    !!----    Initializes general error variables for this module as:
    !!----    ERR_STRING=.false. ;  ERR_String_Mess=" "
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Init_Err_String()

       err_string=.false.
       ERR_String_Mess=" "

       return
    End Subroutine Init_Err_String

    !!----
    !!---- Subroutine Init_FindFMT(nline)
    !!----   integer, optional, intent(in) :: nline
    !!----
    !!----    Initializes the subroutine FindFMT.
    !!----    Mess_FindFMT (of type Err_Text_Type) is initialized to zero lines.
    !!----    Line_nb is initialized to zero (current line in the file),
    !!----    or Line_nb=line if the optional argument "line" is present.
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Init_FindFMT(nline)
       !---- Arguments ----!
       integer, optional, intent(in) :: nline

       line_nb=0
       if(present(nline)) line_nb=nline
       Mess_FindFMT = Err_Text_Type(0,(/" "," "," "," "," "/))

       return
    End Subroutine Init_FindFMT

    !!----
    !!---- Subroutine Lcase(Line)
    !!----    character(len=*), intent(in out) :: Line
    !!----
    !!----    Conversion to lower case. Line is modified
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Lcase(line)
       !---- Argument ----!
       character (len=*), intent(in out) :: line

       line=l_case(line)

       return
    End Subroutine Lcase

    !!----
    !!---- Subroutine Number_Lines(Filename,n, input_string)
    !!----    character(len=*), intent(in) :: Filename     !  In -> Name of the file
    !!----    integer        , intent(out) :: N            ! Out -> Number of lines in the file
    !!----    character(len=*), optional,intent(in) :: input_string   ! In -> String to exit
    !!----
    !!----    Return the number of lines contained in a file. The file will be opened and closed before
    !!----    returning to the calling unit.
    !!----    If 'input_string' is present, return the number of lines until 'input_string' is founded
    !!----    as first string in the line
    !!----    (example : input_string =='END' : avoid Q peaks in a SHELX file)
    !!----
    !!---- Update: February - 2005, March-2014 (removing the "opened" inquire, JRC)
    !!
    Subroutine Number_Lines(filename,n, input_string)
       !---- Arguments ----!
       character(len=*), intent(in)  :: filename
       integer,          intent(out) :: n
       character(len=*), optional, intent(in) :: input_string       ! TR may 2013

       !---- Local Variables ----!
       logical            :: info
       integer            :: lun,cond
       character (len=256):: read_line                             ! TR may 2013
       integer            :: long                                  ! TR may 2013

       !---- Init ----!
       info=.false.
       call get_logunit(lun)
       n=0
       cond=0

       if(present(input_string)) long = len_trim(input_string)    ! TR may 2013

       !---- Exist filename ? ----!
       inquire (file=filename,exist=info)
       if (.not. info) return

       open(unit=lun,file=filename, status="old",action="read", position="rewind")

       !---- Counting lines ----!
       do
          read(unit=lun,fmt="(a)",iostat=cond) read_line
          if (cond /= 0) exit
          read_line=adjustl(read_line)
          if(present(input_string)) then                                         ! TR may 2013
            if(u_case(read_line(1:long)) == u_case(input_string(1:long))) exit
          end if
          n=n+1
       end do

       close(unit=lun)

       return
    End Subroutine Number_Lines

    !!----
    !!---- Subroutine NumCol_from_NumFmt(Text,n_col)
    !!----    character (len=*), intent(in) :: text   !  In -> String: "InPUT Format String"
    !!----    Integer,           intent(out):: n_col  ! Out -> Integer number of columns
    !!----
    !!----    Provides the number of columns spanned by a numeric format field F,I,G,E
    !!----
    !!---- Update: January - 2006
    !!
    Subroutine NumCol_from_NumFmt(Text,n_col)
       !---- Argument ----!
       character (len=*), intent(in) :: text
       Integer,           intent(out) :: n_col

       !---- Local variables ----!
       integer  :: i,j,L,ncom,n1,n2,point,ier
       integer,dimension(0:len(Text)) :: pos
       character (len=len(Text)) :: fm
       character (len=10) :: string

       fm=U_case(adjustl(Text))
       fm=pack_string(fm)
       L=len_trim(fm)
       fm=fm(2:L-1)
       L=L-2
       ncom=0
       pos(0)=0
       do i=1,L
         if(fm(i:i) == ",") then
            ncom=ncom+1
            pos(ncom)=i
         end if
       end do
       ncom=ncom+1
       pos(ncom)=L+1
       n_col=0
       do i=1,ncom
         string=" "
         string=fm(pos(i-1)+1:pos(i)-1)
         point=index(string,".")
         if( point /= 0) string=string(1:point-1)
         L=len_trim(string)
         do j=1,L
           point=index("FIGEX",string(j:j))
           if(point /= 0) then
              point=j
              exit
           end if
         end do
         n1=0
         Select Case (point)
            Case(0)
              n_col=0
              exit
            Case(1)
              string(point:point) = " "
              read(unit=string,fmt=*,iostat=ier) n2
              if(ier /= 0) n2=0
              n1=1
            Case default
              if(string(point:point)=="X") then
                string(point:point) = " "
                n1=1
                read(unit=string,fmt=*,iostat=ier) n2
                if(ier /= 0) n2=0
              else
                string(point:point) = " "
                read(unit=string,fmt=*,iostat=ier) n1,n2
                if(ier /= 0) n2=0
              end if
         End Select
         n_col=n_col+n1*n2
       end do
       if(n_col == 0) then
              err_string=.true.
              ERR_String_Mess="Illegal format string passed to subroutine:  NumCol_from_NumFmt"
       end if
       return
    End Subroutine NumCol_from_NumFmt

    !!--..  Subroutine Read_Fract(str,valu)
    !!--..   Character(len=*), intent(in) :: str
    !!--..   real(kind=cp),    intent(out):: valu
    !!--..
    !!--..  Auxiliary subroutine for reading a string containing a real number
    !!--..  or a fraction. Is able to handle simple symbols:"", "-", "+", means
    !!--..  respectively: 1,-1,1
    !!--..
    !!--..  Created: February - 2012 (JRC).
    !!--..
    Subroutine Read_Fract(str,valu)
     Character(len=*), intent(in) :: str
     real(kind=cp),    intent(out):: valu
     !--- Local variables ---!
     integer :: k, ierr
     real(kind=cp) :: num,den

     if(len_trim(str) == 0) then
       valu=1.0
       return
     else if(len_trim(str) == 1) then
       if(str == "+") then
        valu=1.0
        return
       else if(str == "-") then
        valu=-1.0
        return
       end if
     end if
     k=index(str,"/")
     if(k == 0) then !a single number
       read(unit=str,fmt=*,iostat=ierr) valu
       if(ierr /= 0) then
          valu=0.0
          ERR_String= .true.
          ERR_String_Mess=" The provided symbol is illegal: "//trim(str)
          return
       end if
     else !fraction
       read(unit=str(1:k-1),fmt=*,iostat=ierr) num
       if(ierr /= 0) then
          valu=0.0
          ERR_String= .true.
          ERR_String_Mess=" The provided symbol is illegal: "//str(1:k-1)
          return
       end if
       read(unit=str(k+1:),fmt=*,iostat=ierr) den
       if(ierr /= 0) then
          valu=0.0
          ERR_String= .true.
          ERR_String_Mess=" The provided symbol is illegal: "//str(k+1:)
          return
       end if
       valu=num/den
     end if
    End Subroutine Read_Fract


    !!----
    !!---- Subroutine Read_Key_Str(Filevar,Nline_Ini,Nline_End,Keyword,String)
    !!----    character(len=*),dimension(:), intent(in)      :: Filevar      !  In -> Input vector of String
    !!----    integer,                       intent(in out)  :: Nline_Ini    !  In -> Pointer to initial position to search
    !!----                                                                   ! Out -> Pointer to final position in search
    !!----    integer,                       intent(in)      :: Nline_End    !  In -> Pointer to final position to search
    !!----    character(len=*),              intent(in)      :: Keyword      !  In -> Word to search
    !!----    character(len=*),              intent(out)     :: String       ! Out -> Rest of the input string
    !!----    character(len=1), optional,    intent(in)      :: comment      !  In -> Character that define a comment line
    !!----
    !!----    Read a string on "filevar" starting with a particular "keyword" between lines "nline_ini" and
    !!----    "nline_end".
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Read_Key_Str(filevar,nline_ini,nline_end,keyword,string,comment)
       !---- Arguments ----!
       character(len=*), dimension(:), intent(in)      :: filevar
       integer,                        intent(in out)  :: nline_ini
       integer,                        intent(in)      :: nline_end
       character(len=*),               intent(in)      :: keyword
       character(len=*),               intent(out)     :: string
       character(len=1), optional,     intent(in)      :: comment

       !---- Local Variable ----!
       character(len=len(filevar(1))) :: line,linec
       character(len=len(keyword))    :: key
       character(len=1)               :: cc
       integer                        :: i,np,nt

       !---- Initial value ----!
       cc=' '
       if (present(comment)) cc=comment
       nt=min(size(filevar),nline_end)
       string=" "
       key =adjustl(keyword)
       call lcase(key)

       do i=nline_ini,nt
          line=adjustl(filevar(i))
          if (len_trim(line) == 0 .or. line(1:1) == "!" .or. line(1:1) ==cc) cycle
          linec=line
          call lcase(line)
          np=index(line,key)
          if (np == 0) cycle
          linec=linec(np:)
          call cutst(linec)
          string=linec
          nline_ini=i
          exit
       end do

       return
    End Subroutine Read_Key_Str

    !!----
    !!---- Subroutine Read_Key_Strval(Filevar,Nline_Ini,Nline_End,Keyword,String,Vet,Ivet,Iv,comment)
    !!----    character(len=*),dimension(:),          intent(in)      :: Filevar      !  In -> Input vector of String
    !!----    integer,                                intent(in out)  :: Nline_Ini    !  In -> Pointer to initial position to search
    !!----                                                                            ! Out -> Pointer to final position in search
    !!----    integer,                                intent(in)      :: Nline_End    !  In -> Pointer to final position to search
    !!----    character(len=*),                       intent(in)      :: Keyword      !  In -> Word to search
    !!----    character(len=*),                       intent(out)     :: String       ! Out -> Rest of the input string
    !!----    real(kind=cp),dimension(:),   optional, intent(out)     :: Vet          ! Out -> Vector for real numbers
    !!----    integer,dimension(:),         optional  intent(out)     :: Ivet         ! Out -> Vector for integer numbers
    !!----    integer,                      optional, intent(out)     :: Iv           ! Out -> Number of numbers
    !!----    character(len=1),             optional, intent(in)      :: comment
    !!----
    !!----    Read a string on "filevar" starting with a particular "keyword" between lines "nline_ini" and
    !!----    "nline_end". If the string contains numbers they are read and put into "vet/ivet". The variable
    !!----    "string" contains the input string without the "keyword".
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Read_Key_StrVal(filevar,nline_ini,nline_end,keyword,string,vet,ivet,iv,comment)
       !---- Arguments ----!
       character(len=*), dimension(:),           intent(in)      :: filevar
       integer,                                  intent(in out)  :: nline_ini
       integer,                                  intent(in)      :: nline_end
       character(len=*),                         intent(in)      :: keyword
       character(len=*),                         intent(out)     :: string
       real(kind=cp),dimension(:),     optional, intent(out)     :: vet
       integer,dimension(:),           optional, intent(out)     :: ivet
       integer,                        optional, intent(out)     :: iv
       character(len=1),               optional, intent(in)      :: comment

       !---- Local Variable ----!
       logical                        :: sval
       character(len=len(filevar(1))) :: line,linec
       character(len=len(keyword))    :: key
       character(len=1)               :: cc
       integer                        :: i,np,nt

       !---- Initial value ----!
       cc=' '
       if (present(comment)) cc=comment

       nt=min(size(filevar),nline_end)
       string=" "
       key =adjustl(keyword)
       call lcase(key)
       sval=.false.
       if (present(vet) .and. present(ivet) .and. present(iv)) sval=.true.
       if (sval) then
          vet=0.0
         ivet=0
           iv=0
       end if

       do i=nline_ini,nt
          line=adjustl(filevar(i))
          if (len_trim(line) == 0 .or. line(1:1)=="!" .or. line(1:1)==cc) cycle
          linec=line
          call lcase(line)
          np=index(line,key)
          if (np == 0) cycle
          linec=linec(np:)
          call cutst(linec)
          string=linec
          nline_ini=i
          exit
       end do

       if (sval .and. (len_trim(string) > 0) ) then
          line=string

          !---- String Value ----!
          !call cutst(line,np,string)

          !---- Values ----!
          call getnum(line,vet,ivet,iv)
          if (iv <=0) then
              vet=0.0
             ivet=0
          end if
       end if

       return
    End Subroutine Read_Key_StrVal

    !!----
    !!---- Subroutine Read_Key_Value(Filevar,Nline_Ini,Nline_End,Keyword,Vet,Ivet,Iv,comment,line_key)
    !!----    character(len=*),dimension(:), intent(in)      :: Filevar     !  In -> Input vector of String
    !!----    integer,                       intent(in out)  :: Nline_Ini   !  In -> Pointer to initial position to search
    !!----                                                                  ! Out -> Pointer to final position in search
    !!----    integer,                       intent(in)      :: Nline_End   !  In -> Pointer to final position to search
    !!----    character(len=*),              intent(in)      :: Keyword     !  In -> Word to search
    !!----    real(kind=cp),dimension(:),    intent(out)     :: Vet         ! Out -> Vector for real numbers
    !!----    integer,dimension(:),          intent(out)     :: Ivet        ! Out -> Vector for integer numbers
    !!----    integer,                       intent(out)     :: Iv          ! Out -> Number of components
    !!----    character(len=1),     optional, intent(in)     :: comment     ! Consider the character passed in comment as a comment to skip the line
    !!----    character(len=*),     optional, intent(out)    :: Iv          ! Out -> Cut line where keyword is read
    !!----
    !!----    Read a string on "filevar" starting with a particular "keyword" between lines "nline_ini" and
    !!----    "nline_end". If the string contains numbers they are read and put into "vet/ivet".
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Read_Key_Value(filevar,nline_ini,nline_end,keyword,vet,ivet,iv,comment,line_key)
       !---- Arguments ----!
       character(len=*), dimension(:), intent(in)     :: filevar
       integer,                        intent(in out) :: nline_ini
       integer,                        intent(in)     :: nline_end
       character(len=*),               intent(in)     :: keyword
       real(kind=cp),dimension(:),     intent(out)    :: vet
       integer,dimension(:),           intent(out)    :: ivet
       integer,                        intent(out)    :: iv
       character(len=1),     optional, intent(in)     :: comment
       character(len=*),     optional, intent(out)    :: line_key

       !---- Local Variable ----!
       character(len=len(filevar(1))) :: line
       character(len=len(keyword))    :: key
       character(len=1)               :: cc
       integer                        :: i,np,nt

       !---- Initial value ----!
       cc=' '
       if (present(comment)) cc=comment

       nt=min(size(filevar),nline_end)
       iv  = 0
       vet = 0.0
       ivet= 0
       key =adjustl(keyword)
       call lcase(key)

       do i=nline_ini,nt
          np=0
          line=adjustl(filevar(i))
          if (len_trim(line) == 0 .or. line(1:1) == "!" .or. line(1:1)==cc) cycle
          call lcase(line)
          np=index(line,key)
          if (np == 0) cycle
          line=line(np:)
          call cutst(line)
          call getnum(line,vet,ivet,iv)
          if(present(line_key)) line_key=line
          if (err_string) exit
          nline_ini=i
          exit
       end do

       return
    End Subroutine Read_Key_Value

    !!----
    !!---- Subroutine Read_Key_Valuest(Filevar,Nline_Ini,Nline_End,Keyword,Vet1,Vet2,Iv,comment)
    !!----    character(len=*),dimension(:),  intent(in)     :: Filevar      !  In -> Input vector of String
    !!----    integer,                        intent(in out) :: Nline_Ini    !  In -> Pointer to initial position to search
    !!----                                                                   ! Out -> Pointer to final position in search
    !!----    integer,                        intent(in)     :: Nline_End    !  In -> Pointer to final position to search
    !!----    character(len=*),               intent(in)     :: Keyword      !  In -> Word to search
    !!----    real(kind=cp),dimension(:),     intent(out)    :: Vet1         ! Out -> Vector of real numbers
    !!----    real(kind=cp),dimension(:),     intent(out)    :: Vet2         ! Out -> Vector of standard deviations
    !!----    integer,                        intent(out)    :: Iv           ! Out -> Number of components
    !!----
    !!----    Read parameters and standard deviation on the line of "filevar" starting with a particular "keyword".
    !!----    The search is done between lines "nline_ini" and "nline_end".
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Read_Key_ValueSTD(filevar,nline_ini,nline_end,keyword,vet1,vet2,iv,comment)
       !---- Arguments ----!
       character(len=*), dimension(:),  intent(in)     :: filevar
       integer,                         intent(in out) :: nline_ini
       integer,                         intent(in)     :: nline_end
       character(len=*),                intent(in)     :: keyword
       real(kind=cp),dimension(:),      intent(out)    :: vet1
       real(kind=cp),dimension(:),      intent(out)    :: vet2
       integer,                         intent(out)    :: iv
       character(len=1),      optional, intent(in)     :: comment

       !---- Local Variable ----!
       character(len=len(filevar(1))) :: line
       character(len=len(keyword))    :: key
       character(len=1)               :: cc
       integer                        :: i,np,nt

       !---- Initial value ----!
       cc=' '
       if (present(comment)) cc=comment
       nt=min(size(filevar),nline_end)
       iv  = 0
       vet1 = 0.0
       vet2 = 0.0
       key =adjustl(keyword)
       call lcase(key)

       do i=nline_ini,nt
          line=adjustl(filevar(i))
          if (len_trim(line) == 0 .or. line(1:1) == "!" .or. line(1:1)==cc) cycle
          call lcase(line)
          np=index(line,key)
          if (np == 0) cycle
          line=line(np:)
          call cutst(line)
          call getnum_std(line,vet1,vet2,iv)
          if (err_string) exit
          nline_ini=i
          exit
       end do

       return
    End Subroutine Read_Key_ValueSTD

    !!----
    !!---- Subroutine Reading_Lines(Filename,Nlines,Filevar)
    !!----    character(len= *), intent(in)                :: Filename   !  In -> Filename
    !!----    integer,           intent(in)                :: Nlines     !  In -> Number of lines to read
    !!----    character(len= *), dimension(:), intent(out) :: Filevar    ! Out -> String vector
    !!----
    !!----    Read nlines of the file and put the information on Filevar. The file is opened to read the
    !!----    lines and closed before returning to the calling unit.
    !!----
    !!---- Update: February - 2005, March-2014 (eliminating the "opened" inquire,JRC)
    !!
    Subroutine Reading_Lines(filename,nlines,filevar)
       !---- Arguments ----!
       character(len=*),               intent( in) :: filename
       integer,                        intent( in) :: nlines
       character(len=*), dimension(:), intent(out) :: filevar

       !---- Local Variables ----!
       logical :: info
       integer :: lun,i

       !---- Init ----!
       call init_err_string()
       info=.false.
       call get_logunit(lun)

       !---- Exist filename ? ----!
       inquire (file=filename,exist=info)
       if (.not. info) then
          err_string=.true.
          ERR_String_Mess="The file"//trim(filename)//" does not exist "
          return
       end if

       open(unit=lun,file=filename, status="old",action="read", position="rewind")

       !---- Reading... ----!
       do i=1,nlines
          read(unit=lun,fmt="(a)") filevar(i)
       end do

       close(unit=lun)

       return
    End Subroutine Reading_Lines

    !!----
    !!----
    !!---- Subroutine SetNum_Std(Value,Std,Line)
    !!----    real(kind=cp),            intent(in)  :: Value
    !!----    real(kind=cp),            intent(in)  :: Std
    !!----    character(len=*),intent (out):: Line
    !!----
    !!----    String with real value and standard deviation
    !!----    quoted in parenthesis
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine SetNum_Std(Value, Std, Line)
       !---- Argument ----!
       real(kind=cp),   intent(in)  :: Value
       real(kind=cp),   intent(in)  :: Std
       character(len=*),intent (out):: Line

       !---- Local Variables ----!
       character(len=10) :: fmtcar
       character(len=40) :: aux
       integer           :: n,np,iy,long
       real(kind=cp)     :: y

       if (abs(std) < 0.0000001) then
          if (abs(value) > 999999.0) then
             write(unit=aux,fmt=*) value
          else
             write(unit=aux,fmt="(f14.6)") value
          end if
          line=adjustl(aux)
          if (line(1:1) /= "-") line=" "//trim(line)
          return
       end if

       np=0
       y=std
       do
          if (y >= 2.0) exit
          np=np+1
          y=y*10.0
       end do
       iy=nint(y)

       aux=" "
       write(unit=aux,fmt=*) value
       line=trim(adjustl(aux))
       n=len_trim(line)
       if(n-np < 6) n=np+6
       fmtcar="f"
       if (n < 10) then
          write(unit=fmtcar(2:2),fmt="(i1)") n
       else
          write(unit=fmtcar(2:3),fmt="(i2)") n
       end if

       fmtcar=trim(fmtcar)//"."
       n=len_trim(fmtcar)
       if (np < 10) then
          write(unit=fmtcar(n+1:),fmt="(i1)") np
       else
          write(unit=fmtcar(n+1:),fmt="(i2)") np
       end if
       fmtcar="("//trim(fmtcar)//")"

       aux=" "
       write(unit=aux,fmt=fmtcar) value
       line=trim(adjustl(aux))
       n=len_trim(line)
       if (line(n:n) == ".") then
          line(n:n)=" "
       end if
       line=trim(line)//"("
       n=len_trim(line)
       np=len(line)-n-1             !number of available places for writing
       aux=" "
       write(unit=aux,fmt=*) iy
       aux=pack_string(aux)
       long=len_trim(aux)
       if(long > np) then
         line=line(1:n)//aux(1:np)//")"
       else
          line=line(1:n)//trim(aux)//")"
       end if
       line=pack_string(line)

       if(line(1:1) /= "-") line=" "//trim(line)

       return
    End Subroutine SetNum_Std

    !!--++
    !!--++ Subroutine SGetFTMfield(GetFTMfield,FMTfields,nFld,nFldMax)
    !!--++    Integer ,          intent(out)    ::  GetFTMfield
    !!--++    Character (len=*) ,intent( in)    ::  FMTfields     !  -> format descriptor
    !!--++    Integer ,          intent(in out) ::  nFld          ! <-> current field in format descriptor
    !!--++    Integer ,          intent( in)    ::  nFldMax       !  -> max. number of fields in format descriptor
    !!--++
    !!--++    (PRIVATE)
    !!--++    Get current field type
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine SGetFTMfield(GetFTMfield,FMTfields,nFld,nFldMax)
       !---- Arguments ----!
       Character (len=*) ,intent( in)    ::  FMTfields
       Integer ,          intent(in out) ::  nFld
       Integer ,          intent( in)    ::  nFldMax
       Integer ,          intent(out)    ::  GetFTMfield

       !---- Local variables ----!
       character (len=1) ::  Car

       nFld = nFld + 1
       if (nFld > nFldMax) then
          GetFTMfield = iEndFMT
       else
          Car = FMTfields(nFld:nFld)
          if (Car == "I") then
             GetFTMfield = iInte
          else if (Car == "F") then
             GetFTMfield = iReal
          else if (iChar(Car) >= i_One .and. iChar(Car) <= i_Nine) then
             GetFTMfield = iChar(Car)
          else if (Car == "A") then
             GetFTMfield = 10+i_Zero
          else if (Car == "B") then
             GetFTMfield = 11+i_Zero
          else if (Car == "C") then
             GetFTMfield = 12+i_Zero
          else if (Car == "D") then
             GetFTMfield = 13+i_Zero
          else if (Car == "E") then
             GetFTMfield = 14+i_Zero
          else
             GetFTMfield = iEndFMT
             iErr_fmt = iErrInvalField         ! Error in field definition
          end if
       end if

       return
    End Subroutine SGetFTMfield

    !!----
    !!----
    !!---- Subroutine SString_Replace(string, substr, rep_string,warning)
    !!----    character(len=*), intent(in out) :: string
    !!----    character(len=*), intent(in)     :: substr
    !!----    character(len=*), intent(in)     :: rep_string
    !!----    character(len=*), intent(out)    :: warning
    !!----
    !!----    Subroutine to replace a substring (substr) by another one (rep_string)
    !!----    within a given string (string). The original string is modified on output.
    !!----    If len_trim(warning) /= 0, one of the substrings will not be complete,
    !!----    it works as a warning or error condition without interrupting the
    !!----    procedure.
    !!----
    !!---- Updated: May - 2014
    !!
    Subroutine SString_Replace(string, substr, rep_string,warning)
      character(len=*), intent(in out) :: string
      character(len=*), intent(in)     :: substr
      character(len=*), intent(in)     :: rep_string
      character(len=*), intent(out)    :: warning
      ! --- Local variables ---!
      integer                                      :: i,j,lstr,ncount,nsubs,d,dmax
      integer,            dimension(:),allocatable :: pos
      character(len=1024),dimension(:),allocatable :: splitted_string

      lstr=len(substr)
      warning=" "
      i=index(rep_string,substr)
      if(i /= 0) then !Check if the substring to be replaced is contained in the replacing string
         !In such case the alternative short code doesn't work ... we have to use the longer analysis below
         ncount=String_Count(string,trim(substr))+1
         allocate(pos(ncount))
         allocate(splitted_string(ncount))
         call Get_Substring_Positions(string,substr,pos,nsubs)
         dmax=0
         do i=2,nsubs
           d=pos(i)-pos(i-1)
           if(d > dmax) dmax=d
         end do
         if(dmax > 1024) write(unit=warning,fmt="(a)") " => Warning! ... string too long to be fetch into the splitted_string"
         !Construct the splitted string
         j=1
         splitted_string(j)=string(1:pos(j)-1)
         do
           j=j+1
           if(j > nsubs) exit
           splitted_string(j)=string(pos(j-1)+lstr:pos(j)-1)
         end do
         splitted_string(ncount)=string(pos(nsubs)+lstr:)
         !Construct now the full string
         string=""
         do i=1,nsubs
           string=trim(string)//trim(splitted_string(i))//rep_string
         end do
         string=trim(string)//trim(splitted_string(ncount))

      else  !The following short code works easily when substr is not contained in rep_string

         do
           i=index(string,substr)
           if (i == 0) exit
           string=string(1:i-1)//rep_string//trim(string(i+lstr:))
         end do

      end if
      return
    End Subroutine SString_Replace

    !!--++
    !!--++ Subroutine TreatMCharField(iFld,aLine,L_Line,nC_L,nC_X)
    !!--++    Integer,          intent(in out)  :: iFld   ! <-> "A" format size (1 to 9)
    !!--++    Character(len=*), intent(in)      :: aLine  !  -> data line to be analysed
    !!--++    Integer,          intent(in)      :: L_Line !  -> true length of data Line
    !!--++    Integer,          intent(in out)  :: nC_L   ! <-> current character in data line
    !!--++    Integer,          intent(out)     :: nC_X   ! <-  number of characters in X format field (now nx -> trn)
    !!--++
    !!--++    (PRIVATE)
    !!--++    Fixed length "A1 to A9" field : A<iFld-48>
    !!--++    Leading spaces are ignored; separators : space and Tab
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine TreatMCharField(iFld,aLine,L_Line,nC_L,nC_X)
       !---- Arguments ----!
       Integer,           intent(in out)  :: iFld
       Character (len=*), intent(in)      :: aLine
       Integer,           intent(in)      :: L_Line
       Integer,           intent(in out)  :: nC_L
       Integer,           intent(out)     :: nC_X

       !---- Local variables ----!
       Character (len=1) ::   Car
       Integer           ::   nCar
       Logical           ::   ifEnd

       nC_X = 0
       iErr_fmt = 0

       !---- End of ligne ----!
       if (nC_L >= L_Line) return

       !---- if not 1rst field, 1rst character must be a separator ----!
       if (nC_L > 1) Then
          nC_L = nC_L+1
          Car  = aLine(nC_L:nC_L)
          if (Car /= " " .and. Car /= cTab) then
             iErr_fmt = iErrSepMiss              ! separator missing
             return
          end if
          nC_X = nC_X+1
       end if

       !---- Remove leading spaces ----!
       ifEnd = .false.
       do
          if (ifEnd) exit
          if (nC_L >= L_Line) return        ! end of line
          nC_L = nC_L+1
          Car  = aLine(nC_L:nC_L)
          if (Car == " ") then
             nC_X = nC_X+1                   ! count leading spaces
          else
             ifEnd = .true.                  ! 1rst valid character
             nC_L = nC_L-1
          end if
       end do

       !---- Count characters until next Tab or end of line ----!
       nCar = 0
       ifEnd = .false.
       do
          if (ifEnd) exit
          if (nC_L < L_Line .and. nCar < (iFld-48)) then
             nC_L = nC_L+1
             nCar = nCar+1
             Car = aLine(nC_L:nC_L)
             if (Car == " " .or. Car == cTab) then
                ifEnd = .true.                ! separator found
                nCar  = nCar - 1
                nC_L  = nC_L - 1
             end if
          else
             ifEnd = .true.                  ! end of line
          end if
       end do

       !---- Load size of the A format field ----!
       if (nCar == 0) then
          iErr_fmt = iErrEmptyField             ! no charac. in field
       else
          iFld = nCar+48                    ! true size of the A field
       end if

       return
    End Subroutine TreatMCharField

    !!--++
    !!--++ Subroutine TreatNumerField(iFld,aLine,L_Line,nC_L,nCar)
    !!--++    Integer ,          intent( in)    ::  iFld   !  -> field type
    !!--++    Character (len=*), intent(in out) ::  aLine  ! <-> data line
    !!--++    Integer ,          intent( in)    ::  L_Line !  -> true length of the data line
    !!--++    Integer ,          intent(in out) ::  nC_L   ! <-> counts characters in data line
    !!--++    Integer ,          intent(in out) ::  nCar   ! <-> counts characters in format field
    !!--++
    !!--++    (PRIVATE)
    !!--++    Free "I" and "F" formats
    !!--++    Look for a separator (space or Tab) after any valid character
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine TreatNumerField(iFld,aLine,L_Line,nC_L,nCar)
       !---- Arguments ----!
       Integer ,          intent( in)    ::  iFld   ! field type
       Character (len=*), intent(in out) ::  aLine
       Integer ,          intent( in)    ::  L_Line ! true length of the data line
       Integer ,          intent(in out) ::  nC_L   ! counts characters in data line
       Integer ,          intent(in out) ::  nCar   ! counts characters in format field

       !---- Local variables ----!
       Character (len=1)   ::  Car,Car_
       Integer             ::  nCar1                ! 1st usefull character in field
       Integer             ::  nPosi                ! number of 1st character in field
       Logical             ::  ifEnd,ifDot,ifSign

       iErr_fmt   = 0
       nCar   = 0
       ifDot  = .false.
       ifSign = .false.
       nPosi  = nC_L

       !---- Skip previous separator (space, Tab or sign) and leading spaces ----!
       ifEnd = .false.
       do
          if (ifEnd) exit
          nC_L = nC_L+1
          if (nC_L <= L_Line) then
             nCar = nCar+1
             Car = aLine(nC_L:nC_L)

             !---- Tab character ----!
             if (Car == cTab) Then
                if (nCar == 1 .and. nC_L > 1) then
                   aLine(nC_L:nC_L) = " "      ! previous separator
                else
                   if (ifSign) then
                      iErr_fmt = iErrNumber         ! incomplete number
                      return
                   end if
                   nC_L = nC_L-1               ! new separator
                   nCar = nCar-1
                   return
                end if

             else if (Car == "+" .or. Car == "-") then
                !---- a sign ----!
                ifSign = .true.

             else if (Car == " ") then
                !---- a space ----!
                if (ifSign) then
                   iErr_fmt = iErrNumber           ! incomplete number
                   return
                end if

             else
                !---- any other character ----!
                ifEnd = .true.
             end if
          else
             return                          ! end of line
          end if
       end do

       !---- No valid previous separator found (Except for 1st field) ----!
       if (nPosi > 1 .and. nCar == 1) then
          iErr_fmt = iErrSepMiss                ! separator missing
          return
       end if

       !---- Check first character and initialize search ----!

       !---- Decimal point -> valid in real fields only ----!
       if (Car == ".") then
          ifDot = .true.
          if (iFld /= iReal)  then
             iErr_fmt = iErrFieldType            ! not an integer field
             Return
          end if

       else if(Car == "E".or.Car == "e".or.Car == "d".or.Car == "D") then
          !---- e,E,d,D -> always invalid at this position ----!
          if (iFld == iReal) then
             iErr_fmt = iErrEfrmt                ! incomplete E or D format
          else
             iErr_fmt = iErrInvalC               ! invalid char in int. field
          end if
          return

       else if (iChar(Car) < i_Zero .or. iChar(Car) > i_Nine) then
          !---- invalid if not a sign or a digit ----!
          iErr_fmt = iErrInvalChar        ! invalid character
          return
       end if

       !---- save position of first character ----!
       nCar1 = nCar

       !---- Count characters in number ----!
       ifEnd = .false.

       do
          if (ifEnd) exit
          Car_ = Car      ! save previous character
          nC_L = nC_L+1
          if (nC_L <= L_Line) then
             nCar = nCar+1
             Car = aLine(nC_L:nC_L)

             !---- Current character is a decimal point ----!
             if (Car == ".") then
                if (ifDot) then
                   iErr_fmt = iErrCharBegg         ! begged character (dot)
                   Return
                else if (iFld /= iReal) then
                   iErr_fmt = iErrFieldType        ! not an integer field
                   Return
                else
                   ifDot = .true.
                end if

             else if (Car == " " .or. Car == cTab) then
                !---- Current character is a space or Tab (separator) ----!
                if (Car_ == "+" .or. Car_ == "-") then
                   iErr_fmt = iErrNumber           ! incomplete number
                   return
                end if
                ifEnd = .true.
                nCar  = nCar - 1
                nC_L  = nC_L - 1

             else if (Car == "+" .or. Car == "-") then
                !---- Current character is a sign ----!
                if (Car_ == "+" .or. Car_ == "-") then
                   iErr_fmt = iErrCharBegg         ! begged character
                   return
                else if (nCar > nCar1) then
                   if (iFld == iReal) then
                      if (Car_ /= "E" .and. Car_ /= "e" .and. Car_ /= "D" .and. Car_ /= "d") then
                         ifEnd = .true.          ! Sign is a valid separator
                         nCar  = nCar - 1
                         nC_L  = nC_L - 1
                         Return
                      end if
                   else                        ! Sign is a valid separator
                      ifEnd = .true.
                      nCar  = nCar - 1
                      nC_L  = nC_L - 1
                      Return
                   end if
                end if

             else if (Car == "E" .or. Car == "e" .or. Car == "d" .or. Car == "D") then
                !---- Current character is a "e E d D" ----!
                if (nCar == nCar1 .or. Car_ == "-" .or. Car_ == "+") then
                   iErr_fmt = iErrEfrmt            ! incomplete E or D format
                   return
                else if (Car_ == Car) then
                   iErr_fmt = iErrCharBegg         ! begged character
                   return
                end if

             else if (iChar(Car) < i_Zero .or. iChar(Car) > i_Nine) then
                !---- Ccurrent character is not a valid one ? ----!
                iErr_fmt = iErrInvalChar          ! invalid character
                Return
             end if
          else
             ifEnd = .true.                  ! end of line
          end if
       end do

       return
    End Subroutine TreatNumerField

    !!----
    !!---- Subroutine Ucase(Line)
    !!----    character(len=*) :: Line
    !!----
    !!----    Conversion to upper case. Line is modified
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Ucase(line)
       !---- Argument ----!
       character (len=*), intent(in out) :: line

       line=u_case(line)

       return
    End Subroutine Ucase

 End Module CFML_String_Utilities
!!-------------------------------------------------------
!!---- Crystallographic Fortran Modules Library (CrysFML)
!!-------------------------------------------------------
!!---- The CrysFML project is distributed under LGPL. In agreement with the
!!---- Intergovernmental Convention of the ILL, this software cannot be used
!!---- in military applications.
!!----
!!---- Copyright (C) 1999-2012  Institut Laue-Langevin (ILL), Grenoble, FRANCE
!!----                          Universidad de La Laguna (ULL), Tenerife, SPAIN
!!----                          Laboratoire Leon Brillouin(LLB), Saclay, FRANCE
!!----
!!---- Authors: Juan Rodriguez-Carvajal (ILL)
!!----          Javier Gonzalez-Platas  (ULL)
!!----
!!---- Contributors: Laurent Chapon     (ILL)
!!----               Marc Janoschek     (Los Alamos National Laboratory, USA)
!!----               Oksana Zaharko     (Paul Scherrer Institute, Switzerland)
!!----               Tierry Roisnel     (CDIFX,Rennes France)
!!----               Eric Pellegrini    (ILL)
!!----
!!---- This library is free software; you can redistribute it and/or
!!---- modify it under the terms of the GNU Lesser General Public
!!---- License as published by the Free Software Foundation; either
!!---- version 3.0 of the License, or (at your option) any later version.
!!----
!!---- This library is distributed in the hope that it will be useful,
!!---- but WITHOUT ANY WARRANTY; without even the implied warranty of
!!---- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
!!---- Lesser General Public License for more details.
!!----
!!---- You should have received a copy of the GNU Lesser General Public
!!---- License along with this library; if not, see <http://www.gnu.org/licenses/>.
!!----
!!----
!!---- MODULE: CFML_Math_3D
!!----   INFO: Simple mathematics general utilities for 3D Systems
!!----
!!---- HISTORY
!!----    Update: 04/03/2011
!!----
!!---- DEPENDENCIES
!!--++    Use CFML_GlobalDeps,   only: cp, sp, dp, pi, to_rad, to_deg
!!--++    Use CFML_Math_General, only: cosd, sind
!!----
!!---- VARIABLES
!!--++    EPS
!!----    ERR_Math3D
!!----    ERR_Math3D_Mess
!!----
!!---- PROCEDURES
!!----    Functions:
!!----       CROSS_PRODUCT
!!--++       CROSS_PRODUCT_CMPL_dp     [Overloaded]
!!--++       CROSS_PRODUCT_CMPL_sp     [Overloaded]
!!--++       CROSS_PRODUCT_dp          [Overloaded]
!!--++       CROSS_PRODUCT_in          [Overloaded]
!!--++       CROSS_PRODUCT_sp          [Overloaded]
!!----       DETERM_A
!!--++       DETERM_A_I                [Overloaded]
!!--++       DETERM_A_R                [Overloaded]
!!----       DETERM_V
!!--++       DETERM_V_I                [Overloaded]
!!--++       DETERM_V_R                [Overloaded]
!!----       INVERT_A
!!--++       INVERT_DP                 [Overloaded]
!!--++       INVERT_SP                 [Overloaded]
!!----       MAT_CROSS
!!--++       MAT_CROSS_CMPL_dp     [Overloaded]
!!--++       MAT_CROSS_CMPL_sp     [Overloaded]
!!--++       MAT_CROSS_dp          [Overloaded]
!!--++       MAT_CROSS_in          [Overloaded]
!!--++       MAT_CROSS_sp          [Overloaded]
!!----       POLYHEDRON_VOLUME
!!----       ROTATE_OX
!!----       ROTATE_OY
!!----       ROTATE_OZ
!!----       TENSOR_PRODUCT
!!--++       TENSOR_PRODUCT_CMPL_dp     [Overloaded]
!!--++       TENSOR_PRODUCT_CMPL_sp     [Overloaded]
!!--++       TENSOR_PRODUCT_dp          [Overloaded]
!!--++       TENSOR_PRODUCT_in          [Overloaded]
!!--++       TENSOR_PRODUCT_sp          [Overloaded]
!!----       VECLENGTH
!!----
!!----    Subroutines:
!--..
!!--..    Init Routine
!!----       INIT_ERR_MATH3D
!!----       SET_EPS
!!----       SET_EPS_DEFAULT
!--..
!!--..    Matrix and Vectors Subroutines
!!----       GET_CART_FROM_CYLIN
!!--++       GET_CART_FROM_CYLIN_DP    [Overloaded]
!!--++       GET_CART_FROM_CYLIN_SP    [Overloaded]
!!----       GET_CENTROID_COORD
!!----       GET_CYLINDR_COORD
!!--++       GET_CYLINDR_COORD_DP      [Overloaded]
!!--++       GET_CYLINDR_COORD_SP      [Overloaded]
!!----       GET_CART_FROM_SPHER
!!--++       GET_CART_FROM_SPHER_DP    [Overloaded]
!!--++       GET_CART_FROM_SPHER_SP    [Overloaded]
!!----       GET_PLANE_FROM_POINTS
!!----       GET_SPHERIC_COORD
!!--++       GET_SPHERIC_COORD_DP      [Overloaded]
!!--++       GET_SPHERIC_COORD_SP      [Overloaded]
!!----       MATRIX_DIAGEIGEN
!!----       MATRIX_INVERSE
!!----       RESOLV_SIST_1X2
!!----       RESOLV_SIST_1X3
!!----       RESOLV_SIST_2X2
!!----       RESOLV_SIST_2X3
!!----       RESOLV_SIST_3X3
!!----
!!
 Module CFML_Math_3D
    !---- Use Modules ----!
    Use CFML_GlobalDeps,   only: cp, sp, dp, pi, to_rad, to_deg
    Use CFML_Math_General, only: cosd, sind, euclidean_norm

    implicit none

    private

    !---- List of public functions ----!
    public :: Polyhedron_Volume, Rotate_OX, Rotate_OY, Rotate_OZ, Veclength

    !---- List of public overloaded procedures: functions ----!
    public :: Cross_Product, Determ_A, Determ_V, Invert_A, Mat_Cross, Tensor_Product

    !---- List of public subroutines ----!
    public :: Init_Err_Math3D, Set_Eps, Set_Eps_Default, Matrix_DiagEigen, Matrix_Inverse, &
              Resolv_Sist_1X2, Resolv_Sist_1X3, Resolv_Sist_2X2, Resolv_Sist_2X3,          &
              Resolv_Sist_3X3, Get_Plane_from_Points, Get_Centroid_Coord

    !---- List of public overloaded procedures: subroutines ----!
    public :: Get_Cart_From_Cylin, Get_Cylindr_Coord, Get_Cart_From_Spher, Get_Spheric_Coord

    !----  Make private the overloaded procedures ----!
    private :: Cross_Product_dp, Cross_Product_sp, Determ_A_I, Determ_A_R, Determ_V_I,    &
               Determ_V_R, Invert_dp, Invert_sp, Get_Cart_From_Cylin_dp,                  &
               Get_Cart_From_Cylin_sp, Get_Cylindr_Coord_dp, Get_Cylindr_Coord_sp,        &
               Get_Cart_From_Spher_dp, Get_Cart_From_Spher_sp, Get_Spheric_Coord_dp,      &
               Get_Spheric_Coord_sp, Cross_Product_cmpl_dp, Cross_Product_cmpl_sp,        &
               Mat_Cross_dp,Mat_Cross_sp,Mat_Cross_in,Mat_Cross_cmpl_dp,Mat_Cross_cmpl_sp,&
               Tensor_Product_dp,Tensor_Product_sp,Tensor_Product_in,                     &
               Tensor_Product_cmpl_dp,Tensor_Product_cmpl_sp

    !---- Definitions ----!
    !!--++
    !!--++  EPS
    !!--++     real(kind=cp), private ::  eps=0.00001_cp
    !!--++
    !!--++  (PRIVATE)
    !!--++     Epsilon value
    !!--++
    !!--++  Update: February - 2005
    !!
    real(kind=cp),  private  ::  eps=0.00001_cp

    !!----
    !!---- ERR_Math3D
    !!----    logical :: ERR_Math3D
    !!----
    !!----    Logical Variable indicating an error in CFML_Math_3D module
    !!----
    !!---- Update: February - 2005
    !!
    logical, public  :: ERR_Math3D

    !!----
    !!---- ERR_Math3D_Mess
    !!----    character(len=150) :: ERR_Math3D_Mess
    !!----
    !!----    String containing information about the last error
    !!----
    !!---- Update: February - 2005
    !!
    character(len=150), public :: ERR_Math3D_Mess

    !---- Interfaces - Overlapp ----!
    Interface  Cross_Product
       Module Procedure Cross_product_sp
       Module Procedure Cross_product_dp
       Module Procedure Cross_product_in
       Module Procedure Cross_product_cmpl_sp
       Module Procedure Cross_product_cmpl_dp
    End Interface

    Interface  Determ_A
       Module Procedure Determ_A_I
       Module Procedure Determ_A_R
    End Interface

    Interface  Determ_V
       Module Procedure Determ_V_I
       Module Procedure Determ_V_R
    End Interface

    Interface  Invert_A
       Module Procedure Invert_sp
       Module Procedure Invert_dp
    End Interface

    Interface  Get_Cart_from_Cylin
       Module Procedure Get_Cart_from_Cylin_dp
       Module Procedure Get_Cart_from_Cylin_sp
    End Interface

    Interface  Get_Cylindr_Coord
       Module Procedure Get_Cylindr_Coord_dp
       Module Procedure Get_Cylindr_Coord_sp
    End Interface

    Interface  Get_Cart_from_Spher
       Module Procedure Get_Cart_from_Spher_dp
       Module Procedure Get_Cart_from_Spher_sp
    End Interface

    Interface  Get_Spheric_Coord
       Module Procedure Get_Spheric_Coord_dp
       Module Procedure Get_Spheric_Coord_sp
    End Interface

    Interface  Mat_Cross
       Module Procedure Mat_Cross_sp
       Module Procedure Mat_Cross_dp
       Module Procedure Mat_Cross_in
       Module Procedure Mat_Cross_cmpl_sp
       Module Procedure Mat_Cross_cmpl_dp
    End Interface

    Interface  Tensor_Product
       Module Procedure Tensor_product_sp
       Module Procedure Tensor_product_dp
       Module Procedure Tensor_product_in
       Module Procedure Tensor_product_cmpl_sp
       Module Procedure Tensor_product_cmpl_dp
    End Interface

 Contains

    !!----
    !!---- Function  Cross_Product(U,V) Result(W)
    !!----    real(kind=sp/dp), dimension(3), intent( in) :: u   !  In -> Vector 1
    !!----    real(kind=sp/dp), dimension(3), intent( in) :: v   !  In -> Vector 2
    !!----    real(kind=sp/dp), dimension(3)              :: w   ! Out -> Vector 1 x vector 2
    !!----
    !!----    Calculates the cross product of vectors u and v
    !!----    Vectors, w= u x v, are given in cartesian components.
    !!----
    !!---- Update: February - 2005
    !!

    !!--++
    !!--++ Function  Cross_Product_cmpl_dp(U,V) Result(W)
    !!--++    complex(kind=dp/sp), dimension(3), intent( in) :: u   !  In -> Vector 1
    !!--++    complex(kind=dp/sp), dimension(3), intent( in) :: v   !  In -> Vector 2
    !!--++    complex(kind=dp/sp), dimension(3)              :: w   ! Out -> Vector 1 x vector 2
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Calculates the cross product of the complex vectors u and v
    !!--++    Vectors, w = u x v, are given in cartesian components.
    !!--++
    !!--++ Update: June - 2012
    !!
    Function Cross_Product_cmpl_dp(u,v) Result(w)
       !---- Argument ----!
       complex(kind=dp), dimension(3), intent( in) :: u,v
       complex(kind=dp), dimension(3)              :: w

       w(1)=u(2)*v(3)-u(3)*v(2)
       w(2)=u(3)*v(1)-u(1)*v(3)
       w(3)=u(1)*v(2)-u(2)*v(1)

       return
    End Function Cross_Product_cmpl_dp

    Function Cross_Product_cmpl_sp(u,v) Result(w)
       !---- Argument ----!
       complex(kind=sp), dimension(3), intent( in) :: u,v
       complex(kind=sp), dimension(3)              :: w

       w(1)=u(2)*v(3)-u(3)*v(2)
       w(2)=u(3)*v(1)-u(1)*v(3)
       w(3)=u(1)*v(2)-u(2)*v(1)

       return
    End Function Cross_Product_cmpl_sp

    !!--++
    !!--++ Function  Cross_Product_dp(U,V) Result(W)
    !!--++    real(kind=dp), dimension(3), intent( in) :: u   !  In -> Vector 1
    !!--++    real(kind=dp), dimension(3), intent( in) :: v   !  In -> Vector 2
    !!--++    real(kind=dp), dimension(3)              :: w   ! Out -> Vector 1 x vector 2
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Calculates the cross product of vectors u and v
    !!--++    Vectors, w= u x v, are given in cartesian components.
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Cross_Product_dp(u,v) Result(w)
       !---- Argument ----!
       real(kind=dp), dimension(3), intent( in) :: u,v
       real(kind=dp), dimension(3)              :: w

       w(1)=u(2)*v(3)-u(3)*v(2)
       w(2)=u(3)*v(1)-u(1)*v(3)
       w(3)=u(1)*v(2)-u(2)*v(1)

       return
    End Function Cross_Product_dp

    !!--++
    !!--++ Function  Cross_Product_in(U,V) Result(W)
    !!--++    integer, dimension(3), intent( in) :: u   !  In -> Vector 1
    !!--++    integer, dimension(3), intent( in) :: v   !  In -> Vector 2
    !!--++    integer, dimension(3)              :: w   ! Out -> Vector 1 x vector 2
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Calculates the cross product of integer vectors u and v
    !!--++    In the indices are givent w.r.t the direct lattice, the cross product
    !!--++    are indices w.r.t. reciprocal lattice and viceversa.
    !!--++
    !!--++ Update: November - 2008
    !!
    Function Cross_Product_in(u,v) Result(w)
       !---- Argument ----!
       integer, dimension(3), intent( in) :: u,v
       integer, dimension(3)              :: w

       w(1)=u(2)*v(3)-u(3)*v(2)  ! i  j   k !
       w(2)=u(3)*v(1)-u(1)*v(3)  !u1  u2  u3! = (u2.v3 - u3.v2)i + (v1.u3 - u1.v3)j + (u1.v2-u2.v1)k
       w(3)=u(1)*v(2)-u(2)*v(1)  !v1  v2  v3!

       return
    End Function Cross_Product_in

    !!--++
    !!--++ Function  Cross_Product_sp(U,V) Result(W)
    !!--++    real(kind=sp), dimension(3), intent( in) :: u   !  In -> Vector 1
    !!--++    real(kind=sp), dimension(3), intent( in) :: v   !  In -> Vector 2
    !!--++    real(kind=sp), dimension(3)              :: w   ! Out -> Vector 1 x vector 2
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Calculates the cross product of vectors u and v
    !!--++    Vectors, w= u x v, are given in cartesian components.
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Cross_Product_sp(u,v) Result(w)
       !---- Argument ----!
       real(kind=sp), dimension(3), intent( in) :: u,v
       real(kind=sp), dimension(3)              :: w

       w(1)=u(2)*v(3)-u(3)*v(2)  ! i  j   k !
       w(2)=u(3)*v(1)-u(1)*v(3)  !u1  u2  u3! = (u2.v3 - u3.v2)i + (v1.u3 - u1.v3)j + (u1.v2-u2.v1)k
       w(3)=u(1)*v(2)-u(2)*v(1)  !v1  v2  v3!

       return
    End Function Cross_Product_sp

    !!----
    !!---- Function Determ_A(A)
    !!----    integer/real(kind=cp), dimension(3,3), intent(in)  :: a
    !!----
    !!----    Calculates the determinant of an integer/real 3x3 matrix
    !!----
    !!---- Update: February - 2005
    !!

    !!--++
    !!--++ Function Determ_A_I(A)
    !!--++    integer, dimension(3,3), intent(in)  :: a
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Calculates the determinant of an integer 3x3 matrix
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Determ_A_I(A) Result(determ)
       !---- Argument ----!
       integer, dimension(3,3), intent(in) :: A
       integer                             :: determ

       determ=A(1,1)*A(2,2)*A(3,3)+A(2,1)*A(3,2)*A(1,3)+A(1,2)*A(2,3)*A(3,1) &
             -A(1,3)*A(2,2)*A(3,1)-A(1,1)*A(3,2)*A(2,3)-A(1,2)*A(2,1)*A(3,3)

       return
    End Function Determ_A_I

    !!--++
    !!--++ Function Determ_A_R(A)
    !!--++    real(kind=cp), dimension(3,3), intent(in)  :: a
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Calculates the determinant of a real 3x3 matrix
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Determ_A_R(A) Result (determ)
       !---- Argument ----!
       real(kind=cp), dimension(3,3), intent(in) :: A
       real(kind=cp)                             :: determ

       determ=A(1,1)*A(2,2)*A(3,3)+A(2,1)*A(3,2)*A(1,3)+A(1,2)*A(2,3)*A(3,1) &
             -A(1,3)*A(2,2)*A(3,1)-A(1,1)*A(3,2)*A(2,3)-A(1,2)*A(2,1)*A(3,3)

       return
    End Function Determ_A_R

    !!----
    !!---- Function  Determ_V(a,b,c)
    !!----    integer/real(kind=cp), dimension(3), intent(in) :: a,b,c
    !!----
    !!----    Calculates the determinant of the components of three vectors
    !!----
    !!----  Update: February - 2005
    !!

    !!--++
    !!--++ Function Determ_V_I(A,B,C)
    !!--++    integer, dimension(3), intent(in) :: a,b,c
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Calculates the determinant of the components of three vectors
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Determ_V_I(a,b,c) Result(det)
       !---- Arguments ----!
       integer, dimension(3), intent(in) :: a,b,c
       integer                           :: det

       !---- Local variables ----!
       integer :: i,j,k

       det = 0
       do i = 1,3
          j = i+1
          if (j == 4) j = 1
          k = 6-i-j
          det = det+a(i)*(b(j)*c(k)-b(k)*c(j))
       end do

       return
    End Function Determ_V_I

    !!--++
    !!--++ Function Determ_V_R(A,B,C)
    !!--++    real(kin=cp), dimension(3), intent(in) :: a,b,c
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Calculates the determinant of the components of three vectors
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Determ_V_R(a,b,c) Result(det)
       !---- Arguments ----!
       real(kind=cp), dimension(3), intent(in) :: a,b,c
       real(kind=cp)                           :: det

       !---- Local variables ----!
       integer :: i,j,k

       det = 0.0
       do i = 1,3
          j = i+1
          if (j == 4) j = 1
          k = 6-i-j
          det = det+a(i)*(b(j)*c(k)-b(k)*c(j))
       end do

       return
    End Function Determ_V_R

    !!----
    !!---- Funcion Invert_A(A) Result(b)
    !!----    real(kind=sp/dp), dimension(3,3), intent(in) :: a
    !!----    real(Kind=sp/dp), dimension(3,3)             :: b
    !!----
    !!----    Calculate de inverse of a real 3x3 matrix. If the routine fails,
    !!----    then a 0.0 matrix is returned.
    !!----
    !!---- Update: February - 2005
    !!

    !!--++
    !!--++ Funcion Invert_Dp(A) Result(b)
    !!--++    real(kind=dp), dimension(3,3), intent(in) :: a
    !!--++    real(Kind=dp), dimension(3,3)             :: b
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Calculate de inverse of a real 3x3 matrix
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Invert_Dp(a) Result(b)
       !---- Arguments ----!
       real(kind=dp),dimension(3,3), intent(in) :: a
       real(kind=dp),dimension(3,3)             :: b

       !---- Local variables ----!
       real(kind=dp)  :: dmat

       b(1,1) =   a(2,2)*a(3,3)-a(2,3)*a(3,2)
       b(2,1) = -(a(2,1)*a(3,3)-a(2,3)*a(3,1))
       b(3,1) =   a(2,1)*a(3,2)-a(2,2)*a(3,1)
       b(1,2) = -(a(1,2)*a(3,3)-a(1,3)*a(3,2))
       b(2,2) =   a(1,1)*a(3,3)-a(1,3)*a(3,1)
       b(3,2) = -(a(1,1)*a(3,2)-a(1,2)*a(3,1))
       b(1,3) =   a(1,2)*a(2,3)-a(1,3)*a(2,2)
       b(2,3) = -(a(1,1)*a(2,3)-a(1,3)*a(2,1))
       b(3,3) =   a(1,1)*a(2,2)-a(1,2)*a(2,1)
       dmat = a(1,1)*b(1,1)+a(1,2)*b(2,1)+a(1,3)*b(3,1) !determinant of A

       if (abs(dmat) > tiny(dmat)) then
          b= b/dmat
       else
          b=0.0_dp
       end if

       return
    End Function Invert_Dp

    !!--++
    !!--++ Funcion Invert_Sp(A) Result(b)
    !!--++    real(kind=sp), dimension(3,3), intent(in) :: a
    !!--++    real(Kind=sp), dimension(3,3)             :: b
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Calculate de inverse of a real 3x3 matrix
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Invert_Sp(a) Result(b)
       !---- Arguments ----!
       real(kind=sp),dimension(3,3), intent(in) :: a
       real(kind=sp),dimension(3,3)             :: b

       !---- Local variables ----!
       real(kind=sp)  :: dmat

       b(1,1) =   a(2,2)*a(3,3)-a(2,3)*a(3,2)
       b(2,1) = -(a(2,1)*a(3,3)-a(2,3)*a(3,1))
       b(3,1) =   a(2,1)*a(3,2)-a(2,2)*a(3,1)
       b(1,2) = -(a(1,2)*a(3,3)-a(1,3)*a(3,2))
       b(2,2) =   a(1,1)*a(3,3)-a(1,3)*a(3,1)
       b(3,2) = -(a(1,1)*a(3,2)-a(1,2)*a(3,1))
       b(1,3) =   a(1,2)*a(2,3)-a(1,3)*a(2,2)
       b(2,3) = -(a(1,1)*a(2,3)-a(1,3)*a(2,1))
       b(3,3) =   a(1,1)*a(2,2)-a(1,2)*a(2,1)
       dmat = a(1,1)*b(1,1)+a(1,2)*b(2,1)+a(1,3)*b(3,1) !determinant of A

       if (abs(dmat) > tiny(dmat)) then
          b= b/dmat
       else
          b=0.0
       end if

       return
    End Function Invert_Sp

    !!----
    !!---- Function  Mat_Cross(U) Result(M)
    !!----    real/complex(kind=sp/dp)/integer, dimension(3), intent( in) :: u   !  In -> Vector 1
    !!----    real/complex(kind=sp/dp)/integer, dimension(3,3)            :: M   ! Out -> Matrix [u]cross
    !!----
    !!----    Calculates the matrix corresponding to the operator u x
    !!----    Antisymmetric matrix of the form:
    !!----                /  0   -u(3)  u(2)\
    !!----    M=[u]cross=|  u(3)   0   -u(1) |
    !!----                \-u(2)  u(1)   0  /
    !!----
    !!----  Updated: June - 2012
    !!
    Function Mat_Cross_cmpl_dp(u) Result(M)
       !---- Argument ----!
       complex(kind=dp), dimension(3), intent( in) :: u
       complex(kind=dp), dimension(3,3)            :: M

       M = reshape( (/  (0.0_dp,0.0_dp),   -u(3),         u(2),  &
                            u(3),   (0.0_dp,0.0_dp),     -u(1),  &
                           -u(2),           u(1),   (0.0_dp,0.0_dp)/),(/3,3/))
       return
    End Function Mat_Cross_cmpl_dp

    Function Mat_Cross_cmpl_sp(u) Result(M)
       !---- Argument ----!
       complex(kind=sp), dimension(3), intent( in) :: u
       complex(kind=sp), dimension(3,3)            :: M

       M = reshape( (/  (0.0_sp,0.0_sp),   -u(3),         u(2),  &
                            u(3),   (0.0_sp,0.0_sp),     -u(1),  &
                           -u(2),           u(1),   (0.0_sp,0.0_sp)/),(/3,3/))
       return
    End Function Mat_Cross_cmpl_sp

    Function Mat_Cross_dp(u) Result(M)
       !---- Argument ----!
       real(kind=dp), dimension(3), intent( in) :: u
       real(kind=dp), dimension(3,3)            :: M

       M = reshape( (/ 0.0_dp,   -u(3),     u(2),  &
                        u(3),    0.0_dp,   -u(1),  &
                       -u(2),     u(1),    0.0_dp/),(/3,3/))
       return
    End Function Mat_Cross_dp

    Function Mat_Cross_in(u) Result(M)
       !---- Argument ----!
       integer, dimension(3), intent( in) :: u
       integer, dimension(3,3)            :: M

       M = reshape( (/   0,    -u(3),    u(2),  &
                        u(3),    0,     -u(1),  &
                       -u(2),   u(1),     0 /),(/3,3/))
       return
    End Function Mat_Cross_in

    Function Mat_Cross_sp(u) Result(M)
       !---- Argument ----!
       real(kind=sp), dimension(3), intent( in) :: u
       real(kind=sp), dimension(3,3)            :: M

       M = reshape( (/ 0.0_sp, -u(3),    u(2),  &
                        u(3),  0.0_sp,  -u(1),  &
                       -u(2),   u(1),   0.0_sp/),(/3,3/))
       return
    End Function Mat_Cross_sp

    !!----
    !!---- Function Polyhedron_Volume(Nv,Vert,Cent) Result(vol)
    !!----    integer,                       intent(in) :: Nv       ! Vertices Number
    !!----    real(kind=cp), dimension(:,:), intent(in) :: Vert     ! Cartesian coordinates of vertices
    !!----    real(kind=cp), dimension(3),   intent(in) :: Cent     ! Cartesian coordinates a central point
    !!----
    !!---- This procedure calculate the volume of polyhedral with Nv vertices.
    !!---- It is based on volcal program of L. W. FINGER.
    !!---- Adapted by Javier Gonzalez Platas
    !!----
    !!---- Update: February - 2010
    !!
    Function Polyhedron_Volume(NV,Vert,Cent) Result(vol)
       !---- Arguments ----!
       integer,                       intent(in) :: Nv       ! Number of Vertices
       real(kind=cp), dimension(:,:), intent(in) :: Vert     ! Cartesian coordinates of atoms
       real(kind=cp), dimension(3),   intent(in) :: Cent     ! Cartesian coordinates of Central atom
       real(kind=cp)                             :: vol
       !---- Local Variables ----!
       integer                       :: i,j,k,l,i1,j1
       real(kind=cp)                 :: z,z0,area,factor
       real(kind=cp),dimension(6)    :: vxyz
       real(kind=cp),dimension(3)    :: d
       real(kind=cp),dimension(3,Nv) :: Atm_cart

       vol=0.0
       call init_err_Math3d()

       if (nv <= 3) then
          ERR_Math3D=.true.
          ERR_Math3D_Mess='The number of vertices for polyhedron volume is less than 4'
          return
       end if

       do i=1,nv
          Atm_cart(:,i)=Vert(:,i)- Cent
       end do

       do i=1,nv-2
          i1=i+1
          do j=i1,nv-1
             j1=j+1
             vxyz(1:3)=Atm_cart(:,j)-Atm_cart(:,i)
        loop:do k=j1,nv
                vxyz(4:6)=Atm_cart(:,k)-Atm_cart(:,i)
                d(1)=vxyz(2)*vxyz(6)-vxyz(5)*vxyz(3)
                d(2)=vxyz(4)*vxyz(3)-vxyz(1)*vxyz(6)
                d(3)=vxyz(1)*vxyz(5)-vxyz(4)*vxyz(2)
                area=0.5*sqrt(d(1)*d(1)+d(2)*d(2)+d(3)*d(3))
                z0=0.5*(Atm_cart(1,i)*d(1)+Atm_cart(2,i)*d(2)+Atm_cart(3,i)*d(3))/area

                ! check for and avoid plane through origin
                if (abs(z0) < 1.0e-5) cycle
                factor = 3.0
                do l=1,nv
                   if(l==i .or. l==j .or. l==k) cycle

                   ! calculate distance of point l from plane of ijk
                   z=0.5*((Atm_cart(1,i)-Atm_cart(1,l))*d(1)+ &
                          (Atm_cart(2,i)-Atm_cart(2,l))*d(2)+ &
                          (Atm_cart(3,i)-Atm_cart(3,l))*d(3))/area

                   ! z and z0 must have the same sign
                   if (z * z0 < -0.001) cycle loop
                   if (abs(z * z0) < 0.001)then
                      ! if more than 3 corners on this face, the area will be counted twice.
                      ! change factor to handle this case.
                     factor = 6.0
                   end if
                end do

                ! all points on same side,  thus ijk are face
                ! Direction Cosines Of Plane Normal
                d=d/(2.0*area)

                vol=vol+area*abs(z0)/factor

             end do loop
          end do
       end do

       return
    End Function Polyhedron_Volume

    !!----
    !!---- Function Rotate_OX(X,Angle) Result (Vec)
    !!----    real(kind=cp), dimension(3), intent(in) :: x       !  In -> Vector
    !!----    real(kind=cp),               intent(in) :: angle   !  In -> Angle (Degrees)
    !!----    real(kind=cp), dimension(3)             :: vec     ! Out -> Vector
    !!----
    !!----    X Rotation. Positive rotation is counter-clockwise
    !!----
    !!---- Update: February - 2005
    !!
    Function Rotate_OX(X,Angle) Result(vec)
       !---- Arguments ----!
       real(kind=cp), dimension(3), intent(in) :: x
       real(kind=cp),               intent(in) :: angle
       real(kind=cp), dimension(3)             :: vec

       !---- Variables locales ----!
       real(kind=cp), dimension(3,3)           :: rot

       rot(1,1)=  1.0
       rot(2,1)=  0.0_cp
       rot(3,1)=  0.0_cp

       rot(1,2)=  0.0_cp
       rot(2,2)=  cosd(angle)
       rot(3,2)=  sind(angle)

       rot(1,3)=  0.0_cp
       rot(2,3)=  -sind(angle)
       rot(3,3)=  cosd(angle)

       vec=matmul(rot,x)

       return
    End Function Rotate_OX

    !!----
    !!---- Function Rotate_OY(Y,Angle) Result (Vec)
    !!----    real(kind=cp), dimension(3), intent(in) :: y       !  In -> Vector
    !!----    real(kind=cp),               intent(in) :: angle   !  In -> Angle (Degrees)
    !!----    real(kind=cp), dimension(3)             :: vec     ! Out -> Vector
    !!----
    !!----    Y Rotation.
    !!----
    !!---- Update: February - 2005
    !!
    Function Rotate_OY(Y,Angle) Result(vec)
       !---- Arguments ----!
       real(kind=cp), dimension(3), intent(in) :: y
       real(kind=cp),               intent(in) :: angle     ! Angle in degrees
       real(kind=cp), dimension(3)             :: vec

       !---- Variables locales ----!
       real(kind=cp), dimension(3,3)           :: rot

       rot(1,1)=  cosd(angle)
       rot(2,1)=  0.0_cp
       rot(3,1)=  -sind(angle)

       rot(1,2)=  0.0_cp
       rot(2,2)=  1.0_cp
       rot(3,2)=  0.0_cp

       rot(1,3)= sind(angle)
       rot(2,3)= 0.0_cp
       rot(3,3)= cosd(angle)

      vec=matmul(rot,y)

       return
    End Function Rotate_OY

    !!----
    !!---- Function Rotate_OZ(Z,Angle) Result (Vec)
    !!----    real(kind=cp), dimension(3), intent(in) :: z       !  In -> Vector
    !!----    real(kind=cp),               intent(in) :: angle   !  In -> Angle (Degrees)
    !!----    real(kind=cp), dimension(3)             :: vec     ! Out -> Vector
    !!----
    !!----    Z Rotation
    !!----
    !!---- Update: February - 2005
    !!
    Function Rotate_OZ(Z,Angle) Result(vec)
       !---- Arguments ----!
       real(kind=cp), dimension(3), intent(in) :: z
       real(kind=cp),               intent(in) :: angle
       real(kind=cp), dimension(3)             :: vec

       !---- Variables locales ----!
       real(kind=cp), dimension(3,3)           :: rot

       rot(1,1)=  cosd(angle)
       rot(2,1)=  sind(angle)
       rot(3,1)=  0.0_cp

       rot(1,2)=  -sind(angle)
       rot(2,2)=  cosd(angle)
       rot(3,2)=  0.0_cp

       rot(1,3)=  0.0_cp
       rot(2,3)=  0.0_cp
       rot(3,3)=  1.0_cp

       vec=matmul(rot,z)

       return
    End Function Rotate_OZ

    !!----
    !!---- Function  Tensor_Product(U,V) Result(W)
    !!----    complex/real(kind=sp/dp)/integer, dimension(3), intent( in) :: u   !  In -> Vector 1
    !!----    complex/real(kind=sp/dp)/integer, dimension(3), intent( in) :: v   !  In -> Vector 2
    !!----    complex/real(kind=sp/dp)/integer, dimension(3,3)            :: w   ! Out -> Tensor product Vector1 (o) Vector2
    !!----
    !!----    Calculates the tensor product of vectors u and v
    !!----
    !!---- Updated: June - 2012
    !!
    Function Tensor_Product_cmpl_dp(u,v) Result(w)
       !---- Argument ----!
       complex(kind=dp), dimension(3), intent( in) :: u,v
       complex(kind=dp), dimension(3,3)            :: w
       !
       complex(kind=dp), dimension(3,3)            :: mu,mv
       mu=0.0_dp;  mv=0.0_dp
       mu(:,1)=u
       mv(1,:)=v
       w=matmul(mu,mv)
       return
    End Function Tensor_Product_cmpl_dp

    Function Tensor_Product_cmpl_sp(u,v) Result(w)
       !---- Argument ----!
       complex(kind=sp), dimension(3), intent( in) :: u,v
       complex(kind=sp), dimension(3,3)            :: w
       !
       complex(kind=sp), dimension(3,3)            :: mu,mv
       mu=0.0_sp;  mv=0.0_sp
       mu(:,1)=u
       mv(1,:)=v
       w=matmul(mu,mv)
       return
    End Function Tensor_Product_cmpl_sp

    Function Tensor_Product_dp(u,v) Result(w)
       !---- Argument ----!
       real(kind=dp), dimension(3), intent( in) :: u,v
       real(kind=dp), dimension(3,3)            :: w
       !
       real(kind=dp), dimension(3,3)            :: mu,mv
       mu=0.0_dp;  mv=0.0_dp
       mu(:,1)=u
       mv(1,:)=v
       w=matmul(mu,mv)
       return
    End Function Tensor_Product_dp

    Function Tensor_Product_in(u,v) Result(w)
       !---- Argument ----!
       integer, dimension(3), intent( in) :: u,v
       integer, dimension(3,3)            :: w
       !
       integer, dimension(3,3)            :: mu,mv
       mu=0;  mv=0
       mu(:,1)=u
       mv(1,:)=v
       w=matmul(mu,mv)
       return
    End Function Tensor_Product_in

    Function Tensor_Product_sp(u,v) Result(w)
       !---- Argument ----!
       real(kind=sp), dimension(3), intent( in) :: u,v
       real(kind=sp), dimension(3,3)            :: w
       !
       real(kind=sp), dimension(3,3)            :: mu,mv
       mu=0.0_sp;  mv=0.0_sp
       mu(:,1)=u
       mv(1,:)=v
       w=matmul(mu,mv)
       return
    End Function Tensor_Product_sp
    !!----
    !!---- Function Veclength(A,B) Result(c)
    !!----    real(kind=cp), dimension(3,3), intent(in)  :: a
    !!----    real(kind=cp), dimension(3),   intent(in)  :: b
    !!----    real(kind=cp),                             :: c
    !!----
    !!----    Length of vector B when A is the Crystallographic
    !!----    to orthogonal matrix length=c
    !!----
    !!---- Update: February - 2005
    !!
    Function Veclength(a,b) Result(c)
       !---- Arguments ----!
       real(kind=cp), intent(in)  , dimension(3,3)       :: a
       real(kind=cp), intent(in)  , dimension(3  )       :: b
       real(kind=cp)                                     :: c

       !---- Local variables ----!
       integer                     :: i,j
       real(kind=cp), dimension(3) :: v

       v=0.0
       do i = 1,3
          do j = 1,3
             v(i) = v(i)+a(i,j)*b(j)
          end do
       end do

       c = sqrt(v(1)**2+v(2)**2+v(3)**2)

       return
    End Function Veclength

    !---------------------!
    !---- Subroutines ----!
    !---------------------!

    !!----
    !!---- Subroutine Init_Err_Math3D()
    !!----
    !!----    Initialize the errors flags in CFML_Math_3D
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Init_Err_Math3D()

       ERR_Math3D=.false.
       ERR_Math3D_Mess=" "

       return
    End Subroutine Init_Err_Math3D

    !!----
    !!---- Subroutine Set_Eps(Neweps)
    !!----    real(kind=cp), intent( in) :: neweps
    !!----
    !!----    Sets global EPS to the value "neweps"
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Set_Eps(Neweps)
       !---- Arguments ----!
       real(kind=cp), intent( in) :: neweps

       eps=neweps

       return
    End Subroutine Set_Eps

    !!----
    !!---- Subroutine Set_Eps_Default()
    !!----
    !!----    Sets global EPS to the default value: eps=0.00001
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Set_Eps_Default()

       eps=0.00001

       return
    End Subroutine Set_Eps_Default

    !!----
    !!---- Subroutine Get_Cart_from_Cylin(rho,Phi,zeta,Xo,Mode)
    !!----    real(kind=sp/dp),              intent( in)           :: rho
    !!----    real(kind=sp/dp),              intent( in)           :: phi
    !!----    real(kind=sp/dp),              intent( in)           :: zeta
    !!----    real(kind=sp/dp), dimension(3),intent(out)           :: xo
    !!----    character(len=*),              intent( in), optional :: mode
    !!----
    !!----    Determine the Cartesian coordinates from cylindrical coordinates.
    !!----    If Mode='D' the angle phi is provided in Degrees.
    !!----
    !!---- Update: February - 2005
    !!

    !!--++
    !!--++ Subroutine  Get_Cart_from_Cylin_dp(rho,Phi,zeta,Xo,Mode)
    !!--++    real(kind=dp),              intent( in)           ::  rho
    !!--++    real(kind=dp),              intent( in)           ::  phi
    !!--++    real(kind=dp),              intent( in)           ::  zeta
    !!--++    real(kind=dp), dimension(3),intent(out)           ::  xo
    !!--++    character(len=*),           intent( in), optional ::  mode
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Determine the Cartesian coordinates from cylindrical coordinates.
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Get_Cart_from_Cylin_dp(rho,Phi,zeta,Xo,Mode)
       !---- Arguments ----!
       real(kind=dp),              intent( in)           ::  rho
       real(kind=dp),              intent( in)           ::  phi
       real(kind=dp),              intent( in)           ::  zeta
       real(kind=dp), dimension(3),intent(out)           ::  xo
       character(len=*),           intent( in), optional ::  mode

       !---- Local Variables ----!
       real(kind=dp) :: ph

       ph=phi
       if (present(mode)) then
          if (mode(1:1) == "D" .or. mode(1:1) == "d") ph=phi*to_rad
       end if
       xo(1)=rho*cos(ph)
       xo(2)=rho*sin(ph)
       xo(3)=zeta

       return
    End Subroutine Get_Cart_from_Cylin_dp

    !!--++
    !!--++ Subroutine  Get_Cart_from_Cylin_sp(rho,Phi,zeta,Xo,Mode)
    !!--++    real(kind=sp),              intent( in)           ::  rho
    !!--++    real(kind=sp),              intent( in)           ::  phi
    !!--++    real(kind=sp),              intent( in)           ::  zeta
    !!--++    real(kind=sp), dimension(3),intent(out)           ::  xo
    !!--++    character(len=*),           intent( in), optional ::  mode
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Determine the Cartesian coordinates from cylindrical coordinates.
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Get_Cart_from_Cylin_sp(rho,Phi,zeta,Xo,Mode)
       real(kind=sp),              intent( in)           ::  rho
       real(kind=sp),              intent( in)           ::  phi
       real(kind=sp),              intent( in)           ::  zeta
       real(kind=sp), dimension(3),intent(out)           ::  xo
       character(len=*),           intent( in), optional ::  mode

       !---- Local Variables ----!
       real(kind=sp) :: ph

       ph=phi
       if (present(mode)) then
          if (mode(1:1) == "D" .or. mode(1:1) == "d") ph=phi*to_rad
       end if
       xo(1)=rho*cos(ph)
       xo(2)=rho*sin(ph)
       xo(3)=zeta

       return
    End Subroutine Get_Cart_from_Cylin_sp

    !!----
    !!---- Subroutine Get_Centroid_Coord(Cn,Atm_Cart,Centroid,Baricenter)
    !!----    integer,                       intent(in) :: Cn          ! Coordination Number
    !!----    real(kind=cp), dimension(:,:), intent(in) :: Atm_Cart    ! Cartesian coordinates of atoms
    !!----    real(kind=cp), dimension(3),   intent(out):: Centroid    ! Centroid
    !!----    real(kind=cp), dimension(3),   intent(out):: Baricenter  ! Baricenter
    !!----
    !!---- Procedure to calculate Centroid and BariCenter of a pPolyhedron according to
    !!---- Tonci Balic-Zunic (Acta Cryst. B52, 1996, 78-81; Acta Cryst. B54, 1998, 766-773)
    !!---- Centroid is here different from Baricentre and it is defined in the above reference.
    !!----
    !!---- Update: February - 2010
    !!
    Subroutine Get_Centroid_Coord(Cn,Atm_Cart,Centroid,Baricenter)
       !---- Arguments ----!
       integer,                       intent(in) :: Cn          ! Coordination Number
       real(kind=cp), dimension(:,:), intent(in) :: Atm_Cart    ! Cartesian coordinates of atoms, gathered as: (1:3,1:Cn)
       real(kind=cp), dimension(3),   intent(out):: Centroid    ! Centroid
       real(kind=cp), dimension(3),   intent(out):: Baricenter  ! Baricenter

       !---- Local variables ----!
       real(kind=cp), dimension(4)   :: plane1,plane2,plane3
       real(kind=cp), dimension(3)   :: p0,p1,p2,p3,u,v,r,t
       real(kind=cp), dimension(3,3) :: w, w1
       real(kind=cp)                 :: d,umod,vmod,rmod,d1
       real(kind=cp)                 :: sx, sy, sz, sx2, sy2, sz2, sx3, sy3, sz3
       real(kind=cp)                 :: sxy, sxz, syz, sxy2, sxz2
       real(kind=cp)                 :: sx2y, sx2z, syz2, sy2z
       integer                       :: i

       call init_err_math3d()
       centroid=0.0
       baricenter=0.0

       p1=Atm_Cart(1:3,1)
       p2=Atm_Cart(1:3,2)
       p3=Atm_Cart(1:3,3)

       select case (cn)
          case (:2)
             err_Math3D=.true.
             err_Math3D_Mess='Centroid calculation needs 3 vertives as minimum'
             return

          case (3)
             !---- Plane 1: Defined with those 3 Points ----!
             call Get_Plane_From_Points(p1, p2, p3, &
                                        plane1(1), plane1(2), plane1(3), plane1(4))
             r=plane1(1:3)
             rmod=euclidean_norm(3,r)
             if (abs(rmod) <= 0.0001) then
                err_Math3D=.true.
                err_Math3D_Mess='Imposible to define a Plane with the three given points '
                return
             end if
             r=r/rmod

             !---- Vectors ----!
             u=p2-p1
             umod=euclidean_norm(3,u)
             if (abs(umod) <= 0.0001) then
                err_Math3D=.true.
                err_Math3D_Mess='Check your points! Seems that two of them are equal'
                return
             end if

             v=p3-p1
             vmod=euclidean_norm(3,v)
             if (abs(vmod) <= 0.0001) then
                err_Math3D=.true.
                err_Math3D_Mess='Check your points! Seems that two of them are equal'
                return
             end if

             !---- Plane 2 ----!
             p0=p1+0.5*u
             u=u/umod
             plane2(1:3)=u
             plane2(4)=-( plane2(1)*p0(1)+plane2(2)*p0(2)+plane2(3)*p0(3) )

             !---- Plane 3 ----!
             p0=p1+0.5*v
             v=v/vmod
             plane3(1:3)=v
             plane3(4)=-( plane3(1)*p0(1)+plane3(2)*p0(2)+plane3(3)*p0(3) )

             !---- Centroid ----!
             w(1,1:3)=plane1(1:3)
             w(2,1:3)=plane2(1:3)
             w(3,1:3)=plane3(1:3)
             d=determ_a(w)

             if (abs(d) <= 0.0001) then
                err_Math3D=.true.
                err_Math3D_Mess='Determinant is singular to calculate Centroid point'
                return
             end if

             w(1:3,1)=(/-plane1(4),-plane2(4), -plane3(4)/)
             d1=determ_a(w)
             centroid(1)=d1/d

             w(1,1:3)=plane1(1:3)
             w(2,1:3)=plane2(1:3)
             w(3,1:3)=plane3(1:3)
             w(1:3,2)=(/-plane1(4),-plane2(4), -plane3(4)/)
             d1=determ_a(w)
             centroid(2)=d1/d

             w(1,1:3)=plane1(1:3)
             w(2,1:3)=plane2(1:3)
             w(3,1:3)=plane3(1:3)
             w(1:3,3)=(/-plane1(4),-plane2(4), -plane3(4)/)
             d1=determ_a(w)
             centroid(3)=d1/d

             sx =0.0; sy =0.0; sz =0.0
             do i=1,3
                sx=sx+Atm_Cart(1,i)
                sy=sy+Atm_Cart(2,i)
                sz=sz+Atm_Cart(3,i)
             end do

          case (4:)
             sx =0.0; sy =0.0; sz =0.0
             sx2=0.0; sy2=0.0; sz2=0.0
             sx3=0.0; sy3=0.0; sz3=0.0
             sxy=0.0; sxz=0.0; syz=0.0
             sxy2=0.0; sxz2=0.0
             sx2y=0.0; sx2z=0.0
             syz2=0.0; sy2z=0.0
             do i=1,cn
                sx=sx+Atm_Cart(1,i)
                sy=sy+Atm_Cart(2,i)
                sz=sz+Atm_Cart(3,i)

                sx2=sx2+Atm_Cart(1,i)*Atm_Cart(1,i)
                sy2=sy2+Atm_Cart(2,i)*Atm_Cart(2,i)
                sz2=sz2+Atm_Cart(3,i)*Atm_Cart(3,i)

                sx3=sx3+Atm_Cart(1,i)*Atm_Cart(1,i)*Atm_Cart(1,i)
                sy3=sy3+Atm_Cart(2,i)*Atm_Cart(2,i)*Atm_Cart(2,i)
                sz3=sz3+Atm_Cart(3,i)*Atm_Cart(3,i)*Atm_Cart(3,i)

                sxy=sxy+Atm_Cart(1,i)*Atm_Cart(2,i)
                sxz=sxz+Atm_Cart(1,i)*Atm_Cart(3,i)
                syz=syz+Atm_Cart(2,i)*Atm_Cart(3,i)

                sxy2=sxy2+Atm_Cart(1,i)*Atm_Cart(2,i)*Atm_Cart(2,i)
                sxz2=sxz2+Atm_Cart(1,i)*Atm_Cart(3,i)*Atm_Cart(3,i)

                sx2y=sx2y+Atm_Cart(2,i)*Atm_Cart(1,i)*Atm_Cart(1,i)
                sx2z=sx2z+Atm_Cart(3,i)*Atm_Cart(1,i)*Atm_Cart(1,i)

                syz2=syz2+Atm_Cart(2,i)*Atm_Cart(3,i)*Atm_Cart(3,i)
                sy2z=sy2z+Atm_Cart(3,i)*Atm_Cart(2,i)*Atm_Cart(2,i)
             end do

             w(1,1)=sx2 - (sx**2)/real(cn)
             w(1,2)=sxy - (sx*sy)/real(cn)
             w(1,3)=sxz - (sx*sz)/real(cn)
             t(1)=0.5*(sx3 + sxy2 + sxz2 - ((sx2*sx + sy2*sx + sz2*sx)/real(cn)))

             w(2,1)=sxy - (sx*sy)/real(cn)
             w(2,2)=sy2 - (sy**2)/real(cn)
             w(2,3)=syz - (sy*sz)/real(cn)
             t(2)=0.5*(sx2y + sy3 + syz2 - ((sx2*sy + sy2*sy + sz2*sy)/real(cn)))

             w(3,1)=sxz - (sx*sz)/real(cn)
             w(3,2)=syz - (sy*sz)/real(cn)
             w(3,3)=sz2 - (sz**2)/real(cn)
             t(3)=0.5*(sx2z + sy2z + sz3 - ((sx2*sz + sy2*sz + sz2*sz)/real(cn)))

             d=determ_a(w)
             if (abs(d) <= 0.0001) then
                err_Math3D=.true.
                err_Math3D_Mess='Determinant is singular to calculate Centroid point'
                return
             end if

             w1=w
             w1(:,1)=t
             d1=determ_a(w1)
             centroid(1)=d1/d

             w1=w
             w1(:,2)=t
             d1=determ_a(w1)
             centroid(2)=d1/d

             w1=w
             w1(:,3)=t
             d1=determ_a(w1)
             centroid(3)=d1/d
       end select

       baricenter=(/ sx/real(cn), sy/real(cn), sz/real(cn) /)

       return
    End Subroutine Get_Centroid_Coord

    !!----
    !!---- Subroutine Get_Cylindr_Coord(Xo,rho,Phi,zeta,Mode)
    !!----    real(kind=sp/dp), dimension(3),intent( in)           :: xo
    !!----    real(kind=sp/dp),              intent(out)           :: rho
    !!----    real(kind=sp/dp),              intent(out)           :: phi
    !!----    real(kind=sp/dp),              intent(out)           :: zeta
    !!----    character(len=*),              intent( in), optional :: mode
    !!----
    !!----    Determine the cylindrical coordinates from Cartesian coordinates.
    !!----    If Mode='D' the angle phi is provided in Degrees.
    !!----
    !!---- Update: February - 2005
    !!

    !!--++
    !!--++ Subroutine  Get_Cylindr_Coord_dp(Xo,rho,Phi,zeta,Mode)
    !!--++    real(kind=dp), dimension(3),intent( in)           ::  xo
    !!--++    real(kind=dp),              intent(out)           ::  rho
    !!--++    real(kind=dp),              intent(out)           ::  phi
    !!--++    real(kind=dp),              intent(out)           ::  zeta
    !!--++    character(len=*),           intent( in), optional ::  mode
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Determine the cylindrical coordinates from Cartesian coordinates.
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Get_Cylindr_Coord_dp(Xo,rho,Phi,zeta,Mode)
       !---- Arguments ----!
       real(kind=dp), dimension(3),intent( in)           ::  xo
       real(kind=dp),              intent(out)           ::  rho
       real(kind=dp),              intent(out)           ::  phi
       real(kind=dp),              intent(out)           ::  zeta
       character(len=*),           intent( in), optional ::  mode

       !---- Local Variables ----!
       integer :: j

       zeta=xo(3)
       if( abs(xo(2)) > eps .or. abs(xo(1)) > eps) then
          phi=atan2(xo(2),xo(1))
       else
          phi= 0.0_dp
       end if
       rho=0.0_dp
       do j=1,2
          rho=rho+xo(j)*xo(j)
       end do
       rho=sqrt(rho)

       if (present(mode)) then
          if (mode(1:1) == "D" .or. mode(1:1) == "d") phi=phi*to_deg
       end if

       return
    End Subroutine Get_Cylindr_Coord_dp

    !!--++
    !!--++ Subroutine  Get_Cylindr_Coord_sp(Xo,rho,Phi,zeta,Mode)
    !!--++    real(kind=sp), dimension(3),intent( in)           ::  xo
    !!--++    real(kind=sp),              intent(out)           ::  rho
    !!--++    real(kind=sp),              intent(out)           ::  phi
    !!--++    real(kind=sp),              intent(out)           ::  zeta
    !!--++    character(len=*),           intent( in), optional ::  mode
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Determine the cylindrical coordinates from Cartesian coordinates.
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Get_Cylindr_Coord_sp(Xo,rho,Phi,zeta,Mode)
       !---- Arguments ----!
       real(kind=sp), dimension(3),intent( in)           ::  xo
       real(kind=sp),              intent(out)           ::  rho
       real(kind=sp),              intent(out)           ::  phi
       real(kind=sp),              intent(out)           ::  zeta
       character(len=*),           intent( in), optional ::  mode

       !---- Local Variables ----!
       integer :: j

       zeta=xo(3)
       if( abs(xo(2)) > eps .or. abs(xo(1)) > eps) then
          phi=atan2(xo(2),xo(1))
       else
          phi= 0.0_sp
       end if
       rho=0.0_sp
       do j=1,2
          rho=rho+xo(j)*xo(j)
       end do
       rho=sqrt(rho)

       if (present(mode)) then
          if (mode(1:1) == "D" .or. mode(1:1) == "d") phi=phi*to_deg
       end if

       return
    End Subroutine Get_Cylindr_Coord_sp

    !!----
    !!---- Subroutine Get_Cart_from_Spher(r,Theta,Phi,Xo,Mode)
    !!----    real(kind=sp/dp),              intent( in)           :: r
    !!----    real(kind=sp/dp),              intent( in)           :: Theta
    !!----    real(kind=sp/dp),              intent( in)           :: Phi
    !!----    real(kind=sp/dp), dimension(3),intent(out)           :: xo
    !!----    character(len=*),              intent( in), optional :: mode
    !!----
    !!----    Determine the Cartesian coordinates from spherical coordinates.
    !!----    If Mode='D' the angle phi is provided in Degrees.
    !!----
    !!---- Update: February - 2005
    !!

    !!--++
    !!--++ Subroutine Get_Cart_from_Spher_dp(r,Theta,Phi,Xo,Mode)
    !!--++    real(kind=dp),              intent( in)           :: r
    !!--++    real(kind=dp),              intent( in)           :: Theta
    !!--++    real(kind=dp),              intent( in)           :: Phi
    !!--++    real(kind=dp), dimension(3),intent(out)           :: xo
    !!--++    character(len=*),           intent( in), optional :: mode
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Determine the Cartesian coordinates from spherical coordinates.
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Get_Cart_from_Spher_dp(r,Theta,Phi,Xo,Mode)
       !---- Arguments ----!
       real(kind=dp),              intent( in)           :: r
       real(kind=dp),              intent( in)           :: Theta
       real(kind=dp),              intent( in)           :: phi
       real(kind=dp), dimension(3),intent(out)           :: xo
       character(len=*),           intent( in), optional :: mode

       !---- Local Variables ----!
       real(kind=dp) :: ph,th

       ph=Phi
       th=Theta
       if (present(mode)) then
          if (mode(1:1) == "D" .or. mode(1:1) == "d") then
             ph=Phi*to_rad
             th=Theta*to_rad
          end if
       end if
       xo(1)=r*cos(ph)*sin(th)
       xo(2)=r*sin(ph)*sin(th)
       xo(3)=r*cos(th)

       return
    End Subroutine Get_Cart_from_Spher_dp

    !!--++
    !!--++ Subroutine Get_Cart_from_Spher_sp(r,Theta,Phi,Xo,Mode)
    !!--++    real(kind=sp),              intent( in)           :: r
    !!--++    real(kind=sp),              intent( in)           :: Theta
    !!--++    real(kind=sp),              intent( in)           :: Phi
    !!--++    real(kind=sp), dimension(3),intent(out)           :: xo
    !!--++    character(len=*),           intent( in), optional :: mode
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Determine the Cartesian coordinates from spherical coordinates.
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Get_Cart_from_Spher_sp(r,Theta,Phi,Xo,Mode)
       !---- Arguments ----!
       real(kind=sp),              intent( in)           :: r
       real(kind=sp),              intent( in)           :: Theta
       real(kind=sp),              intent( in)           :: phi
       real(kind=sp), dimension(3),intent(out)           :: xo
       character(len=*),           intent( in), optional :: mode

       !---- Local Variables ----!
       real(kind=sp) :: ph,th

       ph=Phi
       th=Theta
       if (present(mode)) then
          if (mode(1:1) == "D" .or. mode(1:1) == "d") then
             ph=Phi*to_rad
             th=Theta*to_rad
          end if
       end if
       xo(1)=r*cos(ph)*sin(th)
       xo(2)=r*sin(ph)*sin(th)
       xo(3)=r*cos(th)

       return
    End Subroutine Get_Cart_from_Spher_sp

    !!----
    !!---- Subroutine Get_Plane_from_Points(P1,P2,P3,A,B,C,D)
    !!----    real(kind=cp), dimension(3), intent(in) :: P1
    !!----    real(kind=cp), dimension(3), intent(in) :: P2
    !!----    real(kind=cp), dimension(3), intent(in) :: P3
    !!----    real(kind=cp),               intent(out):: A
    !!----    real(kind=cp),               intent(out):: B
    !!----    real(kind=cp),               intent(out):: C
    !!----    real(kind=cp),               intent(out):: D
    !!----
    !!----    Caculate the implicit form of a Plane in 3D as
    !!----    A * X + B * Y + C * Z + D = 0
    !!----
    !!---- Update: July - 2005
    !!
    Subroutine Get_Plane_from_Points(P1, P2, P3, A, B, C, D)
       !---- Arguments ----!
       real(kind=cp), dimension(3), intent(in) :: P1
       real(kind=cp), dimension(3), intent(in) :: P2
       real(kind=cp), dimension(3), intent(in) :: P3
       real(kind=cp),               intent(out):: A
       real(kind=cp),               intent(out):: B
       real(kind=cp),               intent(out):: C
       real(kind=cp),               intent(out):: D

       a = ( p2(2) - p1(2) ) * ( p3(3) - p1(3) ) &
           - ( p2(3) - p1(3) ) * ( p3(2) - p1(2) )

       b = ( p2(3) - p1(3) ) * ( p3(1) - p1(1) ) &
           - ( p2(1) - p1(1) ) * ( p3(3) - p1(3) )

       c = ( p2(1) - p1(1) ) * ( p3(2) - p1(2) ) &
           - ( p2(2) - p1(2) ) * ( p3(1) - p1(1) )

       d = - p2(1) * a - p2(2) * b - p2(3) * c

       return
    End Subroutine Get_Plane_from_Points

    !!----
    !!---- Subroutine Get_Spheric_Coord(Xo,Ss,Theta,Phi,Mode)
    !!----    real(kind=sp/dp), dimension(3),intent( in)           :: xo
    !!----    real(kind=sp/dp),              intent(out)           :: ss
    !!----    real(kind=sp/dp),              intent(out)           :: theta
    !!----    real(kind=sp/dp),              intent(out)           :: phi
    !!----    character(len=*),              intent( in), optional :: mode
    !!----
    !!----    Determine the spheric coordinates from rectangular coordinates.
    !!----    If Mode='D' the angles will be done in Degrees.
    !!----
    !!---- Update: February - 2005
    !!

    !!--++
    !!--++ Subroutine Get_Spheric_Coord_dp(Xo,Ss,Theta,Phi,Mode)
    !!--++    real(kind=dp), dimension(3),intent( in)           :: xo
    !!--++    real(kind=dp),              intent(out)           :: ss
    !!--++    real(kind=dp),              intent(out)           :: theta
    !!--++    real(kind=dp),              intent(out)           :: phi
    !!--++    character(len=*),           intent( in), optional :: mode
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Determine the spheric coordinates from rectangular coordinates
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Get_Spheric_Coord_dp(xo,ss,theta,phi,mode)
       !---- Arguments ----!
       real(kind=dp), intent( in), dimension(3)   :: xo
       real(kind=dp), intent(out)                 :: ss
       real(kind=dp), intent(out)                 :: theta
       real(kind=dp), intent(out)                 :: phi
       character(len=*), intent(in), optional     :: mode

       !---- Local Variables ----!
       integer :: j

       ss=0.0_dp
       do j=1,3
          ss=ss+xo(j)*xo(j)
       end do
       ss=sqrt(ss)
       if (ss > 0.0_dp) then
          theta=xo(3)/ss
          if (abs(theta) > 1.0_dp) then
             theta=sign(1.0_dp,theta)
          end if
          theta=acos(theta)
          if (abs(theta) < eps .or. abs(theta-pi) < eps) then
             phi=0.0_dp
          else
             phi=atan2(xo(2),xo(1))
          end if
       else
          theta=0.0_dp
          phi=0.0_dp
       end if
       if (present(mode)) then
          if (mode(1:1) == "D" .or. mode(1:1) == "d") then
             theta=theta*to_deg
             phi=phi*to_deg
          end if
       end if

       return
    End Subroutine Get_Spheric_Coord_dp

    !!--++
    !!--++ Subroutine Get_Spheric_Coord_sp(Xo,Ss,Theta,Phi,Mode)
    !!--++    real(kind=sp), dimension(3),intent( in)           :: xo
    !!--++    real(kind=sp),              intent(out)           :: ss
    !!--++    real(kind=sp),              intent(out)           :: theta
    !!--++    real(kind=sp),              intent(out)           :: phi
    !!--++    character(len=*),           intent( in), optional :: mode
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Determine the spheric coordinates from rectangular coordinates
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Get_Spheric_Coord_sp(xo,ss,theta,phi,mode)
       !---- Arguments ----!
       real(kind=sp), intent( in), dimension(3)   :: xo
       real(kind=sp), intent(out)                 :: ss
       real(kind=sp), intent(out)                 :: theta
       real(kind=sp), intent(out)                 :: phi
       character(len=*), intent(in), optional     :: mode

       !---- Local Variables ----!
       integer :: j

       ss=0.0_sp
       do j=1,3
          ss=ss+xo(j)*xo(j)
       end do
       ss=sqrt(ss)
       if (ss > 0.0_sp) then
          theta=xo(3)/ss
          if (abs(theta) > 1.0_sp) then
             theta=sign(1.0_sp,theta)
          end if
          theta=acos(theta)
          if (abs(theta) < eps .or. abs(theta-pi) < eps) then
             phi=0.0_sp
          else
             phi=atan2(xo(2),xo(1))
          end if
       else
          theta=0.0_sp
          phi=0.0_sp
       end if
       if (present(mode)) then
          if (mode(1:1) == "D" .or. mode(1:1) == "d") then
             theta=theta*to_deg
             phi=phi*to_deg
          end if
       end if

       return
    End Subroutine Get_Spheric_Coord_sp

    !!----
    !!---- Subroutine Matrix_DiagEigen(A, V, C)
    !!----    real(kind=cp), dimension(3,3), intent(in)  :: a
    !!----    real(kind=cp), dimension(3),   intent(out) :: v
    !!----    real(kind=cp), dimension(3,3), intent(out) :: c
    !!----
    !!----    Diagonalize the matrix A, put eigenvalues in V and
    !!----    eigenvectors in C
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Matrix_DiagEigen(a,v,c)
       !---- Arguments ----!
       real(kind=cp), intent(in)  , dimension(3,3)    :: a
       real(kind=cp), intent(out) , dimension(3)      :: v
       real(kind=cp), intent(out) , dimension(3,3)    :: c

       !---- Local Variables ----!
       integer, parameter            :: n=3
       integer                       :: i, j, k, itmax, nm1, ip1, iter
       real(kind=cp), dimension(3)   :: u
       real(kind=cp), dimension(3,3) :: e
       real(kind=cp), parameter      :: eps1=1.e-7 , eps2=1.e-7 , eps3=1.e-7
       real(kind=cp)                 :: sigma1, offdsq, p, q, spq, csa, sna
       real(kind=cp)                 :: holdik, holdki, sigma2

       call init_err_math3d()
       nm1=n-1
       itmax=50
       do i=1,n
          do j=1,n
             e(i,j)=a(i,j)
             c(i,j)=0.0
             if (j < i) e(i,j)=0.0
          end do
       end do
       sigma1=0.0
       offdsq=0.0

       do i=1,n
          sigma1=sigma1+e(i,i)**2
          c(i,i)=1.0
          ip1=i+1
          if (i >= n) exit
          do j=ip1,n
             offdsq=offdsq+e(i,j)**2
          end do
       end do

       do iter=1,itmax
          do i=1,nm1
             ip1=i+1
             do j=ip1,n
                q=abs(e(i,i)-e(j,j))
                if (q <= eps1) then
                   csa=1.0/sqrt(2.0)
                   sna=csa
                else
                   if (abs(e(i,j)) <= eps2) then
                      e(i,j)=0.0
                      cycle
                   end if
                   p=2.0*e(i,j)*q/(e(i,i)-e(j,j))
                   spq=sqrt(p*p+q*q)
                   csa=sqrt((1.0+q/spq)/2.0)
                   sna=p/(2.0*csa*spq)
                end if
                do k=1,n
                   holdki=c(k,i)
                   c(k,i)=holdki*csa+c(k,j)*sna
                   c(k,j)=holdki*sna-c(k,j)*csa
                end do
                do k=i,n
                   if (k > j) then
                      holdik=e(i,k)
                      e(i,k)=csa*holdik+sna*e(j,k)
                      e(j,k)=sna*holdik-csa*e(j,k)
                   else
                      u(k)=e(i,k)
                      e(i,k)=csa*u(k)+sna*e(k,j)
                      if (k /= j) cycle
                      e(j,k)=sna*u(k)-csa*e(j,k)
                   end if
                end do
                u(j)=sna*u(i)-csa*u(j)
                do k=1,j
                   if (k <= i)  then
                      holdki=e(k,i)
                      e(k,i)=csa*holdki+sna*e(k,j)
                      e(k,j)=sna*holdki-csa*e(k,j)
                   else
                      e(k,j)=sna*u(k)-csa*e(k,j)
                   end if
                end do
                e(i,j)=0.0
             end do
          end do
          sigma2=0.0
          do i=1,n
             v(i)=e(i,i)
             sigma2=sigma2+v(i)*v(i)
          end do
          if (1.0-sigma1/sigma2 <= eps3) return
          sigma1=sigma2
       end do

       ERR_Math3D =.true.
       ERR_Math3D_Mess=" Convergence not reached in diagonalization "

       return
    End Subroutine Matrix_DiagEigen

    !!----
    !!---- Subroutine Matrix_Inverse(A, B, Ifail)
    !!----    real(kind=cp), dimension(3,3), intent(in)  :: a
    !!----    real(kind=cp), dimension(3,3), intent(out) :: b
    !!----    integer                      , intent(out) :: ifail
    !!----                                                  0 = OK; 1 = Fail
    !!----
    !!----    Inverts a 3x3 Matrix
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Matrix_Inverse(a,b,ifail)
       !---- Argument ----!
       real(kind=cp), dimension(3,3), intent(in)  :: a
       real(kind=cp), dimension(3,3), intent(out) :: b
       integer                      , intent(out) :: ifail

       !---- Local variables ----!
       real(kind=cp), parameter :: epso=1.0e-20
       real(kind=cp)            :: dmat

       ifail=0
       call init_err_math3d()

       b(1,1) = a(2,2)*a(3,3)-a(2,3)*a(3,2)
       b(2,1) = -(a(2,1)*a(3,3)-a(2,3)*a(3,1))
       b(3,1) = a(2,1)*a(3,2)-a(2,2)*a(3,1)
       b(1,2) = -(a(1,2)*a(3,3)-a(1,3)*a(3,2))
       b(2,2) = a(1,1)*a(3,3)-a(1,3)*a(3,1)
       b(3,2) = -(a(1,1)*a(3,2)-a(1,2)*a(3,1))
       b(1,3) = a(1,2)*a(2,3)-a(1,3)*a(2,2)
       b(2,3) = -(a(1,1)*a(2,3)-a(1,3)*a(2,1))
       b(3,3) = a(1,1)*a(2,2)-a(1,2)*a(2,1)
       dmat = a(1,1)*b(1,1)+a(1,2)*b(2,1)+a(1,3)*b(3,1)

       if (abs(dmat) < epso) then
          ifail=1
          ERR_Math3D =.true.
          ERR_Math3D_Mess="Singular Matrix: inversion imposible"
          return
       end if

       b = b/dmat

       return
    End Subroutine Matrix_Inverse

    !!----
    !!---- Subroutine Resolv_Sist_1X2(W,T,Ts,X,Ix)
    !!----    integer,       dimension(2),      intent(in) :: w     !  In -> Input vector
    !!----    real(kind=cp),                    intent(in) :: t     !  In -> Input value
    !!----    real(kind=cp), dimension(2),      intent(out):: ts    ! Out -> Fixed value of solution
    !!----    real(kind=cp), dimension(2),      intent(out):: x     ! Out -> Fixed value for x,y
    !!----    integer, dimension(2),            intent(out):: ix    ! Out -> determine if solution
    !!----                                                                   1: x, 2: y, 3: z
    !!--<<
    !!----              w11 x1 + w12 x2  = t1
    !!----              x_sol(i)= ts(i) + x(i) ix(i)
    !!-->>
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Resolv_Sist_1x2(w,t,ts,x,ix)
       !---- Arguments ----!
       integer,dimension(2), intent( in) :: w
       real(kind=cp),                 intent( in) :: t
       real(kind=cp), dimension(2),   intent(out) :: ts
       real(kind=cp), dimension(2),   intent(out) :: x
       integer,dimension(2), intent(out) :: ix

       !---- Initialize ----!
       ts = 0.0
       x  = 1.0
       ix = 0
       call init_err_math3d()

       !---- Both are zeros ----!
       if ( all(w == 0)) then
          if (abs(t) < eps) then
             ix(1)=1
             ix(2)=2
          else
             ERR_Math3D=.true.
             ERR_Math3D_Mess="Inconsistent solution (1x2)"
          end if
          return
       end if

       !---- Any is zero ----!
       if (any(w == 0)) then
          if ( w(1) == 0 ) then
             ix(1)=1
             ts(2)=t/real(w(2))
              x(2)=0.0
          else
             ts(1)=t/real(w(1))
              x(1)=0.0
             ix(2)=2
          end if
       else
          ix(1)=1
          ts(2)=t/real(w(2))
           x(2)=-real(w(1))/real(w(2))
          ix(2)=1
       end if

       return
    End Subroutine Resolv_Sist_1x2

    !!----
    !!---- Subroutine Resolv_Sist_1X3(W,T,Ts,X,Ix)
    !!----    integer, dimension(3),            intent(in) :: w     !  In -> Input vector
    !!----    real(kind=cp),                    intent(in) :: t     !  In -> Input value
    !!----    real(kind=cp), dimension(3),      intent(out):: ts    ! Out -> Fixed value of solution
    !!----    real(kind=cp), dimension(3),      intent(out):: x     ! Out -> Fixed value for x,y,z
    !!----    integer, dimension(3),            intent(out):: ix    ! Out -> determine if solution
    !!----                                                                   1: x, 2: y, 3: z
    !!--<<
    !!----               w11 x1 + w12 x2 + w13 x3 = t1
    !!----               x_sol(i)= ts(i) + x(i) ix(i)
    !!-->>
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Resolv_Sist_1x3(w,t,ts,x,ix)
       !---- Arguments ----!
       integer,dimension(3), intent( in) :: w
       real(kind=cp),                 intent( in) :: t
       real(kind=cp), dimension(3),   intent(out) :: ts
       real(kind=cp), dimension(3),   intent(out) :: x
       integer,dimension(3), intent(out) :: ix

       !---- Local Variables ----!
       integer               :: i, zeros
       integer, dimension(2) :: w1
       integer, dimension(2) :: ix1
       real(kind=cp), dimension(2)    :: ts1
       real(kind=cp), dimension(2)    :: x1

       !---- Initialize ----!
       ts = 0.0
       x  = 1.0
       ix = 0
       call init_err_math3d()

       !---- Are there zeros? ----!
       zeros=0
       do i=1,3
          if (w(i) == 0) zeros=zeros+1
       end do
       select case (zeros)
          case (3)
             if (abs(t) < eps) then
                do i=1,3
                   ix(i)=i
                end do
             else
                ERR_Math3D=.true.
                ERR_Math3D_Mess="Inconsistent solution (1 x 3)"
             end if

          case (2)
             do i=1,3
                if (w(i) /= 0) then
                   ts(i)=t/real(w(i))
                   x(i) =0.0
                else
                   ix(i)=i
                end if
             end do

          case (1)
             do i=1,3
                if (w(i) == 0) exit
             end do
             select case (i)
                case (1)
                   w1=w(2:3)

                case (2)
                   w1(1)=w(1)
                   w1(2)=w(3)

                case (3)
                   w1=w(1:2)
             end select
             call resolv_sist_1x2(w1,t,ts1,x1,ix1)
             select case (i)
                case (1)
                   ix(1)  = 1
                   ts(2:3)= ts1
                   x(2:3) = x1
                   if (ix1(1)==1) ix(2)=2
                   if (ix1(1)==2) ix(2)=3
                   if (ix1(2)==1) ix(3)=2
                   if (ix1(2)==2) ix(3)=3

                  case (2)
                     ix(2)= 2
                     ts(1)= ts1(1)
                     ts(3)= ts1(2)
                     x(1) = x1(1)
                     x(3) = x1(2)
                     if (ix1(1)==1) ix(1)=1
                     if (ix1(1)==2) ix(1)=3
                     if (ix1(2)==1) ix(3)=1
                     if (ix1(2)==2) ix(3)=3

                  case (3)
                     ix(3)  = 3
                     ts(1:2)= ts1
                     x(1:2) = x1
                     ix(1:2)= ix1
               end select

          case (0)
             ERR_Math3D=.true.
             ERR_Math3D_Mess="Inconsistent case ax+by+cz=t (1x3)"
       end select

       return
    End Subroutine Resolv_Sist_1x3

    !!----
    !!---- Subroutine Resolv_Sist_2X2(W,T,Ts,X,Ix)
    !!----    integer, dimension(2,2),          intent(in) :: w     !  In -> Input vector
    !!----    real(kind=cp), dimension(2),      intent(in) :: t     !  In -> Input value
    !!----    real(kind=cp), dimension(2),      intent(out):: ts    ! Out -> Fixed value of solution
    !!----    real(kind=cp), dimension(2),      intent(out):: x     ! Out -> Fixed value for x,y
    !!----    integer, dimension(2),            intent(out):: ix    ! Out -> determine if solution
    !!----                                                                   1: x, 2: y, 3: z
    !!--<<
    !!----                 w11 x1 + w12 x2  = t1
    !!----                 w21 x1 + w22 x2  = t2
    !!----                 x_sol(i)= ts(i) + x(i) ix(i)
    !!-->>
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Resolv_Sist_2x2(w,t,ts,x,ix)
       !---- Arguments ----!
       integer,dimension(2,2), intent( in) :: w
       real(kind=cp),dimension(2),      intent( in) :: t
       real(kind=cp),dimension(2),      intent(out) :: ts
       real(kind=cp),dimension(2),      intent(out) :: x
       integer,dimension(2),   intent(out) :: ix

       !---- Local Variables ----!
       integer                 :: i,deter
       integer, dimension(2)   :: zeros,colum
       real(kind=cp)           :: rden, rnum

       !---- Initialize ----!
       ts    = 0.0
       x     = 1.0
       ix    = 0
       call init_err_math3d()

       deter = w(1,1)*w(2,2) - w(1,2)*w(2,1)
       rden=real(deter)
       if (deter /= 0) then
          !---- X(1) ----!
          rnum=t(1)*w(2,2) - w(1,2)*t(2)
          ts(1)=rnum/rden

          !---- X(2) ----!
          rnum=w(1,1)*t(2) - t(1)*w(2,1)
          ts(2)=rnum/rden

          x =0.0

       else                        ! Singular Matrix
          !---- Are there zero rows? ----!
          zeros=0
          do i=1,2
             if (w(i,1) == 0 .and. w(i,2) == 0 )  zeros(i)=1
          end do
          select case (sum(zeros))
             case (2)
                if (abs(t(1)) <= eps .and. abs(t(2)) <= eps) then
                   ix(1)=1
                   ix(2)=2
                else
                   ERR_Math3D=.true.
                   ERR_Math3D_Mess="Inconsistent solution (2x2)"
                end if

             case (1)
                do i=1,2
                   if (zeros(i) == 0) exit
                end do
                call resolv_sist_1x2(w(i,:),t(i),ts,x,ix)

             case (0)
                !---- Are there zero columns? ----!
                colum=0
                do i=1,2
                   if (w(1,i) == 0 .and. w(2,i) == 0 ) colum(i)=1
                end do
                select case (sum(colum))
                   case (1)
                      do i=1,2
                         if (colum(i) == 0) exit
                      end do
                      if (w(1,i) /= 0) then
                         ts(i)=t(1)/real(w(1,i))
                      else
                         ts(i)=t(2)/real(w(2,i))
                      end if
                      x(i)=0.0
                      if (i == 1) then
                         ix(2)=2
                      else
                         ix(1)=1
                      end if

                   case (0)
                      call resolv_sist_1x2(w(1,:),t(1),ts,x,ix)

                end select
          end select
       end if

       return
    End Subroutine Resolv_Sist_2x2

    !!----
    !!---- Subroutine Resolv_Sist_2X3(W,T,Ts,X,Ix)
    !!----    integer, dimension(2,3),          intent(in) :: w      !  In -> Input vector
    !!----    real(kind=cp), dimension(2),      intent(in) :: t      !  In -> Input value
    !!----    real(kind=cp), dimension(3),      intent(out):: ts     ! Out -> Fixed value of solution
    !!----    real(kind=cp), dimension(3),      intent(out):: x      ! Out -> Fixed value for x,y
    !!----    integer, dimension(3),            intent(out):: ix     ! Out -> determine if solution
    !!----                                                                    1: x, 2: y, 3: z
    !!----               w11 x1 + w12 x2 + w13 x3 = t1
    !!----               w21 x1 + w22 x2 + w23 x3 = t2
    !!----               x_sol(i)= ts(i) + x(i) ix(i)
    !!----
    !!----   Update: February - 2005
    !!
    Subroutine Resolv_Sist_2x3(w,t,ts,x,ix)
       !---- Arguments ----!
       integer,dimension(2,3),          intent( in) :: w
       real(kind=cp),dimension(2),      intent( in) :: t
       real(kind=cp),dimension(3),      intent(out) :: ts
       real(kind=cp),dimension(3),      intent(out) :: x
       integer,dimension(3),            intent(out) :: ix

       !---- Local Variables ----!
       integer                 :: i, j
       integer, dimension(2)   :: fila
       integer, dimension(2)   :: ix1
       integer, dimension(3)   :: colum
       integer, dimension(2,2) :: w1
       integer, dimension(2,3) :: wm
       integer, dimension(2)   :: wc
       real(kind=cp)                    :: tc
       real(kind=cp), dimension(2)      :: tm
       real(kind=cp), dimension(2)      :: ts1, x1

       !---- Initialize ----!
       ts    = 0.0
       x     = 1.0
       ix    = 0
       call init_err_math3d()

       !---- Are there zero columns? ----!
       colum=0
       do i=1,3
            if (all(w(:,i) == 0)) colum(i)=1
       end do
       select case (sum(colum))
          case (3)
             if (abs(t(1)) <= eps .and. abs(t(2)) <= eps) then
                do i=1,3
                   ix(i)=i
                end do
             else
                ERR_Math3D=.true.
                ERR_Math3D_Mess="Inconsistent solution in (2x3)"
             end if

          case (2)
             do i=1,3
                if (colum(i) == 0) exit
             end do
             if (w(1,i) /= 0) then
                ts(i)=t(1)/real(w(1,i))
             else
                ts(i)=t(2)/real(w(2,i))
             end if
             x(i)=0.0
             select case (i)
                case (1)
                   ix(2)=2
                   ix(3)=3

                case (2)
                   ix(1)=1
                   ix(3)=3

                case (3)
                   ix(1)=1
                   ix(2)=2
             end select

          case (1)
             do i=1,3
                if (colum(i) == 1) exit
             end do
             select case (i)
                case (1)
                   w1=w(:,2:3)

                case (2)
                   w1(1,1)=w(1,1)
                   w1(1,2)=w(1,3)
                   w1(2,1)=w(2,1)
                   w1(2,2)=w(2,3)

                case (3)
                   w1=w(:,1:2)
             end select
             call resolv_sist_2x2(w1,t,ts1,x1,ix1)
             select case (i)
                case (1)
                   ix(1)  = 1
                   ts(2:3)= ts1
                   x (2:3)= x1
                   if (ix1(1) == 1) ix(2)=2
                   if (ix1(1) == 2) ix(2)=3
                   if (ix1(2) == 1) ix(3)=2
                   if (ix1(2) == 2) ix(3)=3

                case (2)
                   ix(2)=2
                   ts(1)=ts1(1)
                   ts(3)=ts1(2)
                   x(1) = x1(1)
                   x(3) = x1(2)
                   if (ix1(1) == 1) ix(1)=1
                   if (ix1(1) == 2) ix(1)=3
                   if (ix1(2) == 1) ix(3)=1
                   if (ix1(2) == 2) ix(3)=3

                case (3)
                   ix(3)  = 3
                   ts(1:2)= ts1
                   x (1:2)= x1
                   ix(1:2)= ix1
             end select

          case (0)
             !---- Are there zeros in any element of rows? ----!
             fila = 0
             do i=1,2
                if (all(w(i,:)==0)) fila(i)=1
             end do
             select case (sum(fila))
                case (1)
                   if (w(1,1) /= 0) then
                      call resolv_sist_1x3(w(1,:),t(1),ts,x,ix)
                   else
                      call resolv_sist_1x3(w(2,:),t(2),ts,x,ix)
                   end if

                case (0)
                   fila = 0
                   wm   = w
                   tm   = t
                   !---- Are there zeros in any element of rows? ----!
                   do i=1,2
                      do j=1,3
                         if (w(i,j)==0) fila(i)=fila(i)+1
                      end do
                   end do
                   if ( fila(2) > fila(1) ) then
                      wm(1,:)=w(2,:)
                      wm(2,:)=w(1,:)
                      tm(1)  =t(2)
                      tm(2)  =t(1)
                          j  =fila(1)
                      fila(1)=fila(2)
                      fila(2)=j
                   end if
                   select case (fila(1))
                      case (2)
                         do i=1,3
                            if (wm(1,i) /= 0) exit
                         end do
                         ts(i)=tm(1)/real(wm(1,i))
                         x(i)=0.0
                         select case (i)
                            case (1)
                               wc(1)=wm(2,2)
                               wc(2)=wm(2,3)
                               tc=tm(2)-(wm(2,1)*ts(i))

                            case (2)
                               wc(1)=wm(2,1)
                               wc(2)=wm(2,3)
                               tc=tm(2)-(wm(2,2)*ts(i))

                            case (3)
                               wc(1)=wm(2,1)
                               wc(2)=wm(2,2)
                               tc=tm(2)-(wm(2,3)*ts(i))
                         end select
                         call resolv_sist_1x2(wc,tc,ts1,x1,ix1)
                         select case(i)
                            case (1)
                               ts(2:3)=ts1
                                x(2:3)=x1
                                if (ix1(1)==1) ix(2)=2
                                if (ix1(1)==2) ix(2)=3
                                if (ix1(2)==1) ix(3)=2
                                if (ix1(2)==2) ix(3)=3

                            case (2)
                               ts(1)=ts1(1)
                               ts(3)=ts1(2)
                                x(1)=x1(1)
                                x(3)=x1(2)
                                if (ix1(1)==1) ix(1)=1
                                if (ix1(1)==2) ix(1)=3
                                if (ix1(2)==1) ix(3)=1
                                if (ix1(2)==2) ix(3)=3

                            case (3)
                               ts(1:2)=ts1
                                x(1:2)=x1
                               ix(1:2)=ix1
                         end select

                      case (1)
                         do i=1,3
                            if (wm(1,i) == 0) exit
                         end do
                         select case (fila(2))
                            case (1)
                               do j=1,3
                                  if (wm(2,j) == 0) exit
                               end do
                               select case (i)
                                  case (1)             ! 0 en w(1,1)
                                     select case (j)
                                        case (2)
                                           wc(1)=-wm(2,1)/wm(2,3)
                                           wc(2)= wm(1,2)/wm(1,3)
                                           tc=tm(1)/real(wm(1,3)) - tm(2)/real(wm(2,3))
                                           call resolv_sist_1x2(wc,tc,ts1,x1,ix1)
                                           ts(1:2)=ts1
                                           x(1:2) =x1
                                           ix(1:2)=ix1
                                           if (ix(1) == 0) then
                                              ts(3)=tm(2)/real(wm(2,3)) - ts(1)*wm(2,1)/real(wm(2,3))
                                              x(3)=0.0
                                           else
                                              if (ix(2) == 0) then
                                                 ts(3)=tm(1)/real(wm(1,3)) - ts(2)*wm(1,2)/real(wm(1,3))
                                                 x(3)=0.0
                                              else
                                                 ts(3)=tm(2)/real(wm(2,3))
                                                 x(3)=-real(wm(2,1))/real(wm(2,3))
                                                 ix(3)=1

                                                 ts(2)=tc/real(wc(2))
                                                 x(2) =-real(wc(1))/real(wc(2))
                                                 ix(2)=1
                                              end if
                                           end if

                                        case (3)
                                           wc(1)=-wm(2,1)/wm(2,2)
                                           wc(2)= wm(1,3)/wm(1,2)
                                           tc=tm(1)/real(wm(1,2)) - tm(2)/real(wm(2,2))
                                           call resolv_sist_1x2(wc,tc,ts1,x1,ix1)
                                           ts(1)=ts1(1)
                                           ts(3)=ts1(2)
                                           x(1) =x1(1)
                                           x(3) =x1(2)
                                           if (ix1(1) == 1) ix(1)=1
                                           if (ix1(1) == 2) ix(1)=3
                                           if (ix1(2) == 1) ix(3)=1
                                           if (ix1(2) == 2) ix(3)=3
                                           if (ix(1) == 0) then
                                              ts(2)=tm(2)/real(wm(2,2)) - ts(1)*wm(2,1)/real(wm(2,2))
                                              x(2)=0.0
                                           else
                                              if (ix(3) == 0) then
                                                 ts(2)=tm(1)/real(wm(1,2)) - ts(3)*wm(1,3)/real(wm(1,2))
                                                 x(2)=0.0
                                              else
                                                 ts(2)=tm(2)/real(wm(2,2))
                                                 x(3)=-real(wm(2,1))/real(wm(2,2))
                                                 ix(2)=1

                                                 ts(3)=tc/real(wc(2))
                                                 x(3) =-real(wc(1))/real(wc(2))
                                                 ix(3)=1
                                              end if
                                           end if
                                     end select

                                  case (2)             ! 0 en w(1,2)
                                     select case (j)
                                        case (1)
                                           wc(1)= wm(1,1)/wm(1,3)
                                           wc(2)=-wm(2,2)/wm(2,3)
                                           tc=tm(1)/real(wm(1,3)) - tm(2)/real(wm(2,3))
                                           call resolv_sist_1x2(wc,tc,ts1,x1,ix1)
                                           ts(1:2)=ts1
                                           x(1:2) =x1
                                           ix(1:2)=ix1
                                           if (ix(1) == 0) then
                                              ts(3)=tm(1)/real(wm(1,3)) - ts(1)*wm(1,1)/real(wm(1,3))
                                              x(3)=0.0
                                           else
                                              if (ix(2) == 0) then
                                                 ts(3)=tm(2)/real(wm(2,3)) - ts(2)*wm(2,2)/real(wm(2,3))
                                                 x(3)=0.0
                                              else
                                                 ts(3)=tm(1)/real(wm(1,3))
                                                 x(3)=-real(wm(1,1))/real(wm(1,3))
                                                 ix(3)=1

                                                 ts(2)=tc/real(wc(2))
                                                 x(2) = -real(wc(1))/real(wc(2))
                                                 ix(2)= 1
                                              end if
                                           end if

                                        case (3)
                                           wc(1)=-wm(2,2)/wm(2,1)
                                           wc(2)= wm(1,3)/wm(1,1)
                                           tc=tm(1)/real(wm(1,1)) - tm(2)/real(wm(2,1))
                                           call resolv_sist_1x2(wc,tc,ts1,x1,ix1)
                                           ts(2:3)=ts1
                                           x(2:3) =x1
                                           if (ix1(1) == 1) ix(2)=2
                                           if (ix1(1) == 2) ix(2)=3
                                           if (ix1(2) == 1) ix(3)=2
                                           if (ix1(2) == 2) ix(3)=3
                                           if (ix(2) == 0) then
                                              ts(1)=tm(2)/real(wm(2,1)) - ts(2)*wm(2,2)/real(wm(2,1))
                                              x(1)=0.0
                                           else
                                              if (ix(3) == 0) then
                                                 ts(1)=tm(1)/real(wm(1,1)) - ts(3)*wm(1,3)/real(wm(1,1))
                                                 x(1)=0.0
                                              else
                                                 ix(1)=1

                                                 ts(2)=tm(2)/real(wm(2,2))
                                                 x(2) =-real(wm(2,1))/real(wm(2,2))
                                                 ix(2)=1

                                                 ts(3)=tm(1)/real(wm(1,3))
                                                 x(3) =-real(wm(1,1))/real(wm(1,3))
                                                 ix(3)=1
                                              end if
                                           end if
                                     end select

                                  case (3)             ! 0 en w(1,3)
                                     select case (j)
                                        case (1)
                                           wc(1)= wm(1,1)/wm(1,2)
                                           wc(2)=-wm(2,3)/wm(2,2)
                                           tc=tm(1)/real(wm(1,2)) - tm(2)/real(wm(2,2))
                                           call resolv_sist_1x2(wc,tc,ts1,x1,ix1)
                                           ts(1)=ts1(1)
                                           ts(3)=ts1(2)
                                           x(1) =x1(1)
                                           x(3) =x1(2)
                                           if (ix1(1) == 1) ix(1)=1
                                           if (ix1(1) == 2) ix(1)=3
                                           if (ix1(2) == 1) ix(3)=1
                                           if (ix1(2) == 2) ix(3)=3
                                           if (ix(1) == 0) then
                                              ts(2)=tm(1)/real(wm(1,2)) - ts(1)*wm(1,1)/real(wm(1,2))
                                              x(2)=0.0
                                           else
                                              if (ix(3) == 0) then
                                                 ts(2)=tm(2)/real(wm(2,2)) - ts(3)*wm(2,3)/real(wm(2,2))
                                                 x(2)=0.0
                                              else
                                                 ts(2)=tm(1)/real(wm(1,2))
                                                 x(2) =-real(wm(1,1))/real(wm(1,2))
                                                 ix(2)=1

                                                 ts(3)=tc/real(wc(2))
                                                 x(3) =-real(wc(1))/real(wc(2))
                                                 ix(3)=1
                                              end if
                                           end if

                                        case (2)
                                           wc(1)= wm(1,2)/wm(1,1)
                                           wc(2)=-wm(2,3)/wm(2,1)
                                           tc=tm(1)/real(wm(1,1)) - tm(2)/real(wm(2,1))
                                           call resolv_sist_1x2(wc,tc,ts1,x1,ix1)
                                           ts(2:3)=ts1
                                           x(2:3) =x1
                                           if (ix1(1) == 1) ix(2)=2
                                           if (ix1(1) == 2) ix(2)=3
                                           if (ix1(2) == 1) ix(3)=2
                                           if (ix1(2) == 2) ix(3)=3
                                           if (ix(2) == 0) then
                                              ts(1)=tm(1)/real(wm(1,1)) - ts(2)*wm(1,2)/real(wm(1,1))
                                              x(1)=0.0
                                           else
                                              if (ix(3) == 0) then
                                                 ts(1)=tm(2)/real(wm(2,1)) - ts(3)*wm(2,3)/real(wm(2,1))
                                                 x(1)=0.0
                                              else
                                                 ix(1)=1

                                                 ts(2)=tm(1)/real(wm(1,2))
                                                 x(2) =-real(wm(1,1))/real(wm(1,2))
                                                 ix(2)=1

                                                 ts(3)=tm(2)/real(wm(2,3))
                                                 x(3) =-real(wm(2,1))/real(wm(2,3))
                                                 ix(3)=1
                                              end if
                                           end if
                                     end select
                               end select

                            case (0)
                               select case (i)
                                  case (1)
                                     wc(1)=wm(2,1)
                                     wc(2)=wm(2,2)- wm(2,3)*wm(1,2)/wm(1,3)
                                     tc=tm(2)-tm(1)*wm(2,3)/real(wm(1,3))
                                     call resolv_sist_1x2(wc,tc,ts1,x1,ix1)
                                     ts(1:2)=ts1
                                     x(1:2)=x1
                                     ix(1:2)=ix1
                                     if (ix(2) == 0) then
                                        ts(3)=tm(1)/real(wm(1,3)) - ts(2)*real(wm(1,2))/real(wm(1,3))
                                        x(3)=0.0
                                     else
                                        ix(1)=1

                                        ts(2)=(tm(2) - tm(1)*wm(2,3)/real(wm(1,3))) / &
                                              (real(wm(2,2)) - real(wm(2,3)*wm(1,2))/real(wm(1,3)) )
                                        x(2) =-real(wm(2,1)) / &
                                              (real(wm(2,2)) - real(wm(2,3)*wm(1,2))/real(wm(1,3)) )
                                        ix(2)=1

                                        ts(3)= tm(1)/real(wm(1,3)) - (real(wm(1,2))/real(wm(1,3)))*ts(2)
                                        x(3) =- (real(wm(1,2))/real(wm(1,3)))*x(2)
                                        ix(3)=1
                                     end if

                                  case (2)
                                     wc(1)=wm(2,1)-wm(2,3)*wm(1,1)/wm(1,3)
                                     wc(2)=wm(2,2)
                                     tc=tm(2)-tm(1)*wm(2,3)/real(wm(1,3))
                                     call resolv_sist_1x2(wc,tc,ts1,x1,ix1)
                                    ts(1:2)=ts1
                                    x(1:2)=x1
                                    ix(1:2)=ix1
                                    if (ix(1) == 0) then
                                       ts(3)=tm(1)/real(wm(1,3)) - ts(1)*real(wm(1,1))/real(wm(1,3))
                                       x(3)=0.0
                                    else
                                       ix(1)=1

                                       ts(2)=(tm(2) - tm(1)*wm(2,3)/real(wm(1,3)))/real(wm(2,2))
                                       x(2) =(real(wm(1,1)*wm(2,3))/real(wm(1,3)) - real(wm(2,1)))/real(wm(2,2))
                                       ix(2)=1

                                       ts(3)=tm(1)/real(wm(1,3))
                                       x(3) =-real(wm(1,1))/real(wm(1,3))
                                       ix(3)=1
                                    end if

                                 case (3)
                                    wc(1)=wm(2,1)-wm(1,1)*wm(2,2)/wm(1,2)
                                    wc(2)=wm(2,3)
                                    tc=tm(2)-tm(1)*wm(2,2)/real(wm(1,2))
                                    call resolv_sist_1x2(wc,tc,ts1,x1,ix1)
                                    ts(1)=ts1(1)
                                    ts(3)=ts1(2)
                                    x(1)=x1(1)
                                    x(3)=x1(2)
                                    if (ix1(1) == 1) ix(1)=1
                                    if (ix1(1) == 2) ix(1)=3
                                    if (ix1(2) == 1) ix(3)=1
                                    if (ix1(2) == 2) ix(3)=3
                                    if (ix(1) == 0) then
                                       ts(2)=tm(1)/real(wm(1,2)) - ts(1)*real(wm(1,1))/real(wm(1,2))
                                       x(2)=0.0
                                    else
                                       ix(1) =1

                                       ts(2)=tm(1)/real(wm(1,2))
                                       x(2) =-real(wm(1,1))/real(wm(1,2))
                                       ix(2)=1

                                       ts(3)=(tm(2) - tm(1)*wm(2,2)/real(wm(1,2)))/real(wm(2,3))
                                       x(3) =(real(wm(1,1)*wm(2,2))/real(wm(1,2)) - real(wm(2,1)))/real(wm(2,3))
                                       ix(3)=1
                                    end if
                               end select
                         end select

                      case (0)
                         call resolv_sist_1x3(wm(1,:),tm(1),ts,x,ix)
                   end select

             end select
       end select

       return
    End Subroutine Resolv_Sist_2x3

    !!----
    !!---- Subroutine Resolv_Sist_3X3(W,T,Ts,X,Ix)
    !!----    integer, dimension(3,3),          intent(in) :: w      !  In -> Input vector
    !!----    real(kind=cp), dimension(3),      intent(in) :: t      !  In -> Input value
    !!----    real(kind=cp), dimension(3),      intent(out):: ts     ! Out -> Fixed value of solution
    !!----    real(kind=cp), dimension(3),      intent(out):: x      ! Out -> Fixed value for x,y
    !!----    integer, dimension(3),            intent(out):: ix     ! Out -> determine if solution
    !!----                                                                     1: x, 2: y, 3: z
    !!--<<
    !!----              w11 x1 + w12 x2 + w13 x3 = t1
    !!----              w21 x1 + w22 x2 + w23 x3 = t2
    !!----              w31 x1 + w32 x2 + w33 x3 = t3
    !!----              x_sol(i)= ts(i) + x(i) ix(i)
    !!-->>
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Resolv_Sist_3x3(w,t,ts,x,ix)
       !---- Arguments ----!
       integer, dimension(3,3),          intent(in) :: w
       real(kind=cp), dimension(3),      intent(in) :: t
       real(kind=cp), dimension(3),      intent(out):: ts
       real(kind=cp), dimension(3),      intent(out):: x
       integer, dimension(3),            intent(out):: ix

       !---- Local variables ----!
       integer                 :: i,j,deter
       integer, dimension(3)   :: fila
       integer, dimension(3,3) :: w1
       integer, dimension(2,3) :: wm
       real(kind=cp)                    :: rnum, rden
       real(kind=cp), dimension(3)      :: t1
       real(kind=cp), dimension(2)      :: tm
       real(kind=cp),dimension(3,3)     :: rw

       !---- Initialize ----!
       ts  = 0.0
       x   = 1.0
       ix  = 0
       call init_err_math3d()

       deter=determ_a(w)
       rden=real(deter)

       if (deter /= 0) then
          !---- X(1) ----!
          rw=real(w)
          rw(:,1)=t
          rnum=determ_a(rw)
          ts(1)=rnum/rden

          !---- X(2) ----!
          rw=real(w)
          rw(:,2)=t
          rnum=determ_a(rw)
          ts(2)=rnum/rden

          !---- X(3) ----!
          rw=real(w)
          rw(:,3)=t
          rnum=determ_a(rw)
          ts(3)=rnum/rden

          x=0.0

       else                     !  Singular Matrix
          !---- Are there zero rows? ----!
          fila=0
          do i=1,3
             if (all(w(i,:) == 0)) fila(i)=1
          end do
          select case (sum(fila))
             !---- All values are zeros ----!
             case (3)
                if (all(abs(t) < eps)) then
                   do i=1,3
                      ix(i)=i
                   end do
                else
                   ERR_Math3D=.true.
                   ERR_Math3D_Mess="Inconsistent system (3 x 3)"
                end if

             !---- Two rows with zeroes ----!
             case (2)
                do i=1,3
                   if (fila(i) == 0) exit
                end do
                call resolv_sist_1x3(w(i,:),t(i),ts,x,ix)

             !---- One row with zeroes ----!
             case (1)
                do i=1,3
                   if (fila(i) == 1) exit
                end do
                select case(i)
                   case (1)
                      wm(1,:)=w(2,:)
                      wm(2,:)=w(3,:)
                      tm=t(2:3)

                   case (2)
                      wm(1,:)=w(1,:)
                      wm(2,:)=w(3,:)
                      tm(1)=t(1)
                      tm(2)=t(3)

                   case (3)
                      wm(1,:)=w(1,:)
                      wm(2,:)=w(2,:)
                      tm=t(1:2)

                end select
                call resolv_sist_2x3(wm,tm,ts,x,ix)

             !---- Non zero rows ----!
             case (0)
                w1=w
                t1=t

                !---- Are there 2 rows proportional? ----!
                do i=1,3
                   if ( abs(w1(1,i)) > abs(w1(2,i)) ) then
                      if (w1(2,i) /= 0) then
                         j=w1(1,i)/w1(2,i)
                      else
                         j=0
                      end if
                      if (j /= 0) then
                         if (j*w1(2,1) == w1(1,1) .and. j*w1(2,2) == w1(1,2) .and. &
                             j*w1(2,3) == w1(1,3) ) then
                            w1(1,:)=w1(2,:)
                            t1(1)  =t1(2)
                            exit
                         end if
                      end if
                   else
                      if (w1(1,i) /= 0) then
                         j=w1(2,i)/w1(1,i)
                      else
                         j=0
                      end if
                      if (j /= 0) then
                         if (j*w1(1,1) == w1(2,1) .and. j*w1(1,2) == w1(2,2) .and. &
                             j*w1(1,3) == w1(2,3) ) then
                            w1(2,:)=w1(1,:)
                            t1(2)  =t1(1)
                            exit
                         end if
                      end if
                   end if
                end do

                do i=1,3
                   if ( abs(w1(1,i)) > abs(w1(3,i)) ) then
                      if (w1(3,i) /= 0) then
                         j=w1(1,i)/w1(3,i)
                      else
                         j=0
                      end if
                      if (j /= 0) then
                         if (j*w1(3,1) == w1(1,1) .and. j*w1(3,2) == w1(1,2) .and. &
                             j*w1(3,3) == w1(1,3) ) then
                            w1(1,:)=w1(3,:)
                            t1(1)  =t1(3)
                            exit
                         end if
                      end if
                   else
                      if (w1(1,i) /= 0) then
                         j=w1(3,i)/w1(1,i)
                      else
                         j=0
                      end if
                      if (j /= 0) then
                         if (j*w1(1,1) == w1(3,1) .and. j*w1(1,2) == w1(3,2) .and. &
                             j*w1(1,3) == w1(3,3) ) then
                            w1(3,:)=w1(1,:)
                            t1(3)  =t1(1)
                            exit
                         end if
                      end if
                   end if
                end do

                do i=1,3
                   if ( abs(w1(2,i)) > abs(w1(3,i)) ) then
                      if (w1(3,i) /= 0) then
                         j=w1(2,i)/w1(3,i)
                      else
                         j=0
                      end if
                      if (j /= 0) then
                         if (j*w1(3,1) == w1(2,1) .and. j*w1(3,2) == w1(2,2) .and. &
                             j*w1(3,3) == w1(2,3) ) then
                            w1(2,:)=w1(3,:)
                            t1(2)  =t1(3)
                            exit
                         end if
                      end if
                   else
                      if (w1(2,i) /= 0) then
                         j=w1(3,i)/w1(2,i)
                      else
                         j=0
                      end if
                      if (j /= 0) then
                         if (j*w1(2,1) == w1(3,1) .and. j*w1(2,2) == w1(3,2) .and. &
                             j*w1(2,3) == w1(3,3) ) then
                            w1(3,:)=w1(2,:)
                            t1(3)  =t1(2)
                            exit
                         end if
                      end if
                   end if
                end do

                !---- Are there 3 rows equal? ----!
                if ( (w1(1,1) == w1(2,1)) .and. (w1(1,1) == w1(3,1)) .and. &
                     (w1(1,2) == w1(2,2)) .and. (w1(1,2) == w1(3,2)) .and. &
                     (w1(1,3) == w1(2,3)) .and. (w1(1,3) == w1(3,3)) ) then

                   call resolv_sist_1x3(w1(1,:),t1(1),ts,x,ix)

                !---- Are there 2 rows equal? ----!
                elseif( (w1(1,1) == w1(2,1)) .and. (w1(1,2) == w1(2,2)) .and. &
                        (w1(1,3) == w1(2,3)) ) then

                   call resolv_sist_2x3(w1(2:3,:),t1(2:3),ts,x,ix)

                elseif( (w1(1,1) == w1(3,1)) .and. (w1(1,2) == w1(3,2)) .and. &
                        (w1(1,3) == w1(3,3)) ) then

                   call resolv_sist_2x3(w1(1:2,:),t1(1:2),ts,x,ix)

                elseif( (w1(2,1) == w1(3,1)) .and. (w1(2,2) == w1(3,2)) .and. &
                        (w1(2,3) == w1(3,3)) ) then

                   call resolv_sist_2x3(w1(1:2,:),t1(1:2),ts,x,ix)

                !---- Are linear combinations? ----!
                else
                   call resolv_sist_2x3(w1(1:2,:),t1(1:2),ts,x,ix)

                end if

          end select
       end if

       return
    End Subroutine Resolv_Sist_3x3

 End Module CFML_Math_3D
!!-------------------------------------------------------
!!---- Crystallographic Fortran Modules Library (CrysFML)
!!-------------------------------------------------------
!!---- The CrysFML project is distributed under LGPL. In agreement with the
!!---- Intergovernmental Convention of the ILL, this software cannot be used
!!---- in military applications.
!!----
!!---- Copyright (C) 1999-2012  Institut Laue-Langevin (ILL), Grenoble, FRANCE
!!----                          Universidad de La Laguna (ULL), Tenerife, SPAIN
!!----                          Laboratoire Leon Brillouin(LLB), Saclay, FRANCE
!!----
!!---- Authors: Juan Rodriguez-Carvajal (ILL)
!!----          Javier Gonzalez-Platas  (ULL)
!!----
!!---- Contributors: Laurent Chapon     (ILL)
!!----               Marc Janoschek     (Los Alamos National Laboratory, USA)
!!----               Oksana Zaharko     (Paul Scherrer Institute, Switzerland)
!!----               Tierry Roisnel     (CDIFX,Rennes France)
!!----               Eric Pellegrini    (ILL)
!!----
!!---- This library is free software; you can redistribute it and/or
!!---- modify it under the terms of the GNU Lesser General Public
!!---- License as published by the Free Software Foundation; either
!!---- version 3.0 of the License, or (at your option) any later version.
!!----
!!---- This library is distributed in the hope that it will be useful,
!!---- but WITHOUT ANY WARRANTY; without even the implied warranty of
!!---- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
!!---- Lesser General Public License for more details.
!!----
!!---- You should have received a copy of the GNU Lesser General Public
!!---- License along with this library; if not, see <http://www.gnu.org/licenses/>.
!!----
!!----
!!---- MODULE: CFML_Symmetry_Tables
!!----   INFO: Tabulated information on Crystallographic Symmetry
!!----
!!---- HISTORY
!!----    Update: 04/03/2011
!!----
!!----
!!---- DEPENDENCIES
!!--++    Use CFML_GlobalDeps,       only: cp
!!--++    Use CFML_String_Utilities, only: U_case
!!----
!!---- VARIABLES
!!----    BC_D6H
!!----    BC_OH
!!----    DEPMAT
!!----    ERR_SYMTAB
!!----    ERR_SYMTAB_MESS
!!--++    IT_SET                       [Private]
!!----    INTSYMD6H
!!----    INTSYMOH
!!----    KOV_D6H
!!----    KOV_OH
!!----    LATT
!!----    LAUE_CLASS
!!----    LTR_A
!!----    LTR_B
!!----    LTR_C
!!----    LTR_F
!!----    LTR_I
!!----    LTR_R
!!----    MAGMAT
!!----    ML_D6H
!!----    ML_OH
!!----    MOD6
!!----    POINT_GROUP
!!--++    SPG_GEN                      [Private]
!!----    SPGR_INFO_TYPE
!!----    SPGR_INFO
!!----    SYS_CRY
!!----    TABLE_EQUIV_TYPE
!!----    SYSTEM_EQUIV
!!----    WYCK_INFO_TYPE
!!----    WYCKOFF_INFO
!!----    X_D6H
!!----    X_OH
!!----    ZAK_D6H
!!----    ZAK_OH
!!----
!!---- PROCEDURES
!!----    Functions:
!!----
!!----    Subroutines:
!!----       GET_GENERATORS
!!----       REMOVE_SPGR_INFO
!!----       REMOVE_SYSTEM_EQUIV
!!----       REMOVE_WYCKOFF_INFO
!!--++       SET_IT_GEN                [Private]
!!----       SET_SPGR_INFO
!!----       SET_SYSTEM_EQUIV
!!----       SET_WYCKOFF_INFO
!!----
!!
 Module CFML_Symmetry_Tables
    !---- Use modules ----!
    Use CFML_GlobalDeps,        only: cp
    Use CFML_String_Utilities, only: U_Case

    !---- Variables ----!
    implicit none

    private

    !---- List of public subroutines ----!
    public :: get_generators
    public :: set_spgr_info, set_system_equiv, set_wyckoff_info
    public :: remove_spgr_info, remove_system_equiv, remove_wyckoff_info

    !---- List of private subroutines ----!
    private :: set_IT_gen

    !---- Definitions ----!

    !!----
    !!---- BC_D6H
    !!----    character (len=*), dimension(24), parameter, public :: BC_D6h
    !!----
    !!----    Bradley & Cracknell Notation
    !!----
    !!---- Update: February - 2005
    !!
    character (len=*), dimension(24), parameter, public  :: BC_D6h =(/                  &
       "  E  "," C+_3"," C-_3"," C_2 "," C-_6"," C+_6","C'_23","C'_21","C'_22", &
       "C`_23","C`_21","C`_22","  I  "," S-_6"," S+_6"," s_h "," S+_3"," S-_3", &
       " s_v3"," s_v1"," s_v2"," s_d3"," s_d1"," s_d2" /)

    !!----
    !!---- BC_OH
    !!----    character(len=*), dimension(48), parameter, public :: BC_Oh
    !!----
    !!----    Bradley & Cracknell Notation
    !!----
    !!---- Update: February - 2005
    !!
    character(len=*), dimension(48), parameter, public :: BC_Oh =(/             &
       "  E  "," C_2z"," C_2y"," C_2x","C+_31","C+_34","C+_33","C+_32","C-_31", &
       "C-_33","C-_32","C-_34"," C_2a"," C_2b","C-_4z","C+_4z","C-_4x"," C_2d", &
       " C_2f","C+_4x","C+_4y"," C_2c","C-_4y"," C_2e","  I  "," s_z "," s_y ", &
       " s_x ","S-_61","S-_64","S-_63","S-_62","S+_61","S+_63","S+_62","S+_64", &
       " s_da"," s_db","S+_4z","S-_4z","S+_4x"," s_dd"," s_df","S-_4x","S-_4y", &
       " s_dc","S+_4y"," s_de"  /)

    !!----
    !!---- DEPMAT
    !!----    character(len=*), dimension(72), parameter, public :: Depmat
    !!----
    !!----    Magnetic array
    !!----
    !!---- Update: February - 2005
    !!
    character(len=*), dimension(72), parameter, public :: Depmat = (/       &
       "( Dx, Dy, Dz)      ","(-Dx,-Dy, Dz)      ","(-Dx, Dy,-Dz)      ",   &
       "( Dx,-Dy,-Dz)      ","( Dz, Dx, Dy)      ","( Dz,-Dx,-Dy)      ",   &
       "(-Dz,-Dx, Dy)      ","(-Dz, Dx,-Dy)      ","( Dy, Dz, Dx)      ",   &
       "(-Dy, Dz,-Dx)      ","( Dy,-Dz,-Dx)      ","(-Dy,-Dz, Dx)      ",   &
       "( Dy, Dx,-Dz)      ","(-Dy,-Dx,-Dz)      ","( Dy,-Dx, Dz)      ",   &
       "(-Dy, Dx, Dz)      ","( Dx, Dz,-Dy)      ","(-Dx, Dz, Dy)      ",   &
       "(-Dx,-Dz,-Dy)      ","( Dx,-Dz, Dy)      ","( Dz, Dy,-Dx)      ",   &
       "( Dz,-Dy, Dx)      ","(-Dz, Dy, Dx)      ","(-Dz,-Dy,-Dx)      ",   &
       "(-Dx,-Dy,-Dz)      ","( Dx, Dy,-Dz)      ","( Dx,-Dy, Dz)      ",   &
       "(-Dx, Dy, Dz)      ","(-Dz,-Dx,-Dy)      ","(-Dz, Dx, Dy)      ",   &
       "( Dz, Dx,-Dy)      ","( Dz,-Dx, Dy)      ","(-Dy,-Dz,-Dx)      ",   &
       "( Dy,-Dz, Dx)      ","(-Dy, Dz, Dx)      ","( Dy, Dz,-Dx)      ",   &
       "(-Dy,-Dx, Dz)      ","( Dy, Dx, Dz)      ","(-Dy, Dx,-Dz)      ",   &
       "( Dy,-Dx,-Dz)      ","(-Dx,-Dz, Dy)      ","( Dx,-Dz,-Dy)      ",   &
       "( Dx, Dz, Dy)      ","(-Dx, Dz,-Dy)      ","(-Dz,-Dy, Dx)      ",   &
       "(-Dz, Dy,-Dx)      ","( Dz,-Dy,-Dx)      ","( Dz, Dy, Dx)      ",   &
       "( Dx   ,    Dy, Dz)","(   -Dy, Dx-Dy, Dz)","(-Dx+Dy,-Dx   , Dz)",   &
       "(-Dx   ,   -Dy, Dz)","(    Dy,-Dx+Dy, Dz)","( Dx-Dy, Dx   , Dz)",   &
       "(    Dy, Dx   ,-Dz)","( Dx-Dy,   -Dy,-Dz)","(-Dx   ,-Dx+Dy,-Dz)",   &
       "(   -Dy,-Dx   ,-Dz)","(-Dx+Dy,    Dy,-Dz)","( Dx   , Dx-Dy,-Dz)",   &
       "(-Dx   ,   -Dy,-Dz)","(    Dy,-Dx+Dy,-Dz)","( Dx-Dy, Dx   ,-Dz)",   &
       "( Dx   ,    Dy,-Dz)","(   -Dy, Dx-Dy,-Dz)","(-Dx+Dy,-Dx   ,-Dz)",   &
       "(   -Dy,-Dx   , Dz)","(-Dx+Dy,    Dy, Dz)","( Dx   , Dx-Dy, Dz)",   &
       "(    Dy, Dx   , Dz)","( Dx-Dy,   -Dy, Dz)","(-Dx   ,-Dx+Dy, Dz)"   /)

    !!----
    !!---- ERR_SYMTAB
    !!----    logical, public :: Err_Symtab
    !!----
    !!----    Logical Variable to indicate an error on this module.
    !!----
    !!---- Update: January - 2005
    !!
    logical, public :: ERR_Symtab=.false.

    !!----
    !!---- ERR_SYMTAB_MESS
    !!----    character(len=150), public :: ERR_SymTab_Mess
    !!----
    !!----    String containing information about the last error
    !!----
    !!---- Update: February - 2005
    !!
    character(len=150), public :: ERR_SymTab_Mess=" "

    !!--++
    !!--++ IT_SET
    !!--++    logical, private :: it_set=.false.
    !!--++
    !!--++    (PRIVATE)
    !!--++    Variable to test if generators have been set
    !!--++
    !!--++ Update: February - 2005
    !!
    logical, private :: it_set=.false.

    !!----
    !!---- INTSYMD6H
    !!----    character(len=* ), dimension(24), parameter, public:: IntSymD6h
    !!----
    !!----    International Symbols For Point Group Elements Of 6/mmm (D6h)
    !!----
    !!---- Update: February - 2005
    !!
    character(len=* ), dimension(24), parameter, public :: IntSymD6h =(/     &
       "  1           "," 3+ ( 0, 0, z)"," 3- ( 0, 0, z)","  2 ( 0, 0, z)",  &
       " 6- ( 0, 0, z)"," 6+ ( 0, 0, z)","  2 ( x, x, 0)","  2 ( x, 0, 0)",  &
       "  2 ( 0, y, 0)","  2 ( x,-x, 0)","  2 ( x,2x, 0)","  2 (2x, x, 0)",  &
       " -1           ","-3+ ( 0, 0, z)","-3- ( 0, 0, z)","  m ( x, y, 0)",  &
       "-6- ( 0, 0, z)","-6+ ( 0, 0, z)","  m ( x,-x, z)","  m ( x,2x, z)",  &
       "  m (2x, x, z)","  m ( x, x, z)","  m ( x, 0, z)","  m ( 0, y, z)"   /)

    !!----
    !!---- INTSYMOH
    !!----    character(len=* ), dimension(48), parameter, public :: IntSymOh
    !!----
    !!----    International Symbols For Point Group Elements Of M3M (Oh)
    !!----
    !!---- Update: February - 2005
    !!
    character(len=* ), dimension(48), parameter, public :: IntSymOh = (/     &
       "  1           ","  2 ( 0, 0, z)","  2 ( 0, y, 0)","  2 ( x, 0, 0)",  &
       " 3+ ( x, x, x)"," 3+ (-x, x,-x)"," 3+ ( x,-x,-x)"," 3+ (-x,-x, x)",  &
       " 3- ( x, x, x)"," 3- ( x,-x,-x)"," 3- (-x,-x, x)"," 3- (-x, x,-x)",  &
       "  2 ( x, x, 0)","  2 ( x,-x, 0)"," 4- ( 0, 0, z)"," 4+ ( 0, 0, z)",  &
       " 4- ( x, 0, 0)","  2 ( 0, y, y)","  2 ( 0, y,-y)"," 4+ ( x, 0, 0)",  &
       " 4+ ( 0, y, 0)","  2 ( x, 0, x)"," 4- ( 0, y, 0)","  2 (-x, 0, x)",  &
       " -1           ","  m ( x, y, 0)","  m ( x, 0, z)","  m ( 0, y, z)",  &
       "-3+ ( x, x, x)","-3+ (-x, x,-x)","-3+ ( x,-x,-x)","-3+ (-x,-x, x)",  &
       "-3- ( x, x, x)","-3- ( x,-x,-x)","-3- (-x,-x, x)","-3- (-x, x,-x)",  &
       "  m ( x,-x, z)","  m ( x, x, z)","-4- ( 0, 0, z)","-4+ ( 0, 0, z)",  &
       "-4- ( x, 0, 0)","  m ( x, y,-y)","  m ( x, y, y)","-4+ ( x, 0, 0)",  &
       "-4+ ( 0, y, 0)","  m (-x, y, x)","-4- ( 0, y, 0)","  m ( x, y, x)"   /)

    !!----
    !!---- KOV_D6H
    !!----    character(len=*), dimension(24), parameter, public :: Kov_D6h
    !!----
    !!----    Kovalev Notation
    !!----
    !!---- Update: February - 2005
    !!
    character(len=*), dimension(24), parameter, public :: Kov_d6h=(/       &
       " h1"," h3"," h5"," h4"," h6"," h2","h11"," h9"," h7"," h8","h12",  &
       "h10","h13","h15","h17","h16","h18","h14","h23",                    &
       "h21","h19","h20","h24","h22"/)

    !!----
    !!---- KOV_OH
    !!----    character(len=*), dimension(48), parameter, public :: Kov_Oh
    !!----
    !!----    Kovalev Notation
    !!----
    !!---- Update: February - 2005
    !!
    character(len=*), dimension(48), parameter, public :: Kov_Oh=(/               &
       " h1"," h4"," h3"," h2"," h9","h10","h12","h11"," h5"," h7"," h6"," h8",   &
       "h16","h13","h15","h14","h20","h18","h17","h19","h24","h23",               &
       "h22","h21","h25","h28","h27","h26","h33","h34","h36","h35",               &
       "h29","h31","h30","h32","h40","h37","h39","h38","h44","h42",               &
       "h41","h43","h48","h47","h46","h45"/)

    !!----
    !!---- LATT
    !!----    character(len=* ), dimension( 8) , parameter, public :: Latt
    !!----
    !!----    Lattice Traslations
    !!----
    !!---- Update: February - 2005
    !!
    character(len=* ), dimension( 8) , parameter, public  :: Latt =(/  &
       "  P: { 000 }                                       ",          &
       "  A: { 000;  0  1/2 1/2 }+                         ",          &
       "  B: { 000; 1/2  0  1/2 }+                         ",          &
       "  C: { 000; 1/2 1/2  0  }+                         ",          &
       "  I: { 000; 1/2 1/2 1/2 }+                         ",          &
       "  R: { 000; 2/3 1/3 1/3; 1/3 2/3 2/3   }+          ",          &
       "  F: { 000;  0  1/2 1/2; 1/2  0  1/2; 1/2 1/2  0 }+",          &
       "  Z: { 000;  Unconventional Z-centering vectors  }+"   /)

    !!----
    !!---- LAUE_CLASS
    !!----    character(len=*), dimension(16), parameter, public :: Laue_class
    !!----
    !!----    Laue symbols
    !!----
    !!---- Update: February - 2005
    !!
    character(len=*), dimension(16), parameter, public :: laue_class=(/ &
       "-1   ","2/m  ","mmm  ","4/m  ","4/mmm","-3 R ","-3m R","-3   ", &
       "-3m1 ","-31m ","6/m  ","6/mmm","m-3  ","m-3m ","m3   ","m3m  "/)

    !!----
    !!---- Litvin_point_op_label
    !!----    character(len=*), dimension(48), parameter, public :: Litvin_point_op_label
    !!----
    !!----    Symbols of point operators as given by Litvin (Non-hexagonal)
    !!----    The order corresponds to the Table given by Harold T. Stokes and Branton J. Campbell
    !!----
    !!---- Update: November - 2012, reordered according to the last tables 15/2/2016
    !!
    character(len=*), dimension(48), parameter, public :: Litvin_point_op_label=(/ &
       "1       ","2x      ","2y      ","2z      ","3xyz-1  ","3xy-z   ","3-xyz   ","3x-yz   ", &
       "3xyz    ","3x-yz-1 ","3xy-z-1 ","3-xyz-1 ","2-xy    ","4z      ","4z-1    ","2xy     ", &
       "2-yz    ","2yz     ","4x      ","4x-1    ","2-xz    ","4y-1    ","2xz     ","4y      ", &
       "-1      ","mx      ","my      ","mz      ","-3xyz-1 ","-3xy-z  ","-3-xyz  ","-3x-yz  ", &
       "-3xyz   ","-3x-yz-1","-3xy-z-1","-3-xyz-1","m-xy    ","-4z     ","-4z-1   ","mxy     ", &
       "m-yz    ","myz     ","-4x     ","-4x-1   ","m-xz    ","-4y-1   ","mxz     ","-4y     "/)

    !!----
    !!---- Litvin_point_op
    !!----    character(len=*), dimension(48), parameter, public :: Litvin_point_op
    !!----
    !!----    Jones Faithful symbols of point operators as given by Litvin (Non-hexagonal)
    !!----    The order corresponds to the Table given by Harold T. Stokes and Branton J. Campbell
    !!----
    !!---- Update: November - 2012, reordered according to the last tables 15/2/2016
    !!

    character(len=*), dimension(48), parameter, public :: Litvin_point_op=(/ &
       "x,y,z   ", "x,-y,-z ", "-x,y,-z ", "-x,-y,z ", "y,z,x   ",           &
       "y,-z,-x ", "-y,z,-x ", "-y,-z,x ", "z,x,y   ", "z,-x,-y ",           &
       "-z,x,-y ", "-z,-x,y ", "-y,-x,-z", "-y,x,z  ", "y,-x,z  ",           &
       "y,x,-z  ", "-x,-z,-y", "-x,z,y  ", "x,-z,y  ", "x,z,-y  ",           &
       "-z,-y,-x", "-z,y,x  ", "z,-y,x  ", "z,y,-x  ", "-x,-y,-z",           &
       "-x,y,z  ", "x,-y,z  ", "x,y,-z  ", "-y,-z,-x", "-y,z,x  ",           &
       "y,-z,x  ", "y,z,-x  ", "-z,-x,-y", "-z,x,y  ", "z,-x,y  ",           &
       "z,x,-y  ", "y,x,z   ", "y,-x,-z ", "-y,x,-z ", "-y,-x,z ",           &
       "x,z,y   ", "x,-z,-y ", "-x,z,-y ", "-x,-z,y ", "z,y,x   ",           &
       "z,-y,-x ", "-z,y,-x ", "-z,-y,x "/)


    !!----
    !!---- Litvin_point_op_hex_label
    !!----    character(len=*), dimension(24), parameter, public :: Litvin_point_op_hex_label
    !!----
    !!----    Symbols of point operators as given by Litvin (Hexagonal)
    !!----    The order corresponds to the Table given by Harold T. Stokes and Branton J. Campbell
    !!----
    !!---- Update: November - 2012, reordered according to the last tables 15/2/2016
    !!
    character(len=*), dimension(24), parameter, public :: Litvin_point_op_hex_label=(/ &
       "1    ","6z   ","3z   ","2z   ","3z-1 ","6z-1 ","2x   ","21   ",                &
       "2xy  ","22   ","2y   ","23   ","-1   ","-6z  ","-3z  ","mz   ",                &
       "-3z-1","-6z-1","mx   ","m1   ","mxy  ","m2   ","my   ","m3   "/)


    !!----
    !!---- Litvin_point_op_hex
    !!----    character(len=*), dimension(24), parameter, public :: Litvin_point_op_hex
    !!----
    !!----    Jones Faithful symbols of point operators as given by Litvin (Hexagonal)
    !!----    The order corresponds to the Table given by Harold T. Stokes and Branton J. Campbell
    !!----
    !!---- Update: November - 2012, reordered according to the last tables 15/2/2016
    !!

    character(len=*), dimension(24), parameter, public :: Litvin_point_op_hex=(/      &
       "x,y,z     ","x-y,x,z   ","-y,x-y,z  ","-x,-y,z   ","-x+y,-x,z ","y,-x+y,z  ", &
       "x-y,-y,-z ","x,x-y,-z  ","y,x,-z    ","-x+y,y,-z ","-x,-x+y,-z","-y,-x,-z  ", &
       "-x,-y,-z  ","-x+y,-x,-z","y,-x+y,-z ","x,y,-z    ","x-y,x,-z  ","-y,x-y,-z ", &
       "-x+y,y,z  ","-x,-x+y,z ","-y,-x,z   ","x-y,-y,z  ","x,x-y,z   ","y,x,z     "/)


    !!----
    !!---- LTR_A
    !!----    real(kind=cp), dimension(3,2), parameter, public :: Ltr_A
    !!----
    !!----    Lattice Traslations of type A
    !!----
    !!---- Update: February - 2005
    !!
    real(kind=cp), dimension(3,2), parameter, public :: Ltr_a =reshape ( (/0.0,0.0,0.0, 0.0,0.5,0.5/), (/3,2/) )

    !!----
    !!---- LTR_B
    !!----    real(kind=cp), dimension(3,2), parameter, public :: Ltr_B
    !!----
    !!----    Lattice Traslations of type B
    !!----
    !!---- Update: February - 2005
    !!
    real(kind=cp), dimension(3,2), parameter, public :: Ltr_b =reshape ( (/0.0,0.0,0.0, 0.5,0.0,0.5/), (/3,2/) )

    !!----
    !!---- LTR_C
    !!----    real(kind=cp), dimension(3,2), parameter, public :: Ltr_C
    !!----
    !!----    Lattice Traslations of type C
    !!----
    !!---- Update: February - 2005
    !!
    real(kind=cp), dimension(3,2), parameter, public :: Ltr_c =reshape ( (/0.0,0.0,0.0, 0.5,0.5,0.0/), (/3,2/) )

    !!----
    !!---- LTR_F
    !!----    real(kind=cp), dimension(3,4), parameter, public
    !!----
    !!----    Lattice Traslations of type F
    !!----
    !!---- Update: February - 2005
    !!
    real(kind=cp), dimension(3,4), parameter, public :: &
                   Ltr_f =reshape( (/0.0,0.0,0.0, 0.0,0.5,0.5, 0.5,0.0,0.5, 0.5,0.5,0.0 /),(/3,4/) )

    !!----
    !!---- LTR_I
    !!----    real(kind=cp), dimension(3,2), parameter, public :: Ltr_I
    !!----
    !!----    Lattice Traslations of type I
    !!----
    !!---- Update: February - 2005
    !!
    real(kind=cp), dimension(3,2), parameter, public :: Ltr_i =reshape ( (/0.0,0.0,0.0, 0.5,0.5,0.5/), (/3,2/) )

    !!----
    !!---- LTR_R
    !!----    real(kind=cp), dimension(3,3), parameter, public :: Ltr_R
    !!----
    !!----    Lattice Traslations of type R
    !!----
    !!---- Update: February - 2005
    !!
    real(kind=cp), dimension(3,3), parameter, public :: &
                   Ltr_r =reshape( (/0.0,0.0,0.0, 2.0/3.0,1.0/3.0,1.0/3.0,  1.0/3.0,2.0/3.0,2.0/3.0/),(/3,3/) )

    !!----
    !!---- MAGMAT
    !!----    character(len=* ), dimension(72), parameter, public :: Magmat
    !!----
    !!----    Magnetic array
    !!----
    !!---- Update: February - 2005
    !!
    character(len=* ), dimension(72), parameter, public :: Magmat = (/      &
       "( Mx, My, Mz)      ","(-Mx,-My, Mz)      ","(-Mx, My,-Mz)      ",   &
       "( Mx,-My,-Mz)      ","( Mz, Mx, My)      ","( Mz,-Mx,-My)      ",   &
       "(-Mz,-Mx, My)      ","(-Mz, Mx,-My)      ","( My, Mz, Mx)      ",   &
       "(-My, Mz,-Mx)      ","( My,-Mz,-Mx)      ","(-My,-Mz, Mx)      ",   &
       "( My, Mx,-Mz)      ","(-My,-Mx,-Mz)      ","( My,-Mx, Mz)      ",   &
       "(-My, Mx, Mz)      ","( Mx, Mz,-My)      ","(-Mx, Mz, My)      ",   &
       "(-Mx,-Mz,-My)      ","( Mx,-Mz, My)      ","( Mz, My,-Mx)      ",   &
       "( Mz,-My, Mx)      ","(-Mz, My, Mx)      ","(-Mz,-My,-Mx)      ",   &
       "(-Mx,-My,-Mz)      ","( Mx, My,-Mz)      ","( Mx,-My, Mz)      ",   &
       "(-Mx, My, Mz)      ","(-Mz,-Mx,-My)      ","(-Mz, Mx, My)      ",   &
       "( Mz, Mx,-My)      ","( Mz,-Mx, My)      ","(-My,-Mz,-Mx)      ",   &
       "( My,-Mz, Mx)      ","(-My, Mz, Mx)      ","( My, Mz,-Mx)      ",   &
       "(-My,-Mx, Mz)      ","( My, Mx, Mz)      ","(-My, Mx,-Mz)      ",   &
       "( My,-Mx,-Mz)      ","(-Mx,-Mz, My)      ","( Mx,-Mz,-My)      ",   &
       "( Mx, Mz, My)      ","(-Mx, Mz,-My)      ","(-Mz,-My, Mx)      ",   &
       "(-Mz, My,-Mx)      ","( Mz,-My,-Mx)      ","( Mz, My, Mx)      ",   &
       "( Mx   ,    My, Mz)","(   -My, Mx-My, Mz)","(-Mx+My,-Mx   , Mz)",   &
       "(-Mx   ,   -My, Mz)","(    My,-Mx+My, Mz)","( Mx-My, Mx   , Mz)",   &
       "(    My, Mx   ,-Mz)","( Mx-My,   -My,-Mz)","(-Mx   ,-Mx+My,-Mz)",   &
       "(   -My,-Mx   ,-Mz)","(-Mx+My,    My,-Mz)","( Mx   , Mx-My,-Mz)",   &
       "(-Mx   ,   -My,-Mz)","(    My,-Mx+My,-Mz)","( Mx-My, Mx   ,-Mz)",   &
       "( Mx   ,    My,-Mz)","(   -My, Mx-My,-Mz)","(-Mx+My,-Mx   ,-Mz)",   &
       "(   -My,-Mx   , Mz)","(-Mx+My,    My, Mz)","( Mx   , Mx-My, Mz)",   &
       "(    My, Mx   , Mz)","( Mx-My,   -My, Mz)","(-Mx   ,-Mx+My, Mz)"   /)

    !!----
    !!---- ML_D6H
    !!----    character(len=*), dimension(24), parameter, public:: ML_D6h
    !!----
    !!----    Miller & Love Notation
    !!----
    !!---- Update: February - 2005
    !!
    character(len=*), dimension(24), parameter, public :: ML_d6h=(/               &
       " 1"," 3"," 5"," 4"," 6"," 2"," 9"," 7","11","12","10"," 8","13","15","17",&
       "16","18","14","21","19","23","24","22","20"/)

    !!----
    !!---- ML_OH
    !!----     character(len=*), dimension(48), parameter, public :: ML_Oh
    !!----
    !!----     Miller & Love Notation
    !!----
    !!---- Update: February - 2005
    !!
    character(len=*), dimension(48), parameter, public :: ML_Oh=(/                &
       " 1"," 4"," 3"," 2"," 9","10","12","11"," 5"," 7"," 6"," 8","16","13","15",&
       "14","20","18","17","19","24","23","22","21","25","28","27","26","33","34",&
       "36","35","29","31","30","32","40","37","39","38","44","42","41","43","48",&
       "47","46","45"/)

    !!----
    !!---- MOD6
    !!----    Integer,  dimension(36,3,3), parameter, public :: Mod6
    !!----
    !!----    Matrix Types For Rotational Operators In Conventional Basis
    !!----    1->24 Oh, 25->36 D6h
    !!----
    !!---- Update: February - 2005
    !!
    Integer,  dimension(36,3,3), parameter, public :: Mod6 = reshape (  (/     &
       1,-1,-1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1,-1,                   &
      -1, 1, 0, 0, 0, 0, 1, 0,-1,-1, 0, 1, 0, 1,-1, 0,-1, 1,                   &
       0, 0, 0, 0, 1,-1,-1, 1, 0, 0, 0, 0, 1,-1,-1, 1, 0, 0,                   &
       0, 0, 0, 0, 0, 0, 0, 1,-1, 0,-1, 1, 1, 0,-1,-1, 0, 1,                   &
       0, 0, 0, 0, 0, 0, 0, 0, 1,-1,-1, 1, 0, 0, 0, 0, 0, 0,                   &
       0, 0,-1, 1, 1,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,                   &
       0, 0, 0, 0, 0, 0, 0, 0, 1,-1, 1,-1, 1,-1, 1,-1, 0, 0,                   &
       0, 0, 0, 0, 0, 0, 0,-1, 1, 0, 1,-1, 1,-1, 0,-1, 1, 0,                   &
       1,-1, 1,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,                   &
       0, 0, 1,-1, 1,-1, 1,-1, 0,-1, 1, 0, 0,-1, 1, 0, 1,-1,                   &
       0, 0, 0, 0, 1,-1, 1,-1, 0, 0, 0, 0, 0, 0, 0, 0,-1, 1,                   &
      -1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,                   &
       0, 0, 0, 0, 1, 1,-1,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,                   &
       0, 0, 1, 1,-1,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,                   &
       0, 0, 0, 0, 0, 0, 0, 0, 1, 1,-1,-1, 0, 0, 0, 0, 1, 1,                   &
      -1,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,                   &
       1, 1,-1,-1, 0, 0, 0, 0, 0, 0, 0, 0,-1,-1, 1, 1, 0, 0,                   &
       0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 1,-1,-1,-1,-1,-1,-1 /), (/36,3,3/) )

    !!----
    !!---- POINT_GROUP
    !!----    character(len=*), dimension(39), parameter, public :: Point_group
    !!----
    !!----    Point Group Symbols
    !!----
    !!---- Update: July - 2014: added m3 and m3m for compatibility with Laue_class
    !!
    character(len=*), dimension(41), parameter, public :: point_group=(/  &
       "1    ","-1   ","2    ","m    ","2/m  ","222  ","mm2  ","m2m  ",   &
       "2mm  ","mmm  ","4    ","-4   ","4/m  ","422  ","4mm  ","-42m ",   &
       "-4m2 ","4/mmm","3    ","-3   ","32   ","3m   ","-3m  ","312  ",   &
       "31m  ","-31m ","6    ","-6   ","6/m  ","622  ","6mm  ","-62m ",   &
       "-6m2 ","6/mmm","23   ","m-3  ","432  ","-43m ","m-3m ","m3   ",   &
       "m3m  "/)

    !!--++
    !!--++ SPG_GEN
    !!--++    character(len=120), private, dimension(230) :: spg_gen
    !!--++
    !!--++    (PRIVATE)
    !!--++    Variable to hold the generators of all space groups in the standard setting
    !!--++
    !!--++ Update: February - 2005
    !!
    character(len=120), private, dimension(230) :: spg_gen

    !!----
    !!---- TYPE :: SPGR_INFO_TYPE
    !!--..
    !!---- Type, public :: Spgr_Info_Type
    !!----    integer                 :: N           ! Number of the Spacegroup
    !!----    character (len=12)      :: HM          ! Hermann-Mauguin
    !!----    character (len=16)      :: Hall        ! Hall
    !!----    integer                 :: Laue        ! Laue Group
    !!----    integer                 :: Pg          ! Point group
    !!----    integer, dimension(6)   :: Asu         ! Asymmetric unit * 24
    !!----    character (len= 5)      :: Inf_extra   ! Extra information
    !!---- End Type Spgr_Info_Type
    !!----
    !!----    Definition for General Info about Space Groups
    !!----
    !!---- Update: February - 2005
    !!
    Type, public :: Spgr_Info_Type
       integer                 :: N
       character (len=12)      :: HM
       character (len=16)      :: Hall
       integer                 :: Laue
       integer                 :: Pg
       integer, dimension(6)   :: Asu
       character (len= 5)      :: Inf_Extra
    End Type Spgr_Info_Type

    !!----
    !!---- SPGR_INFO
    !!----    Type(Spgr_Info_Type), allocatable, dimension(:), public :: Spgr_info
    !!----
    !!----    General Info about Space Groups
    !!----    Present dimension: 612
    !!----
    !!---- Update: February - 2005
    !!
    Type(Spgr_Info_Type), allocatable, dimension(:), public :: Spgr_Info

    !!----
    !!---- SYS_CRY
    !!----    character(len=* ), dimension(7) , parameter, public :: Sys_cry
    !!----
    !!----    System Type
    !!----
    !!---- Update: February - 2005
    !!
    character(len=* ), dimension(7) , parameter, public:: sys_cry =(/  &
       "Triclinic   ","Monoclinic  ","Orthorhombic","Tetragonal  ",    &
       "Trigonal    ","Hexagonal   ","Cubic       " /)

    !!----
    !!---- TYPE :: TABLE_EQUIV_TYPE
    !!--..
    !!---- Type, public :: Table_Equiv_Type
    !!----    character(len= 6)      :: SC     ! Schoenflies
    !!----    character(len=17)      :: ML     ! Miller & Love
    !!----    character(len=18)      :: KO     ! Kovalev
    !!----    character(len=32)      :: BC     ! Bradley & Cracknell
    !!----    character(len=18)      :: ZA     ! Zak
    !!---- End Type Table_Equiv_Type
    !!----
    !!----    Definition for Equivalences on a Table
    !!----
    !!---- Update: February - 2005
    !!
    Type, public :: Table_Equiv_Type
       character(len= 6)      :: SC                ! Schoenflies
       character(len=17)      :: ML                ! Miller & Love
       character(len=18)      :: KO                ! Kovalev
       character(len=32)      :: BC                ! Bradley & Cracknell
       character(len=18)      :: ZA                ! Zak
    End Type Table_Equiv_Type

    !!----
    !!---- SYSTEM_EQUIV
    !!----    Type(Table_Equiv_Type), allocatable, dimension(:), public :: System_Equiv
    !!----
    !!----    General Info about Space Groups
    !!----
    !!---- Update: February - 2005
    !!
    Type(Table_Equiv_Type), allocatable, dimension(:), public :: System_Equiv

    !!----
    !!---- TYPE :: WYCK_INFO_TYPE
    !!--..
    !!---- Type, public :: Wyck_Info_Type
    !!----    character (len=12)                :: HM          ! Hermann-Mauguin
    !!----    integer                           :: Norbit      ! Number of orbites
    !!----    character (len= 15),dimension(24) :: Corbit      ! Generator of the orbit
    !!---- End Type Wyck_Info_Type
    !!----
    !!----    Definition for Wyckoff Positions acording to IT
    !!----
    !!---- Update: February - 2005
    !!
    Type, public :: Wyck_Info_Type
       character (len=12)               :: HM
       integer                          :: Norbit
       character (len=15),dimension(26) :: Corbit
    End Type Wyck_Info_Type

    !!----
    !!---- WYCKOFF_INFO
    !!----    Type(Wyck_Info_Type), allocatable, dimension(:), public :: Wyckoff_info
    !!----
    !!----    General Info about Wyckoff Positions on IT
    !!----    Present dimension:
    !!----
    !!---- Update: February - 2005
    !!
    Type(Wyck_Info_Type), allocatable, dimension(:), public :: Wyckoff_Info

    !!----
    !!---- X_D6H
    !!----    character(len=* ), dimension(24), parameter, public:: X_D6h
    !!----
    !!---- Update: February - 2005
    !!
    character(len=* ), dimension(24), parameter, public   :: X_d6h = (/      &
       "( x  ,   y, z)","(  -y, x-y, z)","(-x+y,-x  , z)","(-x  ,  -y, z)",  &
       "(   y,-x+y, z)","( x-y, x  , z)","(   y, x  ,-z)","( x-y,  -y,-z)",  &
       "(-x  ,-x+y,-z)","(  -y,-x  ,-z)","(-x+y,   y,-z)","( x  , x-y,-z)",  &
       "(-x  ,  -y,-z)","(   y,-x+y,-z)","( x-y, x  ,-z)","( x  ,   y,-z)",  &
       "(  -y, x-y,-z)","(-x+y,-x  ,-z)","(  -y,-x  , z)","(-x+y,   y, z)",  &
       "( x  , x-y, z)","(   y, x  , z)","( x-y,  -y, z)","(-x  ,-x+y, z)"   /)

    !!----
    !!---- X_OH
    !!----    character(len=* ), dimension(48), parameter, public :: X_oh
    !!----
    !!---- Update: February - 2005
    !!
    character(len=* ), dimension(48), parameter, public  :: X_oh = (/                 &
       "( x, y, z)","(-x,-y, z)","(-x, y,-z)","( x,-y,-z)","( z, x, y)","( z,-x,-y)", &
       "(-z,-x, y)","(-z, x,-y)","( y, z, x)","(-y, z,-x)","( y,-z,-x)","(-y,-z, x)", &
       "( y, x,-z)","(-y,-x,-z)","( y,-x, z)","(-y, x, z)","( x, z,-y)","(-x, z, y)", &
       "(-x,-z,-y)","( x,-z, y)","( z, y,-x)","( z,-y, x)","(-z, y, x)","(-z,-y,-x)", &
       "(-x,-y,-z)","( x, y,-z)","( x,-y, z)","(-x, y, z)","(-z,-x,-y)","(-z, x, y)", &
       "( z, x,-y)","( z,-x, y)","(-y,-z,-x)","( y,-z, x)","(-y, z, x)","( y, z,-x)", &
       "(-y,-x, z)","( y, x, z)","(-y, x,-z)","( y,-x,-z)","(-x,-z, y)","( x,-z,-y)", &
       "( x, z, y)","(-x, z,-y)","(-z,-y, x)","(-z, y,-x)","( z,-y,-x)","( z, y, x)"  /)

    !!----
    !!---- ZAK_D6H
    !!----    character (len=*), dimension(24), parameter, public :: Zak_D6h
    !!----
    !!----    Zak Notation
    !!----
    !!---- Update: February - 2005
    !!
    character (len=*), dimension(24), parameter, public :: Zak_D6h =(/          &
       "   E   "," C(z)_3","C(2z)_3","  C_2  ","C(5z)_6"," C(z)_6","  U(xy)",   &
       "  U(x) ","  U(y) ","  U(3) ","  U(2) ","  U(1) ","   I   ","S(5z)_6",   &
       " S(z)_6","  s(z) "," S(z)_3","S(2z)_3"," s(xy) ","  s(x) ","  s(y) ",   &
       "  s(3) ","  s(2) ","  s(1) " /)

    !!----
    !!---- ZAK_OH
    !!----    character(len=* ), dimension(48), parameter, public :: Zak_Oh
    !!----
    !!----    Zak Notation
    !!----
    !!---- Update: February - 2005
    !!
    character(len=* ), dimension(48), parameter, public :: Zak_Oh =(/           &
       "     E     ","    U(z)   ","    U(y)   ","    U(x)   ","  C(xyz)_3 ",   &
       " C(-xy-z)_3"," C(x-y-z)_3"," C(-x-yz)_3"," C(2xyz)_3 ","C(2x-y-z)_3",   &
       " C(2x-yz)_3","C(-2xy-z)_3","    U(xy)  ","   U(-xy)  ","   C(3z)_4 ",   &
       "   C(z)_4  ","   C(3x)_4 ","    U(yz)  ","   U(y-z)  ","   C(x)_4  ",   &
       "   C(y)_4  ","    U(xz)  ","   C(3y)_4 ","   U(x-z)  ","      I    ",   &
       "    s(z)   ","    s(y)   ","    s(x)   "," S(5xyz)_6 ","S(-5xy-z)_6",   &
       "S(5x-y-z)_6","S(-5x-yz)_6","  S(xyz)_6 "," S(x-y-z)_6"," S(-x-yz)_6",   &
       " S(-xy-z)_6","    s(xy)  ","   s(-xy)  ","   S(z)_4  ","  S(3z)_4  ",   &
       "   S(x)_4  ","    s(yz)  ","   s(y-z)  ","  S(3x)_4  ","  S(3y)_4  ",   &
       "    s(xz)  ","   S(y)_4  ","   s(x-z)  " /)

 Contains

    !---------------------!
    !---- Subroutines ----!
    !---------------------!

    !!----
    !!---- Subroutine Get_Generators(Spg,Gener)
    !!----    character (len=*), intent(in)  :: spg     !  In -> Hermann_Mauguin symbol or number of S.Group
    !!----    character (len=*), intent(out) :: gener   ! Out -> String with all generators
    !!----
    !!----    Provides the string "gener" containing the list of the generators
    !!----    (as given in the IT Crystallography) corresponding to the space group
    !!----    of symbol "spg". In "spg" the Hermann-Mauguin symbol or the number of the
    !!----    space group should be given. The calling program is responsible of decoding
    !!----    the string "gener". Generator are given in the Jone's Faithful notation and
    !!----    the separator is the symbol ";". An example, corresponding to the space
    !!----    group "R 3 c" is  gener = " x+1/3,y+2/3,z+2/3; -y,x-y,z; -y,-x,z+1/2"
    !!----    The variable is the string contained between the quotes.
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Get_Generators(Spg,Gener)
       !---- Arguments ----!
       character (len=*), intent(in)  :: spg
       character (len=*), intent(out) :: gener

       !----  Local variables ----!
       logical                 :: ok
       integer                 :: i, ier, numg
       character(len=len(spg)) :: symb,sp

       err_symtab=.false.
       if (.not. it_set) call set_IT_gen()
       ok=.false.

       read(unit=spg,fmt=*,iostat=ier) numg
       if (ier == 0) then
          if (numg > 0 .and. numg <= 230) then
             gener=spg_gen(numg)(12:)
             ok=.true.
          else
             gener=spg_gen(1)(12:)
          end if
       else
          symb=u_case(spg)
          do i=1,230
             sp=u_case(spg_gen(i)(1:10))
             if (symb == sp) then
                gener=spg_gen(i)(12:)
                ok=.true.
                exit
             end if
          end do
       end if

       if (.not. ok) then
          err_symtab=.true.
          ERR_SymTab_Mess=" Error in the symbol or number of the space group"
       end if

       return
    End Subroutine Get_Generators

    !!----
    !!---- Subroutine Remove_Spgr_Info()
    !!----
    !!----    Deallocating SPGR_INFO Data
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Remove_Spgr_Info()

       if (allocated(spgr_info)) deallocate(spgr_info)

       return
    End Subroutine Remove_Spgr_Info

    !!----
    !!---- Subroutine Remove_System_Equiv()
    !!----
    !!----    Deallocating SPGR_INFO Data
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Remove_System_Equiv()

       if (allocated(System_Equiv)) deallocate(System_Equiv)

       return
    End Subroutine Remove_System_Equiv

    !!----
    !!---- Subroutine Remove_Wyckoff_Info()
    !!----
    !!----    Deallocating WYCKOFF_INFO Data
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Remove_Wyckoff_Info()

       if (allocated(wyckoff_info)) deallocate(wyckoff_info)

       return
    End Subroutine Remove_Wyckoff_Info

    !!--++
    !!--++ Subroutine Set_It_Gen()
    !!--++
    !!--++    (PRIVATE)
    !!--++    Fills the components of the Spg_Gen character variable
    !!--++    Called once by the public subroutine Get_Generators
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Set_It_Gen()

       spg_gen(  1) =  "P 1       : x,y,z "
       spg_gen(  2) =  "P -1      : -x,-y,-z "
       spg_gen(  3) =  "P 2       : -x,y,-z "
       spg_gen(  4) =  "P 21      : -x,y+1/2,-z "
       spg_gen(  5) =  "C 2       : x+1/2,y+1/2,z; -x,y,-z "
       spg_gen(  6) =  "P m       : x,-y,z "
       spg_gen(  7) =  "P c       : x,-y,z+1/2 "
       spg_gen(  8) =  "C m       : x+1/2,y+1/2,z; x,-y,z "
       spg_gen(  9) =  "C c       : x+1/2,y+1/2,z; x,-y,z+1/2 "
       spg_gen( 10) =  "P 2/m     : -x,y,-z; -x,-y,-z "
       spg_gen( 11) =  "P 21/m    : -x,y+1/2,-z; -x,-y,-z "
       spg_gen( 12) =  "C 2/m     : x+1/2,y+1/2,z; -x,y,-z; -x,-y,-z "
       spg_gen( 13) =  "P 2/c     : -x,y,-z+1/2; -x,-y,-z "
       spg_gen( 14) =  "P 21/c    : -x,y+1/2,-z+1/2; -x,-y,-z "
       spg_gen( 15) =  "C 2/c     : x+1/2,y+1/2,z; -x,y,-z+1/2; -x,-y,-z "
       spg_gen( 16) =  "P 2 2 2   : -x,-y,z; -x,y,-z "
       spg_gen( 17) =  "P 2 2 21  : -x,-y,z+1/2; -x,y,-z+1/2 "
       spg_gen( 18) =  "P 21 21 2 : -x,-y,z; -x+1/2,y+1/2,-z "
       spg_gen( 19) =  "P 21 21 21: -x+1/2,-y,z+1/2; -x,y+1/2,-z+1/2 "
       spg_gen( 20) =  "C 2 2 21  : x+1/2,y+1/2,z; -x,-y,z+1/2; -x,y,-z+1/2 "
       spg_gen( 21) =  "C 2 2 2   : x+1/2,y+1/2,z; -x,-y,z; -x,y,-z "
       spg_gen( 22) =  "F 2 2 2   : x+1/2,y+1/2,z; x+1/2,y,z+1/2; -x,-y,z; -x,y,-z "
       spg_gen( 23) =  "I 2 2 2   : x+1/2,y+1/2,z+1/2; -x,-y,z; -x,y,-z "
       spg_gen( 24) =  "I 21 21 21: x+1/2,y+1/2,z+1/2; -x+1/2,-y,z+1/2; -x,y+1/2,-z+1/2 "
       spg_gen( 25) =  "P m m 2   : -x,-y,z; x,-y,z "
       spg_gen( 26) =  "P m c 21  : -x,-y,z+1/2; x,-y,z+1/2 "
       spg_gen( 27) =  "P c c 2   : -x,-y,z; x,-y,z+1/2 "
       spg_gen( 28) =  "P m a 2   : -x,-y,z; x+1/2,-y,z "
       spg_gen( 29) =  "P c a 21  : -x,-y,z+1/2; x+1/2,-y,z "
       spg_gen( 30) =  "P n c 2   : -x,-y,z; x,-y+1/2,z+1/2 "
       spg_gen( 31) =  "P m n 21  : -x+1/2,-y,z+1/2; x+1/2,-y,z+1/2 "
       spg_gen( 32) =  "P b a 2   : -x,-y,z; x+1/2,-y+1/2,z "
       spg_gen( 33) =  "P n a 21  : -x,-y,z+1/2; x+1/2,-y+1/2,z "
       spg_gen( 34) =  "P n n 2   : -x,-y,z; x+1/2,-y+1/2,z+1/2 "
       spg_gen( 35) =  "C m m 2   : x+1/2,y+1/2,z; -x,-y,z; x,-y,z "
       spg_gen( 36) =  "C m c 21  : x+1/2,y+1/2,z; -x,-y,z+1/2; x,-y,z+1/2 "
       spg_gen( 37) =  "C c c 2   : x+1/2,y+1/2,z; -x,-y,z; x,-y,z+1/2 "
       spg_gen( 38) =  "A m m 2   : x,y+1/2,z+1/2; -x,-y,z; x,-y,z "
       spg_gen( 39) =  "A b m 2   : x,y+1/2,z+1/2; -x,-y,z; x,-y+1/2,z "
       spg_gen( 40) =  "A m a 2   : x,y+1/2,z+1/2; -x,-y,z; x+1/2,-y,z "
       spg_gen( 41) =  "A b a 2   : x,y+1/2,z+1/2; -x,-y,z; x+1/2,-y+1/2,z "
       spg_gen( 42) =  "F m m 2   : x+1/2,y+1/2,z; x+1/2,y,z+1/2; -x,-y,z; x,-y,z "
       spg_gen( 43) =  "F d d 2   : x+1/2,y+1/2,z; x+1/2,y,z+1/2; -x,-y,z; x+1/4,-y+1/4,z+1/4 "
       spg_gen( 44) =  "I m m 2   : x+1/2,y+1/2,z+1/2; -x,-y,z; x,-y,z "
       spg_gen( 45) =  "I b a 2   : x+1/2,y+1/2,z+1/2; -x,-y,z; x+1/2,-y+1/2,z "
       spg_gen( 46) =  "I m a 2   : x+1/2,y+1/2,z+1/2; -x,-y,z; x+1/2,-y,z "
       spg_gen( 47) =  "P m m m   : -x,-y,z; -x,y,-z; -x,-y,-z "
       spg_gen( 48) =  "P n n n   : -x+1/2,-y+1/2,z; -x+1/2,y,-z+1/2; -x,-y,-z "
       spg_gen( 49) =  "P c c m   : -x,-y,z; -x,y,-z+1/2; -x,-y,-z "
       spg_gen( 50) =  "P b a n   : -x+1/2,-y+1/2,z; -x+1/2,y,-z; -x,-y,-z "
       spg_gen( 51) =  "P m m a   : -x+1/2,-y,z; -x,y,-z; -x,-y,-z "
       spg_gen( 52) =  "P n n a   : -x+1/2,-y,z; -x+1/2,y+1/2,-z+1/2; -x,-y,-z "
       spg_gen( 53) =  "P m n a   : -x+1/2,-y,z+1/2; -x+1/2,y,-z+1/2; -x,-y,-z "
       spg_gen( 54) =  "P c c a   : -x+1/2,-y,z; -x,y,-z+1/2; -x,-y,-z "
       spg_gen( 55) =  "P b a m   : -x,-y,z; -x+1/2,y+1/2,-z; -x,-y,-z "
       spg_gen( 56) =  "P c c n   : -x+1/2,-y+1/2,z; -x,y+1/2,-z+1/2; -x,-y,-z "
       spg_gen( 57) =  "P b c m   : -x,-y,z+1/2; -x,y+1/2,-z+1/2; -x,-y,-z "
       spg_gen( 58) =  "P n n m   : -x,-y,z; -x+1/2,y+1/2,-z+1/2; -x,-y,-z "
       spg_gen( 59) =  "P m m n   : -x+1/2,-y+1/2,z; -x,y+1/2,-z; -x,-y,-z "
       spg_gen( 60) =  "P b c n   : -x+1/2,-y+1/2,z+1/2; -x,y,-z+1/2; -x,-y,-z "
       spg_gen( 61) =  "P b c a   : -x+1/2,-y,z+1/2; -x,y+1/2,-z+1/2; -x,-y,-z "
       spg_gen( 62) =  "P n m a   : -x+1/2,-y,z+1/2; -x,y+1/2,-z; -x,-y,-z "
       spg_gen( 63) =  "C m c m   : x+1/2,y+1/2,z; -x,-y,z+1/2; -x,y,-z+1/2; -x,-y,-z "
       spg_gen( 64) =  "C m c a   : x+1/2,y+1/2,z; -x,-y+1/2,z+1/2; -x,y+1/2,-z+1/2; -x,-y,-z "
       spg_gen( 65) =  "C m m m   : x+1/2,y+1/2,z; -x,-y,z; -x,y,-z; -x,-y,-z "
       spg_gen( 66) =  "C c c m   : x+1/2,y+1/2,z; -x,-y,z; -x,y,-z+1/2; -x,-y,-z "
       spg_gen( 67) =  "C m m a   : x+1/2,y+1/2,z; -x,-y+1/2,z; -x,y+1/2,-z; -x,-y,-z "
       spg_gen( 68) =  "C c c a   : x+1/2,y+1/2,z; -x+1/2,-y,z; -x,y,-z+1/2; -x,-y,-z "
       spg_gen( 69) =  "F m m m   : x+1/2,y+1/2,z; x+1/2,y,z+1/2; -x,-y,z; -x,y,-z; -x,-y,-z "
       spg_gen( 70) =  "F d d d   : x+1/2,y+1/2,z; x+1/2,y,z+1/2; -x+3/4,-y+3/4,z; -x+3/4,y,-z+3/4; -x,-y,-z "
       spg_gen( 71) =  "I m m m   : x+1/2,y+1/2,z+1/2; -x,-y,z; -x,y,-z; -x,-y,-z "
       spg_gen( 72) =  "I b a m   : x+1/2,y+1/2,z+1/2; -x,-y,z; -x+1/2,y+1/2,-z; -x,-y,-z "
       spg_gen( 73) =  "I b c a   : x+1/2,y+1/2,z+1/2; -x+1/2,-y,z+1/2; -x,y+1/2,-z+1/2; -x,-y,-z "
       spg_gen( 74) =  "I m m a   : x+1/2,y+1/2,z+1/2; -x,-y+1/2,z; -x,y+1/2,-z; -x,-y,-z "
       spg_gen( 75) =  "P 4       : -x,-y,z; -y,x,z "
       spg_gen( 76) =  "P 41      : -x,-y,z+1/2; -y,x,z+1/4 "
       spg_gen( 77) =  "P 42      : -x,-y,z; -y,x,z+1/2 "
       spg_gen( 78) =  "P 43      : -x,-y,z+1/2; -y,x,z+3/4 "
       spg_gen( 79) =  "I 4       : x+1/2,y+1/2,z+1/2; -x,-y,z; -y,x,z "
       spg_gen( 80) =  "I 41      : x+1/2,y+1/2,z+1/2; -x+1/2,-y+1/2,z+1/2; -y,x+1/2,z+1/4 "
       spg_gen( 81) =  "P -4      : -x,-y,z; y,-x,-z "
       spg_gen( 82) =  "I -4      : x+1/2,y+1/2,z+1/2; -x,-y,z; y,-x,-z "
       spg_gen( 83) =  "P 4/m     : -x,-y,z; -y,x,z; -x,-y,-z "
       spg_gen( 84) =  "P 42/m    : -x,-y,z; -y,x,z+1/2; -x,-y,-z "
       spg_gen( 85) =  "P 4/n     : -x+1/2,-y+1/2,z; -y+1/2,x,z; -x,-y,-z "
       spg_gen( 86) =  "P 42/n    : -x+1/2,-y+1/2,z; -y,x+1/2,z+1/2; -x,-y,-z "
       spg_gen( 87) =  "I 4/m     : x+1/2,y+1/2,z+1/2; -x,-y,z; -y,x,z; -x,-y,-z "
       spg_gen( 88) =  "I 41/a    : x+1/2,y+1/2,z+1/2; -x+1/2,-y,z+1/2; -y+3/4,x+1/4,z+1/4; -x,-y,-z "
       spg_gen( 89) =  "P 4 2 2   : -x,-y,z; -y,x,z; -x,y,-z "
       spg_gen( 90) =  "P 4 21 2  : -x,-y,z; -y+1/2,x+1/2,z; -x+1/2,y+1/2,-z "
       spg_gen( 91) =  "P 41 2 2  : -x,-y,z+1/2; -y,x,z+1/4; -x,y,-z "
       spg_gen( 92) =  "P 41 21 2 : -x,-y,z+1/2; -y+1/2,x+1/2,z+1/4; -x+1/2,y+1/2,-z+1/4 "
       spg_gen( 93) =  "P 42 2 2  : -x,-y,z; -y,x,z+1/2; -x,y,-z "
       spg_gen( 94) =  "P 42 21 2 : -x,-y,z; -y+1/2,x+1/2,z+1/2; -x+1/2,y+1/2,-z+1/2 "
       spg_gen( 95) =  "P 43 2 2  : -x,-y,z+1/2; -y,x,z+3/4; -x,y,-z "
       spg_gen( 96) =  "P 43 21 2 : -x,-y,z+1/2; -y+1/2,x+1/2,z+3/4; -x+1/2,y+1/2,-z+3/4 "
       spg_gen( 97) =  "I 4 2 2   : x+1/2,y+1/2,z+1/2; -x,-y,z; -y,x,z; -x,y,-z "
       spg_gen( 98) =  "I 41 2 2  : x+1/2,y+1/2,z+1/2; -x+1/2,-y+1/2,z+1/2; -y,x+1/2,z+1/4; -x+1/2,y,-z+3/4 "
       spg_gen( 99) =  "P 4 m m   : -x,-y,z; -y,x,z; x,-y,z "
       spg_gen(100) =  "P 4 b m   : -x,-y,z; -y,x,z; x+1/2,-y+1/2,z "
       spg_gen(101) =  "P 42 c m  : -x,-y,z; -y,x,z+1/2; x,-y,z+1/2 "
       spg_gen(102) =  "P 42 n m  : -x,-y,z; -y+1/2,x+1/2,z+1/2; x+1/2,-y+1/2,z+1/2 "
       spg_gen(103) =  "P 4 c c   : -x,-y,z; -y,x,z; x,-y,z+1/2 "
       spg_gen(104) =  "P 4 n c   : -x,-y,z; -y,x,z; x+1/2,-y+1/2,z+1/2 "
       spg_gen(105) =  "P 42 m c  : -x,-y,z; -y,x,z+1/2; x,-y,z "
       spg_gen(106) =  "P 42 b c  : -x,-y,z; -y,x,z+1/2; x+1/2,-y+1/2,z "
       spg_gen(107) =  "I 4 m m   : x+1/2,y+1/2,z+1/2; -x,-y,z; -y,x,z; x,-y,z "
       spg_gen(108) =  "I 4 c m   : x+1/2,y+1/2,z+1/2; -x,-y,z; -y,x,z; x,-y,z+1/2 "
       spg_gen(109) =  "I 41 m d  : x+1/2,y+1/2,z+1/2; -x+1/2,-y+1/2,z+1/2; -y,x+1/2,z+1/4; x,-y,z "
       spg_gen(110) =  "I 41 c d  : x+1/2,y+1/2,z+1/2; -x+1/2,-y+1/2,z+1/2; -y,x+1/2,z+1/4; x,-y,z+1/2 "
       spg_gen(111) =  "P -4 2 m  : -x,-y,z; y,-x,-z; -x,y,-z "
       spg_gen(112) =  "P -4 2 c  : -x,-y,z; y,-x,-z; -x,y,-z+1/2 "
       spg_gen(113) =  "P -4 21 m : -x,-y,z; y,-x,-z; -x+1/2,y+1/2,-z "
       spg_gen(114) =  "P -4 21 c : -x,-y,z; y,-x,-z; -x+1/2,y+1/2,-z+1/2 "
       spg_gen(115) =  "P -4 m 2  : -x,-y,z; y,-x,-z; x,-y,z "
       spg_gen(116) =  "P -4 c 2  : -x,-y,z; y,-x,-z; x,-y,z+1/2 "
       spg_gen(117) =  "P -4 b 2  : -x,-y,z; y,-x,-z; x+1/2,-y+1/2,z "
       spg_gen(118) =  "P -4 n 2  : -x,-y,z; y,-x,-z; x+1/2,-y+1/2,z+1/2 "
       spg_gen(119) =  "I -4 m 2  : x+1/2,y+1/2,z+1/2; -x,-y,z; y,-x,-z; x,-y,z "
       spg_gen(120) =  "I -4 c 2  : x+1/2,y+1/2,z+1/2; -x,-y,z; y,-x,-z; x,-y,z+1/2 "
       spg_gen(121) =  "I -4 2 m  : x+1/2,y+1/2,z+1/2; -x,-y,z; y,-x,-z; -x,y,-z "
       spg_gen(122) =  "I -4 2 d  : x+1/2,y+1/2,z+1/2; -x,-y,z; y,-x,-z; -x+1/2,y,-z+3/4 "
       spg_gen(123) =  "P 4/m m m : -x,-y,z; -y,x,z; -x,y,-z; -x,-y,-z "
       spg_gen(124) =  "P 4/m c c : -x,-y,z; -y,x,z; -x,y,-z+1/2; -x,-y,-z "
       spg_gen(125) =  "P 4/n b m : -x+1/2,-y+1/2,z; -y+1/2,x,z; -x+1/2,y,-z; -x,-y,-z "
       spg_gen(126) =  "P 4/n n c : -x+1/2,-y+1/2,z; -y+1/2,x,z; -x+1/2,y,-z+1/2; -x,-y,-z "
       spg_gen(127) =  "P 4/m b m : -x,-y,z; -y,x,z; -x+1/2,y+1/2,-z; -x,-y,-z "
       spg_gen(128) =  "P 4/m n c : -x,-y,z; -y,x,z; -x+1/2,y+1/2,-z+1/2; -x,-y,-z "
       spg_gen(129) =  "P 4/n m m : -x+1/2,-y+1/2,z; -y+1/2,x,z; -x,y+1/2,-z; -x,-y,-z "
       spg_gen(130) =  "P 4/n c c : -x+1/2,-y+1/2,z; -y+1/2,x,z; -x,y+1/2,-z+1/2; -x,-y,-z "
       spg_gen(131) =  "P 42/m m c: -x,-y,z; -y,x,z+1/2; -x,y,-z; -x,-y,-z "
       spg_gen(132) =  "P 42/m c m: -x,-y,z; -y,x,z+1/2; -x,y,-z+1/2; -x,-y,-z "
       spg_gen(133) =  "P 42/n b c: -x+1/2,-y+1/2,z; -y+1/2,x,z+1/2; -x+1/2,y,-z; -x,-y,-z "
       spg_gen(134) =  "P 42/n n m: -x+1/2,-y+1/2,z; -y+1/2,x,z+1/2; -x+1/2,y,-z+1/2; -x,-y,-z "
       spg_gen(135) =  "P 42/m b c: -x,-y,z; -y,x,z+1/2; -x+1/2,y+1/2,-z; -x,-y,-z "
       spg_gen(136) =  "P 42/m n m: -x,-y,z; -y+1/2,x+1/2,z+1/2; -x+1/2,y+1/2,-z+1/2; -x,-y,-z "
       spg_gen(137) =  "P 42/n m c: -x+1/2,-y+1/2,z; -y+1/2,x,z+1/2; -x,y+1/2,-z; -x,-y,-z "
       spg_gen(138) =  "P 42/n c m: -x+1/2,-y+1/2,z; -y+1/2,x,z+1/2; -x,y+1/2,-z+1/2; -x,-y,-z "
       spg_gen(139) =  "I 4/m m m : x+1/2,y+1/2,z+1/2; -x,-y,z; -y,x,z; -x,y,-z; -x,-y,-z "
       spg_gen(140) =  "I 4/m c m : x+1/2,y+1/2,z+1/2; -x,-y,z; -y,x,z; -x,y,-z+1/2; -x,-y,-z "
       spg_gen(141) =  "I 41/a m d: x+1/2,y+1/2,z+1/2; -x+1/2,-y,z+1/2; -y+1/4,x+3/4,z+1/4; -x+1/2,y,-z+1/2; -x,-y,-z "
       spg_gen(142) =  "I 41/a c d: x+1/2,y+1/2,z+1/2; -x+1/2,-y,z+1/2; -y+1/4,x+3/4,z+1/4; -x+1/2,y,-z; -x,-y,-z "
       spg_gen(143) =  "P 3       : -y,x-y,z "
       spg_gen(144) =  "P 31      : -y,x-y,z+1/3 "
       spg_gen(145) =  "P 32      : -y,x-y,z+2/3 "
       spg_gen(146) =  "R 3       : x+1/3,y+2/3,z+2/3; -y,x-y,z "
       spg_gen(147) =  "P -3      : -y,x-y,z; -x,-y,-z "
       spg_gen(148) =  "R -3      : x+1/3,y+2/3,z+2/3; -y,x-y,z; -x,-y,-z "
       spg_gen(149) =  "P 3 1 2   : -y,x-y,z; -y,-x,-z "
       spg_gen(150) =  "P 3 2 1   : -y,x-y,z; y,x,-z "
       spg_gen(151) =  "P 31 1 2  : -y,x-y,z+1/3; -y,-x,-z+2/3 "
       spg_gen(152) =  "P 31 2 1  : -y,x-y,z+1/3; y,x,-z "
       spg_gen(153) =  "P 32 1 2  : -y,x-y,z+2/3; -y,-x,-z+1/3 "
       spg_gen(154) =  "P 32 2 1  : -y,x-y,z+2/3; y,x,-z "
       spg_gen(155) =  "R 3 2     : x+1/3,y+2/3,z+2/3; -y,x-y,z; y,x,-z "
       spg_gen(156) =  "P 3 m 1   : -y,x-y,z; -y,-x,z "
       spg_gen(157) =  "P 3 1 m   : -y,x-y,z; y,x,z "
       spg_gen(158) =  "P 3 c 1   : -y,x-y,z; -y,-x,z+1/2 "
       spg_gen(159) =  "P 3 1 c   : -y,x-y,z; y,x,z+1/2 "
       spg_gen(160) =  "R 3 m     : x+1/3,y+2/3,z+2/3; -y,x-y,z; -y,-x,z "
       spg_gen(161) =  "R 3 c     : x+1/3,y+2/3,z+2/3; -y,x-y,z; -y,-x,z+1/2 "
       spg_gen(162) =  "P -3 1 m  : -y,x-y,z; -y,-x,-z; -x,-y,-z "
       spg_gen(163) =  "P -3 1 c  : -y,x-y,z; -y,-x,-z+1/2; -x,-y,-z "
       spg_gen(164) =  "P -3 m 1  : -y,x-y,z; y,x,-z; -x,-y,-z "
       spg_gen(165) =  "P -3 c 1  : -y,x-y,z; y,x,-z+1/2; -x,-y,-z "
       spg_gen(166) =  "R -3 m    : x+1/3,y+2/3,z+2/3; -y,x-y,z; y,x,-z; -x,-y,-z "
       spg_gen(167) =  "R -3 c    : x+1/3,y+2/3,z+2/3; -y,x-y,z; y,x,-z+1/2; -x,-y,-z "
       spg_gen(168) =  "P 6       : -y,x-y,z; -x,-y,z "
       spg_gen(169) =  "P 61      : -y,x-y,z+1/3; -x,-y,z+1/2 "
       spg_gen(170) =  "P 65      : -y,x-y,z+2/3; -x,-y,z+1/2 "
       spg_gen(171) =  "P 62      : -y,x-y,z+2/3; -x,-y,z "
       spg_gen(172) =  "P 64      : -y,x-y,z+1/3; -x,-y,z "
       spg_gen(173) =  "P 63      : -y,x-y,z; -x,-y,z+1/2 "
       spg_gen(174) =  "P -6      : -y,x-y,z; x,y,-z "
       spg_gen(175) =  "P 6/m     : -y,x-y,z; -x,-y,z; -x,-y,-z "
       spg_gen(176) =  "P 63/m    : -y,x-y,z; -x,-y,z+1/2; -x,-y,-z "
       spg_gen(177) =  "P 6 2 2   : -y,x-y,z; -x,-y,z; y,x,-z "
       spg_gen(178) =  "P 61 2 2  : -y,x-y,z+1/3; -x,-y,z+1/2; y,x,-z+1/3 "
       spg_gen(179) =  "P 65 2 2  : -y,x-y,z+2/3; -x,-y,z+1/2; y,x,-z+2/3 "
       spg_gen(180) =  "P 62 2 2  : -y,x-y,z+2/3; -x,-y,z; y,x,-z+2/3 "
       spg_gen(181) =  "P 64 2 2  : -y,x-y,z+1/3; -x,-y,z; y,x,-z+1/3 "
       spg_gen(182) =  "P 63 2 2  : -y,x-y,z; -x,-y,z+1/2; y,x,-z "
       spg_gen(183) =  "P 6 m m   : -y,x-y,z; -x,-y,z; -y,-x,z "
       spg_gen(184) =  "P 6 c c   : -y,x-y,z; -x,-y,z; -y,-x,z+1/2 "
       spg_gen(185) =  "P 63 c m  : -y,x-y,z; -x,-y,z+1/2; -y,-x,z+1/2 "
       spg_gen(186) =  "P 63 m c  : -y,x-y,z; -x,-y,z+1/2; -y,-x,z "
       spg_gen(187) =  "P -6 m 2  : -y,x-y,z; x,y,-z; -y,-x,z "
       spg_gen(188) =  "P -6 c 2  : -y,x-y,z; x,y,-z+1/2; -y,-x,z+1/2 "
       spg_gen(189) =  "P -6 2 m  : -y,x-y,z; x,y,-z; y,x,-z "
       spg_gen(190) =  "P -6 2 c  : -y,x-y,z; x,y,-z+1/2; y,x,-z "
       spg_gen(191) =  "P 6/m m m : -y,x-y,z; -x,-y,z; y,x,-z; -x,-y,-z "
       spg_gen(192) =  "P 6/m c c : -y,x-y,z; -x,-y,z; y,x,-z+1/2; -x,-y,-z "
       spg_gen(193) =  "P 63/m c m: -y,x-y,z; -x,-y,z+1/2; y,x,-z+1/2; -x,-y,-z "
       spg_gen(194) =  "P 63/m m c: -y,x-y,z; -x,-y,z+1/2; y,x,-z; -x,-y,-z "
       spg_gen(195) =  "P 2 3     : -x,-y,z; -x,y,-z; z,x,y "
       spg_gen(196) =  "F 2 3     : x+1/2,y+1/2,z; x+1/2,y,z+1/2; -x,-y,z; -x,y,-z; z,x,y "
       spg_gen(197) =  "I 2 3     : x+1/2,y+1/2,z+1/2; -x,-y,z; -x,y,-z; z,x,y "
       spg_gen(198) =  "P 21 3    : -x+1/2,-y,z+1/2; -x,y+1/2,-z+1/2; z,x,y "
       spg_gen(199) =  "I 21 3    : x+1/2,y+1/2,z+1/2; -x+1/2,-y,z+1/2; -x,y+1/2,-z+1/2; z,x,y "
       spg_gen(200) =  "P m -3    : -x,-y,z; -x,y,-z; z,x,y; -x,-y,-z "
       spg_gen(201) =  "P n -3    : -x+1/2,-y+1/2,z; -x+1/2,y,-z+1/2; z,x,y; -x,-y,-z "
       spg_gen(202) =  "F m -3    : x+1/2,y+1/2,z; x+1/2,y,z+1/2; -x,-y,z; -x,y,-z; z,x,y; -x,-y,-z "
       spg_gen(203) =  "F d -3    : x+1/2,y+1/2,z; x+1/2,y,z+1/2; -x+1/4,-y+1/4,z; -x+1/4,y,-z+1/4; z,x,y; -x,-y,-z "
       spg_gen(204) =  "I m -3    : x+1/2,y+1/2,z+1/2; -x,-y,z; -x,y,-z; z,x,y; -x,-y,-z "
       spg_gen(205) =  "P a -3    : -x+1/2,-y,z+1/2; -x,y+1/2,-z+1/2; z,x,y; -x,-y,-z "
       spg_gen(206) =  "I a -3    : x+1/2,y+1/2,z+1/2; -x+1/2,-y,z+1/2; -x,y+1/2,-z+1/2; z,x,y; -x,-y,-z "
       spg_gen(207) =  "P 4 3 2   : -x,-y,z; -x,y,-z; z,x,y; y,x,-z "
       spg_gen(208) =  "P 42 3 2  : -x,-y,z; -x,y,-z; z,x,y; y+1/2,x+1/2,-z+1/2 "
       spg_gen(209) =  "F 4 3 2   : x+1/2,y+1/2,z; x+1/2,y,z+1/2; -x,-y,z; -x,y,-z; z,x,y; y,x,-z "
       spg_gen(210) =  "F 41 3 2  : x+1/2,y+1/2,z; x+1/2,y,z+1/2; -x,-y+1/2,z+1/2; -x+1/2,y+1/2,-z; z,x,y; y+3/4,x+1/4,-z+3/4 "
       spg_gen(211) =  "I 4 3 2   : x+1/2,y+1/2,z+1/2; -x,-y,z; -x,y,-z; z,x,y; y,x,-z "
       spg_gen(212) =  "P 43 3 2  : -x+1/2,-y,z+1/2; -x,y+1/2,-z+1/2; z,x,y; y+1/4,x+3/4,-z+3/4 "
       spg_gen(213) =  "P 41 3 2  : -x+1/2,-y,z+1/2; -x,y+1/2,-z+1/2; z,x,y; y+3/4,x+1/4,-z+1/4 "
       spg_gen(214) =  "I 41 3 2  : x+1/2,y+1/2,z+1/2; -x+1/2,-y,z+1/2; -x,y+1/2,-z+1/2; z,x,y; y+3/4,x+1/4,-z+1/4 "
       spg_gen(215) =  "P -4 3 m  : -x,-y,z; -x,y,-z; z,x,y; y,x,z "
       spg_gen(216) =  "F -4 3 m  : x+1/2,y+1/2,z; x+1/2,y,z+1/2; -x,-y,z; -x,y,-z; z,x,y; y,x,z "
       spg_gen(217) =  "I -4 3 m  : x+1/2,y+1/2,z+1/2; -x,-y,z; -x,y,-z; z,x,y; y,x,z "
       spg_gen(218) =  "P -4 3 n  : -x,-y,z; -x,y,-z; z,x,y; y+1/2,x+1/2,z+1/2 "
       spg_gen(219) =  "F -4 3 c  : x+1/2,y+1/2,z; x+1/2,y,z+1/2; -x,-y,z; -x,y,-z; z,x,y; y+1/2,x+1/2,z+1/2 "
       spg_gen(220) =  "I -4 3 d  : x+1/2,y+1/2,z+1/2; -x+1/2,-y,z+1/2; -x,y+1/2,-z+1/2; z,x,y; y+1/4,x+1/4,z+1/4 "
       spg_gen(221) =  "P m -3 m  : -x,-y,z; -x,y,-z; z,x,y; y,x,-z; -x,-y,-z "
       spg_gen(222) =  "P n -3 n  : -x+1/2,-y+1/2,z; -x+1/2,y,-z+1/2; z,x,y; y,x,-z+1/2; -x,-y,-z "
       spg_gen(223) =  "P m -3 n  : -x,-y,z; -x,y,-z; z,x,y; y+1/2,x+1/2,-z+1/2; -x,-y,-z "
       spg_gen(224) =  "P n -3 m  : -x+1/2,-y+1/2,z; -x+1/2,y,-z+1/2; z,x,y; y+1/2,x+1/2,-z; -x,-y,-z "
       spg_gen(225) =  "F m -3 m  : x+1/2,y+1/2,z; x+1/2,y,z+1/2; -x,-y,z; -x,y,-z; z,x,y; y,x,-z; -x,-y,-z "
       spg_gen(226) =  "F m -3 c  : x+1/2,y+1/2,z; x+1/2,y,z+1/2; -x,-y,z; -x,y,-z; z,x,y; y+1/2,x+1/2,-z+1/2; -x,-y,-z "

       spg_gen(227) =  &
       "F d -3 m  : x+1/2,y+1/2,z; x+1/2,y,z+1/2;-x+3/4,-y+1/4,z+1/2;-x+1/4,y+1/2,-z+3/4;z,x,y;y+3/4,x+1/4,-z+1/2;-x,-y,-z"

       spg_gen(228) =  &
       "F d -3 c  : x+1/2,y+1/2,z; x+1/2,y,z+1/2;-x+1/4,-y+3/4,z+1/2;-x+3/4,y+1/2,-z+1/4;z,x,y;y+3/4,x+1/4,-z;-x,-y,-z"

       spg_gen(229) =  "I m -3 m  : x+1/2,y+1/2,z+1/2; -x,-y,z; -x,y,-z; z,x,y; y,x,-z; -x,-y,-z "
       spg_gen(230) =  "I a -3 d  : x+1/2,y+1/2,z+1/2; -x+1/2,-y,z+1/2; -x,y+1/2,-z+1/2; z,x,y; y+3/4,x+1/4,-z+1/4; -x,-y,-z "

       return
    End Subroutine Set_It_Gen


    !!----
    !!---- Subroutine Set_Spgr_Info()
    !!----    Number of the Space Group
    !!----    Hermann-Mauguin Symbol
    !!----    Hall symbol
    !!----    Laue Group                                                                                                 ----
    !!----    Point Group
    !!----    Asymmetric unit in direct space.
    !!----    Miscellaneous Information depending on crystal system:
    !!----        Monoclinic         b           c           a
    !!----                        abc  c-ba   abc  ba-c   abc -acb
    !!----                        ---------   ---------   --------
    !!----        cell choice 1    b1   -b1    c1   -c1    a1  -a1
    !!----        cell choice 2    b2   -b2    c2   -c2    a2  -a2
    !!----        cell choice 3    b3   -b3    c3   -c3    a3  -a3
    !!----        Orthorhombic     ba-c   change of basis abc -> ba-c
    !!----                         1      origin choice 1
    !!----                         2ba-c  origin choice 2, change basis
    !!----                                abc -> ba-c
    !!----        Tetragonal       1      origin choice 1
    !!----        Cubic            2      origin choice 2
    !!----        Trigonal         H      hexagonal axes
    !!----                         R      rhombohedral axes
    !!----
    !!----    Set Information on Spgr_info array
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Set_Spgr_Info()

       if (.not. allocated(spgr_info) ) allocate(spgr_info(612) )

       !---- Triclinic ----!
       spgr_info(1:14)= (/                                           &
            spgr_info_type(  1,"P 1         ","P 1             ", 1, 1, (/ 0, 0, 0, 24, 24, 24/),"     ") , &
            spgr_info_type(  1,"A 1         ","A 1             ", 1, 1, (/ 0, 0, 0, 24, 24, 24/),"     ") , &
            spgr_info_type(  1,"B 1         ","B 1             ", 1, 1, (/ 0, 0, 0, 24, 24, 24/),"     ") , &
            spgr_info_type(  1,"C 1         ","C 1             ", 1, 1, (/ 0, 0, 0, 24, 24, 24/),"     ") , &
            spgr_info_type(  1,"I 1         ","I 1             ", 1, 1, (/ 0, 0, 0, 24, 24, 24/),"     ") , &
            spgr_info_type(  1,"R 1         ","R 1             ", 1, 1, (/ 0, 0, 0, 24, 24, 24/),"     ") , &
            spgr_info_type(  1,"F 1         ","F 1             ", 1, 1, (/ 0, 0, 0, 24, 24, 24/),"     ") , &
            spgr_info_type(  2,"P -1        ","-P 1            ", 1, 2, (/ 0, 0, 0, 12, 24, 24/),"     ") , &
            spgr_info_type(  2,"A -1        ","-A 1            ", 1, 2, (/ 0, 0, 0, 12, 24, 24/),"     ") , &
            spgr_info_type(  2,"B -1        ","-B 1            ", 1, 2, (/ 0, 0, 0, 12, 24, 24/),"     ") , &
            spgr_info_type(  2,"C -1        ","-C 1            ", 1, 2, (/ 0, 0, 0, 12, 24, 24/),"     ") , &
            spgr_info_type(  2,"I -1        ","-I 1            ", 1, 2, (/ 0, 0, 0, 12, 24, 24/),"     ") , &
            spgr_info_type(  2,"R -1        ","-R 1            ", 1, 2, (/ 0, 0, 0, 12, 24, 24/),"     ") , &
            spgr_info_type(  2,"F -1        ","-F 1            ", 1, 2, (/ 0, 0, 0, 12, 24, 24/),"     ") /)

       !---- Monoclinic ----!
       spgr_info(15:44)= (/                                           &
            spgr_info_type(  3,"P 1 2 1     ","P 2y            ", 2, 3, (/ 0, 0, 0, 24, 24, 12/),"b    ") , &
            spgr_info_type(  3,"P 2         ","P 2y            ", 2, 3, (/ 0, 0, 0, 24, 24, 12/),"b    ") , &
            spgr_info_type(  3,"P 1 1 2     ","P 2             ", 2, 3, (/ 0, 0, 0, 12, 24, 24/),"c    ") , &
            spgr_info_type(  3,"P 2 1 1     ","P 2x            ", 2, 3, (/ 0, 0, 0, 24, 12, 24/),"a    ") , &
            spgr_info_type(  4,"P 1 21 1    ","P 2yb           ", 2, 3, (/ 0, 0, 0, 24, 24, 12/),"b    ") , &
            spgr_info_type(  4,"P 21        ","P 2yb           ", 2, 3, (/ 0, 0, 0, 24, 24, 12/),"b    ") , &
            spgr_info_type(  4,"P 1 1 21    ","P 2c            ", 2, 3, (/ 0, 0, 0, 12, 24, 24/),"c    ") , &
            spgr_info_type(  4,"P 21 1 1    ","P 2xa           ", 2, 3, (/ 0, 0, 0, 24, 12, 24/),"a    ") , &
            spgr_info_type(  5,"C 1 2 1     ","C 2y            ", 2, 3, (/ 0, 0, 0, 12, 12, 24/),"b1   ") , &
            spgr_info_type(  5,"C 2         ","C 2y            ", 2, 3, (/ 0, 0, 0, 12, 12, 24/),"b1   ") , &
            spgr_info_type(  5,"A 1 2 1     ","A 2y            ", 2, 3, (/ 0, 0, 0, 12, 12, 24/),"b2   ") , &
            spgr_info_type(  5,"A 2         ","A 2y            ", 2, 3, (/ 0, 0, 0, 12, 12, 24/),"b2   ") , &
            spgr_info_type(  5,"I 1 2 1     ","I 2y            ", 2, 3, (/ 0, 0, 0, 12, 12, 24/),"b2   ") , &
            spgr_info_type(  5,"I 2         ","I 2y            ", 2, 3, (/ 0, 0, 0, 12, 12, 24/),"b2   ") , &
            spgr_info_type(  5,"A 1 1 2     ","A 2             ", 2, 3, (/ 0, 0, 0, 24, 12, 12/),"c1   ") , &
            spgr_info_type(  5,"B 1 1 2     ","B 2             ", 2, 3, (/ 0, 0, 0, 24, 12, 12/),"c2   ") , &
            spgr_info_type(  5,"I 1 1 2     ","I 2             ", 2, 3, (/ 0, 0, 0, 24, 12, 12/),"c3   ") , &
            spgr_info_type(  5,"B 2 1 1     ","B 2x            ", 2, 3, (/ 0, 0, 0, 12, 24, 12/),"a1   ") , &
            spgr_info_type(  5,"C 2 1 1     ","C 2x            ", 2, 3, (/ 0, 0, 0, 12, 24, 12/),"a2   ") , &
            spgr_info_type(  5,"I 2 1 1     ","I 2x            ", 2, 3, (/ 0, 0, 0, 12, 24, 12/),"a3   ") , &
            spgr_info_type(  6,"P 1 M 1     ","P -2y           ", 2, 4, (/ 0, 0, 0, 24, 12, 24/),"b    ") , &
            spgr_info_type(  6,"P M         ","P -2y           ", 2, 4, (/ 0, 0, 0, 24, 12, 24/),"b    ") , &
            spgr_info_type(  6,"P 1 1 M     ","P -2            ", 2, 4, (/ 0, 0, 0, 24, 24, 12/),"c    ") , &
            spgr_info_type(  6,"P M 1 1     ","P -2x           ", 2, 4, (/ 0, 0, 0, 12, 24, 24/),"a    ") , &
            spgr_info_type(  7,"P 1 C 1     ","P -2yc          ", 2, 4, (/ 0, 0, 0, 24, 12, 24/),"b1   ") , &
            spgr_info_type(  7,"P C         ","P -2yc          ", 2, 4, (/ 0, 0, 0, 24, 12, 24/),"b1   ") , &
            spgr_info_type(  7,"P 1 N 1     ","P -2yac         ", 2, 4, (/ 0, 0, 0, 24, 12, 24/),"b2   ") , &
            spgr_info_type(  7,"P N         ","P -2yac         ", 2, 4, (/ 0, 0, 0, 24, 12, 24/),"b2   ") , &
            spgr_info_type(  7,"P 1 A 1     ","P -2ya          ", 2, 4, (/ 0, 0, 0, 24, 12, 24/),"b3   ") , &
            spgr_info_type(  7,"P A         ","P -2ya          ", 2, 4, (/ 0, 0, 0, 24, 12, 24/),"b3   ") /)

       spgr_info(45:74)= (/                                           &
            spgr_info_type(  7,"P 1 1 A     ","P -2a           ", 2, 4, (/ 0, 0, 0, 24, 24, 12/),"c1   ") , &
            spgr_info_type(  7,"P 1 1 N     ","P -2ab          ", 2, 4, (/ 0, 0, 0, 24, 24, 12/),"c2   ") , &
            spgr_info_type(  7,"P 1 1 B     ","P -2b           ", 2, 4, (/ 0, 0, 0, 24, 24, 12/),"c3   ") , &
            spgr_info_type(  7,"P B 1 1     ","P -2xb          ", 2, 4, (/ 0, 0, 0, 12, 24, 24/),"a1   ") , &
            spgr_info_type(  7,"P N 1 1     ","P -2xbc         ", 2, 4, (/ 0, 0, 0, 12, 24, 24/),"a2   ") , &
            spgr_info_type(  7,"P C 1 1     ","P -2xc          ", 2, 4, (/ 0, 0, 0, 12, 24, 24/),"a3   ") , &
            spgr_info_type(  8,"C 1 M 1     ","C -2y           ", 2, 4, (/ 0, 0, 0, 24,  6, 24/),"b1   ") , &
            spgr_info_type(  8,"C M         ","C -2y           ", 2, 4, (/ 0, 0, 0, 24,  6, 24/),"b1   ") , &
            spgr_info_type(  8,"A 1 M 1     ","A -2y           ", 2, 4, (/ 0, 0, 0, 24,  6, 24/),"b2   ") , &
            spgr_info_type(  8,"A M         ","A -2y           ", 2, 4, (/ 0, 0, 0, 24,  6, 24/),"b2   ") , &
            spgr_info_type(  8,"I 1 M 1     ","I -2y           ", 2, 4, (/ 0, 0, 0, 24,  6, 24/),"b3   ") , &
            spgr_info_type(  8,"I M         ","I -2y           ", 2, 4, (/ 0, 0, 0, 24,  6, 24/),"b3   ") , &
            spgr_info_type(  8,"A 1 1 M     ","A -2            ", 2, 4, (/ 0, 0, 0, 24, 24,  6/),"c1   ") , &
            spgr_info_type(  8,"B 1 1 M     ","B -2            ", 2, 4, (/ 0, 0, 0, 24, 24,  6/),"c2   ") , &
            spgr_info_type(  8,"I 1 1 M     ","I -2            ", 2, 4, (/ 0, 0, 0, 24, 24,  6/),"c3   ") , &
            spgr_info_type(  8,"B M 1 1     ","B -2x           ", 2, 4, (/ 0, 0, 0,  6, 24, 24/),"a1   ") , &
            spgr_info_type(  8,"C M 1 1     ","C -2x           ", 2, 4, (/ 0, 0, 0,  6, 24, 24/),"a2   ") , &
            spgr_info_type(  8,"I M 1 1     ","I -2x           ", 2, 4, (/ 0, 0, 0,  6, 24, 24/),"a3   ") , &
            spgr_info_type(  9,"C 1 C 1     ","C -2yc          ", 2, 4, (/ 0, 0, 0, 24,  6, 24/),"b1   ") , &
            spgr_info_type(  9,"C C         ","C -2yc          ", 2, 4, (/ 0, 0, 0, 24,  6, 24/),"b1   ") , &
            spgr_info_type(  9,"A 1 N 1     ","A -2yac         ", 2, 4, (/ 0, 0, 0, 24,  6, 24/),"b2   ") , &
            spgr_info_type(  9,"A N         ","A -2yac         ", 2, 4, (/ 0, 0, 0, 24,  6, 24/),"b2   ") , &
            spgr_info_type(  9,"I 1 A 1     ","I -2ya          ", 2, 4, (/ 0, 0, 0, 24,  6, 24/),"b3   ") , &
            spgr_info_type(  9,"I A         ","I -2ya          ", 2, 4, (/ 0, 0, 0, 24,  6, 24/),"b3   ") , &
            spgr_info_type(  9,"A 1 A 1     ","A -2ya          ", 2, 4, (/ 0, 0, 0, 24,  6, 24/),"-b1  ") , &
            spgr_info_type(  9,"A A         ","A -2ya          ", 2, 4, (/ 0, 0, 0, 24,  6, 24/),"-b1  ") , &
            spgr_info_type(  9,"C 1 N 1     ","C -2ybc         ", 2, 4, (/ 0, 0, 0, 24,  6, 24/),"-b2  ") , &
            spgr_info_type(  9,"C N         ","C -2ybc         ", 2, 4, (/ 0, 0, 0, 24,  6, 24/),"-b2  ") , &
            spgr_info_type(  9,"I 1 C 1     ","I -2yc          ", 2, 4, (/ 0, 0, 0, 24,  6, 24/),"-b3  ") , &
            spgr_info_type(  9,"I C         ","I -2yc          ", 2, 4, (/ 0, 0, 0, 24,  6, 24/),"-b3  ") /)

       spgr_info(75:104)= (/                                           &
            spgr_info_type(  9,"A 1 1 A     ","A -2a           ", 2, 4, (/ 0, 0, 0, 24, 24,  6/),"c1   ") , &
            spgr_info_type(  9,"B 1 1 N     ","B -2bc          ", 2, 4, (/ 0, 0, 0, 24, 24,  6/),"c2   ") , &
            spgr_info_type(  9,"I 1 1 B     ","I -2b           ", 2, 4, (/ 0, 0, 0, 24, 24,  6/),"c3   ") , &
            spgr_info_type(  9,"B 1 1 B     ","B -2b           ", 2, 4, (/ 0, 0, 0, 24, 24,  6/),"-c1  ") , &
            spgr_info_type(  9,"A 1 1 N     ","A -2ac          ", 2, 4, (/ 0, 0, 0, 24, 24,  6/),"-c2  ") , &
            spgr_info_type(  9,"I 1 1 A     ","I -2a           ", 2, 4, (/ 0, 0, 0, 24, 24,  6/),"-c3  ") , &
            spgr_info_type(  9,"B B 1 1     ","B -2xb          ", 2, 4, (/ 0, 0, 0,  6, 24, 24/),"a1   ") , &
            spgr_info_type(  9,"C N 1 1     ","C -2xbc         ", 2, 4, (/ 0, 0, 0,  6, 24, 24/),"a2   ") , &
            spgr_info_type(  9,"I C 1 1     ","I -2xc          ", 2, 4, (/ 0, 0, 0,  6, 24, 24/),"a3   ") , &
            spgr_info_type(  9,"C C 1 1     ","C -2xc          ", 2, 4, (/ 0, 0, 0,  6, 24, 24/),"-a1  ") , &
            spgr_info_type(  9,"B N 1 1     ","B -2xbc         ", 2, 4, (/ 0, 0, 0,  6, 24, 24/),"-a2  ") , &
            spgr_info_type(  9,"I B 1 1     ","I -2xb          ", 2, 4, (/ 0, 0, 0,  6, 24, 24/),"-a3  ") , &
            spgr_info_type( 10,"P 1 2/M 1   ","-P 2y           ", 2, 5, (/ 0, 0, 0, 12, 12, 24/),"b    ") , &
            spgr_info_type( 10,"P 2/M       ","-P 2y           ", 2, 5, (/ 0, 0, 0, 12, 12, 24/),"b    ") , &
            spgr_info_type( 10,"P 1 1 2/M   ","-P 2            ", 2, 5, (/ 0, 0, 0, 24, 12, 12/),"c    ") , &
            spgr_info_type( 10,"P 2/M 1 1   ","-P 2x           ", 2, 5, (/ 0, 0, 0, 12, 24, 12/),"a    ") , &
            spgr_info_type( 11,"P 1 21/M 1  ","-P 2yb          ", 2, 5, (/ 0, 0, 0, 24,  6, 24/),"b    ") , &
            spgr_info_type( 11,"P 21/M      ","-P 2yb          ", 2, 5, (/ 0, 0, 0, 24,  6, 24/),"b    ") , &
            spgr_info_type( 11,"P 1 1 21/M  ","-P 2c           ", 2, 5, (/ 0, 0, 0, 24, 24,  6/),"c    ") , &
            spgr_info_type( 11,"P 21/M 1 1  ","-P 2xa          ", 2, 5, (/ 0, 0, 0,  6, 24, 24/),"a    ") , &
            spgr_info_type( 11,"B 1 21/M 1  ","-B 2yb          ", 2, 5, (/ 0, 0, 0, 24,  6, 24/),"b    ") , &
            spgr_info_type( 11,"B 21/M      ","-B 2yb          ", 2, 5, (/ 0, 0, 0, 24,  6, 24/),"b    ") , &
            spgr_info_type( 12,"C 1 2/M 1   ","-C 2y           ", 2, 5, (/ 0, 0, 0, 12,  6, 24/),"b1   ") , &
            spgr_info_type( 12,"C 2/M       ","-C 2y           ", 2, 5, (/ 0, 0, 0, 12,  6, 24/),"b1   ") , &
            spgr_info_type( 12,"A 1 2/M 1   ","-A 2y           ", 2, 5, (/ 0, 0, 0, 12,  6, 24/),"b2   ") , &
            spgr_info_type( 12,"A 2/M       ","-A 2y           ", 2, 5, (/ 0, 0, 0, 12,  6, 24/),"b2   ") , &
            spgr_info_type( 12,"I 1 2/M 1   ","-I 2y           ", 2, 5, (/ 0, 0, 0, 12,  6, 24/),"b3   ") , &
            spgr_info_type( 12,"I 2/M       ","-I 2y           ", 2, 5, (/ 0, 0, 0, 12,  6, 24/),"b3   ") , &
            spgr_info_type( 12,"A 1 1 2/M   ","-A 2            ", 2, 5, (/ 0, 0, 0, 24, 12,  6/),"c1   ") , &
            spgr_info_type( 12,"B 1 1 2/M   ","-B 2            ", 2, 5, (/ 0, 0, 0, 24, 12,  6/),"c2   ") /)

       spgr_info(105:134)= (/                                           &
            spgr_info_type( 12,"I 1 1 2/M   ","-I 2            ", 2, 5, (/ 0, 0, 0, 24, 12,  6/),"c3   ") , &
            spgr_info_type( 12,"B 2/M 1 1   ","-B 2x           ", 2, 5, (/ 0, 0, 0,  6, 24, 12/),"a1   ") , &
            spgr_info_type( 12,"C 2/M 1 1   ","-C 2x           ", 2, 5, (/ 0, 0, 0,  6, 24, 12/),"a2   ") , &
            spgr_info_type( 12,"I 2/M 1 1   ","-I 2x           ", 2, 5, (/ 0, 0, 0,  6, 24, 12/),"a3   ") , &
            spgr_info_type( 12,"F 1 2/M 1   ","-F 2y           ", 2, 5, (/ 0, 0, 0, 12,  6, 24/),"b1   ") , &
            spgr_info_type( 12,"F 2/M       ","-F 2y           ", 2, 5, (/ 0, 0, 0, 12,  6, 24/),"b1   ") , &
            spgr_info_type( 13,"P 1 2/C 1   ","-P 2yc          ", 2, 5, (/ 0, 0, 0, 12, 24, 12/),"b1   ") , &
            spgr_info_type( 13,"P 2/C       ","-P 2yc          ", 2, 5, (/ 0, 0, 0, 12, 24, 12/),"b1   ") , &
            spgr_info_type( 13,"P 1 2/C 1   ","-P 2yc          ", 2, 5, (/ 0, 0, 0, 12, 24, 12/),"b1   ") , &
            spgr_info_type( 13,"P 1 2/N 1   ","-P 2yac         ", 2, 5, (/ 0, 0, 0, 24, 24,  6/),"b2   ") , &
            spgr_info_type( 13,"P 2/N       ","-P 2yac         ", 2, 5, (/ 0, 0, 0, 24, 24,  6/),"b2   ") , &
            spgr_info_type( 13,"P 1 2/A 1   ","-P 2ya          ", 2, 5, (/ 0, 0, 0, 12, 24, 12/),"b3   ") , &
            spgr_info_type( 13,"P 2/A       ","-P 2ya          ", 2, 5, (/ 0, 0, 0, 12, 24, 12/),"b3   ") , &
            spgr_info_type( 13,"P 1 1 2/A   ","-P 2a           ", 2, 5, (/ 0, 0, 0, 12, 12, 24/),"c1   ") , &
            spgr_info_type( 13,"C 1 1 2/A   ","-C 2a           ", 2, 5, (/ 0, 0, 0, 12, 12, 24/),"c1   ") , &
            spgr_info_type( 13,"P 1 1 2/N   ","-P 2ab          ", 2, 5, (/ 0, 0, 0,  6, 24, 24/),"c2   ") , &
            spgr_info_type( 13,"P 1 1 2/B   ","-P 2b           ", 2, 5, (/ 0, 0, 0, 12, 12, 24/),"c3   ") , &
            spgr_info_type( 13,"P 2/B 1 1   ","-P 2xb          ", 2, 5, (/ 0, 0, 0, 24, 12, 12/),"a1   ") , &
            spgr_info_type( 13,"P 2/N 1 1   ","-P 2xbc         ", 2, 5, (/ 0, 0, 0, 24,  6, 24/),"a2   ") , &
            spgr_info_type( 13,"P 2/C 1 1   ","-P 2xc          ", 2, 5, (/ 0, 0, 0, 24, 12, 12/),"a3   ") , &
            spgr_info_type( 14,"P 1 21/C 1  ","-P 2ybc         ", 2, 5, (/ 0, 0, 0, 24,  6, 24/),"b1   ") , &
            spgr_info_type( 14,"P 21/C      ","-P 2ybc         ", 2, 5, (/ 0, 0, 0, 24,  6, 24/),"b1   ") , &
            spgr_info_type( 14,"B 1 21/C 1  ","-B 2ybc         ", 2, 5, (/ 0, 0, 0, 24,  6, 24/),"b1   ") , &
            spgr_info_type( 14,"B 21/C      ","-B 2ybc         ", 2, 5, (/ 0, 0, 0, 24,  6, 24/),"b1   ") , &
            spgr_info_type( 14,"P 1 21/N 1  ","-P 2yn          ", 2, 5, (/ 0, 0, 0, 24,  6, 24/),"b2   ") , &
            spgr_info_type( 14,"P 21/N      ","-P 2yn          ", 2, 5, (/ 0, 0, 0, 24,  6, 24/),"b2   ") , &
            spgr_info_type( 14,"P 1 21/A 1  ","-P 2yab         ", 2, 5, (/ 0, 0, 0, 24,  6, 24/),"b3   ") , &
            spgr_info_type( 14,"P 21/A      ","-P 2yab         ", 2, 5, (/ 0, 0, 0, 24,  6, 24/),"b3   ") , &
            spgr_info_type( 14,"P 1 1 21/A  ","-P 2ac          ", 2, 5, (/ 0, 0, 0, 24, 24,  6/),"c1   ") , &
            spgr_info_type( 14,"P 1 1 21/N  ","-P 2n           ", 2, 5, (/ 0, 0, 0, 24, 24,  6/),"c2   ") /)

       spgr_info(135:162)= (/                                           &
            spgr_info_type( 14,"P 1 1 21/B  ","-P 2bc          ", 2, 5, (/ 0, 0, 0, 24, 24,  6/),"c3   ") , &
            spgr_info_type( 14,"P 21/B 1 1  ","-P 2xab         ", 2, 5, (/ 0, 0, 0,  6, 24, 24/),"a1   ") , &
            spgr_info_type( 14,"P 21/N 1 1  ","-P 2xn          ", 2, 5, (/ 0, 0, 0,  6, 24, 24/),"a2   ") , &
            spgr_info_type( 14,"P 21/C 1 1  ","-P 2xac         ", 2, 5, (/ 0, 0, 0,  6, 24, 24/),"a3   ") , &
            spgr_info_type( 15,"C 1 2/C 1   ","-C 2yc          ", 2, 5, (/ 0, 0, 0, 12, 12, 12/),"b1   ") , &
            spgr_info_type( 15,"C 2/C       ","-C 2yc          ", 2, 5, (/ 0, 0, 0, 12, 12, 12/),"b1   ") , &
            spgr_info_type( 15,"A 1 2/N 1   ","-A 2yac         ", 2, 5, (/ 0, 0, 0, 12, 24,  6/),"b2   ") , &
            spgr_info_type( 15,"A 2/N       ","-A 2yac         ", 2, 5, (/ 0, 0, 0, 12, 24,  6/),"b2   ") , &
            spgr_info_type( 15,"I 1 2/A 1   ","-I 2ya          ", 2, 5, (/ 0, 0, 0, 24, 12,  6/),"b3   ") , &
            spgr_info_type( 15,"I 2/A       ","-I 2ya          ", 2, 5, (/ 0, 0, 0, 24, 12,  6/),"b3   ") , &
            spgr_info_type( 15,"A 1 2/A 1   ","-A 2ya          ", 2, 5, (/ 0, 0, 0, 12, 12, 12/),"-b1  ") , &
            spgr_info_type( 15,"A 2/A       ","-A 2ya          ", 2, 5, (/ 0, 0, 0, 12, 12, 12/),"-b1  ") , &
            spgr_info_type( 15,"C 1 2/N 1   ","-C 2ybc         ", 2, 5, (/ 0, 0, 0,  6, 24, 12/),"-b2  ") , &
            spgr_info_type( 15,"C 2/N       ","-C 2ybc         ", 2, 5, (/ 0, 0, 0,  6, 24, 12/),"-b2  ") , &
            spgr_info_type( 15,"I 1 2/C 1   ","-I 2yc          ", 2, 5, (/ 0, 0, 0,  6, 12, 24/),"-b3  ") , &
            spgr_info_type( 15,"I 2/C       ","-I 2yc          ", 2, 5, (/ 0, 0, 0,  6, 12, 24/),"-b3  ") , &
            spgr_info_type( 15,"A 1 1 2/A   ","-A 2a           ", 2, 5, (/ 0, 0, 0, 12, 12, 12/),"c1   ") , &
            spgr_info_type( 15,"B 1 1 2/N   ","-B 2bc          ", 2, 5, (/ 0, 0, 0,  6, 12, 24/),"c2   ") , &
            spgr_info_type( 15,"I 1 1 2/B   ","-I 2b           ", 2, 5, (/ 0, 0, 0,  6, 24, 12/),"c3   ") , &
            spgr_info_type( 15,"B 1 1 2/B   ","-B 2b           ", 2, 5, (/ 0, 0, 0, 12, 12, 12/),"-c1  ") , &
            spgr_info_type( 15,"A 1 1 2/N   ","-A 2ac          ", 2, 5, (/ 0, 0, 0, 12,  6, 24/),"-c2  ") , &
            spgr_info_type( 15,"I 1 1 2/A   ","-I 2a           ", 2, 5, (/ 0, 0, 0, 24,  6, 12/),"-c3  ") , &
            spgr_info_type( 15,"B 2/B 1 1   ","-B 2xb          ", 2, 5, (/ 0, 0, 0, 12, 12, 12/),"a1   ") , &
            spgr_info_type( 15,"C 2/N 1 1   ","-C 2xbc         ", 2, 5, (/ 0, 0, 0, 24,  6, 12/),"a2   ") , &
            spgr_info_type( 15,"I 2/C 1 1   ","-I 2xc          ", 2, 5, (/ 0, 0, 0, 24,  6, 12/),"a3   ") , &
            spgr_info_type( 15,"C 2/C 1 1   ","-C 2xc          ", 2, 5, (/ 0, 0, 0, 12, 12, 12/),"-a1  ") , &
            spgr_info_type( 15,"B 2/N 1 1   ","-B 2xbc         ", 2, 5, (/ 0, 0, 0, 24, 12,  6/),"-a2  ") , &
            spgr_info_type( 15,"I 2/B 1 1   ","-I 2xb          ", 2, 5, (/ 0, 0, 0, 24, 12,  6/),"-a3  ") /)

       !---- Orthorhombic ----!
       spgr_info(163:192)= (/                                           &
            spgr_info_type( 16,"P 2 2 2     ","P 2 2           ", 3, 6, (/ 0, 0, 0, 12, 12, 24/),"     ") , &
            spgr_info_type( 17,"P 2 2 21    ","P 2c 2          ", 3, 6, (/ 0, 0, 0, 12, 12, 24/),"     ") , &
            spgr_info_type( 17,"P 21 2 2    ","P 2a 2a         ", 3, 6, (/ 0, 0, 0, 24, 12, 12/),"cab  ") , &
            spgr_info_type( 17,"P 2 21 2    ","P 2 2b          ", 3, 6, (/ 0, 0, 0, 12, 24, 12/),"bca  ") , &
            spgr_info_type( 18,"P 21 21 2   ","P 2 2ab         ", 3, 6, (/ 0, 0, 0, 12, 12, 24/),"     ") , &
            spgr_info_type( 18,"P 2 21 21   ","P 2bc 2         ", 3, 6, (/ 0, 0, 0, 24, 12, 12/),"cab  ") , &
            spgr_info_type( 18,"P 21 2 21   ","P 2ac 2ac       ", 3, 6, (/ 0, 0, 0, 12, 24, 12/),"bca  ") , &
            spgr_info_type( 19,"P 21 21 21  ","P 2ac 2ab       ", 3, 6, (/ 0, 0, 0, 12, 12, 24/),"     ") , &
            spgr_info_type( 20,"C 2 2 21    ","C 2c 2          ", 3, 6, (/ 0, 0, 0, 12, 12, 12/),"     ") , &
            spgr_info_type( 20,"A 21 2 2    ","A 2a 2a         ", 3, 6, (/ 0, 0, 0, 12, 12, 12/),"cab  ") , &
            spgr_info_type( 20,"B 2 21 2    ","B 2 2b          ", 3, 6, (/ 0, 0, 0, 12, 12, 12/),"bca  ") , &
            spgr_info_type( 21,"C 2 2 2     ","C 2 2           ", 3, 6, (/ 0, 0, 0,  6, 12, 24/),"     ") , &
            spgr_info_type( 21,"A 2 2 2     ","A 2 2           ", 3, 6, (/ 0, 0, 0, 24,  6, 12/),"cab  ") , &
            spgr_info_type( 21,"B 2 2 2     ","B 2 2           ", 3, 6, (/ 0, 0, 0, 12, 24,  6/),"bca  ") , &
            spgr_info_type( 22,"F 2 2 2     ","F 2 2           ", 3, 6, (/ 0, 0, 0,  6,  6, 24/),"     ") , &
            spgr_info_type( 23,"I 2 2 2     ","I 2 2           ", 3, 6, (/ 0, 0, 0, 12, 12, 12/),"     ") , &
            spgr_info_type( 24,"I 21 21 21  ","I 2b 2c         ", 3, 6, (/ 0, 0, 0, 12, 12, 12/),"     ") , &
            spgr_info_type( 25,"P M M 2     ","P 2 -2          ", 3, 7, (/ 0, 0, 0, 12, 12, 24/),"     ") , &
            spgr_info_type( 25,"P 2 M M     ","P -2 2          ", 3, 9, (/ 0, 0, 0, 24, 12, 12/),"cab  ") , &
            spgr_info_type( 25,"P M 2 M     ","P -2 -2         ", 3, 8, (/ 0, 0, 0, 12, 24, 12/),"bca  ") , &
            spgr_info_type( 26,"P M C 21    ","P 2c -2         ", 3, 7, (/ 0, 0, 0, 12, 12, 24/),"     ") , &
            spgr_info_type( 26,"P C M 21    ","P 2c -2c        ", 3, 7, (/ 0, 0, 0, 12, 12, 24/),"ba-c ") , &
            spgr_info_type( 26,"P 21 M A    ","P -2a 2a        ", 3, 9, (/ 0, 0, 0, 24, 12, 12/),"cab  ") , &
            spgr_info_type( 26,"P 21 A M    ","P -2 2a         ", 3, 9, (/ 0, 0, 0, 24, 12, 12/),"-cba ") , &
            spgr_info_type( 26,"P B 21 M    ","P -2 -2b        ", 3, 8, (/ 0, 0, 0, 12, 24, 12/),"bca  ") , &
            spgr_info_type( 26,"P M 21 B    ","P -2b -2        ", 3, 8, (/ 0, 0, 0, 12, 24, 12/),"a-cb ") , &
            spgr_info_type( 27,"P C C 2     ","P 2 -2c         ", 3, 7, (/ 0, 0, 0, 12, 12, 24/),"     ") , &
            spgr_info_type( 27,"P 2 A A     ","P -2a 2         ", 3, 9, (/ 0, 0, 0, 24, 12, 12/),"cab  ") , &
            spgr_info_type( 27,"P B 2 B     ","P -2b -2b       ", 3, 8, (/ 0, 0, 0, 12, 24, 12/),"bca  ") , &
            spgr_info_type( 28,"P M A 2     ","P 2 -2a         ", 3, 7, (/ 0, 0, 0,  6, 24, 24/),"     ") /)

       spgr_info(193:222)= (/                                           &
            spgr_info_type( 28,"P B M 2     ","P 2 -2b         ", 3, 7, (/ 0, 0, 0, 24,  6, 24/),"ba-c ") , &
            spgr_info_type( 28,"P 2 M B     ","P -2b 2         ", 3, 9, (/ 0, 0, 0, 24,  6, 24/),"cab  ") , &
            spgr_info_type( 28,"P 2 C M     ","P -2c 2         ", 3, 9, (/ 0, 0, 0, 24, 24,  6/),"-cba ") , &
            spgr_info_type( 28,"P C 2 M     ","P -2c -2c       ", 3, 8, (/ 0, 0, 0, 24, 24,  6/),"bca  ") , &
            spgr_info_type( 28,"P M 2 A     ","P -2a -2a       ", 3, 8, (/ 0, 0, 0,  6, 24, 24/),"a-cb ") , &
            spgr_info_type( 29,"P C A 21    ","P 2c -2ac       ", 3, 7, (/ 0, 0, 0,  6, 24, 24/),"     ") , &
            spgr_info_type( 29,"P B C 21    ","P 2c -2b        ", 3, 7, (/ 0, 0, 0, 24,  6, 24/),"ba-c ") , &
            spgr_info_type( 29,"P 21 A B    ","P -2b 2a        ", 3, 9, (/ 0, 0, 0, 24,  6, 24/),"cab  ") , &
            spgr_info_type( 29,"P 21 C A    ","P -2ac 2a       ", 3, 9, (/ 0, 0, 0, 24, 24,  6/),"-cba ") , &
            spgr_info_type( 29,"P C 21 B    ","P -2bc -2c      ", 3, 8, (/ 0, 0, 0, 24, 24,  6/),"bca  ") , &
            spgr_info_type( 29,"P B 21 A    ","P -2a -2ab      ", 3, 8, (/ 0, 0, 0,  6, 24, 24/),"a-cb ") , &
            spgr_info_type( 30,"P N C 2     ","P 2 -2bc        ", 3, 7, (/ 0, 0, 0, 12, 24, 12/),"     ") , &
            spgr_info_type( 30,"P C N 2     ","P 2 -2ac        ", 3, 7, (/ 0, 0, 0, 24, 12, 12/),"ba-c ") , &
            spgr_info_type( 30,"P 2 N A     ","P -2ac 2        ", 3, 9, (/ 0, 0, 0, 12, 12, 24/),"cab  ") , &
            spgr_info_type( 30,"P 2 A N     ","P -2ab 2        ", 3, 9, (/ 0, 0, 0, 12, 24, 12/),"-cba ") , &
            spgr_info_type( 30,"P B 2 N     ","P -2ab -2ab     ", 3, 8, (/ 0, 0, 0, 24, 12, 12/),"bca  ") , &
            spgr_info_type( 30,"P N 2 B     ","P -2bc -2bc     ", 3, 8, (/ 0, 0, 0, 12, 12, 24/),"a-cb ") , &
            spgr_info_type( 31,"P M N 21    ","P 2ac -2        ", 3, 7, (/ 0, 0, 0, 12, 12, 24/),"     ") , &
            spgr_info_type( 31,"P N M 21    ","P 2bc -2bc      ", 3, 7, (/ 0, 0, 0, 12, 12, 24/),"ba-c ") , &
            spgr_info_type( 31,"P 21 M N    ","P -2ab 2ab      ", 3, 9, (/ 0, 0, 0, 24, 12, 12/),"cab  ") , &
            spgr_info_type( 31,"P 21 N M    ","P -2 2ac        ", 3, 9, (/ 0, 0, 0, 24, 12, 12/),"-cba ") , &
            spgr_info_type( 31,"P N 21 M    ","P -2 -2bc       ", 3, 8, (/ 0, 0, 0, 12, 24, 12/),"bca  ") , &
            spgr_info_type( 31,"P M 21 N    ","P -2ab -2       ", 3, 8, (/ 0, 0, 0, 12, 24, 12/),"a-cb ") , &
            spgr_info_type( 32,"P B A 2     ","P 2 -2ab        ", 3, 7, (/ 0, 0, 0, 12, 12, 24/),"     ") , &
            spgr_info_type( 32,"P 2 C B     ","P -2bc 2        ", 3, 9, (/ 0, 0, 0, 24, 12, 12/),"cab  ") , &
            spgr_info_type( 32,"P C 2 A     ","P -2ac -2ac     ", 3, 8, (/ 0, 0, 0, 12, 24, 12/),"bca  ") , &
            spgr_info_type( 33,"P N A 21    ","P 2c -2n        ", 3, 7, (/ 0, 0, 0, 12, 12, 24/),"     ") , &
            spgr_info_type( 33,"P B N 21    ","P 2c -2ab       ", 3, 7, (/ 0, 0, 0, 12, 12, 24/),"ba-c ") , &
            spgr_info_type( 33,"P 21 N B    ","P -2bc 2a       ", 3, 9, (/ 0, 0, 0, 24, 12, 12/),"cab  ") , &
            spgr_info_type( 33,"P 21 C N    ","P -2n 2a        ", 3, 9, (/ 0, 0, 0, 24, 12, 12/),"-cba ") /)

       spgr_info(223:252)= (/                                           &
            spgr_info_type( 33,"P C 21 N    ","P -2n -2ac      ", 3, 8, (/ 0, 0, 0, 12, 24, 12/),"bca  ") , &
            spgr_info_type( 33,"P N 21 A    ","P -2ac -2n      ", 3, 8, (/ 0, 0, 0, 12, 24, 12/),"a-cb ") , &
            spgr_info_type( 34,"P N N 2     ","P 2 -2n         ", 3, 7, (/ 0, 0, 0, 12, 12, 24/),"     ") , &
            spgr_info_type( 34,"P 2 N N     ","P -2n 2         ", 3, 9, (/ 0, 0, 0, 24, 12, 12/),"cab  ") , &
            spgr_info_type( 34,"P N 2 N     ","P -2n -2n       ", 3, 8, (/ 0, 0, 0, 12, 24, 12/),"bca  ") , &
            spgr_info_type( 35,"C M M 2     ","C 2 -2          ", 3, 7, (/ 0, 0, 0,  6, 12, 24/),"     ") , &
            spgr_info_type( 35,"A 2 M M     ","A -2 2          ", 3, 9, (/ 0, 0, 0, 24,  6, 12/),"cab  ") , &
            spgr_info_type( 35,"B M 2 M     ","B -2 -2         ", 3, 8, (/ 0, 0, 0, 12, 24,  6/),"bca  ") , &
            spgr_info_type( 36,"C M C 21    ","C 2c -2         ", 3, 7, (/ 0, 0, 0, 12, 12, 12/),"     ") , &
            spgr_info_type( 36,"C C M 21    ","C 2c -2c        ", 3, 7, (/ 0, 0, 0, 12, 12, 12/),"ba-c ") , &
            spgr_info_type( 36,"A 21 M A    ","A -2a 2a        ", 3, 9, (/ 0, 0, 0, 12, 12, 12/),"cab  ") , &
            spgr_info_type( 36,"A 21 A M    ","A -2 2a         ", 3, 9, (/ 0, 0, 0, 12, 12, 12/),"-cba ") , &
            spgr_info_type( 36,"B B 21 M    ","B -2 -2b        ", 3, 8, (/ 0, 0, 0, 12, 12, 12/),"bca  ") , &
            spgr_info_type( 36,"B M 21 B    ","B -2b -2        ", 3, 8, (/ 0, 0, 0, 12, 12, 12/),"a-cb ") , &
            spgr_info_type( 37,"C C C 2     ","C 2 -2c         ", 3, 7, (/ 0, 0, 0,  6, 12, 24/),"     ") , &
            spgr_info_type( 37,"A 2 A A     ","A -2a 2         ", 3, 9, (/ 0, 0, 0, 24,  6, 12/),"cab  ") , &
            spgr_info_type( 37,"B B 2 B     ","B -2b -2b       ", 3, 8, (/ 0, 0, 0, 12, 24,  6/),"bca  ") , &
            spgr_info_type( 38,"A M M 2     ","A 2 -2          ", 3, 7, (/ 0, 0, 0, 12, 12, 12/),"     ") , &
            spgr_info_type( 38,"B M M 2     ","B 2 -2          ", 3, 7, (/ 0, 0, 0, 12, 12, 12/),"ba-c ") , &
            spgr_info_type( 38,"B 2 M M     ","B -2 2          ", 3, 9, (/ 0, 0, 0, 12, 12, 12/),"cab  ") , &
            spgr_info_type( 38,"C 2 M M     ","C -2 2          ", 3, 9, (/ 0, 0, 0, 12, 12, 12/),"-cba ") , &
            spgr_info_type( 38,"C M 2 M     ","C -2 -2         ", 3, 8, (/ 0, 0, 0, 12, 12, 12/),"bca  ") , &
            spgr_info_type( 38,"A M 2 M     ","A -2 -2         ", 3, 8, (/ 0, 0, 0, 12, 12, 12/),"a-cb ") , &
            spgr_info_type( 39,"A B M 2     ","A 2 -2c         ", 3, 7, (/ 0, 0, 0, 12,  6, 24/),"     ") , &
            spgr_info_type( 39,"B M A 2     ","B 2 -2c         ", 3, 7, (/ 0, 0, 0,  6, 12, 24/),"ba-c ") , &
            spgr_info_type( 39,"B 2 C M     ","B -2c 2         ", 3, 9, (/ 0, 0, 0, 24, 12,  6/),"cab  ") , &
            spgr_info_type( 39,"C 2 M B     ","C -2b 2         ", 3, 9, (/ 0, 0, 0, 24,  6, 12/),"-cba ") , &
            spgr_info_type( 39,"C M 2 A     ","C -2b -2b       ", 3, 8, (/ 0, 0, 0,  6, 24, 12/),"bca  ") , &
            spgr_info_type( 39,"A C 2 M     ","A -2c -2c       ", 3, 8, (/ 0, 0, 0, 12, 24,  6/),"a-cb ") , &
            spgr_info_type( 40,"A M A 2     ","A 2 -2a         ", 3, 7, (/ 0, 0, 0,  6, 12, 24/),"     ") /)

       spgr_info(253:282)= (/                                           &
            spgr_info_type( 40,"B B M 2     ","B 2 -2b         ", 3, 7, (/ 0, 0, 0, 12,  6, 24/),"ba-c ") , &
            spgr_info_type( 40,"B 2 M B     ","B -2b 2         ", 3, 9, (/ 0, 0, 0, 24,  6, 12/),"cab  ") , &
            spgr_info_type( 40,"C 2 C M     ","C -2c 2         ", 3, 9, (/ 0, 0, 0, 24, 12,  6/),"-cba ") , &
            spgr_info_type( 40,"C C 2 M     ","C -2c -2c       ", 3, 8, (/ 0, 0, 0, 12, 24,  6/),"bca  ") , &
            spgr_info_type( 40,"A M 2 A     ","A -2a -2a       ", 3, 8, (/ 0, 0, 0,  6, 24, 12/),"a-cb ") , &
            spgr_info_type( 41,"A B A 2     ","A 2 -2ac        ", 3, 7, (/ 0, 0, 0, 12, 12, 12/),"     ") , &
            spgr_info_type( 41,"B B A 2     ","B 2 -2bc        ", 3, 7, (/ 0, 0, 0, 12, 12, 12/),"ba-c ") , &
            spgr_info_type( 41,"B 2 C B     ","B -2bc 2        ", 3, 9, (/ 0, 0, 0, 12, 12, 12/),"cab  ") , &
            spgr_info_type( 41,"C 2 C B     ","C -2bc 2        ", 3, 9, (/ 0, 0, 0, 12, 12, 12/),"-cba ") , &
            spgr_info_type( 41,"C C 2 A     ","C -2bc -2bc     ", 3, 8, (/ 0, 0, 0, 12, 12, 12/),"bca  ") , &
            spgr_info_type( 41,"A C 2 A     ","A -2ac -2ac     ", 3, 8, (/ 0, 0, 0, 12, 12, 12/),"a-cb ") , &
            spgr_info_type( 42,"F M M 2     ","F 2 -2          ", 3, 7, (/ 0, 0, 0,  6,  6, 24/),"     ") , &
            spgr_info_type( 42,"F 2 M M     ","F -2 2          ", 3, 9, (/ 0, 0, 0, 24,  6,  6/),"cab  ") , &
            spgr_info_type( 42,"F M 2 M     ","F -2 -2         ", 3, 8, (/ 0, 0, 0,  6, 24,  6/),"bca  ") , &
            spgr_info_type( 43,"F D D 2     ","F 2 -2d         ", 3, 7, (/ 0, 0, 0,  6,  6, 24/),"     ") , &
            spgr_info_type( 43,"F 2 D D     ","F -2d 2         ", 3, 9, (/ 0, 0, 0, 24,  6,  6/),"cab  ") , &
            spgr_info_type( 43,"F D 2 D     ","F -2d -2d       ", 3, 8, (/ 0, 0, 0,  6, 24,  6/),"bca  ") , &
            spgr_info_type( 44,"I M M 2     ","I 2 -2          ", 3, 7, (/ 0, 0, 0, 12, 12, 12/),"     ") , &
            spgr_info_type( 44,"I 2 M M     ","I -2 2          ", 3, 9, (/ 0, 0, 0, 12, 12, 12/),"cab  ") , &
            spgr_info_type( 44,"I M 2 M     ","I -2 -2         ", 3, 8, (/ 0, 0, 0, 12, 12, 12/),"bca  ") , &
            spgr_info_type( 45,"I B A 2     ","I 2 -2c         ", 3, 7, (/ 0, 0, 0, 12, 12, 12/),"     ") , &
            spgr_info_type( 45,"I 2 C B     ","I -2a 2         ", 3, 9, (/ 0, 0, 0, 12, 12, 12/),"cab  ") , &
            spgr_info_type( 45,"I C 2 A     ","I -2b -2b       ", 3, 8, (/ 0, 0, 0, 12, 12, 12/),"bca  ") , &
            spgr_info_type( 46,"I M A 2     ","I 2 -2a         ", 3, 7, (/ 0, 0, 0,  6, 24, 12/),"     ") , &
            spgr_info_type( 46,"I B M 2     ","I 2 -2b         ", 3, 7, (/ 0, 0, 0, 24,  6, 12/),"ba-c ") , &
            spgr_info_type( 46,"I 2 M B     ","I -2b 2         ", 3, 9, (/ 0, 0, 0, 12,  6, 24/),"cab  ") , &
            spgr_info_type( 46,"I 2 C M     ","I -2c 2         ", 3, 9, (/ 0, 0, 0, 12, 24,  6/),"-cba ") , &
            spgr_info_type( 46,"I C 2 M     ","I -2c -2c       ", 3, 8, (/ 0, 0, 0, 24, 12,  6/),"bca  ") , &
            spgr_info_type( 46,"I M 2 A     ","I -2a -2a       ", 3, 8, (/ 0, 0, 0,  6, 12, 12/),"a-cb ") , &
            spgr_info_type( 47,"P M M M     ","-P 2 2          ", 3,10, (/ 0, 0, 0, 12, 12, 12/),"     ") /)

       spgr_info(283:312)= (/                                           &
            spgr_info_type( 48,"P N N N:1   ","P 2 2 -1n       ", 3,10, (/ 0, 0, 0,  6, 12, 24/),"1    ") , &
            spgr_info_type( 48,"P N N N     ","-P 2ab 2bc      ", 3,10, (/ 0,-6, 0,  6,  6, 24/),"2    ") , &
            spgr_info_type( 49,"P C C M     ","-P 2 2c         ", 3,10, (/ 0, 0, 0, 12, 12, 12/),"     ") , &
            spgr_info_type( 49,"P M A A     ","-P 2a 2         ", 3,10, (/ 0, 0, 0, 12, 12, 12/),"cab  ") , &
            spgr_info_type( 49,"P B M B     ","-P 2b 2b        ", 3,10, (/ 0, 0, 0, 12, 12, 12/),"bca  ") , &
            spgr_info_type( 50,"P B A N:1   ","P 2 2 -1ab      ", 3,10, (/ 0, 0, 0, 12, 12, 12/),"1    ") , &
            spgr_info_type( 50,"P B A N     ","-P 2ab 2b       ", 3,10, (/ 0, 0, 0,  6, 24, 12/),"2    ") , &
            spgr_info_type( 50,"P N C B:1   ","P 2 2 -1bc      ", 3,10, (/ 0, 0, 0, 12, 12, 12/),"1cab ") , &
            spgr_info_type( 50,"P N C B     ","-P 2b 2bc       ", 3,10, (/ 0, 0, 0, 12,  6, 24/),"2cab ") , &
            spgr_info_type( 50,"P C N A:1   ","P 2 2 -1ac      ", 3,10, (/ 0, 0, 0, 12, 12, 12/),"1bca ") , &
            spgr_info_type( 50,"P C N A     ","-P 2a 2c        ", 3,10, (/ 0, 0, 0, 24, 12,  6/),"2bca ") , &
            spgr_info_type( 51,"P M M A     ","-P 2a 2a        ", 3,10, (/ 0, 0, 0,  6, 12, 24/),"     ") , &
            spgr_info_type( 51,"P M M B     ","-P 2b 2         ", 3,10, (/ 0, 0, 0, 12,  6, 24/),"ba-c ") , &
            spgr_info_type( 51,"P B M M     ","-P 2 2b         ", 3,10, (/ 0, 0, 0, 24,  6, 12/),"cab  ") , &
            spgr_info_type( 51,"P C M M     ","-P 2c 2c        ", 3,10, (/ 0, 0, 0, 24, 12,  6/),"-cba ") , &
            spgr_info_type( 51,"P M C M     ","-P 2c 2         ", 3,10, (/ 0, 0, 0, 12, 24,  6/),"bca  ") , &
            spgr_info_type( 51,"P M A M     ","-P 2 2a         ", 3,10, (/ 0, 0, 0,  6, 24, 12/),"a-cb ") , &
            spgr_info_type( 52,"P N N A     ","-P 2a 2bc       ", 3,10, (/ 0, 0, 0, 24,  6, 12/),"     ") , &
            spgr_info_type( 52,"P N N B     ","-P 2b 2n        ", 3,10, (/ 0, 0, 0,  6, 24, 12/),"ba-c ") , &
            spgr_info_type( 52,"P B N N     ","-P 2n 2b        ", 3,10, (/ 0, 0, 0, 12, 24,  6/),"cab  ") , &
            spgr_info_type( 52,"P C N N     ","-P 2ab 2c       ", 3,10, (/ 0, 0, 0, 12,  6, 24/),"-cba ") , &
            spgr_info_type( 52,"P N C N     ","-P 2ab 2n       ", 3,10, (/ 0, 0, 0,  6, 12, 24/),"bca  ") , &
            spgr_info_type( 52,"P N A N     ","-P 2n 2bc       ", 3,10, (/ 0, 0, 0, 24, 12,  6/),"a-cb ") , &
            spgr_info_type( 53,"P M N A     ","-P 2ac 2        ", 3,10, (/ 0, 0, 0, 12, 24,  6/),"     ") , &
            spgr_info_type( 53,"P N M B     ","-P 2bc 2bc      ", 3,10, (/ 0, 0, 0, 24, 12,  6/),"ba-c ") , &
            spgr_info_type( 53,"P B M N     ","-P 2ab 2ab      ", 3,10, (/ 0, 0, 0,  6, 12, 24/),"cab  ") , &
            spgr_info_type( 53,"P C N M     ","-P 2 2ac        ", 3,10, (/ 0, 0, 0,  6, 24, 12/),"-cba ") , &
            spgr_info_type( 53,"P N C M     ","-P 2 2bc        ", 3,10, (/ 0, 0, 0, 24,  6, 12/),"bca  ") , &
            spgr_info_type( 53,"P M A N     ","-P 2ab 2        ", 3,10, (/ 0, 0, 0, 12,  6, 24/),"a-cb ") , &
            spgr_info_type( 54,"P C C A     ","-P 2a 2ac       ", 3,10, (/ 0, 0, 0, 12, 12, 12/),"     ") /)

       spgr_info(313:342)= (/                                           &
            spgr_info_type( 54,"P C C B     ","-P 2b 2c        ", 3,10, (/ 0, 0, 0, 12, 12, 12/),"ba-c ") , &
            spgr_info_type( 54,"P B A A     ","-P 2a 2b        ", 3,10, (/ 0, 0, 0, 12, 12, 12/),"cab  ") , &
            spgr_info_type( 54,"P C A A     ","-P 2ac 2c       ", 3,10, (/ 0, 0, 0, 12, 12, 12/),"-cba ") , &
            spgr_info_type( 54,"P B C B     ","-P 2bc 2b       ", 3,10, (/ 0, 0, 0, 12, 12, 12/),"bca  ") , &
            spgr_info_type( 54,"P B A B     ","-P 2b 2ab       ", 3,10, (/ 0, 0, 0, 12, 12, 12/),"a-cb ") , &
            spgr_info_type( 55,"P B A M     ","-P 2 2ab        ", 3,10, (/ 0, 0, 0, 12, 12, 12/),"     ") , &
            spgr_info_type( 55,"P M C B     ","-P 2bc 2        ", 3,10, (/ 0, 0, 0, 12, 12, 12/),"cab  ") , &
            spgr_info_type( 55,"P C M A     ","-P 2ac 2ac      ", 3,10, (/ 0, 0, 0, 12, 12, 12/),"bca  ") , &
            spgr_info_type( 56,"P C C N     ","-P 2ab 2ac      ", 3,10, (/ 0, 0, 0,  6, 24, 12/),"     ") , &
            spgr_info_type( 56,"P N A A     ","-P 2ac 2bc      ", 3,10, (/ 0, 0, 0, 12,  6, 24/),"cab  ") , &
            spgr_info_type( 56,"P B N B     ","-P 2bc 2ab      ", 3,10, (/ 0, 0, 0, 24, 12,  6/),"bca  ") , &
            spgr_info_type( 57,"P B C M     ","-P 2c 2b        ", 3,10, (/ 0, 0, 0, 12, 24,  6/),"     ") , &
            spgr_info_type( 57,"P C A M     ","-P 2c 2ac       ", 3,10, (/ 0, 0, 0, 24, 12,  6/),"ba-c ") , &
            spgr_info_type( 57,"P M C A     ","-P 2ac 2a       ", 3,10, (/ 0, 0, 0,  6, 12, 24/),"cab  ") , &
            spgr_info_type( 57,"P M A B     ","-P 2b 2a        ", 3,10, (/ 0, 0, 0,  6, 24, 12/),"-cba ") , &
            spgr_info_type( 57,"P B M A     ","-P 2a 2ab       ", 3,10, (/ 0, 0, 0, 24,  6, 12/),"bca  ") , &
            spgr_info_type( 57,"P C M B     ","-P 2bc 2c       ", 3,10, (/ 0, 0, 0, 12,  6, 24/),"a-cb ") , &
            spgr_info_type( 58,"P N N M     ","-P 2 2n         ", 3,10, (/ 0, 0, 0, 12, 12, 12/),"     ") , &
            spgr_info_type( 58,"P M N N     ","-P 2n 2         ", 3,10, (/ 0, 0, 0, 12, 12, 12/),"cab  ") , &
            spgr_info_type( 58,"P N M N     ","-P 2n 2n        ", 3,10, (/ 0, 0, 0, 12, 12, 12/),"bca  ") , &
            spgr_info_type( 59,"P M M N:1   ","P 2 2ab -1ab    ", 3,10, (/ 0, 0, 0, 12, 12, 12/),"1    ") , &
            spgr_info_type( 59,"P M M N     ","-P 2ab 2a       ", 3,10, (/ 0,-6, 0,  6,  6, 24/),"2    ") , &
            spgr_info_type( 59,"P N M M:1   ","P 2bc 2 -1bc    ", 3,10, (/ 0, 0, 0, 12, 12, 12/),"1cab ") , &
            spgr_info_type( 59,"P N M M     ","-P 2c 2bc       ", 3,10, (/ 0, 0,-6, 24,  6,  6/),"2cab ") , &
            spgr_info_type( 59,"P M N M:1   ","P 2ac 2ac -1ac  ", 3,10, (/ 0, 0, 0, 12, 12, 12/),"1bca ") , &
            spgr_info_type( 59,"P M N M     ","-P 2c 2a        ", 3,10, (/-6, 0, 0,  6, 24,  6/),"2bca ") , &
            spgr_info_type( 60,"P B C N     ","-P 2n 2ab       ", 3,10, (/ 0, 0, 0, 12, 12, 12/),"     ") , &
            spgr_info_type( 60,"P C A N     ","-P 2n 2c        ", 3,10, (/ 0, 0, 0, 12, 12, 12/),"ba-c ") , &
            spgr_info_type( 60,"P N C A     ","-P 2a 2n        ", 3,10, (/ 0, 0, 0, 12, 12, 12/),"cab  ") , &
            spgr_info_type( 60,"P N A B     ","-P 2bc 2n       ", 3,10, (/ 0, 0, 0, 12, 12, 12/),"-cba ") /)

       spgr_info(343:372)= (/                                           &
            spgr_info_type( 60,"P B N A     ","-P 2ac 2b       ", 3,10, (/ 0, 0, 0, 12, 12, 12/),"bca  ") , &
            spgr_info_type( 60,"P C N B     ","-P 2b 2ac       ", 3,10, (/ 0, 0, 0, 12, 12, 12/),"a-cb ") , &
            spgr_info_type( 61,"P B C A     ","-P 2ac 2ab      ", 3,10, (/ 0, 0, 0, 12, 12, 12/),"     ") , &
            spgr_info_type( 61,"P C A B     ","-P 2bc 2ac      ", 3,10, (/ 0, 0, 0, 12, 12, 12/),"ba-c ") , &
            spgr_info_type( 62,"P N M A     ","-P 2ac 2n       ", 3,10, (/ 0, 0, 0, 12,  6, 24/),"     ") , &
            spgr_info_type( 62,"P M N B     ","-P 2bc 2a       ", 3,10, (/ 0, 0, 0,  6, 12, 24/),"ba-c ") , &
            spgr_info_type( 62,"P M N B:1   ","P 2ac 2ab -1ab  ", 3,10, (/ 0, 0, 0,  6, 12, 24/),"     ") , &
            spgr_info_type( 62,"P B N M     ","-P 2c 2ab       ", 3,10, (/ 0, 0, 0, 24, 12,  6/),"cab  ") , &
            spgr_info_type( 62,"P B N M:1   ","P 2c 2n -1c     ", 3,10, (/ 0, 0, 0, 24, 12,  6/),"     ") , &
            spgr_info_type( 62,"P C M N     ","-P 2n 2ac       ", 3,10, (/ 0, 0, 0, 24,  6, 12/),"-cba ") , &
            spgr_info_type( 62,"P M C N     ","-P 2n 2a        ", 3,10, (/ 0, 0, 0,  6, 24, 12/),"bca  ") , &
            spgr_info_type( 62,"P M C N:1   ","P 2bc 2a -1a    ", 3,10, (/ 0, 0, 0,  6, 24, 12/),"     ") , &
            spgr_info_type( 62,"P N A M     ","-P 2c 2n        ", 3,10, (/ 0, 0, 0, 12, 24,  6/),"a-cb ") , &
            spgr_info_type( 63,"C M C M     ","-C 2c 2         ", 3,10, (/ 0, 0, 0, 12, 12, 24/),"     ") , &
            spgr_info_type( 63,"C C M M     ","-C 2c 2c        ", 3,10, (/ 0, 0, 0, 12, 12, 24/),"ba-c ") , &
            spgr_info_type( 63,"A M M A     ","-A 2a 2a        ", 3,10, (/ 0, 0, 0, 24, 12, 12/),"cab  ") , &
            spgr_info_type( 63,"A M A M     ","-A 2 2a         ", 3,10, (/ 0, 0, 0, 24, 12, 12/),"-cba ") , &
            spgr_info_type( 63,"B B M M     ","-B 2 2b         ", 3,10, (/ 0, 0, 0, 12, 24, 12/),"bca  ") , &
            spgr_info_type( 63,"B M M B     ","-B 2b 2         ", 3,10, (/ 0, 0, 0, 12, 24, 12/),"a-cb ") , &
            spgr_info_type( 63,"B M M B:1   ","B 2ab 2c -1ac   ", 3,10, (/ 0, 0, 0, 12, 24, 12/),"     ") , &
            spgr_info_type( 64,"C M C A     ","-C 2bc 2        ", 3,10, (/ 0, 0, 0,  6, 12, 12/),"     ") , &
            spgr_info_type( 64,"C C M B     ","-C 2bc 2bc      ", 3,10, (/ 0, 0, 0, 12,  6, 12/),"ba-c ") , &
            spgr_info_type( 64,"C C M B:1   ","C 2bc 2n -1ab   ", 3,10, (/ 0, 0, 0, 12,  6, 12/),"     ") , &
            spgr_info_type( 64,"A B M A     ","-A 2ac 2ac      ", 3,10, (/ 0, 0, 0, 12,  6, 12/),"cab  ") , &
            spgr_info_type( 64,"A C A M     ","-A 2 2ac        ", 3,10, (/ 0, 0, 0, 12, 12,  6/),"-cba ") , &
            spgr_info_type( 64,"B B C M     ","-B 2 2bc        ", 3,10, (/ 0, 0, 0, 12, 12,  6/),"bca  ") , &
            spgr_info_type( 64,"B M A B     ","-B 2bc 2        ", 3,10, (/ 0, 0, 0,  6, 12, 12/),"a-cb ") , &
            spgr_info_type( 65,"C M M M     ","-C 2 2          ", 3,10, (/ 0, 0, 0,  6, 12, 12/),"     ") , &
            spgr_info_type( 65,"A M M M     ","-A 2 2          ", 3,10, (/ 0, 0, 0, 12,  6, 12/),"cab  ") , &
            spgr_info_type( 65,"B M M M     ","-B 2 2          ", 3,10, (/ 0, 0, 0, 12, 12,  6/),"bca  ") /)

       spgr_info(373:402)= (/                                           &
            spgr_info_type( 66,"C C C M     ","-C 2 2c         ", 3,10, (/ 0, 0, 0,  6, 12, 12/),"     ") , &
            spgr_info_type( 66,"A M A A     ","-A 2a 2         ", 3,10, (/ 0, 0, 0, 12,  6, 12/),"cab  ") , &
            spgr_info_type( 66,"B A M B     ","-B 2b 2b        ", 3,10, (/ 0, 0, 0, 12, 12,  6/),"bca  ") , &
            spgr_info_type( 67,"C M M A     ","-C 2b 2         ", 3,10, (/ 0, 0, 0, 12,  6, 12/),"     ") , &
            spgr_info_type( 67,"C M M B     ","-C 2b 2b        ", 3,10, (/ 0, 0, 0,  6, 12, 12/),"ba-c ") , &
            spgr_info_type( 67,"A B M M     ","-A 2c 2c        ", 3,10, (/ 0, 0, 0, 12, 12,  6/),"cab  ") , &
            spgr_info_type( 67,"A C M M     ","-A 2 2c         ", 3,10, (/ 0, 0, 0, 12,  6, 12/),"-cba ") , &
            spgr_info_type( 67,"B M C M     ","-B 2 2c         ", 3,10, (/ 0, 0, 0,  6, 12, 12/),"bca  ") , &
            spgr_info_type( 67,"B M A M     ","-B 2c 2         ", 3,10, (/ 0, 0, 0, 12, 12,  6/),"a-cb ") , &
            spgr_info_type( 68,"C C C A:1   ","C 2 2 -1bc      ", 3,10, (/ 0, 0, 0,  6, 12, 12/),"1    ") , &
            spgr_info_type( 68,"C C C A     ","-C 2b 2bc       ", 3,10, (/ 0, 0, 0, 12,  6, 12/),"2    ") , &
            spgr_info_type( 68,"C C C B:1   ","C 2 2 -1bc      ", 3,10, (/ 0, 0, 0, 12,  6, 12/),"1ba-c") , &
            spgr_info_type( 68,"C C C B     ","-C 2b 2c        ", 3,10, (/ 0, 0, 0,  6, 12, 12/),"2ba-c") , &
            spgr_info_type( 68,"A B A A:1   ","A 2 2 -1ac      ", 3,10, (/ 0, 0, 0, 12, 12,  6/),"1cab ") , &
            spgr_info_type( 68,"A B A A     ","-A 2a 2c        ", 3,10, (/ 0, 0, 0, 12, 12,  6/),"2cab ") , &
            spgr_info_type( 68,"A C A A:1   ","A 2 2 -1ac      ", 3,10, (/ 0, 0, 0, 12,  6, 12/),"1-cba") , &
            spgr_info_type( 68,"A C A A     ","-A 2ac 2c       ", 3,10, (/ 0, 0, 0, 12,  6, 12/),"2-cba") , &
            spgr_info_type( 68,"B B C B:1   ","B 2 2 -1bc      ", 3,10, (/ 0, 0, 0, 12, 12,  6/),"1bca ") , &
            spgr_info_type( 68,"B B C B     ","-B 2bc 2b       ", 3,10, (/ 0, 0, 0,  6, 12, 12/),"2bca ") , &
            spgr_info_type( 68,"B B A B:1   ","B 2 2 -1bc      ", 3,10, (/ 0, 0, 0,  6, 12, 12/),"1a-cb") , &
            spgr_info_type( 68,"B B A B     ","-B 2b 2bc       ", 3,10, (/ 0, 0, 0, 12, 12,  6/),"2a-cb") , &
            spgr_info_type( 69,"F M M M     ","-F 2 2          ", 3,10, (/ 0, 0, 0,  6,  6, 12/),"     ") , &
            spgr_info_type( 70,"F D D D:1   ","F 2 2 -1d       ", 3,10, (/ 0, 0, 0,  3,  6, 24/),"1    ") , &
            spgr_info_type( 70,"F D D D     ","-F 2uv 2vw      ", 3,10, (/ 0,-3, 0,  3,  3, 24/),"2    ") , &
            spgr_info_type( 71,"I M M M     ","-I 2 2          ", 3,10, (/ 0, 0, 0,  6, 12, 12/),"     ") , &
            spgr_info_type( 72,"I B A M     ","-I 2 2c         ", 3,10, (/ 0, 0, 0,  6, 12, 12/),"     ") , &
            spgr_info_type( 72,"I M C B     ","-I 2a 2         ", 3,10, (/ 0, 0, 0, 12,  6, 12/),"cab  ") , &
            spgr_info_type( 72,"I C M A:1   ","I 2 2 -1b       ", 3,10, (/ 0, 0, 0, 12, 12,  6/),"     ") , &
            spgr_info_type( 72,"I C M A     ","-I 2b 2b        ", 3,10, (/ 0, 0, 0, 12, 12,  6/),"bca  ") , &
            spgr_info_type( 73,"I B C A     ","-I 2b 2c        ", 3,10, (/ 0, 0, 0,  6, 12, 12/),"     ") /)

       spgr_info(403:409)= (/                                           &
            spgr_info_type( 73,"I C A B     ","-I 2a 2b        ", 3,10, (/ 0, 0, 0, 12,  6, 12/),"ba-c ") , &
            spgr_info_type( 74,"I M M A     ","-I 2b 2         ", 3,10, (/ 0, 0, 0,  6,  6, 24/),"     ") , &
            spgr_info_type( 74,"I M M B     ","-I 2a 2a        ", 3,10, (/ 0, 0, 0,  6,  6, 24/),"ba-c ") , &
            spgr_info_type( 74,"I B M M     ","-I 2c 2c        ", 3,10, (/ 0, 0, 0, 24,  6,  6/),"cab  ") , &
            spgr_info_type( 74,"I C M M     ","-I 2 2b         ", 3,10, (/ 0, 0, 0, 24,  6,  6/),"-cba ") , &
            spgr_info_type( 74,"I M C M     ","-I 2 2a         ", 3,10, (/ 0, 0, 0,  6, 24,  6/),"bca  ") , &
            spgr_info_type( 74,"I M A M     ","-I 2c 2         ", 3,10, (/ 0, 0, 0,  6, 24,  6/),"a-cb ") /)

       !---- Tetragonal ----!
       spgr_info(410:439)= (/                                           &
            spgr_info_type( 75,"P 4         ","P 4             ", 4,11, (/ 0, 0, 0, 12, 12, 24/),"     ") , &
            spgr_info_type( 76,"P 41        ","P 4w            ", 4,11, (/ 0, 0, 0, 12, 12, 24/),"     ") , &
            spgr_info_type( 77,"P 42        ","P 4c            ", 4,11, (/ 0, 0, 0, 12, 12, 24/),"     ") , &
            spgr_info_type( 78,"P 43        ","P 4cw           ", 4,11, (/ 0, 0, 0, 12, 12, 24/),"     ") , &
            spgr_info_type( 79,"I 4         ","I 4             ", 4,11, (/ 0, 0, 0, 12, 12, 12/),"     ") , &
            spgr_info_type( 80,"I 41        ","I 4bw           ", 4,11, (/ 0, 0, 0, 12, 24,  6/),"     ") , &
            spgr_info_type( 81,"P -4        ","P -4            ", 4,12, (/ 0, 0, 0, 12, 12, 24/),"     ") , &
            spgr_info_type( 82,"I -4        ","I -4            ", 4,12, (/ 0, 0, 0, 12, 12, 12/),"     ") , &
            spgr_info_type( 83,"P 4/M       ","-P 4            ", 4,13, (/ 0, 0, 0, 12, 12, 12/),"     ") , &
            spgr_info_type( 84,"P 42/M      ","-P 4c           ", 4,13, (/ 0, 0, 0, 12, 12, 12/),"     ") , &
            spgr_info_type( 85,"P 4/N:1     ","P 4ab -1ab      ", 4,13, (/ 0, 0, 0, 12, 12, 12/),"1    ") , &
            spgr_info_type( 85,"P 4/N       ","-P 4a           ", 4,13, (/-6,-6, 0,  6,  6, 12/),"2    ") , &
            spgr_info_type( 86,"P 42/N:1    ","P 4n -1n        ", 4,13, (/ 0, 0, 0, 12, 24,  6/),"1    ") , &
            spgr_info_type( 86,"P 42/N      ","-P 4bc          ", 4,13, (/-6,-6, 0,  6,  6, 12/),"2    ") , &
            spgr_info_type( 87,"I 4/M       ","-I 4            ", 4,13, (/ 0, 0, 0, 12, 12,  6/),"     ") , &
            spgr_info_type( 88,"I 41/A:1    ","I 4bw -1bw      ", 4,13, (/ 0, 0, 0,  6,  6, 24/),"1    ") , &
            spgr_info_type( 88,"I 41/A      ","-I 4ad          ", 4,13, (/ 0, 0, 0,  6,  6, 24/),"2    ") , &
            spgr_info_type( 89,"P 4 2 2     ","P 4 2           ", 5,14, (/ 0, 0, 0, 12, 12, 12/),"     ") , &
            spgr_info_type( 90,"P 4 21 2    ","P 4ab 2ab       ", 5,14, (/ 0, 0, 0, 12, 12, 12/),"     ") , &
            spgr_info_type( 90,"C 4 2 21    ","C 4b 2          ", 5,14, (/ 0, 0, 0, 12, 12, 12/),"     ") , &
            spgr_info_type( 91,"P 41 2 2    ","P 4w 2c         ", 5,14, (/ 0, 0, 0, 24, 24,  3/),"     ") , &
            spgr_info_type( 92,"P 41 21 2   ","P 4abw 2nw      ", 5,14, (/ 0, 0, 0, 24, 24,  3/),"     ") , &
            spgr_info_type( 93,"P 42 2 2    ","P 4c 2          ", 5,14, (/ 0, 0, 0, 12, 24,  6/),"     ") , &
            spgr_info_type( 94,"P 42 21 2   ","P 4n 2n         ", 5,14, (/ 0, 0, 0, 12, 12, 12/),"     ") , &
            spgr_info_type( 95,"P 43 2 2    ","P 4cw 2c        ", 5,14, (/ 0, 0, 0, 24, 24,  3/),"     ") , &
            spgr_info_type( 96,"P 43 21 2   ","P 4nw 2abw      ", 5,14, (/ 0, 0, 0, 24, 24,  3/),"     ") , &
            spgr_info_type( 97,"I 4 2 2     ","I 4 2           ", 5,14, (/ 0, 0, 0, 12, 12,  6/),"     ") , &
            spgr_info_type( 98,"I 41 2 2    ","I 4bw 2bw       ", 5,14, (/ 0, 0, 0, 12, 24,  3/),"     ") , &
            spgr_info_type( 99,"P 4 M M     ","P 4 -2          ", 5,15, (/ 0, 0, 0, 12, 12, 24/),"     ") , &
            spgr_info_type(100,"P 4 B M     ","P 4 -2ab        ", 5,15, (/ 0, 0, 0, 12, 12, 24/),"     ") /)

       spgr_info(440:469)= (/                                           &
            spgr_info_type(101,"P 42 C M    ","P 4c -2c        ", 5,15, (/ 0, 0, 0, 12, 12, 24/),"     ") , &
            spgr_info_type(102,"P 42 N M    ","P 4n -2n        ", 5,15, (/ 0, 0, 0, 12, 12, 24/),"     ") , &
            spgr_info_type(103,"P 4 C C     ","P 4 -2c         ", 5,15, (/ 0, 0, 0, 12, 12, 12/),"     ") , &
            spgr_info_type(104,"P 4 N C     ","P 4 -2n         ", 5,15, (/ 0, 0, 0, 12, 12, 12/),"     ") , &
            spgr_info_type(105,"P 42 M C    ","P 4c -2         ", 5,15, (/ 0, 0, 0, 12, 12, 12/),"     ") , &
            spgr_info_type(106,"P 42 B C    ","P 4c -2ab       ", 5,15, (/ 0, 0, 0, 12, 12, 12/),"     ") , &
            spgr_info_type(107,"I 4 M M     ","I 4 -2          ", 5,15, (/ 0, 0, 0, 12, 12, 12/),"     ") , &
            spgr_info_type(108,"I 4 C M     ","I 4 -2c         ", 5,15, (/ 0, 0, 0, 12, 12, 12/),"     ") , &
            spgr_info_type(109,"I 41 M D    ","I 4bw -2        ", 5,15, (/ 0, 0, 0, 12, 12,  6/),"     ") , &
            spgr_info_type(110,"I 41 C D    ","I 4bw -2c       ", 5,15, (/ 0, 0, 0, 12, 12,  6/),"     ") , &
            spgr_info_type(111,"P -4 2 M    ","P -4 2          ", 5,16, (/ 0, 0, 0, 12, 12, 24/),"     ") , &
            spgr_info_type(112,"P -4 2 C    ","P -4 2c         ", 5,16, (/ 0, 0, 0, 12, 12, 12/),"     ") , &
            spgr_info_type(113,"P -4 21 M   ","P -4 2ab        ", 5,16, (/ 0, 0, 0, 12, 12, 24/),"     ") , &
            spgr_info_type(114,"P -4 21 C   ","P -4 2n         ", 5,16, (/ 0, 0, 0, 12, 12, 12/),"     ") , &
            spgr_info_type(115,"P -4 M 2    ","P -4 -2         ", 5,17, (/ 0, 0, 0, 12, 12, 12/),"     ") , &
            spgr_info_type(116,"P -4 C 2    ","P -4 -2c        ", 5,17, (/ 0, 0, 0, 12, 24,  6/),"     ") , &
            spgr_info_type(117,"P -4 B 2    ","P -4 -2ab       ", 5,17, (/ 0, 0, 0, 12, 12, 12/),"     ") , &
            spgr_info_type(117,"C -4 B 2    ","C -4 2b         ", 5,17, (/ 0, 0, 0, 12, 12, 12/),"     ") , &
            spgr_info_type(118,"P -4 N 2    ","P -4 -2n        ", 5,17, (/ 0, 0, 0, 12, 12,  6/),"     ") , &
            spgr_info_type(119,"I -4 M 2    ","I -4 -2         ", 5,17, (/ 0, 0, 0, 12, 12,  6/),"     ") , &
            spgr_info_type(120,"I -4 C 2    ","I -4 -2c        ", 5,17, (/ 0, 0, 0, 12, 12,  6/),"     ") , &
            spgr_info_type(121,"I -4 2 M    ","I -4 2          ", 5,16, (/ 0, 0, 0, 12, 12, 12/),"     ") , &
            spgr_info_type(122,"I -4 2 D    ","I -4 2bw        ", 5,16, (/ 0, 0, 0, 12, 24,  3/),"     ") , &
            spgr_info_type(122,"F -4 D 2    ","F -4 -2cd       ", 5,16, (/ 0, 0, 0, 12, 24,  3/),"     ") , &
            spgr_info_type(123,"P 4/M M M   ","-P 4 2          ", 5,18, (/ 0, 0, 0, 12, 12, 12/),"     ") , &
            spgr_info_type(124,"P 4/M C C   ","-P 4 2c         ", 5,18, (/ 0, 0, 0, 12, 12,  6/),"     ") , &
            spgr_info_type(125,"P 4/N B M:1 ","P 4 2 -1ab      ", 5,18, (/ 0, 0, 0, 12, 12, 12/),"1    ") , &
            spgr_info_type(125,"P 4/N B M   ","-P 4a 2b        ", 5,18, (/-6,-6, 0,  6,  6, 12/),"2    ") , &
            spgr_info_type(126,"P 4/N N C:1 ","P 4 2 -1n       ", 5,18, (/ 0, 0, 0, 12, 12,  6/),"1    ") , &
            spgr_info_type(126,"P 4/N N C   ","-P 4a 2bc       ", 5,18, (/-6,-6, 0,  6,  6,  6/),"2    ") /)

       spgr_info(470:494)= (/                                           &
            spgr_info_type(127,"P 4/M B M   ","-P 4 2ab        ", 5,18, (/ 0, 0, 0, 12, 12, 12/),"     ") , &
            spgr_info_type(128,"P 4/M N C   ","-P 4 2n         ", 5,18, (/ 0, 0, 0, 12, 12,  6/),"     ") , &
            spgr_info_type(129,"P 4/N M M:1 ","P 4ab 2ab -1ab  ", 5,18, (/ 0, 0, 0, 12, 12, 12/),"1    ") , &
            spgr_info_type(129,"P 4/N M M   ","-P 4a 2a        ", 5,18, (/-6,-6, 0,  6,  6, 12/),"2    ") , &
            spgr_info_type(130,"P 4/N C C:1 ","P 4ab 2n -1ab   ", 5,18, (/ 0, 0, 0, 12, 12,  6/),"1    ") , &
            spgr_info_type(130,"P 4/N C C   ","-P 4a 2ac       ", 5,18, (/-6,-6, 0,  6,  6,  6/),"2    ") , &
            spgr_info_type(131,"P 42/M M C  ","-P 4c 2         ", 5,18, (/ 0, 0, 0, 12, 12,  6/),"     ") , &
            spgr_info_type(132,"P 42/M C M  ","-P 4c 2c        ", 5,18, (/ 0, 0, 0, 12, 12,  6/),"     ") , &
            spgr_info_type(133,"P 42/N B C:1","P 4n 2c -1n     ", 5,18, (/ 0, 0, 0, 12, 12,  6/),"1    ") , &
            spgr_info_type(133,"P 42/N B C  ","-P 4ac 2b       ", 5,18, (/-6,-6, 0,  6,  6,  6/),"2    ") , &
            spgr_info_type(134,"P 42/N N M:1","P 4n 2 -1n      ", 5,18, (/ 0, 0, 0, 12, 24,  6/),"1    ") , &
            spgr_info_type(134,"P 42/N N M  ","-P 4ac 2bc      ", 5,18, (/-6,-6, 0,  6,  6, 12/),"2    ") , &
            spgr_info_type(135,"P 42/M B C  ","-P 4c 2ab       ", 5,18, (/ 0, 0, 0, 12, 12,  6/),"     ") , &
            spgr_info_type(136,"P 42/M N M  ","-P 4n 2n        ", 5,18, (/ 0, 0, 0, 12, 12, 12/),"     ") , &
            spgr_info_type(137,"P 42/N M C:1","P 4n 2n -1n     ", 5,18, (/ 0, 0, 0, 12, 12,  6/),"1    ") , &
            spgr_info_type(137,"P 42/N M C  ","-P 4ac 2a       ", 5,18, (/-6,-6, 0,  6,  6,  6/),"2    ") , &
            spgr_info_type(138,"P 42/N C M:1","P 4n 2ab -1n    ", 5,18, (/ 0, 0, 0,  6, 12, 24/),"1    ") , &
            spgr_info_type(138,"P 42/N C M  ","-P 4ac 2ac      ", 5,18, (/-6,-6, 0,  6,  6, 12/),"2    ") , &
            spgr_info_type(139,"I 4/M M M   ","-I 4 2          ", 5,18, (/ 0, 0, 0, 12, 12,  6/),"     ") , &
            spgr_info_type(139,"F 4/M M M   ","-F 4 2          ", 5,18, (/ 0, 0, 0, 12, 12,  6/),"     ") , &
            spgr_info_type(140,"I 4/M C M   ","-I 4 2c         ", 5,18, (/ 0, 0, 0, 12, 12,  6/),"     ") , &
            spgr_info_type(141,"I 41/A M D:1","I 4bw 2bw -1bw  ", 5,18, (/ 0, 0, 0, 12, 12,  3/),"1    ") , &
            spgr_info_type(141,"I 41/A M D  ","-I 4bd 2        ", 5,18, (/ 0,-6, 0, 12,  6,  3/),"2    ") , &
            spgr_info_type(142,"I 41/A C D:1","I 4bw 2aw -1bw  ", 5,18, (/ 0, 0, 0, 12, 12,  3/),"1    ") , &
            spgr_info_type(142,"I 41/A C D  ","-I 4bd 2c       ", 5,18, (/ 0,-6, 0, 12,  6,  3/),"2    ") /)

       !---- Trigonal/Rhombohedral ----!
       spgr_info(495:526)= (/                                           &
            spgr_info_type(143,"P 3         ","P 3             ", 8,19, (/ 0, 0, 0, 16, 16, 24/),"     ") , &
            spgr_info_type(144,"P 31        ","P 31            ", 8,19, (/ 0, 0, 0, 24, 24,  8/),"     ") , &
            spgr_info_type(145,"P 32        ","P 32            ", 8,19, (/ 0, 0, 0, 24, 24,  8/),"     ") , &
            spgr_info_type(146,"R 3         ","R 3             ", 8,19, (/ 0, 0, 0, 16, 16,  8/),"H    ") , &
            spgr_info_type(146,"R 3:R       ","P 3*            ", 6,19, (/ 0, 0, 0, 24, 24, 24/),"R    ") , &
            spgr_info_type(147,"P -3        ","-P 3            ", 8,20, (/ 0, 0, 0, 16, 16, 12/),"     ") , &
            spgr_info_type(148,"R -3        ","-R 3            ", 8,20, (/ 0, 0, 0, 16, 16,  4/),"H    ") , &
            spgr_info_type(148,"R -3:R      ","-P 3*           ", 6,20, (/ 0, 0, 0, 24, 24, 12/),"R    ") , &
            spgr_info_type(149,"P 3 1 2     ","P 3 2           ",10,24, (/ 0, 0, 0, 16, 16, 12/),"     ") , &
            spgr_info_type(150,"P 3 2 1     ","P 3 2""         ", 9,21, (/ 0, 0, 0, 16, 16, 12/),"     ") , &
            spgr_info_type(151,"P 31 1 2    ","P 31 2c (0 0 1) ",10,24, (/ 0, 0, 0, 24, 24,  4/),"     ") , &
            spgr_info_type(152,"P 31 2 1    ","P 31 2""        ", 9,21, (/ 0, 0, 0, 24, 24,  4/),"     ") , &
            spgr_info_type(153,"P 32 1 2    ","P 32 2c (0 0 -1)",10,24, (/ 0, 0, 0, 24, 24,  4/),"     ") , &
            spgr_info_type(154,"P 32 2 1    ","P 32 2""        ", 9,21, (/ 0, 0, 0, 24, 24,  4/),"     ") , &
            spgr_info_type(155,"R 3 2       ","R 3 2""         ", 9,21, (/ 0, 0, 0, 16, 16,  4/),"H    ") , &
            spgr_info_type(155,"R 3 2:R     ","P 3* 2          ", 7,21, (/ 0, 0, 0, 24, 24, 12/),"R    ") , &
            spgr_info_type(156,"P 3 M 1     ","P 3 -2""        ", 9,22, (/ 0, 0, 0, 16, 16, 24/),"     ") , &
            spgr_info_type(157,"P 3 1 M     ","P 3 -2          ",10,25, (/ 0, 0, 0, 16, 12, 24/),"     ") , &
            spgr_info_type(158,"P 3 C 1     ","P 3 -2""c       ", 9,22, (/ 0, 0, 0, 16, 16, 12/),"     ") , &
            spgr_info_type(159,"P 3 1 C     ","P 3 -2c         ",10,25, (/ 0, 0, 0, 16, 16, 12/),"     ") , &
            spgr_info_type(160,"R 3 M       ","R 3 -2""        ", 9,22, (/ 0, 0, 0, 16, 16,  8/),"H    ") , &
            spgr_info_type(160,"R 3 M:R     ","P 3* -2         ", 7,22, (/ 0, 0, 0, 24, 24, 24/),"R    ") , &
            spgr_info_type(161,"R 3 C       ","R 3 -2""c       ", 9,22, (/ 0, 0, 0, 16, 16,  4/),"H    ") , &
            spgr_info_type(161,"R 3 C:R     ","P 3* -2n        ", 7,22, (/ 0, 0, 0, 24, 24, 24/),"R    ") , &
            spgr_info_type(162,"P -3 1 M    ","-P 3 2          ",10,26, (/ 0, 0, 0, 16, 12, 12/),"     ") , &
            spgr_info_type(163,"P -3 1 C    ","-P 3 2c         ",10,26, (/ 0, 0, 0, 16, 16,  6/),"     ") , &
            spgr_info_type(164,"P -3 M 1    ","-P 3 2""        ", 9,23, (/ 0, 0, 0, 16,  8, 24/),"     ") , &
            spgr_info_type(165,"P -3 C 1    ","-P 3 2""c       ", 9,23, (/ 0, 0, 0, 16, 16,  6/),"     ") , &
            spgr_info_type(166,"R -3 M      ","-R 3 2""        ", 9,23, (/ 0, 0, 0, 16, 16,  4/),"H    ") , &
            spgr_info_type(166,"R -3 M:R    ","-P 3* 2         ", 7,23, (/ 0, 0, 0, 24, 24, 12/),"R    ") , &
            spgr_info_type(167,"R -3 C      ","-R 3 2""c       ", 9,23, (/ 0, 0, 0, 16, 16,  2/),"H    ") , &
            spgr_info_type(167,"R -3 C:R    ","-P 3* 2n        ", 7,23, (/ 6, 6, 6, 30, 30, 18/),"R    ") /)

       !---- Hexagonal ----!
       spgr_info(527:553)= (/                                           &
            spgr_info_type(168,"P 6         ","P 6             ",11,27, (/ 0, 0, 0, 16, 12, 24/),"     ") , &
            spgr_info_type(169,"P 61        ","P 61            ",11,27, (/ 0, 0, 0, 24, 24,  4/),"     ") , &
            spgr_info_type(170,"P 65        ","P 65            ",11,27, (/ 0, 0, 0, 24, 24,  4/),"     ") , &
            spgr_info_type(171,"P 62        ","P 62            ",11,27, (/ 0, 0, 0, 24, 24,  8/),"     ") , &
            spgr_info_type(172,"P 64        ","P 64            ",11,27, (/ 0, 0, 0, 24, 24,  8/),"     ") , &
            spgr_info_type(173,"P 63        ","P 6c            ",11,27, (/ 0, 0, 0, 16, 16, 12/),"     ") , &
            spgr_info_type(174,"P -6        ","P -6            ",11,28, (/ 0, 0, 0, 16, 16, 12/),"     ") , &
            spgr_info_type(175,"P 6/M       ","-P 6            ",11,29, (/ 0, 0, 0, 16, 12, 12/),"     ") , &
            spgr_info_type(176,"P 63/M      ","-P 6c           ",11,29, (/ 0, 0, 0, 16, 16,  6/),"     ") , &
            spgr_info_type(177,"P 6 2 2     ","P 6 2           ",12,30, (/ 0, 0, 0, 16, 12, 12/),"     ") , &
            spgr_info_type(178,"P 61 2 2    ","P 61 2 (0 0 -1) ",12,30, (/ 0, 0, 0, 24, 24,  2/),"     ") , &
            spgr_info_type(179,"P 65 2 2    ","P 65 2 (0 0 1)  ",12,30, (/ 0, 0, 0, 24, 24,  2/),"     ") , &
            spgr_info_type(180,"P 62 2 2    ","P 62 2c (0 0 1) ",12,30, (/ 0, 0, 0, 24, 24,  4/),"     ") , &
            spgr_info_type(181,"P 64 2 2    ","P 64 2c (0 0 -1)",12,30, (/ 0, 0, 0, 24, 24,  4/),"     ") , &
            spgr_info_type(182,"P 63 2 2    ","P 6c 2c         ",12,30, (/ 0, 0, 0, 16, 16,  3/),"     ") , &
            spgr_info_type(183,"P 6 M M     ","P 6 -2          ",12,31, (/ 0, 0, 0, 16,  8, 24/),"     ") , &
            spgr_info_type(184,"P 6 C C     ","P 6 -2c         ",12,31, (/ 0, 0, 0, 16, 12, 12/),"     ") , &
            spgr_info_type(185,"P 63 C M    ","P 6c -2         ",12,31, (/ 0, 0, 0, 16, 12, 12/),"     ") , &
            spgr_info_type(186,"P 63 M C    ","P 6c -2c        ",12,31, (/ 0, 0, 0, 16,  8, 24/),"     ") , &
            spgr_info_type(187,"P -6 M 2    ","P -6 2          ",12,33, (/ 0, 0, 0, 16, 16, 12/),"     ") , &
            spgr_info_type(188,"P -6 C 2    ","P -6c 2         ",12,33, (/ 0, 0, 0, 16, 16,  6/),"     ") , &
            spgr_info_type(189,"P -6 2 M    ","P -6 -2         ",12,32, (/ 0, 0, 0, 16, 12, 12/),"     ") , &
            spgr_info_type(190,"P -6 2 C    ","P -6c -2c       ",12,32, (/ 0, 0, 0, 16, 16,  6/),"     ") , &
            spgr_info_type(191,"P 6/M M M   ","-P 6 2          ",12,34, (/ 0, 0, 0, 16,  8, 12/),"     ") , &
            spgr_info_type(192,"P 6/M C C   ","-P 6 2c         ",12,34, (/ 0, 0, 0, 16, 12,  6/),"     ") , &
            spgr_info_type(193,"P 63/M C M  ","-P 6c 2         ",12,34, (/ 0, 0, 0, 16, 12,  6/),"     ") , &
            spgr_info_type(194,"P 63/M M C  ","-P 6c 2c        ",12,34, (/ 0, 0, 0, 16, 16,  6/),"     ") /)

       !---- Cubic ----!
       spgr_info(554:583)= (/                                           &
            spgr_info_type(195,"P 2 3       ","P 2 2 3         ",13,35, (/ 0, 0,  0, 24, 24, 12/),"     ") , &
            spgr_info_type(196,"F 2 3       ","F 2 2 3         ",13,35, (/ 0, 0, -6, 12, 12,  6/),"     ") , &
            spgr_info_type(197,"I 2 3       ","I 2 2 3         ",13,35, (/ 0, 0,  0, 24, 12, 12/),"     ") , &
            spgr_info_type(198,"P 21 3      ","P 2ac 2ab 3     ",13,35, (/ 0, 0,-12, 12, 12, 12/),"     ") , &
            spgr_info_type(199,"I 21 3      ","I 2b 2c 3       ",13,35, (/ 0, 0,  0, 12, 12, 12/),"     ") , &
            spgr_info_type(200,"P M -3      ","-P 2 2 3        ",13,36, (/ 0, 0,  0, 12, 12, 12/),"     ") , &
            spgr_info_type(200,"P M 3       ","-P 2 2 3        ",13,36, (/ 0, 0,  0, 12, 12, 12/),"     ") , &
            spgr_info_type(201,"P N -3:1    ","P 2 2 3 -1n     ",13,36, (/ 0, 0, 0, 24, 12,  12/),"1    ") , &
            spgr_info_type(201,"P N -3      ","-P 2ab 2bc 3    ",13,36, (/-6,-6,-6, 18,  6,   6/),"2    ") , &
            spgr_info_type(201,"P N 3       ","-P 2ab 2bc 3    ",13,36, (/-6,-6,-6, 18,  6,   6/),"2    ") , &
            spgr_info_type(202,"F M -3      ","-F 2 2 3        ",13,36, (/ 0, 0, 0, 12, 12,   6/),"     ") , &
            spgr_info_type(202,"F M 3       ","-F 2 2 3        ",13,36, (/ 0, 0, 0, 12, 12,   6/),"     ") , &
            spgr_info_type(203,"F D -3:1    ","F 2 2 3 -1d     ",13,36, (/ 0, 0,-6, 12,  6,   6/),"1    ") , &
            spgr_info_type(203,"F D -3      ","-F 2uv 2vw 3    ",13,36, (/-3,-3,-9,  9,  3,   3/),"2    ") , &
            spgr_info_type(203,"F D 3       ","-F 2uv 2vw 3    ",13,36, (/-3,-3,-9,  9,  3,   3/),"2    ") , &
            spgr_info_type(204,"I M -3      ","-I 2 2 3        ",13,36, (/ 0, 0, 0, 12, 12,  12/),"     ") , &
            spgr_info_type(204,"I M 3       ","-I 2 2 3        ",13,36, (/ 0, 0, 0, 12, 12,  12/),"     ") , &
            spgr_info_type(205,"P A -3      ","-P 2ac 2ab 3    ",13,36, (/ 0, 0, 0, 12, 12,  12/),"     ") , &
            spgr_info_type(205,"P A 3       ","-P 2ac 2ab 3    ",13,36, (/ 0, 0, 0, 12, 12,  12/),"     ") , &
            spgr_info_type(206,"I A -3      ","-I 2b 2c 3      ",13,36, (/ 0, 0, 0, 12, 12,   6/),"     ") , &
            spgr_info_type(206,"I A 3       ","-I 2b 2c 3      ",13,36, (/ 0, 0, 0, 12, 12,   6/),"     ") , &
            spgr_info_type(207,"P 4 3 2     ","P 4 2 3         ",14,37, (/ 0, 0, 0, 24, 12,  12/),"     ") , &
            spgr_info_type(208,"P 42 3 2    ","P 4n 2 3        ",14,37, (/ 0, 0,-6, 12, 12,   6/),"     ") , &
            spgr_info_type(209,"F 4 3 2     ","F 4 2 3         ",14,37, (/ 0, 0,-6, 12,  6,   6/),"     ") , &
            spgr_info_type(210,"F 41 3 2    ","F 4d 2 3        ",14,37, (/ 0,-3,-3, 12,  3,   3/),"     ") , &
            spgr_info_type(211,"I 4 3 2     ","I 4 2 3         ",14,37, (/ 0, 0, 0, 12, 12,   6/),"     ") , &
            spgr_info_type(212,"P 43 3 2    ","P 4acd 2ab 3    ",14,37, (/ 0, 0,-12, 12, 18,  6/),"     ") , &
            spgr_info_type(213,"P 41 3 2    ","P 4bd 2ab 3     ",14,37, (/-6, 0, 0, 12, 18,  12/),"     ") , &
            spgr_info_type(214,"I 41 3 2    ","I 4bd 2c 3      ",14,37, (/-9,-3,-3,  3,  3,   9/),"     ") , &
            spgr_info_type(215,"P -4 3 M    ","P -4 2 3        ",14,38, (/ 0, 0, 0, 24, 12,  12/),"     ") /)

       spgr_info(584:612)= (/                                           &
            spgr_info_type(216,"F -4 3 M    ","F -4 2 3        ",14,38, (/ 0, 0,-6, 12,  6,  6/),"     ") , &
            spgr_info_type(217,"I -4 3 M    ","I -4 2 3        ",14,38, (/ 0, 0, 0, 12, 12, 12/),"     ") , &
            spgr_info_type(218,"P -4 3 N    ","P -4n 2 3       ",14,38, (/ 0, 0, 0, 12, 12, 12/),"     ") , &
            spgr_info_type(219,"F -4 3 C    ","F -4c 2 3       ",14,38, (/ 0, 0,-6, 12,  6,  6/),"     ") , &
            spgr_info_type(220,"I -4 3 D    ","I -4bd 2c 3     ",14,38, (/ 6, 6, 0, 12, 12, 12/),"     ") , &
            spgr_info_type(221,"P M -3 M    ","-P 4 2 3        ",14,39, (/ 0, 0, 0, 12, 12, 12/),"     ") , &
            spgr_info_type(221,"P M 3 M     ","-P 4 2 3        ",14,39, (/ 0, 0, 0, 12, 12, 12/),"     ") , &
            spgr_info_type(222,"P N -3 N:1  ","P 4 2 3 -1n     ",14,39, (/ 0, 0, 0, 12, 12, 12/),"1    ") , &
            spgr_info_type(222,"P N -3 N    ","-P 4a 2bc 3     ",14,39, (/ 6, 6, 6, 18, 18, 18/),"2    ") , &
            spgr_info_type(222,"P N 3 N     ","-P 4a 2bc 3     ",14,39, (/ 6, 6, 6, 18, 18, 18/),"2    ") , &
            spgr_info_type(223,"P M -3 N    ","-P 4n 2 3       ",14,39, (/ 0, 0, 0, 12, 12,  6/),"     ") , &
            spgr_info_type(223,"P M 3 N     ","-P 4n 2 3       ",14,39, (/ 0, 0, 0, 12, 12,  6/),"     ") , &
            spgr_info_type(224,"P N -3 M:1  ","P 4n 2 3 -1n    ",14,39, (/ 0, 0,-6, 12, 12,  6/),"1    ") , &
            spgr_info_type(224,"P N -3 M    ","-P 4bc 2bc 3    ",14,39, (/ 6, 6, 0, 18, 18, 12/),"2    ") , &
            spgr_info_type(224,"P N 3 M     ","-P 4bc 2bc 3    ",14,39, (/ 6, 6, 0, 18, 18, 12/),"2    ") , &
            spgr_info_type(225,"F M -3 M    ","-F 4 2 3        ",14,39, (/ 0, 0, 0, 12,  6,  6/),"     ") , &
            spgr_info_type(225,"F M 3 M     ","-F 4 2 3        ",14,39, (/ 0, 0, 0, 12,  6,  6/),"     ") , &
            spgr_info_type(226,"F M -3 C    ","-F 4c 2 3       ",14,39, (/ 0, 0, 0, 12,  6,  6/),"     ") , &
            spgr_info_type(226,"F M 3 C     ","-F 4c 2 3       ",14,39, (/ 0, 0, 0, 12,  6,  6/),"     ") , &
            spgr_info_type(227,"F D -3 M:1  ","F 4d 2 3 -1d    ",14,39, (/ 0, 0,-3, 12,  3,  3/),"1    ") , &
            spgr_info_type(227,"F D -3 M    ","-F 4vw 2vw 3    ",14,39, (/-3,-3,-6,  9,  0,  0/),"2    ") , &
            spgr_info_type(227,"F D 3 M     ","-F 4vw 2vw 3    ",14,39, (/-3,-3,-6,  9,  0,  0/),"2    ") , &
            spgr_info_type(228,"F D -3 C:1  ","F 4d 2 3 -1cd   ",14,39, (/ 0, 0,-3, 12,  3,  3/),"1    ") , &
            spgr_info_type(228,"F D -3 C    ","-F 4cvw 2vw 3   ",14,39, (/-3,-3,-6,  9,  0,  0/),"2    ") , &
            spgr_info_type(228,"F D 3 C     ","-F 4cvw 2vw 3   ",14,39, (/-3,-3,-6,  9,  0,  0/),"2    ") , &
            spgr_info_type(229,"I M -3 M    ","-I 4 2 3        ",14,39, (/ 0, 0, 0, 12, 12,  6/),"     ") , &
            spgr_info_type(229,"I M 3 M     ","-I 4 2 3        ",14,39, (/ 0, 0, 0, 12, 12,  6/),"     ") , &
            spgr_info_type(230,"I A -3 D    ","-I 4bd 2c 3     ",14,39, (/-3,-3, 0,  3,  3,  6/),"     ") , &
            spgr_info_type(230,"I A 3 D     ","-I 4bd 2c 3     ",14,39, (/-3,-3, 0,  3,  3,  6/),"     ") /)

       return
    End Subroutine Set_Spgr_Info

    !!----
    !!---- Subroutine Set_System_Equiv()
    !!----
    !!----    Conversion Table    IT - ML - Kov - BC - Zak
    !!----
    !!--..   The information given in this file corresponds to that of TABLE 6 of
    !!--..   "Isotropy Subgroups of the 230 Crystallographic Space Groups", by
    !!--..   Harold T Stokes and Dorian M Hatch, World Scientific, Singapore (1988).
    !!--..
    !!--..   The transformation operators that take space group elements in the
    !!--..   International setting (International Tables of Crystallography, Hahn 1983)
    !!--..   to space-groups elements in the Miller and Love ( ML, 1967), Kovalev
    !!--..   (Kov,1986) Bradley anb Cracknell (BC, 1972) and Zak (Zak, 1969) settings.
    !!--..
    !!--..   In the international setting the basis vectors are always those of the
    !!--..   conventional unit cell. In the Trigonal system the primitive basis
    !!--..   vectors are in an obverse relationship given by (2/3 1/3 1/3),
    !!--..   (-1/3 1/3 1/3) and (-1/3, -2/3 1/3).
    !!--..   In ML the same basis vectors are chosen except that for trigonal/rhombohedral
    !!--..   system the reverse setting is adopted, so the primitive basis vectors
    !!--..   are: t1=(1/3 -1/3 1/3), t2=(1/3, 2/3 1/3) and t3=(2/3 1/3 1/3)
    !!--..   In Kovalev the a,b,c axes of the coordinate system are along the
    !!--..   conventional basis vectors of the lattice, however in the trigonal
    !!--..   system an hexagonal system is chosen so that the primitive basis vectors
    !!--..   are a1=(-1 -1 1/3), a2=(1 0 1/3) and a3=(0 1 1/3).
    !!--..   In the setting of BC the axes a,b,c of the coordinate system are chosen
    !!--..   to be the primitive basis vectors t1,t2,t3 as defined in their book.
    !!--..   The setting of Zak the basis vectors are as in the international setting,
    !!--..   but for trigonal/rhombohedral system the primitive basis vectors w.r.t. the selected
    !!--..   hexagonal coordinate system are given by: (1/3 2/3 1) (1/3 -1/3 1)
    !!--..   (-2/3 -1/3 1)
    !!--..
    !!--..   Symmetry and transformation operators of Space Groups can be given as
    !!--..   4 x 4 Seitz matrices or as a character string called Jones Faithful
    !!--..   representation. This last representation is that used in this file.
    !!--..
    !!--..   To transform a symmetry operator "gI" in the international setting into
    !!--..   a symmetry element "g" in one of the other settings, we simply perform
    !!--..   the following operation:  g = gT gI gT(-1), where gT is the transformation
    !!--..   given tabulated below.
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Set_System_Equiv()

       if (.not. allocated(system_equiv) ) allocate(system_equiv(230))

       system_equiv(1:10) = (/         &
          table_equiv_type("C1_1  ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("C1_i  ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("C1_2  ","z,x,y            ","-z,x,-y           ",        &
                      "-x,z,y                          "," z,x,y            "), &
          table_equiv_type("C2_2  ","z,x,y            ","-z,x,-y           ",        &
                      "-x,z,y                          "," z,x,y            "), &
          table_equiv_type("C3_2  ","z,x,y            ","-z,x,-y           ",        &
                      " z,-x+y,-x-y                    ","-x,z,y            "), &
          table_equiv_type("C1_s  ","z,x,y            ","-z,x,-y           ",        &
                      "-x,z,y                          "," z,x,y            "), &
          table_equiv_type("C2_s  ","z,x,y            ","-z,x,-y           ",        &
                      " z,-x,-y                        "," z,x,y            "), &
          table_equiv_type("C3_s  ","z,x,y            ","-z,x,-y           ",        &
                      " z,-x+y,-x-y                    ","-x,z,y            "), &
          table_equiv_type("C4_s  ","z,x,y            ","-z,x,-y           ",        &
                      " z,-x+y,-x-y                    ","-x,z,y            "), &
          table_equiv_type("C1_2h ","z,x,y            ","-z,x,-y           ",        &
                      "-x,z,y                          "," z,x,y            ") /)

       system_equiv(11:20)= (/         &
          table_equiv_type("C2_2h ","z,x,y            ","-z,x,-y+1/4       ",        &
                      "-x,z,y+1/4                      "," z,x,y            "), &
          table_equiv_type("C3_2h ","z,x,y            ","-z,x,-y           ",        &
                      " z,-x+y,-x-y                    ","-x,z,y            "), &
          table_equiv_type("C4_2h ","z,x,y            ","-z+1/4,x,-y       ",        &
                      " z-1/4,-x,-y                    ","-x,z,y            "), &
          table_equiv_type("C5_2h ","z,x,y            ","-z+1/4,x,-y+1/4   ",        &
                      " z-1/4,-x,-y+1/4                ","-x,z,y            "), &
          table_equiv_type("C6_2h ","z,x,y            ","-z+1/4,x,-y       ",        &
                      " z-1/4,-x+y,-x-y                ","-x,z,y            "), &
          table_equiv_type("D1_2  ","x,y,z            "," x,y,z            ",        &
                      "-y,x,z                          "," x,y,z            "), &
          table_equiv_type("D2_2  ","x,y,z            "," x,y,z            ",        &
                      "-y,x,z+1/4                      "," x,y,z            "), &
          table_equiv_type("D3_2  ","x,y,z            "," x,y,z            ",        &
                      "-y,x,z                          "," x,y,z            "), &
          table_equiv_type("D4_2  ","x,y,z            "," x,y,z            ",        &
                      "-x,-y,z                         "," x,y,z            "), &
          table_equiv_type("D5_2  ","x,y,z            "," x,y,z+1/4        ",        &
                      " x-y,x+y,z                      "," x,y,z            ")/)

       system_equiv(21:30)= (/         &
          table_equiv_type("D6_2  ","x,y,z            "," x,y,z            ",        &
                      " x-y,x+y,z                      "," x,y,z            "), &
          table_equiv_type("D7_2  ","x,y,z            "," x,y,z            ",        &
                      " x+y+z,-x-y+z,x-y-z             "," x,y,z            "), &
          table_equiv_type("D8_2  ","x,y,z            "," x,y,z            ",        &
                      " x+z,-y+z,x-y                   "," x,y,z            "), &
          table_equiv_type("D9_2  ","x,y,z            "," x,y,z            ",        &
                      "-y+z,-x+z,-x-y                  "," x,y,z            "), &
          table_equiv_type("C1_2v ","x,y,z            "," x,y,z            ",        &
                      "-y,x,z                          "," x,y,z            "), &
          table_equiv_type("C2_2v ","x,y,z            "," y,x,z            ",        &
                      "-y,x,z                          "," x,y,z            "), &
          table_equiv_type("C3_2v ","x,y,z            "," x,y,z            ",        &
                      "-y,x,z                          "," x,y,z            "), &
          table_equiv_type("C4_2v ","x,y,z            "," x+1/4,y,z        ",        &
                      "-x-1/4,-y,z                     "," x,y,z            "), &
          table_equiv_type("C5_2v ","x,y,z            "," x+1/4,y,z        ",        &
                      "-x-1/4,-y,z                     "," x,y,z            "), &
          table_equiv_type("C6_2v ","x,y,z            "," y+1/4,x,z        ",        &
                      "-y-1/4,x,z                      "," x,y,z            ") /)

       system_equiv(31:40)= (/         &
          table_equiv_type("C7_2v ","x,y,z            "," x,y,z            ",        &
                      "-x,-y,z                         "," x,y,z            "), &
          table_equiv_type("C8_2v ","x,y,z            "," x+1/4,y+1/4,z    ",        &
                      "-y-1/4,x+1/4,z                  "," x,y,z            "), &
          table_equiv_type("C9_2v ","x,y,z            "," x+1/4,y+1/4,z    ",        &
                      "-x-1/4,-y+1/4,z                 "," x,y,z            "), &
          table_equiv_type("C10_2v","x,y,z            "," x+1/4,y+1/4,z    ",        &
                      "-y-1/4,x+1/4,z                  "," x,y,z            "), &
          table_equiv_type("C11_2v","x,y,z            "," x,y,z            ",        &
                      " x-y,x+y,z                      "," x,y,z            "), &
          table_equiv_type("C12_2v","x,y,z            "," x,y,z            ",        &
                      "-x-y,x-y,z                      "," x,y,z            "), &
          table_equiv_type("C13_2v","x,y,z            "," x,y,z            ",        &
                      " x-y,x+y,z                      "," x,y,z            "), &
          table_equiv_type("C14_2v","-z,y,x           "," -z,y,x           ",        &
                      "-y+z,-y-z,x                     ","-y,-z,x           "), &
          table_equiv_type("C15_2v","-z,y,x           "," -z,y,x           ",        &
                      "-y+z,-y-z,x                     ","-y,-z,x           "), &
          table_equiv_type("C16_2v","-z,y,x           "," -z,y,x           ",        &
                      "-y+z,-y-z,x                     ","-y,-z,x           ") /)

       system_equiv(41:50)= (/         &
          table_equiv_type("C17_2v","-z,y,x           "," -z,y,x           ",        &
                      "-y+z,-y-z,x                     ","-y,-z,x           "), &
          table_equiv_type("C18_2v","x,y,z            "," x,y,z            ",        &
                      " x+y+z,-x-y+z,x-y-z             "," x,y,z            "), &
          table_equiv_type("C19_2v","x,y,z            "," x-1/8,y-1/8,z    ",        &
                      " x+y+z+1/2,-x-y+z-1/2,x-y-z-1/4 "," x,y,z            "), &
          table_equiv_type("C20_2v","x,y,z            "," x,y,z            ",        &
                      " x+z,-y+z,x-y                   "," x,y,z            "), &
          table_equiv_type("C21_2v","x,y,z            "," x,y,z            ",        &
                      " x+z,-y+z,x-y                   "," x,y,z            "), &
          table_equiv_type("C22_2v","x,y,z            "," x,y,z            ",        &
                      "-y+z,-x+z,-x-y                  "," x,y,z            "), &
          table_equiv_type("D1_2h ","x,y,z            "," x,y,z            ",        &
                      "-y,x,z                          "," x,y,z            "), &
          table_equiv_type("D2_2h ","x-1/4,y-1/4,z-1/4"," x-1/4,y-1/4,z-1/4",        &
                      "-y+1/4,x-1/4,z-1/4              "," x-1/4,y-1/4,z-1/4"), &
          table_equiv_type("D3_2h ","x,y,z            "," x,y,z+1/4        ",        &
                      "-y,x,z+1/4                      "," x,y,z            "), &
          table_equiv_type("D4_2h ","x-1/4,y-1/4,z    "," x-1/4,y-1/4,z    ",        &
                      "-y+1/4,x-1/4,z                  "," x-1/4,y-1/4,z    ") /)

       system_equiv(51:60)= (/         &
          table_equiv_type("D5_2h ","x,y,z            "," y,z,x            ",        &
                      "-y,z,-x                         "," x,y,z            "), &
          table_equiv_type("D6_2h ","x,y,z            "," z+1/4,x+1/4,y    ",        &
                      " z-1/4,x+1/4,y                  "," x,y,z            "), &
          table_equiv_type("D7_2h ","x,y,z            "," x-1/4,y,z        ",        &
                      "-x-1/4,-y,z                     "," x,y,z            "), &
          table_equiv_type("D8_2h ","x,y,z            "," y,z+1/4,x        ",        &
                      "-y,z+1/4,-x                     "," x,y,z            "), &
          table_equiv_type("D9_2h ","x,y,z            "," x,y,z            ",        &
                      "-y,x,z                          "," x,y,z            "), &
          table_equiv_type("D10_2h","x,y,z            "," x+1/4,y+1/4,z+1/4",        &
                      "-y-1/4,x+1/4,z+1/4              "," x,y,z            "), &
          table_equiv_type("D11_2h","x,y,z            "," -z,-y-1/4,-x     ",        &
                      "-z,y+1/4,x                      "," x,y,z            "), &
          table_equiv_type("D12_2h","x,y,z            "," x,y,z-1/4        ",        &
                      "-y,x,z+1/4                      "," x,y,z            "), &
          table_equiv_type("D13_2h","x-1/4,y-1/4,z    "," x-1/4,y-1/4,z    ",        &
                      "-y+1/4,x-1/4,z                  "," x-1/4,y-1/4,z+1/4"), &
          table_equiv_type("D14_2h","x,y,z            "," z+1/4,x,y+1/4    ",        &
                      " z-1/4,x,y+1/4                  "," x,y,z            ") /)

       system_equiv(61:70)= (/         &
          table_equiv_type("D15_2h","x,y,z            "," x,y,z            ",        &
                      "-x,-y,z                         "," x,y,z            "), &
          table_equiv_type("D16_2h","x,y,z            "," y+1/4,x+1/4,z    ",        &
                      "-y-1/4,x+1/4,z                  "," x,y,z            "), &
          table_equiv_type("D17_2h","x,y,z            "," y,x,z            ",        &
                      " x-y,x+y,z                      "," x,y,z            "), &
          table_equiv_type("D18_2h","x,y,z            "," y,x+1/4,z        ",        &
                      " x-y+1/4,x+y+1/4,z              "," x,y,z            "), &
          table_equiv_type("D19_2h","x,y,z            "," x,y,z            ",        &
                      " x-y,x+y,z                      "," x,y,z            "), &
          table_equiv_type("D20_2h","x,y,z            "," x,y,z+1/4        ",        &
                      " x-y,x+y,z+1/4                  "," x,y,z            "), &
          table_equiv_type("D21_2h","x,y,z            "," x+1/4,y,z        ",        &
                      " x-y+1/4,x+y+1/4,z              "," x,y,z            "), &
          table_equiv_type("D22_2h","x,y-1/4,z-1/4    "," x,y-1/4,z-1/4    ",        &
                      " x-y+1/4,x+y-1/4,z-1/4          "," x,y-1/4,z-1/4    "), &
          table_equiv_type("D23_2h","x,y,z            "," x,y,z            ",        &
                      " x+y+z,-x-y+z,x-y-z             "," x,y,z            "), &
          table_equiv_type("D24_2h","x-7/8,y-7/8,z-7/8"," x-7/8,y-7/8,z-7/8",        &
                      " x+y+z-15/8,-x-y+z+5/8,x-y-z+5/8"," x-7/8,y-7/8,z-7/8") /)

       system_equiv(71:80)= (/         &
          table_equiv_type("D25_2h","x,y,z            "," x,y,z            ",        &
                      " x+z,-y+z,x-y                   "," x,y,z            "), &
          table_equiv_type("D26_2h","x,y,z            "," x,y,z-1/4        ",        &
                      " x+z+1/4,-y+z+1/4,x-y           "," x,y,z            "), &
          table_equiv_type("D27_2h","x,y,z            "," x,y,z            ",        &
                      " x+z+1/2,-y+z,x-y               "," x,y,z            "), &
          table_equiv_type("D28_2h","x,y,z            "," x,y,z+1/4        ",        &
                      " x+z+1/4,-y+z-1/4,x-y           "," x,y,z            "), &
          table_equiv_type("C1_4  ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("C2_4  ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("C3_4  ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("C4_4  ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("C5_4  ","x,y,z            "," x,y,z            ",        &
                      " y+z,x+z,x+y                    "," x,y,z            "), &
          table_equiv_type("C6_4  ","x,y,z            "," x,y,z            ",        &
                      " y+z,x+z,x+y                    "," x,y,z            ") /)

       system_equiv(81:90)= (/         &
          table_equiv_type("S1_4  ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("S2_4  ","x,y,z            "," x,y,z            ",        &
                      " y+z,x+z,x+y                    "," x,y,z            "), &
          table_equiv_type("C1_4h ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("C2_4h ","x,y,z            "," x,y,z+1/4        ",        &
                      " x,y,z+1/4                      "," x,y,z            "), &
          table_equiv_type("C3_4h ","x-3/4,y-1/4,z    "," x-3/4,y-1/4,z    ",        &
                      " x-3/4,y-1/4,z                  "," x-3/4,y-1/4,z    "), &
          table_equiv_type("C4_4h ","x-3/4,y-3/4,z-3/4"," x-3/4,y-3/4,z-3/4",        &
                      " x-3/4,y-3/4,z-3/4              "," x-3/4,y-3/4,z-3/4"), &
          table_equiv_type("C5_4h ","x,y,z            "," x,y,z            ",        &
                      " y+z,x+z,x+y                    "," x,y,z            "), &
          table_equiv_type("C6_4h ","x,y-3/4,z-7/8    "," x,y-3/4,z-7/8    ",        &
                      " y+z-13/8,x+z-7/8,x+y-3/4       "," x,y-3/4,z-7/8    "), &
          table_equiv_type("D1_4  ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("D2_4  ","x,y,z            "," x,y-1/2,z        ",        &
                      " x+1/2,y,z                      "," x,y,z            ") /)

       system_equiv(91:100) = (/         &
          table_equiv_type("D3_4  ","x,y,z            "," x,y,z+1/4        ",        &
                      " x,y,z+1/4                      "," x,y,z            "), &
          table_equiv_type("D4_4  ","x,y,z            "," x,y-1/2,z+1/8    ",        &
                      " x+1/2,y,z+1/8                  "," x,y,z            "), &
          table_equiv_type("D5_4  ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("D6_4  ","x,y,z            "," x,y+1/2,z+1/4    ",        &
                      " x+1/2,y,z+1/4                  "," x,y,z            "), &
          table_equiv_type("D7_4  ","x,y,z            "," x,y,z+1/4        ",        &
                      " x,y,z+1/4                      "," x,y,z            "), &
          table_equiv_type("D8_4  ","x,y,z            "," x,y-1/2,z-1/8    ",        &
                      " x+1/2,y,z+3/8                  "," x,y,z            "), &
          table_equiv_type("D9_4  ","x,y,z            "," x,y,z            ",        &
                      " y+z,x+z,x+y                    "," x,y,z            "), &
          table_equiv_type("D10_4 ","x,y,z            "," x,y,z            ",        &
                      " y+z+1/8,x+z+1/8,x+y            "," x,y,z            "), &
          table_equiv_type("C1_4v ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("C2_4v ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            ") /)

       system_equiv(101:110)= (/         &
          table_equiv_type("C3_4v ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("C4_4v ","x,y,z            "," x,y-1/2,z        ",        &
                      " x+1/2,y,z                      "," x,y,z            "), &
          table_equiv_type("C5_4v ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("C6_4v ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("C7_4v ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("C8_4v ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("C9_4v ","x,y,z            "," x,y,z            ",        &
                      " y+z,x+z,x+y                    "," x,y,z            "), &
          table_equiv_type("C10_4v","x,y,z            "," x,y,z            ",        &
                      " y+z,x+z,x+y                    "," x,y,z            "), &
          table_equiv_type("C11_4v","x,y,z            "," x,y,z            ",        &
                      " y+z,x+z,x+y                    "," x,y,z            "), &
          table_equiv_type("C12_4v","x,y,z            "," x,y,z            ",        &
                      " y+z,x+z,x+y                    "," x,y,z            ") /)

       system_equiv(111:120)= (/         &
          table_equiv_type("D1_2d ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("D2_2d ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("D3_2d ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("D4_2d ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("D5_2d ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("D6_2d ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("D7_2d ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("D8_2d ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("D9_2d ","x,y,z            "," x,y,z            ",        &
                      " y+z,x+z,x+y                    "," x,y,z            "), &
          table_equiv_type("D10_2d","x,y,z            "," x,y,z            ",        &
                      " y+z,x+z,x+y                    "," x,y,z            ")  /)

       system_equiv(121:130)= (/         &
          table_equiv_type("D11_2d","x,y,z            "," x,y,z            ",        &
                      " y+z,x+z,x+y                    "," x,y,z            "), &
          table_equiv_type("D12_2d","x,y,z            "," x+1/2,y,z+1/4    ",        &
                      " x+z,-y+z,x-y                   "," x,y,z            "), &
          table_equiv_type("D1_4h ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("D2_4h ","x,y,z            "," x,y,z-1/4        ",        &
                      " x,y,z+1/4                      "," x,y,z            "), &
          table_equiv_type("D3_4h ","x-3/4,y-3/4,z    "," x-3/4,y-3/4,z    ",        &
                      " x-1/4,y-3/4,z                  "," x-3/4,y-3/4,z    "), &
          table_equiv_type("D4_4h ","x-3/4,y-3/4,z-3/4"," x-3/4,y-3/4,z-3/4",        &
                      " x-1/4,y-3/4,z-3/4              "," x-3/4,y-3/4,z-3/4"), &
          table_equiv_type("D5_4h ","x,y,z            "," x,y,z            ",        &
                      " x+1/2,y,z                      "," x,y,z            "), &
          table_equiv_type("D6_4h ","x,y,z            "," x,y,z+1/4        ",        &
                      " x+1/2,y,z+1/4                  "," x,y,z            "), &
          table_equiv_type("D7_4h ","x-3/4,y-1/4,z    "," x-3/4,y+1/4,z    ",        &
                      " x-1/4,y-1/4,z                  "," x-3/4,y-1/4,z    "), &
          table_equiv_type("D8_4h ","x-3/4,y-1/4,z    "," x-3/4,y+1/4,z+1/4",        &
                      " x-1/4,y-1/4,z+1/4              "," x,y,z            ") /)

       system_equiv(131:140)= (/         &
          table_equiv_type("D9_4d ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("D10_4d","x,y,z            "," x,y,z-1/4        ",        &
                      " x,y,z+1/4                      "," x,y,z            "), &
          table_equiv_type("D11_4d","x-3/4,y-1/4,z-3/4"," x-3/4,y+1/4,z-1/2",        &
                      " x-3/4,y-1/4,z-1/2              "," x,y,z            "), &
          table_equiv_type("D12_4d","x-3/4,y-1/4,z-3/4"," x-3/4,y+1/4,z-3/4",        &
                      " x-3/4,y-1/4,z-3/4              "," x-3/4,y-1/4,z-3/4"), &
          table_equiv_type("D13_4d","x,y,z            "," x,y,z            ",        &
                      " x+1/2,y,z                      "," x,y,z            "), &
          table_equiv_type("D14_4d","x,y,z            "," x,y+1/2,z+1/4    ",        &
                      " x,y,z+1/4                      "," x+1/2,y,z        "), &
          table_equiv_type("D15_4d","x-3/4,y-1/4,z-3/4"," x-3/4,y+1/4,z-1/2",        &
                      " x-1/4,y-1/4,z-1/2              "," x,y,z            "), &
          table_equiv_type("D16_4d","x-3/4,y-1/4,z-3/4"," x-3/4,y+1/4,z-3/4",        &
                      " x-1/4,y-1/4,z-3/4              "," x,y,z            "), &
          table_equiv_type("D17_4d","x,y,z            "," x,y,z            ",        &
                      " y+z,x+z,x+y                    "," x,y,z            "), &
          table_equiv_type("D18_4d","x,y,z            "," x,y,z+1/4        ",        &
                      " y+z+1/4,x+z+3/4,x+y+1/2        "," x,y,z            ") /)

       system_equiv(141:150)= (/         &
          table_equiv_type("D19_4d","x,y-1/4,z-7/8    "," x,y-1/4,z-7/8    ",        &
                      " y+z-3/4,x+z-3/4,x+y            "," x,y-1/4,z-7/8    "), &
          table_equiv_type("D20_4d","x,y-1/4,z-7/8    "," x,y-1/4,z-9/8    ",        &
                      " y+z,x+z-1/2,x+y+1/2            "," x,y,z            "), &
          table_equiv_type("C1_3  ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("C2_3  ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("C3_3  ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("C4_3  ","y,-x+y,z         ","-2x+y,-x-y,z      ",        &
                      " x+z,-x+y+z,-y+z                "," y,-x+y,3z        "), &
          table_equiv_type("C1_3i ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("C2_3i ","y,-x+y,z         ","-2x+y,-x-y,z      ",        &
                      " x+z,-x+y+z,-y+z                "," y,-x+y,3z        "), &
          table_equiv_type("D1_3  ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("D2_3  ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            ") /)

       system_equiv(151:160)= (/         &
          table_equiv_type("D3_3  ","x,y,z-1/6        "," x,y,z+1/6        ",        &
                      " x,y,z+1/6                      "," x,y,z+1/6        "), &
          table_equiv_type("D4_3  ","x,y,z            "," x,y,z+1/3        ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("D5_3  ","x,y,z-5/6        "," x,y,z+1/3        ",        &
                      " x,y,z-1/6                      "," x,y,z-1/6        "), &
          table_equiv_type("D6_3  ","x,y,z-1/6        "," x,y,z+1/6        ",        &
                      " x,y,z+1/2                      "," x,y,z+1/2        "), &
          table_equiv_type("D7_3  ","y,-x+y,z         ","-2x+y,-x-y,z      ",        &
                      " x+z,-x+y+z,-y+z                "," y,-x+y,3z        "), &
          table_equiv_type("C1_3v ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("C2_3v ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("C3_3v ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("C4_3v ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("C5_3v ","y,-x+y,z         ","-2x+y,-x-y,z      ",        &
                      " x+z,-x+y+z,-y+z                "," y,-x+y,3z        ")/)

       system_equiv(161:170)= (/         &
          table_equiv_type("C6_3v ","y,-x+y,z         ","-2x+y,-x-y,z      ",        &
                      " x+z,-x+y+z,-y+z                "," y,-x+y,3z        "), &
          table_equiv_type("D1_3d ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("D2_3d ","x,y,z            "," x,y,z+1/4        ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("D3_3d ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("D4_3d ","x,y,z            "," x,y,z+1/4        ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("D5_3d ","y,-x+y,z         ","-2x+y,-x-y,z      ",        &
                      " x+z,-x+y+z,-y+z                "," y,-x+y,3z        "), &
          table_equiv_type("D6_3d ","y,-x+y,z         ","-2x+y,-x-y,z      ",        &
                      " x+z,-x+y+z,-y+z                "," y,-x+y,3z        "), &
          table_equiv_type("C1_6  ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("C2_6  ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("C3_6  ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            ") /)

       system_equiv(171:180)= (/         &
          table_equiv_type("C4_6  ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("C5_6  ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("C6_6  ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("C7_6  ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("C1_6h ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("C2_6h ","x,y,z            "," x,y,z            ",        &
                      " x,y,z+1/4                      "," x,y,z            "), &
          table_equiv_type("D1_6  ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("D2_6  ","x,y,z            "," x,y,z+1/6        ",        &
                      " x,y,z+1/4                      "," x,y,z            "), &
          table_equiv_type("D3_6  ","x,y,z            "," x,y,z+1/3        ",        &
                      " x,y,z+1/4                      "," x,y,z            "), &
          table_equiv_type("D4_6  ","x,y,z            "," x,y,z+1/3        ",        &
                      " x,y,z                          "," x,y,z            ") /)

       system_equiv(181:190)= (/         &
          table_equiv_type("D5_6  ","x,y,z            "," x,y,z-1/3        ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("D6_6  ","x,y,z            "," x,y,z            ",        &
                      " x,y,z+1/4                      "," x,y,z            "), &
          table_equiv_type("C1_6v ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("C2_6v ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("C3_6v ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("C4_6v ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("D1_3h ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("D2_3h ","x,y,z            "," x,y,z            ",        &
                      " x,y,z+1/4                      "," x,y,z            "), &
          table_equiv_type("D3_3h ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("D4_3h ","x,y,z            "," x,y,z            ",        &
                      " x,y,z+1/4                      "," x,y,z            ") /)

       system_equiv(191:200)= (/         &
          table_equiv_type("D1_6h ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("D2_6h ","x,y,z            "," x,y,z-1/4        ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("D3_6h ","x,y,z            "," x,y,z-1/4        ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("D4_6h ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("T1    ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("T2    ","x,y,z            "," x,y,z            ",        &
                      "-x+y+z,x-y+z,x+y-z              "," x,y,z            "), &
          table_equiv_type("T3    ","x,y,z            "," x,y,z            ",        &
                      " y+z,x+z,x+y                    "," x,y,z            "), &
          table_equiv_type("T4    ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("T5    ","x,y,z            "," x,y,z            ",        &
                      " y+z,x+z,x+y                    "," x,y,z            "), &
          table_equiv_type("T1_h  ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            ") /)

       system_equiv(201:210)= (/         &
          table_equiv_type("T2_h  ","x-3/4,y-3/4,z-3/4"," x-3/4,y-3/4,z-3/4",        &
                      " x-3/4,y-3/4,z-3/4              "," x-3/4,y-3/4,z-3/4"), &
          table_equiv_type("T3_h  ","x,y,z            "," x,y,z            ",        &
                      "-x+y+z,x-y+z,x+y-z              "," x,y,z            "), &
          table_equiv_type("T4_h  ","x-7/8,y-7/8,z-7/8"," x-7/8,y-7/8,z-7/8",        &
                      "-x+y+z-7/8,x-y+z-7/8,x+y-z-7/8  "," x-7/8,y-7/8,z-7/8"), &
          table_equiv_type("T5_h  ","x,y,z            "," x,y,z            ",        &
                      " y+z,x+z,x+y                    "," x,y,z            "), &
          table_equiv_type("T6_h  ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("T7_h  ","x,y,z            "," x,y,z            ",        &
                      " y+z,x+z,x+y                    "," x,y,z            "), &
          table_equiv_type("O1    ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("O2    ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("O3    ","x,y,z            "," x,y,z            ",        &
                      "-x+y+z,x-y+z,x+y-z              "," x,y,z            "), &
          table_equiv_type("O4    ","x,y,z            "," x,y,z            ",        &
                      "-x+y+z,x-y+z,x+y-z              "," x,y,z            ") /)

       system_equiv(211:220)= (/         &
          table_equiv_type("O5    ","x,y,z            "," x,y,z            ",        &
                      " y+z,x+z,x+y                    "," x,y,z            "), &
          table_equiv_type("O6    ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("O7    ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("O8    ","x,y,z            "," x,y,z            ",        &
                      " y+z,x+z,x+y                    "," x,y,z            "), &
          table_equiv_type("T1_d  ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("T2_d  ","x,y,z            "," x,y,z            ",        &
                      "-x+y+z,x-y+z,x+y-z              "," x,y,z            "), &
          table_equiv_type("T3_d  ","x,y,z            "," x,y,z            ",        &
                      " y+z,x+z,x+y                    "," x,y,z            "), &
          table_equiv_type("T4_d  ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("T5_d  ","x,y,z            "," x,y,z            ",        &
                      "-x+y+z,x-y+z,x+y-z              "," x,y,z            "), &
          table_equiv_type("T6_d  ","x,y,z            "," x,y,z            ",        &
                      " y+z,x+z,x+y                    "," x,y,z            ") /)

       system_equiv(221:230)= (/         &
          table_equiv_type("O1_h  ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("O2_h  ","x-3/4,y-3/4,z-3/4"," x-3/4,y-3/4,z-3/4",        &
                      " x-3/4,y-3/4,z-3/4              "," x-3/4,y-3/4,z-3/4"), &
          table_equiv_type("O3_h  ","x,y,z            "," x,y,z            ",        &
                      " x,y,z                          "," x,y,z            "), &
          table_equiv_type("O4_h  ","x-3/4,y-3/4,z-3/4"," x-3/4,y-3/4,z-3/4",        &
                      " x-3/4,y-3/4,z-3/4              "," x-3/4,y-3/4,z-3/4"), &
          table_equiv_type("O5_h  ","x,y,z            "," x,y,z            ",        &
                      "-x+y+z,x-y+z,x+y-z              "," x,y,z            "), &
          table_equiv_type("O6_h  ","x,y,z            "," x-1/4,y-1/4,z-1/4",        &
                      "-x+y+z+1/4,x-y+z+1/4,x+y-z+1/4  "," x,y,z            "), &
          table_equiv_type("O7_h  ","x,y,z            "," x+1/8,y+1/8,z+1/8",        &
                      "-x+y+z+1/8,x-y+z+1/8,x+y-z+1/8  "," x+1/8,y+1/8,z+1/8"), &
          table_equiv_type("O8_h  ","x,y,z            "," x+3/8,y+3/8,z+3/8",        &
                      "-x+y+z+3/8,x-y+z+3/8,x+y-z+3/8  "," x+3/8,y+3/8,z+3/8"), &
          table_equiv_type("O9_h  ","x,y,z            "," x,y,z            ",        &
                      " y+z,x+z,x+y                    "," x,y,z            "), &
          table_equiv_type("O10_h ","x,y,z            "," x,y,z            ",        &
                      " y+z,x+z,x+y                    "," x,y,z            ") /)

       return
    End Subroutine Set_System_Equiv

    !!----
    !!---- Subroutine Set_Wyckoff_Info()
    !!----
    !!----    Set Information on Wyckoff_info array
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Set_Wyckoff_Info()

       if (.not. allocated(wyckoff_info) ) allocate(wyckoff_info(273) )

       wyckoff_info(  1)= wyck_info_type("P 1         ", 0,     &
                    (/"               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(  2)= wyck_info_type("P -1        ", 8,     &
                    (/"0,0,0          ", "0,0,1/2        ", "0,1/2,0        ",    &
                      "1/2,0,0        ", "1/2,1/2,0      ", "1/2,0,1/2      ",    &
                      "0,1/2,1/2      ", "1/2,1/2,1/2    ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(  3)= wyck_info_type("P 2         ", 4,     &
                    (/"0,y,0          ", "0,y,1/2        ", "1/2,y,0        ",    &
                      "1/2,y,1/2      ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(  4)= wyck_info_type("P 21        ", 0,     &
                    (/"               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(  5)= wyck_info_type("C 2         ", 2,     &
                    (/"0,y,0          ", "0,y,1/2        ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(  6)= wyck_info_type("A 2         ", 2,     &
                    (/"0,y,0          ", "1/2,y,1/2      ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(  7)= wyck_info_type("I 2         ", 2,     &
                    (/"0,y,0          ", "1/2,y,0        ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(  8)= wyck_info_type("P M         ", 2,     &
                    (/"x,0,z          ", "x,1/2,z        ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(  9)= wyck_info_type("P C         ", 0,     &
                    (/"               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 10)= wyck_info_type("C M         ", 1,     &
                    (/"x,0,z          ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 11)= wyck_info_type("A M         ", 1,     &
                    (/"x,0,z          ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 12)= wyck_info_type("I M         ", 1,     &
                    (/"x,0,z          ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 13)= wyck_info_type("C C         ", 0,     &
                    (/"               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 14)= wyck_info_type("P 2/M       ",14,     &
                    (/"0,0,0          ", "0,1/2,0        ", "0,0,1/2        ",    &
                      "1/2,0,0        ", "1/2,1/2,0      ", "0,1/2,1/2      ",    &
                      "1/2,0,1/2      ", "1/2,1/2,1/2    ", "0,y,0          ",    &
                      "1/2,y,0        ", "0,y,1/2        ", "1/2,y,1/2      ",    &
                      "x,0,z          ", "x,1/2,z        ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 15)= wyck_info_type("P 21/M      ", 5,     &
                    (/"0,0,0          ", "1/2,0,0        ", "0,0,1/2        ",    &
                      "1/2,0,1/2      ", "x,1/4,z        ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 16)= wyck_info_type("C 2/M       ", 9,     &
                    (/"0,0,0          ", "0,1/2,0        ", "0,0,1/2        ",    &
                      "0,1/2,1/2      ", "1/4,1/4,0      ", "1/4,1/4,1/2    ",    &
                      "0,y,0          ", "0,y,1/2        ", "x,0,z          ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 17)= wyck_info_type("A 2/M       ", 9,     &
                    (/"0,0,0          ", "0,1/2,0        ", "1/2,0,1/2      ",    &
                      "1/2,1/2,1/2    ", "0,1/4,1/4      ", "1/2,1/4,3/4    ",    &
                      "0,y,0          ", "1/2,y,1/2      ", "x,0,z          ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 18)= wyck_info_type("I 2/M       ", 9,     &
                    (/"0,0,0          ", "0,1/2,0        ", "1/2,0,0        ",    &
                      "1/2,1/2,0      ", "3/4,1/4,3/4    ", "1/4,1/4,3/4    ",    &
                      "0,y,0          ", "1/2,y,0        ", "x,0,z          ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 19)= wyck_info_type("P 2/C       ", 6,     &
                    (/"0,0,0          ", "1/2,1/2,0      ", "0,1/2,0        ",    &
                      "1/2,0,0        ", "0,y,1/4        ", "1/2,y,1/4      ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 20)= wyck_info_type("P 2/N       ", 6,     &
                    (/"0,0,0          ", "0,1/2,1/2      ", "0,1/2,0        ",    &
                      "0,0,1/2        ", "3/4,y,3/4      ", "3/4,y,1/4      ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 21)= wyck_info_type("P 2/A       ", 6,     &
                    (/"0,0,0          ", "1/2,1/2,1/2    ", "0,1/2,0        ",    &
                      "1/2,0,1/2      ", "1/4,y,0        ", "3/4,y,1/2      ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 22)= wyck_info_type("P 21/C      ", 4,     &
                    (/"0,0,0          ", "1/2,0,0        ", "0,0,1/2        ",    &
                      "1/2,0,1/2      ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 23)= wyck_info_type("P 21/N      ", 4,     &
                    (/"0,0,0          ", "0,0,1/2        ", "1/2,0,1/2      ",    &
                      "1/2,0,0        ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 24)= wyck_info_type("P 21/A      ", 4,     &
                    (/"0,0,0          ", "1/2,0,1/2      ", "1/2,0,0        ",    &
                      "0,0,1/2        ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 25)= wyck_info_type("C 2/C       ", 5,     &
                    (/"0,0,0          ", "0,1/2,0        ", "1/4,1/4,0      ",    &
                      "1/4,1/4,1/2    ", "0,y,1/4        ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 26)= wyck_info_type("A 2/N       ", 5,     &
                    (/"0,0,0          ", "0,1/2,0        ", "0,1/4,1/4      ",    &
                      "1/2,1/4,3/4    ", "3/4,y,3/4      ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 27)= wyck_info_type("I 2/A       ", 5,     &
                    (/"0,0,0          ", "0,1/2,0        ", "3/4,1/4,3/4    ",    &
                      "1/4,1/4,3/4    ", "1/4,y,0        ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 28)= wyck_info_type("P 2 2 2     ",20,     &
                    (/"0,0,0          ", "1/2,0,0        ", "0,1/2,0        ",    &
                      "0,0,1/2        ", "1/2,1/2,0      ", "1/2,0,1/2      ",    &
                      "0,1/2,1/2      ", "1/2,1/2,1/2    ", "x,0,0          ",    &
                      "x,0,1/2        ", "x,1/2,0        ", "x,1/2,1/2      ",    &
                      "0,y,0          ", "0,y,1/2        ", "1/2,y,0        ",    &
                      "1/2,y,1/2      ", "0,0,z          ", "1/2,0,z        ",    &
                      "0,1/2,z        ", "1/2,1/2,z      ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 29)= wyck_info_type("P 2 2 21    ", 4,     &
                    (/"x,0,0          ", "x,1/2,0        ", "0,y,1/4        ",    &
                      "1/2,y,1/4      ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 30)= wyck_info_type("P 21 21 2   ", 2,     &
                    (/"0,0,z          ", "0,1/2,z        ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 31)= wyck_info_type("P 21 21 21  ", 0,     &
                    (/"               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 32)= wyck_info_type("C 2 2 21    ", 2,     &
                    (/"x,0,0          ", "0,y,1/4        ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 33)= wyck_info_type("C 2 2 2     ",11,     &
                    (/"0,0,0          ", "0,1/2,0        ", "1/2,0,1/2      ",    &
                      "0,0,1/2        ", "x,0,0          ", "x,0,1/2        ",    &
                      "0,y,0          ", "0,y,1/2        ", "0,0,z          ",    &
                      "0,1/2,z        ", "1/4,1/4,z      ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 34)= wyck_info_type("F 2 2 2     ",10,     &
                    (/"0,0,0          ", "0,0,1/2        ", "1/4,1/4,1/4    ",    &
                      "1/4,1/4,3/4    ", "x,0,0          ", "0,y,0          ",    &
                      "0,0,z          ", "1/4,1/4,z      ", "1/4,y,1/4      ",    &
                      "x,1/4,1/4      ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 35)= wyck_info_type("I 2 2 2     ",10,     &
                    (/"0,0,0          ", "1/2,0,0        ", "0,0,1/2        ",    &
                      "0,1/2,0        ", "x,0,0          ", "x,0,1/2        ",    &
                      "0,y,0          ", "1/2,y,0        ", "0,0,z          ",    &
                      "0,1/2,z        ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 36)= wyck_info_type("I 21 21 21  ", 3,     &
                    (/"x,0,1/4        ", "1/4,y,0        ", "0,1/4,z        ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 37)= wyck_info_type("P M M 2     ", 8,     &
                    (/"0,0,z          ", "0,1/2,z        ", "1/2,0,z        ",    &
                      "1/2,1/2,z      ", "x,0,z          ", "x,1/2,z        ",    &
                      "0,y,z          ", "1/2,y,z        ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 38)= wyck_info_type("P M C 21    ", 2,     &
                    (/"0,y,z          ", "1/2,y,z        ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 39)= wyck_info_type("P C C 2     ", 4,     &
                    (/"0,0,z          ", "0,1/2,z        ", "1/2,0,z        ",    &
                      "1/2,1/2,z      ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 40)= wyck_info_type("P M A 2     ", 3,     &
                    (/"0,0,z          ", "0,1/2,z        ", "1/4,y,z        ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 41)= wyck_info_type("P C A 21    ", 0,     &
                    (/"               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 42)= wyck_info_type("P N C 2     ", 2,     &
                    (/"0,0,z          ", "1/2,0,z        ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 43)= wyck_info_type("P M N 21    ", 1,     &
                    (/"0,y,z          ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 44)= wyck_info_type("P B A 2     ", 2,     &
                    (/"0,0,z          ", "0,1/2,z        ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 45)= wyck_info_type("P N A 21    ", 0,     &
                    (/"               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 46)= wyck_info_type("P N N 2     ", 2,     &
                    (/"0,0,z          ", "0,1/2,z        ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 47)= wyck_info_type("C M M 2     ", 5,     &
                    (/"0,0,z          ", "0,1/2,z        ", "1/4,1/4,z      ",    &
                      "x,0,z          ", "0,y,z          ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 48)= wyck_info_type("C M C 21    ", 1,     &
                    (/"0,y,z          ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 49)= wyck_info_type("C C C 2     ", 3,     &
                    (/"0,0,z          ", "0,1/2,z        ", "1/4,1/4,z      ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 50)= wyck_info_type("A M M 2     ", 5,     &
                    (/"0,0,z          ", "1/2,0,z        ", "x,0,z          ",    &
                      "0,y,z          ", "1/2,y,z        ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 51)= wyck_info_type("A B M 2     ", 3,     &
                    (/"0,0,z          ", "1/2,0,z        ", "x,1/4,z        ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 52)= wyck_info_type("A M A 2     ", 2,     &
                    (/"0,0,z          ", "1/4,y,z        ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 53)= wyck_info_type("A B A 2     ", 1,     &
                    (/"0,0,z          ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 54)= wyck_info_type("F M M 2     ", 4,     &
                    (/"0,0,z          ", "1/4,1/4,z      ", "0,y,z          ",    &
                      "x,0,z          ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 55)= wyck_info_type("F D D 2     ", 1,     &
                    (/"0,0,z          ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 56)= wyck_info_type("I M M 2     ", 4,     &
                    (/"0,0,z          ", "0,1/2,z        ", "x,0,z          ",    &
                      "0,y,z          ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 57)= wyck_info_type("I B A 2     ", 2,     &
                    (/"0,0,z          ", "0,1/2,z        ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 58)= wyck_info_type("I M A 2     ", 2,     &
                    (/"0,0,z          ", "1/4,y,z        ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 59)= wyck_info_type("P M M M     ",26,     &
                    (/"0,0,0          ", "1/2,0,0        ", "0,0,1/2        ",    &
                      "1/2,0,1/2      ", "0,1/2,0        ", "1/2,1/2,0      ",    &
                      "0,1/2,1/2      ", "1/2,1/2,1/2    ", "x,0,0          ",    &
                      "x,0,1/2        ", "x,1/2,0        ", "x,1/2,1/2      ",    &
                      "0,y,0          ", "0,y,1/2        ", "1/2,y,0        ",    &
                      "1/2,y,1/2      ", "0,0,z          ", "0,1/2,z        ",    &
                      "1/2,0,z        ", "1/2,1/2,z      ", "0,y,z          ",    &
                      "1/2,y,z        ", "x,0,z          ", "x,1/2,z        ",    &
                      "x,y,0          ", "x,y,1/2        "/) )
       wyckoff_info( 60)= wyck_info_type("P N N N:1   ",12,     &
                    (/"0,0,0          ", "1/2,0,0        ", "0,0,1/2        ",    &
                      "0,1/2,0        ", "1/4,1/4,1/4    ", "3/4,3/4,3/4    ",    &
                      "x,0,0          ", "x,0,1/2        ", "0,y,0          ",    &
                      "1/2,y,0        ", "0,0,z          ", "0,1/2,z        ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 61)= wyck_info_type("P N N N     ",12,     &
                    (/"1/4,1/4,1/4    ", "3/4,1/4,1/4    ", "1/4,1/4,3/4    ",    &
                      "1/4,3/4,1/4    ", "1/2,1/2,1/2    ", "0,0,0          ",    &
                      "x,1/4,1/4      ", "x,1/4,3/4      ", "1/4,y,1/4      ",    &
                      "3/4,y,1/4      ", "1/4,1/4,z      ", "1/4,3/4,z      ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 62)= wyck_info_type("P C C M     ",17,     &
                    (/"0,0,0          ", "1/2,1/2,0      ", "0,1/2,0        ",    &
                      "1/2,0,0        ", "0,0,1/4        ", "1/2,0,1/4      ",    &
                      "0,1/2,1/4      ", "1/2,1/2,1/4    ", "x,0,1/4        ",    &
                      "x,1/2,1/4      ", "0,y,1/4        ", "1/2,y,1/4      ",    &
                      "0,0,z          ", "1/2,1/2,z      ", "0,1/2,z        ",    &
                      "1/2,0,z        ", "x,y,0          ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 63)= wyck_info_type("P B A N:1   ",12,     &
                    (/"0,0,0          ", "1/2,0,0        ", "1/2,0,1/2      ",    &
                      "0,0,1/2        ", "1/4,1/4,0      ", "1/4,1/4,1/2    ",    &
                      "x,0,0          ", "x,0,1/2        ", "0,y,0          ",    &
                      "0,y,1/2        ", "0,0,z          ", "0,1/2,z        ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 64)= wyck_info_type("P B A N     ",12,     &
                    (/"1/4,1/4,0      ", "3/4,1/4,0      ", "3/4,1/4,1/2    ",    &
                      "1/4,1/4,1/2    ", "0,0,0          ", "0,0,1/2        ",    &
                      "x,1/4,0        ", "x,1/4,1/2      ", "1/4,y,0        ",    &
                      "1/4,y,1/2      ", "1/4,1/4,z      ", "1/4,3/4,z      ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 65)= wyck_info_type("P M M A     ",11,     &
                    (/"0,0,0          ", "0,1/2,0        ", "0,0,1/2        ",    &
                      "0,1/2,1/2      ", "1/4,0,z        ", "1/4,1/2,z      ",    &
                      "0,y,0          ", "0,y,1/2        ", "x,0,z          ",    &
                      "x,1/2,z        ", "1/4,y,z        ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 66)= wyck_info_type("P N N A     ", 4,     &
                    (/"0,0,0          ", "0,0,1/2        ", "1/4,0,z        ",    &
                      "x,1/4,1/4      ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 67)= wyck_info_type("P M N A     ", 8,     &
                    (/"0,0,0          ", "1/2,0,0        ", "1/2,1/2,0      ",    &
                      "0,1/2,0        ", "x,0,0          ", "x,1/2,0        ",    &
                      "1/4,y,1/4      ", "0,y,z          ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 68)= wyck_info_type("P C C A     ", 5,     &
                    (/"0,0,0          ", "0,1/2,0        ", "0,y,1/4        ",    &
                      "1/4,0,z        ", "1/4,1/2,z      ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 69)= wyck_info_type("P B A M     ", 8,     &
                    (/"0,0,0          ", "0,0,1/2        ", "0,1/2,0        ",    &
                      "0,1/2,1/2      ", "0,0,z          ", "0,1/2,z        ",    &
                      "x,y,0          ", "x,y,1/2        ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 70)= wyck_info_type("P C C N     ", 4,     &
                    (/"0,0,0          ", "0,0,1/2        ", "1/4,1/4,z      ",    &
                      "1/4,3/4,z      ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 71)= wyck_info_type("P B C M     ", 4,     &
                    (/"0,0,0          ", "1/2,0,0        ", "x,1/4,0        ",    &
                      "x,y,1/4        ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 72)= wyck_info_type("P N N M     ", 7,     &
                    (/"0,0,0          ", "0,0,1/2        ", "0,1/2,0        ",    &
                      "0,1/2,1/2      ", "0,0,z          ", "0,1/2,z        ",    &
                      "x,y,0          ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 73)= wyck_info_type("P M M N:1   ", 6,     &
                    (/"0,0,z          ", "0,1/2,z        ", "1/4,1/4,0      ",    &
                      "1/4,1/4,1/2    ", "0,y,z          ", "x,0,z          ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 74)= wyck_info_type("P M M N     ", 6,     &
                    (/"1/4,1/4,z      ", "1/4,3/4,z      ", "0,0,0          ",    &
                      "0,0,1/2        ", "1/4,y,z        ", "x,1/4,z        ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 75)= wyck_info_type("P B C N     ", 3,     &
                    (/"0,0,0          ", "0,1/2,0        ", "0,y,1/4        ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 76)= wyck_info_type("P B C A     ", 2,     &
                    (/"0,0,0          ", "0,0,1/2        ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 77)= wyck_info_type("P N M A     ", 3,     &
                    (/"0,0,0          ", "0,0,1/2        ", "x,1/4,z        ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 78)= wyck_info_type("C M C M     ", 7,     &
                    (/"0,0,0          ", "0,1/2,0        ", "0,y,1/4        ",    &
                      "1/4,1/4,0      ", "x,0,0          ", "0,y,z          ",    &
                      "x,y,1/4        ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 79)= wyck_info_type("C M C A     ", 6,     &
                    (/"0,0,0          ", "1/2,0,0        ", "1/4,1/4,0      ",    &
                      "x,0,0          ", "1/4,y,1/4      ", "0,y,z          ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 80)= wyck_info_type("C M M M     ",17,     &
                    (/"0,0,0          ", "1/2,0,0        ", "1/2,0,1/2      ",    &
                      "0,0,1/2        ", "1/4,1/4,0      ", "1/4,1/4,1/2    ",    &
                      "x,0,0          ", "x,0,1/2        ", "0,y,0          ",    &
                      "0,y,1/2        ", "0,0,z          ", "0,1/2,z        ",    &
                      "1/4,1/4,z      ", "0,y,z          ", "x,0,z          ",    &
                      "x,y,0          ", "x,y,1/2        ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 81)= wyck_info_type("C C C M     ",12,     &
                    (/"0,0,1/4        ", "0,1/2,1/4      ", "0,0,0          ",    &
                      "0,1/2,0        ", "1/4,1/4,0      ", "1/4,3/4,0      ",    &
                      "x,0,1/4        ", "0,y,1/4        ", "0,0,z          ",    &
                      "0,1/2,z        ", "1/4,1/4,z      ", "x,y,0          ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 82)= wyck_info_type("C M M A     ",14,     &
                    (/"1/4,0,0        ", "1/4,0,1/2      ", "0,0,0          ",    &
                      "0,0,1/2        ", "1/4,1/4,0      ", "1/4,1/4,1/2    ",    &
                      "0,1/4,z        ", "x,0,0          ", "x,0,1/2        ",    &
                      "1/4,y,0        ", "1/4,y,1/2      ", "1/4,0,z        ",    &
                      "0,y,z          ", "x,1/4,z        ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 83)= wyck_info_type("C C C A:1   ", 8,     &
                    (/"0,0,0          ", "0,0,1/2        ", "1/4,0,1/4      ",    &
                      "0,1/4,1/4      ", "x,0,0          ", "0,y,0          ",    &
                      "0,0,z          ", "1/4,1/4,z      ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 84)= wyck_info_type("C C C A     ", 8,     &
                    (/"0,1/4,1/4      ", "0,1/4,3/2      ", "1/4,3/4,0      ",    &
                      "0,0,0          ", "x,1/4,1/4      ", "0,y,1/4        ",    &
                      "0,1/4,z        ", "1/4,0,z        ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 85)= wyck_info_type("F M M M     ",15,     &
                    (/"0,0,0          ", "0,0,1/2        ", "0,1/4,1/4      ",    &
                      "1/4,0,1/4      ", "1/4,1/4,0      ", "1/4,1/4,1/4    ",    &
                      "x,0,0          ", "0,y,0          ", "0,0,z          ",    &
                      "1/4,1/4,z      ", "1/4,y,1/4      ", "x,1/4,1/4      ",    &
                      "0,y,z          ", "x,0,z          ", "x,y,0          ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 86)= wyck_info_type("F D D D:1   ", 7,     &
                    (/"0,0,0          ", "0,0,1/2        ", "1/8,1/8,1/8    ",    &
                      "5/8,5/8,5/8    ", "x,0,0          ", "0,y,0          ",    &
                      "0,0,z          ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 87)= wyck_info_type("F D D D     ", 7,     &
                    (/"1/8,1/8,1/8    ", "1/8,1/8,5/8    ", "0,0,0          ",    &
                      "1/2,1/2,1/2    ", "x,1/8,1/8      ", "1/8,y,1/8      ",    &
                      "1/8,1/8,z      ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 88)= wyck_info_type("I M M M     ",14,     &
                    (/"0,0,0          ", "0,1/2,1/2      ", "1/2,1/2,0      ",    &
                      "1/2,0,1/2      ", "x,0,0          ", "x,1/2,0        ",    &
                      "0,y,0          ", "0,y,1/2        ", "0,0,z          ",    &
                      "1/2,0,z        ", "1/4,1/4,1/4    ", "0,y,z          ",    &
                      "x,0,z          ", "x,y,0          ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 89)= wyck_info_type("I B A M     ",10,     &
                    (/"0,0,1/4        ", "1/2,0,1/4      ", "0,0,0          ",    &
                      "1/2,0,0        ", "1/4,1/4,1/4    ", "x,0,1/4        ",    &
                      "0,y,1/4        ", "0,0,z          ", "0,1/2,z        ",    &
                      "x,y,0          ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 90)= wyck_info_type("I B C A     ", 5,     &
                    (/"0,0,0          ", "1/4,1/4,1/4    ", "x,0,1/4        ",    &
                      "1/4,y,0        ", "0,1/4,z        ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 91)= wyck_info_type("I M M A     ", 9,     &
                    (/"0,0,0          ", "0,0,1/2        ", "1/4,1/4,1/4    ",    &
                      "1/4,1/4,3/4    ", "0,1/4,z        ", "x,0,0          ",    &
                      "1/4,y,1/4      ", "0,y,z          ", "x,1/4,z        ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 92)= wyck_info_type("P 4         ", 3,     &
                    (/"0,0,z          ", "1/2,1/2,z      ", "0,1/2,z        ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 93)= wyck_info_type("P 41        ", 0,     &
                    (/"               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 94)= wyck_info_type("P 42        ", 3,     &
                    (/"0,0,z          ", "1/2,1/2,z      ", "0,1/2,z        ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 95)= wyck_info_type("P 43        ", 0,     &
                    (/"               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 96)= wyck_info_type("I 4         ", 2,     &
                    (/"0,0,z          ", "0,1/2,z        ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 97)= wyck_info_type("I 41        ", 1,     &
                    (/"0,0,z          ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 98)= wyck_info_type("P -4        ", 7,     &
                    (/"0,0,0          ", "0,0,1/2        ", "1/2,1/2,0      ",    &
                      "1/2,1/2,1/2    ", "0,0,z          ", "1/2,1/2,z      ",    &
                      "0,1/2,z        ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info( 99)= wyck_info_type("I -4        ", 6,     &
                    (/"0,0,0          ", "0,0,1/2        ", "0,1/2,1/4      ",    &
                      "0,1/2,3/4      ", "0,0,z          ", "0,1/2,z        ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(100)= wyck_info_type("P 4/M       ",11,     &
                    (/"0,0,0          ", "0,0,1/2        ", "1/2,1/2,0      ",    &
                      "1/2,1/2,1/2    ", "0,1/2,0        ", "0,1/2,1/2      ",    &
                      "0,0,z          ", "1/2,1/2,z      ", "0,1/2,z        ",    &
                      "x,y,0          ", "x,y,1/2        ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(101)= wyck_info_type("P 42/M      ",10,     &
                    (/"0,0,0          ", "1/2,1/2,0      ", "0,1/2,0        ",    &
                      "0,1/2,1/2      ", "0,0,1/4        ", "1/2,1/2,1/4    ",    &
                      "0,0,z          ", "1/2,1/2,z      ", "0,1/2,z        ",    &
                      "x,y,0          ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(102)= wyck_info_type("P 4/N:1     ", 6,     &
                    (/"0,0,0          ", "0,0,1/2        ", "0,1/2,z        ",    &
                      "1/4,1/4,0      ", "1/4,1/4,1/2    ", "0,0,z          ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(103)= wyck_info_type("P 4/N       ", 6,     &
                    (/"1/4,3/4,0      ", "1/4,3/4,1/2    ", "1/4,1/4,z      ",    &
                      "0,0,0          ", "0,0,1/2        ", "1/4,3/4,z      ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(104)= wyck_info_type("P 42/N:1    ", 6,     &
                    (/"0,0,0          ", "0,0,1/2        ", "1/4,1/4,1/4    ",    &
                      "1/4,1/4,3/4    ", "0,1/2,z        ", "0,0,z          ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(105)= wyck_info_type("P 42/N      ", 6,     &
                    (/"1/4,1/4,1/4    ", "1/4,1/4,3/4    ", "0,0,0          ",    &
                      "0,0,1/2        ", "3/4,1/4,z      ", "1/4,1/4,z      ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(106)= wyck_info_type("I 4/M       ", 8,     &
                    (/"0,0,0          ", "0,0,1/2        ", "0,1/2,0        ",    &
                      "0,1/2,1/4      ", "0,0,z          ", "1/4,1/4,1/4    ",    &
                      "0,1/2,z        ", "x,y,0          ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(107)= wyck_info_type("I 41/A:1    ", 5,     &
                    (/"0,0,0          ", "0,0,1/2        ", "0,1/4,1/8      ",    &
                      "0,1/4,5/8      ", "0,0,z          ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(108)= wyck_info_type("I 41/A      ", 5,     &
                    (/"0,1/4,1/8      ", "0,1/4,5/8      ", "0,0,0          ",    &
                      "0,0,1/2        ", "0,1/4,z        ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(109)= wyck_info_type("P 4 2 2     ",15,     &
                    (/"0,0,0          ", "0,0,1/2        ", "1/2,1/2,0      ",    &
                      "1/2,1/2,1/2    ", "1/2,0,0        ", "1/2,0,1/2      ",    &
                      "0,0,z          ", "1/2,1/2,z      ", "0,1/2,z        ",    &
                      "x,x,0          ", "x,x,1/2        ", "x,0,0          ",    &
                      "x,1/2,1/2      ", "x,0,1/2        ", "x,1/2,0        ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(110)= wyck_info_type("P 4 21 2    ", 6,     &
                    (/"0,0,0          ", "0,0,1/2        ", "0,1/2,z        ",    &
                      "0,0,z          ", "x,x,0          ", "x,x,1/2        ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(111)= wyck_info_type("P 41 2 2    ", 3,     &
                    (/"0,y,0          ", "1/2,y,0        ", "x,x,3/8        ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(112)= wyck_info_type("P 41 21 2   ", 1,     &
                    (/"x,x,0          ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(113)= wyck_info_type("P 42 2 2    ",15,     &
                    (/"0,0,0          ", "1/2,1/2,0      ", "0,1/2,0        ",    &
                      "0,1/2,1/2      ", "0,0,1/4        ", "1/2,1/2,1/4    ",    &
                      "0,0,z          ", "1/2,1/2,z      ", "0,1/2,z        ",    &
                      "x,0,0          ", "x,1/2,1/2      ", "x,0,1/2        ",    &
                      "x,1/2,0        ", "x,x,1/4        ", "x,x,3/4        ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(114)= wyck_info_type("P 42 21 2   ", 6,     &
                    (/"0,0,0          ", "0,0,1/2        ", "0,0,z          ",    &
                      "0,1/2,z        ", "x,x,0          ", "x,x,1/2        ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(115)= wyck_info_type("P 43 2 2    ", 3,     &
                    (/"0,y,0          ", "1/2,y,0        ", "x,x,5/8        ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(116)= wyck_info_type("P 43 21 2   ", 1,     &
                    (/"x,x,0          ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(117)= wyck_info_type("I 4 2 2     ",10,     &
                    (/"0,0,0          ", "0,0,1/2        ", "0,1/2,0        ",    &
                      "0,1/2,1/4      ", "0,0,z          ", "0,1/2,z        ",    &
                      "x,x,0          ", "x,0,0          ", "x,0,1/2        ",    &
                      "x,x+1/2,1/4    ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(118)= wyck_info_type("I 41 2 2    ", 6,     &
                    (/"0,0,0          ", "0,0,1/2        ", "0,0,z          ",    &
                      "x,x,0          ", "-x,x,0         ", "x,1/4,1/8      ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )

       wyckoff_info(119)= wyck_info_type("P 4 M M     ", 6,     &
                    (/"0,0,z          ", "1/2,1/2,z      ", "1/2,0,z        ",    &
                      "x,x,z          ", "x,0,z          ", "x,1/2,z        ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(120)= wyck_info_type("P 4 B M     ", 3,     &
                    (/"0,0,z          ", "0,1/2,z        ", "x,x+1/2,z      ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(121)= wyck_info_type("P 42 C M    ", 4,     &
                    (/"0,0,z          ", "1/2,1/2,z      ", "0,1/2,z        ",    &
                      "x,x,z          ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(122)= wyck_info_type("P 42 N M    ", 3,     &
                    (/"0,0,z          ", "0,1/2,z        ", "x,x,z          ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(123)= wyck_info_type("P 4 C C     ", 3,     &
                    (/"0,0,z          ", "1/2,1/2,z      ", "0,1/2,z        ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(124)= wyck_info_type("P 4 N C     ", 2,     &
                    (/"0,0,z          ", "0,1/2,z        ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(125)= wyck_info_type("P 42 M C    ", 5,     &
                    (/"0,0,z          ", "1/2,1/2,z      ", "0,1/2,z        ",    &
                      "x,0,z          ", "x,1/2,z        ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(126)= wyck_info_type("P 42 B C    ", 2,     &
                    (/"0,0,z          ", "0,1/2,z        ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(127)= wyck_info_type("I 4 M M     ", 4,     &
                    (/"0,0,z          ", "0,1/2,z        ", "x,x,z          ",    &
                      "x,0,z          ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(128)= wyck_info_type("I 4 C M     ", 3,     &
                    (/"0,0,z          ", "1/2,0,z        ", "x,x+1/2,z      ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(129)= wyck_info_type("I 41 M D    ", 2,     &
                    (/"0,0,z          ", "0,y,z          ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(130)= wyck_info_type("I 41 C D    ", 1,     &
                    (/"0,0,z          ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(131)= wyck_info_type("P -4 2 M    ",14,     &
                    (/"0,0,0          ", "1/2,1/2,1/2    ", "0,0,1/2        ",    &
                      "1/2,1/2,0      ", "1/2,0,0        ", "1/2,0,1/2      ",    &
                      "0,0,z          ", "1/2,1/2,z      ", "x,0,0          ",    &
                      "x,1/2,1/2      ", "x,0,1/2        ", "x,1/2,0        ",    &
                      "0,1/2,z        ", "x,x,z          ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(132)= wyck_info_type("P -4 2 C    ",13,     &
                    (/"0,0,1/4        ", "1/2,0,1/4      ", "1/2,1/2,1/4    ",    &
                      "0,1/2,1/4      ", "0,0,0          ", "1/2,1/2,0      ",    &
                      "x,0,1/4        ", "1/2,y,1/4      ", "x,1/2,1/4      ",    &
                      "0,y,1/4        ", "0,0,z          ", "1/2,1/2,z      ",    &
                      "0,1/2,z        ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(133)= wyck_info_type("P -4 21 M   ", 5,     &
                    (/"0,0,0          ", "0,0,1/2        ", "0,1/2,z        ",    &
                      "0,0,z          ", "x,x+1/2,z      ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(134)= wyck_info_type("P -4 21 C   ", 4,     &
                    (/"0,0,0          ", "0,0,1/2        ", "0,0,z          ",    &
                      "0,1/2,z        ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(135)= wyck_info_type("P -4 M 2    ",11,     &
                    (/"0,0,0          ", "1/2,1/2,0      ", "1/2,1/2,1/2    ",    &
                      "0,0,1/2        ", "0,0,z          ", "1/2,1/2,z      ",    &
                      "0,1/2,z        ", "x,x,0          ", "x,x,1/2        ",    &
                      "x,0,z          ", "x,1/2,z        ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(136)= wyck_info_type("P -4 C 2    ", 9,     &
                    (/"0,0,1/4        ", "1/2,1/2,1/4    ", "0,0,0          ",    &
                      "1/2,1/2,0      ", "x,x,1/4        ", "x,x,3/4        ",    &
                      "0,0,z          ", "1/2,1/2,z      ", "0,1/2,z        ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(137)= wyck_info_type("P -4 B 2    ", 8,     &
                    (/"0,0,0          ", "0,0,1/2        ", "0,1/2,0        ",    &
                      "0,1/2,1/2      ", "0,0,z          ", "0,1/2,z        ",    &
                      "x,x+1/2,0      ", "x,x+1/2,1/2    ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(138)= wyck_info_type("P -4 N 2    ", 8,     &
                    (/"0,0,0          ", "0,0,1/2        ", "0,1/2,1/4      ",    &
                      "0,1/2,3/4      ", "0,0,z          ", "x,-x+1/2,1/4   ",    &
                      "x,x+1/2,1/4    ", "0,1/2,z        ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(139)= wyck_info_type("I -4 M 2    ", 9,     &
                    (/"0,0,0          ", "0,0,1/2        ", "0,1/2,1/4      ",    &
                      "0,1/2,3/4      ", "0,0,z          ", "0,1/2,z        ",    &
                      "x,x,0          ", "x,x+1/2,1/4    ", "x,0,z          ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(140)= wyck_info_type("I -4 C 2    ", 8,     &
                    (/"0,0,1/4        ", "0,0,0          ", "0,1/2,1/4      ",    &
                      "0,1/2,0        ", "x,x,1/4        ", "0,0,z          ",    &
                      "0,1/2,z        ", "x,x+1/2,0      ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(141)= wyck_info_type("I -4 2 M    ", 9,     &
                    (/"0,0,0          ", "0,0,1/2        ", "0,1/2,0        ",    &
                      "0,1/2,1/4      ", "0,0,z          ", "x,0,0          ",    &
                      "x,0,1/2        ", "0,1/2,z        ", "x,x,z          ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(142)= wyck_info_type("I -4 2 D    ", 4,     &
                    (/"0,0,0          ", "0,0,1/2        ", "0,0,z          ",    &
                      "x,1/4,1/8      ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(143)= wyck_info_type("P 4/M M M   ",20,     &
                    (/"0,0,0          ", "0,0,1/2        ", "1/2,1/2,0      ",    &
                      "1/2,1/2,1/2    ", "0,1/2,1/2      ", "0,1/2,0        ",    &
                      "0,0,z          ", "1/2,1/2,z      ", "0,1/2,z        ",    &
                      "x,x,0          ", "x,x,1/2        ", "x,0,0          ",    &
                      "x,0,1/2        ", "x,1/2,0        ", "x,1/2,1/2      ",    &
                      "x,y,0          ", "x,y,1/2        ", "x,x,z          ",    &
                      "x,0,z          ", "x,1/2,z        ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(144)= wyck_info_type("P 4/M C C   ",13,     &
                    (/"0,0,1/4        ", "0,0,0          ", "1/2,1/2,1/4    ",    &
                      "1/2,1/2,0      ", "0,1/2,0        ", "0,1/2,1/4      ",    &
                      "0,0,z          ", "1/2,1/2,z      ", "0,1/2,z        ",    &
                      "x,x,1/4        ", "x,0,1/4        ", "x,1/2,1/4      ",    &
                      "x,y,0          ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(145)= wyck_info_type("P 4/N B M:1 ",13,     &
                    (/"0,0,0          ", "0,0,1/2        ", "0,1/2,0        ",    &
                      "0,1/2,1/2      ", "1/4,1/4,0      ", "1/4,1/4,1/2    ",    &
                      "0,0,z          ", "0,1/2,z        ", "x,x,0          ",    &
                      "x,x,1/2        ", "x,0,0          ", "x,0,1/2        ",    &
                      "x,x+1/2,z      ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(146)= wyck_info_type("P 4/N B M   ",13,     &
                    (/"1/4,1/4,0      ", "1/4,1/4,1/2    ", "3/4,1/4,0      ",    &
                      "3/4,1/4,1/2    ", "0,0,0          ", "0,0,1/2        ",    &
                      "1/4,1/4,z      ", "3/4,1/4,z      ", "x,x,0          ",    &
                      "x,x,1/2        ", "x,1/4,0        ", "x,1/4,1/2      ",    &
                      "x,-x,z         ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(147)= wyck_info_type("P 4/N N C:1 ",10,     &
                    (/"0,0,0          ", "0,0,1/2        ", "1/2,0,0        ",    &
                      "1/2,0,1/4      ", "0,0,z          ", "1/4,1/4,1/4    ",    &
                      "1/2,0,z        ", "x,x,0          ", "x,0,0          ",    &
                      "x,0,1/2        ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(148)= wyck_info_type("P 4/N N C   ",10,     &
                    (/"1/4,1/4,1/4    ", "1/4,1/4,3/4    ", "1/4,3/4,3/4    ",    &
                      "1/4,1/4,0      ", "1/4,1/4,z      ", "0,0,0          ",    &
                      "1/4,3/4,z      ", "x,x,1/4        ", "x,1/4,1/4      ",    &
                      "x,3/4,1/4      ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(149)= wyck_info_type("P 4/M B M   ",11,     &
                    (/"0,0,0          ", "0,0,1/2        ", "0,1/2,1/2      ",    &
                      "0,1/2,0        ", "0,0,z          ", "0,1/2,z        ",    &
                      "x,x+1/2,0      ", "x,x+1/2,1/2    ", "x,y,0          ",    &
                      "x,y,1/2        ", "x,x+1/2,z      ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(150)= wyck_info_type("P 4/M N C   ", 8,     &
                    (/"0,0,0          ", "0,0,1/2        ", "0,1/2,0        ",    &
                      "0,1/2,1/4      ", "0,0,z          ", "0,1/2,z        ",    &
                      "x,x+1/2,1/4    ", "x,y,0          ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(151)= wyck_info_type("P 4/N M M:1 ",10,     &
                    (/"0,0,0          ", "0,0,1/2        ", "0,1/2,z        ",    &
                      "1/4,1/4,0      ", "1/4,1/4,1/2    ", "0,0,z          ",    &
                      "x,x,0          ", "x,x,1/2        ", "0,y,z          ",    &
                      "x,x+1/2,z      ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(152)= wyck_info_type("P 4/N M M   ",10,     &
                    (/"3/4,1/4,0      ", "3/4,1/4,1/2    ", "1/4,1/4,z      ",    &
                      "0,0,0          ", "0,0,1/2        ", "3/4,1/4,z      ",    &
                      "x,-x,0         ", "x,-x,1/2       ", "1/4,y,z        ",    &
                      "x,x,z          ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(153)= wyck_info_type("P 4/N C C:1 ", 6,     &
                    (/"0,0,1/4        ", "0,0,0          ", "0,1/2,z        ",    &
                      "1/4,1/4,0      ", "0,0,z          ", "x,x,1/4        ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(154)= wyck_info_type("P 4/N C C   ", 6,     &
                    (/"3/4,1/4,1/4    ", "3/4,1/4,0      ", "1/4,1/4,z      ",    &
                      "0,0,0          ", "3/4,1/4,z      ", "x,-x,1/4       ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(155)= wyck_info_type("P 42/M M C  ",17,     &
                    (/"0,0,0          ", "1/2,1/2,0      ", "0,1/2,0        ",    &
                      "0,1/2,1/2      ", "0,0,1/4        ", "1/2,1/2,1/4    ",    &
                      "0,0,z          ", "1/2,1/2,z      ", "0,1/2,z        ",    &
                      "x,0,0          ", "x,1/2,1/2      ", "x,0,1/2        ",    &
                      "x,1/2,0        ", "x,x,1/4        ", "0,y,z          ",    &
                      "1/2,y,z        ", "x,y,0          ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(156)= wyck_info_type("P 42/M C M  ",15,     &
                    (/"0,0,0          ", "0,0,1/4        ", "1/2,1/2,0      ",    &
                      "1/2,1/2,1/4    ", "0,1/2,1/4      ", "0,1/2,0        ",    &
                      "0,0,z          ", "1/2,1/2,z      ", "x,x,0          ",    &
                      "x,x,1/2        ", "0,1/2,z        ", "x,0,1/4        ",    &
                      "x,1/2,1/4      ", "x,y,0          ", "x,x,z          ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(157)= wyck_info_type("P 42/N B C:1",10,     &
                    (/"0,1/2,1/4      ", "0,0,1/4        ", "0,1/2,0        ",    &
                      "0,0,0          ", "1/4,1/4,1/4    ", "0,1/2,z        ",    &
                      "0,0,z          ", "x,0,1/4        ", "x,0,3/4        ",    &
                      "x,x+1/2,0      ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(158)= wyck_info_type("P 42/N B C  ",10,     &
                    (/"1/4,1/4,0      ", "3/4,1/4,0      ", "1/4,1/4,1/4    ",    &
                      "3/4,1/4,3/4    ", "0,0,0          ", "1/4,1/4,z      ",    &
                      "3/4,1/4,z      ", "x,1/4,0        ", "x,1/4,1/2      ",    &
                      "x,x,1/4        ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(159)= wyck_info_type("P 42/N N M:1",13,     &
                    (/"0,0,0          ", "0,0,1/2        ", "0,1/2,0        ",    &
                      "0,1/2,1/4      ", "1/4,1/4,1/4    ", "3/4,3/4,3/4    ",    &
                      "0,0,z          ", "0,1/2,z        ", "x,0,0          ",    &
                      "x,0,1/2        ", "x,x+1/2,1/4    ", "x,x+1/2,3/4    ",    &
                      "x,x,z          ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(160)= wyck_info_type("P 42/N N M  ",13,     &
                    (/"1/4,3/4,1/4    ", "3/4,1/4,1/4    ", "1/4,1/4,1/4    ",    &
                      "1/4,1/4,0      ", "0,0,1/2        ", "0,0,0          ",    &
                      "3/4,1/4,z      ", "1/4,1/4,z      ", "x,1/4,3/4      ",    &
                      "x,1/4,1/4      ", "x,x,0          ", "x,x,1/2        ",    &
                      "x,-x,z         ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(161)= wyck_info_type("P 42/M B C  ", 8,     &
                    (/"0,0,0          ", "0,0,1/4        ", "0,1/2,0        ",    &
                      "0,1/2,1/4      ", "0,0,z          ", "0,1/2,z        ",    &
                      "x,x+1/2,1/4    ", "x,y,0          ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(162)= wyck_info_type("P 42/M N M  ",10,     &
                    (/"0,0,0          ", "0,0,1/2        ", "0,1/2,0        ",    &
                      "0,1/2,1/4      ", "0,0,z          ", "x,x,0          ",    &
                      "x,-x,0         ", "0,1/2,z        ", "x,y,0          ",    &
                      "x,x,z          ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(163)= wyck_info_type("P 42/N M C:1", 7,     &
                    (/"0,0,0          ", "0,0,1/2        ", "0,0,z          ",    &
                      "0,1/2,z        ", "1/4,1/4,1/4    ", "x,x,0          ",    &
                      "0,y,z          ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(164)= wyck_info_type("P 42/N M C  ", 7,     &
                    (/"3/4,1/4,3/4    ", "3/4,1/4,1/4    ", "3/4,1/4,z      ",    &
                      "1/4,1/4,z      ", "0,0,0          ", "x,-x,1/4       ",    &
                      "1/4,y,z        ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(165)= wyck_info_type("P 42/N C M:1", 9,     &
                    (/"0,0,1/4        ", "0,0,0          ", "1/4,1/4,1/4    ",    &
                      "1/4,1/4,3/4    ", "0,1/2,z        ", "0,0,z          ",    &
                      "x,x,1/4        ", "x,x,3/4        ", "x,x+1/2,z      ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(166)= wyck_info_type("P 42/N C M  ", 9,     &
                    (/"3/4,1/4,0      ", "3/4,1/4,3/4    ", "0,0,1/2        ",    &
                      "0,0,0          ", "1/4,1/4,z      ", "3/4,1/4,z      ",    &
                      "x,-x,1/2       ", "x,-x,0         ", "x,x,z          ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(167)= wyck_info_type("I 4/M M M   ",14,     &
                    (/"0,0,0          ", "0,0,1/2        ", "0,1/2,0        ",    &
                      "0,1/2,1/4      ", "0,0,z          ", "1/4,1/4,1/4    ",    &
                      "0,1/2,z        ", "x,x,0          ", "x,0,0          ",    &
                      "x,1/2,0        ", "x,x+1/2,1/4    ", "x,y,0          ",    &
                      "x,x,z          ", "0,y,z          ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(168)= wyck_info_type("I 4/M C M   ",12,     &
                    (/"0,0,1/4        ", "0,1/2,1/4      ", "0,0,0          ",    &
                      "0,1/2,0        ", "1/4,1/4,1/4    ", "0,0,z          ",    &
                      "0,1/2,z        ", "x,x+1/2,0      ", "x,x,1/4        ",    &
                      "x,0,1/4        ", "x,y,0          ", "x,x+1/2,z      ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(169)= wyck_info_type("I 41/A M D:1", 8,     &
                    (/"0,0,0          ", "0,0,1/2        ", "0,1/4,1/8      ",    &
                      "0,1/4,5/8      ", "0,0,z          ", "x,1/4,1/8      ",    &
                      "x,x,0          ", "0,y,z          ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(170)= wyck_info_type("I 41/A M D  ", 8,     &
                    (/"0,3/4,1/8      ", "0,1/4,3/8      ", "0,0,0          ",    &
                      "0,0,1/2        ", "0,1/4,z        ", "x,0,0          ",    &
                      "x,x+1/4,7/8    ", "0,y,z          ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(171)= wyck_info_type("I 41/A C D:1", 6,     &
                    (/"0,0,0          ", "0,0,1/4        ", "0,1/4,1/8      ",    &
                      "0,0,z          ", "1/4,y,1/8      ", "x,x,1/4        ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(172)= wyck_info_type("I 41/A C D  ", 6,     &
                    (/"0,1/4,3/8      ", "0,1/4,1/8      ", "0,0,0          ",    &
                      "0,1/4,z        ", "x,0,1/4        ", "x,x+1/4,1/8    ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(173)= wyck_info_type("P 3         ", 3,     &
                    (/"0,0,z          ", "1/3,2/3,z      ", "2/3,1/3,z      ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(174)= wyck_info_type("P 31        ", 0,     &
                    (/"               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(175)= wyck_info_type("P 32        ", 0,     &
                    (/"               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(176)= wyck_info_type("R 3         ", 1,     &
                    (/"0,0,z          ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(177)= wyck_info_type("R 3:H       ", 1,     &
                    (/"x,x,x          ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(178)= wyck_info_type("P -3        ", 6,     &
                    (/"0,0,0          ", "0,0,1/2        ", "0,0,z          ",    &
                      "1/3,2/3,z      ", "1/2,0,0        ", "1/2,0,1/2      ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(179)= wyck_info_type("R -3        ", 5,     &
                    (/"0,0,0          ", "0,0,1/2        ", "0,0,z          ",    &
                      "1/2,0,1/2      ", "1/2,0,0        ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(180)= wyck_info_type("R -3:H      ", 5,     &
                    (/"0,0,0          ", "1/2,1/2,1/2    ", "x,x,x          ",    &
                      "1/2,0,0        ", "0,1/2,1/2      ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(181)= wyck_info_type("P 3 1 2     ",11,     &
                    (/"0,0,0          ", "0,0,1/2        ", "1/3,2/3,0      ",    &
                      "1/3,2/3,1/2    ", "2/3,1/3,0      ", "2/3,1/3,1/2    ",    &
                      "0,0,z          ", "1/3,2/3,z      ", "2/3,1/3,z      ",    &
                      "x,-x,0         ", "x,-x,1/2       ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(182)= wyck_info_type("P 3 2 1     ", 6,     &
                    (/"0,0,0          ", "0,0,1/2        ", "0,0,z          ",    &
                      "1/3,2/3,z      ", "x,0,0          ", "x,0,1/2        ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(183)= wyck_info_type("P 31 1 2    ", 2,     &
                    (/"x,-x,1/3       ", "x,-x,5/6       ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(184)= wyck_info_type("P 31 2 1    ", 2,     &
                    (/"x,0,1/3        ", "x,0,5/6        ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(185)= wyck_info_type("P 32 1 2    ", 2,     &
                    (/"x,-x,2/3       ", "x,-x,1/6       ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(186)= wyck_info_type("P 32 2 1    ", 2,     &
                    (/"x,0,2/3        ", "x,0,1/6        ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(187)= wyck_info_type("R 3 2       ", 5,     &
                    (/"0,0,0          ", "0,0,1/2        ", "0,0,z          ",    &
                      "x,0,0          ", "x,0,1/2        ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(188)= wyck_info_type("R 3 2:R     ", 5,     &
                    (/"0,0,0          ", "1/2,1/2,1/2    ", "x,x,x          ",    &
                      "0,y,-y         ", "1/2,y,-y       ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(189)= wyck_info_type("P 3 M 1     ", 4,     &
                    (/"0,0,z          ", "1/3,2/3,z      ", "2/3,1/3,z      ",    &
                      "x,-x,z         ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(190)= wyck_info_type("P 3 1 M     ", 3,     &
                    (/"0,0,z          ", "1/3,2/3,z      ", "x,0,z          ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(191)= wyck_info_type("P 3 C 1     ", 3,     &
                    (/"0,0,z          ", "1/3,2/3,z      ", "2/3,1/3,z      ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(192)= wyck_info_type("P 3 1 C     ", 2,     &
                    (/"0,0,z          ", "1/3,2/3,z      ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(193)= wyck_info_type("R 3 M       ", 2,     &
                    (/"0,0,z          ", "x,-x,z         ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(194)= wyck_info_type("R 3 M:R     ", 2,     &
                    (/"x,x,x          ", "x,x,z          ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(195)= wyck_info_type("R 3 C       ", 1,     &
                    (/"0,0,z          ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(196)= wyck_info_type("R 3 C:R     ", 1,     &
                    (/"x,x,x          ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(197)= wyck_info_type("P -3 1 M    ",11,     &
                    (/"0,0,0          ", "0,0,1/2        ", "1/3,2/3,0      ",    &
                      "1/3,2/3,1/2    ", "0,0,z          ", "1/2,0,0        ",    &
                      "1/2,0,1/2      ", "1/3,2/3,z      ", "x,-x,0         ",    &
                      "x,-x,1/2       ", "x,0,z          ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(198)= wyck_info_type("P -3 1 C    ", 8,     &
                    (/"0,0,1/4        ", "0,0,0          ", "1/3,2/3,1/4    ",    &
                      "2/3,1/3,1/4    ", "0,0,z          ", "1/3,2/3,z      ",    &
                      "1/2,0,0        ", "x,-x,1/4       ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(199)= wyck_info_type("P -3 M 1    ", 9,     &
                    (/"0,0,0          ", "0,0,1/2        ", "0,0,z          ",    &
                      "1/3,2/3,z      ", "1/2,0,0        ", "1/2,0,1/2      ",    &
                      "x,0,0          ", "x,0,1/2        ", "x,-x,z         ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(200)= wyck_info_type("P -3 C 1    ", 6,     &
                    (/"0,0,1/4        ", "0,0,0          ", "0,0,z          ",    &
                      "1/3,2/3,z      ", "1/2,0,0        ", "x,0,1/4        ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(201)= wyck_info_type("R -3 M      ", 8,     &
                    (/"0,0,0          ", "0,0,1/2        ", "0,0,z          ",    &
                      "1/2,0,1/2      ", "1/2,0,0        ", "x,0,0          ",    &
                      "x,0,1/2        ", "x,-x,z         ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(202)= wyck_info_type("R -3 M:R    ", 8,     &
                    (/"0,0,0          ", "1/2,1/2,1/2    ", "x,x,x          ",    &
                      "1/2,0,0        ", "0,1/2,1/2      ", "x,-x,0         ",    &
                      "x,-x,1/2       ", "x,x,z          ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(203)= wyck_info_type("R -3 C      ", 5,     &
                    (/"0,0,1/4        ", "0,0,0          ", "0,0,z          ",    &
                      "1/2,0,0        ", "x,0,1/4        ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(204)= wyck_info_type("R -3 C:R    ", 5,     &
                    (/"1/4,1/4,1/4    ", "0,0,0          ", "x,x,x          ",    &
                      "1/2,0,0        ", "x,-x+1/2,1/4   ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(205)= wyck_info_type("P 6         ", 3,     &
                    (/"0,0,z          ", "1/3,2/3,z      ", "1/2,0,z        ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(206)= wyck_info_type("P 61        ", 0,     &
                    (/"               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(207)= wyck_info_type("P 65        ", 0,     &
                    (/"               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(208)= wyck_info_type("P 62        ", 2,     &
                    (/"0,0,z          ", "1/2,1/2,z      ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(209)= wyck_info_type("P 64        ", 2,     &
                    (/"0,0,z          ", "1/2,1/2,z      ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(210)= wyck_info_type("P 63        ", 2,     &
                    (/"0,0,z          ", "1/3,2/3,z      ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(211)= wyck_info_type("P -6        ",11,     &
                    (/"0,0,0          ", "0,0,1/2        ", "1/3,2/3,0      ",    &
                      "1/3,2/3,1/2    ", "2/3,1/3,0      ", "2/3,1/3,1/2    ",    &
                      "0,0,z          ", "1/3,2/3,z      ", "2/3,1/3,z      ",    &
                      "x,y,0          ", "x,y,1/2        ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(212)= wyck_info_type("P 6/M       ",11,     &
                    (/"0,0,0          ", "0,0,1/2        ", "1/3,2/3,0      ",    &
                      "1/3,2/3,1/2    ", "0,0,z          ", "1/2,0,0        ",    &
                      "1/2,0,1/2      ", "1/3,2/3,z      ", "1/2,0,z        ",    &
                      "x,y,0          ", "x,y,1/2        ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(213)= wyck_info_type("P 63/M      ", 8,     &
                    (/"0,0,1/4        ", "0,0,0          ", "1/3,2/3,1/4    ",    &
                      "2/3,1/3,1/4    ", "0,0,z          ", "1/3,2/3,z      ",    &
                      "1/2,0,0        ", "x,y,1/4        ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(214)= wyck_info_type("P 6 2 2     ",13,     &
                    (/"0,0,0          ", "0,0,1/2        ", "1/3,2/3,0      ",    &
                      "1/3,2/3,1/2    ", "0,0,z          ", "1/2,0,0        ",    &
                      "1/2,0,1/2      ", "1/3,2/3,z      ", "1/2,0,z        ",    &
                      "x,0,0          ", "x,0,1/2        ", "x,-x,0         ",    &
                      "x,-x,1/2       ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(215)= wyck_info_type("P 61 2 2    ", 2,     &
                    (/"x,0,0          ", "x,2x,1/4       ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(216)= wyck_info_type("P 65 2 2    ", 2,     &
                    (/"x,0,0          ", "x,2x,3/4       ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(217)= wyck_info_type("P 62 2 2    ",10,     &
                    (/"0,0,0          ", "0,0,1/2        ", "1/2,0,0        ",    &
                      "1/2,0,1/2      ", "0,0,z          ", "1/2,0,z        ",    &
                      "x,0,0          ", "x,0,1/2        ", "x,2x,0         ",    &
                      "x,2x,1/2       ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(218)= wyck_info_type("P 64 2 2    ",10,     &
                    (/"0,0,0          ", "0,0,1/2        ", "1/2,0,0        ",    &
                      "1/2,0,/1,2     ", "0,0,z          ", "1/2,0,z        ",    &
                      "x,0,0          ", "x,0,1/2        ", "x,2x,0         ",    &
                      "x,2x,1/2       ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(219)= wyck_info_type("P 63 2 2    ", 8,     &
                    (/"0,0,0          ", "0,0,1/4        ", "1/3,2/3,1/4    ",    &
                      "1/3,2/3,3/4    ", "0,0,z          ", "1/3,2/3,z      ",    &
                      "x,0,0          ", "x,2x,1/4       ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(220)= wyck_info_type("P 6 M M     ", 5,     &
                    (/"0,0,z          ", "1/3,2/3,z      ", "1/2,0,z        ",    &
                      "x,0,z          ", "x,-x,z         ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(221)= wyck_info_type("P 6 C C     ", 3,     &
                    (/"0,0,z          ", "1/3,2/3,z      ", "1/2,0,z        ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(222)= wyck_info_type("P 63 C M    ", 3,     &
                    (/"0,0,z          ", "1/3,2/3,z      ", "x,0,z          ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(223)= wyck_info_type("P 63 M C    ", 3,     &
                    (/"0,0,z          ", "1/3,2/3,z      ", "x,-x,z         ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(224)= wyck_info_type("P -6 M 2    ",14,     &
                    (/"0,0,0          ", "0,0,1/2        ", "1/3,2/3,0      ",    &
                      "1/3,2/3,1/2    ", "2/3,1/3,0      ", "2/3,1/3,1/2    ",    &
                      "0,0,z          ", "1/3,2/3,z      ", "2/3,1/3,z      ",    &
                      "x,-x,0         ", "x,-x,1/2       ", "x,y,0          ",    &
                      "x,y,1/2        ", "x,-x,z         ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(225)= wyck_info_type("P -6 C 2    ",11,     &
                    (/"0,0,0          ", "0,0,1/4        ", "1/3,2/3,0      ",    &
                      "1/3,2/3,1/4    ", "2/3,1/3,0      ", "2/3,1/3,1/4    ",    &
                      "0,0,z          ", "1/3,2/3,z      ", "2/3,1/3,z      ",    &
                      "x,-x,0         ", "x,y,1/4        ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(226)= wyck_info_type("P -6 2 M    ",11,     &
                    (/"0,0,0          ", "0,0,1/2        ", "1/3,2/3,0      ",    &
                      "1/3,2/3,1/2    ", "0,0,z          ", "x,0,0          ",    &
                      "x,0,1/2        ", "1/3,2/3,z      ", "x,0,z          ",    &
                      "x,y,0          ", "x,y,1/2        ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(227)= wyck_info_type("P -6 2 C    ", 8,     &
                    (/"0,0,0          ", "0,0,1/4        ", "1/3,2/3,1/4    ",    &
                      "2/3,1/3,1/4    ", "0,0,z          ", "1/3,2/3,z      ",    &
                      "x,0,0          ", "x,y,1/4        ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(228)= wyck_info_type("P 6/M M M   ",17,     &
                    (/"0,0,0          ", "0,0,1/2        ", "1/3,2/3,0      ",    &
                      "1/3,2/3,1/2    ", "0,0,z          ", "1/2,0,0        ",    &
                      "1/2,0,1/2      ", "1/3,2/3,z      ", "1/2,0,z        ",    &
                      "x,0,0          ", "x,0,1/2        ", "x,2x,0         ",    &
                      "x,2x,1/2       ", "x,0,z          ", "x,2x,z         ",    &
                      "x,y,0          ", "x,y,1/2        ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(229)= wyck_info_type("P 6/M C C   ",12,     &
                    (/"0,0,1/4        ", "0,0,0          ", "1/3,2/3,1/4    ",    &
                      "1/3,2/3,0      ", "0,0,z          ", "1/2,0,1/4      ",    &
                      "1/2,0,0        ", "1/3,2/3,z      ", "1/2,0,z        ",    &
                      "x,0,1/4        ", "x,2x,1/4       ", "x,y,0          ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(230)= wyck_info_type("P 63/M C M  ",11,     &
                    (/"0,0,1/4        ", "0,0,0          ", "1/3,2/3,1/4    ",    &
                      "1/3,2/3,0      ", "0,0,z          ", "1/2,0,0        ",    &
                      "x,0,1/4        ", "1/3,2/3,z      ", "x,2x,0         ",    &
                      "x,y,1/4        ", "x,0,z          ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(231)= wyck_info_type("P 63/M M C  ",11,     &
                    (/"0,0,0          ", "0,0,1/4        ", "1/3,2/3,1/4    ",    &
                      "1/3,2/3,3/4    ", "0,0,z          ", "1/3,2/3,z      ",    &
                      "1/2,0,0        ", "x,2x,1/4       ", "x,0,0          ",    &
                      "x,y,1/4        ", "x,2x,z         ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(232)= wyck_info_type("P 2 3       ", 9,     &
                    (/"0,0,0          ", "1/2,1/2,1/2    ", "0,1/2,1/2      ",    &
                      "1/2,0,0        ", "x,x,x          ", "x,0,0          ",    &
                      "x,0,1/2        ", "x,1/2,0        ", "x,1/2,1/2      ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(233)= wyck_info_type("F 2 3       ", 7,     &
                    (/"0,0,0          ", "1/2,1/2,1/2    ", "1/4,1/4,1/4    ",    &
                      "3/4,3/4,3/4    ", "x,x,x          ", "x,0,0          ",    &
                      "x,1/4,1/4      ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(234)= wyck_info_type("I 2 3       ", 5,     &
                    (/"0,0,0          ", "0,1/2,1/2      ", "x,x,x          ",    &
                      "x,0,0          ", "x,1/2,0        ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(235)= wyck_info_type("P 21 3      ", 1,     &
                    (/"x,x,x          ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(236)= wyck_info_type("I 21 3      ", 2,     &
                    (/"x,x,x          ", "x,0,1/4        ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(237)= wyck_info_type("P M -3      ",11,     &
                    (/"0,0,0          ", "1/2,1/2,1/2    ", "0,1/2,1/2      ",    &
                      "1/2,0,0        ", "x,0,0          ", "x,0,1/2        ",    &
                      "x,1/2,0        ", "x,1/2,1/2      ", "x,x,x          ",    &
                      "0,y,z          ", "1/2,y,z        ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(238)= wyck_info_type("P N -3:1    ", 7,     &
                    (/"0,0,0          ", "1/4,1/4,1/4    ", "3/4,3/4,3/4    ",    &
                      "0,1/2,1/2      ", "x,x,x          ", "x,0,0          ",    &
                      "x,1/2,0        ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(239)= wyck_info_type("P N -3      ", 7,     &
                    (/"1/4,1/4,1/4    ", "0,0,0          ", "1/2,1/2,1/2    ",    &
                      "1/4,3/4,3/4    ", "x,x,x          ", "x,1/4,1/4      ",    &
                      "x,3/4,1/4      ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(240)= wyck_info_type("F M -3      ", 8,     &
                    (/"0,0,0          ", "1/2,1/2,1/2    ", "1/4,1/4,1/4    ",    &
                      "0,1/4,1/4      ", "x,0,0          ", "x,x,x          ",    &
                      "x,1/4,1/4      ", "0,y,z          ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(241)= wyck_info_type("F D -3:1    ", 6,     &
                    (/"0,0,0          ", "1/2,1/2,1/2    ", "1/8,1/8,1/8    ",    &
                      "5/8,5/8,5/8    ", "x,x,x          ", "x,0,0          ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(242)= wyck_info_type("F D -3      ", 6,     &
                    (/"1/8,1/8,1/8    ", "5/8,5/8,5/8    ", "0,0,0          ",    &
                      "1/2,1/2,1/2    ", "x,x,x          ", "x,1/8,1/8      ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(243)= wyck_info_type("I M -3      ", 7,     &
                    (/"0,0,0          ", "0,1/2,1/2      ", "1/4,1/4,1/4    ",    &
                      "x,0,0          ", "x,0,1/2        ", "x,x,x          ",    &
                      "0,y,z          ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(244)= wyck_info_type("P A -3      ", 3,     &
                    (/"0,0,0          ", "1/2,1/2,1/2    ", "x,x,x          ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(245)= wyck_info_type("I A -3      ", 4,     &
                    (/"0,0,0          ", "1/4,1/4,1/4    ", "x,x,x          ",    &
                      "x,0,1/4        ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(246)= wyck_info_type("P 4 3 2     ",10,     &
                    (/"0,0,0          ", "1/2,1/2,1/2    ", "0,1/2,1/2      ",    &
                      "1/2,0,0        ", "x,0,0          ", "x,1/2,1/2      ",    &
                      "x,x,x          ", "x,1/2,0        ", "0,y,y          ",    &
                      "1/2,y,y        ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(247)= wyck_info_type("P 42 3 2    ",12,     &
                    (/"0,0,0          ", "1/4,1/4,1/4    ", "3/4,3/4,3/4    ",    &
                      "0,1/2,1/2      ", "1/4,0,1/2      ", "1/4,1/2,0      ",    &
                      "x,x,x          ", "x,0,0          ", "x,0,1/2        ",    &
                      "x,1/2,0        ", "1/4,y,-y+1/2   ", "1/4,y,y+1/2    ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(248)= wyck_info_type("F 4 3 2    ", 9,     &
                    (/"0,0,0          ", "1/2,1/2,1/2    ", "1/4,1/4,1/4    ",    &
                      "0,1/4,1/4      ", "x,0,0          ", "x,x,x          ",    &
                      "0,y,y          ", "1/2,y,y        ", "x,1/4,1/4      ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(249)= wyck_info_type("F 41 3 2    ", 7,     &
                    (/"0,0,0          ", "1/2,1/2,1/2    ", "1/8,1/8,1/8    ",    &
                      "5/8,5/8,5/8    ", "x,x,x          ", "x,0,0          ",    &
                      "1/8,y,-y+1/4   ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(250)= wyck_info_type("I 4 3 2     ", 9,     &
                    (/"0,0,0          ", "0,1/2,1/2      ", "1/4,1/4,1/4    ",    &
                      "1/4,1/2,0      ", "x,0,0          ", "x,x,x          ",    &
                      "x,1/2,0        ", "0,y,y          ", "1/4,y,-y+1/2   ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(251)= wyck_info_type("P 43 3 2    ", 4,     &
                    (/"1/8,1/8,1/8    ", "5/8,5/8,5/8    ", "x,x,x          ",    &
                      "1/8,y,-y+1/4   ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(252)= wyck_info_type("P 41 3 2    ", 4,     &
                    (/"3/8,3/8,3/8    ", "7/8,7/8,7/8    ", "x,x,x          ",    &
                      "1/8,y,y+1/4    ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(253)= wyck_info_type("I 41 3 2    ", 8,     &
                    (/"1/8,1/8,1/8    ", "7/8,7/8,7/8    ", "1/8,0,1/4      ",    &
                      "5/8,0,1/4      ", "x,x,x          ", "x,0,1/4        ",    &
                      "1/8,y,y+1/4    ", "1/8,y,-y+1/4   ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(254)= wyck_info_type("P -4 3 M    ", 9,     &
                    (/"0,0,0          ", "1/2,1/2,1/2    ", "0,1/2,1/2      ",    &
                      "1/2,0,0        ", "x,x,x          ", "x,0,0          ",    &
                      "x,1/2,1/2      ", "x,1/2,0        ", "x,x,z          ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(255)= wyck_info_type("F -4 3 M    ", 8,     &
                    (/"0,0,0          ", "1/2,1/2,1/2    ", "1/4,1/4,1/4    ",    &
                      "3/4,3/4,3/4    ", "x,x,x          ", "x,0,0          ",    &
                      "x,1/4,1/4      ", "x,x,z          ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(256)= wyck_info_type("I -4 3 M    ", 7,     &
                    (/"0,0,0          ", "0,1/2,1/2      ", "x,x,x          ",    &
                      "1/4,1/2,0      ", "x,0,0          ", "x,1/2,0        ",    &
                      "x,x,z          ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(257)= wyck_info_type("P -4 3 N    ", 8,     &
                    (/"0,0,0          ", "0,1/2,1/2      ", "1/4,1/2,0      ",    &
                      "1/4,0,1/2      ", "x,x,x          ", "x,0,0          ",    &
                      "x,1/2,0        ", "x,0,1/2        ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(258)= wyck_info_type("F -4 3 C    ", 7,     &
                    (/"0,0,0          ", "1/4,1/4,1/4    ", "0,1/4,1/4      ",    &
                      "1/4,0,0        ", "x,x,x          ", "x,0,0          ",    &
                      "x,1/4,1/4      ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(259)= wyck_info_type("I -4 3 D    ", 4,     &
                    (/"3/8,0,1/4      ", "7/8,0,1/4      ", "x,x,x          ",    &
                      "x,0,1/4        ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(260)= wyck_info_type("P M -3 M    ",13,     &
                    (/"0,0,0          ", "1/2,1/2,1/2    ", "0,1/2,1/2      ",    &
                      "1/2,0,0        ", "x,0,0          ", "x,1/2,1/2      ",    &
                      "x,x,x          ", "x,1/2,0        ", "0,y,y          ",    &
                      "1/2,y,y        ", "0,y,z          ", "1/2,y,z        ",    &
                      "x,x,z          ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(261)= wyck_info_type("P N -3 N:1  ", 8,     &
                    (/"0,0,0          ", "0,1/2,1/2      ", "1/4,1/4,1/4    ",    &
                      "1/4,0,1/2      ", "x,0,0          ", "x,x,x          ",    &
                      "x,0,1/2        ", "0,y,y          ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(262)= wyck_info_type("P N -3 N    ", 8,     &
                    (/"1/4,1/4,1/4    ", "3/4,1/4,1/4    ", "0,0,0          ",    &
                      "0,3/4,1/4      ", "x,1/4,1/4      ", "x,x,x          ",    &
                      "x,3/4,1/4      ", "1/4,y,y        ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(263)= wyck_info_type("P M -3 N    ",11,     &
                    (/"0,0,0          ", "0,1/2,1/2      ", "1/4,0,1/2      ",    &
                      "1/4,1/2,0      ", "1/4,1/4,1/4    ", "x,0,0          ",    &
                      "x,0,1/2        ", "x,1/2,0        ", "x,x,x          ",    &
                      "1/4,y,y+1/2    ", "0,y,z          ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(264)= wyck_info_type("P N -3 M:1  ",11,     &
                    (/"0,0,0          ", "1/4,1/4,1/4    ", "3/4,3/4,3/4    ",    &
                      "0,1/2,1/2      ", "x,x,x          ", "1/4,0,1/2      ",    &
                      "x,0,0          ", "x,0,1/2        ", "1/4,y,-y+1/2   ",    &
                      "1/4,y,y+1/2    ", "x,x,z          ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(265)= wyck_info_type("P N -3 M    ",11,     &
                    (/"1/4,1/4,1/4    ", "0,0,0          ", "1/2,1/2,1/2    ",    &
                      "1/4,3/4,3/4    ", "x,x,x          ", "1/2,1/4,3/4    ",    &
                      "x,1/4,1/4      ", "x,1/4,3/4      ", "1/2,y,y+1/2    ",    &
                      "1/2,y,-y       ", "x,x,z          ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(266)= wyck_info_type("F M -3 M    ",11,     &
                    (/"0,0,0          ", "1/2,1/2,1/2    ", "1/4,1/4,1/4    ",    &
                      "0,1/4,1/4      ", "x,0,0          ", "x,x,x          ",    &
                      "x,1/4,1/4      ", "0,y,y          ", "1/2,y,y        ",    &
                      "0,y,z          ", "x,x,z          ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(267)= wyck_info_type("F M -3 C    ", 9,     &
                    (/"1/4,1/4,1/4    ", "0,0,0          ", "1/4,0,0        ",    &
                      "0,1/4,1/4      ", "x,0,0          ", "x,1/4,1/4      ",    &
                      "x,x,x          ", "1/4,y,y        ", "0,y,z          ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(268)= wyck_info_type("F D -3 M:1  ", 8,     &
                    (/"0,0,0          ", "1/2,1/2,1/2    ", "1/8,1/8,1/8    ",    &
                      "5/8,5/8,5/8    ", "x,x,x          ", "x,0,0          ",    &
                      "x,x,z          ", "1/8,y,-y+1/4   ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(269)= wyck_info_type("F D -3 M    ", 8,     &
                    (/"1/8,1/8,1/8    ", "3/8,3/8,3/8    ", "0,0,0          ",    &
                      "1/2,1/2,1/2    ", "x,x,x          ", "x,1/8,1/8      ",    &
                      "x,x,z          ", "0,y,-y         ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(270)= wyck_info_type("F D -3 C:1  ", 7,     &
                    (/"0,0,0          ", "1/8,1/8,1/8    ", "3/8,3/8,3/8    ",    &
                      "1/4,0,0        ", "x,x,x          ", "x,0,0          ",    &
                      "1/8,y,-y+1/4   ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(271)= wyck_info_type("F D -3 C    ", 7,     &
                    (/"1/8,1/8,1/8    ", "1/4,1/4,1/4    ", "0,0,0          ",    &
                      "7/8,1/8,1/8    ", "x,x,x          ", "x,1/8,1/8      ",    &
                      "1/4,y,-y       ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
      wyckoff_info(272)= wyck_info_type("I M -3 M    ",11,     &
                    (/"0,0,0          ", "0,1/2,1/2      ", "1/4,1/4,1/4    ",    &
                      "1/4,0,1/2      ", "x,0,0          ", "x,x,x          ",    &
                      "x,0,1/2        ", "0,y,y          ", "1/4,y,-y+1/2   ",    &
                      "0,y,z          ", "x,x,z          ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )
       wyckoff_info(273)= wyck_info_type("I A -3 D    ", 7,     &
                    (/"0,0,0          ", "1/8,1/8,1/8    ", "1/8,0,1/4      ",    &
                      "3/8,0,1/4      ", "x,x,x          ", "x,0,1/4        ",    &
                      "1/8,y,-y+1/4   ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               ", "               ",    &
                      "               ", "               "/) )


       return
    End Subroutine Set_Wyckoff_Info

 End Module CFML_Symmetry_Tables
!!-------------------------------------------------------
!!---- Crystallographic Fortran Modules Library (CrysFML)
!!-------------------------------------------------------
!!---- The CrysFML project is distributed under LGPL. In agreement with the
!!---- Intergovernmental Convention of the ILL, this software cannot be used
!!---- in military applications.
!!----
!!---- Copyright (C) 1999-2012  Institut Laue-Langevin (ILL), Grenoble, FRANCE
!!----                          Universidad de La Laguna (ULL), Tenerife, SPAIN
!!----                          Laboratoire Leon Brillouin(LLB), Saclay, FRANCE
!!----
!!---- Authors: Juan Rodriguez-Carvajal (ILL)
!!----          Javier Gonzalez-Platas  (ULL)
!!----
!!---- Contributors: Laurent Chapon     (ILL)
!!----               Marc Janoschek     (Los Alamos National Laboratory, USA)
!!----               Oksana Zaharko     (Paul Scherrer Institute, Switzerland)
!!----               Tierry Roisnel     (CDIFX,Rennes France)
!!----               Eric Pellegrini    (ILL)
!!----
!!---- This library is free software; you can redistribute it and/or
!!---- modify it under the terms of the GNU Lesser General Public
!!---- License as published by the Free Software Foundation; either
!!---- version 3.0 of the License, or (at your option) any later version.
!!----
!!---- This library is distributed in the hope that it will be useful,
!!---- but WITHOUT ANY WARRANTY; without even the implied warranty of
!!---- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
!!---- Lesser General Public License for more details.
!!----
!!---- You should have received a copy of the GNU Lesser General Public
!!---- License along with this library; if not, see <http://www.gnu.org/licenses/>.
!!----
!!----
!!---- MODULE: CFML_Scattering_Chemical_Tables
!!----
!!----   INFO: Tabulated information about atomic chemical and scattering data. A set of fortran
!!----         TYPEs and variables are defined. Tables are declared as allocatable arrays of
!!----         types and they are charged only if the setting (initialising) procedures are called.
!!----         It is convenient in a particular program using this moduled to call the "removing"
!!----         procedures (making a deallocation) to liberate memory after the required information
!!----         is found and stored in user-defined variables.
!!----
!!---- HISTORY
!!----    Updated: 04/03/2011
!!----
!!---- DEPENDENCIES
!!--++    Use CFML_GlobalDeps,       only: Cp
!!--++    Use CFML_String_Utilities, only: L_Case, U_Case
!!----
!!---- VARIABLES
!!----    ANOMALOUS_SC_TYPE
!!----    ANOMALOUS_SCFAC
!!----    CHEM_INFO_TYPE
!!----    CHEM_INFO
!!----    MAGNETIC_FORM_TYPE
!!----    MAGNETIC_FORM
!!----    MAGNETIC_J2
!!----    MAGNETIC_J4
!!----    MAGNETIC_J6
!!----    NUM_CHEM_INFO
!!----    NUM_DELTA_FP
!!----    NUM_MAG_FORM
!!----    NUM_MAG_J2
!!----    NUM_MAG_J4
!!----    NUM_MAG_J6
!!----    NUM_XRAY_FORM
!!----    XRAY_FORM_TYPE
!!----    XRAY_FORM
!!----    XRAY_WAVELENGTH_TYPE
!!----    XRAY_WAVELENGTHS
!!----
!!---- PROCEDURES
!!----    Functions:
!!----
!!----    Subroutines:
!!----       GET_ATOMIC_MASS
!!----       GET_ATOMIC_VOL
!!----       GET_CHEMSYMB
!!----       GET_COVALENT_RADIUS
!!----       GET_FERMI_LENGTH
!!----       GET_ABS_XS
!!----       GET_INC_XS
!!----       GET_IONIC_RADIUS
!!----       REMOVE_CHEM_INFO
!!----       REMOVE_DELTA_FP_FPP
!!----       REMOVE_MAGNETIC_FORM
!!----       REMOVE_XRAY_FORM
!!----       SET_CHEM_INFO
!!----       SET_DELTA_FP_FPP
!!----       SET_MAGNETIC_FORM
!!----       SET_XRAY_FORM
!!----
!!
 Module CFML_Scattering_Chemical_Tables
    !---- Use Modules ----!
    Use CFML_GlobalDeps,       only: Cp
    Use CFML_String_Utilities, only: U_Case, L_Case

    implicit none

    private

    !---- List of public subroutines ----!
    public :: Get_Atomic_Mass, Get_Atomic_Vol, Get_ChemSymb, Get_Covalent_radius, Get_Ionic_radius
    public :: Get_Fermi_Length, Get_Abs_Xs, Get_Inc_Xs
    public :: Remove_Chem_Info, Remove_Delta_Fp_Fpp, Remove_Magnetic_Form, Remove_Xray_Form
    public :: Set_Chem_Info, Set_Delta_Fp_Fpp, Set_Magnetic_Form, Set_Xray_Form

    !---- Definitions ----!

    !!----
    !!---- TYPE, PUBLIC :: ANOMALOUS_SC_TYPE
    !!--..
    !!---- Type, public :: Anomalous_Sc_Type
    !!----    character (len= 2)           :: Symb  ! Symbol of the Chemical species
    !!----    real(kind=cp), dimension(5)  :: Fp    ! Delta Fp
    !!----    real(kind=cp), dimension(5)  :: Fpp   ! Delta Fpp
    !!---- End Type Anomalous_Sc_Type
    !!----
    !!---- Update: February - 2005
    !!
    Type, public :: Anomalous_Sc_Type
       character(len= 2)            :: Symb
       real(kind=cp), dimension(5)  :: Fp
       real(kind=cp), dimension(5)  :: Fpp
    End Type Anomalous_Sc_Type

    !!----
    !!---- ANOMALOUS_SCFAC
    !!----    Type(Anomalous_Sc_Type), allocatable, dimension(:), public :: Anomalous_ScFac
    !!----
    !!----    Table of Delta-Fp and Delta-Fpp for 5 common radiations.
    !!----    The order is the following:
    !!--<<
    !!----                          1         2         3          4          5
    !!----        Wavelenghts:     Cr        Fe        Cu         Mo         Ag
    !!----             Lambda   2.28962   1.93597   1.54051    0.70926    0.556363
    !!-->>
    !!----
    !!---- Update: February - 2005
    !!
    Type(Anomalous_Sc_Type), allocatable, dimension(:), public :: Anomalous_ScFac

    !!----
    !!---- TYPE, PUBLIC :: CHEM_INFO_TYPE
    !!--..
    !!---- Type, public :: Chem_Info_Type
    !!----    character (len= 2)         :: Symb     ! Symbol of the Element
    !!----    character (len=12)         :: Name     ! Name of the Element
    !!----    integer                    :: Z        ! Atomic Number
    !!----    real(kind=cp)              :: AtWe     ! Atomic weight
    !!----    real(kind=cp)              :: RCov     ! Covalent Radio
    !!----    real(kind=cp)              :: RWaals   ! van der Waals Radio
    !!----    real(kind=cp)              :: VAtm     ! Atomic volumen
    !!----    integer, dimension(5)      :: Oxid     ! Oxidation State
    !!----    real(kind=cp), dimension(5):: Rion     ! Ionic Radio (depending of the oxidation)
    !!----    real(kind=cp)              :: SctF     ! Scattering length Fermi
    !!----    real(kind=cp)              :: SedInc   ! Incoherent Scattering Neutron cross-section (barns -> [10**(-24) cm**2] )
    !!----    real(kind=cp)              :: Sea      ! Neutron Absorption cross-section ( barns, for v= 2200m/s, l(A)=3.95/v (km/s) )
    !!---- End Type Chem_Info_Type
    !!----
    !!---- Update: February - 2005
    !!
    Type, public :: Chem_Info_Type
       character (len= 2)         :: Symb          ! Symbol of the Element
       character (len=12)         :: Name          ! Name of the Element
       integer                    :: Z             ! Atomic Number
       real(kind=cp)              :: AtWe          ! Atomic weight
       real(kind=cp)              :: RCov          ! Covalent Radius
       real(kind=cp)              :: RWaals        ! van der Waals Radius
       real(kind=cp)              :: VAtm          ! Atomic volumen
       integer, dimension(5)      :: Oxid          ! Oxidation State
       real(kind=cp), dimension(5):: Rion          ! Ionic Radius (depending of the oxidation)
       real(kind=cp)              :: SctF          ! Fermi length [10**(-12) cm]
       real(kind=cp)              :: SedInc        ! Incoherent Scattering Neutron cross-section (barns -> [10**(-24) cm**2] )
       real(kind=cp)              :: Sea           ! Neutron Absorption cross-section ( barns, for v= 2200m/s, l(A)=3.95/v (km/s) )
    End Type Chem_Info_Type

    !!----
    !!---- CHEM_INFO
    !!----    Type (Chem_Info_Type), allocatable, dimension(:), public :: Chem_Info
    !!----
    !!----    Tabulated chemical data according to the items specified in the definition of Chem_Info_Type.
    !!----
    !!---- Update: February - 2005
    !!
    Type(Chem_Info_Type), allocatable, dimension(:), public :: Chem_Info

    !!----
    !!---- TYPE :: MAGNETIC_FORM_TYPE
    !!--..
    !!---- Type, public :: Magnetic_Form_Type
    !!----    character (len= 4)          :: Symb   ! Symbol of the Chemical species
    !!----    real(kind=cp), dimension(7) :: SctM   ! Scattering Factors
    !!---- End Type Magnetic_Form_Type
    !!----
    !!---- Update: February - 2005
    !!
    Type, public :: Magnetic_Form_Type
       character (len= 4)         :: Symb         ! Symbol of the Chemical species
       real(kind=cp), dimension(7):: SctM
    End Type Magnetic_Form_Type

    !!----
    !!---- MAGNETIC_FORM
    !!----    Type (Magnetic_Form_Type), allocatable, dimension(:), public :: Magnetic_Form
    !!----
    !!----    Tabulated magnetic form factor data
    !!----
    !!---- Update: February - 2005
    !!
    Type(Magnetic_Form_Type), allocatable, dimension(:), public :: Magnetic_Form

    !!----
    !!---- MAGNETIC_J2
    !!----    Type (Magnetic_Form_Type), allocatable, dimension(:), public :: Magnetic_j2
    !!----
    !!----    Tabulated magnetic form factor J2
    !!----
    !!---- Update: February - 2005
    !!
    Type(Magnetic_Form_Type), allocatable, dimension(:), public :: Magnetic_j2

    !!----
    !!---- MAGNETIC_J4
    !!----    Type (Magnetic_Form_Type), allocatable, dimension(:), public :: Magnetic_J4
    !!----
    !!----    Tabulated magnetic form factor J4
    !!----
    !!---- Update: February - 2005
    !!
    Type(Magnetic_Form_Type), allocatable, dimension(:), public :: Magnetic_j4

    !!----
    !!---- MAGNETIC_J6
    !!----    Type (Magnetic_Form_Type), allocatable, dimension(:), public :: Magnetic_J6
    !!----
    !!----    Tabulated magnetic form factor J6
    !!----
    !!---- Update: February - 2005
    !!
    Type(Magnetic_Form_Type), allocatable, dimension(:), public :: Magnetic_j6

    !!----
    !!---- NUM_CHEM_INFO
    !!----    integer, parameter, public :: Num_Chem_Info = 108
    !!----
    !!----    Number of total Chem_info Data
    !!----
    !!---- Update: February - 2005
    !!
    integer, parameter, public :: Num_Chem_Info = 108

    !!----
    !!---- NUM_DELTA_FP
    !!----    integer, parameter, public :: Num_Delta_Fp  = 98
    !!----
    !!----    Number of total Delta (Fp,Fpp) Data
    !!----
    !!---- Update: February - 2005
    !!
    integer, parameter, public :: Num_Delta_Fp  = 98

    !!----
    !!---- NUM_MAG_FORM
    !!----    integer, parameter, public :: Num_Mag_Form  = 117
    !!----
    !!----    Number of total Magnetic_Form Data
    !!----
    !!---- Update: February - 2005
    !!
    integer, parameter, public :: Num_Mag_Form  = 119

    !!----
    !!---- NUM_MAG_J2
    !!----    integer, parameter, public :: Num_Mag_J2 = 97
    !!----
    !!----    Number of <j2> Magnetic_Form Data
    !!----
    !!---- Update: February - 2005
    !!
    integer, parameter, public :: Num_Mag_j2  = 97

    !!----
    !!---- NUM_MAG_J4
    !!----    integer, parameter, public :: Num_Mag_J4 = 97
    !!----
    !!----    Number of <j4> Magnetic_Form Data
    !!----
    !!---- Update: February - 2005
    !!
    integer, parameter, public :: Num_Mag_j4  = 97

    !!----
    !!---- NUM_MAG_J6
    !!----    integer, parameter, public :: Num_Mag_J6 = 39
    !!----
    !!----    Number of <j5> Magnetic_Form Data
    !!----
    !!---- Update: February - 2005
    !!
    integer, parameter, public :: Num_Mag_j6  = 39

    !!----
    !!---- NUM_XRAY_FORM
    !!----    integer, parameter, public :: Num_Xray_Form = 214
    !!----
    !!----    Number of total Xray_Form Data
    !!----
    !!---- Update: February - 2005
    !!
    integer, parameter, public :: Num_Xray_Form = 214

    !!----
    !!---- TYPE :: XRAY_FORM_TYPE
    !!--..
    !!---- Type, public :: Xray_Form_Type
    !!----    character (len= 4)         :: Symb  ! Symbol of the Chemical species
    !!----    integer                    :: Z     ! Atomic Number
    !!----    real(kind=cp), dimension(4):: a     ! Coefficients for calculating the X-ray scattering factors
    !!----    real(kind=cp), dimension(4):: b     ! f(s) = Sum_{i=1,4} { a(i) exp(-b(i)*s^2) } + c
    !!----    real(kind=cp)              :: c     ! s=sinTheta/Lambda
    !!---- End Type Xray_Form_Type
    !!----
    !!---- Update: February - 2005
    !!
    Type, public :: Xray_Form_Type
       character (len= 4)         :: Symb
       integer                    :: Z
       real(kind=cp), dimension(4):: a
       real(kind=cp), dimension(4):: b
       real(kind=cp)              :: c
    End Type Xray_Form_Type

    !!----
    !!---- XRAY_FORM
    !!----    Type (Xray_Form_Type), allocatable, dimension(:), public :: Xray_Form
    !!----
    !!----    Tabulated Xray scattering factor coefficients
    !!----
    !!---- Update: February - 2005
    !!
    Type(Xray_Form_Type), allocatable, dimension(:), public :: Xray_Form

    !!----
    !!---- TYPE :: XRAY_WAVELENGTH_TYPE
    !!--..
    !!---- Type, public :: Xray_Wavelength_Type
    !!----    character (len= 2)                :: Symb  ! Symbol of the Chemical species
    !!----    real(kind=cp), dimension(2)       :: Kalfa ! K-Serie for X-ray
    !!----    real(kind=cp)                     :: Kbeta ! K-Serie for X-ray
    !!---- End Type Xray_Wavelength_Type
    !!----
    !!---- Update: February - 2005
    !!
    Type, public :: Xray_Wavelength_Type
       character (len= 2)         :: Symb
       real(kind=cp), dimension(2):: Kalfa
       real(kind=cp)              :: Kbeta
    End Type Xray_Wavelength_Type

    !!----
    !!---- XRAY_WAVELENGTHS
    !!----    Type (Xray_Wavelength_Type), dimension(7), public :: Xray_Wavelengths
    !!----
    !!----    Tabulated K-Series for Xray
    !!----
    !!---- Update: February - 2005
    !!
    Type(Xray_Wavelength_Type), dimension(7), public :: Xray_Wavelengths =(/                            &
                                                Xray_Wavelength_type("CR",(/2.28988,2.29428/),2.08480), &
                                                Xray_Wavelength_type("FE",(/1.93631,1.94043/),1.75650), &
                                                Xray_Wavelength_type("CU",(/1.54059,1.54431/),1.39220), &
                                                Xray_Wavelength_type("MO",(/0.70932,0.71360/),0.63225), &
                                                Xray_Wavelength_type("AG",(/0.55942,0.56380/),0.49708), &
                                                Xray_Wavelength_type("CO",(/1.78919,1.79321/),1.62083), &
                                                Xray_Wavelength_type("NI",(/1.65805,1.66199/),1.50017)  /)

 Contains

    !---------------------!
    !---- Subroutines ----!
    !---------------------!

    !!----
    !!---- Subroutine Get_Atomic_Mass(Atm,Mass)
    !!----    character(len=2), intent(in)  :: Atm
    !!----    real(kind=cp),    intent(out) :: Mass
    !!----
    !!----    Provides the atomic mass given the chemical symbol of the element
    !!----    In case of problems the returned mass is ZERO.
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Get_Atomic_Mass(atm,mass)
       !---- Arguments ----!
       character(len=2), intent (in) :: atm
       real(kind=cp),    intent(out) :: Mass

       !---- Local variables ----!
       character(len=2) :: atm_car
       integer :: i

       mass=0.0
       atm_car=u_case(atm)
       if (.not. allocated(chem_info) ) call set_chem_info()

       do i=1,Num_Chem_Info
          if (index(atm_car,chem_info(i)%Symb) /=0) then
             mass=chem_info(i)%AtWe
             exit
          end if
       end do

       return
    End Subroutine Get_Atomic_Mass

    !!----
    !!---- Subroutine Get_Atomic_Vol(Atm,Vol)
    !!----    character(len=2), intent(in)  :: Atm
    !!----    real(kind=cp),    intent(out) :: Vol
    !!----
    !!----    Provides the atomic volume given the chemical symbol of the element
    !!----    In case of problems the returned Volume is ZERO.
    !!----
    !!---- Update: March- 2013
    !!
    Subroutine Get_Atomic_Vol(atm,vol)
       !---- Arguments ----!
       character(len=2), intent (in) :: atm
       real(kind=cp),    intent(out) :: Vol

       !---- Local variables ----!
       character(len=2) :: atm_car
       integer :: i

       vol=0.0
       atm_car=u_case(atm)
       if (.not. allocated(chem_info) ) call set_chem_info()

       do i=1,Num_Chem_Info
          if (index(atm_car,chem_info(i)%Symb) /=0) then
             vol=chem_info(i)%VAtm
             exit
          end if
       end do

       return
    End Subroutine Get_Atomic_Vol

    !!----
    !!---- Subroutine Get_ChemSymb(Label, ChemSymb, Z)
    !!----   character(len=*),  intent(in) :: Label    ! Label
    !!----   character(len=*),  intent(out):: ChemSymb ! Chemical Symbol
    !!----   integer, optional, intent(out):: Z        ! Atomic number
    !!----
    !!----  Subroutine to get the chemical symbol from label and optionally
    !!----  the atomic number
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Get_ChemSymb(Label, ChemSymb, Z)
       !---- Argument ----!
       character(len=*),  intent(in) :: Label    ! Label
       character(len=*),  intent(out):: ChemSymb ! Chemical Symbol
       integer, optional, intent(out):: Z        ! Atomic number

       !---- Local variables ----!
       character(len=*),  parameter :: parcar="1234567890+-."
       character(len=2)             :: car
       integer                      :: npos

       ChemSymb="**"
       car=adjustl(label)
       npos=index(parcar,car(2:2))
       if (npos /=0) car(2:2)=" "
       car=u_case(car)
       car(2:2)=l_case(car(2:2))
       ChemSymb=car

       if (present(z)) then
          if (.not. allocated(chem_info) ) call set_chem_info()
          car=u_case(chemsymb)
          do npos=1,num_chem_info
             if (car == Chem_Info(npos)%Symb) then
                Z=Chem_Info(npos)%Z
                exit
             end if
          end do
       end if

       return
    End Subroutine Get_ChemSymb

    !!----
    !!---- Subroutine Get_Covalent_Radius(nam,rad)
    !!----    character(len=*), intent (in) :: nam
    !!----    real(kind=cp),    intent(out) :: rad
    !!----
    !!----    Provides the covalent radius given the chemical symbol of the element
    !!----    In case of problems the returned radius is 1.4 angstroms.
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Get_Covalent_Radius(nam,rad)
       !---- Arguments ----!
       character(len=*), intent (in) :: nam
       real(kind=cp),    intent(out) :: rad

       !---- Local variables ----!
       character(len=2) :: atm_car
       integer          :: i

       rad=1.4
       atm_car=u_case(nam(1:2))
       if (atm_car(2:2) > "Z" .or. atm_car(2:2) < "A") atm_car(2:2)=" "
       if (.not. allocated(chem_info) ) call set_chem_info()
       do i=1,Num_Chem_Info
          if (index(atm_car,chem_info(i)%Symb) /=0) then
             rad=chem_info(i)%RCov
             exit
          end if
       end do

       return
    End Subroutine Get_Covalent_Radius

    !!----
    !!---- Subroutine Get_Fermi_Length(nam,b)
    !!----    character(len=*), intent (in) :: nam
    !!----    real(kind=cp),    intent(out) :: b
    !!----
    !!----    Provides the Fermi length (in 10-12 cm) given the chemical
    !!----    symbol of the element. In case of problems the returned Fermi
    !!----    length is 0.0 10-12 cm.
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Get_Fermi_Length(nam,b)
       !---- Arguments ----!
       character(len=*), intent (in) :: nam
       real(kind=cp),    intent(out) :: b

       !---- Local variables ----!
       character(len=2) :: atm_car
       integer          :: i

       b=0.0
       atm_car=u_case(nam(1:2))
       if (atm_car(2:2) > "Z" .or. atm_car(2:2) < "A") atm_car(2:2)=" "
       if (.not. allocated(chem_info) ) call set_chem_info()
       do i=1,Num_Chem_Info
          if (index(atm_car,chem_info(i)%Symb) /=0) then
             b=chem_info(i)%SctF
             exit
          end if
       end do

       return
    End Subroutine Get_Fermi_Length

    !!----
    !!---- Subroutine Get_Inc_Xs(nam,u)
    !!----    character(len=*), intent (in) :: nam
    !!----    real(kind=cp),    intent(out) :: u
    !!----
    !!----    Provides incoherent scattering neutron cross-section (barns -> [10**(-24) cm**2] )
    !!----    for given chemical symbol of the element. In case of problems the returned value is 0.0.
    !!----
    !!----
    !!---- Update: Mai - 2013
    !!

    Subroutine Get_Inc_Xs(nam,u)
       !---- Arguments ----!
       character(len=*), intent (in) :: nam
       real(kind=cp),    intent(out) :: u

       !---- Local variables ----!
       character(len=2) :: atm_car
       integer          :: i

       u=0.0
       atm_car=u_case(nam(1:2))
       if (atm_car(2:2) > "Z" .or. atm_car(2:2) < "A") atm_car(2:2)=" "
       if (.not. allocated(chem_info) ) call set_chem_info()
       do i=1,Num_Chem_Info
          if (index(atm_car,chem_info(i)%Symb) /=0) then
             u=chem_info(i)%SedInc
             exit
          end if
       end do

       return
    End Subroutine Get_Inc_Xs

    !!----
    !!---- Subroutine Get_Abs_Xs(nam,u)
    !!----    character(len=*), intent (in) :: nam
    !!----    real(kind=cp),    intent(out) :: u
    !!----
    !!----    Provides the absorption cross-section ( barns, for v= 2200m/s, l(A)=3.95/v (km/s) )
    !!----    for given chemical symbol of the element. In case of problems the returned value is 0.0.
    !!----
    !!----
    !!---- Update: April - 2013
    !!

    Subroutine Get_Abs_Xs(nam,u)
       !---- Arguments ----!
       character(len=*), intent (in) :: nam
       real(kind=cp),    intent(out) :: u

       !---- Local variables ----!
       character(len=2) :: atm_car
       integer          :: i

       u=0.0
       atm_car=u_case(nam(1:2))
       if (atm_car(2:2) > "Z" .or. atm_car(2:2) < "A") atm_car(2:2)=" "
       if (.not. allocated(chem_info) ) call set_chem_info()
       do i=1,Num_Chem_Info
          if (index(atm_car,chem_info(i)%Symb) /=0) then
             u=chem_info(i)%Sea
             exit
          end if
       end do

       return
    End Subroutine Get_Abs_Xs

    !!----
    !!---- Subroutine Get_Ionic_Radius(nam,valence,rad)
    !!----    character(len=*), intent (in) :: nam
    !!----    integer,          intent (in) :: valence
    !!----    real(kind=cp),    intent(out) :: rad
    !!----
    !!----    Provides the ionic radius given the chemical symbol of the element
    !!----    and the valence as an integer. In case of problems the returned radius is 0.0 angstroms.
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Get_Ionic_Radius(nam,valence,rad)
       !---- Arguments ----!
       character(len=*), intent (in) :: nam
       integer,          intent (in) :: valence
       real(kind=cp),    intent(out) :: rad

       !---- Local variables ----!
       character(len=2) :: atm_car
       integer          :: i,j

       rad=0.0
       atm_car=u_case(nam(1:2))
       if (atm_car(2:2) > "Z" .or. atm_car(2:2) < "A") atm_car(2:2)=" "
       if (.not. allocated(chem_info) ) call set_chem_info()
       do i=1,Num_Chem_Info
          if (index(atm_car,chem_info(i)%Symb) /=0) then
             do j=1,5
                if (valence == chem_info(i)%oxid(j)) then
                   rad=chem_info(i)%Rion(j)
                   exit
                end if
             end do
          end if
       end do

       return
    End Subroutine Get_Ionic_Radius

    !!----
    !!---- Subroutine Remove_Chem_Info()
    !!----
    !!----    Deallocate Chem_Info Table
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Remove_Chem_Info()

       if (allocated(chem_info)) deallocate(chem_info)

       return
    End Subroutine Remove_Chem_Info

    !!----
    !!---- Subroutine Remove_Delta_Fp_Fpp()
    !!----
    !!----    Deallocate Anomalous_ScFac Table
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Remove_Delta_Fp_Fpp()

       if (allocated(Anomalous_ScFac)) deallocate(Anomalous_ScFac)

       return
    End Subroutine Remove_Delta_Fp_Fpp

    !!----
    !!---- Subroutine Remove_Magnetic_Form()
    !!----
    !!----    Deallocate Magnetic_Form Table
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Remove_Magnetic_Form()

       if (allocated(Magnetic_Form)) deallocate(Magnetic_Form)
       if (allocated(Magnetic_j2))   deallocate(Magnetic_j2)
       if (allocated(Magnetic_j4))   deallocate(Magnetic_j4)
       if (allocated(Magnetic_j6))   deallocate(Magnetic_j6)

       return
    End Subroutine Remove_Magnetic_form

    !!----
    !!---- Subroutine Remove_Xray_Form()
    !!----
    !!----    Deallocate Xray_Form Table
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Remove_Xray_Form()

       if (allocated(Xray_Form)) deallocate(Xray_Form)

       return
    End Subroutine Remove_Xray_form

    !!----
    !!---- Subroutine Set_Chem_Info()
    !!----    Allocates and loads the table  chem_info(num_chem_info):
    !!--<<
    !!----        1: Symbol of the Element
    !!----        2: Name of the Element
    !!----        3: Atomic Number
    !!----        4: Atomic weight
    !!----        5: Covalent Radius
    !!----        6: Van der Waals Radius
    !!----        7: Atomic volumen
    !!----        8: Oxidation State (5 states)
    !!----        9: Ionic Radius (depending of the oxidation)
    !!----       10: Fermi lenght [10**(-12) cm]
    !!----       11: Incoherent Scattering Neutron cross-section (barns -> [10**(-24) cm**2] )
    !!----       12: Neutron Absorption cross-section ( barns, for v= 2200m/s, l(A)=3.95/v (km/s) )
    !!-->>
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Set_Chem_Info()

       if (.not. allocated(chem_info)) allocate(chem_info(num_chem_info))

       !  Symb , Name, Z , AtWe  , RCov , RWaals, VAtm, Oxid(5), Rion(5), b=SctF, SedInc, Sea
       chem_info( 1:10) = (/  &
                          chem_info_type("H ","Hydrogen    ",  1,  1.00797, 0.320, 1.33, 14.1, (/-1, 1, 0, 0, 0/)  ,  &
                                                           (/ 2.08, 0.00, 0.00, 0.00, 0.00/),-0.3739,80.2600,  0.33260    ) ,  &
                          chem_info_type("HE","Helium      ",  2,  4.00260, 0.930, 1.50, 31.8, (/ 0, 0, 0, 0, 0/)  ,  &
                                                           (/ 0.00, 0.00, 0.00, 0.00, 0.00/), 0.3260, 0.0000,  0.00747    ) ,  &
                          chem_info_type("LI","Lithium     ",  3,  6.94100, 1.230, 1.78, 13.1, (/ 1, 0, 0, 0, 0/)  ,  &
                                                           (/ 0.60, 0.00, 0.00, 0.00, 0.00/),-0.1900, 0.9200, 70.50000    ) ,  &
                          chem_info_type("BE","Beryllium   ",  4,  9.01218, 0.900, 1.45,  5.0, (/ 2, 0, 0, 0, 0/)  ,  &
                                                           (/ 0.31, 0.00, 0.00, 0.00, 0.00/), 0.7790, 0.0018,  0.00760    ) ,  &
                          chem_info_type("B ","Boron       ",  5, 10.81000, 0.820, 1.93,  4.6, (/ 3, 0, 0, 0, 0/)  ,  &
                                                           (/ 0.20, 0.00, 0.00, 0.00, 0.00/), 0.5300, 1.7000,767.00000    ) ,  &
                          chem_info_type("C ","Carbon      ",  6, 12.01100, 0.770, 1.70,  5.3, (/ 2,-4, 4, 0, 0/)  ,  &
                                                           (/ 2.60, 0.15, 0.00, 0.00, 0.00/), 0.6646, 0.0010,  0.0035     ) ,  &
                          chem_info_type("N ","Nitrogen    ",  7, 14.00670, 0.750, 1.70, 17.3, (/ 2,-3, 3, 4, 5/)  ,  &
                                                           (/ 0.00, 1.71, 0.00, 0.00, 0.11/), 0.9360, 0.5000,  1.9000     ) ,  &
                          chem_info_type("O ","Oxygen      ",  8, 15.99940, 0.730, 1.50, 14.0, (/-2, 6, 0, 0, 0/)  ,  &
                                                           (/ 1.40, 0.09, 0.00, 0.00, 0.00/), 0.5803, 0.0000,  0.00019    ) ,  &
                          chem_info_type("F ","Fluorine    ",  9, 18.99840, 0.720, 1.47, 17.1, (/-1, 7, 0, 0, 0/)  ,  &
                                                           (/ 1.36, 0.07, 0.00, 0.00, 0.00/), 0.5654, 0.0008,  0.0096     ) ,  &
                          chem_info_type("NE","Neon        ", 10, 20.17900, 0.710, 1.50, 16.8, (/ 0, 0, 0, 0, 0/)  ,  &
                                                           (/ 0.00, 0.00, 0.00, 0.00, 0.00/), 0.4566, 0.0080,  0.0039     ) /)

       chem_info(11:20) = (/  &
                          chem_info_type("NA","Sodium      ", 11, 22.98977, 1.540, 2.07, 23.7, (/ 1, 0, 0, 0, 0/)  ,  &
                                                           (/ 0.95, 0.00, 0.00, 0.00, 0.00/), 0.3630, 1.6200,  0.5300     ) ,  &
                          chem_info_type("MG","Magnesium   ", 12, 24.30500, 1.360, 2.20, 14.0, (/ 2, 0, 0, 0, 0/)  ,  &
                                                           (/ 0.65, 0.00, 0.00, 0.00, 0.00/), 0.5375, 0.0800,  0.063      ) ,  &
                          chem_info_type("AL","Aluminum    ", 13, 26.98154, 1.180, 2.45, 10.0, (/ 3, 0, 0, 0, 0/)  ,  &
                                                           (/ 0.50, 0.00, 0.00, 0.00, 0.00/), 0.3449, 0.0082,  0.231      ) ,  &
                          chem_info_type("SI","Silicon     ", 14, 28.08600, 1.310, 2.30, 12.1, (/-1, 4, 0, 0, 0/)  ,  &
                                                           (/ 2.71, 0.41, 0.00, 0.00, 0.00/), 0.4149, 0.0040,  0.171       ) , &
                          chem_info_type("P ","Phosphorus  ", 15, 30.97376, 1.060, 2.15, 17.0, (/-3, 3, 4, 5, 0/)  ,  &
                                                           (/ 2.12, 0.00, 0.00, 0.34, 0.00/), 0.5130, 0.0050,  0.172      ) ,  &
                          chem_info_type("S ","Sulfur      ", 16, 32.06000, 1.020, 1.74, 15.5, (/-2, 2, 4, 6, 0/)  ,  &
                                                           (/ 1.84, 0.29, 0.00, 0.00, 0.00/), 0.2847, 0.0070,  0.530      ) ,  &
                          chem_info_type("CL","Chlorine    ", 17, 35.45300, 0.990, 1.76, 18.7, (/-1, 1, 3, 5, 7/)  ,  &
                                                           (/ 1.81, 0.00, 0.00, 0.00, 0.26/), 0.9577, 5.3000, 33.500      ) ,  &
                          chem_info_type("AR","Argon       ", 18, 39.94800, 0.980, 2.00, 24.2, (/ 0, 0, 0, 0, 0/)  ,  &
                                                           (/ 0.00, 0.00, 0.00, 0.00, 0.00/), 0.1909, 0.2250,  0.675      ) ,  &
                          chem_info_type("K ","Potassium   ", 19, 39.09800, 2.030, 2.43, 45.3, (/ 1, 0, 0, 0, 0/)  ,  &
                                                           (/ 1.33, 0.00, 0.00, 0.00, 0.00/), 0.3670, 0.2700,  2.100      ) ,  &
                          chem_info_type("CA","Calcium     ", 20, 40.08000, 1.740, 2.09, 29.9, (/ 2, 0, 0, 0, 0/)  ,  &
                                                           (/ 0.99, 0.00, 0.00, 0.00, 0.00/), 0.4700, 0.0500,  0.430      ) /)

       chem_info(21:30) = (/  &
                          chem_info_type("SC","Scandium    ", 21, 44.95590, 1.440, 2.54, 15.0, (/ 3, 0, 0, 0, 0/)  ,  &
                                                           (/ 0.81, 0.00, 0.00, 0.00, 0.00/), 1.2290, 4.5000, 27.500      ) ,  &
                          chem_info_type("TI","Titanium    ", 22, 47.8670, 1.320, 2.57, 10.6, (/ 2, 4, 0, 0, 0/)  ,  &
                                                           (/ 0.90, 0.68, 0.00, 0.00, 0.00/),-0.3438, 2.8700,  6.090      ) ,  &
                          chem_info_type("V ","Vanadium    ", 23, 50.94140, 1.320, 2.43,  8.3, (/ 2, 3, 4, 5, 0/)  ,  &
                                                           (/ 0.00, 0.74, 0.00, 0.59, 0.00/),-0.0382, 5.0800,  5.080      ) ,  &
                          chem_info_type("CR","Chromium    ", 24, 51.99600, 1.180, 2.45,  7.2, (/ 2, 3, 6, 0, 0/)  ,  &
                                                           (/ 0.00, 0.69, 0.52, 0.00, 0.00/), 0.3635, 1.8370,  3.050      ) ,  &
                          chem_info_type("MN","Manganese   ", 25, 54.93800, 1.170, 2.45,  7.4, (/ 2, 3, 4, 6, 7/)  ,  &
                                                           (/ 0.80, 0.72, 0.53, 0.46, 0.46/),-0.3730, 0.4000, 13.300      ) ,  &
                          chem_info_type("FE","Iron        ", 26, 55.84700, 1.170, 2.44,  7.1, (/ 2, 3, 0, 0, 0/)  ,  &
                                                           (/ 0.76, 0.64, 0.00, 0.00, 0.00/), 0.9450, 0.4000,  2.560      ) ,  &
                          chem_info_type("CO","Cobalt      ", 27, 58.93320, 1.160, 2.43,  6.7, (/ 2, 3, 0, 0, 0/)  ,  &
                                                           (/ 0.74, 0.63, 0.00, 0.00, 0.00/), 0.2490, 4.8000, 37.180      ) ,  &
                          chem_info_type("NI","Nickel      ", 28, 58.70000, 1.160, 2.60,  6.6, (/ 2, 3, 0, 0, 0/)  ,  &
                                                           (/ 0.74, 0.63, 0.00, 0.00, 0.00/), 1.0300, 5.2000,  4.490      ) ,  &
                          chem_info_type("CU","Copper      ", 29, 63.54600, 1.170, 2.62,  7.1, (/ 1, 2, 0, 0, 0/)  ,  &
                                                           (/ 0.96, 0.69, 0.00, 0.00, 0.00/), 0.7718, 0.5500,  3.780      ) ,  &
                          chem_info_type("ZN","Zinc        ", 30, 65.38000, 1.250, 2.55,  9.2, (/ 2, 0, 0, 0, 0/)  ,  &
                                                           (/ 0.74, 0.00, 0.00, 0.00, 0.00/), 0.5680, 0.0770,  1.110      ) /)

       chem_info(31:40) = (/  &
                          chem_info_type("GA","Gallium     ", 31, 69.72000, 1.260, 2.32, 11.8, (/ 1, 3, 0, 0, 0/)  ,  &
                                                           (/ 1.13, 0.62, 0.00, 0.00, 0.00/), 0.7288, 0.1600,  2.750      ) ,  &
                          chem_info_type("GE","Germanium   ", 32, 72.59000, 1.220, 2.27, 13.6, (/ 2, 4, 0, 0, 0/)  ,  &
                                                           (/ 0.93, 0.53, 0.00, 0.00, 0.00/), 0.8185, 0.1700,  2.200      ) ,  &
                          chem_info_type("AS","Arsenic     ", 33, 74.92160, 1.200, 2.11, 13.1, (/-3, 3, 5, 0, 0/)  ,  &
                                                           (/ 2.22, 0.00, 0.47, 0.00, 0.00/), 0.6580, 0.0600,  4.500      ) ,  &
                          chem_info_type("SE","Selenium    ", 34, 78.96000, 1.160, 2.32, 16.5, (/-2, 2, 4, 6, 0/)  ,  &
                                                           (/ 1.98, 0.00, 0.00, 0.42, 0.00/), 0.7970, 0.3200, 11.700      ) ,  &
                          chem_info_type("BR","Bromine     ", 35, 79.90400, 1.140, 1.85, 23.5, (/-1, 1, 3, 5, 7/)  ,  &
                                                           (/ 1.95, 0.00, 0.00, 0.00, 0.39/), 0.6795, 0.1000,  6.900      ) ,  &
                          chem_info_type("KR","Krypton     ", 36, 83.80000, 1.120, 2.50, 32.2, (/ 0, 0, 0, 0, 0/)  ,  &
                                                           (/ 0.00, 0.00, 0.00, 0.00, 0.00/), 0.7810, 0.0100, 25.000      ) ,  &
                          chem_info_type("RB","Rubidium    ", 37, 85.46780, 2.160, 2.57, 55.9, (/ 1, 0, 0, 0, 0/)  ,  &
                                                           (/ 1.48, 0.00, 0.00, 0.00, 0.00/), 0.7090, 0.5000,  0.380      ) ,  &
                          chem_info_type("SR","Strontium   ", 38, 87.62000, 1.910, 2.22, 33.7, (/ 2, 0, 0, 0, 0/)  ,  &
                                                           (/ 1.13, 0.00, 0.00, 0.00, 0.00/), 0.7020, 0.0600,  1.280      ) ,  &
                          chem_info_type("Y ","Yttrium     ", 39, 88.90590, 1.620, 2.88, 19.8, (/ 3, 0, 0, 0, 0/)  ,  &
                                                           (/ 0.93, 0.00, 0.00, 0.00, 0.00/), 0.7750, 0.1500,  1.280      ) ,  &
                          chem_info_type("ZR","Zirconium   ", 40, 91.22000, 1.450, 2.66, 14.1, (/ 4, 0, 0, 0, 0/)  ,  &
                                                           (/ 0.80, 0.00, 0.00, 0.00, 0.00/), 0.7160, 0.0200,  0.185      ) /)

       chem_info(41:50) = (/  &
                          chem_info_type("NB","Niobium     ", 41, 92.90640, 1.340, 2.58, 10.8, (/ 3, 5, 0, 0, 0/)  ,  &
                                                           (/ 0.70, 0.00, 0.00, 0.00, 0.00/), 0.7054, 0.0024,  1.150      ) ,  &
                          chem_info_type("MO","Molybdenum  ", 42, 95.94000, 1.300, 2.57,  9.4, (/ 2, 3, 4, 5, 6/)  ,  &
                                                           (/ 0.00, 0.00, 0.68, 0.00, 0.62/), 0.6715, 0.0400,  2.480      ) ,  &
                          chem_info_type("TC","Technetium  ", 43, 97.00000, 1.270, 2.45,  0.0, (/ 7, 0, 0, 0, 0/)  ,  &
                                                           (/ 0.00, 0.00, 0.00, 0.00, 0.00/), 0.6800, 0.5000, 20.000      ) ,  &
                          chem_info_type("RU","Ruthenium   ", 44,101.07000, 1.250, 2.50,  8.3, (/ 2, 3, 4, 6, 8/)  ,  &
                                                           (/ 0.00, 0.69, 0.67, 0.00, 0.00/), 0.7030, 0.4000,  2.560      ) ,  &
                          chem_info_type("RH","Rhodium     ", 45,102.90550, 1.250, 2.55,  8.3, (/ 2, 3, 4, 0, 0/)  ,  &
                                                           (/ 0.86, 0.00, 0.00, 0.00, 0.00/), 0.5880, 0.3000,144.800      ) ,  &
                          chem_info_type("PD","Palladium   ", 46,106.40000, 1.280, 2.60,  8.9, (/ 2, 4, 0, 0, 0/)  ,  &
                                                           (/ 0.86, 0.00, 0.00, 0.00, 0.00/), 0.5910, 0.0930,  6.900      ) ,  &
                          chem_info_type("AG","Silver      ", 47,107.86800, 1.340, 2.69, 10.3, (/ 1, 0, 0, 0, 0/)  ,  &
                                                           (/ 1.26, 0.00, 0.00, 0.00, 0.00/), 0.5922, 0.5800, 63.300      ) ,  &
                          chem_info_type("CD","Cadmium     ", 48,112.40000, 1.480, 2.79, 13.1, (/ 2, 0, 0, 0, 0/)  ,  &
                                                           (/ 0.97, 0.00, 0.00, 0.00, 0.00/), 0.4870, 3.4600,2520.00      ) ,  &
                          chem_info_type("IN","Indium      ", 49,114.82000, 1.440, 2.73, 15.7, (/ 1, 3, 0, 0, 0/)  ,  &
                                                           (/ 1.32, 0.81, 0.00, 0.00, 0.00/), 0.4065, 0.5400,193.800      ) ,  &
                          chem_info_type("SN","Tin         ", 50,118.69000, 1.410, 2.56, 16.3, (/ 2, 4, 0, 0, 0/)  ,  &
                                                           (/ 1.12, 0.71, 0.00, 0.00, 0.00/), 0.6225, 0.0220,  0.626      ) /)

       chem_info(51:60) = (/  &
                          chem_info_type("SB","Antimony    ", 51,121.75000, 1.400, 2.56, 18.4, (/-3, 3, 5, 0, 0/)  ,  &
                                                           (/ 2.45, 0.00, 0.62, 0.00, 0.00/), 0.5570, 0.0000,  4.910      ) ,  &
                          chem_info_type("TE","Tellurium   ", 52,127.60000, 1.360, 2.57, 20.5, (/-2, 2, 4, 6, 0/)  ,  &
                                                           (/ 2.21, 0.00, 0.00, 0.56, 0.00/), 0.5800, 0.0900,  4.700      ) ,  &
                          chem_info_type("I ","Iodine      ", 53,126.90450, 1.330, 1.98, 25.7, (/-1, 1, 3, 5, 7/)  ,  &
                                                           (/ 2.16, 0.00, 0.00, 0.00, 0.50/), 0.5280, 0.3100,  6.150      ) ,  &
                          chem_info_type("XE","Xenon       ", 54,131.30000, 1.310, 2.50, 42.9, (/ 0, 0, 0, 0, 0/)  ,  &
                                                           (/ 0.00, 0.00, 0.00, 0.00, 0.00/), 0.4920, 0.0000, 23.900      ) ,  &
                          chem_info_type("CS","Cesium      ", 55,132.90540, 2.350, 2.77, 70.0, (/ 1, 0, 0, 0, 0/)  ,  &
                                                           (/ 1.69, 0.00, 0.00, 0.00, 0.00/), 0.5420, 0.2100, 29.000      ) ,  &
                          chem_info_type("BA","Barium      ", 56,137.34000, 1.980, 2.44, 39.0, (/ 2, 0, 0, 0, 0/)  ,  &
                                                           (/ 1.35, 0.00, 0.00, 0.00, 0.00/), 0.5070, 0.1500,  1.100      ) ,  &
                          chem_info_type("LA","Lanthanum   ", 57,138.90550, 1.690, 2.97, 22.5, (/ 3, 0, 0, 0, 0/)  ,  &
                                                           (/ 1.15, 0.00, 0.00, 0.00, 0.00/), 0.8240, 1.1300,  8.970      ) ,  &
                          chem_info_type("CE","Cerium      ", 58,140.12000, 1.650, 2.93, 21.0, (/ 3, 4, 0, 0, 0/)  ,  &
                                                           (/ 1.11, 1.01, 0.00, 0.00, 0.00/), 0.4840, 0.0000,  0.630      ) ,  &
                          chem_info_type("PR","Praseodymium", 59,140.90770, 1.650, 2.92, 20.8, (/ 3, 4, 0, 0, 0/)  ,  &
                                                           (/ 1.09, 0.92, 0.00, 0.00, 0.00/), 0.4580, 0.0150, 11.500      ) ,  &
                          chem_info_type("ND","Neodymium   ", 60,144.24000, 1.640, 2.91, 20.6, (/ 3, 0, 0, 0, 0/)  ,  &
                                                           (/ 1.08, 0.00, 0.00, 0.00, 0.00/), 0.7690, 9.2000, 50.500      ) /)

       chem_info(61:70) = (/  &
                          chem_info_type("PM","Promethium  ", 61,145.00000, 1.630, 2.90,  0.0, (/ 3, 0, 0, 0, 0/)  ,  &
                                                           (/ 1.06, 0.00, 0.00, 0.00, 0.00/), 1.2600, 1.3000,168.400      ) ,  &
                          chem_info_type("SM","Samarium    ", 62,150.40000, 1.620, 2.90, 19.9, (/ 2, 3, 0, 0, 0/)  ,  &
                                                           (/ 0.00, 1.04, 0.00, 0.00, 0.00/), 0.8000,39.0000,5922.00      ) ,  &
                          chem_info_type("EU","Europium    ", 63,151.96000, 1.850, 2.90, 28.9, (/ 2, 3, 0, 0, 0/)  ,  &
                                                           (/ 1.12, 0.00, 0.00, 0.00, 0.00/), 0.7220, 2.5000,4530.00      ) ,  &
                          chem_info_type("GD","Gadolinium  ", 64,157.25000, 1.610, 2.89, 19.9, (/ 3, 0, 0, 0, 0/)  ,  &
                                                           (/ 1.02, 0.00, 0.00, 0.00, 0.00/), 0.6500, 0.0000,49700.0      ) ,  &
                          chem_info_type("TB","Terbium     ", 65,158.92540, 1.590, 2.86, 19.2, (/ 3, 4, 0, 0, 0/)  ,  &
                                                           (/ 1.00, 0.00, 0.00, 0.00, 0.00/), 0.7380, 0.0040, 23.400      ) ,  &
                          chem_info_type("DY","Dysprosium  ", 66,162.50000, 1.590, 2.85, 19.0, (/ 3, 0, 0, 0, 0/)  ,  &
                                                           (/ 0.99, 0.00, 0.00, 0.00, 0.00/), 1.6900,54.4000,994.000      ) ,  &
                          chem_info_type("HO","Holmium     ", 67,164.93040, 1.580, 2.84, 18.7, (/ 3, 0, 0, 0, 0/)  ,  &
                                                           (/ 0.97, 0.00, 0.00, 0.00, 0.00/), 0.8010, 0.3600, 64.700      ) ,  &
                          chem_info_type("ER","Erbium      ", 68,167.26000, 1.570, 2.83, 18.4, (/ 3, 0, 0, 0, 0/)  ,  &
                                                           (/ 0.96, 0.00, 0.00, 0.00, 0.00/), 0.7790, 1.1000,159.000      ) ,  &
                          chem_info_type("TM","Thulium     ", 69,168.93420, 1.560, 2.82, 18.1, (/ 2, 3, 0, 0, 0/)  ,  &
                                                           (/ 0.00, 0.95, 0.00, 0.00, 0.00/), 0.7070, 0.1000,100.000      ) ,  &
                          chem_info_type("YB","Ytterbium   ", 70,173.04000, 0.000, 3.04, 24.8, (/ 2, 3, 0, 0, 0/)  ,  &
                                                           (/ 1.13, 0.94, 0.00, 0.00, 0.00/), 1.2430, 4.0000, 34.800      ) /)

       chem_info(71:80) = (/  &
                          chem_info_type("LU","Lutetium    ", 71,174.97000, 1.560, 2.82, 17.8, (/ 3, 0, 0, 0, 0/)  ,  &
                                                           (/ 0.93, 0.00, 0.00, 0.00, 0.00/), 0.7210, 0.7000, 74.000      ) ,  &
                          chem_info_type("HF","Hafnium     ", 72,178.49000, 1.440, 2.67, 13.6, (/ 4, 0, 0, 0, 0/)  ,  &
                                                           (/ 0.81, 0.00, 0.00, 0.00, 0.00/), 0.7770, 2.6000, 74.000      ) ,  &
                          chem_info_type("TA","Tantalum    ", 73,180.94790, 1.440, 2.53, 10.9, (/ 5, 0, 0, 0, 0/)  ,  &
                                                           (/ 0.73, 0.00, 0.00, 0.00, 0.00/), 0.6910, 0.0100, 20.600      ) ,  &
                          chem_info_type("W ","Tungsten    ", 74,183.85000, 1.300, 2.47,  9.5, (/ 2, 3, 4, 5, 6/)  ,  &
                                                           (/ 0.00, 0.00, 0.68, 0.00, 0.64/), 0.4860, 1.6300, 18.300      ) ,  &
                          chem_info_type("RE","Rhenium     ", 75,186.20700, 1.280, 2.45,  8.8, (/ 1, 2, 4, 6, 7/)  ,  &
                                                           (/ 0.00, 0.00, 0.00, 0.00, 0.00/), 0.9200, 0.9000, 89.700      ) ,  &
                          chem_info_type("OS","Osmium      ", 76,190.20000, 1.260, 2.47,  8.4, (/ 2, 3, 4, 6, 8/)  ,  &
                                                           (/ 0.00, 0.00, 0.69, 0.00, 0.00/), 1.0700, 0.3000, 16.000      ) ,  &
                          chem_info_type("IR","Iridium     ", 77,192.22000, 1.270, 2.42,  8.5, (/ 2, 3, 4, 6, 0/)  ,  &
                                                           (/ 0.00, 0.00, 0.66, 0.00, 0.00/), 1.0600, 0.0000,425.000      ) ,  &
                          chem_info_type("PT","Platinum    ", 78,195.09000, 1.300, 2.60,  9.1, (/ 2, 4, 0, 0, 0/)  ,  &
                                                           (/ 0.96, 0.00, 0.00, 0.00, 0.00/), 0.9600, 0.1300, 10.300      ) ,  &
                          chem_info_type("AU","Gold        ", 79,196.96650, 1.340, 2.60, 10.2, (/ 1, 3, 0, 0, 0/)  ,  &
                                                           (/ 1.37, 0.00, 0.00, 0.00, 0.00/), 0.7630, 0.4300, 98.650      ) ,  &
                          chem_info_type("HG","Mercury     ", 80,200.59000, 1.490, 2.80, 14.8, (/ 2, 0, 0, 0, 0/)  ,  &
                                                           (/ 1.10, 0.00, 0.00, 0.00, 0.00/), 1.2692, 6.6000,372.300      ) /)

       chem_info(81:90) = (/  &
                          chem_info_type("TL","Thallium    ", 81,204.37000, 1.480, 2.65, 17.2, (/ 1, 3, 0, 0, 0/)  ,  &
                                                           (/ 1.40, 0.95, 0.00, 0.00, 0.00/), 0.8776, 0.2100,  3.430      ) ,  &
                          chem_info_type("PB","Lead        ", 82,207.20000, 1.470, 2.64, 18.3, (/ 2, 4, 0, 0, 0/)  ,  &
                                                           (/ 1.20, 0.84, 0.00, 0.00, 0.00/), 0.9405, 0.0030,  0.171      ) ,  &
                          chem_info_type("BI","Bismuth     ", 83,208.98040, 1.460, 2.64, 21.3, (/ 3, 5, 0, 0, 0/)  ,  &
                                                           (/ 1.20, 0.74, 0.00, 0.00, 0.00/), 0.8532, 0.0084,  0.034      ) ,  &
                          chem_info_type("PO","Polonium    ", 84,209.00000, 1.460, 2.60, 22.7, (/ 2, 4, 0, 0, 0/)  ,  &
                                                           (/ 0.00, 0.00, 0.00, 0.00, 0.00/), 0.0000, 0.0000,  0.000      ) ,  &
                          chem_info_type("AT","Astatine    ", 85,210.00000, 0.000, 2.60,  0.0, (/-1, 1, 3, 5, 7/)  ,  &
                                                           (/ 0.00, 0.00, 0.00, 0.00, 0.00/), 0.0000, 0.0000,  0.000      ) ,  &
                          chem_info_type("RN","Radon       ", 86,222.00000, 0.000, 2.60,  0.0, (/ 0, 0, 0, 0, 0/)  ,  &
                                                           (/ 0.00, 0.00, 0.00, 0.00, 0.00/), 0.0000, 0.0000,  0.000      ) ,  &
                          chem_info_type("FR","Francium    ", 87,223.00000, 0.000, 3.00,  0.0, (/ 1, 0, 0, 0, 0/)  ,  &
                                                           (/ 1.76, 0.00, 0.00, 0.00, 0.00/), 0.0000, 0.0000,  0.000      ) ,  &
                          chem_info_type("RA","Radium      ", 88,226.02540, 0.000, 3.00, 45.0, (/ 2, 0, 0, 0, 0/)  ,  &
                                                           (/ 1.40, 0.00, 0.00, 0.00, 0.00/), 1.0000, 0.0000, 12.800      ) ,  &
                          chem_info_type("AC","Actinium    ", 89,227.00000, 0.000, 2.98,  0.0, (/ 3, 0, 0, 0, 0/)  ,  &
                                                           (/ 1.18, 0.00, 0.00, 0.00, 0.00/), 0.0000, 0.0000,  0.000      ) ,  &
                          chem_info_type("TH","Thorium     ", 90,232.03810, 1.650, 2.89, 19.9, (/ 3, 4, 0, 0, 0/)  ,  &
                                                           (/ 1.14, 0.95, 0.00, 0.00, 0.00/), 1.0310, 0.0000,  7.370      ) /)

       chem_info(91:100)= (/  &
                          chem_info_type("PA","Protactinium", 91,231.03597, 0.000, 2.71, 15.0, (/ 3, 4, 5, 0, 0/)  ,  &
                                                           (/ 1.12, 0.98, 0.00, 0.00, 0.00/), 0.9100, 0.1000,200.600      ) ,  &
                          chem_info_type("U ","Uranium     ", 92,238.02900, 1.420, 2.68, 12.5, (/ 3, 4, 5, 6, 0/)  ,  &
                                                           (/ 1.11, 0.97, 0.00, 0.00, 0.00/), 0.8417, 0.0050,  7.570      ) ,  &
                          chem_info_type("NP","Neptunium   ", 93,237.04820, 0.000, 2.65, 21.1, (/ 3, 4, 5, 6, 0/)  ,  &
                                                           (/ 1.09, 0.95, 0.00, 0.00, 0.00/), 1.0550, 0.5000,175.900      ) ,  &
                          chem_info_type("PU","Plutonium   ", 94,244.00000, 0.000, 2.43,  0.0, (/ 3, 4, 5, 6, 0/)  ,  &
                                                           (/ 1.07, 0.93, 0.00, 0.00, 0.00/), 1.4100, 0.0000,558.000      ) ,  &
                          chem_info_type("AM","Americium   ", 95,243.00000, 0.000, 2.61, 20.8, (/ 3, 4, 5, 6, 0/)  ,  &
                                                           (/ 1.06, 0.92, 0.00, 0.00, 0.00/), 0.8300, 0.3000, 75.300      ) ,  &
                          chem_info_type("CM","Curium      ", 96,247.00000, 0.000, 2.60,  0.0, (/ 3, 0, 0, 0, 0/)  ,  &
                                                           (/ 0.00, 0.00, 0.00, 0.00, 0.00/), 0.9500, 0.0000, 16.200      ) ,  &
                          chem_info_type("BK","Berkelium   ", 97,247.00000, 0.000, 2.60,  0.0, (/ 3, 4, 0, 0, 0/)  ,  &
                                                           (/ 0.00, 0.00, 0.00, 0.00, 0.00/), 0.0000, 0.0000,  0.000      ) ,  &
                          chem_info_type("CF","Californium ", 98,251.00000, 0.000, 2.60,  0.0, (/ 3, 0, 0, 0, 0/)  ,  &
                                                           (/ 0.00, 0.00, 0.00, 0.00, 0.00/), 0.0000, 0.0000,  0.000      ) ,  &
                          chem_info_type("ES","Einsteinium ", 99,254.00000, 0.000, 0.00,  0.0, (/ 0, 0, 0, 0, 0/)  ,  &
                                                           (/ 0.00, 0.00, 0.00, 0.00, 0.00/), 0.0000, 0.0000,  0.000      ) ,  &
                          chem_info_type("FM","Fermium     ",100,257.00000, 0.000, 0.00,  0.0, (/ 0, 0, 0, 0, 0/)  ,  &
                                                           (/ 0.00, 0.00, 0.00, 0.00, 0.00/), 0.0000, 0.0000,  0.000      ) /)

       chem_info(101:108)=(/  &
                          chem_info_type("MD","Mendelevium ",101,258.00000, 0.000, 0.00,  0.0, (/ 0, 0, 0, 0, 0/)  ,  &
                                                           (/ 0.00, 0.00, 0.00, 0.00, 0.00/), 0.0000, 0.0000,  0.000      ) ,  &
                          chem_info_type("NO","Nobelium    ",102,255.00000, 0.000, 0.00,  0.0, (/ 0, 0, 0, 0, 0/)  ,  &
                                                           (/ 0.00, 0.00, 0.00, 0.00, 0.00/), 0.0000, 0.0000,  0.000      ) ,  &
                          chem_info_type("LR","Lawrencium  ",103,260.00000, 0.000, 0.00,  0.0, (/ 0, 0, 0, 0, 0/)  ,  &
                                                           (/ 0.00, 0.00, 0.00, 0.00, 0.00/), 0.0000, 0.0000,  0.000      ) ,  &
                          chem_info_type("KU","            ",104,261.00000, 0.000, 0.00,  0.0, (/ 4, 0, 0, 0, 0/)  ,  &
                                                           (/ 0.00, 0.00, 0.00, 0.00, 0.00/), 0.0000, 0.0000,  0.000      ) ,  &
                          chem_info_type("HA","            ",105,262.00000, 0.000, 0.00,  0.0, (/ 0, 0, 0, 0, 0/)  ,  &
                                                           (/ 0.00, 0.00, 0.00, 0.00, 0.00/), 0.0000, 0.0000,  0.000      ) ,  &
                          chem_info_type("BS","Boron-11    ",  5, 10.81000, 0.820, 1.93,  4.6, (/ 3, 0, 0, 0, 0/)  ,  &
                                                           (/ 0.20, 0.00, 0.00, 0.00, 0.00/), 0.6650, 1.7000,767.00000    ) ,  &
                          chem_info_type("ZE","Zero-scatter",  1,  0.00000, 0.820, 1.93,  4.6, (/ 0, 0, 0, 0, 0/)  ,  &
                                                           (/ 0.00, 0.00, 0.00, 0.00, 0.00/), 0.0000, 0.0000,  0.00000    ) ,  &
                          chem_info_type("D ","Deuterium   ",  1,  2.00797, 0.320, 1.33, 14.1, (/-1, 1, 0, 0, 0/)  ,  &
                                                           (/ 2.08, 0.00, 0.00, 0.00, 0.00/),0.6671, 0.0000,  0.00000    ) /)
       !  Symb , Name, Z , AtWe  , RCov , RWaals, VAtm, Oxid(5), Rion(5), b=SctF, SedInc, Sea
       return
    End Subroutine Set_Chem_Info

    !!----
    !!---- Subroutine Set_Delta_Fp_Fpp()
    !!--<<
    !!----    Wavelenghts:     Cr        Fe        Cu         Mo         Ag
    !!----         Lambda   2.28962   1.93597   1.54051    0.70926    0.556363
    !!-->>
    !!----    Set values for Delta-fp & Delta-fpp for the above wavelengths
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Set_Delta_Fp_Fpp()

       if (.not. allocated(anomalous_ScFac)) allocate(anomalous_ScFac(Num_Delta_Fp))

       Anomalous_ScFac( 1)=Anomalous_Sc_Type("h ", (/   0.000,   0.000,   0.000,   0.000,   0.000/), &
                                                   (/   0.000,   0.000,   0.000,   0.000,   0.000/)  )
       Anomalous_ScFac( 2)=Anomalous_Sc_Type("he", (/   0.000,   0.000,   0.000,   0.000,   0.000/), &
                                                   (/   0.000,   0.000,   0.000,   0.000,   0.000/)  )
       Anomalous_ScFac( 3)=Anomalous_Sc_Type("li", (/   0.002,   0.002,   0.001,   0.000,   0.000/), &
                                                   (/   0.001,   0.001,   0.000,   0.000,   0.000/)  )
       Anomalous_ScFac( 4)=Anomalous_Sc_Type("be", (/   0.008,   0.005,   0.003,   0.000,  -0.001/), &
                                                   (/   0.003,   0.002,   0.001,   0.000,   0.000/)  )
       Anomalous_ScFac( 5)=Anomalous_Sc_Type("b ", (/   0.018,   0.013,   0.008,   0.000,   0.000/), &
                                                   (/   0.009,   0.007,   0.004,   0.001,   0.000/)  )
       Anomalous_ScFac( 6)=Anomalous_Sc_Type("c ", (/   0.035,   0.026,   0.017,   0.002,   0.000/), &
                                                   (/   0.021,   0.015,   0.009,   0.002,   0.001/)  )
       Anomalous_ScFac( 7)=Anomalous_Sc_Type("n ", (/   0.059,   0.044,   0.029,   0.004,   0.001/), &
                                                   (/   0.042,   0.029,   0.018,   0.003,   0.002/)  )
       Anomalous_ScFac( 8)=Anomalous_Sc_Type("o ", (/   0.090,   0.069,   0.047,   0.008,   0.003/), &
                                                   (/   0.073,   0.052,   0.032,   0.006,   0.004/)  )
       Anomalous_ScFac( 9)=Anomalous_Sc_Type("f ", (/   0.129,   0.100,   0.069,   0.014,   0.006/), &
                                                   (/   0.119,   0.085,   0.053,   0.010,   0.006/)  )
       Anomalous_ScFac(10)=Anomalous_Sc_Type("ne", (/   0.174,   0.138,   0.097,   0.021,   0.011/), &
                                                   (/   0.184,   0.132,   0.083,   0.016,   0.010/)  )
       Anomalous_ScFac(11)=Anomalous_Sc_Type("na", (/   0.223,   0.180,   0.129,   0.030,   0.016/), &
                                                   (/   0.270,   0.195,   0.124,   0.025,   0.015/)  )
       Anomalous_ScFac(12)=Anomalous_Sc_Type("mg", (/   0.272,   0.224,   0.165,   0.042,   0.023/), &
                                                   (/   0.381,   0.277,   0.177,   0.036,   0.022/)  )
       Anomalous_ScFac(13)=Anomalous_Sc_Type("al", (/   0.318,   0.269,   0.204,   0.056,   0.032/), &
                                                   (/   0.522,   0.381,   0.246,   0.052,   0.031/)  )
       Anomalous_ScFac(14)=Anomalous_Sc_Type("si", (/   0.355,   0.311,   0.244,   0.072,   0.042/), &
                                                   (/   0.693,   0.509,   0.330,   0.071,   0.043/)  )
       Anomalous_ScFac(15)=Anomalous_Sc_Type("p ", (/   0.377,   0.347,   0.283,   0.090,   0.055/), &
                                                   (/   0.900,   0.664,   0.434,   0.095,   0.058/)  )
       Anomalous_ScFac(16)=Anomalous_Sc_Type("s ", (/   0.374,   0.370,   0.319,   0.110,   0.068/), &
                                                   (/   1.142,   0.847,   0.557,   0.124,   0.076/)  )
       Anomalous_ScFac(17)=Anomalous_Sc_Type("cl", (/   0.335,   0.375,   0.348,   0.132,   0.084/), &
                                                   (/   1.423,   1.061,   0.702,   0.159,   0.099/)  )
       Anomalous_ScFac(18)=Anomalous_Sc_Type("ar", (/   0.243,   0.352,   0.366,   0.155,   0.101/), &
                                                   (/   1.747,   1.309,   0.872,   0.201,   0.125/)  )
       Anomalous_ScFac(19)=Anomalous_Sc_Type("k ", (/   0.070,   0.286,   0.365,   0.179,   0.118/), &
                                                   (/   2.110,   1.589,   1.066,   0.250,   0.156/)  )
       Anomalous_ScFac(20)=Anomalous_Sc_Type("ca", (/  -0.221,   0.163,   0.341,   0.203,   0.137/), &
                                                   (/   2.514,   1.904,   1.286,   0.306,   0.193/)  )
       Anomalous_ScFac(21)=Anomalous_Sc_Type("sc", (/  -0.717,  -0.038,   0.285,   0.226,   0.156/), &
                                                   (/   2.968,   2.256,   1.533,   0.372,   0.235/)  )
       Anomalous_ScFac(22)=Anomalous_Sc_Type("ti", (/  -1.683,  -0.357,   0.189,   0.248,   0.175/), &
                                                   (/   3.470,   2.643,   1.807,   0.446,   0.283/)  )
       Anomalous_ScFac(23)=Anomalous_Sc_Type("v ", (/  -3.841,  -0.896,   0.035,   0.267,   0.194/), &
                                                   (/   0.459,   3.070,   2.110,   0.530,   0.338/)  )
       Anomalous_ScFac(24)=Anomalous_Sc_Type("cr", (/  -2.161,  -1.973,  -0.198,   0.284,   0.213/), &
                                                   (/   0.548,   3.533,   2.443,   0.624,   0.399/)  )
       Anomalous_ScFac(25)=Anomalous_Sc_Type("mn", (/  -1.639,  -3.367,  -0.568,   0.295,   0.229/), &
                                                   (/   0.650,   0.481,   2.808,   0.729,   0.468/)  )
       Anomalous_ScFac(26)=Anomalous_Sc_Type("fe", (/  -1.339,  -2.095,  -1.179,   0.301,   0.244/), &
                                                   (/   0.764,   0.566,   3.204,   0.845,   0.545/)  )
       Anomalous_ScFac(27)=Anomalous_Sc_Type("co", (/  -1.124,  -1.623,  -2.464,   0.299,   0.256/), &
                                                   (/   0.893,   0.662,   3.608,   0.973,   0.630/)  )
       Anomalous_ScFac(28)=Anomalous_Sc_Type("ni", (/  -0.956,  -1.343,  -2.956,   0.285,   0.261/), &
                                                   (/   1.036,   0.769,   0.509,   1.113,   0.724/)  )
       Anomalous_ScFac(29)=Anomalous_Sc_Type("cu", (/  -0.795,  -1.129,  -2.019,   0.263,   0.265/), &
                                                   (/   1.196,   0.888,   0.589,   1.266,   0.826/)  )
       Anomalous_ScFac(30)=Anomalous_Sc_Type("zn", (/  -0.684,  -0.978,  -1.612,   0.222,   0.260/), &
                                                   (/   1.373,   1.021,   0.678,   1.431,   0.938/)  )
       Anomalous_ScFac(31)=Anomalous_Sc_Type("ga", (/  -0.570,  -0.841,  -1.354,   0.163,   0.249/), &
                                                   (/   1.569,   1.168,   0.777,   1.609,   1.059/)  )
       Anomalous_ScFac(32)=Anomalous_Sc_Type("ge", (/  -0.462,  -0.717,  -1.163,   0.081,   0.228/), &
                                                   (/   1.786,   1.331,   0.886,   1.801,   1.190/)  )
       Anomalous_ScFac(33)=Anomalous_Sc_Type("as", (/  -0.365,  -0.607,  -1.011,  -0.030,   0.196/), &
                                                   (/   2.022,   1.508,   1.006,   2.007,   1.332/)  )
       Anomalous_ScFac(34)=Anomalous_Sc_Type("se", (/  -0.273,  -0.503,  -0.879,  -0.178,   0.152/), &
                                                   (/   2.283,   1.704,   1.139,   2.223,   1.481/)  )
       Anomalous_ScFac(35)=Anomalous_Sc_Type("br", (/  -0.198,  -0.413,  -0.767,  -0.374,   0.090/), &
                                                   (/   2.563,   1.916,   1.283,   2.456,   1.643/)  )
       Anomalous_ScFac(36)=Anomalous_Sc_Type("kr", (/  -0.130,  -0.328,  -0.665,  -0.652,   0.008/), &
                                                   (/   2.872,   2.149,   1.439,   2.713,   1.820/)  )
       Anomalous_ScFac(37)=Anomalous_Sc_Type("rb", (/  -0.082,  -0.256,  -0.574,  -1.044,  -0.099/), &
                                                   (/   3.201,   2.398,   1.608,   2.973,   2.003/)  )
       Anomalous_ScFac(38)=Anomalous_Sc_Type("sr", (/  -0.012,  -0.161,  -0.465,  -1.657,  -0.230/), &
                                                   (/   3.608,   2.709,   1.820,   3.264,   2.203/)  )
       Anomalous_ScFac(39)=Anomalous_Sc_Type("y ", (/   0.006,  -0.106,  -0.386,  -2.951,  -0.406/), &
                                                   (/   4.002,   3.009,   2.025,   3.542,   2.411/)  )
       Anomalous_ScFac(40)=Anomalous_Sc_Type("zr", (/   0.007,  -0.061,  -0.314,  -2.965,  -0.639/), &
                                                   (/   4.422,   3.329,   2.245,   0.560,   2.630/)  )
       Anomalous_ScFac(41)=Anomalous_Sc_Type("nb", (/  -0.013,  -0.028,  -0.248,  -2.197,  -0.957/), &
                                                   (/   4.876,   3.676,   2.482,   0.621,   2.860/)  )
       Anomalous_ScFac(42)=Anomalous_Sc_Type("mo", (/  -0.063,  -0.012,  -0.191,  -1.825,  -1.416/), &
                                                   (/   5.353,   4.043,   2.735,   0.688,   3.103/)  )
       Anomalous_ScFac(43)=Anomalous_Sc_Type("tc", (/  -0.153,  -0.017,  -0.145,  -1.590,  -2.205/), &
                                                   (/   5.862,   4.434,   3.005,   0.759,   3.353/)  )
       Anomalous_ScFac(44)=Anomalous_Sc_Type("ru", (/  -0.270,  -0.039,  -0.105,  -1.420,  -5.524/), &
                                                   (/   6.406,   4.854,   3.296,   0.836,   3.651/)  )
       Anomalous_ScFac(45)=Anomalous_Sc_Type("rh", (/  -0.424,  -0.083,  -0.077,  -1.287,  -2.649/), &
                                                   (/   6.984,   5.300,   3.605,   0.919,   0.596/)  )
       Anomalous_ScFac(46)=Anomalous_Sc_Type("pd", (/  -0.639,  -0.157,  -0.059,  -1.177,  -2.128/), &
                                                   (/   7.594,   5.773,   3.934,   1.007,   0.654/)  )
       Anomalous_ScFac(47)=Anomalous_Sc_Type("ag", (/  -0.924,  -0.259,  -0.060,  -1.085,  -1.834/), &
                                                   (/   8.235,   6.271,   4.282,   1.101,   0.717/)  )
       Anomalous_ScFac(48)=Anomalous_Sc_Type("cd", (/  -1.303,  -0.416,  -0.079,  -1.005,  -1.637/), &
                                                   (/   8.912,   6.800,   4.653,   1.202,   0.783/)  )
       Anomalous_ScFac(49)=Anomalous_Sc_Type("in", (/  -1.788,  -0.626,  -0.126,  -0.936,  -1.493/), &
                                                   (/   9.627,   7.356,   5.045,   1.310,   0.854/)  )
       Anomalous_ScFac(50)=Anomalous_Sc_Type("sn", (/  -2.401,  -0.888,  -0.194,  -0.873,  -1.378/), &
                                                   (/  10.380,   7.943,   5.459,   1.424,   0.930/)  )
       Anomalous_ScFac(51)=Anomalous_Sc_Type("sb", (/  -3.194,  -1.214,  -0.287,  -0.816,  -1.284/), &
                                                   (/  11.166,   8.557,   5.894,   1.546,   1.010/)  )
       Anomalous_ScFac(52)=Anomalous_Sc_Type("te", (/  -4.267,  -1.630,  -0.418,  -0.772,  -1.212/), &
                                                   (/  11.995,   9.203,   6.352,   1.675,   1.096/)  )
       Anomalous_ScFac(53)=Anomalous_Sc_Type("i ", (/  -5.852,  -2.147,  -0.579,  -0.726,  -1.144/), &
                                                   (/  12.850,   9.885,   6.835,   1.812,   1.187/)  )
       Anomalous_ScFac(54)=Anomalous_Sc_Type("xe", (/  -8.133,  -2.812,  -0.783,  -0.684,  -1.084/), &
                                                   (/  11.933,  10.608,   7.348,   1.958,   1.284/)  )
       Anomalous_ScFac(55)=Anomalous_Sc_Type("cs", (/ -10.742,  -3.652,  -1.022,  -0.644,  -1.029/), &
                                                   (/  12.919,  11.382,   7.904,   2.119,   1.391/)  )
       Anomalous_ScFac(56)=Anomalous_Sc_Type("ba", (/ -11.460,  -4.832,  -1.334,  -0.613,  -0.983/), &
                                                   (/   9.981,  12.164,   8.460,   2.282,   1.500/)  )
       Anomalous_ScFac(57)=Anomalous_Sc_Type("la", (/ -12.135,  -6.683,  -1.716,  -0.588,  -0.942/), &
                                                   (/   3.565,  12.937,   9.036,   2.452,   1.615/)  )
       Anomalous_ScFac(58)=Anomalous_Sc_Type("ce", (/  -9.574,  -8.388,  -2.170,  -0.564,  -0.904/), &
                                                   (/   3.843,  11.953,   9.648,   2.632,   1.735/)  )
       Anomalous_ScFac(59)=Anomalous_Sc_Type("pr", (/  -7.817, -12.457,  -2.939,  -0.530,  -0.859/), &
                                                   (/   4.130,   6.285,  10.535,   2.845,   1.873/)  )
       Anomalous_ScFac(60)=Anomalous_Sc_Type("nd", (/  -7.486, -11.016,  -3.431,  -0.535,  -0.842/), &
                                                   (/   4.427,   9.874,  10.933,   3.018,   1.995/)  )
       Anomalous_ScFac(61)=Anomalous_Sc_Type("pm", (/  -6.891, -12.122,  -4.357,  -0.530,  -0.818/), &
                                                   (/   4.741,   3.627,  11.614,   3.225,   2.135/)  )
       Anomalous_ScFac(62)=Anomalous_Sc_Type("sm", (/  -6.429,  -9.616,  -5.696,  -0.533,  -0.798/), &
                                                   (/   5.073,   3.883,  12.320,   3.442,   2.281/)  )
       Anomalous_ScFac(63)=Anomalous_Sc_Type("eu", (/  -6.050,  -8.352,  -7.718,  -0.542,  -0.782/), &
                                                   (/   5.416,   4.149,  11.276,   3.669,   2.435/)  )
       Anomalous_ScFac(64)=Anomalous_Sc_Type("gd", (/  -5.779,  -7.565,  -9.242,  -0.564,  -0.774/), &
                                                   (/   5.773,   4.427,  11.946,   3.904,   2.595/)  )
       Anomalous_ScFac(65)=Anomalous_Sc_Type("tb", (/  -5.525,  -6.980,  -9.498,  -0.591,  -0.767/), &
                                                   (/   6.153,   4.721,   9.242,   4.151,   2.764/)  )
       Anomalous_ScFac(66)=Anomalous_Sc_Type("dy", (/  -5.250,  -6.492, -10.423,  -0.619,  -0.761/), &
                                                   (/   6.549,   5.026,   9.748,   4.410,   2.940/)  )
       Anomalous_ScFac(67)=Anomalous_Sc_Type("ho", (/  -5.040,  -6.112, -12.255,  -0.666,  -0.765/), &
                                                   (/   6.958,   5.343,   3.704,   4.678,   3.124/)  )
       Anomalous_ScFac(68)=Anomalous_Sc_Type("er", (/  -4.878,  -5.810,  -9.733,  -0.723,  -0.773/), &
                                                   (/   7.387,   5.675,   3.937,   4.958,   3.316/)  )
       Anomalous_ScFac(69)=Anomalous_Sc_Type("tm", (/  -4.753,  -5.565,  -8.488,  -0.795,  -0.790/), &
                                                   (/   7.833,   6.022,   4.181,   5.248,   3.515/)  )
       Anomalous_ScFac(70)=Anomalous_Sc_Type("yb", (/  -4.652,  -5.361,  -7.701,  -0.884,  -0.815/), &
                                                   (/   8.291,   6.378,   4.432,   5.548,   3.723/)  )
       Anomalous_ScFac(71)=Anomalous_Sc_Type("lu", (/  -4.580,  -5.190,  -7.133,  -0.988,  -0.847/), &
                                                   (/   8.759,   6.745,   4.693,   5.858,   3.937/)  )
       Anomalous_ScFac(72)=Anomalous_Sc_Type("hf", (/  -4.592,  -5.088,  -6.715,  -1.118,  -0.890/), &
                                                   (/   9.277,   7.148,   4.977,   6.185,   4.164/)  )
       Anomalous_ScFac(73)=Anomalous_Sc_Type("ta", (/  -4.540,  -4.948,  -6.351,  -1.258,  -0.937/), &
                                                   (/   9.811,   7.565,   5.271,   6.523,   4.399/)  )
       Anomalous_ScFac(74)=Anomalous_Sc_Type("w ", (/  -4.499,  -4.823,  -6.048,  -1.421,  -0.993/), &
                                                   (/  10.364,   7.996,   5.577,   6.872,   4.643/)  )
       Anomalous_ScFac(75)=Anomalous_Sc_Type("re", (/  -4.483,  -4.719,  -5.790,  -1.598,  -1.048/), &
                                                   (/  10.929,   8.439,   5.891,   7.232,   4.894/)  )
       Anomalous_ScFac(76)=Anomalous_Sc_Type("os", (/  -4.503,  -4.647,  -5.581,  -1.816,  -1.127/), &
                                                   (/  11.520,   8.903,   6.221,   7.605,   5.156/)  )
       Anomalous_ScFac(77)=Anomalous_Sc_Type("ir", (/  -4.527,  -4.578,  -5.391,  -2.066,  -1.216/), &
                                                   (/  12.140,   9.389,   6.566,   7.990,   5.427/)  )
       Anomalous_ScFac(78)=Anomalous_Sc_Type("pt", (/  -4.584,  -4.535,  -5.233,  -2.352,  -1.319/), &
                                                   (/  12.787,   9.895,   6.925,   8.388,   5.708/)  )
       Anomalous_ScFac(79)=Anomalous_Sc_Type("au", (/  -4.668,  -4.510,  -5.096,  -2.688,  -1.438/), &
                                                   (/  13.451,  10.418,   7.297,   8.798,   5.998/)  )
       Anomalous_ScFac(80)=Anomalous_Sc_Type("hg", (/  -4.803,  -4.523,  -4.990,  -3.084,  -1.576/), &
                                                   (/  14.143,  10.963,   7.686,   9.223,   6.299/)  )
       Anomalous_ScFac(81)=Anomalous_Sc_Type("tl", (/  -4.945,  -4.532,  -4.883,  -3.556,  -1.730/), &
                                                   (/  14.860,  11.528,   8.089,   9.659,   6.610/)  )
       Anomalous_ScFac(82)=Anomalous_Sc_Type("pb", (/  -5.161,  -4.596,  -4.818,  -4.133,  -1.910/), &
                                                   (/  15.595,  12.108,   8.505,  10.102,   6.930/)  )
       Anomalous_ScFac(83)=Anomalous_Sc_Type("bi", (/  -5.420,  -4.688,  -4.776,  -4.861,  -2.116/), &
                                                   (/  16.341,  12.700,   8.930,  10.559,   7.258/)  )
       Anomalous_ScFac(84)=Anomalous_Sc_Type("po", (/  -5.742,  -4.817,  -4.756,  -5.924,  -2.353/), &
                                                   (/  17.139,  13.331,   9.383,  11.042,   7.600/)  )
       Anomalous_ScFac(85)=Anomalous_Sc_Type("at", (/  -6.132,  -4.992,  -4.772,  -7.444,  -2.630/), &
                                                   (/  17.942,  13.969,   9.843,   9.961,   7.949/)  )
       Anomalous_ScFac(86)=Anomalous_Sc_Type("rn", (/  -6.545,  -5.173,  -4.787,  -8.862,  -2.932/), &
                                                   (/  18.775,  14.629,  10.317,  10.403,   8.307/)  )
       Anomalous_ScFac(87)=Anomalous_Sc_Type("fr", (/  -7.052,  -5.402,  -4.833,  -7.912,  -3.285/), &
                                                   (/  19.615,  15.299,  10.803,   7.754,   8.674/)  )
       Anomalous_ScFac(88)=Anomalous_Sc_Type("ra", (/  -7.614,  -5.659,  -4.898,  -7.620,  -3.702/), &
                                                   (/  20.461,  15.977,  11.296,   8.105,   9.047/)  )
       Anomalous_ScFac(89)=Anomalous_Sc_Type("ac", (/  -8.318,  -5.976,  -4.994,  -7.725,  -4.192/), &
                                                   (/  21.327,  16.668,  11.799,   8.472,   9.428/)  )
       Anomalous_ScFac(90)=Anomalous_Sc_Type("th", (/  -9.150,  -6.313,  -5.091,  -8.127,  -4.784/), &
                                                   (/  22.240,  17.397,  12.330,   8.870,   9.819/)  )
       Anomalous_ScFac(91)=Anomalous_Sc_Type("pa", (/ -10.382,  -6.695,  -5.216,  -8.960,  -5.555/), &
                                                   (/  23.161,  18.140,  12.868,   9.284,  10.227/)  )
       Anomalous_ScFac(92)=Anomalous_Sc_Type("u ", (/ -10.930,  -7.126,  -5.359, -10.673,  -6.735/), &
                                                   (/  23.121,  18.879,  13.409,   9.654,  10.637/)  )
       Anomalous_ScFac(93)=Anomalous_Sc_Type("np", (/ -12.152,  -7.624,  -5.529, -11.158,  -7.842/), &
                                                   (/  24.097,  19.642,  13.967,   4.148,   9.570/)  )
       Anomalous_ScFac(94)=Anomalous_Sc_Type("pu", (/ -12.280,  -8.187,  -5.712,  -9.725,  -8.473/), &
                                                   (/  23.658,  20.425,  14.536,   4.330,   6.999/)  )
       Anomalous_ScFac(95)=Anomalous_Sc_Type("am", (/ -12.771,  -8.872,  -5.930,  -8.926,  -7.701/), &
                                                   (/  24.607,  21.173,  15.087,   4.511,   7.296/)  )
       Anomalous_ScFac(96)=Anomalous_Sc_Type("cm", (/ -13.513,  -9.743,  -6.176,  -8.416,  -7.388/), &
                                                   (/  25.540,  21.896,  15.634,   4.697,   7.589/)  )
       Anomalous_ScFac(97)=Anomalous_Sc_Type("bk", (/ -14.827, -10.539,  -6.498,  -7.990,  -7.485/), &
                                                   (/  26.801,  21.942,  16.317,   4.908,   7.931/)  )
       Anomalous_ScFac(98)=Anomalous_Sc_Type("ze", (/   0.000,   0.000,   0.000,   0.000,   0.000/), &
                                                   (/   0.000,   0.000,   0.000,   0.000,   0.000/)  )
       return
    End Subroutine Set_Delta_Fp_Fpp

    !!----
    !!---- Subroutine Set_Magnetic_Form()
    !!----
    !!----    Magnetic form factors <j0> P.J. Brown, ILL prep. SP.88BR5016
    !!----    (March 1988)
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Set_Magnetic_Form()

       if (.not. allocated(magnetic_form)) allocate(magnetic_form(num_mag_form))
       if (.not. allocated(magnetic_j2))   allocate(magnetic_j2(num_mag_j2))
       if (.not. allocated(magnetic_j4))   allocate(magnetic_j4(num_mag_j4))
       if (.not. allocated(magnetic_j6))   allocate(magnetic_j6(num_mag_j6))

       Magnetic_Form(  1) = Magnetic_Form_Type("MSC0", &
                                              (/  0.251200, 90.029602,  0.329000, 39.402100,  0.423500, 14.322200, -0.004300/) )
       Magnetic_Form(  2) = Magnetic_Form_Type("MSC1", &
                                              (/  0.488900, 51.160301,  0.520300, 14.076400, -0.028600,  0.179200,  0.018500/) )
       Magnetic_Form(  3) = Magnetic_Form_Type("MSC2", &
                                              (/  0.504800, 31.403500,  0.518600, 10.989700, -0.024100,  1.183100,  0.000000/) )
       Magnetic_Form(  4) = Magnetic_Form_Type("MTI0", &
                                              (/  0.465700, 33.589802,  0.549000,  9.879100, -0.029100,  0.323200,  0.012300/) )
       Magnetic_Form(  5) = Magnetic_Form_Type("MTI1", &
                                              (/  0.509300, 36.703300,  0.503200, 10.371300, -0.026300,  0.310600,  0.011600/) )
       Magnetic_Form(  6) = Magnetic_Form_Type("MTI2", &
                                              (/  0.509100, 24.976299,  0.516200,  8.756900, -0.028100,  0.916000,  0.001500/) )
       Magnetic_Form(  7) = Magnetic_Form_Type("MTI3", &
                                              (/  0.357100, 22.841299,  0.668800,  8.930600, -0.035400,  0.483300,  0.009900/) )
       Magnetic_Form(  8) = Magnetic_Form_Type("MV0 ", &
                                              (/  0.408600, 28.810900,  0.607700,  8.543700, -0.029500,  0.276800,  0.012300/) )
       Magnetic_Form(  9) = Magnetic_Form_Type("MV1 ", &
                                              (/  0.444400, 32.647900,  0.568300,  9.097100, -0.228500,  0.021800,  0.215000/) )
       Magnetic_Form( 10) = Magnetic_Form_Type("MV2 ", &
                                              (/  0.408500, 23.852600,  0.609100,  8.245600, -0.167600,  0.041500,  0.149600/) )
       Magnetic_Form( 11) = Magnetic_Form_Type("MV3 ", &
                                              (/  0.359800, 19.336399,  0.663200,  7.617200, -0.306400,  0.029600,  0.283500/) )
       Magnetic_Form( 12) = Magnetic_Form_Type("MV4 ", &
                                              (/  0.310600, 16.816000,  0.719800,  7.048700, -0.052100,  0.302000,  0.022100/) )
       Magnetic_Form( 13) = Magnetic_Form_Type("MCR0", &
                                              (/  0.113500, 45.199001,  0.348100, 19.493099,  0.547700,  7.354200, -0.009200/) )
       Magnetic_Form( 14) = Magnetic_Form_Type("MCR1", &
                                              (/ -0.097700,  0.047000,  0.454400, 26.005400,  0.557900,  7.489200,  0.083100/) )
       Magnetic_Form( 15) = Magnetic_Form_Type("MCR2", &
                                              (/  1.202400, -0.005500,  0.415800, 20.547501,  0.603200,  6.956000, -1.221800/) )
       Magnetic_Form( 16) = Magnetic_Form_Type("MCR3", &
                                              (/ -0.309400,  0.027400,  0.368000, 17.035500,  0.655900,  6.523600,  0.285600/) )
       Magnetic_Form( 17) = Magnetic_Form_Type("MCR4", &
                                              (/ -0.232000,  0.043300,  0.310100, 14.951800,  0.718200,  6.172600,  0.204200/) )
       Magnetic_Form( 18) = Magnetic_Form_Type("MMN0", &
                                              (/  0.243800, 24.962900,  0.147200, 15.672800,  0.618900,  6.540300, -0.010500/) )
       Magnetic_Form( 19) = Magnetic_Form_Type("MMN1", &
                                              (/ -0.013800,  0.421300,  0.423100, 24.667999,  0.590500,  6.654500, -0.001000/) )
       Magnetic_Form( 20) = Magnetic_Form_Type("MMN2", &
                                              (/  0.422000, 17.684000,  0.594800,  6.005000,  0.004300, -0.609000, -0.021900/) )
       Magnetic_Form( 21) = Magnetic_Form_Type("MMN3", &
                                              (/  0.419800, 14.282900,  0.605400,  5.468900,  0.924100, -0.008800, -0.949800/) )
       Magnetic_Form( 22) = Magnetic_Form_Type("MMN4", &
                                              (/  0.376000, 12.566100,  0.660200,  5.132900, -0.037200,  0.563000,  0.001100/) )
       Magnetic_Form( 23) = Magnetic_Form_Type("MMN5", &
                                              (/  0.74050,  5.07409,    0.29237,  11.66547,  -1.78834,   0.00593,   1.75568 /) )
       Magnetic_Form( 24) = Magnetic_Form_Type("MFE0", &
                                              (/  0.070600, 35.008499,  0.358900, 15.358300,  0.581900,  5.560600, -0.011400/) )
       Magnetic_Form( 25) = Magnetic_Form_Type("MFE1", &
                                              (/  0.125100, 34.963299,  0.362900, 15.514400,  0.522300,  5.591400, -0.010500/) )
       Magnetic_Form( 26) = Magnetic_Form_Type("MFE2", &
                                              (/  0.026300, 34.959702,  0.366800, 15.943500,  0.618800,  5.593500, -0.011900/) )
       Magnetic_Form( 27) = Magnetic_Form_Type("MFE3", &
                                              (/  0.397200, 13.244200,  0.629500,  4.903400, -0.031400,  0.349600,  0.004400/) )
       Magnetic_Form( 28) = Magnetic_Form_Type("MFE4", &
                                              (/  0.378200, 11.380000,  0.655600,  4.592000, -0.034600,  0.483300,  0.000500/) )
       Magnetic_Form( 29) = Magnetic_Form_Type("MCO0", &
                                              (/  0.413900, 16.161600,  0.601300,  4.780500, -0.151800,  0.021000,  0.134500/) )
       Magnetic_Form( 30) = Magnetic_Form_Type("MCO1", &
                                              (/  0.099000, 33.125198,  0.364500, 15.176800,  0.547000,  5.008100, -0.010900/) )
       Magnetic_Form( 31) = Magnetic_Form_Type("MCO2", &
                                              (/  0.433200, 14.355300,  0.585700,  4.607700, -0.038200,  0.133800,  0.017900/) )
       Magnetic_Form( 32) = Magnetic_Form_Type("MCO3", &
                                              (/  0.390200, 12.507800,  0.632400,  4.457400, -0.150000,  0.034300,  0.127200/) )
       Magnetic_Form( 33) = Magnetic_Form_Type("MCO4", &
                                              (/  0.351500, 10.778500,  0.677800,  4.234300, -0.038900,  0.240900,  0.009800/) )
       Magnetic_Form( 34) = Magnetic_Form_Type("MNI0", &
                                              (/ -0.017200, 35.739201,  0.317400, 14.268900,  0.713600,  4.566100, -0.014300/) )
       Magnetic_Form( 35) = Magnetic_Form_Type("MNI1", &
                                              (/  0.070500, 35.856098,  0.398400, 13.804200,  0.542700,  4.396500, -0.011800/) )
       Magnetic_Form( 36) = Magnetic_Form_Type("MNI2", &
                                              (/  0.016300, 35.882599,  0.391600, 13.223300,  0.605200,  4.338800, -0.013300/) )
       Magnetic_Form( 37) = Magnetic_Form_Type("MNI3", &
                                              (/ -0.013400, 35.867699,  0.267800, 12.332600,  0.761400,  4.236900, -0.016200/) )
       Magnetic_Form( 38) = Magnetic_Form_Type("MNI4", &
                                              (/ -0.009000, 35.861401,  0.277600, 11.790400,  0.747400,  4.201100, -0.016300/) )
       Magnetic_Form( 39) = Magnetic_Form_Type("MCU0", &
                                              (/  0.090900, 34.983799,  0.408800, 11.443200,  0.512800,  3.824800, -0.012400/) )
       Magnetic_Form( 40) = Magnetic_Form_Type("MCU1", &
                                              (/  0.074900, 34.965599,  0.414700, 11.764200,  0.523800,  3.849700, -0.012700/) )
       Magnetic_Form( 41) = Magnetic_Form_Type("MCU2", &
                                              (/  0.023200, 34.968601,  0.402300, 11.564000,  0.588200,  3.842800, -0.013700/) )
       Magnetic_Form( 42) = Magnetic_Form_Type("MCU3", &
                                              (/  0.003100, 34.907398,  0.358200, 10.913800,  0.653100,  3.827900, -0.014700/) )
       Magnetic_Form( 43) = Magnetic_Form_Type("MCU4", &
                                              (/ -0.013200, 30.681700,  0.280100, 11.162600,  0.749000,  3.817200, -0.016500/) )
       Magnetic_Form( 44) = Magnetic_Form_Type("MY0 ", &
                                              (/  0.591500, 67.608101,  1.512300, 17.900400, -1.113000, 14.135900,  0.008000/) )
       Magnetic_Form( 45) = Magnetic_Form_Type("MZR0", &
                                              (/  0.410600, 59.996101,  1.054300, 18.647600, -0.475100, 10.540000,  0.010600/) )
       Magnetic_Form( 46) = Magnetic_Form_Type("MZR1", &
                                              (/  0.453200, 59.594799,  0.783400, 21.435699, -0.245100,  9.036000,  0.009800/) )
       Magnetic_Form( 47) = Magnetic_Form_Type("MNB0", &
                                              (/  0.394600, 49.229698,  1.319700, 14.821600, -0.726900,  9.615600,  0.012900/) )
       Magnetic_Form( 48) = Magnetic_Form_Type("MNB1", &
                                              (/  0.457200, 49.918201,  1.027400, 15.725600, -0.496200,  9.157300,  0.011800/) )
       Magnetic_Form( 49) = Magnetic_Form_Type("MMO0", &
                                              (/  0.180600, 49.056801,  1.230600, 14.785900, -0.426800,  6.986600,  0.017100/) )
       Magnetic_Form( 50) = Magnetic_Form_Type("MMO1", &
                                              (/  0.350000, 48.035400,  1.030500, 15.060400, -0.392900,  7.479000,  0.013900/) )
       Magnetic_Form( 51) = Magnetic_Form_Type("MTC0", &
                                              (/  0.129800, 49.661098,  1.165600, 14.130700, -0.313400,  5.512900,  0.019500/) )
       Magnetic_Form( 52) = Magnetic_Form_Type("MTC1", &
                                              (/  0.267400, 48.956600,  0.956900, 15.141300, -0.238700,  5.457800,  0.016000/) )
       Magnetic_Form( 53) = Magnetic_Form_Type("MRU0", &
                                              (/  0.106900, 49.423801,  1.191200, 12.741700, -0.317600,  4.912500,  0.021300/) )
       Magnetic_Form( 54) = Magnetic_Form_Type("MRU1", &
                                              (/  0.441000, 33.308601,  1.477500,  9.553100, -0.936100,  6.722000,  0.017600/) )
       Magnetic_Form( 55) = Magnetic_Form_Type("MRH0", &
                                              (/  0.097600, 49.882500,  1.160100, 11.830700, -0.278900,  4.126600,  0.023400/) )
       Magnetic_Form( 56) = Magnetic_Form_Type("MRH1", &
                                              (/  0.334200, 29.756399,  1.220900,  9.438400, -0.575500,  5.332000,  0.021000/) )
       Magnetic_Form( 57) = Magnetic_Form_Type("MPD0", &
                                              (/  0.200300, 29.363300,  1.144600,  9.599300, -0.368900,  4.042300,  0.025100/) )
       Magnetic_Form( 58) = Magnetic_Form_Type("MPD1", &
                                              (/  0.503300, 24.503700,  1.998200,  6.908200, -1.524000,  5.513300,  0.021300/) )
       Magnetic_Form( 59) = Magnetic_Form_Type("MCE2", &
                                              (/  0.295300, 17.684601,  0.292300,  6.732900,  0.431300,  5.382700, -0.019400/) )
       Magnetic_Form( 60) = Magnetic_Form_Type("MND2", &
                                              (/  0.164500, 25.045300,  0.252200, 11.978200,  0.601200,  4.946100, -0.018000/) )
       Magnetic_Form( 61) = Magnetic_Form_Type("MND3", &
                                              (/  0.054000, 25.029301,  0.310100, 12.102000,  0.657500,  4.722300, -0.021600/) )
       Magnetic_Form( 62) = Magnetic_Form_Type("MSM2", &
                                              (/  0.090900, 25.203199,  0.303700, 11.856200,  0.625000,  4.236600, -0.020000/) )
       Magnetic_Form( 63) = Magnetic_Form_Type("MSM3", &
                                              (/  0.028800, 25.206800,  0.297300, 11.831100,  0.695400,  4.211700, -0.021300/) )
       Magnetic_Form( 64) = Magnetic_Form_Type("MEU2", &
                                              (/  0.075500, 25.296000,  0.300100, 11.599300,  0.643800,  4.025200, -0.019600/) )
       Magnetic_Form( 65) = Magnetic_Form_Type("MEU3", &
                                              (/  0.020400, 25.307800,  0.301000, 11.474400,  0.700500,  3.942000, -0.022000/) )
       Magnetic_Form( 66) = Magnetic_Form_Type("MGD2", &
                                              (/  0.063600, 25.382299,  0.303300, 11.212500,  0.652800,  3.787700, -0.019900/) )
       Magnetic_Form( 67) = Magnetic_Form_Type("MGD3", &
                                              (/  0.018600, 25.386700,  0.289500, 11.142100,  0.713500,  3.752000, -0.021700/) )
       Magnetic_Form( 68) = Magnetic_Form_Type("MTB2", &
                                              (/  0.054700, 25.508600,  0.317100, 10.591100,  0.649000,  3.517100, -0.021200/) )
       Magnetic_Form( 69) = Magnetic_Form_Type("MTB3", &
                                              (/  0.017700, 25.509501,  0.292100, 10.576900,  0.713300,  3.512200, -0.023100/) )
       Magnetic_Form( 70) = Magnetic_Form_Type("MDY2", &
                                              (/  0.130800, 18.315500,  0.311800,  7.664500,  0.579500,  3.146900, -0.022600/) )
       Magnetic_Form( 71) = Magnetic_Form_Type("MDY3", &
                                              (/  0.115700, 15.073200,  0.327000,  6.799100,  0.582100,  3.020200, -0.024900/) )
       Magnetic_Form( 72) = Magnetic_Form_Type("MHO2", &
                                              (/  0.099500, 18.176100,  0.330500,  7.855600,  0.592100,  2.979900, -0.023000/) )
       Magnetic_Form( 73) = Magnetic_Form_Type("MHO3", &
                                              (/  0.056600, 18.317600,  0.336500,  7.688000,  0.631700,  2.942700, -0.024800/) )
       Magnetic_Form( 74) = Magnetic_Form_Type("MER2", &
                                              (/  0.112200, 18.122299,  0.346200,  6.910600,  0.564900,  2.761400, -0.023500/) )
       Magnetic_Form( 75) = Magnetic_Form_Type("MER3", &
                                              (/  0.058600, 17.980200,  0.354000,  7.096400,  0.612600,  2.748200, -0.025100/) )
       Magnetic_Form( 76) = Magnetic_Form_Type("MTM2", &
                                              (/  0.098300, 18.323601,  0.338000,  6.917800,  0.587500,  2.662200, -0.024100/) )
       Magnetic_Form( 77) = Magnetic_Form_Type("MTM3", &
                                              (/  0.058100, 15.092200,  0.278700,  7.801500,  0.685400,  2.793100, -0.022400/) )
       Magnetic_Form( 78) = Magnetic_Form_Type("MYB2", &
                                              (/  0.085500, 18.512300,  0.294300,  7.373400,  0.641200,  2.677700, -0.021300/) )
       Magnetic_Form( 79) = Magnetic_Form_Type("MYB3", &
                                              (/  0.041600, 16.094900,  0.284900,  7.834100,  0.696100,  2.672500, -0.022900/) )
       Magnetic_Form( 80) = Magnetic_Form_Type("MU3 ", &
                                              (/  0.505800, 23.288200,  1.346400,  7.002800, -0.872400,  4.868300,  0.019200/) )
       Magnetic_Form( 81) = Magnetic_Form_Type("MU4 ", &
                                              (/  0.329100, 23.547501,  1.083600,  8.454000, -0.434000,  4.119600,  0.021400/) )
       Magnetic_Form( 82) = Magnetic_Form_Type("MU5 ", &
                                              (/  0.365000, 19.803801,  3.219900,  6.281800, -2.607700,  5.301000,  0.023300/) )
       Magnetic_Form( 83) = Magnetic_Form_Type("MNP3", &
                                              (/  0.515700, 20.865400,  2.278400,  5.893000, -1.816300,  4.845700,  0.021100/) )
       Magnetic_Form( 84) = Magnetic_Form_Type("MNP4", &
                                              (/  0.420600, 19.804600,  2.800400,  5.978300, -2.243600,  4.984800,  0.022800/) )
       Magnetic_Form( 85) = Magnetic_Form_Type("MNP5", &
                                              (/  0.369200, 18.190001,  3.151000,  5.850000, -2.544600,  4.916400,  0.024800/) )
       Magnetic_Form( 86) = Magnetic_Form_Type("MNP6", &
                                              (/  0.292900, 17.561100,  3.486600,  5.784700, -2.806600,  4.870700,  0.026700/) )
       Magnetic_Form( 87) = Magnetic_Form_Type("MPU3", &
                                              (/  0.384000, 16.679300,  3.104900,  5.421000, -2.514800,  4.551200,  0.026300/) )
       Magnetic_Form( 88) = Magnetic_Form_Type("MPU4", &
                                              (/  0.493400, 16.835501,  1.639400,  5.638400, -1.158100,  4.139900,  0.024800/) )
       Magnetic_Form( 89) = Magnetic_Form_Type("MPU5", &
                                              (/  0.388800, 16.559200,  2.036200,  5.656700, -1.451500,  4.255200,  0.026700/) )
       Magnetic_Form( 90) = Magnetic_Form_Type("MPU6", &
                                              (/  0.317200, 16.050699,  3.465400,  5.350700, -2.810200,  4.513300,  0.028100/) )
       Magnetic_Form( 91) = Magnetic_Form_Type("MAM2", &
                                              (/  0.474300, 21.776100,  1.580000,  5.690200, -1.077900,  4.145100,  0.021800/) )
       Magnetic_Form( 92) = Magnetic_Form_Type("MAM3", &
                                              (/  0.423900, 19.573900,  1.457300,  5.872200, -0.905200,  3.968200,  0.023800/) )
       Magnetic_Form( 93) = Magnetic_Form_Type("MAM4", &
                                              (/  0.373700, 17.862499,  1.352100,  6.042600, -0.751400,  3.719900,  0.025800/) )
       Magnetic_Form( 94) = Magnetic_Form_Type("MAM5", &
                                              (/  0.295600, 17.372499,  1.452500,  6.073400, -0.775500,  3.661900,  0.027700/) )
       Magnetic_Form( 95) = Magnetic_Form_Type("MAM6", &
                                              (/  0.230200, 16.953300,  1.486400,  6.115900, -0.745700,  3.542600,  0.029400/) )
       Magnetic_Form( 96) = Magnetic_Form_Type("MAM7", &
                                              (/  0.360100, 12.729900,  1.964000,  5.120300, -1.356000,  3.714200,  0.031600/) )
       Magnetic_Form( 97) = Magnetic_Form_Type("MPR3", &
                                              (/  0.050400, 24.998900,  0.257200, 12.037700,  0.714200,  5.003900, -0.021900/) )
       Magnetic_Form( 98) = Magnetic_Form_Type("MO1", &
                                              (/  0.115285, 85.197300,  0.556229, 25.252200,  0.332476,  6.362070, -0.00460676/) )
       Magnetic_Form( 99) = Magnetic_Form_Type("MXX1", &
                                              (/  0.0,  0.0,  0.0,  0.0,  0.0,  0.0,  0.0/) ) !for future use
       Magnetic_Form(100) = Magnetic_Form_Type("MXX2", &
                                              (/  0.0,  0.0,  0.0,  0.0,  0.0,  0.0,  0.0/) ) !for future use
       Magnetic_Form(101) = Magnetic_Form_Type("JCE2", &
                                              (/  0.031972,  8.926222,  0.265792,  7.678510,  0.682151,  2.329783,  0.020578/) )
       Magnetic_Form(102) = Magnetic_Form_Type("JCE3", &
                                              (/  0.051183,  6.115375,  0.277738,  7.952485,  0.654079,  2.287000,  0.016355/) )
       Magnetic_Form(103) = Magnetic_Form_Type("JPR3", &
                                              (/  0.023288,  0.582954,  0.349391,  5.601756,  0.615363,  1.932779,  0.011454/) )
       Magnetic_Form(104) = Magnetic_Form_Type("JND2", &
                                              (/  0.089354,  2.282004,  0.206157,  1.708607,  0.669916,  2.297662,  0.048390/) )
       Magnetic_Form(105) = Magnetic_Form_Type("JND3", &
                                              (/  0.073287,  4.412361,  0.371485,  4.019648,  0.539459,  1.557985,  0.017335/) )
       Magnetic_Form(106) = Magnetic_Form_Type("JGD3", &
                                              (/  0.060537, 10.775218,  0.271475, 13.097898,  0.665241,  3.162837,  0.001566/) )
       Magnetic_Form(107) = Magnetic_Form_Type("JTB2", &
                                              (/  0.049801, 18.734161,  0.277437, 10.084129,  0.661194,  2.745624,  0.010774/) )
       Magnetic_Form(108) = Magnetic_Form_Type("JTB3", &
                                              (/  0.049792, 15.112189,  0.270644,  9.158312,  0.679388,  2.880260, -0.000131/) )
       Magnetic_Form(109) = Magnetic_Form_Type("JDY2", &
                                              (/  0.175586,  5.938148,  0.228867, 11.464046,  0.583298,  2.167554,  0.011186/) )
       Magnetic_Form(110) = Magnetic_Form_Type("JDY3", &
                                              (/  0.146536, 12.639305,  0.375822,  5.511785,  0.515731,  2.090789,  0.093576/) )
       Magnetic_Form(111) = Magnetic_Form_Type("JHO2", &
                                              (/  0.023234,  0.703240,  0.270745,  9.993475,  0.677581,  2.521403,  0.027101/) )
       Magnetic_Form(112) = Magnetic_Form_Type("JHO2", &
                                              (/  0.023234,  0.703240,  0.270745,  9.993475,  0.677581,  2.521403,  0.027101/) )
       Magnetic_Form(113) = Magnetic_Form_Type("JHO3", &
                                              (/  0.043204,  0.910121,  0.279392,  8.683387,  0.668537,  2.417518,  0.008207/) )
       Magnetic_Form(114) = Magnetic_Form_Type("JER2", &
                                              (/  0.037734,  6.081446,  0.256447,  9.598846,  0.679204,  2.139296,  0.025543/) )
       Magnetic_Form(115) = Magnetic_Form_Type("JER3", &
                                              (/  0.038871,  5.311772,  0.259781,  8.173226,  0.678414,  2.082836,  0.022169/) )
       Magnetic_Form(116) = Magnetic_Form_Type("JTM2", &
                                              (/  0.037670,  4.455198,  0.254184,  9.151058,  0.677308,  2.021746,  0.029718/) )
       Magnetic_Form(117) = Magnetic_Form_Type("JTM3", &
                                              (/  0.028279,  2.291633,  0.265583,  7.776700,  0.675720,  2.018924,  0.029883/) )
       Magnetic_Form(118) = Magnetic_Form_Type("JYB3", &
                                           (/  0.092380,  2.046342,  0.258408,  7.471918,  0.609716,  1.913869,  0.038824/) )
       Magnetic_Form(119) = Magnetic_Form_Type("JO1 ", &
                                              (/  0.115285, 85.197300,  0.556229, 25.252200,  0.332476,  6.362070,-0.00460676/) )

       !---- <j2> Coefficients ----!
       Magnetic_j2(  1) = Magnetic_Form_Type("SC0 ",(/10.8172,54.327, 4.7353,14.847, 0.6071, 4.218, 0.0011/))
       Magnetic_j2(  2) = Magnetic_Form_Type("SC1 ",(/ 8.5021,34.285, 3.2116,10.994, 0.4244, 3.605, 0.0009/))
       Magnetic_j2(  3) = Magnetic_Form_Type("SC2 ",(/ 4.3683,28.654, 3.7231,10.823, 0.6074, 3.668, 0.0014/))
       Magnetic_j2(  4) = Magnetic_Form_Type("TI0 ",(/ 4.3583,36.056, 3.8230,11.133, 0.6855, 3.469, 0.0020/))
       Magnetic_j2(  5) = Magnetic_Form_Type("TI1 ",(/ 6.1567,27.275, 2.6833, 8.983, 0.4070, 3.052, 0.0011/))
       Magnetic_j2(  6) = Magnetic_Form_Type("TI2 ",(/ 4.3107,18.348, 2.0960, 6.797, 0.2984, 2.548, 0.0007/))
       Magnetic_j2(  7) = Magnetic_Form_Type("TI3 ",(/ 3.3717,14.444, 1.8258, 5.713, 0.2470, 2.265, 0.0005/))
       Magnetic_j2(  8) = Magnetic_Form_Type("V0  ",(/ 3.8099,21.347, 2.3295, 7.409, 0.4333, 2.632, 0.0015/))
       Magnetic_j2(  9) = Magnetic_Form_Type("V1  ",(/ 4.7474,23.323, 2.3609, 7.808, 0.4105, 2.706, 0.0014/))
       Magnetic_j2( 10) = Magnetic_Form_Type("V2  ",(/ 3.4386,16.530, 1.9638, 6.141, 0.2997, 2.267, 0.0009/))
       Magnetic_j2( 11) = Magnetic_Form_Type("V3  ",(/ 2.3005,14.682, 2.0364, 6.130, 0.4099, 2.382, 0.0014/))
       Magnetic_j2( 12) = Magnetic_Form_Type("V4  ",(/ 1.8377,12.267, 1.8247, 5.458, 0.3979, 2.248, 0.0012/))
       Magnetic_j2( 13) = Magnetic_Form_Type("CR0 ",(/ 3.4085,20.127, 2.1006, 6.802, 0.4266, 2.394, 0.0019/))
       Magnetic_j2( 14) = Magnetic_Form_Type("CR1 ",(/ 3.7768,20.346, 2.1028, 6.893, 0.4010, 2.411, 0.0017/))
       Magnetic_j2( 15) = Magnetic_Form_Type("CR2 ",(/ 2.6422,16.060, 1.9198, 6.253, 0.4446, 2.372, 0.0020/))
       Magnetic_j2( 16) = Magnetic_Form_Type("CR3 ",(/ 1.6262,15.066, 2.0618, 6.284, 0.5281, 2.368, 0.0023/))
       Magnetic_j2( 17) = Magnetic_Form_Type("CR4 ",(/ 1.0293,13.950, 1.9933, 6.059, 0.5974, 2.346, 0.0027/))
       Magnetic_j2( 18) = Magnetic_Form_Type("MN0 ",(/ 2.6681,16.060, 1.7561, 5.640, 0.3675, 2.049, 0.0017/))
       Magnetic_j2( 19) = Magnetic_Form_Type("MN1 ",(/ 3.2953,18.695, 1.8792, 6.240, 0.3927, 2.201, 0.0022/))
       Magnetic_j2( 20) = Magnetic_Form_Type("MN2 ",(/ 2.0515,15.556, 1.8841, 6.063, 0.4787, 2.232, 0.0027/))
       Magnetic_j2( 21) = Magnetic_Form_Type("MN3 ",(/ 1.2427,14.997, 1.9567, 6.118, 0.5732, 2.258, 0.0031/))
       Magnetic_j2( 22) = Magnetic_Form_Type("MN4 ",(/ 0.7879,13.886, 1.8717, 5.743, 0.5981, 2.182, 0.0034/))
       Magnetic_j2( 23) = Magnetic_Form_Type("MN5 ",(/-0.11904,6.59893,-0.23941,10.73086, 0.35048,1.49116,0.00776/))
       Magnetic_j2( 24) = Magnetic_Form_Type("FE0 ",(/ 1.9405,18.473, 1.9566, 6.323, 0.5166, 2.161, 0.0036/))
       Magnetic_j2( 25) = Magnetic_Form_Type("FE1 ",(/ 2.6290,18.660, 1.8704, 6.331, 0.4690, 2.163, 0.0031/))
       Magnetic_j2( 26) = Magnetic_Form_Type("FE2 ",(/ 1.6490,16.559, 1.9064, 6.133, 0.5206, 2.137, 0.0035/))
       Magnetic_j2( 27) = Magnetic_Form_Type("FE3 ",(/ 1.3602,11.998, 1.5188, 5.003, 0.4705, 1.991, 0.0038/))
       Magnetic_j2( 28) = Magnetic_Form_Type("FE4 ",(/ 1.5582, 8.275, 1.1863, 3.279, 0.1366, 1.107,-0.0022/))
       Magnetic_j2( 29) = Magnetic_Form_Type("CO0 ",(/ 1.9678,14.170, 1.4911, 4.948, 0.3844, 1.797, 0.0027/))
       Magnetic_j2( 30) = Magnetic_Form_Type("CO1 ",(/ 2.4097,16.161, 1.5780, 5.460, 0.4095, 1.914, 0.0031/))
       Magnetic_j2( 31) = Magnetic_Form_Type("CO2 ",(/ 1.9049,11.644, 1.3159, 4.357, 0.3146, 1.645, 0.0017/))
       Magnetic_j2( 32) = Magnetic_Form_Type("CO3 ",(/ 1.7058, 8.859, 1.1409, 3.309, 0.1474, 1.090,-0.0025/))
       Magnetic_j2( 33) = Magnetic_Form_Type("CO4 ",(/ 1.3110, 8.025, 1.1551, 3.179, 0.1608, 1.130,-0.0011/))
       Magnetic_j2( 34) = Magnetic_Form_Type("NI0 ",(/ 1.0302,12.252, 1.4669, 4.745, 0.4521, 1.744, 0.0036/))
       Magnetic_j2( 35) = Magnetic_Form_Type("NI1 ",(/ 2.1040,14.866, 1.4302, 5.071, 0.4031, 1.778, 0.0034/))
       Magnetic_j2( 36) = Magnetic_Form_Type("NI2 ",(/ 1.7080,11.016, 1.2147, 4.103, 0.3150, 1.533, 0.0018/))
       Magnetic_j2( 37) = Magnetic_Form_Type("NI3 ",(/ 1.1612, 7.700, 1.0027, 3.263, 0.2719, 1.378, 0.0025/))
       Magnetic_j2( 38) = Magnetic_Form_Type("NI4 ",(/ 1.1612, 7.700, 1.0027, 3.263, 0.2719, 1.378, 0.0025/))
       Magnetic_j2( 39) = Magnetic_Form_Type("CU0 ",(/ 1.9182,14.490, 1.3329, 4.730, 0.3842, 1.639, 0.0035/))
       Magnetic_j2( 40) = Magnetic_Form_Type("CU1 ",(/ 1.8814,13.433, 1.2809, 4.545, 0.3646, 1.602, 0.0033/))
       Magnetic_j2( 41) = Magnetic_Form_Type("CU2 ",(/ 1.5189,10.478, 1.1512, 3.813, 0.2918, 1.398, 0.0017/))
       Magnetic_j2( 42) = Magnetic_Form_Type("CU3 ",(/ 1.2797, 8.450, 1.0315, 3.280, 0.2401, 1.250, 0.0015/))
       Magnetic_j2( 43) = Magnetic_Form_Type("CU4 ",(/ 0.9568, 7.448, 0.9099, 3.396, 0.3729, 1.494, 0.0049/))
       Magnetic_j2( 44) = Magnetic_Form_Type("Y0  ",(/14.4084,44.658, 5.1045,14.904,-0.0535, 3.319, 0.0028/))
       Magnetic_j2( 45) = Magnetic_Form_Type("ZR0 ",(/10.1378,35.337, 4.7734,12.545,-0.0489, 2.672, 0.0036/))
       Magnetic_j2( 46) = Magnetic_Form_Type("ZR1 ",(/11.8722,34.920, 4.0502,12.127,-0.0632, 2.828, 0.0034/))
       Magnetic_j2( 47) = Magnetic_Form_Type("NB0 ",(/ 7.4796,33.179, 5.0884,11.571,-0.0281, 1.564, 0.0047/))
       Magnetic_j2( 48) = Magnetic_Form_Type("NB1 ",(/ 8.7735,33.285, 4.6556,11.605,-0.0268, 1.539, 0.0044/))
       Magnetic_j2( 49) = Magnetic_Form_Type("MO0 ",(/ 5.1180,23.422, 4.1809, 9.208,-0.0505, 1.743, 0.0053/))
       Magnetic_j2( 50) = Magnetic_Form_Type("MO1 ",(/ 7.2367,28.128, 4.0705, 9.923,-0.0317, 1.455, 0.0049/))
       Magnetic_j2( 51) = Magnetic_Form_Type("TC0 ",(/ 4.2441,21.397, 3.9439, 8.375,-0.0371, 1.187, 0.0066/))
       Magnetic_j2( 52) = Magnetic_Form_Type("TC1 ",(/ 6.4056,24.824, 3.5400, 8.611,-0.0366, 1.485, 0.0044/))
       Magnetic_j2( 53) = Magnetic_Form_Type("RU0 ",(/ 3.7445,18.613, 3.4749, 7.420,-0.0363, 1.007, 0.0073/))
       Magnetic_j2( 54) = Magnetic_Form_Type("RU1 ",(/ 5.2826,23.683, 3.5813, 8.152,-0.0257, 0.426, 0.0131/))
       Magnetic_j2( 55) = Magnetic_Form_Type("RH0 ",(/ 3.3651,17.344, 3.2121, 6.804,-0.0350, 0.503, 0.0146/))
       Magnetic_j2( 56) = Magnetic_Form_Type("RH1 ",(/ 4.0260,18.950, 3.1663, 7.000,-0.0296, 0.486, 0.0127/))
       Magnetic_j2( 57) = Magnetic_Form_Type("PD0 ",(/ 3.3105,14.726, 2.6332, 5.862,-0.0437, 1.130, 0.0053/))
       Magnetic_j2( 58) = Magnetic_Form_Type("PD1 ",(/ 4.2749,17.900, 2.7021, 6.354,-0.0258, 0.700, 0.0071/))
       Magnetic_j2( 59) = Magnetic_Form_Type("CE2 ",(/ 0.9809,18.063, 1.8413, 7.769, 0.9905, 2.845, 0.0120/))
       Magnetic_j2( 60) = Magnetic_Form_Type("ND2 ",(/ 1.4530,18.340, 1.6196, 7.285, 0.8752, 2.622, 0.0126/))
       Magnetic_j2( 61) = Magnetic_Form_Type("ND3 ",(/ 0.6751,18.342, 1.6272, 7.260, 0.9644, 2.602, 0.0150/))
       Magnetic_j2( 62) = Magnetic_Form_Type("SM2 ",(/ 1.0360,18.425, 1.4769, 7.032, 0.8810, 2.437, 0.0152/))
       Magnetic_j2( 63) = Magnetic_Form_Type("SM3 ",(/ 0.4707,18.430, 1.4261, 7.034, 0.9574, 2.439, 0.0182/))
       Magnetic_j2( 64) = Magnetic_Form_Type("EU2 ",(/ 0.8970,18.443, 1.3769, 7.005, 0.9060, 2.421, 0.0190/))
       Magnetic_j2( 65) = Magnetic_Form_Type("EU3 ",(/ 0.3985,18.451, 1.3307, 6.956, 0.9603, 2.378, 0.0197/))
       Magnetic_j2( 66) = Magnetic_Form_Type("GD2 ",(/ 0.7756,18.469, 1.3124, 6.899, 0.8956, 2.338, 0.0199/))
       Magnetic_j2( 67) = Magnetic_Form_Type("GD3 ",(/ 0.3347,18.476, 1.2465, 6.877, 0.9537, 2.318, 0.0217/))
       Magnetic_j2( 68) = Magnetic_Form_Type("TB2 ",(/ 0.6688,18.491, 1.2487, 6.822, 0.8888, 2.275, 0.0215/))
       Magnetic_j2( 69) = Magnetic_Form_Type("TB3 ",(/ 0.2892,18.497, 1.1678, 6.797, 0.9437, 2.257, 0.0232/))
       Magnetic_j2( 70) = Magnetic_Form_Type("DY2 ",(/ 0.5917,18.511, 1.1828, 6.747, 0.8801, 2.214, 0.0229/))
       Magnetic_j2( 71) = Magnetic_Form_Type("DY3 ",(/ 0.2523,18.517, 1.0914, 6.736, 0.9345, 2.208, 0.0250/))
       Magnetic_j2( 72) = Magnetic_Form_Type("HO2 ",(/ 0.5094,18.515, 1.1234, 6.706, 0.8727, 2.159, 0.0242/))
       Magnetic_j2( 73) = Magnetic_Form_Type("HO3 ",(/ 0.2188,18.516, 1.0240, 6.707, 0.9251, 2.161, 0.0268/))
       Magnetic_j2( 74) = Magnetic_Form_Type("ER2 ",(/ 0.4693,18.528, 1.0545, 6.649, 0.8679, 2.120, 0.0261/))
       Magnetic_j2( 75) = Magnetic_Form_Type("ER3 ",(/ 0.1710,18.534, 0.9879, 6.625, 0.9044, 2.100, 0.0278/))
       Magnetic_j2( 76) = Magnetic_Form_Type("TM2 ",(/ 0.4198,18.542, 0.9959, 6.600, 0.8593, 2.082, 0.0284/))
       Magnetic_j2( 77) = Magnetic_Form_Type("TM3 ",(/ 0.1760,18.542, 0.9105, 6.579, 0.8970, 2.062, 0.0294/))
       Magnetic_j2( 78) = Magnetic_Form_Type("YB2 ",(/ 0.3852,18.550, 0.9415, 6.551, 0.8492, 2.043, 0.0301/))
       Magnetic_j2( 79) = Magnetic_Form_Type("YB3 ",(/ 0.1570,18.555, 0.8484, 6.540, 0.8880, 2.037, 0.0318/))
       Magnetic_j2( 80) = Magnetic_Form_Type("U3  ",(/ 4.1582,16.534, 2.4675, 5.952,-0.0252, 0.765, 0.0057/))
       Magnetic_j2( 81) = Magnetic_Form_Type("U4  ",(/ 3.7449,13.894, 2.6453, 4.863,-0.5218, 3.192, 0.0009/))
       Magnetic_j2( 82) = Magnetic_Form_Type("U5  ",(/ 3.0724,12.546, 2.3076, 5.231,-0.0644, 1.474, 0.0035/))
       Magnetic_j2( 83) = Magnetic_Form_Type("NP3 ",(/ 3.7170,15.133, 2.3216, 5.503,-0.0275, 0.800, 0.0052/))
       Magnetic_j2( 84) = Magnetic_Form_Type("NP4 ",(/ 2.9203,14.646, 2.5979, 5.559,-0.0301, 0.367, 0.0141/))
       Magnetic_j2( 85) = Magnetic_Form_Type("NP5 ",(/ 2.3308,13.654, 2.7219, 5.494,-0.1357, 0.049, 0.1224/))
       Magnetic_j2( 86) = Magnetic_Form_Type("NP6 ",(/ 1.8245,13.180, 2.8508, 5.407,-0.1579, 0.044, 0.1438/))
       Magnetic_j2( 87) = Magnetic_Form_Type("PU3 ",(/ 2.0885,12.871, 2.5961, 5.190,-0.1465, 0.039, 0.1343/))
       Magnetic_j2( 88) = Magnetic_Form_Type("PU4 ",(/ 2.7244,12.926, 2.3387, 5.163,-0.1300, 0.046, 0.1177/))
       Magnetic_j2( 89) = Magnetic_Form_Type("PU5 ",(/ 2.1409,12.832, 2.5664, 5.152,-0.1338, 0.046, 0.1210/))
       Magnetic_j2( 90) = Magnetic_Form_Type("PU6 ",(/ 1.7262,12.324, 2.6652, 5.066,-0.1695, 0.041, 0.1550/))
       Magnetic_j2( 91) = Magnetic_Form_Type("AM2 ",(/ 3.5237,15.955, 2.2855, 5.195,-0.0142, 0.585, 0.0033/))
       Magnetic_j2( 92) = Magnetic_Form_Type("AM3 ",(/ 2.8622,14.733, 2.4099, 5.144,-0.1326, 0.031, 0.1233/))
       Magnetic_j2( 93) = Magnetic_Form_Type("AM4 ",(/ 2.4141,12.948, 2.3687, 4.945,-0.2490, 0.022, 0.2371/))
       Magnetic_j2( 94) = Magnetic_Form_Type("AM5 ",(/ 2.0109,12.053, 2.4155, 4.836,-0.2264, 0.027, 0.2128/))
       Magnetic_j2( 95) = Magnetic_Form_Type("AM6 ",(/ 1.6778,11.337, 2.4531, 4.725,-0.2043, 0.034, 0.1892/))
       Magnetic_j2( 96) = Magnetic_Form_Type("AM7 ",(/ 1.8845, 9.161, 2.0746, 4.042,-0.1318, 1.723, 0.0020/))
       Magnetic_j2( 97) = Magnetic_Form_Type("PR3 ",(/ 0.8734,18.9876,1.5594,6.0872, 0.8142,2.4150, 0.0111/))

       !---- <j4> Coefficients ----!
       Magnetic_j4(  1) = Magnetic_Form_Type("SC0 ",(/ 1.3420,10.200, 0.3837, 3.079, 0.0468, 0.118,-0.0328/))
       Magnetic_j4(  2) = Magnetic_Form_Type("SC1 ",(/ 7.1167,15.487,-6.6671,18.269, 0.4900, 2.992, 0.0047/))
       Magnetic_j4(  3) = Magnetic_Form_Type("SC2 ",(/-1.6684,15.648, 1.7742, 9.062, 0.4075, 2.412, 0.0042/))
       Magnetic_j4(  4) = Magnetic_Form_Type("TI0 ",(/-2.1515,11.271, 2.5149, 8.859, 0.3555, 2.149, 0.0045/))
       Magnetic_j4(  5) = Magnetic_Form_Type("TI1 ",(/-1.0383,16.190, 1.4699, 8.924, 0.3631, 2.283, 0.0044/))
       Magnetic_j4(  6) = Magnetic_Form_Type("TI2 ",(/-1.3242,15.310, 1.2042, 7.899, 0.3976, 2.156, 0.0051/))
       Magnetic_j4(  7) = Magnetic_Form_Type("TI3 ",(/-1.1117,14.635, 0.7689, 6.927, 0.4385, 2.089, 0.0060/))
       Magnetic_j4(  8) = Magnetic_Form_Type("V0  ",(/-0.9633,15.273, 0.9274, 7.732, 0.3891, 2.053, 0.0063/))
       Magnetic_j4(  9) = Magnetic_Form_Type("V1  ",(/-0.9606,15.545, 1.1278, 8.118, 0.3653, 2.097, 0.0056/))
       Magnetic_j4( 10) = Magnetic_Form_Type("V2  ",(/-1.1729,14.973, 0.9092, 7.613, 0.4105, 2.039, 0.0067/))
       Magnetic_j4( 11) = Magnetic_Form_Type("V3  ",(/-0.9417,14.205, 0.5284, 6.607, 0.4411, 1.967, 0.0076/))
       Magnetic_j4( 12) = Magnetic_Form_Type("V4  ",(/-0.7654,13.097, 0.3071, 5.674, 0.4476, 1.871, 0.0081/))
       Magnetic_j4( 13) = Magnetic_Form_Type("CR0 ",(/-0.6670,19.613, 0.5342, 6.478, 0.3641, 1.905, 0.0073/))
       Magnetic_j4( 14) = Magnetic_Form_Type("CR1 ",(/-0.8309,18.043, 0.7252, 7.531, 0.3828, 2.003, 0.0073/))
       Magnetic_j4( 15) = Magnetic_Form_Type("CR2 ",(/-0.8930,15.664, 0.5590, 7.033, 0.4093, 1.924, 0.0081/))
       Magnetic_j4( 16) = Magnetic_Form_Type("CR3 ",(/-0.7327,14.073, 0.3268, 5.674, 0.4114, 1.810, 0.0085/))
       Magnetic_j4( 17) = Magnetic_Form_Type("CR4 ",(/-0.6748,12.946, 0.1805, 6.753, 0.4526, 1.800, 0.0098/))
       Magnetic_j4( 18) = Magnetic_Form_Type("MN0 ",(/-0.5452,15.471, 0.4406, 4.902, 0.2884, 1.543, 0.0059/))
       Magnetic_j4( 19) = Magnetic_Form_Type("MN1 ",(/-0.7947,17.867, 0.6078, 7.704, 0.3798, 1.905, 0.0087/))
       Magnetic_j4( 20) = Magnetic_Form_Type("MN2 ",(/-0.7416,15.255, 0.3831, 6.469, 0.3935, 1.800, 0.0093/))
       Magnetic_j4( 21) = Magnetic_Form_Type("MN3 ",(/-0.6603,13.607, 0.2322, 6.218, 0.4104, 1.740, 0.0101/))
       Magnetic_j4( 22) = Magnetic_Form_Type("MN4 ",(/-0.5127,13.461, 0.0313, 7.763, 0.4282, 1.701, 0.0113/))
       Magnetic_j4( 23) = Magnetic_Form_Type("MN5 ",(/0.19236,0.32487,1.67062,6.65663,-1.82036,6.19424,-0.04334/))
       Magnetic_j4( 24) = Magnetic_Form_Type("FE0 ",(/-0.5029,19.677, 0.2999, 3.776, 0.2576, 1.424, 0.0071/))
       Magnetic_j4( 25) = Magnetic_Form_Type("FE1 ",(/-0.5109,19.250, 0.3896, 4.891, 0.2810, 1.526, 0.0069/))
       Magnetic_j4( 26) = Magnetic_Form_Type("FE2 ",(/-0.5401,17.227, 0.2865, 3.742, 0.2658, 1.424, 0.0076/))
       Magnetic_j4( 27) = Magnetic_Form_Type("FE3 ",(/-0.5507,11.493, 0.2153, 4.906, 0.3468, 1.523, 0.0095/))
       Magnetic_j4( 28) = Magnetic_Form_Type("FE4 ",(/-0.5352, 9.507, 0.1783, 5.175, 0.3584, 1.469, 0.0097/))
       Magnetic_j4( 29) = Magnetic_Form_Type("CO0 ",(/-0.4221,14.195, 0.2900, 3.979, 0.2469, 1.286, 0.0063/))
       Magnetic_j4( 30) = Magnetic_Form_Type("CO1 ",(/-0.4115,14.561, 0.3580, 4.717, 0.2644, 1.418, 0.0074/))
       Magnetic_j4( 31) = Magnetic_Form_Type("CO2 ",(/-0.4759,14.046, 0.2747, 3.731, 0.2458, 1.250, 0.0057/))
       Magnetic_j4( 32) = Magnetic_Form_Type("CO3 ",(/-0.4466,13.391, 0.1419, 3.011, 0.2773, 1.335, 0.0093/))
       Magnetic_j4( 33) = Magnetic_Form_Type("CO4 ",(/-0.4091,13.194,-0.0194, 3.417, 0.3534, 1.421, 0.0112/))
       Magnetic_j4( 34) = Magnetic_Form_Type("NI0 ",(/-0.4428,14.485, 0.0870, 3.234, 0.2932, 1.331, 0.0096/))
       Magnetic_j4( 35) = Magnetic_Form_Type("NI1 ",(/-0.3836,13.425, 0.3116, 4.462, 0.2471, 1.309, 0.0079/))
       Magnetic_j4( 36) = Magnetic_Form_Type("NI2 ",(/-0.3803,10.403, 0.2838, 3.378, 0.2108, 1.104, 0.0050/))
       Magnetic_j4( 37) = Magnetic_Form_Type("NI3 ",(/-0.3715, 8.952, 0.1211, 2.940, 0.2526, 1.105, 0.0061/))
       Magnetic_j4( 38) = Magnetic_Form_Type("NI4 ",(/-0.3509, 8.157, 0.2220, 2.106, 0.1567, 0.925, 0.0065/))
       Magnetic_j4( 39) = Magnetic_Form_Type("CU0 ",(/-0.3204,15.132, 0.2335, 4.021, 0.2312, 1.196, 0.0068/))
       Magnetic_j4( 40) = Magnetic_Form_Type("CU1 ",(/-0.3572,15.125, 0.2336, 3.966, 0.2315, 1.197, 0.0070/))
       Magnetic_j4( 41) = Magnetic_Form_Type("CU2 ",(/-0.3914,14.740, 0.1275, 3.384, 0.2548, 1.255, 0.0103/))
       Magnetic_j4( 42) = Magnetic_Form_Type("CU3 ",(/-0.3671,14.082,-0.0078, 3.315, 0.3154, 1.377, 0.0132/))
       Magnetic_j4( 43) = Magnetic_Form_Type("CU4 ",(/-0.2915,14.124,-0.1065, 4.201, 0.3247, 1.352, 0.0148/))
       Magnetic_j4( 44) = Magnetic_Form_Type("Y0  ",(/-8.0767,32.201, 7.9197,25.156, 1.4067, 6.827,-0.0001/))
       Magnetic_j4( 45) = Magnetic_Form_Type("ZR0 ",(/-5.2697,32.868, 4.1930,24.183, 1.5202, 6.048,-0.0002/))
       Magnetic_j4( 46) = Magnetic_Form_Type("ZR1 ",(/-5.6384,33.607, 4.6729,22.338, 1.3258, 5.924,-0.0003/))
       Magnetic_j4( 47) = Magnetic_Form_Type("NB0 ",(/-3.1377,25.595, 2.3411,16.569, 1.2304, 4.990,-0.0005/))
       Magnetic_j4( 48) = Magnetic_Form_Type("NB1 ",(/-3.3598,25.820, 2.8297,16.427, 1.1203, 4.982,-0.0005/))
       Magnetic_j4( 49) = Magnetic_Form_Type("MO0 ",(/-2.8860,20.572, 1.8130,14.628, 1.1899, 4.264,-0.0008/))
       Magnetic_j4( 50) = Magnetic_Form_Type("MO1 ",(/-3.2618,25.486, 2.3596,16.462, 1.1164, 4.491,-0.0007/))
       Magnetic_j4( 51) = Magnetic_Form_Type("TC0 ",(/-2.7975,20.159, 1.6520,16.261, 1.1726, 3.943,-0.0008/))
       Magnetic_j4( 52) = Magnetic_Form_Type("TC1 ",(/-2.0470,19.683, 1.6306,11.592, 0.8698, 3.769,-0.0010/))
       Magnetic_j4( 53) = Magnetic_Form_Type("RU0 ",(/-1.5042,17.949, 0.6027, 9.961, 0.9700, 3.393,-0.0010/))
       Magnetic_j4( 54) = Magnetic_Form_Type("RU1 ",(/-1.6278,18.506, 1.1828,10.189, 0.8138, 3.418,-0.0009/))
       Magnetic_j4( 55) = Magnetic_Form_Type("RH0 ",(/-1.3492,17.577, 0.4527,10.507, 0.9285, 3.155,-0.0009/))
       Magnetic_j4( 56) = Magnetic_Form_Type("RH1 ",(/-1.4673,17.957, 0.7381, 9.944, 0.8485, 3.126,-0.0012/))
       Magnetic_j4( 57) = Magnetic_Form_Type("PD0 ",(/-1.1955,17.628, 0.3183,11.309, 0.8696, 2.909,-0.0006/))
       Magnetic_j4( 58) = Magnetic_Form_Type("PD1 ",(/-1.4098,17.765, 0.7927, 9.999, 0.7710, 2.930,-0.0006/))
       Magnetic_j4( 59) = Magnetic_Form_Type("CE2 ",(/-0.6468,10.533, 0.4052, 5.624, 0.3412, 1.535, 0.0080/))
       Magnetic_j4( 60) = Magnetic_Form_Type("ND2 ",(/-0.5416,12.204, 0.3571, 6.169, 0.3154, 1.485, 0.0098/))
       Magnetic_j4( 61) = Magnetic_Form_Type("ND3 ",(/-0.4053,14.014, 0.0329, 7.005, 0.3759, 1.707, 0.0209/))
       Magnetic_j4( 62) = Magnetic_Form_Type("SM2 ",(/-0.4150,14.057, 0.1368, 7.032, 0.3272, 1.582, 0.0192/))
       Magnetic_j4( 63) = Magnetic_Form_Type("SM3 ",(/-0.4288,10.052, 0.1782, 5.019, 0.2833, 1.236, 0.0088/))
       Magnetic_j4( 64) = Magnetic_Form_Type("EU2 ",(/-0.4145,10.193, 0.2447, 5.164, 0.2661, 1.205, 0.0065/))
       Magnetic_j4( 65) = Magnetic_Form_Type("EU3 ",(/-0.4095,10.211, 0.1485, 5.175, 0.2720, 1.237, 0.0131/))
       Magnetic_j4( 66) = Magnetic_Form_Type("GD2 ",(/-0.3824,10.344, 0.1955, 5.306, 0.2622, 1.203, 0.0097/))
       Magnetic_j4( 67) = Magnetic_Form_Type("GD3 ",(/-0.3621,10.353, 0.1016, 5.310, 0.2649, 1.219, 0.0147/))
       Magnetic_j4( 68) = Magnetic_Form_Type("TB2 ",(/-0.3443,10.469, 0.1481, 5.416, 0.2575, 1.182, 0.0104/))
       Magnetic_j4( 69) = Magnetic_Form_Type("TB3 ",(/-0.3228,10.476, 0.0638, 5.419, 0.2566, 1.196, 0.0159/))
       Magnetic_j4( 70) = Magnetic_Form_Type("DY2 ",(/-0.3206,12.071, 0.0904, 8.026, 0.2616, 1.230, 0.0143/))
       Magnetic_j4( 71) = Magnetic_Form_Type("DY3 ",(/-0.2829, 9.525, 0.0565, 4.429, 0.2437, 1.066, 0.0092/))
       Magnetic_j4( 72) = Magnetic_Form_Type("HO2 ",(/-0.2976, 9.719, 0.1224, 4.635, 0.2279, 1.005, 0.0063/))
       Magnetic_j4( 73) = Magnetic_Form_Type("HO3 ",(/-0.2717, 9.731, 0.0474, 4.638, 0.2292, 1.047, 0.0124/))
       Magnetic_j4( 74) = Magnetic_Form_Type("ER2 ",(/-0.2975, 9.829, 0.1189, 4.741, 0.2116, 1.004, 0.0117/))
       Magnetic_j4( 75) = Magnetic_Form_Type("ER3 ",(/-0.2568, 9.834, 0.0356, 4.741, 0.2172, 1.028, 0.0148/))
       Magnetic_j4( 76) = Magnetic_Form_Type("TM2 ",(/-0.2677, 9.888, 0.0925, 4.784, 0.2056, 0.990, 0.0124/))
       Magnetic_j4( 77) = Magnetic_Form_Type("TM3 ",(/-0.2292, 9.895, 0.0124, 4.785, 0.2108, 1.007, 0.0151/))
       Magnetic_j4( 78) = Magnetic_Form_Type("YB2 ",(/-0.2393, 9.947, 0.0663, 4.823, 0.2009, 0.965, 0.0122/))
       Magnetic_j4( 79) = Magnetic_Form_Type("YB3 ",(/-0.2121, 8.197, 0.0325, 3.153, 0.1975, 0.884, 0.0093/))
       Magnetic_j4( 80) = Magnetic_Form_Type("U3  ",(/-0.9859,16.601, 0.6116, 6.515, 0.6020, 2.597,-0.0010/))
       Magnetic_j4( 81) = Magnetic_Form_Type("U4  ",(/-1.0540,16.605, 0.4339, 6.512, 0.6746, 2.599,-0.0011/))
       Magnetic_j4( 82) = Magnetic_Form_Type("U5  ",(/-0.9588,16.485, 0.1576, 6.440, 0.7785, 2.640,-0.0010/))
       Magnetic_j4( 83) = Magnetic_Form_Type("NP3 ",(/-0.9029,16.586, 0.4006, 6.470, 0.6545, 2.563,-0.0004/))
       Magnetic_j4( 84) = Magnetic_Form_Type("NP4 ",(/-0.9887,12.441, 0.5918, 5.294, 0.5306, 2.263,-0.0021/))
       Magnetic_j4( 85) = Magnetic_Form_Type("NP5 ",(/-0.8146,16.581,-0.0055, 6.475, 0.7956, 2.562,-0.0004/))
       Magnetic_j4( 86) = Magnetic_Form_Type("NP6 ",(/-0.6738,16.553,-0.2297, 6.505, 0.8513, 2.553,-0.0003/))
       Magnetic_j4( 87) = Magnetic_Form_Type("PU3 ",(/-0.7014,16.369,-0.1162, 6.697, 0.7778, 2.450, 0.0000/))
       Magnetic_j4( 88) = Magnetic_Form_Type("PU4 ",(/-0.9160,12.203, 0.4891, 5.127, 0.5290, 2.149,-0.0022/))
       Magnetic_j4( 89) = Magnetic_Form_Type("PU5 ",(/-0.7035,16.360,-0.0979, 6.706, 0.7726, 2.447, 0.0000/))
       Magnetic_j4( 90) = Magnetic_Form_Type("PU6 ",(/-0.5560,16.322,-0.3046, 6.768, 0.8146, 2.426, 0.0001/))
       Magnetic_j4( 91) = Magnetic_Form_Type("AM2 ",(/-0.7433,16.416, 0.3481, 6.788, 0.6014, 2.346, 0.0000/))
       Magnetic_j4( 92) = Magnetic_Form_Type("AM3 ",(/-0.8092,12.854, 0.4161, 5.459, 0.5476, 2.172,-0.0011/))
       Magnetic_j4( 93) = Magnetic_Form_Type("AM4 ",(/-0.8548,12.226, 0.3037, 5.909, 0.6173, 2.188,-0.0016/))
       Magnetic_j4( 94) = Magnetic_Form_Type("AM5 ",(/-0.6538,15.462,-0.0948, 5.997, 0.7295, 2.297, 0.0000/))
       Magnetic_j4( 95) = Magnetic_Form_Type("AM6 ",(/-0.5390,15.449,-0.2689, 6.017, 0.7711, 2.297, 0.0002/))
       Magnetic_j4( 96) = Magnetic_Form_Type("AM7 ",(/-0.4688,12.019,-0.2692, 7.042, 0.7297, 2.164,-0.0011/))
       Magnetic_j4( 97) = Magnetic_Form_Type("PR3 ",(/-0.3970,10.9919, 0.0818, 5.9897, 0.3656, 1.5021, 0.0110/))

       !---- <j6> Coefficients ----!
       Magnetic_j6(  1) = Magnetic_Form_Type("CE2 ",(/-0.1212, 7.994,-0.0639, 4.024, 0.1519, 1.096, 0.0078/))
       Magnetic_j6(  2) = Magnetic_Form_Type("ND2 ",(/-0.1600, 8.009, 0.0272, 4.028, 0.1104, 1.068, 0.0139/))
       Magnetic_j6(  3) = Magnetic_Form_Type("ND3 ",(/-0.0416, 8.014,-0.1261, 4.040, 0.1400, 1.087, 0.0102/))
       Magnetic_j6(  4) = Magnetic_Form_Type("SM2 ",(/-0.1428, 6.041, 0.0723, 2.033, 0.0550, 0.513, 0.0081/))
       Magnetic_j6(  5) = Magnetic_Form_Type("SM3 ",(/-0.0944, 6.030,-0.0498, 2.074, 0.1372, 0.645,-0.0132/))
       Magnetic_j6(  6) = Magnetic_Form_Type("EU2 ",(/-0.1252, 6.049, 0.0507, 2.085, 0.0572, 0.646, 0.0132/))
       Magnetic_j6(  7) = Magnetic_Form_Type("EU3 ",(/-0.0817, 6.039,-0.0596, 2.120, 0.1243, 0.764,-0.0001/))
       Magnetic_j6(  8) = Magnetic_Form_Type("GD2 ",(/-0.1351, 5.030, 0.0828, 2.025, 0.0315, 0.503, 0.0187/))
       Magnetic_j6(  9) = Magnetic_Form_Type("GD3 ",(/-0.0662, 6.031,-0.0850, 2.154, 0.1323, 0.891, 0.0048/))
       Magnetic_j6( 10) = Magnetic_Form_Type("TB2 ",(/-0.0758, 6.032,-0.0540, 2.158, 0.1199, 0.890, 0.0051/))
       Magnetic_j6( 11) = Magnetic_Form_Type("TB3 ",(/-0.0559, 6.031,-0.1020, 2.237, 0.1264, 1.107, 0.0167/))
       Magnetic_j6( 12) = Magnetic_Form_Type("DY2 ",(/-0.0568, 6.032,-0.1003, 2.240, 0.1401, 1.106, 0.0109/))
       Magnetic_j6( 13) = Magnetic_Form_Type("DY3 ",(/-0.0423, 6.038,-0.1248, 2.244, 0.1359, 1.200, 0.0188/))
       Magnetic_j6( 14) = Magnetic_Form_Type("HO2 ",(/-0.0725, 6.045,-0.0318, 2.243, 0.0738, 1.202, 0.0252/))
       Magnetic_j6( 15) = Magnetic_Form_Type("HO3 ",(/-0.0289, 6.050,-0.1545, 2.230, 0.1550, 1.260, 0.0177/))
       Magnetic_j6( 16) = Magnetic_Form_Type("ER2 ",(/-0.0648, 6.056,-0.0515, 2.230, 0.0825, 1.264, 0.0250/))
       Magnetic_j6( 17) = Magnetic_Form_Type("ER3 ",(/-0.0110, 6.061,-0.1954, 2.224, 0.1818, 1.296, 0.0149/))
       Magnetic_j6( 18) = Magnetic_Form_Type("TM2 ",(/-0.0842, 4.070, 0.0807, 0.849,-0.2087, 0.039, 0.2095/))
       Magnetic_j6( 19) = Magnetic_Form_Type("TM3 ",(/-0.0727, 4.073, 0.0243, 0.689, 3.9459, 0.002,-3.9076/))
       Magnetic_j6( 20) = Magnetic_Form_Type("YB2 ",(/-0.0739, 5.031, 0.0140, 2.030, 0.0351, 0.508, 0.0174/))
       Magnetic_j6( 21) = Magnetic_Form_Type("YB3 ",(/-0.0345, 5.007,-0.0677, 2.020, 0.0985, 0.549,-0.0076/))
       Magnetic_j6( 22) = Magnetic_Form_Type("U3  ",(/-0.3797, 9.953, 0.0459, 5.038, 0.2748, 1.607, 0.0016/))
       Magnetic_j6( 23) = Magnetic_Form_Type("U4  ",(/-0.1793,11.896,-0.2269, 5.428, 0.3291, 1.701, 0.0030/))
       Magnetic_j6( 24) = Magnetic_Form_Type("U5  ",(/-0.0399,11.891,-0.3458, 5.580, 0.3340, 1.645, 0.0029/))
       Magnetic_j6( 25) = Magnetic_Form_Type("NP3 ",(/-0.2427,11.844,-0.1129, 5.377, 0.2848, 1.568, 0.0022/))
       Magnetic_j6( 26) = Magnetic_Form_Type("NP4 ",(/-0.2436, 9.599,-0.1317, 4.101, 0.3029, 1.545, 0.0019/))
       Magnetic_j6( 27) = Magnetic_Form_Type("NP5 ",(/-0.1157, 9.565,-0.2654, 4.260, 0.3298, 1.549, 0.0025/))
       Magnetic_j6( 28) = Magnetic_Form_Type("NP6 ",(/-0.0128, 9.569,-0.3611, 4.304, 0.3419, 1.541, 0.0032/))
       Magnetic_j6( 29) = Magnetic_Form_Type("PU3 ",(/-0.0364, 9.572,-0.3181, 4.342, 0.3210, 1.523, 0.0041/))
       Magnetic_j6( 30) = Magnetic_Form_Type("PU4 ",(/-0.2394, 7.837,-0.0785, 4.024, 0.2643, 1.378, 0.0012/))
       Magnetic_j6( 31) = Magnetic_Form_Type("PU5 ",(/-0.1090, 7.819,-0.2243, 4.100, 0.2947, 1.404, 0.0015/))
       Magnetic_j6( 32) = Magnetic_Form_Type("PU6 ",(/-0.0001, 7.820,-0.3354, 4.144, 0.3097, 1.403, 0.0020/))
       Magnetic_j6( 33) = Magnetic_Form_Type("AM2 ",(/-0.3176, 7.864, 0.0771, 4.161, 0.2194, 1.339, 0.0018/))
       Magnetic_j6( 34) = Magnetic_Form_Type("AM3 ",(/-0.3159, 6.982, 0.0682, 3.995, 0.2141, 1.188,-0.0015/))
       Magnetic_j6( 35) = Magnetic_Form_Type("AM4 ",(/-0.1787, 7.880,-0.1274, 4.090, 0.2565, 1.315, 0.0017/))
       Magnetic_j6( 36) = Magnetic_Form_Type("AM5 ",(/-0.0927, 6.073,-0.2227, 3.784, 0.2916, 1.372, 0.0026/))
       Magnetic_j6( 37) = Magnetic_Form_Type("AM6 ",(/ 0.0152, 6.079,-0.3549, 3.861, 0.3125, 1.403, 0.0036/))
       Magnetic_j6( 38) = Magnetic_Form_Type("AM7 ",(/ 0.1292, 6.082,-0.4689, 3.879, 0.3234, 1.393, 0.0042/))
       Magnetic_j6( 39) = Magnetic_Form_Type("PR3 ",(/-0.0224, 7.9931,-0.1202, 3.9406, 0.1299, 0.8938, 0.0051/))

       return
    End Subroutine Set_Magnetic_Form

    !!----
    !!---- Subroutine Set_Xray_Form()
    !!----    Set Xray_Form Array:
    !!--<<
    !!----        1: Symbol of the Element
    !!----        2: Name of the Element
    !!----        3: a(4)
    !!----        4: b(4)
    !!----        5: c
    !!----    Coefficients for calculating the X-ray scattering factors
    !!----        f(s) = Sum_{i=1,4} { a(i) exp(-b(i)*s^2) } + c
    !!----
    !!----    where s=sinTheta/Lambda
    !!-->>
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Set_Xray_Form()

       if (.not. allocated(xray_form)) allocate(xray_form(num_xray_form))

       Xray_form( 1:10) = (/ &
                          xray_form_type("h   ",  1, (/  0.493002,   0.322912,   0.140191,   0.040810/), &
                                                     (/ 10.510900,  26.125700,   3.142360,  57.799698/),  0.003038) , &
                          xray_form_type("h-1 ",  1, (/  0.897661,   0.565616,   0.415815,   0.116973/), &
                                                     (/ 53.136799,  15.187000, 186.575989,   3.567090/),  0.002389) , &
                          xray_form_type("he  ",  2, (/  0.873400,   0.630900,   0.311200,   0.178000/), &
                                                     (/  9.103700,   3.356800,  22.927601,   0.982100/),  0.006400) , &
                          xray_form_type("li  ",  3, (/  1.128200,   0.750800,   0.617500,   0.465300/), &
                                                     (/  3.954600,   1.052400,  85.390503, 168.261002/),  0.037700) , &
                          xray_form_type("li+1",  3, (/  0.696800,   0.788800,   0.341400,   0.156300/), &
                                                     (/  4.623700,   1.955700,   0.631600,  10.095300/),  0.016700) , &
                          xray_form_type("be  ",  4, (/  1.591900,   1.127800,   0.539100,   0.702900/), &
                                                     (/ 43.642700,   1.862300, 103.483002,   0.542000/),  0.038500) , &
                          xray_form_type("be+2",  4, (/  6.260300,   0.884900,   0.799300,   0.164700/), &
                                                     (/  0.002700,   0.831300,   2.275800,   5.114600/), -6.109200) , &
                          xray_form_type("b   ",  5, (/  2.054500,   1.332600,   1.097900,   0.706800/), &
                                                     (/ 23.218500,   1.021000,  60.349800,   0.140300/), -0.193200) , &
                          xray_form_type("c   ",  6, (/  2.310000,   1.020000,   1.588600,   0.865000/), &
                                                     (/ 20.843899,  10.207500,   0.568700,  51.651199/),  0.215600) , &
                          xray_form_type("cv  ",  6, (/  2.260690,   1.561650,   1.050750,   0.839259/), &
                                                     (/ 22.690701,   0.656665,   9.756180,  55.594898/),  0.286977) /)

       Xray_form(11:20) = (/ &
                          xray_form_type("n   ",  7, (/ 12.212600,   3.132200,   2.012500,   1.166300/), &
                                                     (/  0.005700,   9.893300,  28.997499,   0.582600/),-11.528999) , &
                          xray_form_type("o   ",  8, (/  3.048500,   2.286800,   1.546300,   0.867000/), &
                                                     (/ 13.277100,   5.701100,   0.323900,  32.908897/),  0.250800) , &
                          xray_form_type("o-1 ",  8, (/  4.191600,   1.639690,   1.526730, -20.306999/), &
                                                     (/ 12.857300,   4.172360,  47.017899,  -0.014040/), 21.941200) , &
                          xray_form_type("f   ",  9, (/  3.539200,   2.641200,   1.517000,   1.024300/), &
                                                     (/ 10.282499,   4.294400,   0.261500,  26.147600/),  0.277600) , &
                          xray_form_type("f-1 ",  9, (/  3.632200,   3.510570,   1.260640,   0.940706/), &
                                                     (/  5.277560,  14.735300,   0.442258,  47.343700/),  0.653396) , &
                          xray_form_type("ne  ", 10, (/  3.955300,   3.112500,   1.454600,   1.125100/), &
                                                     (/  8.404200,   3.426200,   0.230600,  21.718399/),  0.351500) , &
                          xray_form_type("na  ", 11, (/  4.762600,   3.173600,   1.267400,   1.112800/), &
                                                     (/  3.285000,   8.842199,   0.313600, 129.423996/),  0.676000) , &
                          xray_form_type("na+1", 11, (/  3.256500,   3.936200,   1.399800,   1.003200/), &
                                                     (/  2.667100,   6.115300,   0.200100,  14.039000/),  0.404000) , &
                          xray_form_type("mg  ", 12, (/  5.420400,   2.173500,   1.226900,   2.307300/), &
                                                     (/  2.827500,  79.261101,   0.380800,   7.193700/),  0.858400) , &
                          xray_form_type("mg+2", 12, (/  3.498800,   3.837800,   1.328400,   0.849700/), &
                                                     (/  2.167600,   4.754200,   0.185000,  10.141100/),  0.485300) /)

       Xray_form(21:30) = (/ &
                          xray_form_type("al  ", 13, (/  6.420200,   1.900200,   1.593600,   1.964600/), &
                                                     (/  3.038700,   0.742600,  31.547199,  85.088600/),  1.115100) , &
                          xray_form_type("al+3", 13, (/  4.174480,   3.387600,   1.202960,   0.528137/), &
                                                     (/  1.938160,   4.145530,   0.228753,   8.285240/),  0.706786) , &
                          xray_form_type("si  ", 14, (/  6.291500,   3.035300,   1.989100,   1.541000/), &
                                                     (/  2.438600,  32.333698,   0.678500,  81.693695/),  1.140700) , &
                          xray_form_type("siv ", 14, (/  5.662690,   3.071640,   2.624460,   1.393200/), &
                                                     (/  2.665200,  38.663399,   0.916946,  93.545799/),  1.247070) , &
                          xray_form_type("si+4", 14, (/  4.439180,   3.203450,   1.194530,   0.416530/), &
                                                     (/  1.641670,   3.437570,   0.214900,   6.653650/),  0.746297) , &
                          xray_form_type("p   ", 15, (/  6.434500,   4.179100,   1.780000,   1.490800/), &
                                                     (/  1.906700,  27.157000,   0.526000,  68.164497/),  1.114900) , &
                          xray_form_type("s   ", 16, (/  6.905300,   5.203400,   1.437900,   1.586300/), &
                                                     (/  1.467900,  22.215099,   0.253600,  56.172001/),  0.866900) , &
                          xray_form_type("cl  ", 17, (/ 11.460400,   7.196400,   6.255600,   1.645500/), &
                                                     (/  0.010400,   1.166200,  18.519400,  47.778400/), -9.557400) , &
                          xray_form_type("cl-1", 17, (/ 18.291500,   7.208400,   6.533700,   2.338600/), &
                                                     (/  0.006600,   1.171700,  19.542400,  60.448601/),-16.378000) , &
                          xray_form_type("ar  ", 18, (/  7.484500,   6.772300,   0.653900,   1.644200/), &
                                                     (/  0.907200,  14.840700,  43.898300,  33.392899/),  1.444500) /)

       Xray_form(31:40) = (/ &
                          xray_form_type("k   ", 19, (/  8.218599,   7.439800,   1.051900,   0.865900/), &
                                                     (/ 12.794900,   0.774800, 213.186996,  41.684097/),  1.422800) , &
                          xray_form_type("k+1 ", 19, (/  7.957800,   7.491700,   6.359000,   1.191500/), &
                                                     (/ 12.633100,   0.767400,  -0.002000,  31.912800/), -4.997800) , &
                          xray_form_type("ca  ", 20, (/  8.626600,   7.387300,   1.589900,   1.021100/), &
                                                     (/ 10.442100,   0.659900,  85.748398, 178.436996/),  1.375100) , &
                          xray_form_type("ca+2", 20, (/ 15.634800,   7.951800,   8.437200,   0.853700/), &
                                                     (/ -0.007400,   0.608900,  10.311600,  25.990499/),-14.875000) , &
                          xray_form_type("sc  ", 21, (/  9.189000,   7.367900,   1.640900,   1.468000/), &
                                                     (/  9.021299,   0.572900, 136.108002,  51.353100/),  1.332900) , &
                          xray_form_type("sc+3", 21, (/ 14.400800,   8.027300,   1.659430,   1.579360/), &
                                                     (/  0.298540,   7.962900,  -0.286040,  16.066200/), -6.666700) , &
                          xray_form_type("ti  ", 22, (/  9.759500,   7.355800,   1.699100,   1.902100/), &
                                                     (/  7.850800,   0.500000,  35.633801, 116.104996/),  1.280700) , &
                          xray_form_type("ti+2", 22, (/  9.114230,   7.621740,   2.279300,   0.087899/), &
                                                     (/  7.524300,   0.457585,  19.536100,  61.655800/),  0.897155) , &
                          xray_form_type("ti+3", 22, (/ 17.734400,   8.738160,   5.256910,   1.921340/), &
                                                     (/  0.220610,   7.047160,  -0.157620,  15.976800/),-14.652000) , &
                          xray_form_type("ti+4", 22, (/ 19.511400,   8.234730,   2.013410,   1.520800/), &
                                                     (/  0.178847,   6.670180,  -0.292630,  12.946400/),-13.280000) /)

       Xray_form(41:50) = (/ &
                          xray_form_type("v   ", 23, (/ 10.297100,   7.351100,   2.070300,   2.057100/), &
                                                     (/  6.865700,   0.438500,  26.893799, 102.477997/),  1.219900) , &
                          xray_form_type("v+2 ", 23, (/ 10.106000,   7.354100,   2.288400,   0.022300/), &
                                                     (/  6.881800,   0.440900,  20.300400, 115.122002/),  1.229800) , &
                          xray_form_type("v+3 ", 23, (/  9.431410,   7.741900,   2.153430,   0.016865/), &
                                                     (/  6.395350,   0.383349,  15.190800,  63.969002/),  0.656565) , &
                          xray_form_type("v+5 ", 23, (/ 15.688700,   8.142080,   2.030810,  -9.576000/), &
                                                     (/  0.679003,   5.401350,   9.972780,   0.940464/),  1.714300) , &
                          xray_form_type("cr  ", 24, (/ 10.640600,   7.353700,   3.324000,   1.492200/), &
                                                     (/  6.103800,   0.392000,  20.262600,  98.739899/),  1.183200) , &
                          xray_form_type("cr+2", 24, (/  9.540340,   7.750900,   3.582740,   0.509107/), &
                                                     (/  5.660780,   0.344261,  13.307500,  32.422401/),  0.616898) , &
                          xray_form_type("cr+3", 24, (/  9.680900,   7.811360,   2.876030,   0.113575/), &
                                                     (/  5.594630,   0.334393,  12.828800,  32.876099/),  0.518275) , &
                          xray_form_type("mn  ", 25, (/ 11.281900,   7.357300,   3.019300,   2.244100/), &
                                                     (/  5.340900,   0.343200,  17.867399,  83.754303/),  1.089600) , &
                          xray_form_type("mn+2", 25, (/ 10.806100,   7.362000,   3.526800,   0.218400/), &
                                                     (/  5.279600,   0.343500,  14.343000,  41.323502/),  1.087400) , &
                          xray_form_type("mn+3", 25, (/  9.845210,   7.871940,   3.565310,   0.323613/), &
                                                     (/  4.917970,   0.294393,  10.817100,  24.128099/),  0.393974) /)

       Xray_form(51:60) = (/ &
                          xray_form_type("mn+4", 25, (/  9.962530,   7.970570,   2.760670,   0.054447/), &
                                                     (/  4.848500,   0.283303,  10.485200,  27.573000/),  0.251877) , &
                          xray_form_type("fe  ", 26, (/ 11.769500,   7.357300,   3.522200,   2.304500/), &
                                                     (/  4.761100,   0.307200,  15.353500,  76.880501/),  1.036900) , &
                          xray_form_type("fe+2", 26, (/ 11.042400,   7.374000,   4.134600,   0.439900/), &
                                                     (/  4.653800,   0.305300,  12.054600,  31.280899/),  1.009700) , &
                          xray_form_type("fe+3", 26, (/ 11.176400,   7.386300,   3.394800,   0.072400/), &
                                                     (/  4.614700,   0.300500,  11.672900,  38.556599/),  0.970700) , &
                          xray_form_type("co  ", 27, (/ 12.284100,   7.340900,   4.003400,   2.348800/), &
                                                     (/  4.279100,   0.278400,  13.535900,  71.169197/),  1.011800) , &
                          xray_form_type("co+2", 27, (/ 11.229600,   7.388300,   4.739300,   0.710800/), &
                                                     (/  4.123100,   0.272600,  10.244300,  25.646599/),  0.932400) , &
                          xray_form_type("co+3", 27, (/ 10.337999,   7.881730,   4.767950,   0.725591/), &
                                                     (/  3.909690,   0.238668,   8.355830,  18.349100/),  0.286667) , &
                          xray_form_type("ni  ", 28, (/ 12.837600,   7.292000,   4.443800,   2.380000/), &
                                                     (/  3.878500,   0.256500,  12.176300,  66.342102/),  1.034100) , &
                          xray_form_type("ni+2", 28, (/ 11.416600,   7.400500,   5.344200,   0.977300/), &
                                                     (/  3.676600,   0.244900,   8.873000,  22.162600/),  0.861400) , &
                          xray_form_type("ni+3", 28, (/ 10.780600,   7.758680,   5.227460,   0.847114/), &
                                                     (/  3.547700,   0.223140,   7.644680,  16.967300/),  0.386044) /)

       Xray_form(61:70) = (/ &
                          xray_form_type("cu  ", 29, (/ 13.337999,   7.167600,   5.615800,   1.673500/), &
                                                     (/  3.582800,   0.247000,  11.396600,  64.812599/),  1.191000) , &
                          xray_form_type("cu+1", 29, (/ 11.947500,   7.357300,   6.245500,   1.557800/), &
                                                     (/  3.366900,   0.227400,   8.662500,  25.848700/),  0.890000) , &
                          xray_form_type("cu+2", 29, (/ 11.816800,   7.111810,   5.781350,   1.145230/), &
                                                     (/  3.374840,   0.244078,   7.987600,  19.896999/),  1.144310) , &
                          xray_form_type("zn  ", 30, (/ 14.074300,   7.031800,   5.162500,   2.410000/), &
                                                     (/  3.265500,   0.233300,  10.316299,  58.709702/),  1.304100) , &
                          xray_form_type("zn+2", 30, (/ 11.971900,   7.386200,   6.466800,   1.394000/), &
                                                     (/  2.994600,   0.203100,   7.082600,  18.099499/),  0.780700) , &
                          xray_form_type("ga  ", 31, (/ 15.235400,   6.700600,   4.359100,   2.962300/), &
                                                     (/  3.066900,   0.241200,  10.780500,  61.413498/),  1.718900) , &
                          xray_form_type("ga+3", 31, (/ 12.691999,   6.698830,   6.066920,   1.006600/), &
                                                     (/  2.812620,   0.227890,   6.364410,  14.412200/),  1.535450) , &
                          xray_form_type("ge  ", 32, (/ 16.081600,   6.374700,   3.706800,   3.683000/), &
                                                     (/  2.850900,   0.251600,  11.446800,  54.762501/),  2.131300) , &
                          xray_form_type("ge+4", 32, (/ 12.917200,   6.700030,   6.067910,   0.859041/), &
                                                     (/  2.537180,   0.205855,   5.479130,  11.603000/),  1.455720) , &
                          xray_form_type("as  ", 33, (/ 16.672300,   6.070100,   3.431300,   4.277900/), &
                                                     (/  2.634500,   0.264700,  12.947900,  47.797199/),  2.531000) /)

       Xray_form(71:80) = (/ &
                          xray_form_type("se  ", 34, (/ 17.000599,   5.819600,   3.973100,   4.354300/), &
                                                     (/  2.409800,   0.272600,  15.237200,  43.816299/),  2.840900) , &
                          xray_form_type("br  ", 35, (/ 17.178900,   5.235800,   5.637700,   3.985100/), &
                                                     (/  2.172300,  16.579599,   0.260900,  41.432800/),  2.955700) , &
                          xray_form_type("br-1", 35, (/ 17.171799,   6.333800,   5.575400,   3.727200/), &
                                                     (/  2.205900,  19.334499,   0.287100,  58.153500/),  3.177600) , &
                          xray_form_type("kr  ", 36, (/ 17.355499,   6.728600,   5.549300,   3.537500/), &
                                                     (/  1.938400,  16.562300,   0.226100,  39.397202/),  2.825000) , &
                          xray_form_type("rb  ", 37, (/ 17.178400,   9.643499,   5.139900,   1.529200/), &
                                                     (/  1.788800,  17.315100,   0.274800, 164.933990/),  3.487300) , &
                          xray_form_type("rb+1", 37, (/ 17.581600,   7.659800,   5.898100,   2.781700/), &
                                                     (/  1.713900,  14.795700,   0.160300,  31.208700/),  2.078200) , &
                          xray_form_type("sr  ", 38, (/ 17.566299,   9.818399,   5.422000,   2.669400/), &
                                                     (/  1.556400,  14.098800,   0.166400, 132.376007/),  2.506400) , &
                          xray_form_type("sr+2", 38, (/ 18.087400,   8.137300,   2.565400, -34.193001/), &
                                                     (/  1.490700,  12.696300,  24.565100,  -0.013800/), 41.402500) , &
                          xray_form_type("y   ", 39, (/ 17.775999,  10.294600,   5.726290,   3.265880/), &
                                                     (/  1.402900,  12.800600,   0.125599, 104.353996/),  1.912130) , &
                          xray_form_type("y+3 ", 39, (/ 17.926800,   9.153100,   1.767950, -33.108002/), &
                                                     (/  1.354170,  11.214500,  22.659901,  -0.013190/), 40.260201) /)

       Xray_form(81:90) = (/ &
                          xray_form_type("zr  ", 40, (/ 17.876499,  10.948000,   5.417320,   3.657210/), &
                                                     (/  1.276180,  11.916000,   0.117622,  87.662697/),  2.069290) , &
                          xray_form_type("zr+4", 40, (/ 18.166800,  10.056200,   1.011180,  -2.647900/), &
                                                     (/  1.214800,  10.148300,  21.605400,  -0.102760/),  9.414539) , &
                          xray_form_type("nb  ", 41, (/ 17.614201,  12.014400,   4.041830,   3.533460/), &
                                                     (/  1.188650,  11.766000,   0.204785,  69.795700/),  3.755910) , &
                          xray_form_type("nb+3", 41, (/ 19.881199,  18.065300,  11.017700,   1.947150/), &
                                                     (/  0.019175,   1.133050,  10.162100,  28.338900/),-12.912000) , &
                          xray_form_type("nb+5", 41, (/ 17.916300,  13.341700,  10.799000,   0.337905/), &
                                                     (/  1.124460,   0.028781,   9.282060,  25.722799/), -6.393400) , &
                          xray_form_type("mo  ", 42, (/  3.702500,  17.235600,  12.887600,   3.742900/), &
                                                     (/  0.277200,   1.095800,  11.004000,  61.658401/),  4.387500) , &
                          xray_form_type("mo+3", 42, (/ 21.166401,  18.201700,  11.742300,   2.309510/), &
                                                     (/  0.014734,   1.030310,   9.536590,  26.630699/),-14.421000) , &
                          xray_form_type("mo+5", 42, (/ 21.014900,  18.099199,  11.463200,   0.740625/), &
                                                     (/  0.014345,   1.022380,   8.788090,  23.345200/),-14.316000) , &
                          xray_form_type("mo+6", 42, (/ 17.887100,  11.175000,   6.578910,   0.000000/), &
                                                     (/  1.036490,   8.480610,   0.058881,   0.000000/),  0.344941) , &
                          xray_form_type("tc  ", 43, (/ 19.130100,  11.094800,   4.649010,   2.712630/), &
                                                     (/  0.864132,   8.144870,  21.570700,  86.847198/),  5.404280) /)

       Xray_form(91:100)= (/ &
                          xray_form_type("ru  ", 44, (/ 19.267399,  12.918200,   4.863370,   1.567560/), &
                                                     (/  0.808520,   8.434669,  24.799700,  94.292801/),  5.378740) , &
                          xray_form_type("ru+3", 44, (/ 18.563801,  13.288500,   9.326019,   3.009640/), &
                                                     (/  0.847329,   8.371640,   0.017662,  22.886999/), -3.189200) , &
                          xray_form_type("ru+4", 44, (/ 18.500299,  13.178699,   4.713040,   2.185350/), &
                                                     (/  0.844582,   8.125340,   0.364950,  20.850399/),  1.423570) , &
                          xray_form_type("rh  ", 45, (/ 19.295700,  14.350100,   4.734250,   1.289180/), &
                                                     (/  0.751536,   8.217580,  25.874901,  98.606201/),  5.328000) , &
                          xray_form_type("rh+3", 45, (/ 18.878500,  14.125900,   3.325150,  -6.198900/), &
                                                     (/  0.764252,   7.844380,  21.248699,  -0.010360/), 11.867800) , &
                          xray_form_type("rh+4", 45, (/ 18.854500,  13.980600,   2.534640,  -5.652600/), &
                                                     (/  0.760825,   7.624360,  19.331699,  -0.010200/), 11.283500) , &
                          xray_form_type("pd  ", 46, (/ 19.331900,  15.501699,   5.295370,   0.605844/), &
                                                     (/  0.698655,   7.989290,  25.205200,  76.898598/),  5.265930) , &
                          xray_form_type("pd+2", 46, (/ 19.170099,  15.209600,   4.322340,   0.000000/), &
                                                     (/  0.696219,   7.555730,  22.505699,   0.000000/),  5.291600) , &
                          xray_form_type("pd+4", 46, (/ 19.249300,  14.790000,   2.892890,  -7.949200/), &
                                                     (/  0.683839,   7.148330,  17.914400,   0.005127/), 13.017400) , &
                          xray_form_type("ag  ", 47, (/ 19.280800,  16.688499,   4.804500,   1.046300/), &
                                                     (/  0.644600,   7.472600,  24.660500,  99.815598/),  5.179000) /)

       Xray_form(101:110)=(/ &
                          xray_form_type("ag+1", 47, (/ 19.181200,  15.971900,   5.274750,   0.357534/), &
                                                     (/  0.646179,   7.191230,  21.732599,  66.114700/),  5.215720) , &
                          xray_form_type("ag+2", 47, (/ 19.164299,  16.245600,   4.370900,   0.000000/), &
                                                     (/  0.645643,   7.185440,  21.407200,   0.000000/),  5.214040) , &
                          xray_form_type("cd  ", 48, (/ 19.221399,  17.644400,   4.461000,   1.602900/), &
                                                     (/  0.594600,   6.908900,  24.700800,  87.482498/),  5.069400) , &
                          xray_form_type("cd+2", 48, (/ 19.151400,  17.253500,   4.471280,   0.000000/), &
                                                     (/  0.597922,   6.806390,  20.252100,   0.000000/),  5.119370) , &
                          xray_form_type("in  ", 49, (/ 19.162399,  18.559601,   4.294800,   2.039600/), &
                                                     (/  0.547600,   6.377600,  25.849899,  92.802902/),  4.939100) , &
                          xray_form_type("in+3", 49, (/ 19.104500,  18.110800,   3.788970,   0.000000/), &
                                                     (/  0.551522,   6.324700,  17.359501,   0.000000/),  4.996350) , &
                          xray_form_type("sn  ", 50, (/ 19.188900,  19.100500,   4.458500,   2.466300/), &
                                                     (/  5.830300,   0.503100,  26.890900,  83.957100/),  4.782100) , &
                          xray_form_type("sn+2", 50, (/ 19.109400,  19.054800,   4.564800,   0.487000/), &
                                                     (/  0.503600,   5.837800,  23.375200,  62.206100/),  4.786100) , &
                          xray_form_type("sn+4", 50, (/ 18.933300,  19.713100,   3.418200,   0.019300/), &
                                                     (/  5.764000,   0.465500,  14.004900,  -0.758300/),  3.918200) , &
                          xray_form_type("sb  ", 51, (/ 19.641800,  19.045500,   5.037100,   2.682700/), &
                                                     (/  5.303400,   0.460700,  27.907400,  75.282501/),  4.590900) /)

       Xray_form(111:120)=(/ &
                          xray_form_type("sb+3", 51, (/ 18.975500,  18.932999,   5.107890,   0.288753/), &
                                                     (/  0.467196,   5.221260,  19.590200,  55.511299/),  4.696260) , &
                          xray_form_type("sb+5", 51, (/ 19.868500,  19.030199,   2.412530,   0.000000/), &
                                                     (/  5.448530,   0.467973,  14.125900,   0.000000/),  4.692630) , &
                          xray_form_type("te  ", 52, (/ 19.964399,  19.013800,   6.144870,   2.523900/), &
                                                     (/  4.817420,   0.420885,  28.528400,  70.840302/),  4.352000) , &
                          xray_form_type("i   ", 53, (/ 20.147200,  18.994900,   7.513800,   2.273500/), &
                                                     (/  4.347000,   0.381400,  27.765999,  66.877602/),  4.071200) , &
                          xray_form_type("i-1 ", 53, (/ 20.233200,  18.997000,   7.806900,   2.886800/), &
                                                     (/  4.357900,   0.381500,  29.525900,  84.930397/),  4.071400) , &
                          xray_form_type("xe  ", 54, (/ 20.293301,  19.029800,   8.976700,   1.990000/), &
                                                     (/  3.928200,   0.344000,  26.465900,  64.265800/),  3.711800) , &
                          xray_form_type("cs  ", 55, (/ 20.389200,  19.106199,  10.662000,   1.495300/), &
                                                     (/  3.569000,   0.310700,  24.387899, 213.903992/),  3.335200) , &
                          xray_form_type("cs+1", 55, (/ 20.352400,  19.127800,  10.282100,   0.961500/), &
                                                     (/  3.552000,   0.308600,  23.712799,  59.456497/),  3.279100) , &
                          xray_form_type("ba  ", 56, (/ 20.336100,  19.297001,  10.888000,   2.695900/), &
                                                     (/  3.216000,   0.275600,  20.207300, 167.201996/),  2.773100) , &
                          xray_form_type("ba+2", 56, (/ 20.180700,  19.113600,  10.905399,   0.776340/), &
                                                     (/  3.213670,   0.283310,  20.055799,  51.745998/),  3.029020) /)

       Xray_form(121:130)=(/ &
                          xray_form_type("la  ", 57, (/ 20.577999,  19.598999,  11.372700,   3.287190/), &
                                                     (/  2.948170,   0.244475,  18.772600, 133.123993/),  2.146780) , &
                          xray_form_type("la+3", 57, (/ 20.248899,  19.376301,  11.632299,   0.336048/), &
                                                     (/  2.920700,   0.250698,  17.821100,  54.945297/),  2.408600) , &
                          xray_form_type("ce  ", 58, (/ 21.167099,  19.769501,  11.851299,   3.330490/), &
                                                     (/  2.812190,   0.226836,  17.608299, 127.112999/),  1.862640) , &
                          xray_form_type("ce+3", 58, (/ 20.803600,  19.559000,  11.936900,   0.612376/), &
                                                     (/  2.776910,   0.231540,  16.540800,  43.169201/),  2.090130) , &
                          xray_form_type("ce+4", 58, (/ 20.323500,  19.818600,  12.123300,   0.144583/), &
                                                     (/  2.659410,   0.218850,  15.799200,  62.235500/),  1.591800) , &
                          xray_form_type("pr  ", 59, (/ 22.043999,  19.669701,  12.385600,   2.824280/), &
                                                     (/  2.773930,   0.222087,  16.766899, 143.643997/),  2.058300) , &
                          xray_form_type("pr+3", 59, (/ 21.372700,  19.749100,  12.132900,   0.975180/), &
                                                     (/  2.645200,   0.214299,  15.323000,  36.406502/),  1.771320) , &
                          xray_form_type("pr+4", 59, (/ 20.941299,  20.053900,  12.466800,   0.296689/), &
                                                     (/  2.544670,   0.202481,  14.813700,  45.464298/),  1.242850) , &
                          xray_form_type("nd  ", 60, (/ 22.684500,  19.684700,  12.774000,   2.851370/), &
                                                     (/  2.662480,   0.210628,  15.885000, 137.903000/),  1.984860) , &
                          xray_form_type("nd+3", 60, (/ 21.961000,  19.933899,  12.120000,   1.510310/), &
                                                     (/  2.527220,   0.199237,  14.178300,  30.871700/),  1.475880) /)

       Xray_form(131:140)=(/ &
                          xray_form_type("pm  ", 61, (/ 23.340500,  19.609501,  13.123500,   2.875160/), &
                                                     (/  2.562700,   0.202088,  15.100900, 132.720993/),  2.028760) , &
                          xray_form_type("pm+3", 61, (/ 22.552700,  20.110800,  12.067100,   2.074920/), &
                                                     (/  2.417400,   0.185769,  13.127500,  27.449100/),  1.194990) , &
                          xray_form_type("sm  ", 62, (/ 24.004200,  19.425800,  13.439600,   2.896040/), &
                                                     (/  2.472740,   0.196451,  14.399600, 128.007004/),  2.209630) , &
                          xray_form_type("sm+3", 62, (/ 23.150400,  20.259899,  11.920200,   2.714880/), &
                                                     (/  2.316410,   0.174081,  12.157100,  24.824200/),  0.954586) , &
                          xray_form_type("eu  ", 63, (/ 24.627399,  19.088600,  13.760300,   2.922700/), &
                                                     (/  2.387900,   0.194200,  13.754600, 123.173996/),  2.574500) , &
                          xray_form_type("eu+2", 63, (/ 24.006300,  19.950399,  11.803400,   3.872430/), &
                                                     (/  2.277830,   0.173530,  11.609600,  26.515600/),  1.363890) , &
                          xray_form_type("eu+3", 63, (/ 23.749699,  20.374500,  11.850900,   3.265030/), &
                                                     (/  2.222580,   0.163940,  11.311000,  22.996599/),  0.759344) , &
                          xray_form_type("gd  ", 64, (/ 25.070900,  19.079800,  13.851800,   3.545450/), &
                                                     (/  2.253410,   0.181951,  12.933100, 101.397995/),  2.419600) , &
                          xray_form_type("gd+3", 64, (/ 24.346600,  20.420799,  11.870800,   3.714900/), &
                                                     (/  2.135530,   0.155525,  10.578199,  21.702900/),  0.645089) , &
                          xray_form_type("tb  ", 65, (/ 25.897600,  18.218500,  14.316700,   2.953540/), &
                                                     (/  2.242560,   0.196143,  12.664800, 115.362000/),  3.582240) /)

       Xray_form(141:150)=(/ &
                          xray_form_type("tb+3", 65, (/ 24.955900,  20.327099,  12.247100,   3.773000/), &
                                                     (/  2.056010,   0.149525,  10.049900,  21.277300/),  0.691967) , &
                          xray_form_type("dy  ", 66, (/ 26.507000,  17.638300,  14.559600,   2.965770/), &
                                                     (/  2.180200,   0.202172,  12.189899, 111.874001/),  4.297280) , &
                          xray_form_type("dy+3", 66, (/ 25.539499,  20.286100,  11.981200,   4.500730/), &
                                                     (/  1.980400,   0.143384,   9.349720,  19.580999/),  0.689690) , &
                          xray_form_type("ho  ", 67, (/ 26.904900,  17.293999,  14.558300,   3.638370/), &
                                                     (/  2.070510,   0.197940,  11.440700,  92.656601/),  4.567960) , &
                          xray_form_type("ho+3", 67, (/ 26.129601,  20.099400,  11.978800,   4.936760/), &
                                                     (/  1.910720,   0.139358,   8.800180,  18.590799/),  0.852795) , &
                          xray_form_type("er  ", 68, (/ 27.656300,  16.428499,  14.977900,   2.982330/), &
                                                     (/  2.073560,   0.223545,  11.360400, 105.703003/),  5.920460) , &
                          xray_form_type("er+3", 68, (/ 26.722000,  19.774799,  12.150600,   5.173790/), &
                                                     (/  1.846590,   0.137290,   8.362249,  17.897400/),  1.176130) , &
                          xray_form_type("tm  ", 69, (/ 28.181900,  15.885099,  15.154200,   2.987060/), &
                                                     (/  2.028590,   0.238849,  10.997499, 102.960999/),  6.756210) , &
                          xray_form_type("tm+3", 69, (/ 27.308300,  19.332001,  12.333900,   5.383480/), &
                                                     (/  1.787110,   0.136974,   7.967780,  17.292200/),  1.639290) , &
                          xray_form_type("yb  ", 70, (/ 28.664101,  15.434500,  15.308700,   2.989630/), &
                                                     (/  1.988900,   0.257119,  10.664700, 100.417000/),  7.566720) /)

       Xray_form(151:160)=(/ &
                          xray_form_type("yb+2", 70, (/ 28.120899,  17.681700,  13.333500,   5.146570/), &
                                                     (/  1.785030,   0.159970,   8.183040,  20.389999/),  3.709830) , &
                          xray_form_type("yb+3", 70, (/ 27.891701,  18.761400,  12.607200,   5.476470/), &
                                                     (/  1.732720,   0.138790,   7.644120,  16.815300/),  2.260010) , &
                          xray_form_type("lu  ", 71, (/ 28.947599,  15.220800,  15.100000,   3.716010/), &
                                                     (/  1.901820,   9.985189,   0.261033,  84.329803/),  7.976280) , &
                          xray_form_type("lu+3", 71, (/ 28.462799,  18.121000,  12.842899,   5.594150/), &
                                                     (/  1.682160,   0.142292,   7.337270,  16.353500/),  2.975730) , &
                          xray_form_type("hf  ", 72, (/ 29.143999,  15.172600,  14.758600,   4.300130/), &
                                                     (/  1.832620,   9.599899,   0.275116,  72.028999/),  8.581540) , &
                          xray_form_type("hf+4", 72, (/ 28.813099,  18.460100,  12.728500,   5.599270/), &
                                                     (/  1.591360,   0.128903,   6.762320,  14.036600/),  2.396990) , &
                          xray_form_type("ta  ", 73, (/ 29.202400,  15.229300,  14.513500,   4.764920/), &
                                                     (/  1.773330,   9.370460,   0.295977,  63.364399/),  9.243540) , &
                          xray_form_type("ta+5", 73, (/ 29.158699,  18.840700,  12.826799,   5.386950/), &
                                                     (/  1.507110,   0.116741,   6.315240,  12.424400/),  1.785550) , &
                          xray_form_type("w   ", 74, (/ 29.081800,  15.430000,  14.432700,   5.119820/), &
                                                     (/  1.720290,   9.225900,   0.321703,  57.056000/),  9.887500) , &
                          xray_form_type("w+6 ", 74, (/ 29.493599,  19.376301,  13.054399,   5.064120/), &
                                                     (/  1.427550,   0.104621,   5.936670,  11.197200/),  1.010740) /)

       Xray_form(161:170)=(/ &
                          xray_form_type("re  ", 75, (/ 28.762100,  15.718900,  14.556400,   5.441740/), &
                                                     (/  1.671910,   9.092270,   0.350500,  52.086098/), 10.472000) , &
                          xray_form_type("os  ", 76, (/ 28.189400,  16.154999,  14.930500,   5.675890/), &
                                                     (/  1.629030,   8.979480,   0.382661,  48.164700/), 11.000500) , &
                          xray_form_type("os+4", 76, (/ 30.418999,  15.263700,  14.745800,   5.067950/), &
                                                     (/  1.371130,   6.847060,   0.165191,  18.003000/),  6.498040) , &
                          xray_form_type("ir  ", 77, (/ 27.304899,  16.729599,  15.611500,   5.833770/), &
                                                     (/  1.592790,   8.865530,   0.417916,  45.001099/), 11.472200) , &
                          xray_form_type("ir+3", 77, (/ 30.415600,  15.862000,  13.614500,   5.820080/), &
                                                     (/  1.343230,   7.109090,   0.204633,  20.325399/),  8.279030) , &
                          xray_form_type("ir+4", 77, (/ 30.705799,  15.551200,  14.232600,   5.536720/), &
                                                     (/  1.309230,   6.719830,   0.167252,  17.491100/),  6.968240) , &
                          xray_form_type("pt  ", 78, (/ 27.005899,  17.763901,  15.713100,   5.783700/), &
                                                     (/  1.512930,   8.811740,   0.424593,  38.610298/), 11.688300) , &
                          xray_form_type("pt+2", 78, (/ 29.842899,  16.722401,  13.215300,   6.352340/), &
                                                     (/  1.329270,   7.389790,   0.263297,  22.942600/),  9.853290) , &
                          xray_form_type("pt+4", 78, (/ 30.961201,  15.982900,  13.734800,   5.920340/), &
                                                     (/  1.248130,   6.608340,   0.168640,  16.939199/),  7.395340) , &
                          xray_form_type("au  ", 79, (/ 16.881901,  18.591299,  25.558201,   5.860000/), &
                                                     (/  0.461100,   8.621600,   1.482600,  36.395599/), 12.065800) /)

       Xray_form(171:180)=(/ &
                          xray_form_type("au+1", 79, (/ 28.010899,  17.820400,  14.335899,   6.580770/), &
                                                     (/  1.353210,   7.739500,   0.356752,  26.404301/), 11.229900) , &
                          xray_form_type("au+3", 79, (/ 30.688599,  16.902901,  12.780100,   6.523540/), &
                                                     (/  1.219900,   6.828720,   0.212867,  18.659000/),  9.096800) , &
                          xray_form_type("hg  ", 80, (/ 20.680901,  19.041700,  21.657499,   5.967600/), &
                                                     (/  0.545000,   8.448400,   1.572900,  38.324600/), 12.608900) , &
                          xray_form_type("hg+1", 80, (/ 25.085300,  18.497299,  16.888300,   6.482160/), &
                                                     (/  1.395070,   7.651050,   0.443378,  28.226200/), 12.020500) , &
                          xray_form_type("hg+2", 80, (/ 29.564100,  18.059999,  12.837400,   6.899120/), &
                                                     (/  1.211520,   7.056390,   0.284738,  20.748199/), 10.626800) , &
                          xray_form_type("tl  ", 81, (/ 27.544600,  19.158400,  15.538000,   5.525930/), &
                                                     (/  0.655150,   8.707510,   1.963470,  45.814899/), 13.174600) , &
                          xray_form_type("tl+1", 81, (/ 21.398500,  20.472300,  18.747799,   6.828470/), &
                                                     (/  1.471100,   0.517394,   7.434630,  28.848200/), 12.525800) , &
                          xray_form_type("tl+3", 81, (/ 30.869499,  18.384100,  11.932800,   7.005740/), &
                                                     (/  1.100800,   6.538520,   0.219074,  17.211399/),  9.802700) , &
                          xray_form_type("pb  ", 82, (/ 31.061699,  13.063700,  18.441999,   5.969600/), &
                                                     (/  0.690200,   2.357600,   8.618000,  47.257900/), 13.411800) , &
                          xray_form_type("pb+2", 82, (/ 21.788601,  19.568199,  19.140600,   7.011070/), &
                                                     (/  1.336600,   0.488383,   6.772700,  23.813200/), 12.473400) /)

       Xray_form(181:190)=(/ &
                          xray_form_type("pb+4", 82, (/ 32.124397,  18.800301,  12.017500,   6.968860/), &
                                                     (/  1.005660,   6.109260,   0.147041,  14.714000/),  8.084280) , &
                          xray_form_type("bi  ", 83, (/ 33.368900,  12.951000,  16.587700,   6.469200/), &
                                                     (/  0.704000,   2.923800,   8.793700,  48.009300/), 13.578199) , &
                          xray_form_type("bi+3", 83, (/ 21.805300,  19.502600,  19.105301,   7.102950/), &
                                                     (/  1.235600,   6.241490,   0.469999,  20.318501/), 12.471100) , &
                          xray_form_type("bi+5", 83, (/ 33.536400,  25.094601,  19.249699,   6.915550/), &
                                                     (/  0.916540,   0.390420,   5.714140,  12.828500/), -6.799400) , &
                          xray_form_type("po  ", 84, (/ 34.672600,  15.473300,  13.113800,   7.025880/), &
                                                     (/  0.700999,   3.550780,   9.556419,  47.004501/), 13.677000) , &
                          xray_form_type("at  ", 85, (/ 35.316299,  19.021099,   9.498870,   7.425180/), &
                                                     (/  0.685870,   3.974580,  11.382400,  45.471500/), 13.710800) , &
                          xray_form_type("rn  ", 86, (/ 35.563099,  21.281601,   8.003700,   7.443300/), &
                                                     (/  0.663100,   4.069100,  14.042200,  44.247299/), 13.690500) , &
                          xray_form_type("fr  ", 87, (/ 35.929901,  23.054699,  12.143900,   2.112530/), &
                                                     (/  0.646453,   4.176190,  23.105200, 150.644989/), 13.724700) , &
                          xray_form_type("ra  ", 88, (/ 35.763000,  22.906399,  12.473900,   3.210970/), &
                                                     (/  0.616341,   3.871350,  19.988701, 142.324997/), 13.621099) , &
                          xray_form_type("ra+2", 88, (/ 35.215000,  21.670000,   7.913420,   7.650780/), &
                                                     (/  0.604909,   3.576700,  12.601000,  29.843599/), 13.543100) /)

       Xray_form(191:200)=(/ &
                          xray_form_type("ac  ", 89, (/ 35.659698,  23.103199,  12.597700,   4.086550/), &
                                                     (/  0.589092,   3.651550,  18.598999, 117.019997/), 13.526600) , &
                          xray_form_type("ac+3", 89, (/ 35.173599,  22.111200,   8.192160,   7.055450/), &
                                                     (/  0.579689,   3.414370,  12.918700,  25.944300/), 13.463699) , &
                          xray_form_type("th  ", 90, (/ 35.564499,  23.421900,  12.747300,   4.807030/), &
                                                     (/  0.563359,   3.462040,  17.830900,  99.172195/), 13.431400) , &
                          xray_form_type("th+4", 90, (/ 35.100700,  22.441799,   9.785540,   5.294440/), &
                                                     (/  0.555054,   3.244980,  13.466100,  23.953300/), 13.375999) , &
                          xray_form_type("pa  ", 91, (/ 35.884701,  23.294800,  14.189100,   4.172870/), &
                                                     (/  0.547751,   3.415190,  16.923500, 105.250999/), 13.428699) , &
                          xray_form_type("u   ", 92, (/ 36.022800,  23.412800,  14.949100,   4.188000/), &
                                                     (/  0.529300,   3.325300,  16.092699, 100.612999/), 13.396600) , &
                          xray_form_type("u+3 ", 92, (/ 35.574699,  22.525900,  12.216499,   5.370730/), &
                                                     (/  0.520480,   3.122930,  12.714800,  26.339399/), 13.309200) , &
                          xray_form_type("u+4 ", 92, (/ 35.371498,  22.532600,  12.029100,   4.798400/), &
                                                    (/  0.516598,   3.050530,  12.572300,  23.458200/), 13.267099) , &
                          xray_form_type("u+6 ", 92, (/ 34.850899,  22.758400,  14.009900,   1.214570/), &
                                                     (/  0.507079,   2.890300,  13.176700,  25.201700/), 13.166500) , &
                          xray_form_type("np  ", 93, (/ 36.187401,  23.596399,  15.640200,   4.185500/), &
                                                     (/  0.511929,   3.253960,  15.362200,  97.490799/), 13.357300) /)

       Xray_form(201:210)=(/ &
                          xray_form_type("np+3", 93, (/ 35.707397,  22.612999,  12.989799,   5.432270/), &
                                                     (/  0.502322,   3.038070,  12.144899,  25.492800/), 13.254400) , &
                          xray_form_type("np+4", 93, (/ 35.510300,  22.578699,  12.776600,   4.921590/), &
                                                     (/  0.498626,   2.966270,  11.948400,  22.750200/), 13.211599) , &
                          xray_form_type("np+6", 93, (/ 35.013599,  22.728600,  14.388400,   1.756690/), &
                                                     (/  0.489810,   2.810990,  12.330000,  22.658100/), 13.113000) , &
                          xray_form_type("pu  ", 94, (/ 36.525398,  23.808300,  16.770700,   3.479470/), &
                                                     (/  0.499384,   3.263710,  14.945499, 105.979996/), 13.381200) , &
                          xray_form_type("pu+3", 94, (/ 35.840000,  22.716900,  13.580700,   5.660160/), &
                                                    (/  0.484936,   2.961180,  11.533100,  24.399200/), 13.199100) , &
                          xray_form_type("pu+4", 94, (/ 35.649300,  22.646000,  13.359500,   5.188310/), &
                                                     (/  0.481422,   2.890200,  11.316000,  21.830099/), 13.155500) , &
                          xray_form_type("pu+6", 94, (/ 35.173599,  22.718100,  14.763500,   2.286780/), &
                                                     (/  0.473204,   2.738480,  11.552999,  20.930300/), 13.058200) , &
                          xray_form_type("am  ", 95, (/ 36.670601,  24.099199,  17.341499,   3.493310/), &
                                                     (/  0.483629,   3.206470,  14.313600, 102.272995/), 13.359200) , &
                          xray_form_type("cm  ", 96, (/ 36.648800,  24.409599,  17.399000,   4.216650/), &
                                                     (/  0.465154,   3.089970,  13.434600,  88.483398/), 13.288700) , &
                          xray_form_type("bk  ", 97, (/ 36.788101,  24.773600,  17.891899,   4.232840/), &
                                                     (/  0.451018,   3.046190,  12.894600,  86.002998/), 13.275400) /)

       Xray_form(211:214)=(/ &
                          xray_form_type("cf  ", 98, (/ 36.918499,  25.199499,  18.331699,   4.243910/), &
                                                     (/  0.437533,   3.007750,  12.404400,  83.788101/), 13.267400) , &
                          xray_form_type("o-2 ",  8, (/  4.758000,   3.637000,   0.000000,   0.000000/), &
                                                     (/  7.831000,  30.049999,   0.000000,   0.000000/), 1.5940000) , &
                          xray_form_type("ze  ",  1, (/  0.000000,   0.000000,   0.000000,   0.000000/), &
                                                     (/  0.000000,   0.000000,   0.000000,   0.000000/), 0.0000000) , &
                          xray_form_type("d   ",  1, (/  0.493002,   0.322912,   0.140191,   0.040810/), &
                                                     (/ 10.510900,  26.125700,   3.142360,  57.799698/),  0.003038) /)
       return
    End  Subroutine Set_Xray_Form

 End Module CFML_Scattering_Chemical_Tables

!!-------------------------------------------------------
!!---- Crystallographic Fortran Modules Library (CrysFML)
!!-------------------------------------------------------
!!---- The CrysFML project is distributed under LGPL. In agreement with the
!!---- Intergovernmental Convention of the ILL, this software cannot be used
!!---- in military applications.
!!----
!!---- Copyright (C) 1999-2012  Institut Laue-Langevin (ILL), Grenoble, FRANCE
!!----                          Universidad de La Laguna (ULL), Tenerife, SPAIN
!!----                          Laboratoire Leon Brillouin(LLB), Saclay, FRANCE
!!----
!!---- Authors: Juan Rodriguez-Carvajal (ILL)
!!----          Javier Gonzalez-Platas  (ULL)
!!----
!!---- Contributors: Laurent Chapon     (ILL)
!!----               Marc Janoschek     (Los Alamos National Laboratory, USA)
!!----               Oksana Zaharko     (Paul Scherrer Institute, Switzerland)
!!----               Tierry Roisnel     (CDIFX,Rennes France)
!!----               Eric Pellegrini    (ILL)
!!----
!!---- This library is free software; you can redistribute it and/or
!!---- modify it under the terms of the GNU Lesser General Public
!!---- License as published by the Free Software Foundation; either
!!---- version 3.0 of the License, or (at your option) any later version.
!!----
!!---- This library is distributed in the hope that it will be useful,
!!---- but WITHOUT ANY WARRANTY; without even the implied warranty of
!!---- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
!!---- Lesser General Public License for more details.
!!----
!!---- You should have received a copy of the GNU Lesser General Public
!!---- License along with this library; if not, see <http://www.gnu.org/licenses/>.
!!----
!!----
!!---- MODULE: CFML_Crystallographic_Symmetry
!!----   INFO: This module constains everything needed for handling symmetry
!!----         in Crystallography. Part of the information is obtained from
!!----         tabulated items in the module Symmetry_Tables. In particular
!!----         the correspondence of non standard settings Hermann-Mauguin
!!----         symbols and Hall symbols for space groups.
!!----         The construction of variables of the public type Space_Group_Type
!!----         is done by using a variety of algorithms and methods.
!!----         Many procedures for handling symmetry (symbolic and algebraic)
!!----         are provided in this module.
!!----
!!---- HISTORY
!!----    Update: 05/03/2011
!!----
!!---- DEPENDENCIES
!!----
!!--++    Use CFML_GlobalDeps,       only: Cp
!!--++    Use CFML_Math_General,     only: Trace, Zbelong, Modulo_Lat, equal_matrix, Equal_Vector
!!--++    Use CFML_String_Utilities, only: Equal_Sets_Text, Pack_String, Get_Fraction_2Dig, &
!!--++                                     Get_Fraction_1Dig, Frac_Trans_1Dig, L_Case,     &
!!--++                                     U_case, Ucase, Getnum, Frac_Trans_2Dig
!!--++    Use CFML_Math_3D,          only: Determ_A, matrix_inverse, Resolv_Sist_3x3
!!--++    Use CFML_Symmetry_Tables
!!----
!!----
!!---- VARIABLES
!!----    CUBIC
!!--++    EPS_SYMM                     [Private]
!!----    ERR_SYMM
!!----    ERR_SYMM_MESS
!!--++    GENER_OPER_TYPE              [Private]
!!----    HEXA
!!----    HEXAG
!!----    INLAT
!!----    Lat_Ch
!!----    LATTICE_CENTRING_TYPE
!!----    LTR
!!----    MONOC
!!----    NLAT
!!----    NUM_SPGR_INFO
!!----    ORTHOR
!!----    SPACEG
!!----    SYM_OPER_TYPE
!!----    WYCK_POS_TYPE
!!----    WYCKOFF_TYPE
!!----    SPACE_GROUP_TYPE
!!----    TETRA
!!----    TRIGO
!!----
!!---- PROCEDURES
!!----    Functions:
!!----       APPLYSO
!!----       AXES_ROTATION
!!--++       EQUAL_SYMOP               [Overloaded Operator]
!!--++       EQUIV_SYMOP               [Private]
!!----       GET_LAUE_NUM
!!----       GET_MULTIP_POS
!!----       GET_OCC_SITE
!!----       GET_POINTGROUP_NUM
!!--++       IS_AXIS                   [Private]
!!--++       IS_DIGIT                  [Private]
!!--++       IS_HEXA                   [Private]
!!----       IS_NEW_OP
!!--++       IS_PLANE                  [Private]
!!--++       IS_XYZ                    [Private]
!!----       LATTICE_TRANS
!!--++       PRODUCT_SYMOP             [Overloaded Operator]
!!----       SPGR_EQUAL
!!----       SYM_PROD
!!----
!!----    Subroutines:
!!----       ALLOCATE_LATTICE_CENTRING
!!--++       CHECK_SYMBOL_HM           [Private]
!!----       CHECK_GENERATOR
!!----       COPY_NS_SPG_TO_SPG
!!----       DECODMATMAG
!!----       GET_CENTRING_VECTORS
!!----       GET_CRYSTAL_SYSTEM
!!--++       GET_CRYSTAL_SYSTEM_R_OP   [Overloaded]
!!--++       GET_CRYSTAL_SYSTEM_R_ST   [Overloaded]
!!----       GET_GENSYMB_FROM_GENER
!!----       GET_HALLSYMB_FROM_GENER
!!----       GET_LATTICE_TYPE
!!----       GET_LAUE_PG
!!----       GET_LAUE_STR
!!----       GET_ORBIT
!!----       GET_POINTGROUP_STR
!!--++       GET_SEITZ                 [Private]
!!--++       GET_SEITZ_SYMBOL
!!--++       GET_SETTING_INFO          [Private]
!!----       GET_SHUBNIKOV_OPERATOR_SYMBOL
!!----       GET_SO_FROM_FIX
!!----       GET_SO_FROM_GENER
!!----       GET_SO_FROM_HALL
!!----       GET_SO_FROM_HMS
!!----       GET_STABILIZER
!!----       GET_STRING_RESOLV
!!----       GET_SUBORBITS
!!----       GET_SYMEL
!!----       GET_SYMKOV
!!----       GET_SYMSYMB
!!--++       GET_SYMSYMBI              [Overloaded]
!!--++       GET_SYMSYMBR              [Overloaded]
!!----       GET_T_SUBGROUPS
!!----       GET_TRASFM_SYMBOL
!!----       GET_TRANSL_SYMBOL
!!----       INIT_ERR_SYMM
!!----       INVERSE_SYMM
!!----       LATSYM
!!--++       MAX_CONV_LATTICE_TYPE     [Private]
!!--++       MOD_TRANS                 [Private]
!!----       READ_BIN_SPACEGROUP
!!----       READ_MSYMM
!!----       READ_SYMTRANS_CODE
!!----       READ_XSYM
!!----       SEARCHOP
!!----       SET_SPACEGROUP
!!----       SET_SPG_MULT_TABLE
!!----       SETTING_CHANGE
!!--++       SETTING_CHANGE_CONV       [Overloaded]
!!--++       SETTING_CHANGE_NONCONV    [Overloaded]
!!----       SIMILAR_TRANSF_SG
!!----       SYM_B_RELATIONS
!!--++       SYM_B_RELATIONS_OP        [Overloaded]
!!--++       SYM_B_RELATIONS_ST        [Overloaded]
!!----       SYM_PROD_ST
!!----       SYMMETRY_SYMBOL
!!--++       SYMMETRY_SYMBOL_OP        [Overloaded]
!!--++       SYMMETRY_SYMBOL_STR       [Overloaded]
!!--++       SYMMETRY_SYMBOL_XYZ       [Overloaded]
!!----       WRITE_BIN_SPACEGROUP
!!----       WRITE_SPACEGROUP
!!----       WRITE_SYM
!!----       WRITE_SYMTRANS_CODE
!!----       WRITE_WYCKOFF
!!----       WYCKOFF_ORBIT
!!----
!!--..    Operators:
!!--..       (*)
!!--..       (==)
!!----
!!
 Module CFML_Crystallographic_Symmetry

    !---- Used External Modules ----!
    Use CFML_GlobalDeps,       only: cp
    Use CFML_Math_General,     only: Trace, Zbelong, Modulo_Lat, equal_matrix,             &
                                     Equal_Vector,Sort,Set_Epsg,Set_Epsg_Default
    Use CFML_Math_3D,          only: Determ_A, matrix_inverse, Resolv_Sist_3x3
    Use CFML_String_Utilities, only: Equal_Sets_Text, Pack_String, Get_Fraction_2Dig,      &
                                     Get_Fraction_1Dig, Frac_Trans_1Dig, L_Case,           &
                                     U_case, Ucase, Getnum, Frac_trans_2Dig, Get_Num_String
    Use CFML_Symmetry_Tables

    implicit none

    private

    !---- List of public variables and types ----!

    !---- List of public overloaded operators ----!
    public ::  operator (*), operator (==)

    !---- List of public functions ----!
    public  :: ApplySO, Axes_Rotation, Get_Laue_Num, Get_Multip_Pos, Get_Occ_Site,     &
               Get_Pointgroup_Num, Is_New_Op, Lattice_Trans, Spgr_Equal, Sym_Prod

    !---- List of public subroutines ----!
    public  :: Decodmatmag, Get_Centring_Vectors, Get_Crystal_System, Get_Lattice_Type,              &
               Get_Laue_Pg, Get_Laue_Str, Get_orbit, Get_Pointgroup_Str, Get_So_From_Fix,            &
               Get_So_From_Gener,Get_So_From_Hall, Get_So_From_Hms, Get_HallSymb_From_Gener,         &
               Get_Stabilizer,Get_String_Resolv,Get_SubOrbits,Get_Symel, Get_Symkov, Get_SymSymb,    &
               Init_Err_Symm, Inverse_Symm, Latsym, Read_Msymm, Read_Xsym, Searchop,                 &
               Set_Spacegroup, Setting_Change, Sym_B_Relations, Sym_Prod_St, Symmetry_Symbol,        &
               Write_Spacegroup, Write_Sym, Write_Wyckoff, Wyckoff_Orbit, Get_T_SubGroups,           &
               Similar_Transf_SG, Read_SymTrans_Code, Write_SymTrans_Code, Set_SpG_Mult_Table,       &
               Get_Seitz_Symbol, Get_Trasfm_Symbol,Get_Shubnikov_Operator_Symbol,                    &
               Get_Transl_Symbol, Read_Bin_Spacegroup, Write_Bin_Spacegroup, Get_GenSymb_from_Gener, &
               Check_Generator, Copy_NS_SpG_To_SpG, Allocate_Lattice_Centring

    !---- List of private Operators ----!
    private :: Equal_Symop, Product_Symop

    !---- List of private functions ----!
    private :: Is_Axis, Is_Digit, Is_Hexa, Is_Plane, Is_Xyz, Equiv_Symop

    !---- List of private subroutines ----!
    private :: Check_Symbol_Hm, Get_Seitz, Get_SymSymbI, Get_SymSymbR, Mod_Trans, Sym_B_Relations_Op  , &
               Sym_B_Relations_St, Symmetry_Symbol_Op, Symmetry_Symbol_Xyz , Symmetry_Symbol_Str,       &
               Max_Conv_Lattice_Type,Get_Setting_Info,Get_Crystal_System_R_OP,Get_Crystal_System_R_ST, &
               Setting_Change_Conv,Setting_Change_NonConv


    !---- Global Variables ----!

    !---- Definitions ----!

    !!----
    !!---- CUBIC
    !!----    integer, parameter, public :: Cubic
    !!----
    !!----    Cubic parameter index: Cubic = 554
    !!----
    !!---- Update: February - 2005
    !!
    integer, parameter, public :: Cubic = 554

    !!--++
    !!--++ eps_symm
    !!--++    real(kind=cp), parameter, private :: eps_symm
    !!--++
    !!--++    (PRIVATE)
    !!--++    Epsilon for comparisons within this module
    !!--++
    !!--++ Update: February - 2005
    !!
    real(kind=cp), parameter, private :: eps_symm  = 0.0002_cp

    !!----
    !!---- ERR_SYMM_MESS
    !!----    character(len=150), public :: ERR_Symm_Mess
    !!----
    !!----    String containing information about the last error
    !!----
    !!---- Update: February - 2005
    !!
    character(len=150), public :: ERR_Symm_Mess

    !!----
    !!---- ERR_SYMM
    !!----    logical, public :: Err_Symm
    !!----
    !!----    Logical Variable to indicate an error on this module.
    !!----
    !!---- Update: February - 2005
    !!
    logical, public :: Err_Symm

    !!--++
    !!--++ TYPE :: GENER_OPER_TYPE
    !!--..
    !!--++ Type, private :: Gener_Oper_Type
    !!--++    integer          :: orden
    !!--++    character(len=1) :: axes
    !!--++    character(len=1) :: axes2
    !!--++    character(len=2) :: tras
    !!--++ End Type Gener_Oper_Type
    !!--++
    !!--++ Update: February - 2005
    !!
    Type, private :: Gener_Oper_Type
       integer          :: orden
       character(len=1) :: axes
       character(len=1) :: axes2
       character(len=3) :: tras
    End Type Gener_Oper_Type

    !!----
    !!---- HEXA
    !!----    logical, public :: Hexa
    !!----
    !!----    .false. Rotational part of symmetry operators  belongs to m3m
    !!----    .true.  Rotational part of symmetry operators  belongs to 6/mmm
    !!----
    !!---- Update: February - 2005
    !!
    logical, public :: Hexa

    !!----
    !!---- HEXAG
    !!----    integer, parameter, public :: Hexag
    !!----
    !!----    Index parameter for hexagonal Groups: Hexag  = 527
    !!----
    !!---- Update: February - 2005
    !!
    integer, parameter, public :: Hexag         = 527

    !!----
    !!---- INLAT
    !!----    integer, public        :: Inlat
    !!----
    !!----    Ordinal index of the lattice
    !!----
    !!---- Update: February - 2005
    !!
    integer, public        :: Inlat

    !!----
    !!---- Lat_Ch
    !!----    character(len= 1), public     :: Lat_Ch
    !!----
    !!----    First character of the space group symbol
    !!----
    !!---- Update: February - 2005
    !!
    character(len= 1), public     :: Lat_Ch

    !!----
    !!---- TYPE :: Lattice_Centring_Type
    !!--..
    !!---- Type, public :: Lattice_Centring_Type
    !!----    integer                                     :: N_lat
    !!----    logical                                     :: set
    !!----    real(kind=cp), dimension(:,:),allocatable   :: LTr
    !!---- End Type Lattice_Centring_Type
    !!----
    !!----   Lattice centring translations (including anti-translation)
    !!----   symmetry operators defined with respect to arbitrary axes.
    !!----   Normally the first translation is the identity element of the translation
    !!----   group: Ltr(:,1)=[0,0,0] or [0,0,0,1] if time inversion is considered to take
    !!----   into account also the anti-translations.
    !!----   For using this type first the program should allocate the arrays by calling
    !!----   the subroutine Allocate_Lattice_Centring and then construct totally the object
    !!----   by assigning appropriate values and putting set=.true.
    !!----
    !!---- Update: October - 2014
    !!
    Type, public :: Lattice_Centring_Type
       integer                                     :: N_lat
       logical                                     :: set
       real(kind=cp), dimension(:,:),allocatable   :: LTr
    End Type Lattice_Centring_Type


    !!----
    !!---- LTR
    !!----    real(kind=cp), dimension(3,192), public  :: Ltr
    !!----
    !!----    Centering Lattice Translations, up to 192 lattice centring
    !!----    vectors are allowed. Conventional lattice centring need only 4 vectors
    !!----
    !!---- Update: February - 2005, January-2014
    !!
    real(kind=cp), dimension(3,192), public  :: Ltr    ! Centering Lattice Translations

    !!----
    !!---- MONOC
    !!----    integer, parameter, public :: Monoc
    !!----
    !!----    Index parameter for Monoclinic Groups: Monoc  =  15
    !!----
    !!---- Update: February - 2005
    !!
    integer, parameter, public :: Monoc         =  15

    !!----
    !!---- NLAT
    !!----    integer, public      :: Nlat
    !!----
    !!----    Multiplicity of the lattice
    !!----
    !!---- Update: February - 2005
    !!
    integer, public      :: Nlat

    !!----
    !!---- TYPE :: NS_SYM_OPER_TYPE
    !!--..
    !!---- Type, public :: NS_Sym_Oper_Type
    !!----    real(kind=cp), dimension(3,3) :: Rot     !  Rotational Part of Symmetry Operator
    !!----    real(kind=cp), dimension(3)   :: Tr      !  Traslational part of Symmetry Operator
    !!---- End Type  NS_Sym_Oper_Type
    !!----
    !!----   Non-standard symmetry operator. Needed for describing non-standard space groups with
    !!----   symmetry operators defined with respect to arbitrary axes
    !!----
    !!---- Update: January - 2014
    !!
    Type, public :: NS_Sym_Oper_Type
       real(kind=cp), dimension(3,3) :: Rot
       real(kind=cp), dimension(3)   :: Tr
    End Type NS_Sym_Oper_Type

    !!----
    !!---- TYPE :: NS_SPACE_GROUP_TYPE
    !!--..
    !!---- Type, public :: NS_Space_Group_Type
    !!----    Integer                                          :: NumSpg        ! Number of the Space Group
    !!----    Character(len=20)                                :: SPG_Symb      ! Hermann-Mauguin Symbol
    !!----    Character(len=16)                                :: Hall          ! Hall symbol
    !!----    Character(len=90)                                :: gHall         ! Generalised Hall symbol
    !!----    Character(len=12)                                :: CrystalSys    ! Crystal system
    !!----    Character(len= 5)                                :: Laue          ! Laue Class
    !!----    Character(len= 5)                                :: PG            ! Point group
    !!----    Character(len= 5)                                :: Info          ! Extra information
    !!----    Character(len=90)                                :: SG_setting    ! Information about the SG setting
    !!----                                                                      ! (IT,KO,ML,ZA,Table,Standard,UnConventional)
    !!----    Character(len= 1)                                :: SPG_lat       ! Lattice type
    !!----    Character(len= 2)                                :: SPG_latsy     ! Lattice type Symbol
    !!----    Integer                                          :: NumLat        ! Number of lattice points in a cell
    !!----    real(kind=cp), allocatable, dimension(:,:)       :: Latt_trans    ! Lattice translations
    !!----    Character(len=51)                                :: Bravais       ! String with Bravais symbol + translations
    !!----    Character(len=80)                                :: Centre        ! Information about Centric or Acentric
    !!----    Integer                                          :: Centred       ! =0 Centric(-1 no at origin)
    !!----                                                                      ! =1 Acentric
    !!----                                                                      ! =2 Centric(-1 at origin)
    !!----    real(kind=cp), dimension(3)                      :: Centre_coord  ! Fractional coordinates of the inversion centre
    !!----    Integer                                          :: NumOps        ! Number of reduced set of S.O.
    !!----    Integer                                          :: Multip        ! Multiplicity of the general position
    !!----    Integer                                          :: Num_gen       ! Minimum number of operators to generate the Group
    !!----    type(NS_Sym_Oper_Type), allocatable, dimension(:):: SymOp         ! Symmetry operators (192)
    !!----    Character(len=50),      allocatable, dimension(:):: SymopSymb     ! Strings form of symmetry operators (192)
    !!---- End Type NS_Space_Group_Type
    !!----
    !!----  Definition of the type NS_Space_Group_Type: Non-standard space group. This type has been created
    !!----  in order to be able to describe symmetry operators with non-integer values when they are referred
    !!----  to arbitrary settings. They are created only as intermediate variables in some calculations.
    !!----
    !!---- Updated: February - 2005, January 2014 (JRC to make some components allocatable and change the length of some strings)
    !!
    Type, public :: NS_Space_Group_Type
       integer                                          :: NumSpg=0         ! Number of the Space Group
       character(len=20)                                :: SPG_Symb=" "     ! Hermann-Mauguin Symbol
       character(len=16)                                :: Hall=" "         ! Hall symbol
       character(len=90)                                :: gHall=" "        ! Generalised Hall symbol
       character(len=12)                                :: CrystalSys=" "   ! Crystal system
       character(len= 5)                                :: Laue=" "         ! Laue Class
       character(len= 5)                                :: PG=" "           ! Point group
       character(len= 5)                                :: Info=" "         ! Extra information
       character(len=90)                                :: SG_setting=" "   ! Information about the SG setting (IT,KO,ML,ZA,Table,Standard,UnConventional)
       character(len= 1)                                :: SPG_lat=" "      ! Lattice type
       character(len= 2)                                :: SPG_latsy=" "    ! Lattice type Symbol
       integer                                          :: NumLat=1         ! Number of lattice points in a cell
       real(kind=cp), allocatable,dimension(:,:)        :: Latt_trans       ! Lattice translations (3,12)
       character(len=51)                                :: Bravais=" "      ! String with Bravais symbol + translations
       character(len=80)                                :: Centre=" "       ! Alphanumeric information about the center of symmetry
       integer                                          :: Centred=0        ! Centric or Acentric [ =0 Centric(-1 no at origin),=1 Acentric,=2 Centric(-1 at origin)]
       real(kind=cp), dimension(3)                      :: Centre_coord=0.0 ! Fractional coordinates of the inversion centre
       integer                                          :: NumOps=0         ! Number of reduced set of S.O.
       integer                                          :: Multip=0         ! Multiplicity of the general position
       integer                                          :: Num_gen=0        ! Minimum number of operators to generate the Group
       type(NS_Sym_Oper_Type), allocatable,dimension(:) :: SymOp            ! Symmetry operators (192)
       character(len=50),      allocatable,dimension(:) :: SymopSymb        ! Strings form of symmetry operators
    End Type NS_Space_Group_Type

    !!----
    !!---- NUM_SPGR_INFO
    !!----    integer, parameter, public :: Num_Spgr_Info
    !!----
    !!----    Total dimension of SPGR_INFO: Num_Spgr_Info = 612
    !!----
    !!---- Update: February - 2005
    !!
    integer, parameter, public :: Num_Spgr_Info = 612

    !!----
    !!---- ORTHOR
    !!----    integer, parameter, public :: Orthor
    !!----
    !!----    Index parameter for Orthorhombic Groups: Orthor  = 163
    !!----
    !!---- Update: February - 2005
    !!
    integer, parameter, public :: Orthor  = 163

    !!----
    !!---- SPACEG
    !!----     character(len=20), public     :: SpaceG
    !!----
    !!----     Space group symbol
    !!----
    !!---- Update: February - 2005
    !!
    character(len=20), public   :: SpaceG

    !!----
    !!---- TYPE :: SYM_OPER_TYPE
    !!--..
    !!---- Type, public :: Sym_Oper_Type
    !!----    integer,       dimension(3,3) :: Rot     !  Rotational Part of Symmetry Operator
    !!----    real(kind=cp), dimension(3)   :: Tr      !  Traslational part of Symmetry Operator
    !!---- End Type  Sym_Oper_Type
    !!----
    !!----    Definition of Variable
    !!----
    !!---- Update: February - 2005
    !!
    Type, public :: Sym_Oper_Type
       integer,       dimension(3,3) :: Rot
       real(kind=cp), dimension(3)   :: Tr
    End Type Sym_Oper_Type

    !!----
    !!---- TYPE :: WYCK_POS_TYPE
    !!--..
    !!---- Type, public :: Wyck_Pos_Type
    !!----    integer                         :: multp     ! Multiplicity
    !!----    character(len= 6)               :: site      ! Site Symmetry
    !!----    integer                         :: norb      ! Number of elements in orbit
    !!----    character(len=40)               :: orig      ! Orig
    !!----    character(len=40),dimension(48) :: str_orbit ! Orbit
    !!----    character(len=40),dimension(192):: extra_orbit
    !!---- End Type Wyck_Pos_Type
    !!----
    !!----    Definition of Variable
    !!----
    !!---- Update: February - 2005
    !!
    Type, public :: Wyck_Pos_Type
       integer                          :: multp
       character(len= 6)                :: site
       integer                          :: norb
       character(len=40)                :: str_orig
       character(len=40),dimension(48)  :: str_orbit
    End Type Wyck_Pos_Type

    !!----
    !!---- TYPE :: WYCKOFF_TYPE
    !!--..
    !!---- Type, public :: Wyckoff_Type
    !!----    integer                            :: num_orbit      ! Number of orbits
    !!----    type(wyck_pos_type), dimension(26) :: orbit          ! Orbit type
    !!---- End Type Wyckoff_Type
    !!----
    !!----    Definition of Variable
    !!----
    !!---- Update: February - 2005
    !!
    Type, public :: Wyckoff_Type
       integer                            :: num_orbit
       type(wyck_pos_type), dimension(26) :: orbit
    End Type Wyckoff_Type

    !!----
    !!---- TYPE :: SPACE_GROUP_TYPE
    !!--..
    !!---- Type, public :: Space_Group_Type
    !!----    Integer                                         :: NumSpg        ! Number of the Space Group
    !!----    Character(len=20)                               :: SPG_Symb      ! Hermann-Mauguin Symbol
    !!----    Character(len=16)                               :: Hall          ! Hall symbol
    !!----    Character(len=90)                               :: gHall         ! Generalised Hall symbol
    !!----    Character(len=12)                               :: CrystalSys    ! Crystal system
    !!----    Character(len= 5)                               :: Laue          ! Laue Class
    !!----    Character(len= 5)                               :: PG            ! Point group
    !!----    Character(len= 5)                               :: Info          ! Extra information
    !!----    Character(len=90)                               :: SG_setting    ! Information about the SG setting
    !!----                                                                     ! (IT,KO,ML,ZA,Table,Standard,UnConventional)
    !!----    Logical                                         :: Hexa          !
    !!----    Character(len= 1)                               :: SPG_lat       ! Lattice type
    !!----    Character(len= 2)                               :: SPG_latsy     ! Lattice type Symbol
    !!----    Integer                                         :: NumLat        ! Number of lattice points in a cell
    !!----    real(kind=cp), allocatable, dimension(:,:)      :: Latt_trans    ! Lattice translations
    !!----    Character(len=51)                               :: Bravais       ! String with Bravais symbol + translations
    !!----    Character(len=80)                               :: Centre        ! Information about Centric or Acentric
    !!----    Integer                                         :: Centred       ! =0 Centric(-1 no at origin)
    !!----                                                                     ! =1 Acentric
    !!----                                                                     ! =2 Centric(-1 at origin)
    !!----    real(kind=cp), dimension(3)                     :: Centre_coord  ! Fractional coordinates of the inversion centre
    !!----    Integer                                         :: NumOps        ! Number of reduced set of S.O.
    !!----    Integer                                         :: Multip        ! Multiplicity of the general position
    !!----    Integer                                         :: Num_gen       ! Minimum number of operators to generate the Group
    !!----    type(Sym_Oper_Type), allocatable, dimension(:)  :: SymOp         ! Symmetry operators (192)
    !!----    Character(len=50),   allocatable, dimension(:)  :: SymopSymb     ! Strings form of symmetry operators (192)
    !!----    type(wyckoff_type)                              :: Wyckoff       ! Wyckoff Information
    !!----    real(kind=cp), dimension(3,2)                   :: R_Asym_Unit   ! Asymmetric unit in real space
    !!---- End Type Space_Group_Type
    !!----
    !!----     Definition of a variable type Space_Group_Type
    !!----
    !!---- Updated: February - 2005, January 2014 (JRC to make some components allocatable and change the length of some strings)
    !!
    Type, public :: Space_Group_Type
       integer                                       :: NumSpg=0         ! Number of the Space Group
       character(len=20)                             :: SPG_Symb=" "     ! Hermann-Mauguin Symbol
       character(len=16)                             :: Hall=" "         ! Hall symbol
       character(len=90)                             :: gHall=" "        ! Generalised Hall symbol
       character(len=12)                             :: CrystalSys=" "   ! Crystal system
       character(len= 5)                             :: Laue=" "         ! Laue Class
       character(len= 5)                             :: PG=" "           ! Point group
       character(len= 5)                             :: Info=" "         ! Extra information
       character(len=90)                             :: SG_setting=" "   ! Information about the SG setting (IT,KO,ML,ZA,Table,Standard,UnConventional)
       logical                                       :: Hexa=.false.     !
       character(len= 1)                             :: SPG_lat=" "      ! Lattice type
       character(len= 2)                             :: SPG_latsy=" "    ! Lattice type Symbol
       integer                                       :: NumLat=0         ! Number of lattice points in a cell
       real(kind=cp), allocatable,dimension(:,:)     :: Latt_trans       ! Lattice translations (3,12)
       character(len=51)                             :: Bravais=" "      ! String with Bravais symbol + translations
       character(len=80)                             :: Centre=" "       ! Alphanumeric information about the center of symmetry
       integer                                       :: Centred=0        ! Centric or Acentric [ =0 Centric(-1 no at origin),=1 Acentric,=2 Centric(-1 at origin)]
       real(kind=cp), dimension(3)                   :: Centre_coord=0.0 ! Fractional coordinates of the inversion centre
       integer                                       :: NumOps=0         ! Number of reduced set of S.O.
       integer                                       :: Multip=0         ! Multiplicity of the general position
       integer                                       :: Num_gen          ! Minimum number of operators to generate the Group
       type(Sym_Oper_Type), allocatable,dimension(:) :: SymOp            ! Symmetry operators (192)
       character(len=50),   allocatable,dimension(:) :: SymopSymb        ! Strings form of symmetry operators
       type(Wyckoff_Type)                            :: Wyckoff          ! Wyckoff Information
       real(kind=cp),dimension(3,2)                  :: R_Asym_Unit=0.0  ! Asymmetric unit in real space
    End Type Space_Group_Type

    !!----
    !!---- TETRA
    !!----    integer, parameter, public :: Tetra
    !!----
    !!----    Index parameter for Tetragonal Groups: Tetra = 410
    !!----
    !!---- Update: February - 2005
    !!
    integer, parameter, public :: Tetra = 410

    !!----
    !!---- TRIGO
    !!----    integer, parameter, public :: Trigo
    !!----
    !!----    Index parameter for Trigonal Groups: Trigo = 495
    !!----
    !!---- Update: February - 2005
    !!
    integer, parameter, public :: Trigo = 495


    !---- Interfaces Definitions for Overload ----!

    Interface  Get_Crystal_System
       Module Procedure Get_Crystal_System_R_OP
       Module Procedure Get_Crystal_System_R_ST
    End Interface  Get_Crystal_System

    Interface  Get_SymSymb
       Module Procedure Get_SymSymbI
       Module Procedure Get_SymSymbR
    End Interface  Get_SymSymb

    Interface  Setting_Change
       Module Procedure Setting_Change_Conv
       Module Procedure Setting_Change_NonConv
    End Interface  Setting_Change

    Interface  Sym_B_Relations
       Module Procedure Sym_B_Relations_Op
       Module Procedure Sym_B_Relations_St
    End Interface  Sym_B_Relations

    Interface  Symmetry_Symbol
       Module Procedure Symmetry_Symbol_Op
       Module Procedure Symmetry_Symbol_Str
       Module Procedure Symmetry_Symbol_Xyz
    End Interface  Symmetry_Symbol

    Interface operator (*)
       Module Procedure Product_Symop
    End Interface

    Interface Operator (==)
       Module Procedure Equal_Symop
    End Interface

 Contains

    !---- Functions ----!

    !!----
    !!---- Function Applyso(Op,V) Result(Applysop)
    !!----    Type(Sym_Oper_Type),          intent(in) :: Op        !  In -> Symmetry Operator Type
    !!----    real(kind=cp), dimension(3) , intent(in) :: v         !  In -> Vector
    !!----    real(kind=cp), dimension(3)              :: ApplySOp  ! Out -> Output vector
    !!----
    !!----    Apply a symmetry operator to a vector:  Vp = ApplySO(Op,v)
    !!----
    !!---- Update: February - 2005
    !!
    Function ApplySO(Op,V) Result(Applysop)
       !---- Arguments ----!
       Type(Sym_Oper_Type),          intent(in) :: Op
       real(kind=cp), dimension(3),  intent(in) :: v
       real(kind=cp), dimension(3)              :: ApplySOp

       ApplySOp = matmul(Op%Rot,v) + Op%tr

       return
    End Function ApplySO

    !!----
    !!---- Function Axes_Rotation(R) Result(N)
    !!----    integer, dimension(3,3), intent  (in) :: r    !  In -> Rotation part of Symmetry Operator
    !!----    integer                               :: n    ! Out -> Orden of the Rotation Part
    !!----
    !!----    Determine the orden of rotation (valid for all bases). Return a zero
    !!----    if any error occurs.
    !!----
    !!---- Update: February - 2005
    !!
    Function Axes_Rotation(R) Result(N)
       !---- Arguments ----!
       integer, dimension(3,3), intent (in) :: r
       integer                              :: n

       !---- Local Variables ----!
       integer :: det,itr

       n=0

       det=determ_A(r)
       itr=trace(r)
       select case (itr)
          case (-3)
             if (det == -1) n=-1

          case (-2)
             if (det == -1) n=-6

          case (-1)
             if (det == -1) n=-4
             if (det ==  1) n= 2

          case ( 0)
             if (det == -1) n=-3
             if (det ==  1) n= 3

          case ( 1)
             if (det == -1) n=-2
             if (det ==  1) n= 4

          case ( 2)
             if (det ==  1) n= 6

          case ( 3)
             if (det ==  1) n= 1
       end select

       return
    End Function Axes_Rotation

    !!--++
    !!--++ Function Equal_Symop(Syma,Symb) Result (Aeqb)
    !!--++    type(Sym_Oper_Type), intent (in) :: syma
    !!--++    type(Sym_Oper_Type), intent (in) :: symb
    !!--++    logical                          :: aeqb
    !!--++
    !!--++    (OVERLOADED)
    !!--++    The result is .true. if syma == symb, otherwise is .false.
    !!--++    It overloads the "==" operator for objects of type Sym_Oper_Type.
    !!--++    The calling program can use a statement like: if(syma == symb) then ...
    !!--++
    !!--++  Update: February - 2005
    !!
    Function Equal_Symop(Syma,Symb) Result (Aeqb)
       !---- Arguments ----!
       type(Sym_Oper_Type), intent (in) :: syma
       type(Sym_Oper_Type), intent (in) :: symb
       logical                          :: aeqb

       !---- Local variables ----!
       integer :: i,j

       aeqb=.false.
       do i=1,3
          if (abs(Syma%tr(i)-Symb%tr(i)) > eps_symm) return
       end do

       do i=1,3
          do j=1,3
             if (abs(Syma%Rot(i,j)-Symb%Rot(i,j)) > eps_symm) return
          end do
       end do
       aeqb=.true.

       return
    End Function Equal_Symop

    !!--++
    !!--++ Equiv_Symop(Syma,Symb,Lat) Result (Aeqb)
    !!--++    type(Sym_Oper_Type), intent (in) :: syma
    !!--++    type(Sym_Oper_Type), intent (in) :: symb
    !!--++    character (len=*),   intent (in) :: lat
    !!--++    logical                          :: aeqb
    !!--++
    !!--++    The result is .true. if Syma  differ from Symb just by a lattice
    !!--++    translation. This Function is used by the subroutine constructing
    !!--++    the multiplication table of the factor group of a space group.
    !!--++
    !!--++  Update: April - 2005
    !!
    Function Equiv_Symop(Syma,Symb,Lat) Result (Aeqb)
       !---- Arguments ----!
       type(Sym_Oper_Type), intent (in) :: syma
       type(Sym_Oper_Type), intent (in) :: symb
       character (len=*),   intent (in) :: lat
       logical                          :: aeqb

       !---- Local variables ----!
       integer                     :: i,j
       real(kind=cp), dimension(3) :: tr

       aeqb=.false.
       tr= Syma%tr-Symb%tr
       if (.not. Lattice_Trans(tr,Lat)) return
       do i=1,3
          do j=1,3
             if (abs(Syma%Rot(i,j)-Symb%Rot(i,j)) > 0) return
          end do
       end do
       aeqb=.true.

       return
    End Function Equiv_Symop


    !!----
    !!---- Function Get_Laue_Num(Laueclass) Result(Lnum)
    !!----    character(len=*), intent (in) :: laueclass    !  In -> Laue Class string
    !!----    integer                       :: lnum         ! Out -> Ordinal number according LAUE_CLASS
    !!----
    !!----    Obtain the ordinal number corresponding to the Laue-Class
    !!----    symbol according to Laue_Class array. Zero if error is present
    !!----
    !!---- Update: February - 2005
    !!
    Function Get_Laue_Num(Laueclass) Result(Lnum)
       !---- Arguments ----!
       character(len=*), intent (in) :: laueclass
       integer                       :: lnum

       !---- Local Variables ----!
       integer                       :: i
       character(len=len(laueclass)) :: laue

       lnum=0
       laue=adjustl(laueclass)

       do i=1,16
          if (laue(1:5) == laue_class(i)) then
             lnum=i
             exit
          end if
       end do
       if (lnum==15) lnum=13
       if (lnum==16) lnum=14

       return
    End Function Get_Laue_Num

    !!----
    !!----  Function Get_Multip_Pos(X,Spg) Result(Mult)
    !!----    real(kind=cp), dimension(3), intent (in) :: x        !  In -> Position vector
    !!----    type(Space_Group_type),      intent (in) :: spgr     !  In -> Space Group
    !!----    integer                                  :: mult     !  Result -> Multiplicity
    !!----
    !!----    Obtain the multiplicity of a real space point given the space group.
    !!----
    !!---- Update: February - 2005
    !!
    Function Get_Multip_Pos(x,Spg) Result(mult)
       !---- Arguments ----!
       real(kind=cp), dimension(3),  intent (in) :: x
       type(Space_Group_type),       intent (in) :: spg
       integer                                   :: mult

       !---- Local variables ----!
       integer                                :: j, nt
       real(kind=cp), dimension(3)            :: xx,v
       real(kind=cp), dimension(3,Spg%multip) :: u

       !> Init Epss
       call set_epsg(1.0e-3)

       mult=1
       u(:,1)=x(:)

       ext: do j=2,Spg%multip
          xx=ApplySO(Spg%SymOp(j),x)
          xx=modulo_lat(xx)
          do nt=1,mult
             v=u(:,nt)-xx(:)
             if (Lattice_trans(v,Spg%spg_lat)) cycle ext
          end do
          mult=mult+1
          u(:,mult)=xx(:)
       end do ext

       mult=mult*Spg%Numlat

       !> Reset value for epss
       call set_epsg_default()

       return
    End Function Get_Multip_Pos

    !!----
    !!---- Function Get_Occ_Site(Pto,Spg) Result(Occ)
    !!----    real(kind=cp),dimension(3),intent (in) :: Pto ! Point for Occupancy calculation
    !!----    Type (Space_Group_Type),   intent(in)  :: Spg ! Space Group
    !!----    real(kind=cp)                          :: Occ ! Result
    !!----
    !!----    Obtain the occupancy factor (site multiplicity/multiplicity) for Pto
    !!----
    !!---- Update: February - 2005
    !!
    Function Get_Occ_Site(Pto,Spg) Result(Occ)
       !---- Arguments ----!
       real(kind=cp), dimension(3),intent(in) :: Pto
       type (Space_Group_Type),    intent(in) :: Spg
       real(kind=cp)                          :: Occ

       !---- Local Variables ----!

       !> Init Epss
       call set_epsg(1.0e-3)

       Occ=real(Get_Multip_pos(pto,Spg))/real(Spg%multip)

       !> Reset value Epss
       call set_epsg_default()

       return
    End Function Get_Occ_Site

    !!----
    !!---- Function Get_Pointgroup_Num(Pgname) Result(Ipg)
    !!----    character(len=*), intent (in) :: pgname        !  In -> String for PointGroup
    !!----    integer                       :: ipg           ! Out -> Ordinal number as POINT_GROUP
    !!----
    !!----    Obtain the ordinal number corresponding to the Point Group
    !!----    symbol according to Point_Group array. Zero if Error is present
    !!----
    !!---- Update: July - 2014: added m3 and m3m for compatibility with Laue_class
    !!
    Function Get_Pointgroup_Num(Pgname) Result(Ipg)
       !---- Arguments ----!
       character(len=*), intent (in) :: pgname
       integer                       :: ipg

       !---- Local Variables ----!
       integer                       :: i
       character(len=len(pgname))    :: pg

       ipg=0
       pg=adjustl(pgname)

       do i=1,41                ! was 39, now 41 to accomodate m3 and m3m
          if (pg(1:5) == point_group(i)) then
             ipg=i
             exit
          end if
       end do

       !> return previous numbers for m3 and m3m
       if(ipg == 40)ipg=36      ! m3 now m-3
       if(ipg == 41)ipg=39      ! m3m now m-3m

       return
    End Function Get_PointGroup_Num

    !!--++
    !!--++ Logical Function Is_Axis(Ax) Result(Is_Axiss)
    !!--++    character(len=*), intent(in) :: Ax
    !!--++
    !!--++    (PRIVATE)
    !!--++    Detect the presence of a rotation axis
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Is_Axis(Ax) Result(Is_Axiss)
       !---- Argument ----!
       character(len=*), intent(in) :: Ax
       logical                      :: Is_axiss

       !---- Local Variables ----!
       character(len=*), dimension(6), parameter :: axis=(/"1","2","3","4","5","6"/)
       integer                                   :: i

       Is_axiss=.false.
       do i=1,6
          if (Ax == axis(i))  then
             Is_axiss=.true.
             exit
          end if
       end do

       return
    End Function Is_Axis

    !!--++
    !!--++ Logical Function Is_Digit(A) Result(Is_Digitt)
    !!--++    character(len=*), intent(in) :: A    !  In ->
    !!--++
    !!--++    (PRIVATE)
    !!--++    Determine if A is a digit
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Is_Digit(A) Result(Is_Digitt)
       !---- Argument ----!
       character(len=*), intent(in) :: A
       logical                      :: Is_digitt
       character(len=*), parameter  :: digit="0123456789"

       Is_digitt=.false.
       if (index(digit,a) /= 0 ) Is_digitt=.true.

       return
    End Function Is_Digit

    !!--++
    !!--++ Logical Function Is_Hexa(Ng,Ss)
    !!--++    integer, intent (in)                  :: ng   !  In -> Number of Symmetry Operators
    !!--++    integer, dimension(:,:,:), intent(in) :: ss   !  In -> Rotation part of Symmetry Operators  (3,3,48)
    !!--++
    !!--++    (PRIVATE)
    !!--++    Calculate if the SpaceGroup is HEXAGONAL
    !!--++    Valid only for conventional bases
    !!--++
    !!--++  Update: February - 2005
    !!
    Function Is_Hexa(Ng,Ss) Result(Is_Hexag)
       !---- Argument ----!
       integer, intent (in)                   :: ng
       integer, dimension(:,:,:), intent(in)  :: ss   !(3,3,48)
       logical                                :: is_Hexag

       !---- Local Variables ----!
       integer :: i

       Is_Hexag=.false.
       do i=2,ng
          if (sum(abs(ss(:,1,i))) > 1) then
             Is_hexag=.true.
             exit
          end if
          if (sum(abs(ss(:,2,i))) > 1) then
             Is_hexag=.true.
             exit
          end if
       end do

       return
    End Function Is_Hexa

    !!----
    !!---- Logical Function Is_New_Op(Op,N,List_Op) Result(Is_New)
    !!----    type(Sym_Oper_type), intent(in)               :: op      !  In ->  Symmetry operator
    !!----    Integer,             intent(in)               :: n       !  In ->  Integer giving the number of Op i the list
    !!----    type(Sym_Oper_type), intent(in), dimension(:) :: list_op !  In ->  List of n symmetry operators
    !!----
    !!----    Determine if a symmetry operator is or not in a given list
    !!----
    !!---- Update: February - 2005
    !!
    Function Is_New_Op(Op,N,List_Op) Result(Is_New)
       !---- Argument ----!
       type(Sym_Oper_type), intent(in)               :: op
       Integer,             intent(in)               :: n
       type(Sym_Oper_type), intent(in), dimension(:) :: list_op
       logical                                       :: is_new

       !---- Local Variables ----!
       integer :: i

       is_new=.true.
       do i=1,n
          if (op == list_op(i))  then
             is_new=.false.
             exit
          end if
       end do

       return
    End Function Is_New_Op

    !!--++
    !!--++  Logical Function Is_Plane(Ax) Result(Is_Planee)
    !!--++     character(len=*), intent(in) :: Ax
    !!--++
    !!--++     (PRIVATE)
    !!--++     Detect the presence of a mirror or glide plane
    !!--++
    !!--++  Update: February - 2005
    !!
    Function Is_Plane(Ax) Result(Is_Planee)
       !---- Argument ----!
       character(len=*), intent(in) :: Ax
       logical                      :: Is_Planee

       !---- Local Variables ----!
       character(len=*), dimension(6), parameter :: plane=(/"A","B","C","D","M","N"/)
       integer                                   :: i

       Is_planee=.false.
       do i=1,6
          if (Ax == plane(i))  then
             Is_planee=.true.
             exit
          end if
       end do

       return
    End Function Is_Plane

    !!--++
    !!--++ Logical Function Is_Xyz(A) Result(Iss_Xyz)
    !!--++    character(len=*), intent(in) :: A
    !!--++
    !!--++    (PRIVATE)
    !!--++    Determine if A is a character X, Y or Z
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Is_Xyz(A) Result(Iss_Xyz)
       !---- Argument ----!
       character(len=*), intent(in) :: A
       logical                      :: Iss_xyz

       Iss_xyz=.false.
       if (A == "x" .or. A == "X" .or.   &
           A == "y" .or. A == "Y" .or.   &
           A == "z" .or. A == "Z")  Iss_xyz=.true.

       return
    End Function Is_Xyz

    !!----
    !!---- Logical Function Lattice_Trans(V,Lat) Result(Lattice_Transl)
    !!----    real(kind=cp), dimension(3), intent( in) :: v              !  In -> Vector
    !!----    character(len=*),            intent( in) :: Lat            !  In -> Lattice Character
    !!----    logical                                  :: Lattice_Transl ! Out -> .True. or .False.
    !!----
    !!----    Determine whether a vector is a lattice vector
    !!----    depending on the Bravais lattice.
    !!----
    !!---- Update: February - 2005
    !!
    Function Lattice_Trans(V,Lat) Result(Lattice_Transl)
       !---- Argument ----!
       real(kind=cp), dimension(3), intent( in) :: v
       character(len=*),            intent( in) :: Lat
       logical                                  :: Lattice_Transl

       !---- Local variables ----!
       real(kind=cp)   , dimension(3) :: vec
       integer                        :: i

       Lattice_Transl=.false.

       if (Zbelong(v)) then                      ! if v is an integral vector =>  v is a lattice vector
          Lattice_Transl=.true.
       else                                      ! if not look for lattice type
          select case (Lat)
             case("A","a")
                vec=Ltr_a(:,2)-v
                if (Zbelong(vec)) Lattice_Transl=.true.
             case("B","b")
                vec=Ltr_b(:,2)-v
                if (Zbelong(vec)) Lattice_Transl=.true.
             case("C","c")
                vec=Ltr_c(:,2)-v
                if (Zbelong(vec)) Lattice_Transl=.true.
             case("I","i")
                vec=Ltr_i(:,2)-v
                if (Zbelong(vec)) Lattice_Transl=.true.
             case("R","r")
                vec=Ltr_r(:,2)-v
                if (Zbelong(vec)) Lattice_Transl=.true.
                vec=Ltr_r(:,3)-v
                if (Zbelong(vec)) Lattice_Transl=.true.
             case("F","f")
                vec=Ltr_f(:,2)-v
                if (Zbelong(vec)) Lattice_Transl=.true.
                vec=Ltr_f(:,3)-v
                if (Zbelong(vec)) Lattice_Transl=.true.
                vec=Ltr_f(:,4)-v
                if (Zbelong(vec)) Lattice_Transl=.true.
             case("Z")
                do i=2,nlat
                  vec=Ltr(:,i)-v
                  if (Zbelong(vec)) then
                    Lattice_Transl=.true.
                    exit
                  end if
                end do
          end select
       end if

       return
    End Function  Lattice_Trans

    !!--++
    !!--++ Function Product_Symop(Syma,Symb) Result (Symab)
    !!--++    type(Sym_Oper_Type), intent (in) :: syma
    !!--++    type(Sym_Oper_Type), intent (in) :: symb
    !!--++    type(Sym_Oper_Type)              :: symab
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Obtain the symmetry operation corresponding
    !!--++    to the product of two operators by using the * operator.
    !!--++    The calling program can use a statement like: symab=syma*symb
    !!--++
    !!--++  Update: February - 2005
    !!
    Function Product_Symop(Syma,Symb) Result (Symab)
       !---- Arguments ----!
       type(Sym_Oper_Type), intent (in) :: syma
       type(Sym_Oper_Type), intent (in) :: symb
       type(Sym_Oper_Type)              :: symab

       symab%tr  = Syma%tr + matmul(real(Syma%Rot),Symb%tr)
       Symab%Rot = matmul(Syma%Rot,Symb%Rot)

       return
    End Function Product_Symop

    !!----
    !!---- Logical Function Spgr_Equal(Spacegroup1,Spacegroup2) Result(Ispgr_Equal)
    !!----    Type (Space_Group_Type),  intent(in) :: SpaceGroup1   ! In ->
    !!----    Type (Space_Group_Type),  intent(in) :: SpaceGroup2   ! In ->
    !!----
    !!----    Determine if two SpaceGroups are equal
    !!----
    !!---- Update: February - 2005
    !!
    Function Spgr_Equal(Spacegroup1, Spacegroup2) Result(Ispgr_Equal)
       !---- Arguments ----!
       type (Space_Group_Type),  intent(in) :: SpaceGroup1, SpaceGroup2
       logical                              :: iSpGr_Equal

       !---- Trivial tests----!
       iSpGr_Equal=.false.
       if (SpaceGroup1%multip == 0 .or. SpaceGroup2%multip == 0) return
       if (SpaceGroup1%multip /= SpaceGroup2%multip) return

       iSpGr_Equal=Equal_sets_text(SpaceGroup1%SymopSymb,SpaceGroup1%multip, &
                                   SpaceGroup2%SymopSymb,SpaceGroup2%multip)

       return
    End Function Spgr_Equal

    !!----
    !!---- Function Sym_Prod(Syma,Symb,Modlat) Result (Symab)
    !!----    type(Sym_Oper_Type), intent (in) :: syma
    !!----    type(Sym_Oper_Type), intent (in) :: symb
    !!----    logical,optional,    intent (in) :: modlat
    !!----    type(Sym_Oper_Type)              :: symab
    !!----
    !!----    Obtain the symmetry operation corresponding to the product of
    !!----    two operators.
    !!----    If modlat=.true. or it is not present, the traslation
    !!----    part of the resulting operator is reduced to have components <1.0
    !!----
    !!---- Update: February - 2005
    !!
    Function Sym_Prod(Syma,Symb,Modlat) Result (Symab)
       !---- Arguments ----!
       type(Sym_Oper_Type), intent (in) :: syma
       type(Sym_Oper_Type), intent (in) :: symb
       logical,optional,    intent (in) :: modlat
       type(Sym_Oper_Type)              :: symab

       if (present(modlat)) then
          if (.not. modlat) then
             symab%tr = Syma%tr + matmul(real(Syma%Rot),Symb%tr)
          else
             symab%tr = modulo_lat(Syma%tr + matmul(real(Syma%Rot),Symb%tr))
          end if
       else
          symab%tr = modulo_lat(Syma%tr + matmul(real(Syma%Rot),Symb%tr))
       end if
       Symab%Rot = matmul(Syma%Rot,Symb%Rot)

       return
    End Function Sym_Prod

    !!---- Subroutine Allocate_Lattice_Centring(Latt,n,tinv)
    !!----   Type(Lattice_Centring_Type), intent(out)  :: Latt
    !!----   integer,                     intent(in)   :: n
    !!----   logical,  optional,          intent(in)   :: tinv
    !!----
    !!----  Allocates a Lattice_Centring_Type object. If tinv is present and tinv=.true.
    !!----  four indices are selected for the first dimension for storing the presence or
    !!----  absence of time inversion once the object is constructed.
    !!----
    !!----  Updated: October 2014
    !!----
    !!
    Subroutine Allocate_Lattice_Centring(Latt,n,tinv)
      Type(Lattice_Centring_Type), intent(out)  :: Latt
      integer,                     intent(in)   :: n
      logical,  optional,          intent(in)   :: tinv
      !--- Local variables ---!
      if(present(tinv)) then
        if(tinv) then
           allocate(Latt%Ltr(4,n))
        else
           allocate(Latt%Ltr(3,n))
        end if
      else
        allocate(Latt%Ltr(3,n))
      end if
      Latt%Ltr=0.0
      Latt%N_lat=n
      Latt%set=.false.
      return
    End Subroutine Allocate_Lattice_Centring

    !!---- Subroutine Check_Generator(gen,ok,symbol)
    !!----   Character(len=*),         intent(in)  :: gen
    !!----   logical,                  intent(out) :: ok
    !!----   character(len=*),optional,intent(out) :: symbol
    !!----
    !!----  Check that the string containing a generator, contains a legal symmetry operator
    !!----  Only integer coefficients and determinant of the rotational part equal to +1 or -1
    !!----  are allowed. In the optional argument "symbol" the nature of the operator is provided.
    !!----
    !!----  Updated: January 2014
    !!----
    !!
    Subroutine Check_Generator(gen,ok,symbol)
      Character(len=*),         intent(in)  :: gen
      logical,                  intent(out) :: ok
      character(len=*),optional,intent(out) :: symbol
      !--- Local variables ---!
      integer :: i,j,k,n,itr,idet
      character(len=len(gen)), dimension(3) :: split
      character(len=len(gen))  :: symb
      character(len=*), dimension(3), parameter :: code=(/"x","y","z"/)
      real(kind=cp)  :: det
      real(kind=cp), dimension(3,3) :: Mat,iMat
      logical :: esta

      call Init_Err_Symm()
      ok=.false.
      i=index(gen,",")
      j=index(gen,",",back=.true.)
      split(1)= l_case(pack_string(gen(1:i-1)))
      split(2)= l_case(pack_string(gen(i+1:j-1)))
      split(3)= l_case(pack_string(gen(j+1:)))
      !Remove the translation part if it exists
      !write(*,"(4a)") " => Initial split: ", (trim(split(i))//"   ",i=1,3)
      do i=1,3
        n=len_trim(split(i))
        j=index(split(i),"+",back=.true.)
        if(j /= 0) then
          symb=split(i)(j+1:)
          esta=.false.
          do k=1,len_trim(symb)
            if(symb(k:k) == code(1) .or. symb(k:k) == code(2) .or. symb(k:k) == code(3) ) then
               esta = .true.  !A translation is not provided after the matrix
               exit
            end if
          end do
          if(.not. esta) then ! a translation is given in that part of the string, so remove it!
             split(i)=split(i)(1:j-1)
          else ! we have to check starting from the left of the string
             j=index(split(i),"+") !look for the first appearance of "+"
             !Check if there are x,y,z on the left of "+"
             if(j > 1) then
                symb=split(i)(1:j-1)
                esta=.false.
                do k=1,len_trim(symb)
                  if(symb(k:k) == code(1) .or. symb(k:k) == code(2) .or. symb(k:k) == code(3) ) then
                     esta = .true.  !A translation is not provided before the matrix
                     exit
                  end if
                end do
                if(.not. esta) then   !A translation exists
                  split(i)=split(i)(j+1:)
                end if
             end if
          end if
        end if
        if(len_trim(split(i)) == n) then !Check now if instead of "+" the translation is given with "-" sign
          j=index(split(i),"-",back=.true.)
          if(j /= 0) then
            symb=split(i)(j+1:)
            esta=.false.
            do k=1,len_trim(symb)
              if(symb(k:k) == code(1) .or. symb(k:k) == code(2) .or. symb(k:k) == code(3) ) then
                 esta = .true.  !A translation is not provided after the matrix
                 exit
              end if
            end do
            if(.not. esta) then ! a translation is given in that part of the string, so remove it!
               split(i)=split(i)(1:j-1)
            else ! we have to check "-" starting from the left of the string
               j=index(split(i),"-") !look for the first appearance of "+"
               !Check if there are x,y,z on the left of "-"
               if(j > 1) then
                  symb=split(i)(1:j-1)
                  esta=.false.
                  do k=1,len_trim(symb)
                    if(symb(k:k) == code(1) .or. symb(k:k) == code(2) .or. symb(k:k) == code(3) ) then
                       esta = .true.  !A translation is not provided before the matrix
                       exit
                    end if
                  end do
                  if(.not. esta) then   !A translation exists
                    split(i)=split(i)(j+1:)
                  end if
               end if
            end if
          end if
        end if
      end do
      !write(*,"(4a)") " => Final split: ", (trim(split(i))//"   ",i=1,3)
      do i=1,3
       call Get_Num_String(trim(split(i)), Mat(i,:),code)
      end do
      !Now determine if the matrix has integer components
      iMat=real(nint(Mat))
      !now calculate the determinant ... it should be equal to +/-1!
      det=determ_A(Mat)
      idet=nint(det)
      det=abs(det)
      if(present(symbol)) then
        itr=nint(trace(Mat))
        n=0
        select case (itr)
           case (-3)
              if (idet == -1) symbol="-1"
           case (-2)
              if (idet == -1) symbol="-6"
           case (-1)
              if (idet == -1) symbol="-4"
              if (idet ==  1) symbol="2 or 21"
           case ( 0)
              if (idet == -1) symbol="-3"
              if (idet ==  1) symbol="3 or 31/32"
           case ( 1)
              if (idet == -1) symbol="m or g"
              if (idet ==  1) symbol="4 or 41,42..."
           case ( 2)
              if (idet ==  1) symbol="6 or 61,62,..."
           case ( 3)
              if (idet ==  1) symbol="1"
           case default
              n=0
        end select
        symbol=trim(symbol)//"  [undet. loc.]"
      end if
      iMat=iMat-Mat
      if(sum(abs(iMat)) > eps_symm) then
        err_symm=.true.
        err_symm_mess="The matrix corresponding to a generator has non-integer values!"
        return
      else
        if(abs(det-1.0) > eps_symm) then
          err_symm=.true.
          err_symm_mess="The matrix corresponding to a generator has a determinant with absolute value different of 1.0"
          return
        end if
      end if
      ok=.true.  !arriving here the generator is ok!
      return
    End Subroutine Check_Generator

    !---- Subroutines ----!

    !!--++
    !!--++ Subroutine Check_Symbol_Hm(Hms)
    !!--++    character (len=1), dimension(3,4), intent( in):: HMS   ! In -> Hermann-Mauguin Symbol
    !!--++
    !!--++    (PRIVATE)
    !!--++    Subroutine used by Get_SO_from_HMS.
    !!--++    Check the correctness of the Herman-Mauguin Symbol (not all!!!).
    !!--++    Logical "hexa" must be defined and control error is present.
    !!--++
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Check_Symbol_Hm(Hms)
       !---- Argument ----!
       character (len=1), dimension(3,4), intent( in):: HMS

       !---- Local Variables ----!
       logical          :: is_there,axis,plane
       character(len=1) :: Item_SP
       character(len=*), dimension(16), parameter ::                    &
                         good=(/"1","2","3","4","5","6","A","B","C","D","M","N","P","/","-"," "/)
       integer          :: ncount,five,i,j,l

       !---- Check for missprinted symbols ----!
       call init_err_symm()
       do i=1,3
          do j=1,4
             is_there=.false.
             five=0
             if (HMS(i,j) == "5") five=j
             do L=1,16
                if (HMS(i,j) == good(L)) is_there=.true.
             end do
             if (.not. is_there) then
                err_symm=.true.
                ERR_Symm_Mess=" The symbol: "//HMS(i,j)//" is not allowed"
                return
             else if (five == 1) then
                err_symm=.true.
                ERR_Symm_Mess=" The fivefold axis is not allowed"
                return
             end if
          end do
       end do

       !---- Check for repetitions and axes followed by planes (and viceversa) ----!
       do i=1,3
          do j=1,3
             Item_SP=HMS(i,j)
             if (Item_SP == " ") cycle
             is_there=.false.
             axis=Is_axis(Item_SP)
             plane=Is_plane(Item_SP)
             do L=j+1,4
                if (HMS(i,L) == Item_SP)  is_there=.true.
             end do
             if (is_there) then
                err_symm=.true.
                ERR_Symm_Mess=" The symbol: "//HMS(i,j)// &
                              " has been repeated within the same symmetry direction"
                return
             end if
             if (axis .and. Is_plane(HMS(i,j+1))) then
                err_symm=.true.
                ERR_Symm_Mess=" A rotation axis cannot be immediately followed by a plane"//char(13)//&
                              " within the same symmetry direction"
                return
             end if
             if (plane .and. Is_axis(HMS(i,j+1))) then
                err_symm=.true.
                ERR_Symm_Mess=" A mirror plane cannot be immediately followed by a rotation axis"//char(13)//&
                              " within the same symmetry direction"
                return
             end if
          end do
       end do

       !---- Check for two planes in the same symmetry direction ----!
       do i=1,3
          ncount=0
          do j=1,4
             Item_SP=HMS(i,j)
             do L=7,12
                if (good(L) == Item_SP) ncount=ncount+1
             end do
          end do
          if (ncount > 1) then
             err_symm=.true.
             ERR_Symm_Mess=" There is more than one plane within the same symmetry direction"
             return
          end if
       end do

       !---- Check for ILLEGAL screw axes ----!
       do i=1,3
          ncount=0
          do j=1,4
             Item_SP=HMS(i,j)
             if (Item_SP == " ") cycle
             do L=1,6
                if (good(L) == Item_SP) ncount=ncount+1
             end do
          end do
          if (ncount > 1) then  !there is more than one axis-symbol -> Screw
          !   if (iachar(HMS(i,1)) < iachar(HMS(i,2))) then
             if (HMS(i,1) <  HMS(i,2) ) then
                err_symm=.true.
                ERR_Symm_Mess=" Screw axis: "//HMS(i,1)//" "//HMS(i,2)//" not allowed"
                return
             end if
          end if
       end do

       return
    End Subroutine Check_Symbol_HM

    !!----
    !!---- Subroutine Decodmatmag(Sim,Xyzstring)
    !!----    integer, dimension(3,3), intent(in)  :: sim          !  In -> Rotation matrix
    !!----    character (len=*),       intent(out) :: XYZstring    ! Out -> String (Mx,My,Mz)
    !!----
    !!----    Supplies a string of the form (Mx,My,Mz) for the rotation matrix Sim.
    !!----    Logical "hexa" must be defined.
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Decodmatmag(Sim,Xyzstring)
       !---- Arguments ----!
       integer,dimension (3,3), intent( in) :: sim
       character (len=*),       intent(out) :: XYZstring

       !---- Local variables ----!
       integer :: Iu,j,ihex

       call SearchOp(sim,1,36,Iu)

       if (.not. hexa) then
          j=abs(Iu)
          if (Iu < 0) j=j+24
          XYZstring= MAGmat(j)
       else
          j=abs(Iu)-24
          ihex=2
          if ( j < 0 ) then
             j=j+24
             ihex=1
          end if
          if (Iu < 0) j=j+24/ihex
          XYZstring= MAGmat(j+(ihex-1)*48)
       end if

       return
    End Subroutine DecodMatMag

    !!----
    !!---- Subroutine Get_Centring_Vectors(L,Latc,LatSymb)
    !!----    integer,                        intent (in out) :: L       ! Number of centring vectors
    !!----    real(kind=cp), dimension(:,:),  intent (in out) :: latc    ! Centering vectors
    !!----    character(len=1),               intent (   out) :: LatSymb ! Lattice symbol
    !!----
    !!----    Subroutine to complete the centring vectors of a centered lattice and to provide a lattice symbol.
    !!----    It is useful when non-conventional lattices are used to obtain all lattice
    !!----    translations with components in the range [0.0 1.0). The (0,0,0) translation
    !!----    is removed in case it comes on input.
    !!----
    !!---- Update: February - 2005, January-2014 (JRC)
    !!
    Subroutine Get_Centring_Vectors(L,Latc,LatSymb)
       !---- Arguments ----!
       integer,                       intent (in out) :: L
       real(kind=cp), dimension(:,:), intent (in out) :: latc  !(3,n)
       character(len=*),              intent (out)    :: LatSymb
       !---- Local variables ----!
       logical                                  :: isnew
       real(kind=cp), dimension(3,size(latc,2)) :: latinv,newlat
       real(kind=cp), dimension(3)              :: v,v1,v2
       integer                                  :: i,j,k1,k2,n,lat_ini,lm
       real(kind=cp), parameter                 :: teps=3.0*eps_symm

       LatSymb="P"
       if(L == 0) return
       newlat=latc
       !Purge the translations
       do i=1,L-1
         v=newlat(:,i)
         if(sum(v) < teps) cycle
         do j=i+1,L
            if(sum(abs(newlat(:,j)-v)) < teps) newlat(:,j)=0.0
         end do
       end do
       n=0
       do i=1,L
         if(sum(abs(newlat(:,i))) < teps) cycle
         n=n+1
         latc(:,n)=newlat(:,i)
       end do
       L=n  !normally n < L_initial

       latinv=0.0
       where (abs(latc)> teps)
          latinv=1.0/latc
       end where
       do
          lat_ini=L
          do i=1,L    !Even for a single centring vector this loop is executed
            v1=latc(:,i)
            do j=i,L  !start on i to ensure that for a single centring vector the internal loops are executed
              v2=latc(:,j)
              do k1=0,maxval(nint(latinv(:,i)))
                do k2=0,maxval(nint(latinv(:,j)))
                  v=modulo_lat(k1*v1+k2*v2)
                  if(sum(abs(v)) < teps) cycle
                  if( any(v > 1.0-teps) ) cycle
                  isnew=.true.
                  do lm=1,L
                    if (sum(abs(v-latc(:,lm))) < teps) then
                       isnew=.false.
                       exit
                    end if
                  end do
                  if(isnew) then
                     L=L+1
                     latc(:,L)=v
                  end if
                end do
              end do
            end do
          end do
          If(L == Lat_ini) exit !No more vectors have been generated
       end do

       !Recognize the type of Lattice
       Select Case(L)

         Case(1) !Test I, A, B, C
            if(sum(abs(latc(:,1)-Ltr_i(:,2))) < teps) then
              LatSymb="I"
              return
            end if
            if(sum(abs(latc(:,1)-Ltr_a(:,2))) < teps) then
              LatSymb="A"
              return
            end if
            if(sum(abs(latc(:,1)-Ltr_b(:,2))) < teps) then
              LatSymb="B"
              return
            end if
            if(sum(abs(latc(:,1)-Ltr_c(:,2))) < teps) then
              LatSymb="C"
              return
            end if

         Case(2)  !Test R
             isnew=.false.
             if(sum(abs(latc(:,1)-Ltr_r(:,2))) < teps .or. sum(abs(latc(:,1)-Ltr_r(:,3))) < teps) isnew=.true.
             if(isnew) then
               if(sum(abs(latc(:,2)-Ltr_r(:,2))) < teps .or. sum(abs(latc(:,2)-Ltr_r(:,3))) < teps) then
                 LatSymb="R"
                 return
               end if
             end if

         Case(3)
             isnew=.false.
             do i=2,4
                if (  sum(abs(latc(:,1)-Ltr_f(:,i))) < teps  ) then
                   isnew=.true.
                   exit
                end if
             end do
             if(isnew) then
                isnew=.false.
                do i=2,4
                   if (  sum(abs(latc(:,2)-Ltr_f(:,i))) < teps  ) then
                      isnew=.true.
                      exit
                   end if
                end do
             end if
             if(isnew) then
                isnew=.false.
                do i=2,4
                   if (  sum(abs(latc(:,3)-Ltr_f(:,i))) < teps  ) then
                       LatSymb="F"
                       return
                   end if
                end do
             end if

       End Select
       LatSymb="Z"
       return
    End Subroutine Get_Centring_Vectors

    !!----
    !!---- Subroutine Get_Crystal_System(Ng, Ss / Gen, Isystm, Crys)
    !!----    integer,                      intent(in) :: Ng     !  In -> Number of Operators (not related by
    !!----                                                                inversion and lattice traslations)
    !!----    integer, dimension(:,:,:),    intent(in) :: Ss     !  In -> Rotation Part   (3,3,48)
    !!----    or
    !!----    character(len=*),dimension(:),intent(in) :: gen    !  In -> Jones Faithful form of symmetry operators
    !!----    integer,                      intent(out):: ISystm ! Out -> Number for Crystal System
    !!----                                                                 1: Triclinic       2: Monoclinic
    !!----                                                                 3: Orthorrombic    4: Tetragonal
    !!----                                                                 5: Trigonal        6: Hexagonal
    !!----                                                                 7: Cubic
    !!----    character(len=1),             intent(out):: Crys   ! Out -> Symbol of Crystal family
    !!----
    !!----    Obtain the number and string of the Crystal System from a set of operators
    !!----
    !!---- Update: February - 2005
    !!

    !!--++
    !!--++ Subroutine Get_Crystal_System_R_OP(Ng, Ss, Isystm, Crys)
    !!--++    integer,                   intent(in) :: Ng       !  In -> Number of Operators (not related by
    !!--++                                                               inversion and lattice traslations)
    !!--++    integer, dimension(:,:,:), intent(in) :: Ss       !  In -> Rotation Part   (3,3,48)
    !!--++    integer,                   intent(out):: ISystm   ! Out -> Number for Crystal System
    !!--++                                                                1: Triclinic       2: Monoclinic
    !!--++                                                                3: Orthorrombic    4: Tetragonal
    !!--++                                                                5: Trigonal        6: Hexagonal
    !!--++                                                                7: Cubic
    !!--++    character(len=1),          intent(out):: Crys     ! Out -> Symbol of Crystal family
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Obtain the number and string of the Crystal System from a set of operators
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Get_Crystal_System_R_OP(Ng,Ss, Isystm, Crys)
       !---- Arguments ----!
       integer,                   intent(in) :: Ng
       integer, dimension(:,:,:), intent(in) :: Ss    !(3,3,48)
       integer,                   intent(out):: ISystm
       character(len=1),          intent(out):: Crys

       !---- Local variables ----!
       integer   :: i, ndet
       integer   :: nrot_1, nrot_2, nrot_3, nrot_4, nrot_6
       integer   :: nrot_1b, nrot_2b, nrot_3b, nrot_4b, nrot_6b

       nrot_1  = 0
       nrot_2  = 0
       nrot_3  = 0
       nrot_4  = 0
       nrot_6  = 0
       nrot_1b = 0
       nrot_2b = 0
       nrot_3b = 0
       nrot_4b = 0
       nrot_6b = 0

       do i=1,ng
          ndet= Axes_Rotation(ss(:,:,i))
          select case (ndet)
              case (-6)
                 nrot_6b=nrot_6b +1
              case (-4)
                 nrot_4b=nrot_4b +1
              case (-3)
                 nrot_3b=nrot_3b +1
              case (-2)
                 nrot_2b=nrot_2b +1
              case (-1)
                 nrot_1b=nrot_1b +1
              case ( 1)
                 nrot_1 =nrot_1  +1
              case ( 2)
                 nrot_2 =nrot_2  +1
              case ( 3)
                 nrot_3 =nrot_3  +1
              case ( 4)
                 nrot_4 =nrot_4  +1
              case ( 6)
                 nrot_6 =nrot_6  +1
              case default
                 err_symm=.true.
                 ERR_Symm_Mess= " Axes rotation wrong"
                 return
          end select
       end do

       !---- Cubic ----!
       if ( (nrot_3 + nrot_3b == 8) ) then
          isystm = 7
          crys="c"

       !---- Hexagonal ----!
       else if ( (nrot_6 + nrot_6b == 2) ) then
          isystm = 6
          crys="h"

       !---- Trigonal ----!
       else if ( (nrot_3 + nrot_3b == 2) ) then
          isystm = 5
          crys="h"

       !---- Tetragonal ----!
       else if ( (nrot_4 + nrot_4b == 2) ) then
          isystm = 4
          crys="t"

       !---- Orthorhombic ----!
       else if ( (nrot_2 + nrot_2b == 3) ) then
          isystm = 3
          crys="o"

       !---- Monoclinic  ----!
       else if ( (nrot_2 + nrot_2b == 1) ) then
          isystm = 2
          crys="m"

       !---- Triclinic  ----!
       else
          isystm = 1
          crys="a"

       end if

       return
    End Subroutine Get_Crystal_System_R_OP

    !!--++
    !!--++ Subroutine Get_Crystal_System_R_ST(Ng,Gen,Isystm, Crys)
    !!--++    integer,                      intent(in) :: Ng     !  In -> Number of Operators
    !!--++    character(len=*),dimension(:),intent(in) :: gen    !  In -> Jones Faithful form of symmetry operators
    !!--++    integer,                      intent(out):: ISystm ! Out -> Number for Crystal System
    !!--++                                                                1: Triclinic       2: Monoclinic
    !!--++                                                                3: Orthorrombic    4: Tetragonal
    !!--++                                                                5: Trigonal        6: Hexagonal
    !!--++                                                                7: Cubic
    !!--++    character(len=1),             intent(out):: Crys   ! Out -> Symbol of Crystal family
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Obtain the number and string of the Crystal System from a set of operators
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Get_Crystal_System_R_ST(Ng,gen, Isystm, Crys)
       !---- Arguments ----!
       integer,                        intent(in) :: Ng
       character(len=*), dimension(:), intent(in) :: Gen
       integer,                        intent(out):: ISystm
       character(len=1),               intent(out):: Crys

       !---- Local variables ----!
       integer, dimension(3,3,Ng) :: Ss    !(3,3,48)
       integer                    :: i

       do i=1,Ng
          call Read_Xsym(gen(i),1,Ss(:,:,i))
       end do
       call Get_Crystal_System_R_OP(Ng,Ss, Isystm, Crys)

       return
    End Subroutine Get_Crystal_System_R_ST

    !!----
    !!---- Subroutine Get_GenSymb_from_Gener(gen,ngen, SpaceH)
    !!----    character(len=*),dimension(:),  intent(in) :: gen     !  In -> list of generators is string mode
    !!----    integer,                        intent(in) :: ngen    !  In -> number of generators provided
    !!----    character(len=*),              intent(out) :: SpaceH  ! Out -> Generalised Hall Symbol
    !!----
    !!----    Determines a generalised Hall symbol for a space group formed by the symmetry symbols of
    !!----    the provided generators.
    !!----
    !!---- Updated: January - 2014 (JRC)
    !!
    Subroutine Get_GenSymb_from_Gener(gen,ngen,SpaceH)
       !---- Arguments ----!
       character(len=*),dimension(:),  intent(in) :: gen
       integer,                        intent(in) :: ngen
       character(len=*),              intent(out) :: SpaceH

       !----Local variables ----!
       character(len= 1)          :: LatSymb
       character(len=20)          :: centr
       character(len=40)          :: gen_symb
       integer                    :: ng, ini, i, orden,L,j
       integer, dimension(3,3,24) :: ss
       integer, dimension(3,3)    :: nulo,unitm

       real(kind=cp), dimension(3,24)  :: ts
       real(kind=cp), dimension(3,192) :: latc
       real(kind=cp), dimension(3)     :: ts_centre
       logical                         :: centred

       !---- Initial Values ----!
       nulo=0
       unitm=0
       unitm(1,1)=1;  unitm(2,2)=1;  unitm(3,3)=1
       latc=0.0
       centred=.false.
       centr=" "
       SpaceH=" "

       ! --- Test if lattice translations are provide with a symbol in the first generator
       if(index(gen(1),"-I") /= 0) then       !Centric with -1 at 000
         SpaceH="-I"
       else if(index(gen(1),"-A") /= 0) then
         SpaceH="-A"
       else if(index(gen(1),"-B") /= 0) then
         SpaceH="-B"
       else if(index(gen(1),"-C") /= 0) then
         SpaceH="-C"
       else if(index(gen(1),"-R") /= 0) then
         SpaceH="-R"
       else if(index(gen(1),"-F") /= 0) then
         SpaceH="-F"
       else if(index(gen(1),"-Z") /= 0) then
         SpaceH="-Z"
       else if(index(gen(1),"-P") /= 0) then
         SpaceH="-P"
       end if
       if(len_trim(SpaceH) == 0) then           !centric with -1 out of 000 or acentric
           if(index(gen(1),"I") /= 0) then
             SpaceH="I"
           else if(index(gen(1),"A") /= 0) then
             SpaceH="A"
           else if(index(gen(1),"B") /= 0) then
             SpaceH="B"
           else if(index(gen(1),"C") /= 0) then
             SpaceH="C"
           else if(index(gen(1),"R") /= 0) then
             SpaceH="R"
           else if(index(gen(1),"F") /= 0) then
             SpaceH="F"
           else if(index(gen(1),"P") /= 0) then
             SpaceH="P"
           else if(index(gen(1),"Z") /= 0) then
             SpaceH="Z"
           end if
       end if
       LatSymb="P"
       if(len_trim(SpaceH) == 0) then
         ini=1  !If there is a centring lattice it must be given in the list of the generators
       else
         ini=2
         if(len_trim(SpaceH)==1) LatSymb=trim(SpaceH)
       end if
       ng=0
       do i=ini,ngen
         ng=ng+1
         call Read_Xsym(gen(i),1,ss(:,:,ng),ts(:,ng))
       end do
       !Look for lattice translations as generators
       if(ini == 1) then
         L=0
         do i=1,ng
           if(equal_matrix(ss(:,:,i),unitm,3)) then
             L=L+1
             latc(:,L)=ts(:,i)
             ss(:,:,i)=0
           end if
         end do
         if(L > 0) then !There are lattice translations
           call Get_Centring_Vectors(L,latc,LatSymb)
         end if
       end if
       !Look for centre of symmetry as generator
       do i=1,ng
         if(equal_matrix(ss(:,:,i),-unitm,3)) then !Centre of symmetry
           ts_centre=ts(:,i)
           ss(:,:,i)=0
           centred=.true.
           exit
         end if
       end do
       if(centred) then
         if(sum(abs(ts_centre)) < eps_symm) then
             SpaceH="-"//LatSymb
          else
            ts_centre=0.5*ts_centre
            call Frac_Trans_2Dig(ts_centre,centr)
            centr="-1"//trim(centr)
          end if
       else
         if(ini ==1) SpaceH=LatSymb
       end if
       !Construct the symbol
       do i=1,ng
          if(equal_matrix(ss(:,:,i), nulo,3)) cycle
          call symmetry_symbol(ss(:,:,i),ts(:,i),gen_symb)

          if(len_trim(gen_symb) == 0) then
            orden=axes_rotation(ss(:,:,i))
            write(unit=gen_symb,fmt="(i2)") orden
            gen_symb=adjustl(gen_symb)//"[]"
          else
            j=index(gen_symb,")")
            if( j /= 0) then
               gen_symb=gen_symb(1:j)
               j=index(gen_symb,"+")
               gen_symb(j:j)=" "
               gen_symb=pack_string(gen_symb)
            else
               j=index(gen_symb," ")
               gen_symb=gen_symb(1:j)
               j=index(gen_symb,"+")
               gen_symb=gen_symb(1:j-1)
            end if
          end if
          SpaceH=trim(SpaceH)//" "//trim(gen_symb)
       end do
       SpaceH=trim(SpaceH)//" "//trim(centr)
       return
    End Subroutine Get_GenSymb_from_Gener

    !!----
    !!---- Subroutine Get_HallSymb_From_Gener(Spacegroup, Spaceh)
    !!----    type(Space_Group_Type),   intent(in out) :: SpaceGroup   !  In -> SpaceGroup type variable
    !!----                                                               Out -> SpaceGroup type variable
    !!----    character(len=*), intent(out), optional  :: SpaceH       ! Out -> Hall Symbol
    !!----
    !!----    Determines the Hall symbol. In general this routine try to obtain
    !!----    the Hall symbol from generators so you need call Get_So_from_Gener
    !!----    before and call Set_Spgr_Info.It doesn't work for arbitrary settings.
    !!----    If one wants to use arbitrary settings the subroutine Get_GenSymb_from_Gener
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Get_HallSymb_from_Gener(SpaceGroup,SpaceH)
       !---- Arguments ----!
       type(Space_Group_Type), intent(in out)        :: SpaceGroup
       character(len=*),       intent(out), optional :: SpaceH

       !----Local variables ----!
       character(len= 1)        :: axes,axes2
       character(len= 3)        :: tras
       character(len=20)        :: Hall
       character(len=*), dimension(13), parameter :: traslacion =&
                           (/"N","A","B","C","D","U","V","W","1","2","3","4","5"/)

       integer                    :: ng,ngen, ini, i, j, k, orden, nt, npos
       integer, dimension(3)      :: tt, tt1, tt2, tt3
       integer, dimension(6)      :: norden
       integer, dimension(3,3,24) :: ss
       integer, dimension(3,3)    :: ss1
       integer, dimension(3,6), parameter :: lattice=reshape((/0,6,6, 6,0,6, &
                                                     6,6,0, 6,6,6, 8,4,4, 4,8,8/),(/3,6/))
       integer, dimension(3,13), parameter :: tras_val=reshape((/6,6,6, 6,0,0, &
                                       0,6,0, 0,0,6, 3,3,3, 3,0,0, 0,3,0, 0,0,3, &
                                       1,0,0, 2,0,0, 3,0,0, 4,0,0, 5,0,0/),(/3,13/))
       integer, dimension(3,3), parameter  :: x_1   = reshape( &
                                 (/ 1, 0, 0,  0, 1, 0,  0, 0, 1/),(/3,3/))
       integer, dimension(3,3), parameter  :: z_1   = reshape( &
                                 (/ 1, 0, 0,  0, 1, 0,  0, 0, 1/),(/3,3/))
       integer, dimension(3,3), parameter  :: x_2   = reshape( &
                                 (/ 1, 0, 0,  0,-1, 0,  0, 0,-1/),(/3,3/))
       integer, dimension(3,3), parameter  :: y_2   = reshape( &
                                 (/-1, 0, 0,  0, 1, 0,  0, 0,-1/),(/3,3/))
       integer, dimension(3,3), parameter  :: z_2   = reshape( &
                                 (/-1, 0, 0,  0,-1, 0,  0, 0, 1/),(/3,3/))
       integer, dimension(3,3), parameter  :: x_3   = reshape( &
                                 (/ 1, 0, 0,  0, 0, 1,  0,-1,-1/),(/3,3/))
       integer, dimension(3,3), parameter  :: y_3   = reshape( &
                                 (/-1, 0,-1,  0, 1, 0,  1, 0, 0/),(/3,3/))
       integer, dimension(3,3), parameter  :: z_3   = reshape( &
                                 (/ 0, 1, 0, -1,-1, 0,  0, 0, 1/),(/3,3/))
       integer, dimension(3,3), parameter  :: x_4   = reshape( &
                                 (/ 1, 0, 0,  0, 0, 1,  0,-1, 0/),(/3,3/))
       integer, dimension(3,3), parameter  :: y_4   = reshape( &
                                 (/ 0, 0,-1,  0, 1, 0,  1, 0, 0/),(/3,3/))
       integer, dimension(3,3), parameter  :: z_4   = reshape( &
                                 (/ 0, 1, 0, -1, 0, 0,  0, 0, 1/),(/3,3/))
       integer, dimension(3,3), parameter  :: x_6   = reshape( &
                                 (/ 1, 0, 0,  0, 1, 1,  0,-1, 0/),(/3,3/))
       integer, dimension(3,3), parameter  :: y_6   = reshape( &
                                 (/ 0, 0,-1,  0, 1, 0,  1, 0, 1/),(/3,3/))
       integer, dimension(3,3), parameter  :: z_6   = reshape( &
                                 (/ 1, 1, 0, -1, 0, 0,  0, 0, 1/),(/3,3/))
       integer, dimension(3,3), parameter  :: x_2p  = reshape( &
                                 (/-1, 0, 0,  0, 0,-1,  0,-1, 0/),(/3,3/))
       integer, dimension(3,3), parameter  :: y_2p  = reshape( &
                                 (/ 0, 0,-1,  0,-1, 0, -1, 0, 0/),(/3,3/))
       integer, dimension(3,3), parameter  :: z_2p  = reshape( &
                                 (/ 0,-1, 0, -1, 0, 0,  0, 0,-1/),(/3,3/))
       integer, dimension(3,3), parameter  :: x_2pp = reshape( &
                                 (/-1, 0, 0,  0, 0, 1,  0, 1, 0/),(/3,3/))
       integer, dimension(3,3), parameter  :: y_2pp = reshape( &
                                 (/ 0, 0, 1,  0,-1, 0,  1, 0, 0/),(/3,3/))
       integer, dimension(3,3), parameter  :: z_2pp = reshape( &
                                 (/ 0, 1, 0,  1, 0, 0,  0, 0,-1/),(/3,3/))
       integer, dimension(3,3), parameter  :: xyz_3 = reshape( &
                                 (/ 0, 1, 0,  0, 0, 1,  1, 0, 0/),(/3,3/))
       integer, dimension(4,4), parameter :: nulo      = reshape((/0, 0, 0, 0, &
                                                                   0, 0, 0, 0, &
                                                                   0, 0, 0, 0, &
                                                                   0, 0, 0, 0/),(/4,4/))

       real(kind=cp), dimension(3,24)          :: ts
       real(kind=cp), dimension(3)             :: ts1
       type (Gener_Oper_Type),dimension(5) :: generador

       !---- Initial Values ----!
       Hall          = " "
       ngen          = 0
       generador = gener_oper_type(0," "," "," ")

       !---- Load Operators ----!
       ng=SpaceGroup%NumOps
       do i=1,ng
          ss(:,:,i) = SpaceGroup%Symop(i)%rot
          ts(:,  i) = SpaceGroup%Symop(i)%tr
       end do

       !---- Tipo de Red ----!
       select case (SpaceGroup%centred)
          case (0,1)
             hall(1:1)=SpaceGroup%SPG_lat
          case (2)
             hall(1:2)="-"//SpaceGroup%SPG_lat
       end select

       !---- Origen del Centro de inversion ----!
       if (SpaceGroup%centred == 0) then
          ngen=ngen+1
          ini=1
          tras=" "
          tt=nint(12.0*2.0*SpaceGroup%centre_coord)

          select case (SpaceGroup%Bravais)
             case ("A")
                tt1=mod(tt-lattice(:,1)+48,12)
                if (sum(tt1) < sum(tt) ) tt=tt1

             case ("B")
                tt1=mod(tt-lattice(:,2)+48,12)
                if (sum(tt1) < sum(tt) ) tt=tt1

             case ("C")
                tt1=mod(tt-lattice(:,3)+48,12)
                if (sum(tt1) < sum(tt) ) tt=tt1

             case ("I")
                tt1=mod(tt-lattice(:,4)+48,12)
                if (sum(tt1) < sum(tt) ) tt=tt1

             case ("R")
                tt1=mod(tt-lattice(:,5)+48,12)
                tt2=mod(tt-lattice(:,6)+48,12)
                if (sum(tt1) < sum(tt) ) tt=tt1
                if (sum(tt2) < sum(tt) ) tt=tt2

             case ("F")
                tt1=mod(tt-lattice(:,3)+48,12)
                tt2=mod(tt-lattice(:,2)+48,12)
                tt3=mod(tt-lattice(:,1)+48,12)
                if (sum(tt1) < sum(tt) ) tt=tt1
                if (sum(tt2) < sum(tt) ) tt=tt2
                if (sum(tt3) < sum(tt) ) tt=tt3

          end select

          do k=1,3     ! 3 pasadas
             if (tt(1) == 0 .and. tt(2) == 0 .and. tt(3) == 0) exit
             do j=1,8
                tt1=tt-tras_val(:,j)
                if ( all(tt1 >= 0) ) then
                   tras(ini:ini)=l_case(traslacion(j))
                   tt=tt1
                   ini=ini+1
                   exit
                end if
             end do
          end do

          generador(ngen)%orden= -1
          generador(ngen)%axes = "z"
          generador(ngen)%tras=tras
       end if

       !---- Suppress non needed contributions ----!
       do i=1,ng
          if (equal_matrix(ss(1:3,1:3,i), x_2,3) .or.  equal_matrix(ss(1:3,1:3,i),-x_2,3) .or. &
              equal_matrix(ss(1:3,1:3,i), y_2,3) .or.  equal_matrix(ss(1:3,1:3,i),-y_2,3) .or. &
              equal_matrix(ss(1:3,1:3,i), z_2,3) .or.  equal_matrix(ss(1:3,1:3,i),-z_2,3) .or. &
              equal_matrix(ss(1:3,1:3,i), x_3,3) .or.  equal_matrix(ss(1:3,1:3,i),-x_3,3) .or. &
              equal_matrix(ss(1:3,1:3,i), y_3,3) .or.  equal_matrix(ss(1:3,1:3,i),-y_3,3) .or. &
              equal_matrix(ss(1:3,1:3,i), z_3,3) .or.  equal_matrix(ss(1:3,1:3,i),-z_3,3) .or. &
              equal_matrix(ss(1:3,1:3,i), x_4,3) .or.  equal_matrix(ss(1:3,1:3,i),-x_4,3) .or. &
              equal_matrix(ss(1:3,1:3,i), y_4,3) .or.  equal_matrix(ss(1:3,1:3,i),-y_4,3) .or. &
              equal_matrix(ss(1:3,1:3,i), z_4,3) .or.  equal_matrix(ss(1:3,1:3,i),-z_4,3) .or. &
              equal_matrix(ss(1:3,1:3,i), x_6,3) .or.  equal_matrix(ss(1:3,1:3,i),-x_6,3) .or. &
              equal_matrix(ss(1:3,1:3,i), y_6,3) .or.  equal_matrix(ss(1:3,1:3,i),-y_6,3) .or. &
              equal_matrix(ss(1:3,1:3,i), z_6,3) .or.  equal_matrix(ss(1:3,1:3,i),-z_6,3) .or. &
              equal_matrix(ss(1:3,1:3,i), x_2p,3).or.  equal_matrix(ss(1:3,1:3,i),-x_2p,3).or. &
              equal_matrix(ss(1:3,1:3,i), y_2p,3).or.  equal_matrix(ss(1:3,1:3,i),-y_2p,3).or. &
              equal_matrix(ss(1:3,1:3,i), z_2p,3).or.  equal_matrix(ss(1:3,1:3,i),-z_2p,3).or. &
              equal_matrix(ss(1:3,1:3,i), x_2pp,3).or. equal_matrix(ss(1:3,1:3,i),-x_2pp,3).or. &
              equal_matrix(ss(1:3,1:3,i), y_2pp,3).or. equal_matrix(ss(1:3,1:3,i),-y_2pp,3).or. &
              equal_matrix(ss(1:3,1:3,i), z_2pp,3).or. equal_matrix(ss(1:3,1:3,i),-z_2pp,3).or. &
              equal_matrix(ss(1:3,1:3,i), xyz_3,3).or. equal_matrix(ss(1:3,1:3,i),-xyz_3,3) ) cycle

              ss(:,:,i)=0
       end do

       !---- Ordering following Order of rotations ----!
       norden=0
       do i=1,ng
          if (equal_matrix(ss(1:3,1:3,i),nulo(1:3,1:3),3)) cycle
           orden=axes_rotation(ss(1:3,1:3,i))
          norden(abs(orden))=norden(abs(orden))+1
       end do

       npos=0
       do j=6,1,-1
          if (norden(j) == 0) cycle
          do i=1,ng
             if (equal_matrix(ss(1:3,1:3,i),nulo(1:3,1:3),3)) cycle
              orden=axes_rotation(ss(1:3,1:3,i))
             if (abs(orden) == j) then
                ss1=ss(:,:,i)
                ts1=ts(:,i)
                npos=npos+1
                ss(:,:,i)=ss(:,:,npos)
                ts(:,i)  =ts(:,npos)
                ss(:,:,npos)=ss1
                ts(:,npos)  =ts1
             end if
          end do
       end do
       nt=npos

       if (nt == 0) then
          ngen=ngen+1
          generador(ngen)%orden= 1
          generador(ngen)%axes = "z"
          generador(ngen)%tras= " "
       end if

       !---- Ordering following axes Direction ----!
       norden=0
       do i=1,nt
          if (equal_matrix(ss(1:3,1:3,i),nulo(1:3,1:3),3)) cycle
          orden=axes_rotation(ss(1:3,1:3,i))
          norden(abs(orden))=norden(abs(orden))+1
       end do
       if (norden(6) > 0) norden(3)=0

       do i=1,nt
          orden=0
          axes =" "
          axes2=" "
          tras ="  "
          orden=axes_rotation(ss(1:3,1:3,i))
          if (norden(abs(orden)) == 0) cycle
          select case (abs(orden))
              case (1)
                 if (orden > 0) then
                    if (equal_matrix(ss(1:3,1:3,i),z_1,3)) then
                       axes="z"
                    end if
                 else
                    if (equal_matrix(ss(1:3,1:3,i),-z_1,3)) then
                       axes="z"
                    end if
                 end if

              case (2)
                 if (orden > 0) then
                    if (equal_matrix(ss(1:3,1:3,i),x_2,3)) then
                       axes="x"
                    else if (equal_matrix(ss(1:3,1:3,i),y_2,3)) then
                       axes="y"
                    else if (equal_matrix(ss(1:3,1:3,i),z_2,3)) then
                       axes="z"
                    else if (equal_matrix(ss(1:3,1:3,i),x_2p,3)) then
                       axes="'"
                       axes2="x"
                    else if (equal_matrix(ss(1:3,1:3,i),y_2p,3)) then
                       axes="'"
                       axes2="y"
                    else if (equal_matrix(ss(1:3,1:3,i),z_2p,3)) then
                       axes="'"
                       axes2="z"
                    else if (equal_matrix(ss(1:3,1:3,i),x_2pp,3)) then
                       axes=""""
                       axes2="x"
                    else if (equal_matrix(ss(1:3,1:3,i),y_2pp,3)) then
                       axes=""""
                       axes2="y"
                    else if (equal_matrix(ss(1:3,1:3,i),z_2pp,3)) then
                       axes=""""
                       axes2="z"
                    end if
                 else
                    if (equal_matrix(ss(1:3,1:3,i),-x_2,3)) then
                       axes="x"
                    else if (equal_matrix(ss(1:3,1:3,i),-y_2,3)) then
                       axes="y"
                    else if (equal_matrix(ss(1:3,1:3,i),-z_2,3)) then
                       axes="z"
                    else if (equal_matrix(ss(1:3,1:3,i),-x_2p,3)) then
                       axes="'"
                       axes2="x"
                    else if (equal_matrix(ss(1:3,1:3,i),-y_2p,3)) then
                       axes="'"
                       axes2="y"
                    else if (equal_matrix(ss(1:3,1:3,i),-z_2p,3)) then
                       axes="'"
                       axes2="z"
                    else if (equal_matrix(ss(1:3,1:3,i),-x_2pp,3)) then
                       axes=""""
                       axes2="x"
                    else if (equal_matrix(ss(1:3,1:3,i),-y_2pp,3)) then
                       axes=""""
                       axes2="y"
                    else if (equal_matrix(ss(1:3,1:3,i),-z_2pp,3)) then
                       axes=""""
                       axes2="z"
                    end if
                 end if

              case (3)
                 if (orden > 0) then
                    if (equal_matrix(ss(1:3,1:3,i),x_3,3)) then
                       axes="x"
                    else if (equal_matrix(ss(1:3,1:3,i),y_3,3)) then
                       axes="y"
                    else if (equal_matrix(ss(1:3,1:3,i),z_3,3)) then
                       axes="z"
                    else if (equal_matrix(ss(1:3,1:3,i),xyz_3,3)) then
                       axes="*"
                    end if
                 else
                    if (equal_matrix(ss(1:3,1:3,i),-x_3,3)) then
                       axes="x"
                    else if (equal_matrix(ss(1:3,1:3,i),-y_3,3)) then
                       axes="y"
                    else if (equal_matrix(ss(1:3,1:3,i),-z_3,3)) then
                       axes="z"
                    else if (equal_matrix(ss(1:3,1:3,i),-xyz_3,3)) then
                       axes="*"
                    end if
                 end if

              case (4)
                 if (orden > 0) then
                    if (equal_matrix(ss(1:3,1:3,i),x_4,3)) then
                       axes="x"
                    else if (equal_matrix(ss(1:3,1:3,i),y_4,3)) then
                       axes="y"
                    else if (equal_matrix(ss(1:3,1:3,i),z_4,3)) then
                       axes="z"
                    end if
                 else
                    if (equal_matrix(ss(1:3,1:3,i),-x_1,3)) then
                       axes="x"
                    else if (equal_matrix(ss(1:3,1:3,i),-y_4,3)) then
                       axes="y"
                    else if (equal_matrix(ss(1:3,1:3,i),-z_4,3)) then
                       axes="z"
                    end if
                 end if

              case (6)
                 if (orden > 0) then
                    if (equal_matrix(ss(1:3,1:3,i),x_6,3)) then
                       axes="x"
                    else if (equal_matrix(ss(1:3,1:3,i),y_6,3)) then
                       axes="y"
                    else if (equal_matrix(ss(1:3,1:3,i),z_6,3)) then
                       axes="z"
                    end if
                 else
                    if (equal_matrix(ss(1:3,1:3,i),-x_6,3)) then
                       axes="x"
                    else if (equal_matrix(ss(1:3,1:3,i),-y_6,3)) then
                       axes="y"
                    else if (equal_matrix(ss(1:3,1:3,i),-z_6,3)) then
                       axes="z"
                    end if
                 end if

          end select

          !---- Translations ----!
          tt=mod(nint(ts(:,i)*12.0)+48,12)

           select case (SpaceGroup%Bravais)
             case ("A")
                tt1=mod(tt-lattice(:,1)+48,12)
                if (sum(tt1) < sum(tt) ) tt=tt1

             case ("B")
                tt1=mod(tt-lattice(:,2)+48,12)
                if (sum(tt1) < sum(tt) ) tt=tt1

             case ("C")
                tt1=mod(tt-lattice(:,3)+48,12)
                if (sum(tt1) < sum(tt) ) tt=tt1

             case ("I")
                tt1=mod(tt-lattice(:,4)+48,12)
                if (sum(tt1) < sum(tt) ) tt=tt1

             case ("R")
                tt1=mod(tt-lattice(:,5)+48,12)
                tt2=mod(tt-lattice(:,6)+48,12)
                if (sum(tt1) < sum(tt) ) tt=tt1
                if (sum(tt2) < sum(tt) ) tt=tt2

             case ("F")
                tt1=mod(tt-lattice(:,3)+48,12)
                tt2=mod(tt-lattice(:,2)+48,12)
                tt3=mod(tt-lattice(:,1)+48,12)
                if (sum(tt1) < sum(tt) ) tt=tt1
                if (sum(tt2) < sum(tt) ) tt=tt2
                if (sum(tt3) < sum(tt) ) tt=tt3

          end select

          ini=1

          !---- Fractional translation ----!
          select case (abs(orden))
              case (3)
                 select case (axes)
                     case ("x")
                        if (tt(2) == 0 .and. tt(3) == 0) then
                           select case (tt(1))
                              case (4)              ! 31
                                 tras(ini:ini)="1"
                                 tt(1)=0

                              case (8)              ! 32
                                 tras(ini:ini)="2"
                                 tt(1)=0
                           end select
                        end if

                     case ("y")
                        if (tt(1) == 0 .and. tt(3) == 0) then
                           select case (tt(2))
                              case (4)              ! 31
                                 tras(ini:ini)="1"
                                 tt(2)=0

                              case (8)              ! 32
                                 tras(ini:ini)="2"
                                 tt(2)=0
                           end select
                        end if
                     case ("z")
                        if (tt(1) == 0 .and. tt(2) == 0) then
                           select case (tt(3))
                              case (4)              ! 31
                                 tras(ini:ini)="1"
                                 tt(3)=0

                              case (8)              ! 32
                                 tras(ini:ini)="2"
                                 tt(3)=0
                           end select
                        end if

                 end select

              case (6)
                 select case (axes)
                     case ("x")
                        if (tt(2) == 0 .and. tt(3) ==0) then
                           select case (tt(1))
                              case (2)              ! 61
                                 tras(ini:ini)="1"
                                 tt(1)=0

                              case (4)              ! 62
                                 tras(ini:ini)="2"
                                 tt(1)=0

                              case (8)              ! 64
                                 tras(ini:ini)="4"
                                 tt(1)=0

                              case(10)
                                 tras(ini:ini)="5"  ! 65
                                 tt(1)=0

                           end select
                        end if

                     case ("y")
                        if (tt(1) == 0 .and. tt(3) == 0) then
                           select case (tt(2))
                              case (2)              ! 61
                                 tras(ini:ini)="1"
                                 tt(2)=0

                              case (4)              ! 62
                                 tras(ini:ini)="2"
                                 tt(2)=0

                              case (8)              ! 64
                                 tras(ini:ini)="4"
                                 tt(2)=0

                              case(10)
                                 tras(ini:ini)="5"  ! 65
                                 tt(2)=0

                           end select
                        end if

                     case ("z")
                        if (tt(1) == 0 .and. tt(2) == 0) then
                           select case (tt(3))
                              case (2)              ! 61
                                 tras(ini:ini)="1"
                                 tt(3)=0

                              case (4)              ! 62
                                 tras(ini:ini)="2"
                                 tt(3)=0

                              case (8)              ! 64
                                 tras(ini:ini)="4"
                                 tt(3)=0

                              case(10)
                                 tras(ini:ini)="5"  ! 65
                                 tt(3)=0

                           end select
                        end if

                 end select
          end select

          !---- Translation vector ----!
          do k=1,3     ! 3 pasadas
             if (tt(1) == 0 .and. tt(2) == 0 .and. tt(3) == 0) exit

             do j=1,8
                tt1=tt-tras_val(:,j)
                if ( all(tt1 >= 0) ) then
                   tras(ini:ini)=l_case(traslacion(j))
                   tt(:)=tt1(:)
                   ini=ini+1
                   exit
                end if
             end do

          end do

          !---- Last check ----!
          if (nt == 1) then
             ngen=ngen+1
             generador(ngen)%orden= orden
             generador(ngen)%axes = axes
             generador(ngen)%tras = tras
          else
             if (norden(6) > 0) then
                if (abs(orden) == 6 .and. axes =="z") then
                   ngen=ngen+1

                   if (ngen > 4) then
                      err_symm=.true.
                      ERR_Symm_Mess=" Error in generators"
                      return
                   end if
                   generador(ngen)%orden= orden
                   generador(ngen)%axes = axes
                   generador(ngen)%tras = tras
                end if

                if (abs(orden) == 2 .and. (axes == "'" .or. axes =="""") .and. &
                    axes2 == "z") then
                   ngen=ngen+1

                   if (ngen > 4) then
                      err_symm=.true.
                      ERR_Symm_Mess=" Error in generators"
                      return
                   end if
                   generador(ngen)%orden= orden
                   generador(ngen)%axes = axes
                   generador(ngen)%axes2= axes2
                   generador(ngen)%tras = tras
                end if
             end if

             if (norden(4) > 0) then
                if (abs(orden) == 4 .and. axes =="z") then
                   ngen=ngen+1

                   if (ngen > 4) then
                      err_symm=.true.
                      ERR_Symm_Mess=" Error in generators"
                      return
                   end if
                   generador(ngen)%orden= orden
                   generador(ngen)%axes = axes
                   generador(ngen)%tras = tras
                end if

                if (abs(orden) == 3 .and. axes == "*") then
                   ngen=ngen+1

                   if (ngen > 4) then
                      err_symm=.true.
                      ERR_Symm_Mess=" Error in generators"
                      return
                   end if
                   generador(ngen)%orden= orden
                   generador(ngen)%axes = axes
                   generador(ngen)%tras = tras
                end if

                if (abs(orden) == 2 .and. axes == "x") then
                   ngen=ngen+1

                   if (ngen > 4) then
                      err_symm=.true.
                      ERR_Symm_Mess=" Error in generators"
                      return
                   end if
                   generador(ngen)%orden= orden
                   generador(ngen)%axes = axes
                   generador(ngen)%tras = tras
                end if
             end if

             if (norden(3) > 0 .and. norden(4) == 0) then
                if (abs(orden) == 3 .and. (axes =="z" .or. axes == "*")) then
                   ngen=ngen+1

                   if (ngen > 4) then
                      err_symm=.true.
                      ERR_Symm_Mess=" Error in generators"
                      return
                   end if
                   generador(ngen)%orden= orden
                   generador(ngen)%axes = axes
                   generador(ngen)%tras = tras
                end if

                if ( (abs(orden) == 2 .and. axes == "z")  .or. &
                     (abs(orden) == 2 .and. axes == "x")  .or. &
                     (abs(orden) == 2 .and. axes == "'")  .or. &
                     (abs(orden) == 2 .and. axes == """")) then
                   ngen=ngen+1

                   if (ngen > 4) then
                      err_symm=.true.
                      ERR_Symm_Mess=" Error in generators"
                      return
                   end if
                   generador(ngen)%orden= orden
                   generador(ngen)%axes = axes
                   generador(ngen)%axes2= axes2
                   generador(ngen)%tras = tras
                end if
             end if

             if (norden(2) > 0 .and. norden(3) == 0 .and. norden(4) == 0  &
                .and. norden(6) == 0) then
                if (abs(orden) == 2 .and. axes == "z") then
                   ngen=ngen+1

                   if (ngen > 4) then
                      err_symm=.true.
                      ERR_Symm_Mess=" Error in generators"
                      return
                   end if
                   generador(ngen)%orden= orden
                   generador(ngen)%axes = axes
                   generador(ngen)%tras = tras
                end if
                if (abs(orden) == 2 .and. axes == "x") then
                   ngen=ngen+1

                   if (ngen > 4) then
                      err_symm=.true.
                      ERR_Symm_Mess=" Error in generators"
                      return
                   end if
                   generador(ngen)%orden= orden
                   generador(ngen)%axes = axes
                   generador(ngen)%tras = tras
                end if
             end if

          end if
       end do

       !---- Purge Generators ----!
       j=0
       k=0
       if (ngen > 1) then
          do i=1,ngen
             if (generador(i)%axes =="'") j=i
             if (generador(i)%axes =="""") k=i
          end do
          if (j /= 0 .and. k /=0) then
             if (generador(j)%axes2 =="z") then
                do i=k+1,ngen
                   generador(i-1)=generador(i)
                end do
                ngen=ngen-1
             else
                do i=j+1,ngen
                   generador(i-1)=generador(i)
                end do
                ngen=ngen-1
             end if
          end if
       end if

       !---- Order Generators ----!
       select case (ngen)
          case (2)
             if (abs(generador(1)%orden) < abs(generador(2)%orden)) then
                generador(5)=generador(1)
                generador(1)=generador(2)
                generador(2)=generador(5)
             else if (abs(generador(1)%orden) == abs(generador(2)%orden)) then
                if (generador(2)%axes == "z") then
                   generador(5)=generador(1)
                   generador(1)=generador(2)
                   generador(2)=generador(5)
                end if
             end if
          case (3)
             do i=1,3
                if (abs(generador(i)%orden) == 1 .or. abs(generador(i)%orden) == 3) then
                   generador(5)=generador(i)
                   do j=i+1,3
                      generador(j-1)=generador(j)
                   end do
                   generador(3)=generador(5)
                end if
             end do
             if (abs(generador(1)%orden) < abs(generador(2)%orden)) then
                generador(5)=generador(1)
                generador(1)=generador(2)
                generador(2)=generador(5)
             else if (abs(generador(1)%orden) == abs(generador(2)%orden)) then
                if (generador(2)%axes == "z") then
                   generador(5)=generador(1)
                   generador(1)=generador(2)
                   generador(2)=generador(5)
                end if
             end if

          case (4)
             do i=1,4
                if (abs(generador(i)%orden) == 1) then
                   generador(5)=generador(i)
                   do j=i+1,4
                      generador(j-1)=generador(j)
                   end do
                   generador(4)=generador(5)
                end if
             end do
             do i=1,3
                if (abs(generador(i)%orden) == 3) then
                   generador(5)=generador(i)
                   do j=i+1,3
                      generador(j-1)=generador(j)
                   end do
                   generador(3)=generador(5)
                end if
             end do
             if (abs(generador(1)%orden) < abs(generador(2)%orden)) then
                generador(5)=generador(1)
                generador(1)=generador(2)
                generador(2)=generador(5)
             else if (abs(generador(1)%orden) == abs(generador(2)%orden)) then
                if (generador(2)%axes == "z") then
                   generador(5)=generador(1)
                   generador(1)=generador(2)
                   generador(2)=generador(5)
                end if
             end if

       end select

       !---- Hall Symbol ----!
       ini=len_trim(hall)
       ini=ini+1

       do i=1,ngen
          !---- Rotation ----!
          if (generador(i)%orden >0) then
             ini=ini+1
             write(unit=hall(ini:ini),fmt="(i1)") generador(i)%orden
          else
             ini=ini+1
             write(unit=hall(ini:ini+1),fmt="(i2)") generador(i)%orden
             ini=ini+1
          end if

          !---- Axis ----!
          select case (i)
             case (1)
                if (generador(i)%axes /= "z") then
                   ini=ini+1
                   hall(ini:ini)=generador(i)%axes
                end if

             case (2)
                if (abs(generador(i)%orden) == 2) then
                   if (abs(generador(1)%orden) == 2 .or. abs(generador(1)%orden) == 4) then
                      if (generador(i)%axes /= "x") then
                         ini=ini+1
                         hall(ini:ini)=generador(i)%axes
                      end if
                   else if (abs(generador(1)%orden) == 3 .or. abs(generador(1)%orden) == 6) then
                      if (generador(i)%axes /= "'") then
                         ini=ini+1
                         hall(ini:ini)=generador(i)%axes
                      end if
                   end if

                else
                   if (abs(generador(i)%orden) /= 1) then
                      ini=ini+1
                      hall(ini:ini)=generador(i)%axes
                   end if
                end if

             case (3)
                if (abs(generador(i)%orden) /= 3 .and. abs(generador(i)%orden) /= 1) then
                   ini=ini+1
                   hall(ini:ini)=generador(i)%axes
                end if

             case (4)

          end select

          !---- Translation ----!
          select case (len_trim(generador(i)%tras))
             case (1)
                ini=ini+1
                hall(ini:ini)=generador(i)%tras

             case (2)
                ini=ini+1
                hall(ini:ini+1)=generador(i)%tras
                ini=ini+1

             case (3)
                ini=ini+1
                hall(ini:ini+2)=generador(i)%tras
                ini=ini+2

          end select
          ini=ini+1
       end do

       !---- Check the Hall Symbol for repetitions of minus sign ----!

       i=index(hall,"-")
       if(i /= 0 ) then
         k=index(hall,"-",back=.true.)
         if(k /= i ) then
           hall=hall(1:k-1)//hall(k+1:)
         end if
       end if

       !---- Is the Hall Symbol in the table? ----!
       k=0
       do i=1,num_spgr_info
          if (hall(1:16) == spgr_info(i)%hall) then
             k=i
             exit
          end if
       end do

       if(hall(1:1) /= "-") hall=" "//hall
       Spacegroup%Hall=hall

       if (k /= 0) then
          SpaceGroup%NumSpg       = spgr_info(k)%n
          SpaceGroup%Spg_Symb     = spgr_info(k)%hm
                call get_laue_str(spgr_info(k)%laue,SpaceGroup%Laue)
                call get_PointGroup_str(spgr_info(k)%pg,SpaceGroup%PG)
          SpaceGroup%Info         = spgr_info(k)%inf_extra
          SpaceGroup%R_Asym_Unit(1,1) = real(spgr_info(k)%asu(1))/24.0
          SpaceGroup%R_Asym_Unit(2,1) = real(spgr_info(k)%asu(2))/24.0
          SpaceGroup%R_Asym_Unit(3,1) = real(spgr_info(k)%asu(3))/24.0
          SpaceGroup%R_Asym_Unit(1,2) = real(spgr_info(k)%asu(4))/24.0
          SpaceGroup%R_Asym_Unit(2,2) = real(spgr_info(k)%asu(5))/24.0
          SpaceGroup%R_Asym_Unit(3,2) = real(spgr_info(k)%asu(6))/24.0
       else
          SpaceGroup%Spg_Symb     = "Unknown"
          SpaceGroup%Info         = "User-provided generators "

       end if

       if (present(SpaceH) ) SpaceH=hall

       return
    End Subroutine Get_HallSymb_from_Gener

    !!----
    !!---- Subroutine Get_Lattice_Type(L, Latc, Lattyp)
    !!----    integer,                        intent(in)  :: L         !  number of centring vectors
    !!----    real(kind=cp), dimension(:,:),  intent(in)  :: Latc      ! (3,11) centring vectors
    !!----    character(len=*),               intent(out) :: lattyp    ! Lattice symbol
    !!----
    !!----    Subroutine to get the lattice symbol from a set of centring vectors.
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Get_Lattice_Type(L, Latc, lattyp)
       !---- Arguments ----!
       integer,                        intent( in) :: L
       real(kind=cp), dimension(:,:),  intent( in) :: Latc
       character(len=*),               intent(out) :: lattyp

       !---- Local variables ----!
       logical :: latt_p, latt_a, latt_b, latt_c, latt_i, latt_r, latt_f, latt_z
       integer, dimension(6) :: latt_given
       integer, dimension(3) :: tt
       integer               :: i, j
       integer, dimension(3,6), parameter :: lattice=reshape((/0,6,6, 6,0,6, &
                                                     6,6,0, 6,6,6, 8,4,4, 4,8,8/),(/3,6/))

       if (l > 3) then  !non conventional centring
          lattyp="Z"
          return
       else if(l == 0) then !primitive lattice
          lattyp="P"
          return
       end if

       latt_p=.true.
       latt_a=.false.
       latt_b=.false.
       latt_c=.false.
       latt_i=.false.
       latt_r=.false.
       latt_f=.false.
       latt_z=.false.

       do i=1,L
          tt(1:3)=nint(12.0 * Latc(1:3,i))   ! Translations x 12

          !---- Compare the translation part of the operator with tabulated array ----!
          latt_given(:) = 0
          do j=1,6
             if (equal_vector(tt,lattice(:,j),3)) then
                latt_given(j) = 1
                select case (j)
                   case (1)
                      latt_a=.true.
                   case (2)
                      latt_b=.true.
                   case (3)
                      latt_c=.true.
                   case (4)
                      latt_i=.true.
                   case (5,6)
                      latt_r=.true.
                end select
                exit
             end if
          end do
          if (sum(latt_given) == 0) then
             latt_z = .true.
             exit
          end if
       end do

       !---- Lattice Type ----!
       if (latt_z) then
           lattyp="Z"
           return
       end if
       if ( (latt_a .and. latt_b .and. latt_c) .or. (latt_a .and. latt_b) .or. &
            (latt_a .and. latt_c) .or. (latt_b .and. latt_c) ) then
            latt_f=.true.
            latt_a=.false.
            latt_b=.false.
            latt_c=.false.
            latt_p=.false.
            latt_i=.false.
       end if
       if (latt_p) lattyp="P"
       if (latt_a) lattyp="A"
       if (latt_b) lattyp="B"
       if (latt_c) lattyp="C"
       if (latt_i) lattyp="I"
       if (latt_r) lattyp="R"
       if (latt_f) lattyp="F"

       return
    End Subroutine Get_Lattice_Type

    !!----
    !!---- Subroutine Get_Laue_Pg(Spacegroup, Laue_Car, Point_Car)
    !!----    type (Space_Group_Type),  intent( in) :: SpaceGroup   !  In -> Space Group type variable
    !!----    character(len=*),         intent(out) :: Laue_car     ! Out -> String with Laue symbol
    !!----    character(len=*),         intent(out) :: Point_car    ! Out -> String with Point Group symbol
    !!----
    !!----    Subroutine to get the information of Laue and Point Group.
    !!----    Vvalid only for conventional bases for Point Group
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Get_Laue_PG(SpaceGroup, Laue_car, Point_car)
       !---- Arguments ----!
       type (Space_Group_Type),  intent( in) :: SpaceGroup
       character (len=*),        intent(out) :: Laue_car
       character (len=*),        intent(out) :: Point_car

       !---- Local variables ----!
       integer :: nrot_1, nrot_1b
       integer :: nrot_2, nrot_2b
       integer :: nrot_3, nrot_3b
       integer :: nrot_4, nrot_4b
       integer :: nrot_6, nrot_6b
       integer :: i,n_m,ndet,ind

       !---- Initializing ----!
       point_car=" "
       laue_car=" "

       nrot_1  = 0
       nrot_2  = 0
       nrot_3  = 0
       nrot_4  = 0
       nrot_6  = 0
       nrot_1b = 0
       nrot_2b = 0
       nrot_3b = 0
       nrot_4b = 0
       nrot_6b = 0
       n_m = 0

       call init_err_symm()
       if (spacegroup%numops == 0) then
          err_symm=.true.
          ERR_Symm_Mess=" No symmetry operators are given"
          return
       end if
       do i=1,spacegroup%numops
          ndet= Axes_Rotation(SpaceGroup%Symop(i)%Rot(:,:))
          select case (ndet)
             case (-6)
                nrot_6b=nrot_6b +1
             case (-4)
                nrot_4b=nrot_4b +1
             case (-3)
                nrot_3b=nrot_3b +1
             case (-2)
                nrot_2b=nrot_2b +1
             case (-1)
                nrot_1b=nrot_1b +1
             case ( 1)
                nrot_1 =nrot_1  +1
             case ( 2)
                nrot_2 =nrot_2  +1
             case ( 3)
                nrot_3 =nrot_3  +1
             case ( 4)
                nrot_4 =nrot_4  +1
             case ( 6)
                nrot_6 =nrot_6  +1
             case default
                err_symm=.true.
                ERR_Symm_Mess=" Rotation Not Determined"
                return
          end select
       end do

       n_m = nrot_1  + nrot_2  + nrot_3  + nrot_4  + nrot_6  + &
             nrot_1b + nrot_2b + nrot_3b + nrot_4b + nrot_6b

       !---- Cubic ----!
       if ( (nrot_3 + nrot_3b == 8) ) then
          select case (n_m)
             case (12)
                if (SpaceGroup%Centred ==1) then
                   point_car="23"
                else
                   point_car="m-3"
                end if
                laue_car="m-3"

             case (24)
                if (SpaceGroup%Centred /=1) then
                   point_car="m-3m"
                else
                   if (nrot_4  == 6) point_car="432"
                   if (nrot_4b == 6) point_car="-43m"
                end if
                laue_car="m-3m"
          end select

       !---- Hexagonal ----!
       else if ( (nrot_6 + nrot_6b == 2) ) then
          select case (n_m)
             case (6)
                if (SpaceGroup%Centred /=1) then
                   point_car="6/m"
                else
                   if (nrot_6  == 2) point_car="6"
                   if (nrot_6b == 2) point_car="-6"
                end if
                laue_car="6/m"

             case (12)
                if (SpaceGroup%Centred /=1) then
                   point_car="6/mmm"
                else
                   if (nrot_6b == 2) then
                      do i=1,spacegroup%numops
                         ndet= Axes_Rotation(SpaceGroup%Symop(i)%Rot(:,:))
                         if (ndet /= 2) cycle
                         !---- This is only valid for conventional bases ---!
                         call SearchOp(SpaceGroup%Symop(i)%Rot(:,:),25,36,ind)
                         if (ind < 0) then
                            ind=-ind-12
                         end if
                         select case (ind)
                            case (31)
                               point_car="-62m"
                            case default
                               point_car="-6m2"
                         end select
                         exit
                      end do
                   end if
                   if ( (nrot_6  == 2 .and. nrot_2 == 7) ) point_car="622"
                   if ( (nrot_6  == 2 .and. nrot_2b== 6) ) point_car="6mm"
                end if
                laue_car="6/mmm"
          end select

       !---- Trigonal ----!
       else if ( (nrot_3 + nrot_3b == 2) ) then
          select case (n_m)
             case (3)
                if (SpaceGroup%Centred /=1) then
                   point_car="-3"
                else
                   point_car="3"
                end if
                laue_car="-3"

             case (6)
                if (SpaceGroup%Hexa) then
                   if (SpaceGroup%Centred /=1) then
                      do i=1,spacegroup%numops
                           ndet=Axes_Rotation(SpaceGroup%Symop(i)%Rot(:,:))
                           if (ndet /= -2) cycle
                         !---- This is only valid for conventional bases ---!
                         call SearchOp(SpaceGroup%Symop(i)%Rot(:,:),25,36,ind)
                         if (ind < 0) then
                            ind=-ind-12
                         end if
                         select case (ind)
                            case (22)
                               point_car="-31m"
                               laue_car ="-31m"
                            case default
                               point_car="-3m"
                               laue_car ="-3m"
                         end select
                         exit
                      end do
                   else
                      if (nrot_2  == 3 ) then
                         do i=1,spacegroup%numops
                            ndet=Axes_Rotation(SpaceGroup%Symop(i)%Rot(:,:))
                            if (ndet /= 2) cycle
                            !---- This is only valid for conventional bases ---!
                            call SearchOp(SpaceGroup%Symop(i)%Rot(:,:),25,36,ind)
                            if (ind < 0) then
                               ind=-ind-12
                            end if
                            select case (ind)
                               case (34)
                                  point_car="-312"
                                  laue_car ="-31m"
                               case default
                                  point_car="-32"
                                  laue_car ="-3m"
                            end select
                            exit
                         end do
                      end if

                      if (nrot_2b == 3 ) then
                         do i=1,spacegroup%numops
                            ndet=Axes_Rotation(SpaceGroup%Symop(i)%Rot(:,:))
                            if (ndet /= -2) cycle
                            !---- This is only valid for conventional bases ---!
                            call SearchOp(SpaceGroup%Symop(i)%Rot(:,:),25,36,ind)
                            if (ind < 0) then
                               ind=-ind-12
                            end if
                            select case (ind)
                               case (22)
                                  point_car="31m"
                                  laue_car ="-31m"
                               case default
                                  point_car="3m"
                                  laue_car ="-3m"
                            end select
                            exit
                         end do
                      end if
                   end if
                else
                   if (SpaceGroup%Centred /=1) then
                      point_car="-3m"
                   else
                      if (nrot_2  == 3 ) point_car="32"
                      if (nrot_2b == 3 ) point_car="3m"
                   end if
                   laue_car="-3m"
                end if

          end select

       !---- Tetragonal ----!
       else if ( (nrot_4 + nrot_4b == 2) ) then
          select case (n_m)
             case (4)
                if (SpaceGroup%Centred /=1) then
                   point_car="4/m"
                else
                   if (nrot_4  == 2 ) point_car="4"
                   if (nrot_4b == 2 ) point_car="-4"
                end if
                laue_car="4/m"

             case (8)
                if (SpaceGroup%Centred /=1) then
                   point_car="4/mmm"
                else
                   if (nrot_4b == 2 ) then
                   do i=1,spacegroup%numops
                         ndet=Axes_Rotation(SpaceGroup%Symop(i)%Rot(:,:))
                      if (ndet /= -2) cycle
                      !---- This is only valid for conventional bases ---!
                      call SearchOp(SpaceGroup%Symop(i)%Rot(:,:),1,24,ind)
                      if (ind < 0) then
                         ind=24-ind
                      end if
                      select case (ind)
                         case (28)
                            point_car="-4m2"
                         case default
                            point_car="-42m"
                      end select
                      exit
                   end do
                end if
                if ( (nrot_4  == 2 .and. nrot_2 == 5) ) point_car="422"
                if ( (nrot_4  == 2 .and. nrot_2b== 4) ) point_car="4mm"
             end if
             laue_car="4/mmm"

          end select

       !---- Orthorhombic ----!
       else if ( (nrot_2 + nrot_2b == 3) ) then
          if (SpaceGroup%Centred /=1) then
             point_car="mmm"
          else
             if (nrot_2  == 3 ) point_car="222"
             if (nrot_2b == 2 ) then
                do i=1,spacegroup%numops
                       ndet=Axes_Rotation(SpaceGroup%Symop(i)%Rot(:,:))
                   if (ndet /= 2) cycle
                   !---- This is only valid for conventional bases ---!
                   call SearchOp(SpaceGroup%Symop(i)%Rot(:,:),1,24,ind)
                   select case (ind)
                      case (4)
                         point_car="2mm"
                      case (3)
                         point_car="m2m"
                      case default
                         point_car="mm2"
                   end select
                   exit
                end do
             end if
          end if
          laue_car="mmm"

       !---- Monoclinic ----!
       else if ( (nrot_2 + nrot_2b == 1)  ) then
          if (SpaceGroup%Centred /=1) then
             point_car="2/m"
          else
             if (nrot_2  == 1 ) point_car="2"
             if (nrot_2b == 1 ) point_car="m"
          end if
          laue_car="2/m"

       !---- Triclinic ----!
       else if (n_m == 1) then
          if (SpaceGroup%Centred /=1) then
             point_car="-1"
          else
             point_car="1"
          end if
          laue_car="-1"

       end if

       return
    End Subroutine Get_Laue_PG

    !!----
    !!---- Subroutine Get_Laue_Str(Ilaue,Laue_Str)
    !!----    integer,          intent( in) :: ilaue         !  In -> Ordinal number in LAUE_CLASS
    !!----    character(len=*), intent(out) :: Laue_Str      ! Out -> String with the Laue class
    !!----
    !!----    Obtain the string for the Laue-Class. Control of error is
    !!----    present
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Get_Laue_Str(Ilaue,Str)
       !---- Arguments ----!
       integer,          intent( in) :: ilaue
       character(len=*), intent(out) :: str

       call init_err_symm()
       if (ilaue < 1 .or. ilaue > 16) then
          err_symm=.true.
          ERR_Symm_Mess=" Laue Number Incorrect"
       else
          str=laue_class(ilaue)
       end if

       return
    End Subroutine Get_Laue_Str

    !!----
    !!----  Subroutine Get_Orbit(X,Spg,Mult,orb,ptr,prim,symm)
    !!----    real(kind=cp), dimension(3),  intent (in) :: x     !  In -> Position vector
    !!----    type(Space_Group_type),       intent (in) :: spgr  !  In -> Space Group
    !!----    integer,                      intent(out) :: mult  !  Out -> Multiplicity
    !!----    real(kind=cp), dimension(:,:),intent(out) :: orb   !  Out -> List of equivalent positions
    !!----    integer,dimension(:),optional,intent(out) :: ptr   !  Out -> Pointer to the symmetry elements
    !!----    character(len=*),    optional,intent( in) :: prim  !  In  -> If given, only the primitive cell is considered
    !!----    character(len=*),    optional,intent( in) :: symm  !  In  -> If given, the coordinates are normalized as to be -1/2 <= x <1/2
    !!----
    !!----    Obtain the multiplicity and list of equivalent positions
    !!----    (including centring!) modulo integer lattice translations or within the range [-1/2,1/2) if symm is given.
    !!----
    !!---- Update: June - 2011 (JRC - removing pointer to stabilizer)
    !!
    Subroutine Get_Orbit(x,Spg,Mult,orb,ptr,prim,symm)
       !---- Arguments ----!
       real(kind=cp), dimension(3),  intent (in) :: x
       type(Space_Group_type),       intent (in) :: spg
       integer,                      intent(out) :: mult
       real(kind=cp),dimension(:,:), intent(out) :: orb
       integer,dimension(:),optional,intent(out) :: ptr
       character(len=*),    optional,intent( in) :: prim
       character(len=*),    optional,intent( in) :: symm

       !---- Local variables ----!
       integer                                :: j, nt
       real(kind=cp), dimension(3)            :: xx,v
       character(len=1)                       :: laty

       laty="P"
       if(present(prim)) laty=Spg%spg_lat
       mult=1
       orb(:,1)=x(:)
       if(present(ptr)) ptr(mult) = 1
       ext: do j=2,Spg%multip
          xx=ApplySO(Spg%SymOp(j),x)
          xx=modulo_lat(xx)
          do nt=1,mult
             v=orb(:,nt)-xx(:)
             if (Lattice_trans(v,Spg%spg_lat)) then
               if (.not. Lattice_trans(v,laty)) cycle  !Count in orbit the centred related atoms
               cycle ext
             end if
          end do
          mult=mult+1
          orb(:,mult)=xx(:)
          if(present(ptr)) ptr(mult) = j   !Effective symop
       end do ext

       if(present(symm)) then
         !Normalize the coordinates to be -1/2 <= x < 1/2
         do j=1,Mult
           do nt=1,3
              if(Orb(nt,j) >= 0.5) Orb(nt,j)= Orb(nt,j) - 1.0
           end do
         end do
       end if

       return
    End Subroutine Get_Orbit

    !!----
    !!---- Subroutine Get_Pointgroup_Str(Ipg,Str)
    !!----    integer,          intent( in) :: ipg        !  In -> Ordinal number for POINT_GROUP
    !!----    character(len=*), intent(out) :: Str        ! Out -> String for Point Group
    !!----
    !!----    Obtain the string for the Point Group. Error control is present
    !!----
    !!---- Update: Update: July - 2014: added m3 and m3m for compatibility with Laue_class
    !!
    Subroutine Get_Pointgroup_Str(Ipg,Str)
       !---- Arguments ----!
       integer,          intent( in) :: ipg
       character(len=*), intent(out) :: str

       call init_err_symm()
       if (ipg < 1 .or. ipg > 41) then
          err_symm=.true.
          ERR_Symm_Mess=" Point Group Number Incorrect"
       else
          str=point_group(ipg)
       end if

       return
    End Subroutine Get_PointGroup_Str

    !!--++
    !!--++ Subroutine Get_Seitz(N_Op,Tt,Seitz_Symb)
    !!--++    integer,                     intent( in) :: n_op          !  In -> Number of the rotational matrix
    !!--++    real(kind=cp), dimension(3), intent( in) :: tt            !  In -> Translation part
    !!--++    character (len=*),           intent(out) :: Seitz_symb    ! Out -> Seitz Symbol
    !!--++
    !!--++    (PRIVATE)
    !!--++    Provide the Seitz symbol of a symmetry operator.
    !!--++    This is mainly for internal use in the module.
    !!--++    Run before SearchOp.
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Get_Seitz(n_op,tt,Seitz_symb)
       !---- Arguments ----!
       integer,                     intent( in) :: n_op
       real(kind=cp), dimension(3), intent( in) :: tt
       character (len=*),           intent(out) :: Seitz_symb

       !---- Local variables ----!
       character (len=*), dimension(16), parameter  :: fracc =(/" 0 ","1/2","1/3","2/3",    &
                        "1/4","3/4","1/6","5/6","1/8","3/8","5/8","7/8","1  ","2  ","3  ","4  "/)
       integer :: i,j,ini
       real(kind=cp), dimension(16), parameter :: frac= (/0.0, 0.5,1.0/3.0,2.0/3.0,0.25,0.75, &
                                                  1.0/6.0,5.0/6.0,0.125,0.375,0.625,0.875,1.0,2.0,3.0,4.0/)

       if (hexa) then
          Seitz_symb(1:14) ="{"//X_d6h(n_op)(2:13)//"|"
          ini=15
       else
          Seitz_symb(1:10) ="{"//X_Oh(n_op)(2:9)//"|"
          ini=11
       end if
       xyz:do i=1,3
          do j=1,16
             if (abs(frac(j)-abs(tt(i))) < eps_symm) then
                if (tt(i) < 0.0) then
                   Seitz_symb(ini:ini+3)="-"//fracc(j)
                else
                   Seitz_symb(ini:ini+3)=" "//fracc(j)
                end if
                ini=ini+4
                cycle xyz
             end if
          end do
       end do xyz

       Seitz_symb(ini:ini)="}"

       return
    End Subroutine Get_Seitz

    !!----
    !!---- Subroutine Get_Seitz_Symbol(iop,itim,tr,Seitz_symb)
    !!----    integer,                   intent(in) :: iop,itim      !  In -> Number of the rotational matrix, time inversion
    !!----    real(kind=cp),dimension(3),intent(in) :: tr            !  In -> Translation part
    !!----    character(len=*),          intent(out):: Seitz_symb    ! Out -> Seitz Symbol
    !!----
    !!----    Provide the Seitz symbol of a symmetry operator. It uses the Litvin notation and
    !!----    the ordering is that of Table given by Harold T. Stokes and Branton J. Campbell.
    !!----    Hexa should be defined before using this subroutine. This subroutine is intended
    !!----    to be used with the reading of Magnetic Space Groups (see CFML_Magnetic_Symmetry)
    !!----
    !!---- Update: November 2012
    !!
    Subroutine Get_Seitz_Symbol(iop,itim,tr,Seitz_symb)
      integer,                     intent(in) :: iop,itim
      real(kind=cp), dimension(3), intent(in) :: tr
      character(len=*),            intent(out):: Seitz_symb
      !---- Local variables ----!
      integer :: i
      character(len=25) :: transl
      character(len=8)  :: operator_symb
      character(len=6)  :: Fracc

      if(hexa) then
        Operator_symb=Litvin_point_op_hex_label(iop)
      else
        Operator_symb=Litvin_point_op_label(iop)
      end if
      transl=" "
      do i=1,3
        call Get_Fraction_2Dig(tr(i),Fracc)
        transl=trim(transl)//trim(Fracc)//","
      end do
      i=len_trim(transl)
      transl(i:i)=" "
      do i=1,len_trim(transl)
        if(transl(i:i) == "+") transl(i:i)=" "
      end do
      Seitz_symb="("//trim(operator_symb)//" | "//trim(transl)//")"
      Seitz_symb=Pack_String(Seitz_symb)
      if(itim == -1)  Seitz_symb=trim(Seitz_symb)//"'"
      return
    End Subroutine Get_Seitz_Symbol


    !!--++
    !!--++ Subroutine Get_Setting_Info(Mat,orig,setting,matkind)
    !!--++    real(kind=cp), dimension (3,3),intent( in)    :: Mat     ! Matrix transforming the basis
    !!--++    real(kind=cp), dimension (  3),intent( in)    :: orig    ! Coordinates of the new origin
    !!--++    character (len=*),             intent(out)    :: setting ! String with the new setting
    !!--++    character (len=*), optional,   intent( in)    :: matkind ! Type of the input matrix
    !!--++
    !!--++    (PRIVATE)
    !!--++    Subroutine to construct a string with the transformation of the basis
    !!--++    corresponding to the matrix "Mat" and new origin "orig"
    !!--++    If matkind is given and matkind="it"/"IT", the input matrix is given
    !!--++    as in International Tables: (a' b' c') = (a b c) Mat
    !!--++    If matkind is not given or if it is not equal to "it"/"IT" the input matrix
    !!--++    is the transpose of the International convention (column matrices for basis vectors)
    !!--++    An example of the output is: a'=a+c, b'=2b, c'=-a+c  -> Origin: (0,1/4,0)
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Get_Setting_Info(Mat,orig,setting,matkind)
       !---- Arguments ----!
       real(kind=cp), dimension (3,3),intent( in)    :: Mat
       real(kind=cp), dimension (  3),intent( in)    :: orig
       character (len=*),             intent(out)    :: setting
       character (len=*), optional,   intent( in)    :: matkind

       !---- local variables ----!
       real(kind=cp), dimension (  3), parameter  :: nul = (/ 0.0, 0.0, 0.0/)
       real(kind=cp), dimension (3,3)  :: S
       character (len=22)     :: tro
       integer                :: i

       if (present(matkind)) then
          if (matkind(1:2) == "it" .or. matkind(1:2) == "IT" ) then
             S=transpose(Mat)
          else
             S=Mat
          end if
       else
          S=Mat
       end if

       call Get_SymSymb(S,nul,setting)
       i=index(setting,",")
       setting="a'="//setting(1:i)//" b'="//setting(i+1:)
       i=index(setting,",",back=.true.)
       setting=setting(1:i)//" c'="//setting(i+1:)
       do i=1,len_trim(setting)
          if (setting(i:i) == "x")  setting(i:i) = "a"
          if (setting(i:i) == "y")  setting(i:i) = "b"
          if (setting(i:i) == "z")  setting(i:i) = "c"
       end do

       call Frac_Trans_2Dig(Orig,tro)
       i=len_trim(setting)
       setting(i+2:)=" -> Origin: "//trim(tro)

       return
    End Subroutine Get_Setting_Info

    !!----
    !!---- Subroutine Get_Shubnikov_Operator_Symbol(Mat,Rot,tr,ShOp_symb,mcif)
    !!----   integer, dimension(3,3), intent(in) :: Mat,Rot     ! Symmetry operators for positions and magnetic moments
    !!----   real,    dimension(3),   intent(in) :: tr          ! Translation associated to the symmetry operator
    !!----   character(len=*),        intent(out):: ShOp_symb   ! String with the Shubnikov operator symbol
    !!----   logical,  optional,      intent(in) :: mcif        ! if present the Shubnikov operator is like in mcif: -x,y+1/2,z  mx,-my,-mz +1
    !!----
    !!---- Subroutine to construct a string with the Shubnikov operator
    !!---- in the following form: (-x,y+1/2,-z;u,-v,w)
    !!---- It also working for Wyckoff positions, when the matrices Mat and Rot
    !!---- are not symmetry operators (det=0). It is extensively used when reading
    !!---- the database containing the Magnetic Space Groups provided by
    !!---- < Harold T. Stokes and Branton J. Campbell
    !!----   Brigham Young University, Provo, Utah, USA
    !!----   June 2010 >
    !!----
    !!---- Updated: November 2012, January 2014
    !!----
    Subroutine Get_Shubnikov_Operator_Symbol(Mat,Rot,tr,ShOp_symb,mcif)
      integer,       dimension(3,3), intent(in) :: Mat,Rot
      real(kind=cp), dimension(3),   intent(in) :: tr
      character(len=*),              intent(out):: ShOp_symb
      logical, optional,             intent(in) :: mcif
      !---- Local variables ----!
      integer                 :: i,i1,i2,idet
      integer, dimension(3,3) :: sMat
      character(len=25)       :: xyz_op, uvw_op, mxmymz_op
      character(len=2)        :: time_inv

      call Get_SymSymb(Mat,tr,xyz_op)
      call Get_SymSymb(Rot,(/0.0_cp,0.0_cp,0.0_cp/),uvw_op)

      do i=1,len_trim(uvw_op)
        if(uvw_op(i:i) == "x")  uvw_op(i:i)="u"
        if(uvw_op(i:i) == "y")  uvw_op(i:i)="v"
        if(uvw_op(i:i) == "z")  uvw_op(i:i)="w"
      end do
      i1=index(xyz_op,",")
      if(i1 == 1) xyz_op="0"//trim(xyz_op)
      i2=index(xyz_op,",",back=.true.)
      if(i2 == len_trim(xyz_op)) xyz_op=trim(xyz_op)//"0"
      i1=index(xyz_op,",,")
      if(i1 /= 0) xyz_op=xyz_op(1:i1)//"0"//xyz_op(i1+1:)

      i1=index(uvw_op,",")
      if(i1 == 1) uvw_op="0"//trim(uvw_op)
      i2=index(uvw_op,",",back=.true.)
      if(i2 == len_trim(uvw_op)) uvw_op=trim(uvw_op)//"0"
      i1=index(uvw_op,",,")
      if(i1 /= 0) uvw_op=uvw_op(1:i1)//"0"//uvw_op(i1+1:)
      xyz_op=Pack_string(xyz_op)
      uvw_op=Pack_string(uvw_op)
      if(present(mcif)) then
        idet=determ_A(Mat)
        sMat=(idet*Mat-Rot)
        if(sum(sMat) == 0) then
          time_inv="+1"
        else
          time_inv="-1"
        end if
        !Expand the operator uvw_op to convert it to mx,my,mz like
        mxmymz_op=" "
        do i=1,len_trim(uvw_op)
          Select Case(uvw_op(i:i))
            case("u")
               mxmymz_op=trim(mxmymz_op)//"mx"
            case("v")
               mxmymz_op=trim(mxmymz_op)//"my"
            case("w")
               mxmymz_op=trim(mxmymz_op)//"mz"
            case default
               mxmymz_op=trim(mxmymz_op)//uvw_op(i:i)
          End Select
        end do
        ShOp_symb=trim(xyz_op)//" "//trim(mxmymz_op)//" "//time_inv
      else
        ShOp_symb="("//trim(xyz_op)//";"//trim(uvw_op)//")"
      end if
      return
    End Subroutine Get_Shubnikov_Operator_Symbol

    !!----
    !!---- Subroutine Get_So_From_Fix(Isystm,Isymce,Ibravl,Ng,Ss,Ts,Latsy,Co,Spacegen,lsym)
    !!----    integer,                     intent(out) :: ISYSTM    ! Out -> Number of the crystalline system
    !!----                                                          ! Out    (1:T, 2:M, 3:O, 4:T, 5:R-Trg, 6:H, 7:C)
    !!----    integer,                     intent(out) :: ISYMCE    ! Out -> 0 Centric (-1 not at origin)
    !!----                                                                   1 Acentric
    !!----                                                                   2 Centric (-1 at origin)
    !!----    integer,                     intent(out) :: IBRAVL    ! Out -> Index of the Bravais Lattice type
    !!----                                                                   1   2   3   4   5   6   7   8
    !!----                                                                   "P","A","B","C","I","R","F","Z"
    !!----    integer,                     intent(in ) :: NG        !  In -> Number of symmetry operators
    !!----    real(kind=cp),dimension(:,:),intent(in ) :: TS        !  In -> Translation parts of the symmetry operators(3,48)
    !!----    integer, dimension(:,:,:),   intent(in ) :: SS        !  In -> Rotation parts of the symmetry operators (3,3,48)
    !!----    character (len=2),           intent(out) :: latsy     ! Out -> Bravais Lattice symbol
    !!----    real(kind=cp),dimension(3)  ,intent(out) :: Co        ! Out -> Coordinates of origin
    !!----    character (len=1),           intent(out) :: SpaceGen  ! Out -> Type of Cell
    !!----    character (len=1),           intent(in)  :: lsym      ! In  -> Type of Cell forced
    !!----
    !!----    Determines some of items of the object Space_Group_Type from FIXed
    !!----    symmetry operators given by user.
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Get_SO_from_FIX(Isystm,Isymce,Ibravl,Ng,Ss,Ts,Latsy,Co,SpaceGen,lsym)
       !---- Arguments ----!
       integer,                      intent(out) :: Isystm
       integer,                      intent(out) :: Isymce
       integer,                      intent(out) :: Ibravl
       integer,                      intent(in ) :: Ng
       integer, dimension(:,:,:),    intent(in ) :: Ss  !(3,3,48)
       real(kind=cp),dimension(:,:), intent(in ) :: Ts  !(3  ,48)
       character (len= 2),           intent(out) :: Latsy
       real(kind=cp),dimension(3),   intent(out) :: Co
       character (len= 1),           intent(out) :: SpaceGen
       character (len= 1),optional,  intent(in ) :: lsym

       !---- Local Variables ----!
       logical :: latt_p, latt_a, latt_b, latt_c, latt_i, latt_r, latt_f, latt_z

       character(len=*), dimension(8),  parameter :: red = &
                         (/"P","A","B","C","I","R","F","Z"/)

       integer, dimension(3,6), parameter :: lattice=reshape((/0,6,6, 6,0,6, &
                                                   6,6,0, 6,6,6, 8,4,4, 4,8,8/),(/3,6/))

       integer, dimension(4,4), parameter :: identidad = reshape((/1, 0, 0, 0, &
                                                                   0, 1, 0, 0, &
                                                                   0, 0, 1, 0, &
                                                                   0, 0, 0, 1/),(/4,4/))
       integer, dimension(6)          :: latt_given
       real(kind=cp), dimension(3,11) :: latc
       integer, dimension(3)          :: tt
       integer                        :: i,j,l

       !---- Initializing ----!

       isystm  = 0
       isymce  = 1
       ibravl  = 0
       co      = 0.0
       latsy   = " "
       SpaceGen= " "
       if(present(lsym)) then
         if(.not. (lsym == "P" .or. lsym=="p")) SpaceGen=lsym
       end if

       if(len_trim(SpaceGen) == 0) then  !Test lattice translation only if lsym has not been provided
          latt_p=.true.                  !or if lsym="P"
          latt_a=.false.
          latt_b=.false.
          latt_c=.false.
          latt_i=.false.
          latt_r=.false.
          latt_f=.false.
          latt_z=.false.


          !---- Determine the type of lattice ----!
          !---- This is only in case an explicit translation generator is given.
          l=0
          do i=1,ng
             if (equal_matrix(ss(:,:,i),identidad(1:3,1:3),3)) then
                tt(1)=nint(12.0 * ts(1,i))   ! Translations x 12
                tt(2)=nint(12.0 * ts(2,i))
                tt(3)=nint(12.0 * ts(3,i))

                !---- Identity (I,0) is being processed ----!
                if (tt(1) == 0 .and. tt(2) == 0 .and. tt(3) == 0) cycle

                !---- Compare the translation part of the operator with tabulated array ----!
                l=l+1  !counts the number of non trivial centring vectors
                latt_given(:) = 0
                do j=1,6
                   if (equal_vector(tt,lattice(:,j),3)) then
                      latt_given(j)=1
                      select case (j)
                         case (1)
                            latt_a=.true.
                         case (2)
                            latt_b=.true.
                         case (3)
                            latt_c=.true.
                         case (4)
                            latt_i=.true.
                         case (5,6)
                            latt_r=.true.
                      end select
                      exit
                   end if
                end do
                latc(:,L) = ts(:,i)
                if(sum(latt_given) == 0) latt_z=.true.
             end if
          end do

          !---- Lattice Type ----!
          if ( (latt_a .and. latt_b .and. latt_c) .or. (latt_a .and. latt_b) .or. &
               (latt_a .and. latt_c) .or. (latt_b .and. latt_c) ) then
             latt_f=.true.
             latt_a=.false.
             latt_b=.false.
             latt_c=.false.
             latt_p=.false.
             latt_i=.false.
          end if

          if (latt_p) then
             SpaceGen="P"
             Ibravl  = 1
          end if
          if (latt_a) then
             SpaceGen="A"
             Ibravl  = 2
          end if
          if (latt_b) then
             SpaceGen="B"
             Ibravl  = 3
          end if
          if (latt_c) then
             SpaceGen="C"
             Ibravl  = 4
          end if
          if (latt_i) then
             SpaceGen="I"
             Ibravl  = 5
          end if
          if (latt_r) then
             SpaceGen="R"
             Ibravl  = 6
          end if
          if (latt_f) then
             SpaceGen="F"
             Ibravl  = 7
          end if
          if (latt_z) then
             SpaceGen="Z"
             Ibravl  = 8
          end if
       end if

       if (len_trim(SpaceGen) /= 0) then
          call latsym(SpaceGen,L,latc)
       else
          err_symm=.true.
          ERR_Symm_Mess=" Lattice Type couldn't be determined"
          return
       end if

       !---- Centre of symmetry ? ----!
       do i=1,ng
          if (equal_matrix(ss(:,:,i),-identidad(1:3,1:3),3)) then
             tt(1)=nint(12.0 * ts(1,i))
             tt(2)=nint(12.0 * ts(2,i))
             tt(3)=nint(12.0 * ts(3,i))

             if (tt(1) == 0 .and. tt(2) == 0 .and. tt(3) == 0) then
                isymce=2       ! Centric with -1 at origin
             else
                isymce=0       ! Centric without -1 at origin
                co=0.5*ts(:,i)
             end if
          end if
       end do

       !---- Determination of the crystalline system and Bravais lattice ----!
       call get_crystal_System(ng,ss,isystm,latsy(1:1))
       latsy(2:)=red(ibravl)

       return
    End Subroutine Get_So_From_Fix

    !!----
    !!---- Subroutine Get_So_From_Gener(Isystm,Isymce,Ibravl,Ng,Ss,Ts,Latsy,Co,Num_G,Spacegen)
    !!----    integer,                      intent(out)   :: ISYSTM    ! Out -> Number of the crystalline system
    !!----                                                                      (1:T, 2:M, 3:O, 4:T, 5:R-Trg, 6:H, 7:C)
    !!----    integer,                      intent(out)   :: ISYMCE    ! Out -> 0 Centric (-1 not at origin)
    !!----                                                                      1 Acentric
    !!----                                                                      2 Centric (-1 at origin)
    !!----    integer,                      intent(out)   :: IBRAVL    ! Out -> Index of the Bravais Lattice type
    !!----                                                                      1   2   3   4   5   6   7   8
    !!----                                                                      "P","A","B","C","I","R","F","Z"
    !!----    integer,                      intent(in out):: NG        !  In -> Number of defined generators
    !!----                                                             ! Out -> Number of symmetry operators
    !!----    integer, dimension(:,:,:),    intent(in out):: SS        !  In -> Rotation parts of the given generators  (3,3,48)
    !!----                                                             ! Out -> Rotation parts of the symmetry operators
    !!----    real(kind=cp),dimension(:,:), intent(in out):: TS        !  In -> Translation parts of the given generators  (3,48)
    !!----                                                             ! Out -> Translation parts of the symmetry operators
    !!----    character (len=2),            intent(out)   :: latsy     ! Out -> Bravais Lattice symbol
    !!----    real(kind=cp),dimension(3),   intent(out)   :: Co        ! Out -> Coordinates of origin
    !!----    integer,                      intent(out)   :: Num_g     ! Out -> Minimum number of generators
    !!----    character (len=1),            intent(out)   :: SpaceGen  ! Out -> Type of Cell
    !!----
    !!----    Calculates the whole set of symmetry operators from a set of given generators.
    !!----
    !!---- Update: February - 2005, February-2014 (JRC)
    !!
    Subroutine Get_SO_from_Gener(Isystm,Isymce,Ibravl,Ng,Ss,Ts,Latsy,Co,Num_g,SpaceGen,num_lat,lat_cent)
       !---- Arguments ----!
       integer,                                              intent(   out) :: Isystm
       integer,                                              intent(   out) :: Isymce
       integer,                                              intent(   out) :: Ibravl
       integer,                                              intent(in out) :: Ng
       integer, dimension(:,:,:),                            intent(in out) :: Ss ! (3,3,48)
       real(kind=cp),dimension(:,:),                         intent(in out) :: Ts ! (3  ,48)
       character (len=*),                                    intent(   out) :: Latsy
       real(kind=cp),dimension(3),                           intent(   out) :: Co
       integer,                                              intent(   out) :: Num_g
       character (len=*),                                    intent(   out) :: SpaceGen
       integer, optional,                                    intent(   out) :: num_lat
       real(kind=cp), dimension(:,:), allocatable, optional, intent(   out) :: lat_cent

       !---- Local Variables ----!
       real(kind=cp),dimension(3,192)  :: latc
       integer                         :: nlat_t
       logical :: latt_p, latt_a, latt_b, latt_c, latt_i, latt_r, latt_f, latt_z
       integer, dimension(6) :: latt_given
       character(len=*), dimension(8),  parameter :: red = &
                           (/"P","A","B","C","I","R","F","Z"/)
       integer, dimension(3,192)          :: lat_trans
       integer, dimension(3)              :: txyz
       integer, dimension(3,6), parameter :: lattice=reshape((/0,6,6, 6,0,6, &
                                                     6,6,0, 6,6,6, 8,4,4, 4,8,8/),(/3,6/))
       integer, dimension(4,4), parameter :: identidad = reshape((/1, 0, 0, 0, &
                                                                   0, 1, 0, 0, &
                                                                   0, 0, 1, 0, &
                                                                   0, 0, 0, 1/),(/4,4/))
       integer, dimension(4,4), parameter :: nulo      = reshape((/0, 0, 0, 0, &
                                                                   0, 0, 0, 0, &
                                                                   0, 0, 0, 0, &
                                                                   0, 0, 0, 0/),(/4,4/))
       integer, parameter             :: num_tab=24
       integer, dimension(4,4,num_tab):: tabla
       integer, dimension(4,4)        :: m1,m2
       integer, dimension(3)          :: tt,tt1
       real(kind=cp), parameter       :: lat_norm=12.0  !a multiple of 12 is compulsory
       integer,       parameter       :: ilat_norm=12, ilat_fact=ilat_norm*4
       integer :: i,j,k,n,nop,nopp,ipos,nt,ntp,L,jcen
       integer :: tx, ty, tz
       logical :: cen_found

       !---- Initializing ----!
       nop     = ng
       isystm  = 0
       isymce  = 1
       ibravl  = 0
       co      = 0.0
       latsy   = " "
       SpaceGen=" "

       latt_p=.true.
       latt_a=.false.
       latt_b=.false.
       latt_c=.false.
       latt_i=.false.
       latt_r=.false.
       latt_f=.false.
       latt_z=.false.
       !Set to zero all previous centring vectors
       nlat=0
       Ltr=0.0_cp

       !---- Redundances ----!
       do i=1,nop
          if (equal_matrix(ss(:,:,i),      nulo(1:3,1:3),3)) cycle  !ignore zero matrices
          if (equal_matrix(ss(:,:,i), identidad(1:3,1:3),3)) cycle  !Do not consider lattice translations
          if (equal_matrix(ss(:,:,i),-identidad(1:3,1:3),3)) cycle  !Do not consider inversion centre
          do j=i+1,nop
             if (equal_matrix(ss(:,:,j),      nulo(1:3,1:3),3)) cycle
             if (equal_matrix(ss(:,:,j), identidad(1:3,1:3),3)) cycle
             if (equal_matrix(ss(:,:,j),-identidad(1:3,1:3),3)) cycle

             !---- Traslation part ----!
             if (equal_matrix(ss(:,:,i),ss(:,:,j),3)) then
                tt =nint(lat_norm * ts(:,i))
                tt1=nint(lat_norm * ts(:,j))

                tx=mod(tt(1)-tt1(1)+ilat_fact,ilat_norm)        !?????????
                ty=mod(tt(2)-tt1(2)+ilat_fact,ilat_norm)
                tz=mod(tt(3)-tt1(3)+ilat_fact,ilat_norm)

                if (tx == 0 .and. ty == 0 .and. tz == 0) then
                   ss(:,:,j)=0
                   ts(:,j)=0.0
                   cycle
                else
                   tx=mod(tt(1)+tt1(1)+ilat_fact,ilat_norm)
                   ty=mod(tt(2)+tt1(2)+ilat_fact,ilat_norm)
                   tz=mod(tt(3)+tt1(3)+ilat_fact,ilat_norm)

                   if (tx == 0 .and. ty == 0 .and. tz == 0) then
                      ss(:,:,j)=0
                      ts(:,j)=0.0
                      cycle
                   else
                      ss(:,:,j)=identidad(1:3,1:3)
                      ts(1,j)=real(tx)/lat_norm
                      ts(2,j)=real(ty)/lat_norm
                      ts(3,j)=real(tz)/lat_norm
                      cycle
                   end if
                end if
             end if

             !---- Inversion part ----!
             if (equal_matrix(ss(:,:,i),-ss(:,:,j),3)) then
                tt =nint(lat_norm * ts(:,i))
                tt1=nint(lat_norm * ts(:,j))

                tx=mod(tt(1)-tt1(1)+ilat_fact,ilat_norm)        !?????????
                ty=mod(tt(2)-tt1(2)+ilat_fact,ilat_norm)
                tz=mod(tt(3)-tt1(3)+ilat_fact,ilat_norm)

                if (tx == 0 .and. ty == 0 .and. tz == 0) then
                   ss(:,:,j)=-identidad(1:3,1:3)
                   ts(:,j)=0.0
                   cycle
                else
                   tx=mod(tt(1)+tt1(1)+ilat_fact,ilat_norm)
                   ty=mod(tt(2)+tt1(2)+ilat_fact,ilat_norm)
                   tz=mod(tt(3)+tt1(3)+ilat_fact,ilat_norm)

                   if (tx == 0 .and. ty == 0 .and. tz == 0) then
                      ss(:,:,j)=-identidad(1:3,1:3)
                      ts(:,j)=0.0
                      cycle
                   else
                      ss(:,:,j)=-identidad(1:3,1:3)
                      ts(1,j)=real(tx)/lat_norm
                      ts(2,j)=real(ty)/lat_norm
                      ts(3,j)=real(tz)/lat_norm
                      cycle
                   end if
                end if
             end if

          end do
       end do

       !---- Determine the type of lattice before starting generation ----!
       !---- This is only in case an explicit translation generator is given.
       !---- This block construct the lattice vectors and remove the corresponding operators
       L=0
       do i=1,nop
          if (equal_matrix(ss(:,:,i),identidad(1:3,1:3),3)) then
             tt=nint(lat_norm * ts(:,i))   ! Translations x 12

             !---- Identity (I,0) is being processed ----!
             if (tt(1) == 0 .and. tt(2) == 0 .and. tt(3) == 0) then
                ss(:,:,i)=0
                ts(:,i)=0.0
                cycle
             end if
             !---- Compare the translation part of the operator with tabulated array ----!
             L=L+1  !counts the number of non trivial centring vectors
             latt_given(:) = 0
             do j=1,6
                if (equal_vector(tt,(ilat_norm/12)*lattice(:,j),3)) then
                   latt_given(j) = 1
                   select case (j)
                      case (1)
                         latt_a=.true.
                      case (2)
                         latt_b=.true.
                      case (3)
                         latt_c=.true.
                      case (4)
                         latt_i=.true.
                      case (5,6)
                         latt_r=.true.
                   end select
                   exit
                end if
             end do
             latc(:,L) = ts(:,i)
             ss(:,:,i)=0   !Removing the operators with pure translations
             ts(:,i)=0.0
             if(sum(latt_given) == 0) latt_z = .true.
          end if
       end do

       !---- Lattice Type ----!
       if ( (latt_a .and. latt_b .and. latt_c) .or. (latt_a .and. latt_b) .or. &
            (latt_a .and. latt_c) .or. (latt_b .and. latt_c) ) then
          latt_f=.true.
          latt_a=.false.
          latt_b=.false.
          latt_c=.false.
          latt_p=.false.
          latt_i=.false.
       end if
       if(latt_f .and. latt_r) latt_z=.true.
       if(latt_i .and. latt_r) latt_z=.true.
       if(latt_a .and. latt_r) latt_z=.true.
       if(latt_b .and. latt_r) latt_z=.true.
       if(latt_c .and. latt_r) latt_z=.true.

       if(latt_z) then
          latt_f=.false.
          latt_a=.false.
          latt_b=.false.
          latt_c=.false.
          latt_p=.false.
          latt_i=.false.
          latt_r=.false.
       end if

       if (latt_p) then
          SpaceGen="P"
          Ibravl  = 1
          nlat_t=0
       end if
       if (latt_a) then
          SpaceGen="A"
          Ibravl  = 2
          nlat_t=1
          latc(:,1)=(/0.0,0.5,0.5/)
       end if
       if (latt_b) then
          SpaceGen="B"
          Ibravl  = 3
          nlat_t=1
          latc(:,1)=(/0.5,0.0,0.5/)
       end if
       if (latt_c) then
          SpaceGen="C"
          Ibravl  = 4
          nlat_t=1
          latc(:,1)=(/0.5,0.5,0.0/)
       end if
       if (latt_i) then
          SpaceGen="I"
          Ibravl  = 5
          nlat_t=1
          latc(:,1)=(/0.5,0.5,0.5/)
       end if
       if (latt_r) then
          SpaceGen="R"
          Ibravl  = 6
          nlat_t=2
          latc(:,1)=(/ 2.0/3.0, 1.0/3.0, 1.0/3.0 /)
          latc(:,2)=(/ 1.0/3.0, 2.0/3.0, 2.0/3.0 /)
       end if
       if (latt_f) then
          SpaceGen="F"
          Ibravl  = 7
          nlat_t=3
          latc(:,1)=(/0.5,0.5,0.0/)
          latc(:,2)=(/0.5,0.0,0.5/)
          latc(:,3)=(/0.0,0.5,0.5/)
       end if
       if (latt_z) then
          Ibravl  = 8
          !Determine here the total number of non-trivial centring vectors
          call get_centring_vectors(L,latc,SpaceGen)
          nlat_t=L
          do i=1,nlat_t
             lat_trans(:,i)=maxval(nint(lat_norm*latc(:,i)))
          end do
       end if

       if(present(num_lat) .and. present(lat_cent)) then
         num_lat=nlat_t
         if(allocated(lat_cent)) deallocate(lat_cent)
         allocate(lat_cent(3,num_lat))
         lat_cent(:,1:num_lat)=latc(:,1:num_lat)
       end if

       if (len_trim(SpaceGen) /= 0) then
          !write(*,"(a)") " => Lattice centrings at Get_SO_from_Gener: "
          !do i=1,nlat_t
          !   write(*,"(i8,3f14.5)")i,latc(:,i)
          !end do
          call latsym(SpaceGen,nlat_t,latc)
       else
          err_symm=.true.
          ERR_Symm_Mess=" Lattice Type couldn't be determined"
          return
       end if

       !---- Removing Centre of symmetry if found ----!
       do i=1,nop
          if (equal_matrix(ss(:,:,i),-identidad(1:3,1:3),3)) then
             tt=nint(lat_norm * ts(:,i))

             if (tt(1) == 0 .and. tt(2) == 0 .and. tt(3) == 0) then
                isymce=2       ! Centric with -1 at origin
             else
                if(isymce /= 2) then !do that only if a centre has not been found at the origin
                  isymce=0       ! Centric without -1 at origin
                  co=0.5*ts(:,i)
                end if
             end if
             ss(:,:,i)=0
             ts(:,i)=0.0
          end if
       end do

       !---- Purge the starting list of generators ----!
       !     by diminishing the number of generators to the strictly
       !     assymmetric block without translations and centre
       nopp=nop
       ipos=1
       do
          do i=ipos,nopp
             if (equal_matrix(ss(:,:,i),nulo(1:3,1:3),3)) then
                do j=i+1,nopp
                   ss(:,:,j-1)= ss(:,:,j)
                   ts(:,j-1)  = ts(:,j)
                end do
                ss(:,:,nopp)=0
                ts(:,nopp)=0.0
                nopp=nopp-1
                ipos=i
                exit
             end if
          end do
          if (i >= nopp) exit
       end do
       if (equal_matrix(ss(:,:,nopp),nulo(1:3,1:3),3)) nopp=nopp-1
       nop=nopp    !nop is the number of generators without centre of symmetry
                   !and lattice centrings

       !---- Now we have an eventually shorter list of generators and we
       !---- know if a centre of symmetry or lattice centrings were
       !---- among the given generators.

       !---- Creation of the symmetry operators table ----!
       !write(*,"(a,i6)") " => Number of generators (no centre/no lattice) to start the table: ",nop
       !do i=1,nop
       !  write(*,"(9i4,3f8.4)") ss(:,:,i), ts(:,i)
       !end do
       !---- Initializing ----!
       nt=1
       tabla=0
       tabla(4,4,:)=1
       do i=1,4               !---- Identity operator is the first one ----!
          tabla(i,i,1)=1
       end do

       !---- Put operators in the table ----!
       do i=1,nop
          nt=nt+1
          tabla(1:3,1:3,nt)= ss(:,:,i)
          tabla(1:3,4,nt)  = mod(nint(lat_norm*ts(1:3,i))+ilat_fact,ilat_norm)
       end do

       num_g=nop   !Minimum number of generators (except inversion)

       !---- Generate power operations from generators ----!
       do i=2,nt
             ntp=axes_rotation(tabla(1:3,1:3,i))    ! Determine the order of the generator
          if (ntp == -1 .or. ntp == -3) then
             ntp=-2*ntp
          else
             ntp=abs(ntp)
          end if

          m1=tabla(:,:,i)
          m2=identidad

          p1:do j=1,ntp-1
             m2=matmul(m2,m1)
             m2(:,4)=mod(m2(:,4)+ilat_fact,ilat_norm)

             !---- Check if the generated operation is already in the table
             do k=1,nt
                if (equal_matrix(tabla(:,:,k),m2,4)) cycle p1
             end do

             !---- Eliminating lattice contribution if necessary ----!
             select case (ibravl)
                 case (2)
                    ty=m2(2,4)
                    tz=m2(3,4)
                    if (ty >= 6 .and. tz >= 6) then
                       ty=mod(m2(2,4),6)
                       tz=mod(m2(3,4),6)

                       if (ty == 0 .and. tz == 0) then
                          cycle p1
                       else
                          m2(2,4)=ty
                          m2(3,4)=tz
                       end if
                    end if

                 case (3)
                    tx=m2(1,4)
                    tz=m2(3,4)
                    if (tx >= 6 .and. tz >=6) then
                       tx=mod(m2(1,4),6)
                       tz=mod(m2(3,4),6)

                       if (tx == 0 .and. tz == 0) then
                          cycle p1
                       else
                          m2(1,4)=tx
                          m2(3,4)=tz
                       end if
                    end if

                 case (4)
                    tx=m2(1,4)
                    ty=m2(2,4)
                    if (tx >=6 .and. ty >= 6) then
                       tx=mod(m2(1,4),6)
                       ty=mod(m2(2,4),6)

                       if (tx == 0 .and. ty == 0) then
                          cycle p1
                       else
                          m2(1,4)=tx
                          m2(2,4)=ty
                       end if
                    end if

                 case (5)
                    tx=m2(1,4)
                    ty=m2(2,4)
                    tz=m2(3,4)
                    if (tx >=6 .and. ty >=6 .and. tz >=6) then
                       tx=mod(m2(1,4),6)
                       ty=mod(m2(2,4),6)
                       tz=mod(m2(3,4),6)

                       if (tx == 0 .and. ty == 0 .and. tz == 0) then
                          cycle p1
                       else
                          m2(1,4)=tx
                          m2(2,4)=ty
                          m2(3,4)=tz
                       end if
                    end if

                 case (6)
                    tx=m2(1,4)
                    ty=m2(2,4)
                    tz=m2(3,4)
                    if (tx >=8 .and. ty >=4 .and. tz >=4) then
                       tx=mod(m2(1,4),8)
                       ty=mod(m2(2,4),4)
                       tz=mod(m2(3,4),4)
                       if (tx == 0 .and. ty == 0 .and. tz == 0) then
                          cycle p1
                       else
                          m2(1,4)=tx
                          m2(2,4)=ty
                          m2(3,4)=tz
                       end if

                    else if (tx >=4 .and. ty >=8 .and. tz >=8) then
                       tx=mod(m2(1,4),4)
                       ty=mod(m2(2,4),8)
                       tz=mod(m2(3,4),8)
                       if (tx == 0 .and. ty == 0 .and. tz == 0) then
                          cycle p1
                       else
                          m2(1,4)=tx
                          m2(2,4)=ty
                          m2(3,4)=tz
                       end if
                    end if

                 case (7)
                    tx=m2(1,4)
                    ty=m2(2,4)
                    tz=m2(3,4)
                    if (ty >= 6 .and. tz >=6) then
                       ty=mod(m2(2,4),6)
                       tz=mod(m2(3,4),6)
                       if (tx == 0 .and. ty == 0 .and. tz == 0) then
                          cycle p1
                       else
                          m2(2,4)=ty
                          m2(3,4)=tz
                       end if
                    else if (tx >=6 .and. tz >=6) then
                       tx=mod(m2(1,4),6)
                       tz=mod(m2(3,4),6)
                       if (tx == 0 .and. ty == 0 .and. tz == 0) then
                          cycle p1
                       else
                          m2(1,4)=tx
                          m2(3,4)=tz
                       end if
                    else if (tx >=6 .and. ty >=6) then
                       tx=mod(m2(1,4),6)
                       ty=mod(m2(2,4),6)
                       if (tx == 0 .and. ty == 0 .and. tz == 0) then
                          cycle p1
                       else
                          m2(1,4)=tx
                          m2(2,4)=ty
                       end if
                    end if

                 Case(8)
                    !eliminate translations
                    txyz=m2(1:3,4)
                    do k=1,nlat_t
                       if(txyz(1) >= lat_trans(1,k) .and. txyz(2) >= lat_trans(2,k) .and. txyz(3) >= lat_trans(3,k)) then
                          txyz(:)=mod(m2(1:3,4), lat_trans(:,k))
                          if(txyz(1) == 0 .and. txyz(2) == 0 .and.txyz(3) == 0 ) then
                             cycle p1
                          else
                              m2(1:3,4)=txyz(:)
                          end if
                       end if
                    end do

             end select

             nt=nt+1
             if (nt > num_tab) then
                err_symm=.true.
                ERR_Symm_Mess=" Dimension of Table exceeded (I)"
                return
             end if
             tabla(:,:,nt)=m2
          end do p1

       end do

       !write(*,"(a,i6)") " => Number of terms in the table at stage I: ",nt
       !do i=1,nt
       !  write(*,"(9i3,3i6)") tabla(1:3,1:3,i),tabla(1:3,4,i)
       !end do
       !write(*,"(//a//)") " => MULTIPLICATION OF GENERATORS: "

       !---- Multiplications between generators ----!
       do
          if (nt == 1) exit
          n=nt

          do i=1,n
             p2:do j=i,n

                m2=matmul(tabla(:,:,i),tabla(:,:,j))
                m2(:,4)=mod(m2(:,4)+ilat_fact,ilat_norm)

                !---- Eliminating lattice contribution if necessary ----!
                select case (ibravl)
                   case (2)
                      ty=m2(2,4)
                      tz=m2(3,4)
                      if (ty >= 6 .and. tz >= 6) then
                         m2(2,4)=mod(m2(2,4),6)
                         m2(3,4)=mod(m2(3,4),6)
                      end if

                   case (3)
                      tx=m2(1,4)
                      tz=m2(3,4)
                      if (tx >= 6 .and. tz >= 6) then
                         m2(1,4)=mod(m2(1,4),6)
                         m2(3,4)=mod(m2(3,4),6)
                      end if

                   case (4)
                      tx=m2(1,4)
                      ty=m2(2,4)
                      if (tx >= 6 .and. ty >= 6) then
                         m2(1,4)=mod(m2(1,4),6)
                         m2(2,4)=mod(m2(2,4),6)
                      end if

                   case (5)
                      tx=m2(1,4)
                      ty=m2(2,4)
                      tz=m2(3,4)
                      if (tx >= 6 .and. ty >= 6 .and. tz >= 6) then
                         m2(1,4)=mod(m2(1,4),6)
                         m2(2,4)=mod(m2(2,4),6)
                         m2(3,4)=mod(m2(3,4),6)
                      end if

                   case (6)
                      tx=m2(1,4)
                      ty=m2(2,4)
                      tz=m2(3,4)
                      if (tx >=8 .and. ty >=4 .and. tz >=4) then
                         m2(1,4)=mod(m2(1,4),8)
                         m2(2,4)=mod(m2(2,4),4)
                         m2(3,4)=mod(m2(3,4),4)
                      else if (tx >=4 .and. ty >=8 .and. tz >=8) then
                         m2(1,4)=mod(m2(1,4),4)
                         m2(2,4)=mod(m2(2,4),8)
                         m2(3,4)=mod(m2(3,4),8)
                      end if

                   case (7)
                      tx=m2(1,4)
                      ty=m2(2,4)
                      tz=m2(3,4)
                      if (ty >= 6 .and. tz >=6) then
                         m2(2,4)=mod(m2(2,4),6)
                         m2(3,4)=mod(m2(3,4),6)
                      else if (tx >=6 .and. tz >=6) then
                         m2(1,4)=mod(m2(1,4),6)
                         m2(3,4)=mod(m2(3,4),6)
                      else if (tx >=6 .and. ty >=6) then
                         m2(1,4)=mod(m2(1,4),6)
                         m2(2,4)=mod(m2(2,4),6)
                      end if

                   case(8)

                      txyz=m2(1:3,4)
                      do k=1,nlat_t
                         if(txyz(1) >= lat_trans(1,k) .and. txyz(2) >= lat_trans(2,k) .and. txyz(3) >= lat_trans(3,k)) then
                            m2(1:3,4)=mod(m2(1:3,4), lat_trans(:,k))
                         end if
                      end do

                end select

                do k=1,nt
                   if ( equal_matrix(m2(:,:),tabla(:,:,k),4) ) cycle p2
                   if ( equal_matrix(m2(:,:),tabla(:,:,k),3) ) then
                      tx=m2(1,4)+tabla(1,4,k)
                      ty=m2(2,4)+tabla(2,4,k)
                      tz=m2(3,4)+tabla(3,4,k)
                      tx=mod(tx,ilat_norm)
                      ty=mod(ty,ilat_norm)
                      tz=mod(tz,ilat_norm)
                      select case (ibravl)
                          case (2)
                             if (ty == 6 .and. tz == 6) cycle p2
                             if (ty == 0 .and. tz == 0) cycle p2

                          case (3)
                             if (tx == 6 .and. tz == 6) cycle p2
                             if (tx == 0 .and. tz == 0) cycle p2

                          case (4)
                             if (tx == 6 .and. ty == 6) cycle p2
                             if (tx == 0 .and. ty == 0) cycle p2

                          case (5)
                             if (tx == 6 .and. ty == 6 .and. tz == 6) cycle p2
                             if (tx == 0 .and. ty == 0 .and. tz == 0) cycle p2

                          case (6)
                             if (tx == 8 .and. ty == 4 .and. tz == 4) cycle p2
                             if (tx == 4 .and. ty == 8 .and. tz == 8) cycle p2
                             if (tx == 0 .and. ty == 0 .and. tz == 0) cycle p2

                          case (7)
                             if (ty == 6 .and. tz == 6) cycle p2
                             if (tx == 6 .and. tz == 6) cycle p2
                             if (tx == 6 .and. ty == 6) cycle p2

                             if (ty == 0 .and. tz == 0) cycle p2
                             if (tx == 0 .and. tz == 0) cycle p2
                             if (tx == 0 .and. ty == 0) cycle p2

                          case (8)
                             txyz=(/tx,ty,tz/)
                             if(txyz(1) == 0 .and. txyz(2) == 0 .and. txyz(3) == 0) cycle p2
                             do l=1,nlat_t
                               if(txyz(1)==lat_trans(1,l) .and. txyz(2)==lat_trans(2,l) .and. txyz(3)==lat_trans(3,l)) cycle p2
                             end do

                      end select

                      tx=m2(1,4)-tabla(1,4,k)
                      ty=m2(2,4)-tabla(2,4,k)
                      tz=m2(3,4)-tabla(3,4,k)
                      tx=mod(tx+ilat_fact,ilat_norm)
                      ty=mod(ty+ilat_fact,ilat_norm)
                      tz=mod(tz+ilat_fact,ilat_norm)

                      select case (ibravl)
                          case (2)
                             if (ty == 6 .and. tz == 6) cycle p2
                             if (ty == 0 .and. tz == 0) cycle p2

                          case (3)
                             if (tx == 6 .and. tz == 6) cycle p2
                             if (tx == 0 .and. tz == 0) cycle p2

                          case (4)
                             if (tx == 6 .and. ty == 6) cycle p2
                             if (tx == 0 .and. ty == 0) cycle p2

                          case (5)
                             if (tx == 6 .and. ty == 6 .and. tz == 6) cycle p2
                             if (tx == 0 .and. ty == 0 .and. tz == 0) cycle p2

                          case (6)
                             if (tx == 8 .and. ty == 4 .and. tz == 4) cycle p2
                             if (tx == 4 .and. ty == 8 .and. tz == 8) cycle p2
                             if (tx == 0 .and. ty == 0 .and. tz == 0) cycle p2

                          case (7)
                             if (ty == 6 .and. tz == 6) cycle p2
                             if (tx == 6 .and. tz == 6) cycle p2
                             if (tx == 6 .and. ty == 6) cycle p2

                             if (ty == 0 .and. tz == 0) cycle p2
                             if (tx == 0 .and. tz == 0) cycle p2
                             if (tx == 0 .and. ty == 0) cycle p2

                          case (8)
                             txyz=(/tx,ty,tz/)
                             if(txyz(1) == 0 .and. txyz(2) == 0 .and. txyz(3) == 0) cycle p2
                             do l=1,nlat_t
                               if(txyz(1)==lat_trans(1,l) .and. txyz(2)==lat_trans(2,l) .and. txyz(3)==lat_trans(3,l)) cycle p2
                             end do

                      end select
                   end if
                end do

                nt=nt+1
                if (nt > num_tab) then
                   err_symm=.true.
                   write(unit=ERR_Symm_Mess,fmt="(a,i5)") " Dimension of Table exceeded (II): ",nt
                   return
                end if
                !new operator
                tabla(:,:,nt)=m2
                !write(*,"(a,i4,a,9i3,3i6)")  "  Op:",nt," -> ", tabla(1:3,1:3,nt),tabla(1:3,4,nt)
             end do p2
          end do

          if (n == nt) exit

       end do

       !---- Carga Final ----!
       ng=nt
       do i=1,nt
          ss(:,:,i)=tabla(1:3,1:3,i)
          ts(:,i)  = real(tabla(1:3,4,i))/lat_norm
       end do

       ! Check anomalous cases where the order of generators has produced
       ! a centre of symmetry at the end.
       ! In some cases the number of operators were wrong => the list of
       ! operators contained centrosymmetric related items.

       cen_found = .false.
       do i=1,nt
          if ( equal_matrix(ss(:,:,i),-identidad,3) ) then
             cen_found=.true.
             jcen=i
             exit
          end if
       end do

       if(cen_found) then
           ng=nt/2     !in all cases only half operators are needed
           if (isymce == 1) then
              tt=tabla(1:3,4,jcen)
              if (tt(1) == 0 .and. tt(2) == 0 .and. tt(3) == 0) then
                 isymce=2       ! Centric with -1 at origin
              else
                 isymce=0       ! Centric without -1 at origin
                 co=0.5*ts(:,jcen)
              end if
           end if
       end if

       !---- Determination of the crystalline system and Bravais lattice ----!
       call get_crystal_System(ng,ss,isystm,latsy(1:1))
       latsy(2:)=red(ibravl)

       return
    End Subroutine Get_SO_from_Gener

    !!----
    !!---- Subroutine Get_So_From_Hall(Isystm,Isymce,Ibravl,Ng,Ss,Ts,Latsy,Co,Num_G,Hall)
    !!----    integer,                   intent(out)  :: ISYSTM    ! Out -> Number of the crystalline system
    !!----                                                                  (1:T, 2:M, 3:O, 4:T, 5:R-Trg, 6:H, 7:C)
    !!----    integer,                   intent(out)  :: ISYMCE    ! Out -> 0 Centric (-1 not at origin)
    !!----                                                                  1 Acentric
    !!----                                                                  2 Centric (-1 at origin)
    !!----    integer,                   intent(out)  :: IBRAVL    ! Out -> Index of the Bravais Lattice type
    !!----                                                                  1   2   3   4   5   6   7
    !!----                                                                 "P","A","B","C","I","R","F"
    !!----    integer,                   intent(out)  :: NG        ! Out -> Number of symmetry operators
    !!----    real(kind=cp),    dimension(:,:),   intent(out)  :: TS        ! Out -> Translation parts of the symmetry operators  (3,48)
    !!----    integer, dimension(:,:,:), intent(out)  :: SS        ! Out -> Rotation parts of the symmetry operators     (3,3,48)
    !!----    character (len=2),         intent(out)  :: latsy     ! Out -> Bravais lattice symbol
    !!----    real(kind=cp), dimension(3),        intent(out)  :: Co        ! Out -> Coordinates of symmetry center
    !!----    integer,                   intent(out)  :: num_g     ! Out -> Number of generators
    !!----    character (len=20),        intent( in)  :: Hall      !  In -> Hall Spacegroup symbol
    !!----
    !!----    Subroutine to get all the information contained in the Hall symbol. This
    !!----    routine to interpret the Hall symbol for a space group.
    !!--..    (Author:Javier Gonzalez-Platas)
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Get_SO_from_Hall(Isystm,Isymce,Ibravl,Ng,Ss,Ts,Latsy,Co,Num_g,Hall)
       !---- Arguments ----!
       integer,                   intent(out) :: Isystm
       integer,                   intent(out) :: Isymce
       integer,                   intent(out) :: Ibravl
       integer,                   intent(out) :: Ng
       integer, dimension(:,:,:), intent(out) :: Ss  !(3,3,48)
       real(kind=cp),    dimension(:,:),   intent(out) :: Ts  !(3,48)
       character (len= 2),        intent(out) :: Latsy
       real(kind=cp),    dimension(3),     intent(out) :: Co
       integer,                   intent(out) :: Num_g
       character (len=*),         intent( in) :: Hall

       !----Local variables ----!
       character (len=16)                         :: group
       character(len=*), dimension(7),  parameter :: red = &
                         (/"P","A","B","C","I","R","F"/)
       character(len=*), dimension(13), parameter :: traslacion =&
                         (/"A","B","C","N","U","V","W","D","1","2","3","4","5"/)
       character(len=*), dimension(6),  parameter :: ejes_rotacion = &
                         (/"X","Y","Z","'","""","*"/)
       character(len=*), dimension(5),  parameter :: rotacion=(/"1","2","3","4","6"/)
       character(len=*), dimension(5),  parameter :: shift=(/"1","2","3","4","5"/)
       integer, dimension(3,13), parameter :: tras_val=reshape((/6,0,0, 0,6,0, &
                                       0,0,6, 6,6,6, 3,0,0, 0,3,0, 0,0,3, 3,3,3, &
                                       1,0,0, 2,0,0, 3,0,0, 4,0,0, 5,0,0/),(/3,13/))
       integer, dimension(3,3), parameter  :: x_1   = reshape( &
                                 (/ 1, 0, 0,  0, 1, 0,  0, 0, 1/),(/3,3/))
       integer, dimension(3,3), parameter  :: y_1   = reshape( &
                                 (/ 1, 0, 0,  0, 1, 0,  0, 0, 1/),(/3,3/))
       integer, dimension(3,3), parameter  :: z_1   = reshape( &
                                 (/ 1, 0, 0,  0, 1, 0,  0, 0, 1/),(/3,3/))
       integer, dimension(3,3), parameter  :: x_2   = reshape( &
                                 (/ 1, 0, 0,  0,-1, 0,  0, 0,-1/),(/3,3/))
       integer, dimension(3,3), parameter  :: y_2   = reshape( &
                                 (/-1, 0, 0,  0, 1, 0,  0, 0,-1/),(/3,3/))
       integer, dimension(3,3), parameter  :: z_2   = reshape( &
                                 (/-1, 0, 0,  0,-1, 0,  0, 0, 1/),(/3,3/))
       integer, dimension(3,3), parameter  :: x_3   = reshape( &
                                 (/ 1, 0, 0,  0, 0, 1,  0,-1,-1/),(/3,3/))
       integer, dimension(3,3), parameter  :: y_3   = reshape( &
                                 (/-1, 0,-1,  0, 1, 0,  1, 0, 0/),(/3,3/))
       integer, dimension(3,3), parameter  :: z_3   = reshape( &
                                 (/ 0, 1, 0, -1,-1, 0,  0, 0, 1/),(/3,3/))
       integer, dimension(3,3), parameter  :: x_4   = reshape( &
                                 (/ 1, 0, 0,  0, 0, 1,  0,-1, 0/),(/3,3/))
       integer, dimension(3,3), parameter  :: y_4   = reshape( &
                                 (/ 0, 0,-1,  0, 1, 0,  1, 0, 0/),(/3,3/))
       integer, dimension(3,3), parameter  :: z_4   = reshape( &
                                 (/ 0, 1, 0, -1, 0, 0,  0, 0, 1/),(/3,3/))
       integer, dimension(3,3), parameter  :: x_6   = reshape( &
                                 (/ 1, 0, 0,  0, 1, 1,  0,-1, 0/),(/3,3/))
       integer, dimension(3,3), parameter  :: y_6   = reshape( &
                                 (/ 0, 0,-1,  0, 1, 0,  1, 0, 1/),(/3,3/))
       integer, dimension(3,3), parameter  :: z_6   = reshape( &
                                 (/ 1, 1, 0, -1, 0, 0,  0, 0, 1/),(/3,3/))
       integer, dimension(3,3), parameter  :: x_2p  = reshape( &
                                 (/-1, 0, 0,  0, 0,-1,  0,-1, 0/),(/3,3/))
       integer, dimension(3,3), parameter  :: y_2p  = reshape( &
                                 (/ 0, 0,-1,  0,-1, 0, -1, 0, 0/),(/3,3/))
       integer, dimension(3,3), parameter  :: z_2p  = reshape( &
                                 (/ 0,-1, 0, -1, 0, 0,  0, 0,-1/),(/3,3/))
       integer, dimension(3,3), parameter  :: x_2pp = reshape( &
                                 (/-1, 0, 0,  0, 0, 1,  0, 1, 0/),(/3,3/))
       integer, dimension(3,3), parameter  :: y_2pp = reshape( &
                                 (/ 0, 0, 1,  0,-1, 0,  1, 0, 0/),(/3,3/))
       integer, dimension(3,3), parameter  :: z_2pp = reshape( &
                                 (/ 0, 1, 0,  1, 0, 0,  0, 0,-1/),(/3,3/))
       integer, dimension(3,3), parameter  :: xyz_3 = reshape( &
                                 (/ 0, 1, 0,  0, 0, 1,  1, 0, 0/),(/3,3/))
       integer, dimension(4,4), parameter :: identidad = reshape((/1, 0, 0, 0, &
                                                                     0, 1, 0, 0, &
                                                                     0, 0, 1, 0, &
                                                                     0, 0, 0, 1/),(/4,4/))
       integer, parameter             :: num_tab=24
       integer, dimension(4,4,num_tab):: tabla
       integer, dimension(4,4,4) :: gener
       integer, dimension(4,4)   :: sn, snp
       integer, dimension(4,4)   :: m1,m2
       integer, dimension(4)     :: num_rot
       integer, dimension(4)     :: num_eje
       integer, dimension(4)     :: num_tras
       integer, dimension(3)     :: vtras

       logical                   :: only_rot
       integer                   :: i,j,k,n,nt,ntp,npos
       integer                   :: pos_ini,pos_act,pos_fin,ini,fin
       integer                   :: ngen, neje, nrot, signo
       integer                   :: tx,ty,tz

       !---- Inicio ----!
       isystm=0
       isymce=1
       ibravl=0
       ng=0
       ss=0
       ts=0.0
       co=0.0
       latsy=" "
       num_g=1
       call init_err_symm()

       !---- Convert to Upper case ----!
       group = hall
       call ucase(group)
       group=adjustl(group)

       pos_ini=1
       pos_act=1
       pos_fin=len_trim(group)

       !---- Centric / Acentric ----!
       if (group(pos_ini:pos_ini) == "-") then
          isymce=2
          pos_ini=pos_ini+1
       else
       !
       ! Determine first if there are parenthesis
       !
          i=index(group(1:pos_fin),"(")
          if(i == 0) then
             npos=index(group(1:pos_fin),"-1",back=.true.)
          else
             npos=index(group(1:i),"-1",back=.true.)
          end if
          if (npos /= 0) then
             vtras=0
             do i=npos+2,pos_fin
                do j=1,13
                   if (group(i:i) == traslacion(j)) then
                      if (j < 9) then       ! a b c n u v w d
                         vtras=vtras+tras_val(:,j)
                      end if
                   end if
                end do
             end do

             vtras=mod(vtras,12)
             co=real(vtras)/12.0
             co=0.5*co
             if (vtras(1) == 0 .and. vtras(2) == 0 .and. vtras(3) == 0) then
                isymce=2
             else
                isymce=0
                pos_fin=npos-2
             end if
          end if
       end if

       !---- Tipo de Celda ----!
       ibravl=0
       do i=1,7
          if (group(pos_ini:pos_ini) /= red(i)) cycle
          ibravl=i
          exit
       end do
       if (ibravl == 0) then
          err_symm=.true.
          ERR_Symm_Mess=" IBRAVL is Equal Zero"
          return
       end if
       pos_ini=pos_ini+2

       !---- Determinacion de Generadores ----!
       gener=0
       gener(4,4,:)=1

       num_rot=0
       num_eje=0
       num_tras=1
       ngen=0

       do
          if (pos_ini > pos_fin) exit        ! Fin de caracterizacion

          pos_act=index(group(pos_ini:pos_fin)," ")

          only_rot=.false.
          nrot=0
          vtras=0
          signo=1
          neje=0
          if (ngen==0) neje=3                ! Eje C

          if (pos_act /=0) then
             ini=pos_ini
             if (pos_act /= 1) then
                fin=pos_ini+pos_act-2
             else
                fin=pos_ini+pos_act-1
             end if
          else
             ini=pos_ini
             fin=pos_fin
          end if

          !---- Desplazamiento del origen ----!
          if (group(ini:ini)=="(") then
             npos=0
             do i=ini+1,pos_fin-1            ! Eliminamos parentesis
                if (group(i:i)==" ") cycle
                if (group(i:i)=="-") then
                   signo=-1
                   cycle
                end if

                npos=npos+1
                do j=1,5
                   if (group(i:i)==shift(j)) then
                      vtras(npos)=j*signo
                      signo=1
                      exit
                   end if
                end do

             end do

             sn=0
             snp=0
             do i=1,4
                sn(i,i)=1
                snp(i,i)=1
             end do
             do i=1,3
                sn(i,4) =  vtras(i)
                snp(i,4)= -vtras(i)
             end do

             gener(:,:,ngen)=matmul(sn,gener(:,:,ngen))
             gener(:,:,ngen)=matmul(gener(:,:,ngen),snp)

             exit         ! Fin de busqueda
          end if

          !---- Eje de rotacion Propio/Impropio ----!
          if (group(ini:ini)=="-") then
             signo=-1
             ini=ini+1
          end if

          !---- Eje de rotacion ----!
          do j=1,5
             if (group(ini:ini) /= rotacion(j)) cycle
             nrot=j
             exit
          end do
          if (nrot==0) then
             err_symm=.true.
             return
          end if

          if (ini ==fin) only_rot=.true.
          ini=ini+1
          ini=min(ini,fin)

          !---- Direccion de Rotacion y Traslaciones ----!
          do i=ini,fin
             do j=1,6
                if (group(i:i) /= ejes_rotacion(j)) cycle
                neje=j
                exit
             end do

             if (neje == 0) then
                select case (ngen)
                    case (0)
                       neje=3
                    case (1)
                       neje=1
                       if (nrot == 2) then
                          if (num_rot(1)==2 .or. num_rot(1)==4) neje=1
                          if (num_rot(1)==3 .or. num_rot(1)==5) neje=4
                       end if
                    case (2)
                       neje=1
                       if (nrot == 3) neje=6
                    case (3)
                       neje=1
                end select
             end if


             if (only_rot) cycle    ! Solo eje de rotacion

             do j=1,13
                if (group(i:i) == traslacion(j)) then
                   if (j < 9) then       ! a b c n u v w d
                      vtras=vtras+tras_val(:,j)
                      select case (j)
                          case (5:8)
                          num_tras(ngen+1)=num_tras(ngen+1)*3
                      end select

                   else                  ! 1 2 3 4 6
                      if (nrot ==3 .or. nrot==4 .or. nrot==5) then
                         n=j-8
                         if (nrot==5) then
                            n=n*2
                         else
                            n=n*12/nrot
                         end if
                         vtras=0
                         vtras(neje)=n

                         num_tras(ngen+1)=num_tras(ngen+1)*(nrot-1)
                      else
                         err_symm=.true.
                         return
                      end if
                   end if
                end if
             end do

          end do

          !---- Cargando informacion ----!
          ngen=ngen+1
          num_rot(ngen)=nrot
          num_eje(ngen)=neje

          select case (nrot)
              case (1)
                 select case (neje)
                     case (1)
                        gener(1:3,1:3,ngen)=x_1*signo
                     case (2)
                        gener(1:3,1:3,ngen)=y_1*signo
                     case (3)
                        gener(1:3,1:3,ngen)=z_1*signo
                     case (4:6)
                        err_symm=.true.
                        return
                 end select
                 gener(1:3,4,ngen)=vtras

              case (2)
                 select case (neje)
                     case (1)
                        gener(1:3,1:3,ngen)=x_2*signo
                     case (2)
                        gener(1:3,1:3,ngen)=y_2*signo
                     case (3)
                        gener(1:3,1:3,ngen)=z_2*signo
                     case (4)
                        select case (num_eje(1))
                            case (1)
                               gener(1:3,1:3,ngen)=x_2p*signo
                            case (2)
                               gener(1:3,1:3,ngen)=y_2p*signo
                            case (3)
                               gener(1:3,1:3,ngen)=z_2p*signo
                            case (6)
                               gener(1:3,1:3,ngen)=z_2p*signo
                            case default
                               err_symm=.true.
                               return
                        end select
                     case (5)
                        select case (num_eje(1))
                            case (1)
                               gener(1:3,1:3,ngen)=x_2pp*signo
                            case (2)
                               gener(1:3,1:3,ngen)=y_2pp*signo
                            case (3)
                               gener(1:3,1:3,ngen)=z_2pp*signo
                            case default
                               err_symm=.true.
                               return
                        end select
                     case (6)
                        err_symm=.true.
                        return
                 end select
                 gener(1:3,4,ngen)=vtras

              case (3)
                 select case (neje)
                     case (1)
                        gener(1:3,1:3,ngen)=x_3*signo
                     case (2)
                        gener(1:3,1:3,ngen)=y_3*signo
                     case (3)
                        gener(1:3,1:3,ngen)=z_3*signo
                     case (4:5)
                        err_symm=.true.
                        return
                     case (6)
                        gener(1:3,1:3,ngen)=xyz_3*signo
                 end select
                 gener(1:3,4,ngen)=vtras

              case (4)
                 select case (neje)
                     case (1)
                        gener(1:3,1:3,ngen)=x_4*signo
                     case (2)
                        gener(1:3,1:3,ngen)=y_4*signo
                     case (3)
                        gener(1:3,1:3,ngen)=z_4*signo
                     case (4:6)
                        err_symm=.true.
                        return
                 end select
                 gener(1:3,4,ngen)=vtras

              case (5)
                 select case (neje)
                     case (1)
                        gener(1:3,1:3,ngen)=x_6*signo
                     case (2)
                        gener(1:3,1:3,ngen)=y_6*signo
                     case (3)
                        gener(1:3,1:3,ngen)=z_6*signo
                     case (4:6)
                        err_symm=.true.
                        return
                 end select
                 gener(1:3,4,ngen)=vtras

          end select

          pos_ini=fin+2
       end do

       !---- Tabla de caracteres ----!
       tabla=0
       tabla(:,:,1)=identidad

       !---- Put Generators on the table ----!
       nt=1
       do i=1,ngen
          if (ngen == 1 .and. num_rot(1)==1) exit    ! only triclinic
          nt=nt+1
          tabla(:,:,nt)=gener(:,:,i)
          tabla(:,4,nt)=mod(tabla(:,4,nt)+48,12)
       end do

       !num_g=nt-1 !Minimum number of generators
        num_g=ngen

            !---- Generate power operations from generators ----!
       do i=2,nt
           ntp=axes_rotation(tabla(:,:,i))    ! Determine the order of the generator
          if (ntp == -1 .or. ntp == -3) then
             ntp=-2*ntp
          else
             ntp=abs(ntp)
          end if

          m1=tabla(:,:,i)
          m2=identidad

          p1:do j=1,ntp-1
             m2=matmul(m2,m1)
             m2(:,4)=mod(m2(:,4)+48,12)

             !---- Check if the generated operation is already in the table
             do k=1,nt
                if (equal_matrix(tabla(:,:,k),m2,4)) cycle p1
             end do

             !---- Eliminating lattice contribution if necessary ----!
             select case (ibravl)
                 case (2)
                    ty=m2(2,4)
                    tz=m2(3,4)
                    if (ty >= 6 .and. tz >= 6) then
                       ty=mod(m2(2,4),6)
                       tz=mod(m2(3,4),6)

                       if (ty == 0 .and. tz == 0) then
                          cycle p1
                       else
                          m2(2,4)=ty
                          m2(3,4)=tz
                       end if
                    end if

                 case (3)
                    tx=m2(1,4)
                    tz=m2(3,4)
                    if (tx >= 6 .and. tz >=6) then
                       tx=mod(m2(1,4),6)
                       tz=mod(m2(3,4),6)

                       if (tx == 0 .and. tz == 0) then
                          cycle p1
                       else
                          m2(1,4)=tx
                          m2(3,4)=tz
                       end if
                    end if

                 case (4)
                    tx=m2(1,4)
                    ty=m2(2,4)
                    if (tx >=6 .and. ty >= 6) then
                       tx=mod(m2(1,4),6)
                       ty=mod(m2(2,4),6)

                       if (tx == 0 .and. ty == 0) then
                          cycle p1
                       else
                          m2(1,4)=tx
                          m2(2,4)=ty
                       end if
                    end if

                 case (5)
                    tx=m2(1,4)
                    ty=m2(2,4)
                    tz=m2(3,4)
                    if (tx >=6 .and. ty >=6 .and. tz >=6) then
                       tx=mod(m2(1,4),6)
                       ty=mod(m2(2,4),6)
                       tz=mod(m2(3,4),6)

                       if (tx == 0 .and. ty == 0 .and. tz == 0) then
                          cycle p1
                       else
                          m2(1,4)=tx
                          m2(2,4)=ty
                          m2(3,4)=tz
                       end if
                    end if

                 case (6)
                    tx=m2(1,4)
                    ty=m2(2,4)
                    tz=m2(3,4)
                    if (tx >=8 .and. ty >=4 .and. tz >=4) then
                       tx=mod(m2(1,4),8)
                       ty=mod(m2(2,4),4)
                       tz=mod(m2(3,4),4)
                       if (tx == 0 .and. ty == 0 .and. tz == 0) then
                          cycle p1
                       else
                          m2(1,4)=tx
                          m2(2,4)=ty
                          m2(3,4)=tz
                       end if

                    else if (tx >=4 .and. ty >=8 .and. tz >=8) then
                       tx=mod(m2(1,4),4)
                       ty=mod(m2(2,4),8)
                       tz=mod(m2(3,4),8)
                       if (tx == 0 .and. ty == 0 .and. tz == 0) then
                          cycle p1
                       else
                          m2(1,4)=tx
                          m2(2,4)=ty
                          m2(3,4)=tz
                       end if
                    end if

                 case (7)
                    tx=m2(1,4)
                    ty=m2(2,4)
                    tz=m2(3,4)
                    if (ty >= 6 .and. tz >=6) then
                       ty=mod(m2(2,4),6)
                       tz=mod(m2(3,4),6)
                       if (tx == 0 .and. ty == 0 .and. tz == 0) then
                          cycle p1
                       else
                          m2(2,4)=ty
                          m2(3,4)=tz
                       end if
                    else if (tx >=6 .and. tz >=6) then
                       tx=mod(m2(1,4),6)
                       tz=mod(m2(3,4),6)
                       if (tx == 0 .and. ty == 0 .and. tz == 0) then
                          cycle p1
                       else
                          m2(1,4)=tx
                          m2(3,4)=tz
                       end if
                    else if (tx >=6 .and. ty >=6) then
                       tx=mod(m2(1,4),6)
                       ty=mod(m2(2,4),6)
                       if (tx == 0 .and. ty == 0 .and. tz == 0) then
                          cycle p1
                       else
                          m2(1,4)=tx
                          m2(2,4)=ty
                       end if
                    end if
             end select

             nt=nt+1
             if (nt > num_tab) then
                err_symm=.true.
                ERR_Symm_Mess=" Dimension of Table exceeded (I)"
                return
             end if
             tabla(:,:,nt)=m2
          end do p1
       end do

       !---- Multiplications between generators ----!
       do
          if (nt == 1) exit
          n=nt

          do i=1,n
             p2:do j=i,n

                m2=matmul(tabla(:,:,i),tabla(:,:,j))
                m2(:,4)=mod(m2(:,4)+48,12)

                !---- Eliminating lattice contribution if necessary ----!
                select case (ibravl)
                   case (2)
                      ty=m2(2,4)
                      tz=m2(3,4)
                      if (ty >= 6 .and. tz >= 6) then
                         ty=mod(m2(2,4),6)
                         tz=mod(m2(3,4),6)
                         m2(2,4)=ty
                         m2(3,4)=tz
                      end if

                   case (3)
                      tx=m2(1,4)
                      tz=m2(3,4)
                      if (tx >= 6 .and. tz >= 6) then
                         tx=mod(m2(1,4),6)
                         tz=mod(m2(3,4),6)
                         m2(1,4)=tx
                         m2(3,4)=tz
                      end if

                   case (4)
                      tx=m2(1,4)
                      ty=m2(2,4)
                      if (tx >= 6 .and. ty >= 6) then
                         tx=mod(m2(1,4),6)
                         ty=mod(m2(2,4),6)
                         m2(1,4)=tx
                         m2(2,4)=ty
                      end if

                   case (5)
                      tx=m2(1,4)
                      ty=m2(2,4)
                      tz=m2(3,4)
                      if (tx >= 6 .and. ty >= 6 .and. tz >= 6) then
                         tx=mod(m2(1,4),6)
                         ty=mod(m2(2,4),6)
                         tz=mod(m2(3,4),6)
                         m2(1,4)=tx
                         m2(2,4)=ty
                         m2(3,4)=ty
                      end if

                   case (6)
                      tx=m2(1,4)
                      ty=m2(2,4)
                      tz=m2(3,4)
                      if (tx >=8 .and. ty >=4 .and. tz >=4) then
                         tx=mod(m2(1,4),8)
                         ty=mod(m2(2,4),4)
                         tz=mod(m2(3,4),4)
                         m2(1,4)=tx
                         m2(2,4)=ty
                         m2(3,4)=tz
                      else if (tx >=4 .and. ty >=8 .and. tz >=8) then
                         tx=mod(m2(1,4),4)
                         ty=mod(m2(2,4),8)
                         tz=mod(m2(3,4),8)
                         m2(1,4)=tx
                         m2(2,4)=ty
                         m2(3,4)=tz
                      end if

                   case (7)
                      tx=m2(1,4)
                      ty=m2(2,4)
                      tz=m2(3,4)
                      if (ty >= 6 .and. tz >=6) then
                         ty=mod(m2(2,4),6)
                         tz=mod(m2(3,4),6)
                         m2(2,4)=ty
                         m2(3,4)=tz
                      else if (tx >=6 .and. tz >=6) then
                         tx=mod(m2(1,4),6)
                         tz=mod(m2(3,4),6)
                         m2(1,4)=tx
                         m2(3,4)=tz
                      else if (tx >=6 .and. ty >=6) then
                         tx=mod(m2(1,4),6)
                         ty=mod(m2(2,4),6)
                         m2(1,4)=tx
                         m2(2,4)=ty
                      end if
                end select

                do k=1,nt
                   if ( equal_matrix(m2(:,:),tabla(:,:,k),4) ) cycle p2
                   if ( equal_matrix(m2(:,:),tabla(:,:,k),3) ) then
                      tx=m2(1,4)+tabla(1,4,k)
                      ty=m2(2,4)+tabla(2,4,k)
                      tz=m2(3,4)+tabla(3,4,k)
                      tx=mod(tx,12)
                      ty=mod(ty,12)
                      tz=mod(tz,12)
                      select case (ibravl)
                          case (2)
                             if (ty == 6 .and. tz == 6) cycle p2
                             if (ty == 0 .and. tz == 0) cycle p2

                          case (3)
                             if (tx == 6 .and. tz == 6) cycle p2
                             if (tx == 0 .and. tz == 0) cycle p2

                          case (4)
                             if (tx == 6 .and. ty == 6) cycle p2
                             if (tx == 0 .and. ty == 0) cycle p2

                          case (5)
                             if (tx == 6 .and. ty == 6 .and. tz == 6) cycle p2
                             if (tx == 0 .and. ty == 0 .and. tz == 0) cycle p2

                          case (6)
                             if (tx == 8 .and. ty == 4 .and. tz == 4) cycle p2
                             if (tx == 4 .and. ty == 8 .and. tz == 8) cycle p2
                             if (tx == 0 .and. ty == 0 .and. tz == 0) cycle p2

                          case (7)
                             if (ty == 6 .and. tz == 6) cycle p2
                             if (tx == 6 .and. tz == 6) cycle p2
                             if (tx == 6 .and. ty == 6) cycle p2

                             if (ty == 0 .and. tz == 0) cycle p2
                             if (tx == 0 .and. tz == 0) cycle p2
                             if (tx == 0 .and. ty == 0) cycle p2

                      end select

                      tx=m2(1,4)-tabla(1,4,k)
                      ty=m2(2,4)-tabla(2,4,k)
                      tz=m2(3,4)-tabla(3,4,k)
                      tx=mod(tx+48,12)
                      ty=mod(ty+48,12)
                      tz=mod(tz+48,12)

                      select case (ibravl)
                          case (2)
                             if (ty == 6 .and. tz == 6) cycle p2
                             if (ty == 0 .and. tz == 0) cycle p2

                          case (3)
                             if (tx == 6 .and. tz == 6) cycle p2
                             if (tx == 0 .and. tz == 0) cycle p2

                          case (4)
                             if (tx == 6 .and. ty == 6) cycle p2
                             if (tx == 0 .and. ty == 0) cycle p2

                          case (5)
                             if (tx == 6 .and. ty == 6 .and. tz == 6) cycle p2
                             if (tx == 0 .and. ty == 0 .and. tz == 0) cycle p2

                          case (6)
                             if (tx == 8 .and. ty == 4 .and. tz == 4) cycle p2
                             if (tx == 4 .and. ty == 8 .and. tz == 8) cycle p2
                             if (tx == 0 .and. ty == 0 .and. tz == 0) cycle p2

                          case (7)
                             if (ty == 6 .and. tz == 6) cycle p2
                             if (tx == 6 .and. tz == 6) cycle p2
                             if (tx == 6 .and. ty == 6) cycle p2

                             if (ty == 0 .and. tz == 0) cycle p2
                             if (tx == 0 .and. tz == 0) cycle p2
                             if (tx == 0 .and. ty == 0) cycle p2
                      end select
                   end if
                end do

                nt=nt+1
                if (nt > num_tab) then
                   err_symm=.true.
                   ERR_Symm_Mess=" Dimension of Table exceeded (II)"
                   return
                end if
                tabla(:,:,nt)=m2

             end do p2
          end do

          if (n == nt) exit

       end do

       !---- Carga Final ----!
       ng=nt
       do i=1,nt
          ss(:,:,i)=tabla(1:3,1:3,i)
          ts(:,i)  = real(tabla(1:3,4,i))/12.0
       end do

       !---- Determination of the crystalline system and Bravais lattice ----!
       call get_crystal_System(ng,ss,isystm,latsy(1:1))
       latsy(2:)=red(ibravl)
       call latsym(red(ibravl))

       return
    End Subroutine Get_SO_from_Hall

    !!----
    !!---- Subroutine Get_So_From_Hms(Isystm,Isymce,Ibravl,Ng,Ss,Ts,Latsy,Spaceh)
    !!----    integer,                        intent(out)  :: ISYSTM    ! Out -> Number of the crystalline system
    !!----                                                                       (1:T, 2:M, 3:O, 4:T, 5:R-Trg, 6:H, 7:C)
    !!----    integer,                        intent(out)  :: ISYMCE    ! Out -> 0 Centric (-1 not at origin)
    !!----                                                                       1 Acentric
    !!----                                                                       2 Centric (-1 at origin)
    !!----    integer,                        intent(out)  :: IBRAVL    ! Out -> Index of the Bravais Lattice type
    !!----                                                                       1   2   3   4   5   6   7
    !!----                                                                      "P","A","B","C","F","I","R"
    !!----    integer,                        intent(out)  :: NG        ! Out -> Number of symmetry operators
    !!----    real(kind=cp),dimension(:,:),   intent(out)  :: TS        ! Out -> Translation parts of the symmetry operators
    !!----    integer, dimension(:,:,:),      intent(out)  :: SS        ! Out -> Rotation parts of the symmetry operators
    !!----    character (len=2),              intent(out)  :: latsy     ! Out -> Bravais lattice symbol
    !!----    character (len=20),             intent( in)  :: SpaceH    !  In -> H-M Spacegroup symbol
    !!----
    !!----    Subroutine to get all the information contained in the H-M symbol.
    !!----    Routine to interpret Hermann-Mauguin symbol for space group.
    !!--..    This routine has been adapted from a program supplied by prof. Burzlaff,
    !!--..    University of Erlangen, Germany.
    !!--..    (Author:Juan Rodriguez-Carvajal)
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Get_SO_from_HMS(Isystm,Isymce,Ibravl,Ng,Ss,Ts,Latsy,SpaceH)
       !---- Arguments ----!
       integer,                   intent(out) :: ISYSTM
       integer,                   intent(out) :: ISYMCE
       integer,                   intent(out) :: IBRAVL
       integer,                   intent(out) :: NG
       integer, dimension(:,:,:), intent(out) :: Ss  !(3,3,48)
       real(kind=cp),    dimension(:,:),   intent(out) :: Ts  !(3,48)
       character (len= 2),        intent(out) :: Latsy
       character (len=*),         intent( in) :: SpaceH

       !---- Local variables ----!
       character (len=20):: GROUP
       character (len=1) :: M,N, Item_SP
       character (len=1), dimension(3,4) :: HMS
       character (len=*), dimension(7), parameter :: IBRA=(/"P","A","B","C","F","I","R"/)
       integer :: SYS,i,j,k,l,NBR,NE,MM,ID,IC,NS,IND,NBL,NLQ,MA
       integer, dimension(3) ::  NMA
       integer, dimension(3,3) :: E
       real(kind=cp) :: TC
       real(kind=cp), dimension(   3):: TE, SH

       NMA = 0
       SH  = 0.25

       !---- Convert to upper case  SpaceG -> GROUP ----!
       group=adjustl(SpaceH)
       call ucase(group)

       NBL=-1
       NG=1
       NS=1
       IBRAVL=0
       TE(1:3) = 0.0
       TS(1:3,1:24) = 0.0
       E(1:3 ,1:3) = 0
       SS(1:3,1:3,1:24) = 0
       SS(1,1,1) = 1
       SS(2,2,1) = 1
       SS(3,3,1) = 1
       HMS(1:3,1:4) = " "
       call init_err_symm()

       do i=1,len_trim(group)         !scanning the Upper-ed case space group symbol
          item_sp=group(i:i)
          if (item_sp == " ") then     !If blank cycle after initializing the indices
             nlq=0                     !for HMS
             ic=0
             cycle
          end if

          if (nbl < 0) then
             do j=1,7
                nbr=j
                if (item_sp == ibra(j)) then
                   nbl=0
                   ibravl=nbr        !Bravais Lattice symbol (first non-blank item of GROUP)
                   exit
                end if
             end do

             if (ibravl == 0) then
                err_symm=.true.
                ERR_Symm_Mess=" Wrong space-group symbol: "//SpaceH
                return
             else if (IBRAVL == 5) then     !These changes are to conform with
                IBRAVL=7                    !the definition of LAT in SYMMETRY
             else if (IBRAVL == 6) then     !modules
                IBRAVL=5
             else if (IBRAVL == 7) THEN
                IBRAVL=6
             end if                         !                1   2   3   4   5   6   7
             cycle                          !               "P","A","B","C","F","I","R"
          end if                            !                p   a   b   c   i   r   f

          if (nlq == 0) nbl=nbl+1      !New blank separating symmetry directions
          ic=ic+1                      !Maximum =4  eg. 63/m
          if (ic > 4) ic=4             !Protection against bad typing of
          if (nbl > 3) nbl=3           !space group symbol
          hms(nbl,ic)=item_sp
          nlq=1
          if (item_sp == "/") ns=0
       end do                          !End loop of Scanning the Upper-ed case space group symbol

       !---- Determination of the crystal system ----!
       SYS=0
       do i=1,4
          if (hms(2,i) == "3") then    !cubic
             sys=6
             isystm=7
             latsy="c"//ibra(NBR)
             exit
          else if (hms(1,i) == "3") then
             sys=5                        !trigonal (rhombohedral)
             isystm=5
             latsy="h"//ibra(NBR)
             exit
          else if (hms(1,i) == "6") then
             sys=5                        !hexagonal (same block as trigonal)
             isystm=6
             latsy="hP"
             exit
          else if(hms(1,i) == "4") then
             sys=4                        !tetragonal
             isystm=4
             latsy="t"//ibra(NBR)
             exit
          end if
       end do

       if (nbl <= 1 .and. sys==0) then
          if (hms(1,1) == "1" .or. hms(1,1) == "-") then
             sys=1           !triclinic
             isystm=1
             latsy="a"//ibra(nbr)
          else
             sys=2           !monoclinic
             isystm=2
             latsy="m"//ibra(nbr)
             do i=1,4
                hms(2,i)=hms(1,i)  ! put the symbol in the form l 1 2/m 1
                hms(1,i)=" "
             end do
             hms(1,1)="1"   !complete the symbol with 1 along a and c
             hms(3,1)="1"
          end if
       end if

       if (nbl > 1 .and. sys==0) then
          sys=3     !orthorhombic
          isystm=3
          latsy="o"//ibra(nbr)
          if (hms(1,1) == "1".or.hms(2,1) == "1") then
             sys=2
             isystm=2
             latsy="m"//ibra(nbr)
          end if
       end if

       call check_symbol_hm(HMS)
       if (err_symm) return
       call latsym(ibra(nbr))


       SELECT CASE (SYS)     !SYS is the crystal family
          CASE (1)      !  TRICLINIC
             IF (HMS(1,1) == "-") NS=0

          CASE (2)      !  MONOCLINIC
             NG=2
             DO I=1,3
                IF (HMS(I,1)/="1") IND=I
             END DO
             ID=1
             IF (HMS(IND,1) == "2") ID=-1
             DO I=1,3
                SS(I,I,2)=SS(I,I,1)*ID
             END DO
             SS(IND,IND,2)=-SS(IND,IND,2)
             DO I=1,3
                IF (HMS(I,1) == "2".AND.HMS(I,2) == "1") TS(I,2)=0.5
                DO J=1,4
                   IF (HMS(I,J) == "A") TS(1,2)=0.5
                   IF (HMS(I,J) == "B") TS(2,2)=0.5
                   IF (HMS(I,J) == "C") TS(3,2)=0.5
                   IF (HMS(I,J) == "N") THEN
                      K=I+1
                      IF (K > 3) K=K-3
                      TS(K    ,2)=0.5
                      TS(6-K-I,2)=0.5
                   END IF
                END DO
             END DO

          CASE (3)   !  ORTHORHOMBIC
             NG=4
             IC=0
             IND=1
             IF (HMS(1,1)/="2".AND.HMS(2,1)/="2".AND.HMS(3,1) /= "2") IND=-1
             IF (IND == -1) NS=0
             DO I=1,3
                ID=1
                IF (HMS(I,1) == "2") ID=-1
                DO J=1,3
                   SS(J,J,1+I)=SS(J,J,1)*ID*IND
                END DO
                SS(I,I,1+I)=-SS(I,I,1+I)
             END DO
             DO I=1,3
                IF (HMS(I,1) == "2" .AND. HMS(I,2) == "1") TS(I,1+I)=0.5
                DO J=1,4
                   IF (HMS(I,J) == "A") TS(1,1+I)=0.5
                   IF (HMS(I,J) == "B") TS(2,1+I)=0.5
                   IF (HMS(I,J) == "C") TS(3,1+I)=0.5
                   IF (HMS(I,J) == "N" .OR. HMS(I,J) == "D") THEN
                      K=I+1
                      IF (K > 3) K=K-3
                      IF (HMS(I,J) == "D") THEN
                         IC=1
                         IF (NS == 1) THEN
                            TS(1,1+I)=0.25
                            TS(2,1+I)=0.25
                            TS(3,1+I)=0.25
                         ELSE                !was missing
                            TS(    K,1+I)=0.25
                            TS(6-K-I,1+I)=0.25
                         END IF
                      ELSE                   !was missing
                        TS(K    ,1+I)=0.5
                        TS(6-K-I,1+I)=0.5
                      END IF
                   END IF
                END DO
             END DO

             if (ic == 1) then
                call mod_trans(ng,ns,ts,isymce)
                return
             end if

             if (ns == 1) then
                ic=0
                do i=1,3
                   if (ss(1,1,1+i)*ss(2,2,1+i)*ss(3,3,1+i) == -1) ic=1  !there are planes
                end do

                if (ic == 1) then
                   do i=1,3
                      if (ss(1,1,1+i)*ss(2,2,1+i)*ss(3,3,1+i) == 1) id=i
                   end do
                   do i=1,3
                      tc=ts(i,2)+ts(i,3)+ts(i,4)
                      if (abs(tc) < eps_symm .or. abs(tc-1.0) < eps_symm) cycle
                      IF (HMS(1,1) == "M" .AND. HMS(2,1) == "N".OR.         &
                          HMS(2,1) == "M" .AND. HMS(3,1) == "N".OR.         &
                          HMS(3,1) == "M" .AND. HMS(1,1) == "N")    THEN
                         k=i-1
                         if (k == 0) k=k+3
                         ts(i,1+k)=0.5
                         cycle !was missing
                      end if
                      do j=1,3
                         if (id/=j) then
                            if (abs(ts(i,1+j)-0.5) > eps_symm) ts(i,1+j)=0.5
                         end if
                      end do
                   end do
                      call mod_trans(ng,ns,ts,isymce)
                      return
                end if   ! it was else

                   tc=ts(1,2)+ts(2,3)+ts(3,4)
                   if (abs(tc) < eps_symm) then
                      call mod_trans(ng,ns,ts,isymce)
                      return
                   end if
                   do i=1,3
                      k=i+1
                      if (k > 3) k=k-3
                      if (tc > 0.5) then
                         if (tc > 1.0) then
                            ts(k,1+i)=0.5
                            cycle
                         end if
                         if (abs(ts(i,1+i)) >=0.000001) cycle
                         l=k+1
                         if (l > 3) l=l-3
                         ts(l,1+k)=0.5
                         ts(k,1+l)=0.5
                         cycle
                      end if
                      if (abs(ts(i,1+i)) < eps_symm) cycle
                      mm=i-1
                      if (mm == 0) mm=mm+3
                      ts(i,1+mm)=0.5
                   end do
                   call mod_trans(ng,ns,ts,isymce)
                   return
             end if

                do i=1,3
                   k=1+i
                   if (k > 3) k=k-3
                   tc=ts(i,1+k)+ts(i,1+6-i-k)
                   if (abs(tc-1.0) < eps_symm) tc=0.0
                   ts(i,1+i)=tc
                end do

                !---- special treatment of c m m a, c m c a, i m m a ---- !
                if (nbr == 1 .or. nbr == 5) then
                   call mod_trans(ng,ns,ts,isymce)
                   return
                end if
                ma=0
                do i=1,3
                   do j=1,4
                      IF (HMS(I,J) == "M") NMA(I)=1
                   end do
                   ma=ma+nma(i)
                end do

                if (.not. (nbr == 6 .and. ma == 2) ) then

                   if (ma == 0 .or. ma == 3 .or. nbr == 6) then
                      call mod_trans(ng,ns,ts,isymce)
                      return
                   end if
                   do i=1,3
                      if (nma(nbr-1) == 1) then
                         call mod_trans(ng,ns,ts,isymce)
                         return
                      end if
                      sh(nbr-1)=0.0
                   end do

                end if

                   !---- origin shift ----!
                   do i=1,ng
                      do j=1,3
                         do k=1,3
                            id=1
                            if (j/=k) id=0
                            ts(j,i)=ts(j,i)+(id-ss(j,k,i))*sh(k)
                         end do
                         if (ts(j,i) > 1.0) ts(j,i)=ts(j,i)-1.0
                         if (ts(j,i) < 0.0) ts(j,i)=ts(j,i)+1.0
                      end do
                   end do
                   call mod_trans(ng,ns,ts,isymce)
                   return

          CASE (4)   !  TETRAGONAL
             NG=4
             IF (NBL == 3) NG=8
             SS(1,2,2)=-1
             SS(2,1,2)=1
             SS(3,3,2)=1
             M=HMS(1,1)
             N=HMS(1,2)
             DO I=1,3
                DO J=1,3
                   IF (M == "-") SS(I,J,2)=-SS(I,J,2)
                END DO
             END DO
             IF (M/="-") THEN
                IF (N == "1") TS(3,2)=0.25
                IF (N == "2") TS(3,2)=0.5
                IF (N == "3") TS(3,2)=0.75
                IF (HMS(1,3) == "N" .OR. (HMS(1,4) =="N" .AND. NBL == 3)) TS(1,2)=0.5
                IF ((HMS(1,4) == "N" .AND. NBL == 1).OR.(N == "1" .AND.     &
                     NS == 1 .AND. NBR == 6)) TS(2,2)=0.5
                IF (N == "1" .AND. NS == 0 .AND. NBR == 6) THEN
                   TS(1,2)=0.25
                   TS(2,2)=0.75
                   IF (NBL == 1) TS(1,2)=0.75
                   IF (NBL == 1) TS(2,2)=0.25
                ELSE IF (HMS(2,2) == "1".OR.(HMS(1,4)/="N" .AND. HMS(2,1)    &
                                 ==   "N" .AND. HMS(3,1) == "M")) THEN
                   TS(1,2)=0.5
                   TS(2,2)=0.5
                END IF
             END IF
             ss(1,1,3)=-1
             ss(2,2,3)=-1
             ss(3,3,3)=1
             ts(1,3)=ss(1,2,2)*ts(2,2)+ts(1,2)
             ts(2,3)=ss(2,1,2)*ts(1,2)+ts(2,2)
             ts(3,3)=ss(3,3,2)*ts(3,2)+ts(3,2)
             do i=1,3
                if (nbr == 6                                 &
                            .and. abs(ts(1,3)-0.5) < eps_symm     &
                            .and. abs(ts(2,3)-0.5) < eps_symm     &
                            .and. abs(ts(3,3)-0.5) < eps_symm) ts(i,3)=0.0
             end do
             do i=1,3
                ts(i,4)=ts(i,2)
                do j=1,3
                   ts(i,4)=ts(i,4)+ss(i,j,2)*ts(j,3)
                   do k=1,3
                      ss(i,j,4)=ss(i,j,4)+ss(i,k,2)*ss(k,j,3)
                   end do
                end do
             end do
             if (nbl == 1) then
                call mod_trans(ng,ns,ts,isymce)
                return
             end if
             m=hms(2,1)
             n=hms(3,1)
             ne=4
             IF (NS == 0) THEN
                E(1,1)=-1
                E(2,2)=1
                E(3,3)=1
                IF (M == "C".OR.M == "N") TE(3)=0.5
                IF (M == "B".OR.M == "N") TE(2)=0.5
                IF (M == "B".OR.M == "N") TE(1)=0.5
                IF (HMS(1,3) == "N".OR.HMS(1,4) == "N") TE(1)=TE(1)+0.5
             ELSE IF (M/="2".AND.N/="2")  THEN
                M=HMS(2,1)
                E(1,1)=-1
                E(2,2)=1
                E(3,3)=1
                IF (M == "C".OR.M == "N") TE(3)=0.5
                IF (M == "N".OR.M == "B") TE(1)=0.5
                IF (M == "N".OR.M == "B") TE(2)=0.5
             ELSE IF (M == "2".AND.N == "2") THEN
                E(1,2)=1
                E(2,1)=1
                E(3,3)=-1
    !            IF (.NOT.(HMS(2,2)/="0" .OR. NBR == 6 .OR. HMS(1,2) == "0")) THEN
                IF (.NOT.(HMS(2,2)/=" " .OR. NBR == 6 .OR. HMS(1,2) == " ")) THEN
                   IF (HMS(1,2) == "1") TE(3)=0.75
                   IF (HMS(1,2) == "2") TE(3)=0.5
                   IF (HMS(1,2) == "3") TE(3)=0.25
                END IF
             ELSE IF (M == "2") THEN
                E(1,1)=1
                E(2,2)=-1
                E(3,3)=-1
                IF (N == "C") TE(3)=0.5
                IF (N == "D") TE(3)=0.25
                IF (N == "D") TE(2)=0.5
                IF (.NOT. (HMS(2,2) /= "1")) THEN
                   TE(1)=0.5
                   TE(2)=0.5
                END IF
             ELSE
                IF (M == "C" .OR. M == "N") TE(3)=0.5
                E(1,1)=-1
                E(2,2)=1
                E(3,3)=1
                IF (.NOT.(M /= "N" .AND. M /= "B") ) THEN
                   TE(1)=0.5
                   TE(2)=0.5
                END IF
             END IF

          CASE(5)   !  HEXAGONAL  and TRIGONAL (RHOMBOHEDRAL)
             NG=3
             NE=6
             IF (HMS(1,1) == "3".OR.(HMS(1,2) == "3".AND.HMS(1,1) == "-")) NE=3
             M=HMS(1,1)
             N=HMS(1,2)
             IF (M == "-".AND.N == "3") NS=0
             IF (M == "6") THEN
                NG=NG+NG
                SS(1,1,2)=1
                SS(1,2,2)=-1
                SS(2,1,2)=1
                SS(3,3,2)=1
                IF (N == "1") TS(3,2)=1.0/6.0
                IF (N == "2") TS(3,2)=2.0/6.0
                IF (N == "3") TS(3,2)=3.0/6.0
                IF (N == "4") TS(3,2)=4.0/6.0
                IF (N == "5") TS(3,2)=5.0/6.0
                DO I=1,4
                   DO J=1,3
                      TS(J,2+I)=TS(J,2)
                      DO K=1,3
                         TS(J,2+I)=TS(J,2+I)+SS(J,K,2)*TS(K,1+I)
                         IF (TS(J,2+I) > 1.0) TS(J,2+I)=TS(J,2+I)-1.0
                         DO L=1,3
                            SS(J,K,2+I)=SS(J,K,2+I)+SS(J,L,2)*SS(L,K,1+I)
                         END DO
                      END DO
                   END DO
                END DO
                IF (NBL == 1) THEN
                   CALL MOD_TRANS(NG,NS,TS,ISYMCE)
                   RETURN
                END IF

             ELSE

                SS(1,2,2)=-1
                SS(2,1,2)=1
                SS(2,2,2)=-1
                SS(3,3,2)=1
                IF (N == "1") TS(3,2)=1.0/3.0
                IF (N == "2") TS(3,2)=2.0/3.0
                SS(1,1,3)=-1
                SS(2,1,3)=-1
                SS(1,2,3)=1
                SS(3,3,3)=1
                TS(3,3)=2.0*TS(3,2)
                IF (TS(3,3) >= 1.0) TS(3,3)=TS(3,3)-1.0
                IF (NBL == 1 .AND. N /= "6") THEN
                   CALL MOD_TRANS(NG,NS,TS,ISYMCE)
                   RETURN
                END IF
                IF (N == "6") THEN
                   NG=NG+NG
                   DO I=1,3
                      DO J=1,3
                         DO K=1,3
                            SS(J,K,3+I)=SS(J,K,I)
                            SS(3,3,3+I)=-1
                         END DO
                      END DO
                   END DO
                END IF
                IF (NBL == 1) THEN
                   CALL MOD_TRANS(NG,NS,TS,ISYMCE)
                   RETURN
                END IF
                IF (.NOT.(HMS(2,1)/="C".AND.HMS(3,1)/="C"))  THEN
                   TS(3,4)=0.5
                   TS(3,5)=0.5
                   TS(3,6)=0.5
                END IF
             END IF

             NG=NG+NG
             M=HMS(2,1)
             N=HMS(3,1)
             IF (M == "1") THEN
                IF (N == "2") THEN
                   E(1,2)=-1
                   E(2,1)=-1
                   E(3,3)=-1
                   TE(3)=2.0*TS(3,2)
                   IF (TE(3) > 1.0) TE(3)=TE(3)-1.0
                ELSE
                   E(1,2)=1
                   E(2,1)=1
                   E(3,3)=1
                   IF (N == "C") TE(3)=0.5
                END IF
             ELSE IF (M == "2") THEN
                E(1,2)=1
                E(2,1)=1
                E(3,3)=-1
                TE(3)=2.0*TS(3,2)
                !---- GROUP P 31 I 2 AND P 32 I 2 ----!
                IF(HMS(1,1)=="3".AND.(HMS(1,2)=="1".OR.HMS(1,2)=="2")) TE(3)=0.0
             ELSE
                E(1,2)=-1
                E(2,1)=-1
                E(3,3)=1
                IF (M == "C") TE(3)=0.5
             END IF

          CASE (6)    !  CUBIC
             NG=12
             IF (NBL == 3) NG=24
             IF (HMS(1,1)/="2".AND.HMS(1,1)/="4".AND.HMS(1,1)/="-") NS=0
             DO I=1,3
                DO J=1,3
                   SS(J,J,1+I)=1
                   IF (I/=J) THEN
                      SS(J,J,1+I)=-1
                      IF (HMS(1,1) == "N") TS(J,1+I)=0.5
                      IF (HMS(1,1) == "D") TS(J,1+I)=0.25
                   END IF
                END DO
             END DO
             IF (.NOT.((HMS(1,1) /="A".AND.HMS(3,1)/="D".AND.HMS(1,2)    &
                                 /="3" .AND.HMS(1,2)/="1".OR.NBR == 5))) THEN
                DO I=1,3
                   TS(I,1+I)=0.5
                   K=I+1
                   IF (K == 4) K=1
                   TS(K,1+I)=0.5
                END DO
             END IF
             DO I=1,4
                DO J=1,3
                   DO K=1,3
                      L=J+1
                      IF (L == 4) L=1
                      MM=J-1
                      IF (MM == 0) MM=3
                      SS(J,K,4+I)=SS(L,K ,I)
                      SS(J,K,8+I)=SS(MM,K,I)
                      TS(J,4+I)=TS(L ,I)
                      TS(J,8+I)=TS(MM,I)
                   END DO
                END DO
             END DO
             IF (NG == 12) THEN
                CALL MOD_TRANS(NG,NS,TS,ISYMCE)
                RETURN
             END IF
             NE=12
             E(1,2)=1
             E(2,1)=1
             E(3,3)=1
             IF (HMS(3,1) == "2") E(3,3)=-1
             IF (HMS(3,1) == "C") TE(3)=0.5
             DO I=1,3
                IF (HMS(3,1)=="N".OR.HMS(1,2)=="2") TE(I)=0.5
                IF (HMS(3,1)=="D".OR.HMS(1,2)=="1".OR.HMS(1,2)=="3") TE(I)=0.25
             END DO
             IF (HMS(1,2) == "1".AND.NBR == 1) TE(1)=0.75
             IF (.NOT.((HMS(1,2) /="1".OR.NBR/=6).AND.(HMS(1,2)   &
                                 /="3" .OR.NBR/=1))) THEN
                TE(2)=0.75
                TE(3)=0.75
             END IF
       END SELECT     ! On crystal system

       if (sys == 4 .or. sys == 5 .or. sys == 6) then
          do i=1,ne
             do j=1,3
                ts(j,ne+i)=te(j)
                do k=1,3
                   ts(j,ne+i)=ts(j,ne+i)+e(j,k)*ts(k,i)
                   do l=1,3
                      ss(j,k,ne+i)=ss(j,k,ne+i)+e(j,l)*ss(l,k,i)
                   end do
                end do
             end do
          end do
       end if

       call mod_trans(ng,ns,ts,isymce)

       return
    End Subroutine Get_SO_from_HMS

    !!----
    !!---- Subroutine Get_Stabilizer(X,Spg,Order,Ptr,Atr)
    !!----    real(kind=cp), dimension(3),  intent (in)  :: x     ! real(kind=cp) space position (fractional coordinates)
    !!----    type(Space_Group_type),       intent (in)  :: Spg   ! Space group
    !!----    integer,                      intent(out)  :: order ! Number of sym.op. keeping invariant the position x
    !!----    integer, dimension(:),        intent(out)  :: ptr   ! Array pointing to the symmetry operators numbers
    !!----                                                        ! of the stabilizer (point group) of x
    !!----    real(kind=cp), dimension(:,:),intent(out)  :: atr   ! Associated additional translation to the symmetry operator
    !!----
    !!----    Subroutine to obtain the list of symmetry operator of a space group that leaves
    !!----    invariant an atomic position. This subroutine provides a pointer to the symmetry
    !!----    operators of the site point group and the additional translation with respect to
    !!----    the canonical representant.
    !!----
    !!---- Update: June - 2011 (JRC)
    !!
    Subroutine Get_Stabilizer(X,Spg,Order,Ptr,Atr)
       !---- Arguments ----!
       real(kind=cp), dimension(3),  intent (in)  :: x     ! real space position (fractional coordinates)
       type(Space_Group_type),       intent (in)  :: Spg   ! Space group
       integer,                      intent(out)  :: order ! Number of sym.op. keeping invariant the position x
       integer, dimension(:),        intent(out)  :: ptr   ! Array pointing to the symmetry operators numbers
                                                           ! of the stabilizer of x
       real(kind=cp), dimension(:,:),intent(out)  :: atr   ! Associated additional translation to the symmetry operator
       !---- Local variables ----!
       real(kind=cp), dimension(3)    :: xx, tr

       integer                        :: j,n1,n2,n3

       order    = 1    !Identity belongs always to the stabilizer
       ptr(:)   = 0
       atr(:,:) = 0.0
       ptr(1)   = 1

       do n1=-1,1
        do n2=-1,1
          do n3=-1,1
            tr=real((/n1,n2,n3/))
             do j=2,Spg%multip
                xx=ApplySO(Spg%SymOp(j),x)+tr-x
                if (sum(abs(xx)) > 2.0 * eps_symm) cycle
                order=order+1
                ptr(order)=j
                atr(:,order)=tr
             end do
          end do
        end do
       end do

       return
    End Subroutine Get_Stabilizer

    !!----
    !!---- Subroutine Get_String_Resolv(T,X,Ix,Symb)
    !!----    real(kind=cp), dimension(3), intent( in) :: t      !  In -> Traslation part
    !!----    real(kind=cp), dimension(3), intent( in) :: x      !  In -> real(kind=cp) part of variable
    !!----    integer, dimension(3),       intent( in) :: ix     !  In -> Frags: 1:x, 2:y, 3:z
    !!----    character (len=*),           intent(out) :: symb   ! Out -> String
    !!----
    !!----    Returning a string for point, axes or plane give as
    !!----    written in fractional form from Resolv_sist procedures.
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Get_String_Resolv(t,x,ix,symb)
       !---- Arguments ----!
       real(kind=cp), dimension(3),      intent( in) :: t
       real(kind=cp), dimension(3),      intent( in) :: x
       integer, dimension(3),   intent( in) :: ix
       character (len=*),       intent(out) :: symb

       !---- Local Variables ----!
       character(len=60) :: car
       integer           :: i, np, npos
       real(kind=cp),dimension(3) :: xx

       !---- Main ----!
       xx=x
       do i=1,3
          call get_fraction_2dig(x(i),car)
          np=index(car,"1/2")
          if (np > 0) then
             xx=2.0*x
             exit
          end if
       end do

       symb=" "
       npos=1
       do i=1,3
          !---- Only t value ----!
          if (abs(xx(i)) <= eps_symm) then
             call get_fraction_2dig(t(i),car)
             car=adjustl(car)
             if (car(1:1) == "+") car=car(2:)
             np=len_trim(car)
             if (i < 3) then
                symb(npos:)=car(1:np)//", "
                npos=npos+np+2
             else
                symb(npos:)=car(1:np)
             end if
             cycle
          end if

          call get_fraction_2dig(xx(i),car)
          car=adjustl(car)
          if (abs(abs(xx(i)) - 1.0) <= eps_symm) then
             if (car(1:2) == "+1") car=car(3:)
             if (car(1:2) == "-1") car(2:)=car(3:)
          else
             if (car(1:1) == "+") car=car(2:)
          end if
          np=len_trim(car)
          symb(npos:)=car(1:np)
          npos=npos+np
          select case (ix(i))
             case (1)
                symb(npos:)="x"
             case (2)
                symb(npos:)="y"
             case (3)
                symb(npos:)="z"
          end select
          npos=npos+1
          if (abs(t(i)) > 0.0 ) then
             call get_fraction_2dig(t(i),car)
             car=adjustl(car)
             np=len_trim(car)
             symb(npos:)=car(1:np)
             npos=npos+np
          end if
          if (i < 3) then
             symb(npos:)=", "
             npos=npos+2
          end if

       end do
       symb=pack_string(symb)

       return
    End Subroutine Get_String_Resolv

    !!----
    !!----  Subroutine Get_SubOrbits(X,Spg,ptr,Mult,orb,ind,conv)
    !!----    real(kind=cp), dimension(3),  intent (in) :: x     !  In -> Position vector
    !!----    type(Space_Group_type),       intent (in) :: spgr  !  In -> Space Group
    !!----    integer,dimension(:),         intent( in) :: ptr   !  In -> Pointer to symops of a subgroup
    !!----    integer,                      intent(out) :: mult  !  Out -> Multiplicity
    !!----    real, dimension(:,:),         intent(out) :: orb   !  Out -> List of equivalent positions
    !!----    integer,dimension(:),         intent(out) :: ind   !  Out -> Integer giving the number of the suborbits
    !!----    character(len=*), optional,   intent( in) :: conv  !  In  -> If present centring transl. are considered
    !!----
    !!----    Obtain the multiplicity and list of equivalent positions
    !!----    modulo lattice translations (including centring!) of a
    !!----    position. When symmetry operators of a subgroup of Spg is given
    !!----    an index vector (ind) gives the division in subOrbits.
    !!----    The pointer ptr indicates the symmetry operators of Spg belonging
    !!----    to the subgroup. The first zero value of ptr terminates the search.
    !!----    If the optional argument "conv" is given the centring translations
    !!----    are considered. The orbits are formed by all atoms within a
    !!----    conventional unit cell. Otherwise the orbit is formed only with
    !!----    the content of a primitive cell.
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Get_SubOrbits(x,Spg,ptr,mult,orb,ind,conv)
       !---- Arguments ----!
       real(kind=cp), dimension(3),    intent (in) :: x
       type(Space_Group_type),         intent (in) :: spg
       integer,dimension(:),           intent( in) :: ptr
       integer,                        intent(out) :: mult
       real(kind=cp),dimension(:,:),   intent(out) :: orb
       integer,dimension(:),           intent(out) :: ind
       character(len=*), optional,     intent( in) :: conv

       !---- Local variables ----!
       integer                                 :: i,j, nt,is, numorb
       real(kind=cp), dimension(3)             :: xx,v,xi
       character(len=1)                        :: laty

       laty=Spg%spg_lat
       if(present(conv)) laty="P"
       ! First obtain the equivalent positions in the full group
       mult=1
       orb(:,1)=x(:)
       ext: do j=2,Spg%multip
          xx=ApplySO(Spg%SymOp(j),x)
          xx=modulo_lat(xx)
          do nt=1,mult
             v=orb(:,nt)-xx(:)
             if (Lattice_trans(v,laty)) cycle ext
          end do
          mult=mult+1
          orb(:,mult)=xx(:)
       end do ext

       numorb=1
       ind=0
       do i=1,mult
        if(ind(i) /= 0) cycle
        xi=orb(:,i)
        do j=1,Spg%multip
           is= ptr(j)
           if(is == 0) exit
           xx=ApplySO(Spg%SymOp(is),xi)
           xx=modulo_lat(xx)
           do nt=1,mult
              if(ind(nt) /= 0) cycle
              v=orb(:,nt)-xx(:)
              if (Lattice_trans(v,laty)) then
                ind(nt)=numorb
                exit
              end if
           end do
        end do !j
        numorb=numorb+1
       end do !i

       return
    End Subroutine Get_SubOrbits

    !!----
    !!---- Subroutine Get_Symel(Sim,Xyzstring)
    !!----    integer, dimension(3,3), intent( in) :: sim         !  In -> Rotational part
    !!----    character (len=*),       intent(out) :: XYZstring   ! Out -> String
    !!----
    !!----    Supplies a string with the "symmetry element" (I.T.) for the
    !!----    rotation matrix Sim. They correspond to the symbols given in
    !!----    I.T. for space groups Pm3m and P6/mmm.
    !!----    Logical "hexa" must be defined
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Get_SymEl(Sim,Xyzstring)
       !---- Arguments ----!
       integer,dimension (3,3), intent( in) :: sim
       character (len=*),       intent(out) :: XYZstring

       !---- Local Variables ----!
       integer :: Iu,i1,i2,j

       if (.not. hexa) then
          i1=1
          i2=24
       else
          i1=25
          i2=36
       end if
       call SearchOp(sim,i1,i2,Iu)

       if (.not. hexa) then
          j=abs(Iu)
          if (Iu < 0) j=j+24
          XYZstring=IntSymOh(j)
       else
          j=abs(Iu)-24
          if (Iu < 0) j=j+12
          XYZstring=IntSymD6h(j)
       end if

       return
    End Subroutine Get_SymEl

    !!----
    !!---- Subroutine Get_Symkov(Sim,Xyzstring)
    !!----    integer, dimension(3,3), intent( in) :: sim        !  In -> Rotational part
    !!----    character (len=*),       intent(out) :: XYZstring
    !!----
    !!----    Supplies a string with the "symmetry element" (I.T.) for the rotation
    !!----    matrix Sim. They correspond to the symbols Kovalev.
    !!----    Logical "hexa" must be defined
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Get_SymKov(Sim,Xyzstring)
       !---- Arguments ----!
       integer,dimension (3,3), intent( in) :: sim
       character (len=*),       intent(out) :: XYZstring

       !---- Local variables ----!
       integer :: Iu,i1,i2,j

       if (.not. hexa) then
          i1=1
          i2=24
       else
          i1=25
          i2=36
       end if
       call SearchOp(sim,i1,i2,Iu)

       if (.not. hexa) then
          j=abs(Iu)
          if (Iu < 0) j=j+24
          XYZstring=IntSymOh(j)//" -> "//Kov_Oh(j)
       else
          j=abs(Iu)-24
          if (Iu < 0) j=j+12
          XYZstring=IntSymD6h(j)//" -> "//Kov_D6h(j)
       end if

       return
    End Subroutine Get_SymKov

    !!----
    !!---- Subroutine Get_SymSymb(Sim,Tt,Strsym)
    !!----    real(kind=cp)/integer, dimension(3,3), intent( in)    :: sim      !  In -> Rotational part of the S.O.
    !!----    real(kind=cp), dimension( 3),          intent( in)    :: tt       !  In -> Translational part of the S.O.
    !!----    character (len=*),                     intent(out)    :: Strsym   ! Out -> String in th form X,Y,-Z, ...
    !!----
    !!----    Obtain the Jones Faithful representation of a symmetry operator
    !!----
    !!---- Update: February - 2005
    !!

    !!--++
    !!--++ Subroutine Get_SymsymbI(Sim,Tt,Strsym)
    !!--++    integer, dimension(3,3),      intent( in)    :: sim      !  In -> Rotational part of the S.O.
    !!--++    real(kind=cp), dimension( 3), intent( in)    :: tt       !  In -> Translational part of the S.O.
    !!--++    character (len=*),            intent(out)    :: Strsym   ! Out -> String in th form X,Y,-Z, ...
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Obtain the Jones Faithful representation of a symmetry operator
    !!--++
    !!--++ Update: February - 2005, January-2014 (changed for a more robust algorithm,JRC)
    !!
    Subroutine Get_SymSymbI(X,T,Symb)
       !---- Arguments ----!
       integer,       dimension(3,3), intent( in) :: x
       real(kind=cp), dimension(3),   intent( in) :: t
       character (len=*),          intent(out) :: symb

       !---- Local Variables ----!
       character(len=*),dimension(3),parameter :: xyz=(/"x","y","z"/)
       character(len= 25)              :: car
       character(len= 25),dimension(3) :: sym
       integer           :: i,j

       !---- Main ----!
       symb=" "
       do i=1,3
          sym(i)=" "
          do j=1,3
             if(x(i,j) == 1) then
                sym(i) = trim(sym(i))//"+"//xyz(j)
             else if(x(i,j) == -1) then
                sym(i) =  trim(sym(i))//"-"//xyz(j)
             else if(x(i,j) /= 0) then
               car=" "
               write(unit=car,fmt="(i3,a)") x(i,j),xyz(j)
               if(x(i,j) > 0) car="+"//trim(car)
               sym(i)=trim(sym(i))//pack_string(car)
             end if
          end do
          if (abs(t(i)) > eps_symm ) then
             call get_fraction_2dig(t(i),car)
             sym(i)=trim(sym(i))//trim(car)
          end if
          sym(i)=adjustl(sym(i))
          if(sym(i)(1:1) == "+")  then
            sym(i)(1:1) = " "
            sym(i)=adjustl(sym(i))
          end if
          sym(i)=pack_string(sym(i))
       end do
       symb=trim(sym(1))//","//trim(sym(2))//","//trim(sym(3))
       return
    End Subroutine Get_SymSymbI

    !!--++
    !!--++  Subroutine Get_SymSymbR(X,T,Symb)
    !!--++     real(kind=cp),    dimension(3,3),    intent( in) :: x
    !!--++     real(kind=cp),    dimension(3),      intent( in) :: t
    !!--++     character (len=*),                   intent(out) :: symb
    !!--++
    !!--++     (OVERLOADED)
    !!--++     Returning a string for symmetry operators or for points, axes or plane give as
    !!--++     written in fractional form
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Get_SymSymbR(X,T,Symb)
       !---- Arguments ----!
       real(kind=cp),    dimension(3,3), intent( in) :: x
       real(kind=cp),    dimension(3),   intent( in) :: t
       character (len=*),                intent(out) :: symb

       !---- Local Variables ----!
       character(len= 25):: car
       integer           :: i,j,k, np,npp,npos
       real(kind=cp)     :: suma

       !---- Main ----!
       symb=" "
       npos=1
       do i=1,3
          npp=0
          do j=1,3
             if (abs(x(i,j)) > 0.0 ) then
                call get_fraction_2dig(x(i,j),car)
                car=adjustl(car)
                if (abs(abs(x(i,j))-1.0) <= eps_symm) then
                     if (npp == 0) then
                        select case (car(1:2))
                           case ("-1")
                              car(2:)=car(3:)//"  "
                           case ("+1")
                              car=car(3:)//"  "
                        end select
                     else
                        car(2:)=car(3:)//"  "
                     end if
                else
                   if (npp == 0) then
                      if (car(1:1) =="+") then
                         car=car(2:)//"  "
                      end if
                   end if
                end if

                np=len_trim(car)
                select case (j)
                   case (1)
                      k=index(car(1:np),"/")
                      if( k /= 0) then
                        if(car(k-1:k-1) == "1") then
                          car(k-1:k-1) = "x"
                          symb(npos:)=car(1:np)
                        else
                          symb(npos:)=car(1:k-1)//"x"//car(k:np)
                        end if
                      else
                        symb(npos:)=car(1:np)//"x"
                      end if
                   case (2)
                      k=index(car(1:np),"/")
                      if( k /= 0) then
                        if(car(k-1:k-1) == "1") then
                          car(k-1:k-1) = "y"
                          symb(npos:)=car(1:np)
                        else
                          symb(npos:)=car(1:k-1)//"y"//car(k:np)
                        end if
                      else
                        symb(npos:)=car(1:np)//"y"
                      end if
                   case (3)
                      k=index(car(1:np),"/")
                      if( k /= 0) then
                        if(car(k-1:k-1) == "1") then
                          car(k-1:k-1) = "z"
                          symb(npos:)=car(1:np)
                        else
                          symb(npos:)=car(1:k-1)//"z"//car(k:np)
                        end if
                      else
                        symb(npos:)=car(1:np)//"z"
                      end if
                end select
                npos=len_trim(symb)+1
                npp=npos
             end if
          end do

          if (abs(t(i)) <= eps_symm .and. npp /= 0) then
             if (i < 3) then
                symb(npos:)=", "
                npos=len_trim(symb)+2
             end if
             cycle
          end if

          call get_fraction_2dig(t(i),car)
          car=adjustl(car)
          suma=0.0
          do j=1,3
             suma=suma+abs(x(i,j))
          end do
          np=len_trim(car)
          if (suma <= 3.0*eps_symm) then
             if (car(1:1) == "+") car=car(2:np)//" "
          end if

          if (i < 3) then
             symb(npos:)=car(1:np)//", "
             npos=len_trim(symb)+2
          else
             symb(npos:)=car(1:np)
          end if
       end do

       symb=pack_string(symb)

       return
    End Subroutine Get_SymSymbR

    !!----
    !!---- Subroutine Get_T_SubGroups(SpG,SubG,nsg,point)
    !!----    type (Space_Group_Type) ,             intent( in) :: SpG
    !!----    type (Space_Group_Type) ,dimension(:),intent(out) :: SubG
    !!----    integer,                              intent(out) :: nsg
    !!----    logical, dimension(:,:), optional,    intent(out) :: point
    !!----
    !!----    Subroutine to obtain the list of all non-trivial translationengleiche
    !!----    subgroups (t-subgroups) of a given space group. The unit cell setting
    !!----    is supposed to be the same as that of the input space group "SpG"
    !!----    The search of space sub-groups is performed using a systematic combination
    !!----    of the symmetry operators of the group.
    !!----    The optional argument point has dimensions (SpG%multip,nsg) and contains
    !!----    true point(i,j)=.true. if the operator i of the space group SpG belongs
    !!----    to the subgroup SubG(j).
    !!----
    !!---- Update: February - 2005, April 2015
    !!
    Subroutine Get_T_SubGroups(SpG,SubG,nsg,point)
       !---- Arguments ----!
       type (Space_Group_Type) ,             intent( in) :: SpG
       type (Space_Group_Type) ,dimension(:),intent(out) :: SubG
       integer,                              intent(out) :: nsg
       logical, dimension(:,:), optional,    intent(out) :: point
       !--- Local variables ---!
       integer                            :: i,L,j,k, nc, maxg,ng , nla, i1,i2,nop
       character (len=30), dimension(192) :: gen
       logical                            :: newg, cen_added

       maxg=size(SubG)
       !---- Construct first the generators of centring translations ----!
       ng=0
       nop=SpG%numops !number of symmetry operators excluding lattice centrings
       if (SpG%centred /= 1) nop=nop*2
       do i=2,SpG%numlat
          ng=ng+1
          gen(ng)= SpG%SymopSymb(1+nop*(i-1))
       end do

       nla=ng
       nc=SpG%Numops+1  !Position of the centre of symmetry if it exist
       L=0
       !---- Determine first the triclinic subgroups
       cen_added=.false.
       do
           L=L+1
           newg=.true.
           call set_spacegroup(" ",SubG(L),gen,ng,"gen")
           do j=1,L-1
              if (SpGr_Equal(SubG(L), SubG(j))) then
                 newg=.false.
                 exit
              end if
           end do
           if (newg) then
              call get_HallSymb_from_gener(SubG(L))
           else
              L=L-1
           end if
           if (SpG%centred /= 1 .and. newg .and. .not. cen_added) then !add the centre of symmetry if needed
              ng=ng+1
              gen(ng)=SpG%SymopSymb(nc)
              cen_added=.true.
           else
              exit
           end if
       end do

       !---- Determine first the groups with only one rotational generator
       do i=2,nop
          ng=nla+1
          gen(ng) = SpG%SymopSymb(i)
          cen_added=.false.
          do
             L=L+1
             if (L > maxg) then
                nsg=maxg
                return
             end if
             newg=.true.
             call set_spacegroup(" ",SubG(L),gen,ng,"gen")
             do j=1,L-1
                if (SpGr_Equal(SubG(L), SubG(j))) then
                   newg=.false.
                   exit
                end if
             end do
             if (newg) then
                call get_HallSymb_from_gener(SubG(L))
             else
                L=L-1
             end if
             if (SpG%centred /= 1 .and. newg .and. .not. cen_added) then !add the centre of symmetry if needed
                ng=ng+1
                gen(ng)=SpG%SymopSymb(nc)
                cen_added=.true.
             else
                exit
             end if
          end do
       end do

       !---- Determine now the groups with two rotational generator ----!

       do i1=2,nop-1
          gen(nla+1) = SpG%SymopSymb(i1)
          do i2 = i1+1,nop
             gen(nla+2) = SpG%SymopSymb(i2)
             ng=nla+2
             cen_added=.false.
             do
                L=L+1
                if (L > maxg) then
                   nsg=maxg
                   return
                end if
                newg=.true.
                call set_spacegroup(" ",SubG(L),gen,ng,"gen")
                do j=1,L-1
                   if (SpGr_Equal(SubG(L), SubG(j))) then
                      newg=.false.
                      exit
                   end if
                end do
                if (newg) then
                   call get_HallSymb_from_gener(SubG(L))
                else
                   L=L-1
                end if
                if (SpG%centred /= 1 .and. newg .and. .not. cen_added) then !add the centre of symmetry if needed
                   ng=ng+1
                   gen(ng)=SpG%SymopSymb(nc)
                   cen_added=.true.
                else
                   exit
                end if
             end do
          end do
       end do
       nsg=L
       if(present(point)) then
         point=.false.
         do j=1,nsg
           L=1
           do i=1,SpG%multip
              do k=L,SubG(j)%multip
               if(SubG(j)%SymopSymb(k) == SpG%SymopSymb(i)) then
                  point(i,j) = .true.
                  L=k+1
                  exit
               end if
              end do
           end do
         end do
       end if

       return
    End Subroutine Get_T_SubGroups

    !!----
    !!---- Subroutine Get_Trasfm_Symbol(Mat,tr,abc_symb,oposite)
    !!----    integer, dimension(3,3), intent(in) :: Mat
    !!----    real,    dimension(3),   intent(in) :: tr
    !!----    character(len=*),        intent(out):: abc_symb
    !!----    logical,optional,        intent(in) :: oposite
    !!----
    !!----    Provides the short symbol for a setting change defined by
    !!----    the transfomation matrix Mat and origin given by the translation
    !!----    vector tr. For instance given the matrix:
    !!----
    !!----     1  0 -1                      a'=a-c
    !!----     0  2  0   corresponding to   b'=2b
    !!----     1  0  1                      c'=a+c
    !!----     And the change of origin given by (0.5,0.0,0.5)
    !!----     The subroutine provide the symbol: (1/2,0,1/2; a-c,2b,a+c)
    !!----     If "oposite" is provided theh the symbol: (a-c,2b,a+c; 1/2,0,1/2)
    !!----
    !!----
    !!---- Update: November - 2012, February 2016 (optional argument)
    !!
    Subroutine Get_Trasfm_Symbol(Mat,tr,abc_symb,oposite)
      integer,       dimension(3,3), intent(in) :: Mat
      real(kind=cp), dimension(3),   intent(in) :: tr
      character(len=*),              intent(out):: abc_symb
      logical,optional,              intent(in) :: oposite
      !---- Local variables ----!
      integer :: i
      character(len=25) :: xyz_op, transl
      character(len=6)  :: Fracc
      call Get_SymSymb(Mat,(/0.0_cp,0.0_cp,0.0_cp/),xyz_op)
      do i=1,len_trim(xyz_op)
        if(xyz_op(i:i) == "x")  xyz_op(i:i)="a"
        if(xyz_op(i:i) == "y")  xyz_op(i:i)="b"
        if(xyz_op(i:i) == "z")  xyz_op(i:i)="c"
      end do
      transl=" "
      do i=1,3
        call Get_Fraction_2Dig(tr(i),Fracc)
        transl=trim(transl)//trim(Fracc)//","
      end do
      i=len_trim(transl)
      transl(i:i)=";"
      do i=1,len_trim(transl)-2
        if(transl(i:i) == "+") transl(i:i)=" "
      end do
      transl=Pack_string(transl)
      abc_symb="("//trim(transl)//" "//trim(xyz_op)//")"
      if(present(oposite)) then
        i=len_trim(transl)
        abc_symb="("//trim(xyz_op)//"; "//transl(1:i-1)//")"
      end if
      return
    End Subroutine Get_Trasfm_Symbol

    !!----
    !!---- Subroutine Get_Transl_Symbol(tr,Transl_symb)
    !!----   real,    dimension(3),   intent(in) :: tr
    !!----   character(len=*),        intent(out):: Transl_symb
    !!----
    !!----    Provides the short symbol for a translation vector
    !!----    for which the coordinates are given as fractional symbols
    !!----
    !!---- Update: November - 2012
    !!
    Subroutine Get_Transl_Symbol(tr,Transl_symb)
      real(kind=cp), dimension(3),   intent(in) :: tr
      character(len=*),              intent(out):: Transl_symb
      !---- Local variables ----!
      integer :: i
      character(len=25) :: transl
      character(len=6)  :: Fracc

      transl=" "
      do i=1,3
        call Get_Fraction_2Dig(tr(i),Fracc)
        transl=trim(transl)//trim(Fracc)//","
      end do
      i=len_trim(transl)
      transl(i:i)=" "
      do i=1,len_trim(transl)
        if(transl(i:i) == "+") transl(i:i)=" "
      end do
      Transl_symb="("//trim(transl)//")"
      return
    End Subroutine Get_Transl_Symbol

    !!----
    !!---- Subroutine Init_Err_Symm()
    !!----
    !!----    Initialize the errors flags in this Module
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Init_Err_Symm()

       err_symm=.false.
       ERR_Symm_Mess=" "

       return
    End Subroutine Init_Err_Symm

    !!----
    !!---- Subroutine Inverse_Symm(R,T,S,U)
    !!----    integer, dimension(3,3),     intent(in)  :: R     !  In -> Rotational Part
    !!----    real(kind=cp), dimension(3), intent(in)  :: t     !  In -> Traslational part
    !!----    integer, dimension(3,3),     intent(out) :: S     ! Out -> New Rotational part
    !!----    real(kind=cp), dimension(3), intent(out) :: u     ! Out -> new traslational part
    !!----
    !!----    Calculates the inverse of the symmetry operator (R,t)
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Inverse_Symm(R,t,S,u)
       !---- Arguments ----!
       integer, dimension(3,3),     intent(in)  :: R
       real(kind=cp), dimension(3), intent(in)  :: t
       integer, dimension(3,3),     intent(out) :: S
       real(kind=cp), dimension(3), intent(out) :: u

       !---- Local variables ----!
       integer                        :: ifail
       real(kind=cp), dimension(3,3)  :: a,b

       call init_err_symm()
       a=real(r)
       s=0
       u=0.0

       call matrix_inverse(a,b,ifail)
       if (ifail /= 0) then
          err_symm=.true.
          ERR_Symm_Mess= "Inversion Matrix Failed"
          return
       end if
       s=nint(b)
       u=matmul(-b,t)

       return
    End Subroutine Inverse_Symm

    !!----
    !!---- Subroutine Latsym(Symb,Numl,Latc)
    !!----    character (len=*),                       intent(in)  :: SYMB  !  In -> Space Group H-M/Hall symbol
    !!----    integer, optional,                       intent(in)  :: numL  !  Number of centring vectors
    !!----    real(kind=cp),optional, dimension(:,:),  intent(in)  :: latc  !  Centering vectors
    !!----
    !!--<<        Inlat  Lattice type & associated translations
    !!----          1     P: { 000 }
    !!----          2     A: { 000;  0  1/2 1/2 }+
    !!----          3     B: { 000; 1/2  0  1/2 }+
    !!----          4     C: { 000; 1/2 1/2  0  }+
    !!----          5     I: { 000; 1/2 1/2 1/2 }+
    !!----          6     R: { 000; 2/3 1/3 1/3; 1/3 2/3 2/3   } +
    !!----          7     F: { 000;  0  1/2 1/2; 1/2  0  1/2; 1/2 1/2  0 } +
    !!----          8     Z: { 000;  user-given centring vectors } +
    !!-->>
    !!----    Provides the Lattice type of the S.G. SYMB. Also gives the index (Inlat)
    !!----    of the lattice, the multiplicity (Nlat) and the fractionnal lattice translations
    !!----    ((Ltr(in,j)j=1,3),in=1,Nlat) and Lat_Ch.
    !!----
    !!---- Update: February - 2005, January 2014 (JRC)
    !!
    Subroutine LatSym(SYMB,numL,latc)
       !---- Argument ----!
       character(len=*),                        intent(in)  :: SYMB
       integer, optional,                       intent(in)  :: numL
       real(kind=cp),optional, dimension(:,:),  intent(in)  :: latc  !general vector (JRC, Jan2014)

       !---- Local variables ----!
       character(len=1)                        :: LAT
       character(len=len(symb))                :: SYMBB
       integer                                 :: i

       call init_err_symm()
       symbb=adjustl(symb)
       do i=1,len_trim(symbb)
          if (symbb(i:i) == "-" .or. symbb(i:i) == " ") cycle
          lat=symbb(i:i)
          exit
       end do

       nlat=1
       ltr(:,1)=0.0
       select case (lat)
          case ("P","p")
             lat="P"
             nlat=1
             inlat=1

          case ("A","a")
             lat="A"
             nlat=2
             inlat=2
             ltr(1,2)=0.0
             ltr(2,2)=0.5
             ltr(3,2)=0.5

          case ("B","b")
             lat="B"
             nlat=2
             inlat=3
             ltr(1,2)=0.5
             ltr(2,2)=0.0
             ltr(3,2)=0.5

          case ("C","c")
             lat="C"
             nlat=2
             inlat=4
             ltr(1,2)=0.5
             ltr(2,2)=0.5
             ltr(3,2)=0.0

          case ("I","i")
             lat="I"
             nlat=2
             inlat=5
             ltr(:,2)=0.5

          case ("R","r")
             lat="R"
             nlat=3
             inlat=6
             ltr(1,2)=2.0/3.0
             ltr(2,2)=1.0/3.0
             ltr(3,2)=1.0/3.0
             ltr(1,3)=1.0/3.0
             ltr(2,3)=2.0/3.0
             ltr(3,3)=2.0/3.0

          case ("F","f")
             lat="F"
             nlat=4
             inlat=7
             ltr(1,2)=0.5
             ltr(2,2)=0.5
             ltr(3,2)=0.0
             ltr(1,3)=0.5
             ltr(2,3)=0.0
             ltr(3,3)=0.5
             ltr(1,4)=0.0
             ltr(2,4)=0.5
             ltr(3,4)=0.5

          case ("Z","z","X","x")
             if(present(numL) .and. present(latc)) then
              lat="Z"
              nlat=numL+1
              !nlat=min(nlat,12) !restriction removed in January 2014
              inlat=8
              do i=2,nlat
                ltr(:,i)=latc(:,i-1)
              end do
             else
               err_symm=.true.
               ERR_Symm_Mess="Unconventional Lattice Symbol Z needs centring vectors"
             end if
          case default
             err_symm=.true.
             ERR_Symm_Mess="Wrong Lattice Symbol "//LAT
       end select

       Lat_Ch=LAT

       return
    End Subroutine Latsym

    !!--++
    !!--++ Subroutine Max_Conv_Lattice_Type(L, Latc, Lattyp)
    !!--++    integer,                        intent(in)  :: L         !  number of centring vectors
    !!--++    real(kind=cp), dimension(:,:),  intent(in)  :: Latc      ! (3,11) centring vectors
    !!--++    character(len=*),               intent(out) :: lattyp    ! Lattice symbol
    !!--++
    !!--++    (PRIVATE)
    !!--++    Subroutine to get the maximum conventional lattice symbol from
    !!--++    a set of possible centring vectors.
    !!--++    Used by subroutine: Similar_Transf_SG
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Max_Conv_Lattice_Type(L, Latc, lattyp)
       !---- Arguments ----!
       integer,                        intent( in) :: L
       real(kind=cp), dimension(:,:),  intent( in) :: Latc
       character(len=*),               intent(out) :: lattyp

       !---- Local variables ----!
       logical                            :: latt_p, latt_a, latt_b, latt_c, latt_i, latt_r, latt_f
       integer, dimension(3)              :: tt
       integer                            :: i, j
       integer, dimension(3,6), parameter :: lattice=reshape((/0,6,6, 6,0,6, &
                                                     6,6,0, 6,6,6, 8,4,4, 4,8,8/),(/3,6/))

       if (l == 0) then !primitive lattice
          lattyp="P"
          return
       end if

       latt_p=.true.
       latt_a=.false.
       latt_b=.false.
       latt_c=.false.
       latt_i=.false.
       latt_r=.false.
       latt_f=.false.

       do i=1,L
          tt(1:3)=nint(12.0 * Latc(1:3,i))   ! Translations x 12

          !---- Compare the translation part of the operator with tabulated array ----!
          do j=1,6
             if (equal_vector(tt,lattice(:,j),3)) then
                select case (j)
                   case (1)
                      latt_a=.true.
                   case (2)
                      latt_b=.true.
                   case (3)
                      latt_c=.true.
                   case (4)
                      latt_i=.true.
                   case (5,6)
                      latt_r=.true.
                end select
                exit
             end if
          end do
       end do

       !---- Lattice Type ----!
       if ( (latt_a .and. latt_b .and. latt_c) .or. (latt_a .and. latt_b) .or. &
            (latt_a .and. latt_c) .or. (latt_b .and. latt_c) ) then
            latt_f=.true.
            latt_a=.false.
            latt_b=.false.
            latt_c=.false.
            latt_p=.false.
            latt_i=.false.
       end if
       if (latt_p) lattyp="P"
       if (latt_a) lattyp="A"
       if (latt_b) lattyp="B"
       if (latt_c) lattyp="C"
       if (latt_i) lattyp="I"
       if (latt_r) lattyp="R"
       if (latt_f) lattyp="F"

       return
    End Subroutine Max_Conv_Lattice_Type

    !!--++
    !!--++ Subroutine Mod_Trans(Ng, Ns, Ts, Isymce)
    !!--++    integer, intent( in)                           :: ng      ! In -> Number of operators
    !!--++    integer, intent( in)                           :: ns      ! In ->
    !!--++    real(kind=cp), dimension(3,24), intent(in out) :: ts      ! In -> Traslation part
    !!--++                                                                Out ->
    !!--++    integer, intent(out),optional                  :: isymce  ! Out -> Origin information
    !!--++                                                                0= Ccenter of Inversion in the Origin
    !!--++                                                                1= Non centrosymmetric
    !!--++                                                                2= Center of Inversion out of origin
    !!--++
    !!--++    (PRIVATE)
    !!--++    Subroutine used by Get_SO_from_HMS.
    !!--++    Put all tranlations in conventional form (positive and less than 1)
    !!--++    Provides Isymce
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Mod_Trans(Ng,Ns,Ts,Isymce)
       !---- Arguments ----!
       integer, intent(          in)                  :: ng,ns
       real(kind=cp), dimension(3,24), intent(in out) :: ts
       integer, intent(out),optional                  :: isymce

       !---- Local Variables ----!
       integer :: i

       do i=1,ng
          ts(:,i)=modulo_lat(ts(:,i))
       end do
       if (present(isymce)) isymce=2-ns

       return
    End Subroutine Mod_Trans

    !!----
    !!---- Subroutine Read_Bin_Spacegroup(SpG,Lun,ok)
    !!----    type (Space_Group),  intent(out) :: SpG   !  Out -> SpaceGroup Variable
    !!----    integer,             intent(in)  :: Lun   !  In -> Logical unit of the file
    !!----    logical,             intent(out) :: ok    !  .true. if everything is OK
    !!----
    !!----    Reading in file of logical unit "lun" the full structure of Space_Group_Type, SpG
    !!----    The file should have been opened with the access="stream" attribute. The procedure
    !!----    reads in the given order a series of bytes corresponding to the components of the
    !!----    type SpG.
    !!----
    !!---- Update: February - 2013
    !!
    Subroutine Read_Bin_SpaceGroup(SpG,lun,ok)
       !---- Arguments ----!
       type (Space_Group_Type),intent(out) :: SpG
       integer,                intent(in)  :: lun
       logical,                intent(out) :: ok

       !---- Local variables ----!
       integer                           :: i,j,ier

       ok=.true.
       read(unit=Lun,iostat=ier) SpG%NumSpg,        &   ! Number of the Space Group
                                 SpG%SPG_Symb,      &   ! Hermann-Mauguin Symbol
                                 SpG%Hall,          &   ! Hall symbol
                                 SpG%CrystalSys,    &   ! Crystal system
                                 SpG%Laue,          &   ! Laue Class
                                 SpG%PG,            &   ! Point group
                                 SpG%Info,          &   ! Extra information
                                 SpG%SG_setting,    &   ! Information about the SG setting (IT,KO,ML,ZA,Table,Standard,UnConventional)
                                 SpG%Hexa,          &   !
                                 SpG%SPG_lat,       &   ! Lattice type
                                 SpG%SPG_latsy,     &   ! Lattice type Symbol
                                 SpG%NumLat             ! Number of lattice points in a cell
       if(ier /= 0) then
        ok=.false.
        return
       end if

       if(allocated(SpG%Latt_trans)) deallocate(SpG%Latt_trans)
       allocate(SpG%Latt_trans(3,SpG%NumLat))

       read(unit=Lun,iostat=ier) SpG%Latt_trans,    &   ! Lattice translations
                                 SpG%Bravais,       &   ! String with Bravais symbol + translations
                                 SpG%Centre,        &   ! Alphanumeric information about the center of symmetry
                                 SpG%Centred,       &   ! Centric or Acentric [ =0 Centric(-1 no at origin),=1 Acentric,=2 Centric(-1 at origin)]
                                 SpG%Centre_coord,  &   ! Fractional coordinates of the inversion centre
                                 SpG%NumOps,        &   ! Number of reduced set of S.O.
                                 SpG%Multip,        &   ! Multiplicity of the general position
                                 SpG%Num_gen            ! Minimum number of operators to generate the Group
       if(ier /= 0) then
        ok=.false.
        return
       end if

       if(allocated(SpG%SymOp)) deallocate(SpG%SymOp)
       allocate(SpG%SymOp(SpG%Multip))
       if(allocated(SpG%SymOpSymb)) deallocate(SpG%SymOpSymb)
       allocate(SpG%SymOpSymb(SpG%Multip))

       do i=1,SpG%Multip
         read(unit=Lun,iostat=ier) SpG%SymOp(i)%Rot,SpG%SymOp(i)%tr, & ! Symmetry operators
                                   SpG%SymopSymb(i)                    ! Strings form of symmetry operators
         if(ier /= 0) then
          ok=.false.
          return
         end if
       end do
       read(unit=Lun,iostat=ier) SpG%R_Asym_Unit      ! Asymmetric unit in real space
       if(ier /= 0) then
         ok=.false.
         return
       end if
       read(unit=Lun,iostat=ier) SpG%Wyckoff%num_orbit              ! Wyckoff Information
       if(ier /= 0) then
        ok=.false.
        return
       end if
       if (SpG%Wyckoff%num_orbit == 0) return
       do i=1,SpG%Wyckoff%num_orbit
         read(unit=Lun,iostat=ier) SpG%Wyckoff%orbit(i)%norb
         read(unit=Lun,iostat=ier) SpG%Wyckoff%orbit(i)%str_Orig
         do j=1,SpG%Wyckoff%orbit(i)%norb
           read(unit=Lun,iostat=ier) SpG%Wyckoff%orbit(i)%str_orbit(j)
         end do
         if(ier /= 0) then
          ok=.false.
          return
         end if
       end do
       return
    End Subroutine Read_Bin_SpaceGroup

    !!----
    !!---- Subroutine Read_Msymm(Info,Sim,P_Mag,ctrl)
    !!----    character (len=*),       intent( in) :: Info   !  In -> Input string with S.Op.
    !!----                                                            in the form: MSYM  u,w,w,p_mag
    !!----    integer, dimension(3,3), intent(out) :: sim    ! Out -> Rotation matrix
    !!----    real(kind=cp),           intent(out) :: p_mag  ! Out -> magnetic phase
    !!----    logical, optional,       intent(in)  :: ctrl   ! in  -> If provided and .true. an error condition
    !!----                                                            is raised if the det(Sim)=0
    !!----    Read magnetic symmetry operators in the form U,V,W, etc...
    !!----    Provides the magnetic rotational matrix and phase associated to a MSYM symbol
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Read_Msymm(Info,Sim,P_Mag,ctrl)
       !---- Arguments ----!
       character (len=*),       intent( in) :: Info
       integer, dimension(3,3), intent(out) :: sim
       real(kind=cp),           intent(out) :: p_mag
       logical, optional,       intent(in)  :: ctrl

       !---- Local variables ----!
       integer ::  i,imax,nop,s,ifound,j,ioerr,istart,mod_istart
       character(len=len(info)) :: aux
       logical :: control

       control=.false.
       if(present(ctrl)) control=ctrl
       call init_err_symm()
       do j=len(Info),1,-1
          if (info(j:j) == ",") exit
       end do
       p_mag=0.0
       imax=j-1
       read(unit=info(j+1:),fmt=*,iostat=ioerr) p_mag
       if (ioerr /= 0) then
          p_mag=0.0
       end if
       sim = 0
       aux=adjustl(l_case(Info))
       if(aux(1:4) == "msym" .or. aux(1:4) == "dsym") then
         istart=6
       else
         istart=1
       end if

       do nop=1,3
          s=1
          mod_istart=0
          ifound=0
          do i=istart,imax
             if (aux(i:i) == " ") cycle
             if (aux(i:i) == "," .or. info(i:i) == "*") then
                mod_istart=1
                exit
             end if
             ifound=1
             if (aux(i:i) == "u" ) then
                sim(nop,1)=s
                s=1
             else if (aux(i:i) == "v") then
                sim(nop,2)=s
                s=1
             else if(aux(i:i) == "w") then
                sim(nop,3)=s
                s=1
             else if(aux(i:i) == "+") then
                s=1
             else if(aux(i:i) == "-") then
                s=-1
             else
                err_symm=.true.
                ERR_Symm_Mess=" Invalid character... "//aux(I:I)//" in Sym. Op."
                return
             end if
          end do    !End loop through the string

          if (mod_istart == 1) then
            istart=i+1
          end if

          if (ifound == 0) then
             err_symm=.true.
             ERR_Symm_Mess=" Blank operator field "//info
             return
          end if
       end do    !End external loop over the three expected items

       if (determ_A(sim) == 0 .and. control) then      !Verify it is a suitable s.o.
          err_symm=.true.
          ERR_Symm_Mess=" The above operator is wrong "//info
          return
       end if

       if (ifound == 1) return

       err_symm=.true.
       ERR_Symm_Mess=" The above operator is wrong "//info

       return
    End Subroutine Read_Msymm

    !!----
    !!---- Subroutine Read_SymTrans_Code(Code,N,Tr)
    !!----    character (len=*),          intent( in) :: Code
    !!----    integer,                    intent(out) :: N
    !!----    real(kind=cp),dimension(3), intent(out) :: Tr
    !!----
    !!----    Read a Code string for reference the symmetry operator and the
    !!----    Traslation applied.
    !!--<<        _2.555     : N_Op = 2, Tr=( 0.0, 0.0, 0.0)
    !!----        _3.456     : N_Op = 3, Tr=(-1.0, 0.0, 1.0)
    !!-->>
    !!----
    !!---- Update: April - 2005
    !!
    Subroutine Read_SymTrans_Code(Code,N,Tr)
       !---- Arguments ----!
       character (len=*),          intent( in) :: Code
       integer,                    intent(out) :: N
       real(kind=cp),dimension(3), intent(out) :: Tr

       !---- Local variables ----!
       character(len=20) :: car
       integer          :: i,j,k,n_ini,n_end,nt

       N=1
       Tr=0.0
       if (len_trim(code) <= 0) return

       car=adjustl(code)
       n_ini=index(car,"_")
       n_ini=n_ini+1

       !---- Found Number of Symmetry Operator ----!
       n_end=index(car,".")
       if (n_end ==0) n_end=len_trim(car)+1
       read (unit=car(n_ini:n_end-1),fmt=*) n

       !---- Found the Traslation ----!
       n_ini=index(car,".")
       if (n_ini /= 0) then
          n_ini=n_ini+1
          n_end=len_trim(car)
          read (unit=car(n_ini:n_end),fmt=*) nt
          i=nt/100
          j=mod(nt,100)/10
          k=nt-(i*100+j*10)
          i=i-5
          j=j-5
          k=k-5
          tr(1)=real(i)
          tr(2)=real(j)
          tr(3)=real(k)
       end if

       return
    End Subroutine Read_SymTrans_Code

    !!----
    !!---- Subroutine Read_Xsym(Info,Istart,Sim,Tt,ctrl)
    !!----    character (len=*),                     intent( in)    :: Info   !  In -> String with the symmetry symbol
    !!----                                                                             in the form: SYMM  x,-y+1/2,z
    !!----    integer,                               intent(in)     :: istart !  In -> Starting index of info to read in.
    !!----    integer, dimension(3,3),               intent(out)    :: sim    ! Out -> Rotational part of S.O.
    !!----    real(kind=cp), optional, dimension(3), intent(out)    :: tt     ! Out -> Traslational part of S.O.
    !!----
    !!----
    !!----    Read symmetry or transformation operators in the form X,Y,Z, etc...
    !!----    Provides the rotational matrix and translation associated a to SYMM symbol
    !!----    in the Jones Faithful representation.
    !!----
    !!---- Update: June - 2011 (JRC, adding ctrl for controlling if a real symmetry operator is needed)
    !!
    Subroutine Read_Xsym(Info,Istart,Sim,Tt,ctrl)
       !---- Arguments ----!
       character (len=*),                     intent(in)     :: Info
       integer,                               intent(in)     :: istart
       integer, dimension(3,3),               intent(out)    :: sim
       real(kind=cp), optional, dimension(3), intent(out)    :: tt
       logical,       optional,               intent(in)     :: ctrl

       !---- Local variables ----!
       character (len=*), dimension(10), parameter :: ANUM=(/"1","2","3","4","5","6","7","8","9","0"/)
       integer, dimension(10), parameter           :: NUM =(/1,2,3,4,5,6,7,8,9,0/)
       integer :: i,imax,nop,s,np,isl,ifound,ip,k,mod_istart,ST=0,I_P,ist
       real(kind=cp) :: t,a
       logical       :: control

       control=.true.
       if(present(ctrl)) control=ctrl
       call init_err_symm()
       imax=len_trim(info)
       if (present(tt)) tt=0.0
       sim = 0
       ist=istart
       do nop=1,3
          s=1
          t=0.0
          ip=0
          i_p=1
          np=0
          isl=0
          ifound=0
          mod_istart=0
          loop_string: do i=ist,imax
             if (info(i:i) == " ") cycle
             if (info(i:i) == "," .or. info(i:i) == "*") then
                mod_istart=1
                exit
             end if
             ifound=1
             if (info(i:i) == "X" .or. info(i:i) == "x") then
                sim(nop,1)=s*i_p
                i_p=1
                s=1
             else if (info(i:i) == "Y" .or. info(i:i) == "y") then
                sim(nop,2)=s*i_p
                i_p=1
                s=1
             else if(info(i:i) == "Z" .or. info(i:i) == "z") then
                sim(nop,3)=s*i_p
                i_p=1
                s=1
             else if(info(i:i) == "+") then
                s=1
             else if(info(i:i) == "-") then
                s=-1
             else if(info(i:i) == "/") then
                isl=1
             else if(info(i:i) == ".") then
                ip=1
             else
                st=s
                do k=1,10
                   if (info(i:i) == anum(k))  then
                      if (is_xyz(info(i+1:i+1))) then
                         i_p=num(k)
                         cycle loop_string
                      else
                         a=num(k)
                         if (isl == 1) then
                            t=t/a
                         else if(ip == 1) then
                            np=np+1
                            t=t+a/10**np
                         else
                            t=10.0*t+a
                         end if
                         cycle loop_string
                      end if
                   end if
                end do
                err_symm=.true.
                ERR_Symm_Mess=" Invalid character... "//INFO(I:I)//" in operator string"
                return
             end if
          end do  loop_string   !end loop through the string (index:i= ist,imax)

          if (mod_istart == 1) then
             ist=i+1
          end if

          t=t*st
          if (present(tt)) tt(nop)=t

          if (ifound == 0) then
             err_symm=.true.
             ERR_Symm_Mess=" Blank operator field"
             return
          end if

       end do    !End external loop over the three expected items (index:NOP)

       if (determ_A(sim) == 0 .and. control) then      !Verify it is a suitable s.o.
          err_symm=.true.
          ERR_Symm_Mess=" The above operator is wrong: "//info
          return
       end if

       if (ifound == 1) return

       err_symm=.true.
       ERR_Symm_Mess=" The above operator is wrong: "//info

       return
    End Subroutine Read_Xsym

    !!----
    !!---- Subroutine Searchop(Sim,I1,I2,Isl)
    !!----    integer , dimension(3,3), Intent(in)  :: sim      !  In -> Rotational part of a symmetry operator
    !!----    integer ,                 Intent(in)  :: i1       !  In -> i1=1,  i2=24  if not hexagonal  (matrices of m3m )
    !!----    integer ,                 Intent(in)  :: i2       !  In -> i1=25, i2=36  if     hexagonal  (matrices of 6/mmm)
    !!----    integer ,                 Intent(out) :: Isl      ! Out -> Index of the matrix Mod6(Isl,:,:)=sim.
    !!----                                                               This index allow to get the corresponding tabulated symmetry symbol.
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Searchop(Sim,I1,I2,Isl)
       !---- Arguments ----!
       integer , dimension(3,3), Intent(in) :: sim
       integer , Intent(in)                 :: i1,i2
       integer , Intent(out)                :: Isl

       !---- Local variables ----!
       integer               :: iss,ipass,j,k,im

       iss=1
       ipass=0
       call init_err_symm()
       do
          ipass=ipass+1
          imdo:  do im=i1,i2
             Isl=0
             do j=1,3
                do k=1,3
                   if (sim(j,k) /= iss*Mod6(im,j,k)) cycle imdo
                end do
             end do
             Isl=iss*im
             exit
          end do imdo

          if (Isl /= 0) return

          if (ipass >=2 ) then
             ERR_Symm_Mess=" Try to re-write your S.O. using a rotational part"
             if (i1 == 1 .and.  i2 == 24) then
                ERR_Symm_Mess=trim(ERR_Symm_Mess)//" identical to a S.O. of the space group P m -3 m"
             else if(i1 == 25 .and.  i2 == 36) then
                ERR_Symm_Mess=trim(ERR_Symm_Mess)//" identical to a S.O. of the space group P 6/m m m"
             else
                ERR_Symm_Mess=trim(ERR_Symm_Mess)//" identical to a S.O. of the space group P m -3 m or P 6/m m m"
             end if
             err_symm=.true.
             return
          end if
          iss=-1
       end do

       return
    End Subroutine Searchop

    !!----
    !!---- Subroutine Set_Spacegroup(Spacegen, Spacegroup, Gen, Ngen, Mode, Force_Hall)
    !!----    character (len=*),                       intent(in)     :: SpaceGen     !  In -> String with Number, Hall or Hermman-Mauguin
    !!----    Type (Space_Group),                         intent(out) :: SpaceGroup   ! Out -> SpaceGroup variable
    !!----    character (len=*), dimension(:),  intent(in ), optional :: gen          !  In -> String Generators
    !!----    Integer,                          intent(in ), optional :: ngen         !  In -> Number of Generators
    !!----    character (len=*),                intent(in ), optional :: Mode         !  In -> HMS, ITC, Hall, Gen, Fix
    !!----    character (len=*),                intent(in ), optional :: force_hall   !  In -> f_hall (if present force generation from Hall)
    !!----
    !!----    Subroutine that construct the object SpaceGroup from the H-M or Hall symbol.
    !!----    Expand the set of operators including centre of symmetry and non integer
    !!----    translations for centred cells.
    !!----    If the optional argument Gen is given, then Ngen and Mode="GEN" should be given.
    !!----    If the optional argument mode="ITC", the space group will be generated using the
    !!----    the generators given in the International Tables for the standard setting. In this
    !!----    case the string in SpaceGen should correspond to the Hermann-Mauguin symbol.
    !!----    If the optional argument mode="HMS","HALL" is given the string in SpaceGen
    !!----    should correspond to the desired symbol.
    !!----    If Gen,NGen and Mode are not given but force_hall="f_hall" is given, the generation
    !!----    of the symmetry operators from the symbol of the space group is according to the Hall
    !!----    symbol even if the provided symbol is of Hermann-Maugin type.
    !!----    The use of the different options give rise to different ordering of the symmetry
    !!----    operators or different origins and settings for the same space group.
    !!----
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Set_SpaceGroup(Spacegen,Spacegroup,Gen,Ngen,Mode,Force_Hall)
       !----Arguments ----!
       character (len=*),                intent(in )           :: SpaceGen
       Type (Space_Group_Type),          intent(out)           :: SpaceGroup
       character (len=*), dimension(:),  intent(in ), optional :: gen
       Integer,                          intent(in ), optional :: ngen
       character (len=*),                intent(in ), optional :: Mode
       character (len=*),                intent(in ), optional :: force_hall

       !---- Local variables ----!
       character (len=*),dimension(0:2), parameter  :: Centro = &
                                          (/"Centric (-1 not at origin)", &
                                            "Acentric                  ", &
                                            "Centric (-1 at origin)    "/)
       character (len=20)               :: Spgm
       character (len=20)               :: ssymb
       character (len=130)              :: gener
       character (len=3)                :: opcion
       character (len=2)                :: Latsy
       integer                          :: num, i, j, iv, istart
       integer,      dimension(1)       :: ivet
       integer,      dimension(5)       :: poscol
       integer                          :: isystm,isymce,ibravl,Num_g
       integer                          :: m,l,ngm,k,ier
       integer                          :: ng
       integer,      dimension(3,3,384) :: ss
       real(kind=cp),dimension(3,384)   :: ts
       real(kind=cp),dimension(3)       :: co
       real(kind=cp),dimension(1)       :: vet
       real(kind=cp),dimension(3)       :: vec
       logical                          :: ok

       !---- Inicializing Space Group ----!
       call init_err_symm()

       !Constructor eliminated because some components are nowadays allocatable
       !There's no risk of undefined fields because in this procedure everything is set.
       !
       !SpaceGroup=Space_Group_Type(0,"unknown","unknown","unknown","?","?","?","?",.false.,"?","?", &
       !                       0,0.0,"?","?", -1, 0.0,  0, 0,  0, Sym_Oper_Type(0, 0.0),"?",         &
       !                       wyckoff_type(0,wyck_pos_type(0," ",0," "," ")),0.0)
       SpaceGroup%R_Asym_Unit(:,2)=1.0
       SpaceGroup%gHall=" "

       !---- Loading Tables ----!
       call Set_Spgr_Info()
       call Set_Wyckoff_Info()

       !---- Mode Option ----!
       opcion=" "
       spgm=adjustl(SpaceGen)
       spgm=u_case(spgm)
       num=-1

       if (present(mode)) then
          opcion=adjustl(mode)
          call ucase(opcion)

          Select case (opcion(1:3))

            case("HMS")
                do i=1,num_spgr_info
                   if (spgm(1:12) == spgr_info(i)%hm) then
                      num=i
                      exit
                   end if
                end do

            case("ITC")
                read(unit=spgm(1:12),fmt=*,iostat=ier) ivet(1)

                if( ier == 0) then
                   do i=1,num_spgr_info
                     if (ivet(1) == spgr_info(i)%n) then
                        num=i
                      exit
                     end if
                   end do
                else
                   do i=1,num_spgr_info
                     if (spgm(1:12) == spgr_info(i)%hm) then
                       num=i
                       exit
                     end if
                   end do
                end if

            case("HAL")
                do i=1,num_spgr_info
                   if (spgm(1:16) == u_case(spgr_info(i)%hall)) then
                      num=i
                      exit
                   end if
                end do
          End select

       else       ! detect automatically the symbol of the group

          call getnum(spgm,vet,ivet,iv)
          if (iv /= 1) then
             !---- Is HM Symbol ? ----!
             do i=1,num_spgr_info
                if (spgm(1:12) == spgr_info(i)%hm) then
                   num=i
                   opcion="HMS"
                   if(present(force_hall)) then
                     opcion="HAL"
                     spgm=spgr_info(i)%hall
                   end if
                   exit
                end if
             end do
              !Special treatment of groups P N M 21 (211), P 21 N M (213),
              !P M 21 N (215), B A M B (375), C 4 2 21 (429), C -4 B 2 (457)
              ! and F -4 D 2 (463)   => Force HALL in all these cases
              if(opcion(1:3) == "HMS" .and.  &
              (num==211 .or. num==213 .or. num==215  &
              .or. num==375 .or. num==429 .or. num==457 .or. num==463)) then
                  opcion(1:3) = "HAL"
                  spgm=spgr_info(num)%hall
              end if
             !---- Is a standard Hall Symbol ? ----!
             if (num < 0) then
                do i=1,num_spgr_info
                   if (spgm(1:16) == u_case(spgr_info(i)%hall)) then
                      num=i
                      opcion="HAL"
                      exit
                   end if
                end do
             end if

             !---- Using Generators ----!
             if (num <=0) then
                 if(present(gen)) then
                   opcion="GEN"
                 else  !The last option is a non-standard Hall symbol
                    opcion="HAL"
                 end if
             end if
          else
             if (ivet(1) > 0 .and. ivet(1) < 231) then
               do i=1,num_spgr_info
                   if (ivet(1) == spgr_info(i)%n) then
                      num=i
                      spgm=spgr_info(i)%hall
                      opcion="HAL"
                      exit
                   end if
                end do
             else
                err_symm=.true.
                ERR_Symm_Mess=" Number of Space Group out of limits"
                return
             end if
          end if
       end if  ! present(mode)

       select case (opcion(1:3))
          case ("FIX")
             if (present(gen) .and. present(ngen))  then
                ng=ngen
                istart=1
                num_g=ng-1
                do i=1,ngen
                   call Read_Xsym(gen(i),istart,ss(:,:,i),ts(:,i))
                end do
             else
                err_symm=.true.
                ERR_Symm_Mess=" Generators should be provided if FIX option is Used"
                return
             end if
             call Get_SO_from_FIX(isystm,isymce,ibravl,ng,ss,ts,latsy,co,Spgm,Spacegen(1:1))

             SpaceGroup%Spg_Symb     = "unknown "
             SpaceGroup%Hall         = "unknown "
             SpaceGroup%Laue         = " "
             SpaceGroup%Info         = "Fixed symmetry operators (no info)"
             SpaceGroup%SPG_lat      = Lat_Ch
             SpaceGroup%NumLat       = nlat

             if(allocated(SpaceGroup%Latt_trans)) deallocate(SpaceGroup%Latt_trans)
             allocate(SpaceGroup%Latt_trans(3,nlat))

             SpaceGroup%Latt_trans   = Ltr(:,1:nlat)
             SpaceGroup%Num_gen      = max(0,num_g)
             SpaceGroup%Centre_coord = co
             SpaceGroup%SG_setting   = "Non-Conventional (user-given operators)"
             SpaceGroup%CrystalSys   = " "
             SpaceGroup%Bravais      = Latt(ibravl)
             SpaceGroup%SPG_latsy    = latsy
             SpaceGroup%centred      = isymce
             SpaceGroup%centre       = Centro(isymce)
             SpaceGroup%Numops       = NG

          case ("GEN")
             if (present(gen) .and. present(ngen))  then
                do i=1,ngen
                   call Check_Generator(gen(i),ok)
                   !write(*,"(a,i3,a,tr2,L)") " => Generator # ",i,"  "//trim(gen(i)), ok
                   if(.not. ok) return
                end do
                ng=ngen
                istart=1
                num_g=ng
                call Get_GenSymb_from_Gener(gen,ng,SpaceGroup%gHall)
                do i=1,ngen
                   call Read_Xsym(gen(i),istart,ss(:,:,i),ts(:,i))
                end do
             else
                err_symm=.true.
                ERR_Symm_Mess=" Generators should be provided in GEN calling Set_SpaceGroup"
                return
             end if
             call Get_SO_from_Gener(Isystm,Isymce,Ibravl,Ng,Ss,Ts,Latsy, &
                                    Co,Num_g,Spgm)

             SpaceGroup%CrystalSys   = sys_cry(isystm)
             SpaceGroup%SG_setting   = "Non-Conventional (user-given operators)"
             SpaceGroup%SPG_lat      = Lat_Ch
             SpaceGroup%SPG_latsy    = latsy
             SpaceGroup%NumLat       = nlat
             if(allocated(SpaceGroup%Latt_trans)) deallocate(SpaceGroup%Latt_trans)
             allocate(SpaceGroup%Latt_trans(3,nlat))
             SpaceGroup%Latt_trans   = Ltr(:,1:nlat)
             SpaceGroup%Bravais      = Latt(ibravl)
             SpaceGroup%centre       = Centro(isymce)
             SpaceGroup%centred      = isymce
             SpaceGroup%Centre_coord = co
             SpaceGroup%Numops       = NG
             SpaceGroup%Num_gen      = max(0,num_g)

          case ("HAL")
             call Get_SO_from_Hall (Isystm,Isymce,Ibravl,Ng,Ss,Ts,Latsy, &
                                    Co,Num_g,Spgm)

             if (num > 0) then
                SpaceGroup%NumSpg       = spgr_info(num)%n
                SpaceGroup%Spg_Symb     = spgr_info(num)%hm
                SpaceGroup%Hall         = spgr_info(num)%hall
                call get_laue_str(spgr_info(num)%laue,SpaceGroup%Laue)
                call get_PointGroup_str(spgr_info(num)%pg,SpaceGroup%PG)
                SpaceGroup%Info         = spgr_info(num)%inf_extra
                SpaceGroup%R_Asym_Unit(1,1) = real(spgr_info(num)%asu(1))/24.0
                SpaceGroup%R_Asym_Unit(2,1) = real(spgr_info(num)%asu(2))/24.0
                SpaceGroup%R_Asym_Unit(3,1) = real(spgr_info(num)%asu(3))/24.0
                SpaceGroup%R_Asym_Unit(1,2) = real(spgr_info(num)%asu(4))/24.0
                SpaceGroup%R_Asym_Unit(2,2) = real(spgr_info(num)%asu(5))/24.0
                SpaceGroup%R_Asym_Unit(3,2) = real(spgr_info(num)%asu(6))/24.0
             else
                SpaceGroup%Hall         = Spgm
             end if
             SpaceGroup%CrystalSys   = sys_cry(isystm)
             SpaceGroup%SG_setting   = "Generated from Hall symbol"
             SpaceGroup%SPG_lat      = Lat_Ch
             SpaceGroup%SPG_latsy    = latsy
             SpaceGroup%NumLat       = nlat
             if(allocated(SpaceGroup%Latt_trans)) deallocate(SpaceGroup%Latt_trans)
             allocate(SpaceGroup%Latt_trans(3,nlat))
             SpaceGroup%Latt_trans   = Ltr(:,1:nlat)
             SpaceGroup%Bravais      = Latt(ibravl)
             SpaceGroup%centre       = Centro(isymce)
             SpaceGroup%centred      = isymce
             SpaceGroup%Centre_coord = co
             SpaceGroup%Numops       = NG
             SpaceGroup%Num_gen      = max(0,num_g)

          case ("HMS")
             i=index(SpaceGen,":")
             co=0.0
             if (i /=0 .and. num > 0) then
                spgm=spgr_info(num)%hall
                call Get_SO_from_Hall (Isystm,Isymce,Ibravl,Ng,Ss,Ts,Latsy, &
                                       Co,Num_g,Spgm)
             else
                if (i /= 0) then
                   Spgm=SpaceGen(1:i-1)
                else
                   Spgm=SpaceGen
                end if
                call Get_SO_from_HMS  (Isystm,Isymce,Ibravl,Ng,Ss,Ts,Latsy, &
                                       Spgm)
             end if
             if (num > 0) then
                SpaceGroup%NumSpg       = spgr_info(num)%n
                SpaceGroup%Spg_Symb     = spgr_info(num)%hm
                SpaceGroup%Hall         = spgr_info(num)%hall
                call get_laue_str(spgr_info(num)%laue,SpaceGroup%Laue)
                call get_PointGroup_str(spgr_info(num)%pg,SpaceGroup%PG)
                SpaceGroup%Info         = spgr_info(num)%inf_extra
                SpaceGroup%R_Asym_Unit(1,1) = real(spgr_info(num)%asu(1))/24.0
                SpaceGroup%R_Asym_Unit(2,1) = real(spgr_info(num)%asu(2))/24.0
                SpaceGroup%R_Asym_Unit(3,1) = real(spgr_info(num)%asu(3))/24.0
                SpaceGroup%R_Asym_Unit(1,2) = real(spgr_info(num)%asu(4))/24.0
                SpaceGroup%R_Asym_Unit(2,2) = real(spgr_info(num)%asu(5))/24.0
                SpaceGroup%R_Asym_Unit(3,2) = real(spgr_info(num)%asu(6))/24.0
             else
                SpaceGroup%Spg_Symb     = SpaceGen
                SpaceGroup%Num_gen= 0    !unknown
             end if
             SpaceGroup%CrystalSys   = sys_cry(isystm)
             if (i /=0 .and. num > 0) then
                SpaceGroup%SG_setting   = "Generated from Hall symbol"
                SpaceGroup%Num_gen=max(0,num_g)
             else
                SpaceGroup%SG_setting   ="IT (Generated from Hermann-Mauguin symbol)"
                if(num > 0) then
                   Select Case (spgr_info(num)%n)
                     case(1:2)
                        SpaceGroup%Num_gen= 0    !triclinic
                     case(3:15)
                        SpaceGroup%Num_gen= 1    !monoclinic
                     case(16:74)
                        SpaceGroup%Num_gen= 2    !orthorhombic
                     case(75:88)
                        SpaceGroup%Num_gen= 1    !tetragonal
                     case(89:142)
                        SpaceGroup%Num_gen= 2    !tetragonal
                     case(143:148)
                        SpaceGroup%Num_gen= 1    !trigonal
                     case(149:167)
                        SpaceGroup%Num_gen= 2    !trigonal
                     case(168:176)
                        SpaceGroup%Num_gen= 1    !hexagonal
                     case(177:194)
                        SpaceGroup%Num_gen= 2    !hexagonal
                     case(195:230)
                        SpaceGroup%Num_gen= 3    !cubic
                     case default
                        SpaceGroup%Num_gen= 0    !unknown
                   End Select
                end if
             end if
             SpaceGroup%SPG_lat      = Lat_Ch
             SpaceGroup%SPG_latsy    = latsy
             SpaceGroup%NumLat       = nlat
             if(allocated(SpaceGroup%Latt_trans)) deallocate(SpaceGroup%Latt_trans)
             allocate(SpaceGroup%Latt_trans(3,nlat))
             SpaceGroup%Latt_trans   = Ltr(:,1:nlat)
             SpaceGroup%Bravais      = Latt(ibravl)
             SpaceGroup%centre       = Centro(isymce)
             SpaceGroup%centred      = isymce
             SpaceGroup%Centre_coord = co
             SpaceGroup%Numops       = NG

          case ("ITC")

             call get_generators(spgm,gener)
             if (err_symtab) then
                err_symm=.true.
                ERR_Symm_Mess=" Problems in SpaceGroup: "//trim(spgm)//" => the HM symbol or the number is incorrect "
                return
             else  !Decode gener in generators to construct the space group
                k=0
                do i=1,len_trim(gener)
                   if (gener(i:i) == ";") then
                      k=k+1
                      poscol(k)=i
                   end if
                end do
                if (k /= 0) then
                   ssymb=" "
                   ssymb= adjustl(gener(1:poscol(1)-1))
                   call Read_Xsym(ssymb,1,ss(:,:,1),ts(:,1))
                   do i=2,k
                      ssymb=" "
                      ssymb=adjustl(gener(poscol(i-1)+1:poscol(i)-1))
                      call Read_Xsym(ssymb,1,ss(:,:,i),ts(:,i))
                   end do
                   ssymb=" "
                   ssymb=gener(poscol(k)+1:)
                   call Read_Xsym(ssymb,1,ss(:,:,k+1),ts(:,k+1))
                else
                   ssymb=gener
                   call Read_Xsym(ssymb,1,ss(:,:,k+1),ts(:,k+1))
                end if
             end if

             ng=k+1     !k+1 is the number of generators
             num_g=ng
             call Get_SO_from_Gener(Isystm,Isymce,Ibravl,Ng,Ss,Ts,Latsy, &
                                    Co,Num_g,Spgm)
             if (num > 0) then
                SpaceGroup%NumSpg       = spgr_info(num)%n
                SpaceGroup%Spg_Symb     = spgr_info(num)%hm
                SpaceGroup%Hall         = spgr_info(num)%hall
                call get_laue_str(spgr_info(num)%laue,SpaceGroup%Laue)
                call get_PointGroup_str(spgr_info(num)%pg,SpaceGroup%PG)
                SpaceGroup%Info         = spgr_info(num)%inf_extra
                SpaceGroup%R_Asym_Unit(1,1) = real(spgr_info(num)%asu(1))/24.0
                SpaceGroup%R_Asym_Unit(2,1) = real(spgr_info(num)%asu(2))/24.0
                SpaceGroup%R_Asym_Unit(3,1) = real(spgr_info(num)%asu(3))/24.0
                SpaceGroup%R_Asym_Unit(1,2) = real(spgr_info(num)%asu(4))/24.0
                SpaceGroup%R_Asym_Unit(2,2) = real(spgr_info(num)%asu(5))/24.0
                SpaceGroup%R_Asym_Unit(3,2) = real(spgr_info(num)%asu(6))/24.0
                SpaceGroup%SG_setting   = "Generated from explicit IT generators"
             else
                SpaceGroup%Spg_Symb     = SpaceGen
                SpaceGroup%Num_gen= 0    !unknown
             end if

             SpaceGroup%CrystalSys   = sys_cry(isystm)
             SpaceGroup%SPG_lat      = Lat_Ch
             SpaceGroup%SPG_latsy    = latsy
             SpaceGroup%NumLat       = nlat
             if(allocated(SpaceGroup%Latt_trans)) deallocate(SpaceGroup%Latt_trans)
             allocate(SpaceGroup%Latt_trans(3,nlat))
             SpaceGroup%Latt_trans   = Ltr(:,1:nlat)
             SpaceGroup%Bravais      = Latt(ibravl)
             SpaceGroup%centre       = Centro(isymce)
             SpaceGroup%centred      = isymce
             SpaceGroup%Centre_coord = co
             SpaceGroup%Numops       = NG
             SpaceGroup%Num_gen      = max(0,num_g)

          case default
             err_symm=.true.
             ERR_Symm_Mess=" Problems in SpaceGroup"
             return
       end select

       if (err_symm) return
       if (Is_Hexa(ng,ss)) SpaceGroup%Hexa=.true.

       hexa=SpaceGroup%Hexa  !added 24/05/2007

       if (opcion(1:3) /= "FIX") then              !This has been changed of place for allocating
           select case (SpaceGroup%centred)        !the allocatable components properly
              case (0)
                 SpaceGroup%Multip = 2*NG*nlat
              case (1)
                 SpaceGroup%Multip =   NG*nlat
              case (2)
                 SpaceGroup%Multip = 2*NG*nlat
           end select
       else
           SpaceGroup%Multip =   NG
       end if

       !Allocate here the total number of symmetry operators (JRC, Jan2014)

       if(allocated(SpaceGroup%Symop)) deallocate(SpaceGroup%Symop)
       allocate(SpaceGroup%Symop(SpaceGroup%Multip))
       if(allocated(SpaceGroup%SymopSymb)) deallocate(SpaceGroup%SymopSymb)
       allocate(SpaceGroup%SymopSymb(SpaceGroup%Multip))

       do i=1,SpaceGroup%Numops
          SpaceGroup%Symop(i)%Rot(:,:) = ss(:,:,i)
          SpaceGroup%Symop(i)%tr(:)    = ts(:,i)
       end do

       if (opcion(1:3) /= "FIX") then
          m=SpaceGroup%Numops
          if (SpaceGroup%centred == 0) then
             do i=1,SpaceGroup%Numops
                m=m+1
                vec=-ts(:,i)+2.0*SpaceGroup%Centre_coord(:)
                SpaceGroup%Symop(m)%Rot(:,:) = -ss(:,:,i)
                SpaceGroup%Symop(m)%tr(:)    =  modulo_lat(vec)
             end do
          end if
          if (SpaceGroup%centred == 2) then
             do i=1,SpaceGroup%Numops
                m=m+1
                SpaceGroup%Symop(m)%Rot(:,:) = -ss(:,:,i)
                SpaceGroup%Symop(m)%tr(:)    =  modulo_lat(-ts(:,i))
             end do
          end if
          ngm=m
          if (SpaceGroup%NumLat > 1) then

             do L=2,SpaceGroup%NumLat  ! min(SpaceGroup%NumLat,4)  restriction removed Jan2014 (JRC)
                do i=1,ngm
                   m=m+1
                   vec=SpaceGroup%Symop(i)%tr(:) + SpaceGroup%Latt_trans(:,L)
                   SpaceGroup%Symop(m)%Rot(:,:) = SpaceGroup%Symop(i)%Rot(:,:)
                   SpaceGroup%Symop(m)%tr(:)    = modulo_lat(vec)
                end do
             end do
          end if

       end if
       !write(*,"(a)") " => Generating the symetry operators symbols"
       do i=1,SpaceGroup%multip  ! min(SpaceGroup%multip,192) restriction removed Jan2014 (JRC)
          call Get_SymSymb(SpaceGroup%Symop(i)%Rot(:,:), &
                           SpaceGroup%Symop(i)%tr(:)   , &
                           SpaceGroup%SymopSymb(i))
       end do
       !write(*,"(a)") " => done"

       if (num <= 0) then
          call Get_Laue_PG(SpaceGroup, SpaceGroup%Laue, SpaceGroup%PG)
       end if
       !write(*,"(a)") " => Point group done"

       if(isymce == 0) then
          SpaceGroup%centre = trim(SpaceGroup%centre)//"  Gen(-1):"//SpaceGroup%SymopSymb(NG+1)
       end if

       if(opcion(1:3)=="GEN") call Get_HallSymb_from_Gener(SpaceGroup)

       !write(*,"(a)") " => Wyckoff information"

       !---- Wyckoff information ----!
       if (len_trim(SpaceGroup%Spg_Symb) /= 0) then
          do i=1,273
             if (SpaceGroup%Spg_Symb(1:12) /= wyckoff_info(i)%hm) cycle
             SpaceGroup%Wyckoff%num_orbit=wyckoff_info(i)%norbit
             do j=1,wyckoff_info(i)%norbit

                call wyckoff_orbit(SpaceGroup,wyckoff_info(i)%corbit(j), &
                                   SpaceGroup%Wyckoff%Orbit(j)%norb,     &
                                   SpaceGroup%Wyckoff%Orbit(j)%Str_Orbit)
                SpaceGroup%Wyckoff%Orbit(j)%multp=SpaceGroup%Wyckoff%Orbit(j)%norb*spacegroup%numlat
             end do
             exit
          end do
          SpaceGroup%Spg_Symb(2:)=l_case(SpaceGroup%Spg_Symb(2:))  !Make lowercase the HM generators of the group
       end if
       !write(*,"(a)") " => Wyckoff done"

       return
    End Subroutine Set_SpaceGroup

    !!----
    !!---- Subroutine Set_SpG_Mult_Table(SpG,tab,complete)
    !!----   Type(Space_Group_Type),    intent (in)    :: SpG
    !!----   integer, dimension(:,:),   intent (out)   :: tab
    !!----   logical, optional,         intent (in)    :: complete
    !!----
    !!----   Subroutine to construct the multiplication table of the factor group of
    !!----   a space group. Two operators are equal if they differ only in a lattice
    !!----   translation. The multiplication table is a square matrix with integer
    !!----   numbers corresponding to the ordering of operators in the space group
    !!----   If "complete" is not present, or if complete=.false., we consider only
    !!----   the symmetry operators corresponding to the "primitive" content of the
    !!----   unit cell, so a maximun 48x48 matrix is needed to hold the table in this
    !!----   case. If complete is present and .true., the full table is constructed.
    !!----
    !!----
    !!----  Update: April 2005
    !!----

    Subroutine Set_SpG_Mult_Table(SpG,tab,complete)
      Type(Space_Group_Type),    intent (in)    :: SpG
      integer, dimension(:,:),   intent (out)   :: tab
      logical, optional,         intent (in)    :: complete

       !---- Local Variables ----!
       Type(Sym_Oper_Type) :: Opi,Opj,Opk
       integer :: i,j, ng, k
       logical :: eqvo
       character(len=1) :: lat

       tab=0
       lat=SpG%SPG_lat
       ng=SpG%Numops
       if(SpG%Centred /= 1) ng=2*ng
       if(present(complete)) then
         if(complete) then
           lat="P"
           ng=SpG%Multip
         end if
       end if

       do i=1,ng
         Opi=SpG%SymOp(i)
         do j=1,ng
           Opj=SpG%SymOp(j)
           Opk=Opi*Opj
           do k=1,ng
             eqvo= Equiv_Symop(Opk,SpG%SymOp(k),lat)
             if(eqvo) then
               tab(i,j)=k
               exit
             end if
           end do
           if(tab(i,j) == 0) then
             err_symm=.true.
             ERR_Symm_Mess=" Problems constructing the multiplication Table of the space group: "//trim(spg%spg_symb)
             return
           end if
         end do
       end do

      return
    End Subroutine Set_SpG_Mult_Table

    !!--++
    !!--++ Subroutine Setting_Change_Conv(From_Syst,To_Syst,Spacegroup, Car_Sym, Icar_Sym)
    !!--++    character(len=2),    intent(in)     :: From_Syst   !  In -> IT : International Tables
    !!--++                                                                ML : Miller & Love
    !!--++                                                                KO : Kovalev
    !!--++                                                                BC : Bradley & Cracknell
    !!--++                                                                ZA : Zack
    !!--++    character(len=2),    intent(in)     :: To_Syst     !  In -> (Idem to From_Syst)
    !!--++    type (Space_Group),  intent(in out) :: SpaceGroup  !  In ->
    !!--++                                                         Out ->
    !!--++    character(len=35),    intent(out)   :: car_sym     ! Out ->
    !!--++    character(len=35),    intent(out)   :: icar_sym    ! Out ->
    !!--++
    !!--++    Traslate From From_Syst to To_syst the set of symmetry operators
    !!--++
    !!--++   Update: February - 2005 (Name changed and overloaded by JRC in Jan2014)
    !!
    Subroutine Setting_Change_Conv(From_Syst, To_Syst, SpaceGroup, car_sym, icar_sym)
       !---- Arguments ----!
       character(len=2),          intent(in)     :: From_Syst, To_Syst
       type (Space_Group_Type),   intent(in out) :: SpaceGroup
       character(len=35),         intent(out)    :: car_sym, icar_sym

       !---- Local Variables ----!
       character(len=2) :: car1, car2
       integer                 :: i,j,num
       integer, dimension(4,4) :: s, si, st, sti, w
       integer, dimension(3,3) :: r, r_inv, rt, rt_inv
       real(kind=cp), dimension(3)      :: t, t_inv, tt, tt_inv

       !---- Initializing variables ----!
       call init_err_symm()
       call Set_System_Equiv()

       car1=From_Syst
       car2=To_Syst
       car_sym=" "
       icar_sym=" "
       call ucase(car1)
       call ucase(car1)

       !---- Checking data ----!
       if (len_trim (car1) == 0) then
          err_symm=.true.
          ERR_Symm_Mess=" Blank Option"
          return
       end if
       if (len_trim (car2) == 0) then
          err_symm=.true.
          ERR_Symm_Mess=" Blank Option"
          return
       end if
       if (SpaceGroup%NumSpg <= 0 .or. SpaceGroup%NumSpg > 230 ) then
          err_symm=.true.
          ERR_Symm_Mess=" Space Group Not Defined..."
          return
       end if
       SpaceGroup%SG_setting="Changed from "//car1//" to "//car2
       num=SpaceGroup%NumSpg
       r     = 0
       r_inv = 0
       rt    = 0
       rt_inv= 0
       t     = 0.0
       t_inv = 0.0
       tt    = 0.0
       tt_inv= 0.0
       do i=1,3
          r(i,i)      = 1
          r_inv(i,i)  = 1
          rt(i,i)     = 1
          rt_inv(i,i) = 1
       end do
       s     = 0
       si    = 0
       st    = 0
       sti   = 0
       w     = 0
       do i=1,4
          s(i,i)   = 1
          si(i,i)  = 1
          st(i,i)  = 1
          sti(i,i) = 1
          w(i,i)   = 1
       end do

       select case (car1)
          case ("IT")    !---- International Tables ----!
             select case (car2)
                case ("IT")
                   return
                case ("ML")
                   car_sym=system_equiv(num)%ml
                case ("KO")
                   car_sym=system_equiv(num)%ko
                case ("BC")
                   car_sym=system_equiv(num)%bc
                case ("ZA")
                   car_sym=system_equiv(num)%za
             end select
             j=1
             call read_Xsym(car_sym,j,r,t)
             call inverse_symm(r,t,r_inv,t_inv)
             if (err_symm) return

          case ("ML")    !---- Miller & Love ----!
             select case (car2)
                case ("IT")
                   car_sym=system_equiv(num)%ml
                   j=1
                   call read_Xsym(car_sym,j,r_inv,t_inv)
                   call inverse_symm(r_inv,t_inv,r,t)
                   if (err_symm) return

                case ("ML")
                   return

                case ("KO")
                   car_sym=system_equiv(num)%ml
                   j=1
                   call read_Xsym(car_sym,j,r_inv,t_inv)
                   call inverse_symm(r_inv,t_inv,r,t)
                   if (err_symm) return
                   car_sym=system_equiv(num)%ko
                   j=1
                   call read_Xsym(car_sym,j,rt,tt)
                   call inverse_symm(rt,tt,rt_inv,t_inv)
                   if (err_symm) return

                case ("BC")
                   car_sym=system_equiv(num)%ml
                   j=1
                   call read_Xsym(car_sym,j,r_inv,t_inv)
                   call inverse_symm(r_inv,t_inv,r,t)
                   if (err_symm) return
                   car_sym=system_equiv(num)%bc
                   j=1
                   call read_Xsym(car_sym,j,rt,tt)
                   call inverse_symm(rt,tt,rt_inv,t_inv)
                   if (err_symm) return

                case ("ZA")
                   car_sym=system_equiv(num)%ml
                   j=1
                   call read_Xsym(car_sym,j,r_inv,t_inv)
                   call inverse_symm(r_inv,t_inv,r,t)
                   if (err_symm) return
                   car_sym=system_equiv(num)%za
                   j=1
                   call read_Xsym(car_sym,j,rt,tt)
                   call inverse_symm(rt,tt,rt_inv,t_inv)
                   if (err_symm) return
             end select

          case ("KO")    !---- Kovalev ----!
             select case (car2)
                case ("IT")
                   car_sym=system_equiv(num)%ko
                   j=1
                   call read_Xsym(car_sym,j,r_inv,t_inv)
                   call inverse_symm(r_inv,t_inv,r,t)
                   if (err_symm) return

                case ("ML")
                   car_sym=system_equiv(num)%ko
                   j=1
                   call read_Xsym(car_sym,j,r_inv,t_inv)
                   call inverse_symm(r_inv,t_inv,r,t)
                   if (err_symm) return
                   car_sym=system_equiv(num)%ml
                   j=1
                   call read_Xsym(car_sym,j,rt,tt)
                   call inverse_symm(rt,tt,rt_inv,t_inv)
                   if (err_symm) return

                case ("KO")
                   return

                case ("BC")
                   car_sym=system_equiv(num)%ko
                   j=1
                   call read_Xsym(car_sym,j,r_inv,t_inv)
                   call inverse_symm(r_inv,t_inv,r,t)
                   if (err_symm) return
                   car_sym=system_equiv(num)%bc
                   j=1
                   call read_Xsym(car_sym,j,rt,tt)
                   call inverse_symm(rt,tt,rt_inv,t_inv)
                   if (err_symm) return

                case ("ZA")
                   car_sym=system_equiv(num)%ko
                   j=1
                   call read_Xsym(car_sym,j,r_inv,t_inv)
                   call inverse_symm(r_inv,t_inv,r,t)
                   if (err_symm) return
                   car_sym=system_equiv(num)%za
                   j=1
                   call read_Xsym(car_sym,j,rt,tt)
                   call inverse_symm(rt,tt,rt_inv,t_inv)
                   if (err_symm) return
             end select

          case ("BC")    !---- Bradley & Cracknell ----!
             select case (car2)
                case ("IT")
                   car_sym=system_equiv(num)%bc
                   j=1
                   call read_Xsym(car_sym,j,r_inv,t_inv)
                   call inverse_symm(r_inv,t_inv,r,t)
                   if (err_symm) return

                case ("ML")
                   car_sym=system_equiv(num)%bc
                   j=1
                   call read_Xsym(car_sym,j,r_inv,t_inv)
                   call inverse_symm(r_inv,t_inv,r,t)
                   if (err_symm) return
                   car_sym=system_equiv(num)%ml
                   j=1
                   call read_Xsym(car_sym,j,rt,tt)
                   call inverse_symm(rt,tt,rt_inv,t_inv)
                   if (err_symm) return

                case ("KO")
                   car_sym=system_equiv(num)%bc
                   j=1
                   call read_Xsym(car_sym,j,r_inv,t_inv)
                   call inverse_symm(r_inv,t_inv,r,t)
                   if (err_symm) return
                   car_sym=system_equiv(num)%ko
                   j=1
                   call read_Xsym(car_sym,j,rt,tt)
                   call inverse_symm(rt,tt,rt_inv,t_inv)
                   if (err_symm) return

                case ("BC")
                   return

                case ("ZA")
                   car_sym=system_equiv(num)%bc
                   j=1
                   call read_Xsym(car_sym,j,r_inv,t_inv)
                   call inverse_symm(r_inv,t_inv,r,t)
                   if (err_symm) return
                   car_sym=system_equiv(num)%za
                   j=1
                   call read_Xsym(car_sym,j,rt,tt)
                   call inverse_symm(rt,tt,rt_inv,t_inv)
                   if (err_symm) return
             end select

          case ("ZA")    !---- Zak ----!
             select case (car2)
                case ("IT")
                   car_sym=system_equiv(num)%za
                   j=1
                   call read_Xsym(car_sym,j,r_inv,t_inv)
                   call inverse_symm(r_inv,t_inv,r,t)
                   if (err_symm) return

                case ("ML")
                   car_sym=system_equiv(num)%za
                   j=1
                   call read_Xsym(car_sym,j,r_inv,t_inv)
                   call inverse_symm(r_inv,t_inv,r,t)
                   if (err_symm) return
                   car_sym=system_equiv(num)%ml
                   j=1
                   call read_Xsym(car_sym,j,rt,tt)
                   call inverse_symm(rt,tt,rt_inv,t_inv)
                   if (err_symm) return

                case ("KO")
                   car_sym=system_equiv(num)%za
                   j=1
                   call read_Xsym(car_sym,j,r_inv,t_inv)
                   call inverse_symm(r_inv,t_inv,r,t)
                   if (err_symm) return
                   car_sym=system_equiv(num)%ko
                   j=1
                   call read_Xsym(car_sym,j,rt,tt)
                   call inverse_symm(rt,tt,rt_inv,t_inv)
                   if (err_symm) return

                case ("BC")
                   car_sym=system_equiv(num)%za
                   j=1
                   call read_Xsym(car_sym,j,r_inv,t_inv)
                   call inverse_symm(r_inv,t_inv,r,t)
                   if (err_symm) return
                   car_sym=system_equiv(num)%bc
                   j=1
                   call read_Xsym(car_sym,j,rt,tt)
                   call inverse_symm(rt,tt,rt_inv,t_inv)
                   if (err_symm) return

                case ("ZA")
                   return
             end select

       end select

       call Get_SymSymb(rt_inv,t_inv,icar_sym)
       s(1:3,1:3)  = r
       s(1:3,4)    = mod(nint(t*24.0)+48,24)
       si(1:3,1:3) = r_inv
       si(1:3,4)   = mod(nint(t_inv*24.0)+48,24)

       st(1:3,1:3) = rt
       st(1:3,4)   = mod(nint(tt*24.0)+48,24)
       sti(1:3,1:3)= rt_inv
       sti(1:3,4)  = mod(nint(tt_inv*24.0)+48,24)

       s=matmul(st,s)
       si=matmul(si,sti)

       do i=1,SpaceGroup%multip
          w(1:3,1:3) = SpaceGroup%Symop(i)%Rot
          w(1:3,4)   = mod(nint(SpaceGroup%Symop(i)%Tr*24.0)+48,24)
          w=matmul(s,w)
          w=matmul(w,si)
          SpaceGroup%Symop(i)%Rot = w(1:3,1:3)
          SpaceGroup%Symop(i)%Tr  = mod(real(w(1:3,4)/24.0)+10.0_cp,1.0_cp)
       end do
       do i=1,SpaceGroup%numops
          call Get_SymSymb(SpaceGroup%Symop(i)%Rot,  &
                           SpaceGroup%Symop(i)%tr,SpaceGroup%SymopSymb(i))
       end do

       return
    End Subroutine Setting_Change_Conv

    !!--++
    !!--++ Subroutine Setting_Change_NonConv(Mat,Orig,Spg,Spgn,Matkind)
    !!--++   real(kind=cp), dimension(3,3),intent(in) :: mat      ! Basis transformation matrix
    !!--++   real(kind=cp), dimension(3),  intent(in) :: orig     ! New origing in the old basis
    !!--++   type (Space_Group_Type),      intent(in) :: SpG      ! Input space group
    !!--++   type (NS_Space_Group_Type),  intent(out) :: SpGn     ! New space group in the new setting.
    !!--++   character (len=*), optional,  intent(in) :: matkind  ! Kind of transformation matrix
    !!--++
    !!--++    Transform the symmetry operators of the space group to a new basis given by
    !!--++    the matrix "mat" and vector "orig"
    !!--++    If matkind is given and matkind="it"/"IT", the input matrix is given
    !!--++    as in International Tables: Mat=P =>  (a,b,c)'=(a,b,c)P
    !!--++    Otherwise it is the trasposed matrix Mat=Pt
    !!--++
    !!--++ Created: January - 2014 (JRC)
    !!
    Subroutine Setting_Change_NonConv(Mat,Orig,Spg,Spgn,Matkind)
       !---- Arguments ----!
       real(kind=cp), dimension(3,3),intent(in) :: Mat
       real(kind=cp), dimension(3),  intent(in) :: Orig
       type (Space_Group_Type),      intent(in) :: SpG
       type (NS_Space_Group_Type),  intent(out) :: SpGn
       character (len=*), optional,  intent(in) :: Matkind

       !--- Local variables ---!
       integer                 :: ifail, i, j, k, L, im, nc, m, ngm,n,ngen
       real(kind=cp)           :: det
       character(len=40)       :: transla
       character(len=1)        :: LatSymb
       real(kind=cp), dimension (3,3), parameter :: e = reshape ((/1.0,0.0,0.0,  &
                                                                   0.0,1.0,0.0,  &
                                                                   0.0,0.0,1.0/),(/3,3/))
       real(kind=cp), dimension (3,192)    :: newlat = 0.0 !big enough number of centring tranlations
       real(kind=cp), dimension (3,3)      :: S, Sinv, rot, rotn  !S is the ITC matrix P.
       integer,       dimension (3,3)      :: nulo
       real(kind=cp), dimension (  3)      :: tr, trn, v
       logical                             :: lattl,change_only_origin
       character(len=80)                   :: symbsg
       character(len=60),dimension(15)     :: gen
       character(len=180)                  :: setting
       real(kind=cp),  dimension(3,3,Spg%Multip) :: sm
       real(kind=cp),  dimension(3,Spg%Multip)   :: tm

       call Init_Err_Symm()
       change_only_origin=.false.
       nulo=0
       call get_setting_info(Mat,orig,setting,matkind)
       symbsg=Pack_String(SpG%spg_symb)
       if (present(matkind)) then
          if (matkind(1:2) == "it" .or. matkind(1:2) == "IT" ) then
             S=Mat
          else
             S=transpose(Mat)
          end if
       else
          S=transpose(Mat)
       end if
       setting = trim(setting)//" det:"
       if(equal_matrix(S,e,3)) change_only_origin=.true.
       det=determ_a(Mat)
       i=len_trim(setting)
       write(unit=setting(i+2:),fmt="(f6.2)") det
       !write(unit=*,fmt="(a)") " => Setting Symbol: "//trim(setting)
       call matrix_inverse(S,Sinv,ifail)
       if (ifail /= 0) then
          err_symm=.true.
          ERR_Symm_Mess= "Inversion Matrix Failed on: Setting_Change_NonConv"
          return
       end if

       L=0
       if (SpG%NumLat > 1) then  !Original lattice is centered
          do i=2,SpG%NumLat      !Transform the centring vectors to the new lattice
             v=Modulo_Lat(matmul(Sinv,SpG%Latt_trans(:,i)))
             if (sum(v) < eps_symm) cycle
             L=L+1
             newlat(:,L)=v
          end do
       end if
       do i=1,3  !Test the basis vectors of the original setting
         rot(:,i)=Modulo_Lat(Sinv(:,i))
         if (sum(rot(:,i)) < eps_symm) cycle
         L=L+1
         newlat(:,L)=rot(:,i)
       end do

       if (det > 1 ) then  !The new lattice is centred
          im=nint(det)-1         !Determine the new lattice translations
          ngm=L+im
          doi: do i=0,im
             v(1) = i
             do j=0,im
                v(2) = j
                do k=0,im
                   v(3) = k
                   if (nint(sum(v)) == 0) cycle
                   tr=Modulo_Lat(matmul(Sinv,v))
                   if (sum(tr) < eps_symm) cycle
                   lattl =.true.
                   do m=1,L
                      if (sum(abs(tr-newlat(:,m))) < eps_symm) then
                         lattl =.false.
                         exit
                      end if
                   end do
                   if (lattl) then ! new lattice translation
                      L=L+1
                      newlat(:,L) = tr(:)
                      if (L == ngm) exit doi
                   end if
                end do !k
             end do !j
          end do doi !i
       end if

       call get_centring_vectors(L,newlat,LatSymb)  !Complete the centring vectors
       !Now we have L centring translations
       call LatSym(LatSymb,L,newlat)  !provides the value of the global variable inlat: index of the type of lattice
       SpGn%SPG_lat      = LatSymb
       SpGn%SPG_latsy    = SpG%SPG_latsy(1:1)//LatSymb

       !---- Change of symmetry operator under a change of basis and origin
       !----  A'= M A,  origin O =>  X'=inv(Mt)(X-O)
       !----  Symmetry operator C = (R,T)  -> C' = (R',T')
       !----   R' = inv(Mt) R Mt                 ITC:    R'= inv(P) R P
       !----   T' = inv(Mt) (T -(E-R)O)                  T'= inv(P) (T-(E-R)O)
       sm=0.0
       tm=0.0
       sm(:,:,1)=SpG%SymOp(1)%Rot
       tm(:,1)=SpG%SymOp(1)%tr
       n=1
       do_i:do i=2,SpG%NumOps
          Rot=SpG%SymOp(i)%rot
          Rotn=matmul(matmul(Sinv,Rot),S)
          !irot=nint(Rotn)
          do k=n,1,-1
            if(equal_matrix(Rotn,sm(:,:,k),3))  cycle do_i
          end do
          n=n+1
          sm(:,:,N)=Rotn
          tr=SpG%SymOp(i)%tr
          trn=matmul(Sinv,tr-matmul(e-Rot,orig))
          tm(:,n)=Modulo_Lat(trn)
       end do do_i

       SpGn%Centred=SpG%Centred
       SpGn%Centre_coord=SpG%Centre_coord
       if (SpG%Centred /= 1) then !the space group is centro-symmetric
          nc=SpG%NumOps+1
          Rot=SpG%SymOp(nc)%rot
          tr=SpG%SymOp(nc)%tr
          trn=matmul(Sinv,tr-matmul(e-Rot,orig)) ! matmul(Sinv,tr-2*orig)
          trn= Modulo_Lat(trn)
          if(sum(abs(trn)) > 3.0*eps_symm) then
            SpGn%Centred=0
            SpGn%Centre_coord=0.5*trn
          end if
       end if

       !Do another thing we conserve the transformations and generate ourself the new group
       !The new multiplicity is
       i=1
       if(SpGn%Centred /= 1) i=2
       SpGn%multip= n * i * nlat  !nlat=L+1

       allocate(SpGn%SymOp(SpGn%multip), SpGn%SymOpSymb(SpGn%multip))
       SpGn%NumOps=n
       do i=1,SpGn%NumOps
         SpGn%SymOp(i)%Rot=sm(:,:,i)
         SpGn%SymOp(i)%tr=tm(:,i)
       end do

       allocate(SpGn%Latt_trans(3,nlat))
       SpGn%NumLat    = nlat
       SpGn%Latt_trans= Ltr(:,1:nlat)
       SpGn%CrystalSys   = SpG%CrystalSys
       SpGn%SG_setting   = setting
       SpGn%Bravais      = Latt(inlat)
       Select Case (SpGn%Centred)
           Case(0,2)
             call Frac_Trans_2Dig(SpGn%Centre_coord,transla)
             SpGn%centre="Centric, -1 at "//trim(transla)
           Case Default
             SpGn%centre="Acentric"
       End Select
       SpGn%Num_gen      = SpG%Num_gen
       SpGn%PG           = SpG%PG
       SpGn%Laue         = SpG%laue
       SpGn%NumSpg=SpG%NumSpg
       m=SpGn%Numops
       if (SpGn%centred /= 1) then
          do i=1,SpGn%Numops
             m=m+1
             SpGn%Symop(m)%Rot(:,:) = -SpGn%Symop(i)%Rot(:,:)
             SpGn%Symop(m)%tr(:)    =  modulo_lat(-SpGn%Symop(i)%tr(:)+2.0*SpGn%Centre_coord)
          end do
       end if
       ngm=m
       if (SpGn%NumLat > 1) then
          do L=2,SpGn%NumLat
             do i=1,ngm
                m=m+1
                trn=SpGn%Symop(i)%tr(:) + SpGn%Latt_trans(:,L)
                SpGn%Symop(m)%Rot(:,:) = SpGn%Symop(i)%Rot(:,:)
                SpGn%Symop(m)%tr(:)    = modulo_lat(trn)
             end do
          end do
       end if
       do i=1,SpGn%multip
          call Get_SymSymb(SpGn%Symop(i)%Rot(:,:), &
                           SpGn%Symop(i)%tr(:)   , &
                           SpGn%SymopSymb(i))
       end do
       !Try to assign a Hall symbol to the space group in the new setting
       !If the hall symbol has been found and the symbol exists in the table the H-M symbol is also set.
       SpGn%hall="From:"//trim(SpG%hall)
       SpGn%spg_symb="From:"//trim(SpG%spg_symb)
       if(change_only_origin) then
         SpGn%spg_symb=trim(symbsg)
       else
         if(SpGn%NumSpg == 0) then
            SpGn%spg_symb="From:"//trim(symbsg)
         end if
       end if
       !Generate a general symbol, first select generators as a function of SpGn$Numops
       n=SpGn%NumOps
       Select Case(SpGn%centred)
         Case(0)
           gen(1)=SpGn%SPG_lat
           gen(2)=SpGn%SymopSymb(n+1)
           ngen=2
         Case(1)
           gen(1)=SpGn%SPG_lat
           ngen=1
         Case(2)
           gen(1)="-"//SpGn%SPG_lat
           ngen=1
       End Select

       Select Case(n)
         case(1:3)
           ngen=ngen+1
           gen(ngen)=SpGn%SymopSymb(2)
         case(4:)
           ngen=ngen+1
           gen(ngen)=SpGn%SymopSymb(2)
           ngen=ngen+1
           gen(ngen)=SpGn%SymopSymb(3)
       End Select
       !
       call Get_GenSymb_from_Gener(gen,ngen,SpGn%ghall)

       return
    End Subroutine Setting_Change_NonConv

    !!----
    !!---- Subroutine Similar_Transf_Sg(Mat,Orig,Spg,Spgn,Matkind)
    !!----    real(kind=cp), dimension (3,3),   intent( in)    :: Mat     ! Matrix transforming the basis
    !!----    real(kind=cp), dimension (  3),   intent( in)    :: orig    ! Coordinates of the new origin
    !!----    type (Space_Group_Type) ,         intent( in)    :: SpG     ! Initial space group
    !!----    type (Space_Group_Type) ,         intent(out)    :: SpGn    ! Maximum subgroup of SpG
    !!----    character (len=*), optional,      intent( in)    :: matkind ! Type of the input matrix
    !!----    character (len=*), optional,      intent( in)    :: Fix_lat ! Fixing Lattice type
    !!----
    !!----    Subroutine to construct a space group "SpGn" that is a maximal subgroup
    !!----    of the input space group "SpG" compatible with the transformation
    !!----    of the basis corresponding to the matrix "Mat" and the new origin "orig".
    !!----    The transformed SpGn will have (if it is the case) conventional centring vectors.
    !!----    If matkind is given and matkind="it"/"IT", the input matrix is given
    !!----    as in International Tables:
    !!--<<
    !!----                      (a' b' c') = (a b c) Mat
    !!-->>
    !!----    If matkind is not given or if it is not equal to "it"/"IT" the input matrix
    !!----    is the transpose of the International convention (column matrices for basis vectors)
    !!----    The new space group is obtained using the properties of conventional Bravais
    !!----    lattices and symmetry operators. Only the symmetry operators of the conventionnal
    !!----    form are retained to construct the new space group. If the Hermann-Mauguin symbol
    !!----    is not given, that means it correspond to a special setting. The Hall symbol is
    !!----    always given.
    !!----    The coordinates of the origin is always given with respect to the (a b c) basis.
    !!----    If Fix_lat is given a conventional lattice centring, this is fixed irrespective
    !!----    of the centring obtained by applying the similarity transformation. For instance
    !!----    is Fix_lat="P" and the transformation implies new centring vectors or the input
    !!----    group is centred, the generators with fraccional translations are removed from
    !!----    the group. If Fix_lat="A" (or whatever) the program will add the corresponding
    !!----    generators irrespective that the generator is in the original/transformed group.
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Similar_Transf_SG(Mat,orig,SpG,SpGn,matkind,Fix_lat)
       !---- Arguments ----!
       real(kind=cp), dimension (3,3),   intent( in)    :: Mat
       real(kind=cp), dimension (  3),   intent( in)    :: orig
       type (Space_Group_Type) ,         intent( in)    :: SpG
       type (Space_Group_Type) ,         intent(out)    :: SpGn
       character (len=*), optional,      intent( in)    :: matkind
       character (len=*), optional,      intent( in)    :: Fix_lat

       !--- Local variables ---!
       integer                 :: ifail, i, j, k, det, L, im, nc, m, ngm, ngen, Isystm
       real(kind=cp), dimension (3,3), parameter :: e = reshape ((/1.0,0.0,0.0,  &
                                                                   0.0,1.0,0.0,  &
                                                                   0.0,0.0,1.0/),(/3,3/))
       real(kind=cp), dimension (3,192):: newlat = 0.0 !big enough number of centring tranlations
       real(kind=cp), dimension (3,3)  :: S, Sinv, rot, rotn
       integer,       dimension (3,3)  :: irot
       real(kind=cp), dimension (  3)  :: tr, trn, v
       real(kind=cp)                   :: rmin,rmax
       logical                         :: latt
       character(len=40),dimension(60) :: gen
       integer,       dimension (60)   :: pt
       character(len=40)               :: string
       character(len=80)               :: setting, symbsg
       character(len=12)               :: csys
       character(len=1)                :: lattsymb, crys

       err_symm=.false.
       call get_setting_info(Mat,orig,setting,matkind)
       symbsg=Pack_String(SpG%spg_symb)
       csys=SpG%CrystalSys
       if (present(matkind)) then
          if (matkind(1:2) == "it" .or. matkind(1:2) == "IT" ) then
             S=Mat
          else
             S=transpose(Mat)
          end if
       else
          S=transpose(Mat)
       end if

       setting = trim(setting)
       det=determ_a(Mat)
       call matrix_inverse(S,Sinv,ifail)
       if (ifail /= 0) then
          err_symm=.true.
          ERR_Symm_Mess= "Inversion Matrix Failed on: similar_SG"
          return
       end if

       if(present(Fix_lat)) then
          lattsymb=Fix_lat
       else
          L=0
          if (SpG%NumLat > 1) then  !Original lattice is centered
             do i=2,SpG%NumLat      !Transform the centring vectors to the new lattice
                v=Modulo_Lat(matmul(Sinv,SpG%Latt_trans(:,i)))
                if (sum(v) < eps_symm) cycle
                L=L+1
                newlat(:,L)=v
             end do
          end if

          do i=1,3  !Test also the basis vectors of the original setting
            rot(:,i)=Modulo_Lat(Sinv(:,i))
            if (sum(rot(:,i)) < eps_symm) cycle
            L=L+1
            newlat(:,L)=rot(:,i)
          end do

          if (det > 1 ) then  !The new lattice is centred
             im=det-1         !Determine the new lattice translations
             ngm=L+im
             doi: do i=0,im
                v(1) = i
                do j=0,im
                   v(2) = j
                   do k=0,im
                      v(3) = k
                      if (nint(sum(v)) == 0) cycle
                      tr=Modulo_Lat(matmul(Sinv,v))
                      if (sum(tr) < eps_symm) cycle
                      latt =.true.
                      do m=1,L
                         if (sum(abs(tr-newlat(:,m))) < eps_symm) then
                            latt =.false.
                            exit
                         end if
                      end do
                      if (latt) then ! new lattice translation
                         L=L+1
                         newlat(:,L) = tr(:)
                         if (L == ngm) exit doi
                      end if
                   end do !k
                end do !j
             end do doi !i
          end if

          call get_centring_vectors(L,newlat,lattsymb)
          if(lattsymb == "Z") call Max_Conv_Lattice_Type(L, newlat, lattsymb)
          !newlat is not used anymore
       end if
       !---- Select the generators of the maximum conventional lattice
       ngen=0
       Select Case(lattsymb)
          Case("A")
             ngen=1
             gen(1)="x,y+1/2,z+1/2"
          Case("B")
             ngen=1
             gen(1)="x+1/2,y,z+1/2"
          Case("C")
             ngen=1
             gen(1)="x+1/2,y+1/2,z"
          Case("I")
             ngen=1
             gen(1)="x+1/2,y+1/2,z+1/2"
          Case("F")
             ngen=2
             gen(1)="x+1/2,y+1/2,z"
             gen(2)="x+1/2,y,z+1/2"
          Case("R")
             ngen=1
             gen(1)="x+2/3,y+1/3,z+1/3"
       End Select

       !---- Up to here all "conventionnal" translational generators have been obtained
       !---- Set the minimum and maximum admissible component of translations
       select case (csys)
          Case("Triclinic")
             rmin=0.0
             rmax=1.0
          Case("Monoclinic")
             rmin=0.5
             rmax=0.5
          Case("Orthorhombic")
             rmin=0.5
             rmax=0.5
             if (lattsymb == "F") then
                rmin=0.25
                rmax=0.75
             end if
          Case("Tetragonal")
             rmin=0.25
             rmax=0.75
          Case("Rhombohedral","Hexagonal","Trigonal")
             rmin=1.0/6.0
             rmax=5.0/6.0
          Case("Cubic")
             rmin=0.25
             rmax=0.75
          Case default
             rmin=0.5
             rmax=0.5
       end select

       !---- Change of symmetry operator under a change of basis and origin
       !----  A'= M A,  origin O =>  X'=inv(Mt)(X-O)
       !----  Symmetry operator C = (R,T)  -> C' = (R',T')
       !----   R' = inv(Mt) R Mt                 ITC:    R'= inv(P) R P
       !----   T' = inv(Mt) (T -(E-R)O)                  T'= inv(P) (T-(E-R)O)
       do i=2,SpG%NumOps
          Rot=SpG%SymOp(i)%rot
          tr=SpG%SymOp(i)%tr
          Rotn=matmul(matmul(Sinv,Rot),S)
          irot=abs(nint(rotn))
          if ( any(irot > 1) ) cycle    !Conserve only the conventional forms  |aij|=1,0
          if (.not. Zbelong(Rotn)) cycle
          ! Verify is the associated translation is admissible in the crystal system of
          ! the parent space group.
          trn=matmul(Sinv,tr-matmul(e-Rot,orig))
          trn=Modulo_Lat(trn)
          if ( any((trn < rmin .and. trn > 0.0) .or. trn > rmax) ) cycle  !internal compiler error in gfortran
          call Get_SymSymb(nint(Rotn),trn,string)
          ngen=ngen+1
          gen(ngen)=string
       end do

       !----Obtain the maximum expected crystal system after going to the new setting
       call Get_Crystal_System(Ngen,Gen, Isystm, Crys)

       select case (Isystm)
          Case(1)
             rmin=0.0
             rmax=1.0
          Case(2)
             rmin=0.5
             rmax=0.5
          Case(3)
             rmin=0.5
             rmax=0.5
             if (lattsymb == "F") then
                rmin=0.25
                rmax=0.75
             end if
          Case(4)
             rmin=0.25
             rmax=0.75
          Case(5,6)
             rmin=1.0/6.0
             rmax=5.0/6.0
          Case(7)
             rmin=0.25
             rmax=0.75
          Case default
             rmin=0.0
             rmax=1.0
       end select

       pt(1:ngen) = 1
       do i=1,ngen
          string=gen(i)

          !---- Test if the generator is still compatible with the crystal system
          call Read_Xsym(string,1,iRot,tr)
          if ( any((tr < rmin .and. tr > 0.0) .or. tr > rmax) ) then
             pt(i)=0
             cycle
          end if
          j=index(string,",")
          k=index(string,",",back=.true.)
          select case (Isystm)
             Case(1,2,3)  ! "Triclinic","Monoclinic","Orthorhombic"
                if (index(string(1:j),"y") /= 0 .or. index(string(1:j),"z") /= 0) pt(i)=0
                if (index(string(j:k),"x") /= 0 .or. index(string(1:j),"z") /= 0) pt(i)=0
                if (index(string(k: ),"x") /= 0 .or. index(string(1:j),"y") /= 0) pt(i)=0
             Case(4,5,6)  ! "Tetragonal","Rhombohedral","Hexagonal","Trigonal"
                if (index(string(1:k),"z") /= 0 ) pt(i)=0
                if (index(string(k: ),"x") /= 0 .or. index(string(k: ),"y") /= 0) pt(i)=0
          end select
       end do

       m=0
       do i=1,ngen
          string=gen(i)
          if (pt(i) == 1) then
             m=m+1
             gen(m)=string
          end if
       end do
       ngen=m
       if (SpG%Centred /= 1) then !the space group is centro-symmetric
          nc=SpG%NumOps+1
          Rot=SpG%SymOp(nc)%rot
          tr=SpG%SymOp(nc)%tr
          trn=matmul(Sinv,tr-matmul(e-Rot,orig)) ! matmul(Sinv,tr-2*orig)
          trn= Modulo_Lat(trn)
          if(Lattice_Trans(trn,lattsymb)) trn=(/0.0,0.0,0.0/) !Check Lattice centring

          if (.not. any((trn < rmin .and. trn > 0.0) .or. trn > rmax) ) then
             ngen=ngen+1
             call Get_SymSymb(SpG%SymOp(nc)%rot,trn,gen(ngen))
          end if

       end if

       !---- Check if non conventionnal centring vectors have been generated from
       !---- the given generators. In such a case reduce by one unit the number of
       !---- generators and restart the generation
       dob:do
          call set_spacegroup("  ",SpGn,gen,ngen,"GEN")
          do i=1,SpGn%multip
             call symmetry_symbol(SpGn%SymOp(i),string)
             string=adjustl(string)
             if (string(1:1) == "t") then
                if (lattice_trans(SpGn%SymOp(i)%tr,SpGn%SPG_lat)) cycle
                ngen=ngen-1
                cycle dob
             end if
          end do
          exit
       end do dob

       If(present(Fix_Lat)) then
          SpGn%spg_symb="From("//trim(symbsg)//") Lat:"//Fix_lat
       else
          SpGn%spg_symb="From("//trim(symbsg)//")"
       end if
       call get_HallSymb_from_gener(SpGn)
       SpGn%SG_setting=setting

       return
    End Subroutine Similar_Transf_SG


    !!----
    !!---- Subroutine Sym_B_Relations(Op/Symb,B_Ind,B_Fac)
    !!----    integer, dimension(3,3),     intent (in) :: Op      !  In  -> Rotation Matrix
    !!----    character(len=*),            intent (in) :: Symb    !  In  -> Symmetry string
    !!----
    !!----    integer, dimension(6),       intent(out) :: B_Ind   !  Out -> B Index
    !!----    real(kind=cp), dimension(6), intent(out) :: B_Fac   !  Out -> B Factor
    !!----
    !!----    Symmetry relations among coefficients of the anisotropic temperature
    !!----    factor.
    !!----
    !!----    Order for B is: B11 B22 B33 B12 B13 B23
    !!----
    !!---- Update: February - 2005
    !!

    !!--++
    !!--++ Subroutine Sym_B_Relations_Op(R,B_Ind,B_Fac)
    !!--++    integer,dimension(3,3),      intent (in) :: R
    !!--++    integer, dimension(6),       intent(out) :: B_Ind
    !!--++    real(kind=cp), dimension(6), intent(out) :: B_Fac
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Symmetry relations among coefficients of the anisotropic temperature
    !!--++    factor.
    !!--++
    !!--++    Order for B is: B11 B22 B33 B12 B13 B23
    !!--++
    !!--++    B is considered as a 6-D vector and a single 6x6 matrix RB is constructed
    !!--++    in such a way as the matrix relation  B'ij = Sum{kh}[Rik Bkh Rjh] = Bij
    !!--++    is writen as B'= RB B = B  => (RB-I) B = 0
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Sym_B_Relations_OP(R,B_Ind,B_Fac)
       !---- Arguments ----!
       integer,dimension(3,3),      intent (in) :: R
       integer, dimension(6),       intent(out) :: B_Ind
       real(kind=cp), dimension(6), intent(out) :: B_Fac

       !---- Local variables ----!
       integer, dimension(6,6) :: rb
       integer                 :: i,j,k,nvar
       integer                 :: i1,i2

       !---- Init variables ----!
       err_symm=.false.
       ERR_Symm_Mess=" "

        rb(1,1)=r(1,1)*r(1,1)
        rb(1,2)=r(2,1)*r(2,1)
        rb(1,3)=r(3,1)*r(3,1)
        rb(1,4)=2*r(1,1)*r(2,1)
        rb(1,5)=2*r(1,1)*r(3,1)
        rb(1,6)=2*r(2,1)*r(3,1)

        rb(2,1)=r(1,2)*r(1,2)
        rb(2,2)=r(2,2)*r(2,2)
        rb(2,3)=r(3,2)*r(3,2)
        rb(2,4)=2*r(1,2)*r(2,2)
        rb(2,5)=2*r(1,2)*r(3,2)
        rb(2,6)=2*r(2,2)*r(3,2)

        rb(3,1)=r(1,3)*r(1,3)
        rb(3,2)=r(2,3)*r(2,3)
        rb(3,3)=r(3,3)*r(3,3)
        rb(3,4)=2*r(1,3)*r(2,3)
        rb(3,5)=2*r(1,3)*r(3,3)
        rb(3,6)=2*r(2,3)*r(3,3)

        rb(4,1)=r(1,1)*r(1,2)
        rb(4,2)=r(2,1)*r(2,2)
        rb(4,3)=r(3,1)*r(3,2)
        rb(4,4)=r(1,1)*r(2,2)+r(1,2)*r(2,1)
        rb(4,5)=r(1,1)*r(3,2)+r(3,1)*r(1,2)
        rb(4,6)=r(2,1)*r(3,2)+r(3,1)*r(2,2)

        rb(5,1)=r(1,1)*r(1,3)
        rb(5,2)=r(2,1)*r(2,3)
        rb(5,3)=r(3,1)*r(3,3)
        rb(5,4)=r(1,1)*r(2,3)+r(2,1)*r(1,3)
        rb(5,5)=r(1,1)*r(3,3)+r(1,3)*r(3,1)
        rb(5,6)=r(2,1)*r(3,3)+r(3,1)*r(2,3)

        rb(6,1)=r(1,2)*r(1,3)
        rb(6,2)=r(2,2)*r(2,3)
        rb(6,3)=r(3,2)*r(3,3)
        rb(6,4)=r(1,2)*r(2,3)+r(2,2)*r(1,3)
        rb(6,5)=r(1,2)*r(3,3)+r(3,2)*r(1,3)
        rb(6,6)=r(2,2)*r(3,3)+r(3,2)*r(2,3)

      !---- (Rb-1) Array ----!

       do i=1,6
          rb(i,i)=rb(i,i)-1
       end do

       !---- Init Output variables ----!
       b_ind=-1
       b_fac= 0.0
       nvar = 0

       !---- Free B parameters ----!
       do i=1,6
          if (all(rb(i,:)==0)) then
             b_ind(i)=i
             b_fac(i)=1.0
             nvar=nvar+1
          end if
       end do

       do j=1,6
          if (all(rb(:,j)==0)) then
             if (b_ind(j) < 0 ) then
                b_ind(j)=j
                b_fac(j)=1.0
                nvar=nvar+1
             end if
          end if
       end do

       !---- Zero B parameters ----!
       if (nvar /= 6) then
          do i=1,6
             j=count(rb(i,:)/=0)
             if (j /= 1) cycle
             do k=1,6
                if (rb(i,k)/=0 .and. b_ind(k) < 0) then
                   b_ind(k)=k
                   nvar=nvar+1
                   exit
                end if
             end do
          end do
       end if

       !---- Other relations ----!
       if (nvar /=6) then
          do i=1,6
             j=count(rb(i,:)/=0)
             if (j /= 2) cycle
             do j=1,6
                if (rb(i,j)/=0) then
                   i1=j
                   exit
                end if
             end do
             do k=i1+1,6
                if (rb(i,k)/=0) then
                   i2=k
                   exit
                end if
             end do

             if (b_ind(i1) < 0 .and. b_ind(i2) < 0) then
                b_ind(i1)=i1
                b_ind(i2)=i1
                b_fac(i1)=1.0
                b_fac(i2)=-real(rb(i,i1))/real(rb(i,i2))
                nvar=nvar+2
             else
                if (b_ind(i1) < 0) then
                   b_fac(i1)=-real(rb(i,i2))/real(rb(i,i1))
                   b_ind(i1)=i2
                else
                   b_fac(i2)=-real(rb(i,i1))/real(rb(i,i2))
                   b_ind(i2)=i1
                end if
                nvar=nvar+1
             end if
          end do
       end if

       if (any(b_ind==-1)) then
          err_symm=.true.
          ERR_Symm_Mess="Symmetry relations in B Factors are wrong! "
       end if

       return
    End Subroutine Sym_B_Relations_OP

    !!--++
    !!--++ Subroutine Sym_B_Relations_St(Symmcar,B_Ind,B_Fac)
    !!--++    character(len=*),            intent (in) :: Symmcar
    !!--++    integer, dimension(6),       intent(out) :: B_Ind
    !!--++    real(kind=cp), dimension(6), intent(out) :: B_Fac
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Symmetry relations among coefficients of the anisotropic temperature
    !!--++    factor.
    !!--++
    !!--++    Order for B is: B11 B22 B33 B12 B13 B23
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Sym_B_Relations_ST(Symmcar,B_Ind,B_Fac)
       !---- Arguments ----!
       character(len=*),            intent (in) :: Symmcar
       integer, dimension(6),       intent(out) :: B_Ind
       real(kind=cp), dimension(6), intent(out) :: B_Fac

       !---- Local variables ----!
       integer, dimension(3,3) :: a
       real(kind=cp), dimension(3)      :: t

       call read_xsym(symmcar,1,a,t)
       call sym_b_relations_op(a,b_ind,b_fac)

       return
    End Subroutine Sym_B_Relations_ST

    !!----
    !!---- Subroutine Sym_Prod_St(Syma,Symb,Symab,Modlat)
    !!----    character(len=*),         intent (in)  :: syma
    !!----    character(len=*),         intent (in)  :: symb
    !!----    character(len=len(syma)), intent (out) :: symab
    !!----    logical, optional,        intent (in)  :: modlat
    !!----
    !!----    Obtain the symbol/Op/Matrix+trans of the  symmetry operation corresponding
    !!----    to the product of two operators given in the Jone's Faithful(symbol)
    !!----    representation or in Symmetry Operator type.
    !!--<<
    !!----     Op_a =  (Sa,ta) ;  Op_b =  (Sb,tb)
    !!----
    !!----     Op_ab =  (Sa,ta) (Sb,tb)  = (Sa Sb,  Sa tb + ta)
    !!-->>
    !!----    If modlat=.true. or it is not present, the traslation
    !!----    part of the resulting operator is reduced to have components < 1.0
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Sym_Prod_St(Syma,Symb,Symab,Modlat)
       !---- Arguments ----!
       character(len=*),         intent (in) :: syma
       character(len=*),         intent (in) :: symb
       character(len=len(syma)), intent(out) :: symab
       logical,optional,         intent (in) :: modlat

       !--- Local variables ---!
       integer, dimension (3,3)      :: Sa,Sb
       real(kind=cp),dimension (3)   :: ta,tb

       call Read_Xsym(syma,1,Sa,ta)
       call Read_Xsym(symb,1,Sb,tb)

       if(present(modlat)) then
         if(.not. modlat) then
           ta = ta + matmul(real(Sa),tb)
         else
           ta = modulo_lat(ta + matmul(real(Sa),tb))
         end if
       else
         ta = modulo_lat(ta + matmul(real(Sa),tb))
       end if
       Sa = matmul(Sa,Sb)
       call Get_symsymb(Sa,ta,symab)

       return
    End Subroutine Sym_Prod_St

    !!----
    !!---- Subroutine Symmetry_Symbol(Op,Symb), (S,T,Symb), (Symm,Symb)
    !!----    type(Sym_Oper_type),         intent (in) :: Op
    !!----
    !!----    integer, dimension(3,3),     intent (in) :: S
    !!----    real(kind=cp), dimension(3), intent (in) :: t
    !!----
    !!----    character(len=*),            intent (in) :: Symm
    !!----
    !!----    character(len=*),            intent (out):: symb
    !!----
    !!----    Obtain the symbol of the symmetry element of the operator Op
    !!----
    !!---- Update: February - 2005
    !!

    !!--++
    !!--++ Subroutine Symmetry_Symbol_Op(Op,Symb)
    !!--++    type(Sym_Oper_type), intent (in)  :: Op
    !!--++    character(len=*),    intent (out) :: symb
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Obtain the symbol of the symmetry element of the operator Op
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Symmetry_Symbol_OP(Op,symb)
       !---- Arguments ----!
       type(Sym_Oper_Type),   intent (in)  :: Op
       character(len=*),     intent (out)  :: symb

       call symmetry_symbol_str(Op%Rot,Op%tr,symb)

       return
    End Subroutine Symmetry_Symbol_OP

    !!--++
    !!--++ Subroutine Symmetry_Symbol_Str(S,T,Symb)
    !!--++    integer, dimension(3,3),     intent( in) :: s
    !!--++    real(kind=cp), dimension(3), intent( in) :: t
    !!--++    character (len=*),           intent(out) :: symb
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Obtain the symbol of the symmetry element corresponding to operator (S,T)
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Symmetry_Symbol_Str(S,T,Symb)
       !---- Arguments ----!
       integer,       dimension(3,3),    intent( in) :: s
       real(kind=cp), dimension(3),      intent( in) :: t
       character (len=*),                intent(out) :: symb

       !---- Local variables ----!
       character (len=80)      :: carsym
       character (len=1)       :: signo
       integer                 :: i, n, npos
       integer, dimension(3)   :: ix1, ix2, ix3
       integer, dimension(3,3) :: w
       integer, dimension(3,3), parameter :: identidad = reshape((/1, 0, 0, &
                                                                   0, 1, 0, &
                                                                   0, 0, 1/),(/3,3/))
       real(kind=cp)                    :: rnum
       real(kind=cp), dimension(3)      :: t0,t1,t2,t3
       real(kind=cp), dimension(3)      :: x1,x2,x3
       real(kind=cp), dimension(3)      :: p0,p1,p2,p3
       real(kind=cp), dimension(3,3)    :: ww

       !---- Initialize ----!
       symb=" "
       n=axes_rotation(s)
       !t0=mod(t+10.0_cp,1.0_cp)  !Attempt to use the given translation
       t0=t                       !of the symmetry operator
       x1 =0.0
       ix1=0
       call Init_Err_Symm()

       select case (n)
          case (1) ! Traslation or identity
             if (sum(abs(t)) <= 3.0*eps_symm) then
                symb(1:1) ="1"
             else
                symb(1:3)="t ("
                npos=4
                call get_string_resolv(t0,x1,ix1,carsym)
                symb(npos:)=carsym(1:len_trim(carsym))//")"
             end if

          case (:-3) ! Rotoinversion
             !---- Inversion point ----!
             w=s-identidad
             call resolv_sist_3x3(w,-t0,t3,x3,ix3)

             !---- Axes rotation ----!
             w=matmul(s,s)-identidad
             t1=matmul(real(s),t0)+t0
             call resolv_sist_3x3(w,-t1,t2,x2,ix2)

             !---- Sense of rotation ----!
             !---- P0, P1 ----!
             p0=0.0
             p1=1.0
             do i=1,3
                if (ix2(i) == 0) then
                   p0(i)=t2(i)
                   p1(i)=t2(i)
                else
                   p0(i)=t2(i)+x2(i)*p0(ix2(i))
                   p1(i)=t2(i)+x2(i)*p1(ix2(i))
                end if
             end do

             !---- P2 ----!
             do i=1,3
                if (p1(i) > 0.0 ) exit
             end do
             select case (i)
                case (1)
                   p2(3)=0.5*p1(3)
                   p2(2)=0.7*p1(2)
                   p2(1)=-(p2(2)*p1(2) + p2(3)*p1(3))/p1(1)

                case (2)
                   p2(1)=0.5*p1(1)
                   p2(3)=0.7*p1(3)
                   p2(2)=-(p2(1)*p1(1) + p2(3)*p1(3))/p1(2)

                case (3)
                   p2(1)=0.5*p1(1)
                   p2(2)=0.7*p1(2)
                   p2(3)=-(p2(1)*p1(1) + p2(2)*p1(2))/p1(3)
             end select
             do i=1,3
                if (abs(p2(i) - p0(i)) <= eps_symm) p2(i)=p2(i)*p2(i)+0.5*real(i)
             end do

             !---- P3 ----!
             p3=matmul(real(s),p2)+t0
             ww(1,:)=p1-p0
             ww(2,:)=p2-p0
             ww(3,:)=p3-p0
             rnum=determ_a(ww)
             if (rnum > 0.0) then
                signo="-"
             else
                signo="+"
             end if

             !---- Determine the final symbol ----!
             write(unit=symb,fmt="(i2)") n
             symb=adjustl(symb)
             npos=len_trim(symb)
             npos=npos+1
             symb(npos:npos)=signo
             npos=npos+2
             call get_string_resolv(t2,x2,ix2,carsym)
             symb(npos:)=carsym(1:len_trim(carsym))//";"
             npos=len_trim(symb)+2
             call get_string_resolv(t3,x3,ix3,carsym)
             symb(npos:)=carsym(1:len_trim(carsym))

          case (-2)  ! Reflection or glide reflection
             t1=matmul(s,t0)+t0
             if (t1(1) <= eps_symm .and. t1(2) <= eps_symm .and. &
                 t1(3) <= eps_symm) then        ! Pure Reflection

                !----Mirror Plane ----!
                w=s-identidad
                call resolv_sist_3x3(w,-t0,t3,x3,ix3)
                symb(1:2)="m "
                npos=3
                call get_string_resolv(t3,x3,ix3,carsym)
                symb(npos:)=carsym(1:len_trim(carsym))
             else                          ! Glide Reflection
                t3=0.5*t1
                w=s-identidad
                t1=t0-t3
                call resolv_sist_3x3(w,-t1,t2,x2,ix2)

                !---- Determine the final symbol ----!
                symb(1:2)="g "

                !---- a: (1/2, 0, 0) ----!
                if ( (abs(t3(1) - 0.5) <= eps_symm) .and. (abs(t3(2)) <= eps_symm) .and. &
                     (abs(t3(3)) <= eps_symm) ) then
                   symb(1:2)="a "
                end if

                !---- b: (0, 1/2, 0) ----!
                if ( (abs(t3(2) - 0.5) <= eps_symm) .and. (abs(t3(1)) <= eps_symm) .and. &
                     (abs(t3(3)) <= eps_symm) ) then
                   symb(1:2)="b "
                end if

                !---- c: (0, 0, 1/2) ----!
                if ( (abs(t3(3) - 0.5) <= eps_symm) .and. (abs(t3(2)) <= eps_symm) .and. &
                     (abs(t3(1)) <= eps_symm) ) then
                   symb(1:2)="c "
                end if

                !---- n: ( 1/2, 1/2, 0); (0, 1/2, 1/2); (1/2, 0, 1/2) ----!
                !---- n: ( 1/2, 1/2, 1/2) ----!
                !---- n: (-1/2, 1/2, 1/2); (1/2, -1/2, 1/2); (1/2, 1/2, -1/2) ----!
                if ( (abs(t3(1) - 0.5) <= eps_symm) .and. (abs(t3(2) - 0.5) <= eps_symm) .and. &
                     (abs(t3(3)) <= eps_symm) ) then
                   symb(1:2)="n "
                end if
                if ( (abs(t3(2) - 0.5) <= eps_symm) .and. (abs(t3(3) - 0.5) <= eps_symm) .and. &
                     (abs(t3(1)) <= eps_symm) ) then
                   symb(1:2)="n "
                end if
                if ( (abs(t3(1) - 0.5) <= eps_symm) .and. (abs(t3(3) - 0.5) <= eps_symm) .and. &
                     (abs(t3(2)) <= eps_symm) ) then
                   symb(1:2)="n "
                end if
                if ( (abs(t3(1) - 0.5) <= eps_symm) .and. (abs(t3(2) - 0.5) <= eps_symm) .and. &
                     (abs(t3(3) - 0.5) <= eps_symm) ) then
                   symb(1:2)="n "
                end if
                if ( (abs(t3(1) + 0.5) <= eps_symm) .and. (abs(t3(2) - 0.5) <= eps_symm) .and. &
                     (abs(t3(3) - 0.5) <= eps_symm) ) then
                   symb(1:2)="n "
                end if
                if ( (abs(t3(1) - 0.5) <= eps_symm) .and. (abs(t3(2) + 0.5) <= eps_symm) .and. &
                     (abs(t3(3) - 0.5) <= eps_symm) ) then
                   symb(1:2)="n "
                end if
                if ( (abs(t3(1) - 0.5) <= eps_symm) .and. (abs(t3(2) - 0.5) <= eps_symm) .and. &
                     (abs(t3(3) + 0.5) <= eps_symm) ) then
                   symb(1:2)="n "
                end if

                !---- d: ( 1/4,+-1/4, 0); (0, 1/4,+-1/4); (+-1/4, 0, 1/4) ----!
                !---- d: ( 1/4, 1/4,+-1/4); (+-1/4, 1/4, 1/4); (1/4,+-1/4, 1/4) ----!
                !---- d: (-1/4, 1/4,+-1/4); (+-1/4,-1/4, 1/4); (1/4,+-1/4,-1/4) ----!
                p3=t3
                p3=mod(p3+10.0_cp,1.0_cp)
                do i=1,3
                   if (p3(i) > 0.5) p3(i)=p3(i) -1.0
                end do
                if ( (abs(p3(1) - 0.25) <= eps_symm) .and. (abs(abs(p3(2)) - 0.25) <= eps_symm) .and. &
                     (abs(p3(3)) <= eps_symm) ) then
                   symb(1:2)="d "
                end if
                if ( (abs(p3(2) - 0.25) <= eps_symm) .and. (abs(abs(p3(3)) - 0.25) <= eps_symm) .and. &
                     (abs(p3(1)) <= eps_symm) ) then
                   symb(1:2)="d "
                end if
                if ( (abs(p3(3) - 0.25) <= eps_symm) .and. (abs(abs(p3(1)) - 0.25) <= eps_symm) .and. &
                     (abs(p3(2)) <= eps_symm) ) then
                   symb(1:2)="d "
                end if
                if ( (abs(p3(1) - 0.25) <= eps_symm) .and. (abs(abs(p3(3)) - 0.25) <= eps_symm) .and. &
                     (abs(p3(2) - 0.25) <= eps_symm) ) then
                   symb(1:2)="d "
                end if
                if ( (abs(p3(2) - 0.25) <= eps_symm) .and. (abs(abs(p3(1)) - 0.25) <= eps_symm) .and. &
                     (abs(p3(3) - 0.25) <= eps_symm) ) then
                   symb(1:2)="d "
                end if
                if ( (abs(p3(1) - 0.25) <= eps_symm) .and. (abs(abs(p3(2)) - 0.25) <= eps_symm) .and. &
                     (abs(p3(3) - 0.25) <= eps_symm) ) then
                   symb(1:2)="d "
                end if
                if ( (abs(p3(1) + 0.25) <= eps_symm) .and. (abs(abs(p3(3)) - 0.25) <= eps_symm) .and. &
                     (abs(p3(2) - 0.25) <= eps_symm) ) then
                   symb(1:2)="d "
                end if
                if ( (abs(p3(2) + 0.25) <= eps_symm) .and. (abs(abs(p3(1)) - 0.25) <= eps_symm) .and. &
                     (abs(p3(3) - 0.25) <= eps_symm) ) then
                   symb(1:2)="d "
                end if
                if ( (abs(p3(3) + 0.25) <= eps_symm) .and. (abs(abs(p3(2)) - 0.25) <= eps_symm) .and. &
                     (abs(p3(1) - 0.25) <= eps_symm) ) then
                   symb(1:2)="d "
                end if
                npos=3

                !---- Glide Part ----!
                if ( symb(1:1) == "n" .or. symb(1:1) == "d" .or. &
                     symb(1:1) == "g" ) then
                   symb(npos:)="("
                   npos=npos+1
                   x1 =0.0
                   ix1=0
                   call get_string_resolv(t3,x1,ix1,carsym)
                   symb(npos:)=carsym(1:len_trim(carsym))//")"
                   npos=len_trim(symb)+2
                end if

                !---- Location of Glide Plane ----!
                call get_string_resolv(t2,x2,ix2,carsym)
                symb(npos:)=carsym(1:len_trim(carsym))
             end if

          case (-1)  ! Inversion
             t1=0.5*t0
             symb(1:3)="-1 "
             npos=4
             x1 =0.0
             ix1=0
             call get_string_resolv(t1,x1,ix1,carsym)
             symb(npos:)=carsym(1:len_trim(carsym))

          case (2:)  ! Rotation / Screw Rotation
             w=identidad
             t1=t0
             do i=1,n-1
                w=matmul(w,s)
                t1=t1+matmul(w,t0)
             end do
             if (abs(t1(1)) <= eps_symm .and. abs(t1(2)) <= eps_symm &
                 .and. abs(t1(3)) <= eps_symm) then              ! Pure rotation

                !---- Rotations axes ----!
                w=s-identidad
                call resolv_sist_3x3(w,-t0,t2,x2,ix2)

                !---- Sense of rotation ----!
                !---- P0, P1 ----!
                p0=0.0
                p1=1.0
                do i=1,3
                   if (ix2(i) == 0) then
                      p0(i)=t2(i)
                      p1(i)=t2(i)
                   else
                      p0(i)=t2(i)+x2(i)*p0(ix2(i))
                      p1(i)=t2(i)+x2(i)*p1(ix2(i))
                   end if
                end do

                !---- P2 ----!
                do i=1,3
                   if (p1(i) > 0.0 ) exit
                end do
                select case (i)
                   case (1)
                      p2(3)=0.5*p1(3)
                      p2(2)=0.7*p1(2)
                      p2(1)=-(p2(2)*p1(2) + p2(3)*p1(3))/p1(1)

                   case (2)
                      p2(1)=0.5*p1(1)
                      p2(3)=0.7*p1(3)
                      p2(2)=-(p2(1)*p1(1) + p2(3)*p1(3))/p1(2)

                   case (3)
                      p2(1)=0.5*p1(1)
                      p2(2)=0.7*p1(2)
                      p2(3)=-(p2(1)*p1(1) + p2(2)*p1(2))/p1(3)
                end select
                do i=1,3
                   if (abs(p2(i) - p0(i)) <= eps_symm) p2(i)=p2(i)*p2(i)+0.5*real(i)
                end do

                !---- P3 ----!
                p3=matmul(real(s),p2)+t0
                ww(1,:)=p1-p0
                ww(2,:)=p2-p0
                ww(3,:)=p3-p0

                rnum=determ_a(ww)
                if (rnum > 0.0) then
                   signo="+"
                else
                   signo="-"
                end if

                !---- Determine the final symbol ----!
                write(unit=symb,fmt="(i2)") n
                symb=adjustl(symb)
                npos=len_trim(symb)
                if ( n /= 2) then
                   npos=npos+1
                   symb(npos:)=signo
                end if
                npos=npos+2
                call get_string_resolv(t2,x2,ix2,carsym)
                symb(npos:)=carsym(1:len_trim(carsym))
             else                     ! Screw Rotation
                t3=(1.0/real(n))*t1
                w=s-identidad
                t1=t0-t3
                call resolv_sist_3x3(w,-t1,t2,x2,ix2)

                !---- Sense of rotation ----!
                !---- P0, P1 ----!
                p0=0.0
                p1=1.0
                do i=1,3
                   if (ix2(i) == 0) then
                      p0(i)=t2(i)
                      p1(i)=t2(i)
                   else
                      p0(i)=t2(i)+x2(i)*p0(ix2(i))
                      p1(i)=t2(i)+x2(i)*p1(ix2(i))
                   end if
                end do

                !---- P2 ----!
                do i=1,3
                   if (p1(i) > 0.0 ) exit
                end do
                select case (i)
                   case (1)
                      p2(3)=0.5*p1(3)
                      p2(2)=0.7*p1(2)
                      p2(1)=-(p2(2)*p1(2) + p2(3)*p1(3))/p1(1)

                   case (2)
                      p2(1)=0.5*p1(1)
                      p2(3)=0.7*p1(3)
                      p2(2)=-(p2(1)*p1(1) + p2(3)*p1(3))/p1(2)

                   case (3)
                      p2(1)=0.5*p1(1)
                      p2(2)=0.7*p1(2)
                      p2(3)=-(p2(1)*p1(1) + p2(2)*p1(2))/p1(3)
                end select
                do i=1,3
                   if (abs(p2(i) - p0(i)) <= eps_symm) p2(i)=p2(i)*p2(i)+0.5*real(i)
                end do

                !---- P3 ----!
                p3=matmul(real(s),p2)+t0
                ww(1,:)=p1-p0
                ww(2,:)=p2-p0
                ww(3,:)=p3-p0
                rnum=determ_a(ww)
                if (rnum > 0.0) then
                   signo="+"
                else
                   signo="-"
                end if

                !---- Determine the final symbol ----!
                write(unit=symb,fmt="(i2)") n
                symb=adjustl(symb)
                npos=len_trim(symb)
                if ( n /= 2) then
                   npos=npos+1
                   symb(npos:npos)=signo
                end if
                npos=npos+2

                !---- Screw Part ----!
                symb(npos:)="("
                npos=npos+1
                x1 =0.0
                ix1=0
                call get_string_resolv(t3,x1,ix1,carsym)
                symb(npos:)=carsym(1:len_trim(carsym))//")"
                npos=len_trim(symb)+2
                call get_string_resolv(t2,x2,ix2,carsym)
                symb(npos:)=carsym(1:len_trim(carsym))
             end if

       end select

       return
    End Subroutine Symmetry_Symbol_Str

    !!--++
    !!--++ Subroutine Symmetry_Symbol_Xyz(Symm,Symb)
    !!--++    character(len=*), intent (in)  :: symm
    !!--++    character(len=*), intent (out) :: symb
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Obtain the symbol of the  symmetry element corresponding
    !!--++    to an operator given in the Jone's Faithful representation
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Symmetry_Symbol_Xyz(Symm,Symb)
       !---- Arguments ----!
       character(len=*), intent (in)  :: symm
       character(len=*), intent (out) :: symb

       !--- Local variables ---!
       integer, dimension (3,3)      :: s
       real(kind=cp),    dimension (3)        :: t

       call Read_Xsym(symm,1,s,t)
       call symmetry_symbol_str(s,t,symb)

       return
    End Subroutine Symmetry_Symbol_Xyz

    !!----
    !!---- Subroutine Write_Bin_Spacegroup(SpG,Lun)
    !!----    type (Space_Group),  intent(in)  :: SpG   !  In -> SpaceGroup Variable
    !!----    integer,             intent(in)  :: Lun   !  In -> Logical unit of the file
    !!----
    !!----    Writing in file of logical unit "lun" the full structure of Space_Group_Type, SpG
    !!----    The file should have been opened with the access="stream" attribute. The procedure
    !!----    writes in the given order a series of bytes corresponding to the components of the
    !!----    type SpG. For reading back a Space Group structure from a binary file the subroutine
    !!----    Read_Bin_Spacegroup has to be used.
    !!----
    !!---- Update: February - 2013
    !!
    Subroutine Write_Bin_SpaceGroup(SpG,lun)
       !---- Arguments ----!
       type (Space_Group_Type),intent(in) :: SpG
       integer,                intent(in) :: lun

       !---- Local variables ----!
       integer                           :: i,j

       !---- Writing variables ----!
       write(unit=Lun) SpG%NumSpg,        &   ! Number of the Space Group
                       SpG%SPG_Symb,      &   ! Hermann-Mauguin Symbol
                       SpG%Hall,          &   ! Hall symbol
                       SpG%CrystalSys,    &   ! Crystal system
                       SpG%Laue,          &   ! Laue Class
                       SpG%PG,            &   ! Point group
                       SpG%Info,          &   ! Extra information
                       SpG%SG_setting,    &   ! Information about the SG setting (IT,KO,ML,ZA,Table,Standard,UnConventional)
                       SpG%Hexa,          &   !
                       SpG%SPG_lat,       &   ! Lattice type
                       SpG%SPG_latsy,     &   ! Lattice type Symbol
                       SpG%NumLat,        &   ! Number of lattice points in a cell
                       SpG%Latt_trans,    &   ! Lattice translations
                       SpG%Bravais,       &   ! String with Bravais symbol + translations
                       SpG%Centre,        &   ! Alphanumeric information about the center of symmetry
                       SpG%Centred,       &   ! Centric or Acentric [ =0 Centric(-1 no at origin),=1 Acentric,=2 Centric(-1 at origin)]
                       SpG%Centre_coord,  &   ! Fractional coordinates of the inversion centre
                       SpG%NumOps,        &   ! Number of reduced set of S.O.
                       SpG%Multip,        &   ! Multiplicity of the general position
                       SpG%Num_gen            ! Minimum number of operators to generate the Group
       do i=1,SpG%Multip
         write(unit=Lun) SpG%SymOp(i)%Rot,SpG%SymOp(i)%tr ! Symmetry operators
         write(unit=Lun) SpG%SymopSymb(i)                 ! Strings form of symmetry operators
       end do
       write(unit=Lun) SpG%R_Asym_Unit                    ! Asymmetric unit in real space
       write(unit=Lun) SpG%Wyckoff%num_orbit              ! Wyckoff Information
       do i=1,SpG%Wyckoff%num_orbit
         write(unit=Lun) SpG%Wyckoff%orbit(i)%norb
         write(unit=Lun) SpG%Wyckoff%orbit(i)%str_Orig
         do j=1,SpG%Wyckoff%orbit(i)%norb
           write(unit=Lun) SpG%Wyckoff%orbit(i)%str_orbit(j)
         end do
       end do
       return
    End Subroutine Write_Bin_SpaceGroup

    !!----
    !!---- Subroutine Write_Spacegroup(Spacegroup,Iunit,Full)
    !!----    type (Space_Group),  intent(in)  :: SpaceGroup !  In -> SpaceGroup Variable
    !!----    integer,  optional,  intent(in)  :: iunit      !  In -> Write information on Iunit
    !!----    logical,  optional,  intent(in)  :: full       !  In -> Full operator or not
    !!----
    !!----    Writing in file of logical unit "lun" the characteristics of
    !!----    the space group "SpaceG". Part of the information contained
    !!----    in  SpaceGroup may be undefined, depending on the tabulated
    !!----    nature of the item. If full=.true. is present the whole group
    !!----    is output including the symmetry symbol associated to each
    !!----    operator.
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Write_SpaceGroup(SpaceGroup,Iunit,Full)
       !---- Arguments ----!
       type (Space_Group_Type),intent(in) :: SpaceGroup
       integer,   optional,    intent(in) :: iunit
       logical,   optional,    intent(in) :: full

       !---- Local variables ----!
       integer,  parameter                      :: max_lines=192
       character (len=100), dimension(max_lines):: texto
       character (len=40)                       :: aux
       integer                                  :: lun
       integer                                  :: i, nlines
       logical                                  :: print_latt

       !---- Initializing variables ----!
       lun=6
       print_latt=.false.
       if (present(iunit)) lun=iunit
       if (present(full))  print_latt=.true.

       !---- Printing ----!
       write(unit=lun,fmt="(/,/,a)")          "        Information on Space Group: "
       write(unit=lun,fmt="(a,/ )")           "        --------------------------- "
       write(unit=lun,fmt="(a,i3)")          " =>   Number of Space group: ", SpaceGroup%NumSpg
       write(unit=lun,fmt="(a,a)")           " =>  Hermann-Mauguin Symbol: ", trim(SpaceGroup%SPG_Symb)
       write(unit=lun,fmt="(a,a)")           " =>             Hall Symbol: ", trim(SpaceGroup%Hall)
       if(len_trim(SpaceGroup%gHall) > 1) &
       write(unit=lun,fmt="(a,a)")           " => Generalized Hall Symbol: ", trim(SpaceGroup%gHall)
       if(len_trim(SpaceGroup%info) > 1) &
       write(unit=lun,fmt="(a,a)")           " =>    Table Setting Choice: ", trim(SpaceGroup%info)
       write(unit=lun,fmt="(a,a)")           " =>            Setting Type: ", trim(SpaceGroup%SG_setting)

       write(unit=lun,fmt="(a,a)")           " =>          Crystal System: ", trim(SpaceGroup%CrystalSys)
       write(unit=lun,fmt="(a,a)")           " =>              Laue Class: ", trim(SpaceGroup%Laue)
       write(unit=lun,fmt="(a,a)")           " =>             Point Group: ", trim(SpaceGroup%Pg)

       write(unit=lun,fmt="(a,a)")           " =>         Bravais Lattice: ", trim(SpaceGroup%SPG_Lat)
       write(unit=lun,fmt="(a,a)")           " =>          Lattice Symbol: ", trim(SpaceGroup%SPG_Latsy)

       write(unit=lun,fmt="(a,i3)")          " =>  Reduced Number of S.O.: ", SpaceGroup%NumOps
       write(unit=lun,fmt="(a,i3)")          " =>    General multiplicity: ", SpaceGroup%Multip
       write(unit=lun,fmt="(a,a)")           " =>          Centrosymmetry: ", trim(SpaceGroup%Centre)
       write(unit=lun,fmt="(a,i3)")          " =>  Generators (exc. -1&L): ", SpaceGroup%num_gen
       write(unit=lun,fmt="(a,f6.3,a,f6.3)") " =>         Asymmetric unit: ", SpaceGroup%R_Asym_Unit(1,1), &
                                                                  " <= x <= ",SpaceGroup%R_Asym_Unit(1,2)
       write(unit=lun,fmt="(a,f6.3,a,f6.3)") "                             ", SpaceGroup%R_Asym_Unit(2,1), &
                                                                  " <= y <= ",SpaceGroup%R_Asym_Unit(2,2)
       write(unit=lun,fmt="(a,f6.3,a,f6.3)") "                             ", SpaceGroup%R_Asym_Unit(3,1), &
                                                                  " <= z <= ",SpaceGroup%R_Asym_Unit(3,2)

       if (SpaceGroup%centred == 0) then
          call Frac_Trans_1Dig(SpaceGroup%Centre_coord,texto(1))
          write(unit=lun,fmt="(a,a)")        " =>               Centre at: ", trim(texto(1))
       end if
       if (SpaceGroup%SPG_Lat == "Z" .or. print_latt) then
          texto(:) (1:100) = " "
          if (SpaceGroup%SPG_Lat == "Z") then
            write(unit=lun,fmt="(a,i3)")          " => Non-conventional Centring vectors:",SpaceGroup%Numlat
          else
            write(unit=lun,fmt="(a,i3)")          " => Centring vectors:",SpaceGroup%Numlat-1
          end if
          nlines=1
          do i=2,SpaceGroup%Numlat
             call Frac_Trans_1Dig(SpaceGroup%Latt_trans(:,i),aux)
             if (mod(i-1,2) == 0) then
                write(unit=texto(nlines)(51:100),fmt="(a,i2,a,a)") &
                                           " => Latt(",i-1,"): ",trim(aux)
                nlines=nlines+1
             else
                write(unit=texto(nlines)( 1:50),fmt="(a,i2,a,a)")  &
                                           " => Latt(",i-1,"): ",trim(aux)
             end if
          end do
          do i=1,nlines
             write(unit=lun,fmt="(a)") texto(i)
          end do
       end if

       !---- Symmetry Operators ----!
       if (present(full)) then
          write(unit=lun,fmt="(/,a,/)")        " => List of all Symmetry Operators and Symmetry Symbols"

          do i=1,SpaceGroup%Multip
             texto(1)=" "
             call Symmetry_Symbol(SpaceGroup%SymopSymb(i),texto(1))
             write(unit=lun,fmt="(a,i3,2a,t50,2a)") " => SYMM(",i,"): ",trim(SpaceGroup%SymopSymb(i)), &
                                                     "Symbol: ",trim(texto(1))
          end do

          !---- Wyckoff Information ----!
          call Write_Wyckoff(SpaceGroup%Wyckoff, SpaceGroup%SPG_Symb,lun)

       else
          write(unit=lun,fmt="(/,a)") " => List of S.O. without inversion and lattice centring translations"

          texto(:) (1:100) = " "
          nlines=1
          do i=1,SpaceGroup%NumOps
             if (mod(i,2) == 0) then
                write(unit=texto(nlines)(51:100),fmt="(a,i3,a,a)") &
                                           " => SYMM(",i,"): ",trim(SpaceGroup%SymopSymb(i))
                nlines=nlines+1
             else
                write(unit=texto(nlines)( 1:50),fmt="(a,i3,a,a)")  &
                                           " => SYMM(",i,"): ",trim(SpaceGroup%SymopSymb(i))
             end if
             if(nlines == max_lines) then
                texto(nlines)=trim(texto(nlines))//"   <= Maximum number of lines exhausted!"
                exit
             end if
          end do
          do i=1,nlines
             write(unit=lun,fmt="(a)") trim(texto(i))
          end do

       end if


       return
    End Subroutine Write_SpaceGroup

    !!----
    !!---- Subroutine Write_Sym(Lun,Indx,Sim,Tt,P_Mag,Mag)
    !!----    integer,                     intent(in) :: lun       !  In -> Logical unit of the file to write
    !!----    integer,dimension(3,3),      intent(in) :: sim       !  In -> Rotational part of the S.O.
    !!----    integer,                     intent(in) :: indx      !  In -> Ordinal of the current Symm.Operator
    !!----    real(kind=cp), dimension(3), intent(in) :: tt        !  In -> Translation part of the S.O.
    !!----    real(kind=cp),               intent(in) :: p_mag     !  In -> Magnetic phase of the magnetic S.O.
    !!----    logical,                     intent(in) :: mag       !  In -> .true. if it is a magnetic S.O.
    !!----
    !!----    Writing the reduced set of symmetry operators
    !!----    Logical hexa must be defined (valid for conventional bases)
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Write_Sym(Lun,Indx,Sim,Tt,P_Mag,Mag)
       !---- Arguments ----!
       integer,                     intent(in) :: lun,indx
       integer, dimension(3,3),     intent(in) :: sim
       real(kind=cp), dimension(3), intent(in) :: tt
       real(kind=cp),               intent(in) :: p_mag
       logical,                     intent(in) :: mag

       !---- Local variables ----!
       character (len=35)             :: symcod
       character (len=40)             :: Seitz_symb
       integer                        :: j,ihex,i1,i2,isl

       if (.not. hexa) then
          i1=1
          i2=24
       else
          i1=25
          i2=36
       end if
       call SearchOp(sim,i1,i2,Isl)
       call Get_SymSymb(sim,tt,Symcod)

       if (hexa) then
          j=abs(isl)-24
          if(Isl < 0) j=j+12
          call  Get_Seitz(j,tt,Seitz_symb)
          write(unit=lun,fmt="(i4,4(a,a))") indx," :: ",trim(IntSymD6h(j))," :: ", &
                                      trim(Kov_D6h(j))," :: ",trim(SymCod)," :: ",trim(Seitz_symb)

          if (mag) then
             j=abs(isl)-24
             ihex=2
             if (j < 0) then
                j=j+24
                ihex=1
             end if
             if (isl < 0) j=j+24/ihex
             write(unit=lun,fmt="(a,i2,a,a19,a,f12.4)") "      (",indx,"): ",  &
                                                  MAGmat(J+(ihex-1)*48)," MPhas: ",P_MAG
          end if

       else              ! No hexa
          j=abs(isl)
          if (isl < 0) j=j+24
          call  Get_Seitz(j,tt,Seitz_symb)
          write(unit=lun,fmt="(i4,4(a,a))") indx," :: ",trim(IntSymOh(j))," :: ", &
                                      trim(Kov_Oh(j))," :: ",trim(SymCod)," :: ",trim(Seitz_symb)
          if (mag) then
             j=abs(isl)
             if (isl < 0) j=j+24
             write(unit=lun,fmt="(a,i2,a,a13,a,f12.4)") "      (",indx,"): ",   &
                                                  MAGmat(J)," MPhas: ",P_MAG
          end if
       end if            ! End if(Hexa)

       return
    End Subroutine Write_Sym

    !!----
    !!---- Subroutine Write_SymTrans_Code(N,Tr,Code)
    !!----    integer,                    intent(in)  :: N
    !!----    real(kind=cp),dimension(3), intent(in)  :: Tr
    !!----    character (len=*),          intent(out) :: Code
    !!----
    !!----    Write the code string for reference the symmetry operator and the
    !!----    Traslation applied.
    !!--<<        _2.555     : N_Op = 2, Tr=( 0.0, 0.0, 0.0)
    !!----        _3.456     : N_Op = 3, Tr=(-1.0, 0.0, 1.0)
    !!-->>
    !!----
    !!---- Update: April - 2005
    !!
    Subroutine Write_SymTrans_Code(N,Tr,Code)
       !---- Arguments ----!
       integer,                    intent(in)  :: N
       real(kind=cp),dimension(3), intent(in)  :: Tr
       character (len=*),          intent(out) :: Code

       !---- Local Variables ----!
       character(len=3)      :: car
       integer, dimension(3) :: i

       Code=" "
       if (N <=0) return
       car="   "
       !---- Number of the Symmetry Operator ----!
       write(unit=car,fmt="(i3)") n
       car=adjustl(car)
       Code="_"//trim(car)
       car="   "
       !---- Traslation Part ----!
       i=5+nint(tr)
       if (any(i /= 5)) then
          write(unit=car(1:1),fmt="(i1)") i(1)
          write(unit=car(2:2),fmt="(i1)") i(2)
          write(unit=car(3:3),fmt="(i1)") i(3)
          code=trim(code)//"."//trim(car)
       else
          if(len_trim(code)==2 .and. code(2:2) == "1") Code=" "
       end if


       return
    End Subroutine Write_SymTrans_Code

    !!----
    !!---- Subroutine Write_Wyckoff(Wyckoff,Spg_Name,Lun, Sorting)
    !!----    type(wyckoff_type), intent(in) :: Wyckoff     !  In -> Wyckoff Type variable
    !!----    character(len=*),   intent(in) :: Spg_Name    !  In -> SpaceGroup Name
    !!----    integer,optional,   intent(in) :: Lun         !  In -> Unit to write the information
    !!----    logical, optional,  intent(in) :: Sorting     !  In -> .true. for sorting list
    !!----
    !!----    Print/Write the Wyckoff positions in Lun unit
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Write_Wyckoff(Wyckoff,Spg, Lun, Sorting)
       !---- Arguments ----!
       type(wyckoff_type), intent(in) :: wyckoff
       character(len=*),   intent(in) :: Spg
       integer, optional,  intent(in) :: Lun
       logical, optional,  intent(in) :: Sorting

       !---- Local variables ----!
       character(len=3)      :: carm
       character(len=12)     :: site
       integer               :: i,j,iunit
       integer,dimension(26) :: list,order
       character(len=*), dimension(26),parameter :: alphabet = (/  &
       "a","b","c","d","e","f","g","h","i","j","k","l","m","n","o","p","q","r","s","t","u","v","w","x","y","z"/)

       if (wyckoff%num_orbit == 0) return
       iunit=6
       if (present(lun)) iunit=lun

       !---- Sorting the final Wyckoff List ----!
       do i=1, wyckoff%num_orbit
          list(i)=wyckoff%orbit(i)%norb
          order(i)=i
       end do

       if (present(sorting)) then
          if (sorting) call sort(list,wyckoff%num_orbit,order)
       end if

       !---- Info ----!
       write(unit=iunit,fmt="(/,a)") " => Special Wyckoff Positions for "//trim(spg)
       write(unit=iunit,fmt="(a)") " "
       write(unit=iunit,fmt="(a)") "    Multp     Site        Representative Coordinates (centring translations excluded)"
       do i=wyckoff%num_orbit,1,-1
          write(unit=carm,fmt="(i3)") wyckoff%orbit(order(i))%multp
          site=alphabet(i)
          do j=1,wyckoff%orbit(order(i))%norb,3
             write(unit=iunit,fmt="(a,a,t15,a,t30,a,t50,a,t70,a)") "    ",&
                   carm,site,wyckoff%orbit(order(i))%str_orbit(j:j+2)
             carm=" "
             site=" "
          end do
          write(unit=iunit,fmt="(a)") " "
       end do

       return
     End Subroutine Write_Wyckoff

    !!----
    !!---- Subroutine Wyckoff_Orbit(Spacegroup,Wyckoffstr,N_Orbit,Orbitstr)
    !!----    type (Space_Group_Type),       intent( in) :: SpaceGroup !  In -> SpaceGroup Variable
    !!----    character(len=*),              intent( in) :: WyckoffStr !  In -> Representative of the Orbit
    !!----    integer,                       intent(out) :: N_Orbit    ! Out -> Number of Components in the Orbit
    !!----    character(len=*),dimension(:), intent(out) :: OrbitStr   ! Out -> Wyckoff Positions Strings
    !!----
    !!----    Calculation of the Wyckoff positions from the representative element
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Wyckoff_Orbit(SGrp,Wyckoff_Car, N, Wyckoff_Orb)
       !---- Arguments ----!
       type (Space_Group_Type),        intent( in) :: SGrp           !  In -> Space Group Information
       character(len=*),               intent( in) :: Wyckoff_Car    !  In -> Representative of the Orbit to calculate
       integer,                        intent(out) :: N              ! Out -> Number of components in the orbit
       character(len=*),dimension(:),  intent(out) :: Wyckoff_Orb    ! Out -> Wyckoff positions for this Orbit

       !---- Local Variables ----!
       logical                         :: delete
       character(len=40)               :: symb,symb2
       integer                         :: i,j,k,num
       integer,dimension(3,3)          :: w
       real(kind=cp),   dimension(3,3) :: w1
       real(kind=cp), dimension(3)     :: t,t1,t2

       Wyckoff_Orb=" "
       n=0
       if (len_trim(wyckoff_car) <= 0) return

       n=1
       wyckoff_orb(n)=adjustl(wyckoff_car)
       call Read_Xsym(wyckoff_car,1,w,t)
       err_symm=.false.

       num=sgrp%multip/sgrp%numlat

       do i=2,num
          w1=real(sgrp%symop(i)%rot)
          t1=sgrp%symop(i)%tr
          t1=applyso(sgrp%symop(i),t)
          t1=mod(t1+10.0_cp,1.0_cp)
          w1=matmul(w1,real(w))
          call Get_SymSymb(w1,t1,symb)
          delete=.false.
          do j=1,n
             if (symb == wyckoff_orb(j)) then
                delete=.true.
                exit
             end if
          end do
          if (delete) cycle

          !---- Lattice Contribution ----!
          do j=2,sgrp%numlat
             t2=t1+sgrp%latt_trans(:,j)
             t2=mod(t2+10.0_cp,1.0_cp)
             call Get_SymSymb(w1,t2,symb2)
             delete=.false.
             do k=1,n
                if (symb2 == wyckoff_orb(k)) then
                   delete=.true.
                   exit
                end if
             end do
             if (delete) exit
          end do
          if (delete) cycle

          n=n+1
          wyckoff_orb(n)=adjustl(symb)
       end do

       return
    End Subroutine Wyckoff_Orbit

    Subroutine Copy_NS_SpG_To_SpG(SpGN,SpG)
       !---- Arguments ----!
       type(NS_Space_Group_type), intent(in)    :: SpGN
       type(Space_Group_type),    intent(out)   :: SpG

       !---- Local Variables ----!
       logical              :: change
       integer              :: i,j,k
       real, dimension(3,3) :: w

       !> Init
       call init_err_symm()
       change=.true.

       !> Check if the copy is possible
       loop_1: do k=1,SpG%Multip
          w=SpGn%Symop(k)%Rot
          w=abs(w)*100.0
          do i=1,3
             do j=1,3
                if (w(i,j) > 0.5 .and. w(i,j) < 99.5) then
                   change=.false.
                   exit loop_1
                end if
             end do
          end do
       end do loop_1

       if (.not. change) then
          err_symm=.true.
          ERR_Symm_Mess="No copy was possible for SpgN to Spg "
          return
       end if

       SpG%NumSpg      = SpGn%NumSpg
       SpG%SPG_Symb    = SpGn%SPG_Symb
       SpG%Hall        = SpGn%Hall
       SpG%gHall       = SpGn%gHall
       SpG%CrystalSys  = SpGn%CrystalSys
       SpG%Laue        = SpGn%Laue
       SpG%PG          = SpGn%PG
       SpG%Info        = SpGn%Info
       SpG%SG_setting  = SpGn%SG_setting
       SpG%SPG_lat     = SpGn%SPG_lat
       SpG%SPG_latsy   = SpGn%SPG_latsy
       SpG%NumLat      = SpGn%NumLat
       if(allocated(SpG%Latt_Trans)) deallocate(SpG%Latt_Trans)
       allocate(SpG%Latt_Trans(3,SpG%NumLat))
       SpG%Latt_Trans  = SpGn%Latt_Trans
       SpG%Bravais     = SpGn%Bravais
       SpG%Centre      = SpGn%Centre
       SpG%Centred     = SpGn%Centred
       SpG%Centre_coord= SpGn%Centre_coord
       SpG%NumOps      = SpGn%NumOps
       SpG%Multip      = SpGn%Multip
       SpG%Num_gen     = SpGn%Num_gen
       if(allocated(SpG%SymopSymb)) deallocate(SpG%SymopSymb)
       allocate(SpG%SymopSymb(SpG%Multip))
       SpG%SymopSymb=SpGn%SymopSymb
       if(allocated(SpG%Symop)) deallocate(SpG%Symop)
       allocate(SpG%Symop(SpG%Multip))
       do i=1,SpG%Multip
         SpG%Symop(i)%Rot(:,:) = nint(SpGn%Symop(i)%Rot(:,:))
         SpG%Symop(i)%tr(:) =  SpGn%Symop(i)%tr(:)
       end do

       return
    End Subroutine Copy_NS_SpG_To_SpG

 End Module CFML_Crystallographic_Symmetry
!!-------------------------------------------------------
!!---- Crystallographic Fortran Modules Library (CrysFML)
!!-------------------------------------------------------
!!---- The CrysFML project is distributed under LGPL. In agreement with the
!!---- Intergovernmental Convention of the ILL, this software cannot be used
!!---- in military applications.
!!----
!!---- Copyright (C) 1999-2012  Institut Laue-Langevin (ILL), Grenoble, FRANCE
!!----                          Universidad de La Laguna (ULL), Tenerife, SPAIN
!!----                          Laboratoire Leon Brillouin(LLB), Saclay, FRANCE
!!----
!!---- Authors: Juan Rodriguez-Carvajal (ILL)
!!----          Javier Gonzalez-Platas  (ULL)
!!----
!!---- Contributors: Laurent Chapon     (ILL)
!!----               Marc Janoschek     (Los Alamos National Laboratory, USA)
!!----               Oksana Zaharko     (Paul Scherrer Institute, Switzerland)
!!----               Tierry Roisnel     (CDIFX,Rennes France)
!!----               Eric Pellegrini    (ILL)
!!----
!!---- This library is free software; you can redistribute it and/or
!!---- modify it under the terms of the GNU Lesser General Public
!!---- License as published by the Free Software Foundation; either
!!---- version 3.0 of the License, or (at your option) any later version.
!!----
!!---- This library is distributed in the hope that it will be useful,
!!---- but WITHOUT ANY WARRANTY; without even the implied warranty of
!!---- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
!!---- Lesser General Public License for more details.
!!----
!!---- You should have received a copy of the GNU Lesser General Public
!!---- License along with this library; if not, see <http://www.gnu.org/licenses/>.
!!----
!!----
!!---- MODULE: CFML_Crystal_Metrics
!!----   INFO: Module to define crystallographic types and to provide
!!----         automatic crystallographic operations.
!!----
!!---- HISTORY
!!----    Update: 05/03/2011
!!----
!!--.. INFORMATION
!!--..
!!--..    List Of Matrix Relationships For Crystallographic Applications
!!--..
!!--..    Small "t" is for transpose, inv(F) is the inverse of matrix F
!!--..
!!--..    Basis vectors as symbolic matrices
!!--..       At = (a,b,c)  At'=(a',b',c') ;  At* = (a*,b*,c*)  At*'=(a*',b*',c*')
!!--..
!!--..    Direct and reciprocal metric tensors: G, G*=inv(G)
!!--..    X  column vector in     direct space, referred to basis A
!!--..    X* column vector in reciprocal space, referred to basis A*
!!--..
!!--..       A'  = M  A           X'  = inv(Mt) X
!!--..       A*  = G* A           X*  =   G     X
!!--..       A*' = inv(Mt) A*     X*' =   M     X*
!!--..
!!--..       G' = M G Mt          G*' = inv(Mt) G* inv(M)
!!--..
!!--..   Symmetry operator defined in bases: A, A', A*, A*'
!!--..       C = (R,T), C'= (R',T'), C*= (R*,T*), C*'= (R*',T*')
!!--..
!!--..       R'  = inv(Mt) R Mt  ; T' = inv(Mt) T
!!--..       R*' =  M  R* inv(M) ; T*' = M T*
!!--..       R*  = G R G*  = inv(Rt)
!!--..
!!--..   If a change of origin is performed the positions are changed
!!--..   Ot=(o1,o2,o3) origin of the new basis A' w.r.t. old basis A
!!--..
!!--..       X' = inv(Mt) (X-O)
!!--..
!!--..   Changing just the origin   Xn  = C  X  = R  X  + T
!!--..                              Xn' = C' X' = R' X' + T'
!!--..          R=R'                X'  = X -O
!!--..                              Xn' = Xn-O
!!--..                  Xn-O = R' (X-O) + T' = R X + T - O
!!--..                   R X - R O + T' = R X + T - O
!!--..                               T' = T - (O - R O) = T - (E-R)O
!!--..
!!--..   Changing the basis (A,o) -> (A',o')
!!--..                  Xn  = C  X  = R  X  + T
!!--..                  Xn' = C' X' = R' X' + T'
!!--..                  X'= inv(Mt) (X-O), Xn' = inv(Mt) (Xn-O)
!!--..
!!--..            inv(Mt) (Xn-O) = R' inv(Mt) (X-O) + T'
!!--..            inv(Mt) (R  X  + T -O) = R' inv(Mt) (X-O) + T'
!!--..            inv(Mt) R X + inv(Mt)(T-O) = R' inv(Mt) X - R' inv(Mt) O + T'
!!--..            inv(Mt) R = R' inv(Mt)  => R' = inv(Mt) R Mt
!!--..            inv(Mt) (T-O)  = - R' inv(Mt) O + T'
!!--..            T' = R' inv(Mt) O + inv(Mt) (T-O)
!!--..            T' = inv(Mt) R Mt inv(Mt) O + inv(Mt) (T-O)
!!--..            T' = inv(Mt) R  O + inv(Mt) (T-O)
!!--..            T' = inv(Mt) R  O + inv(Mt) T - inv(Mt) O
!!--..            T' = inv(Mt)( R  O + T -  O) = inv(Mt) (T -(E-R)O)
!!--..
!!--..
!!--..                       R' = inv(Mt) R Mt
!!--..
!!--..                       T' = inv(Mt) (T -(E-R)O)
!!--..
!!--..
!!--..   A symmetry operator does not change the modulus of vectors and
!!--..   the angles between vectors (dot product is invariant):
!!--..
!!--..      X' = R X ,  Y' = R Y  =>  Xt' = Xt Rt,  Yt' = Yt Rt
!!--..
!!--..      Xt' G Y' = Xt Rt G R Y = Xt G Y  =>  G = Rt G R
!!--..
!!--..
!!--..   Second rank tensor Q and Q* defined in bases A and A*.
!!--..
!!--..      Q' = M Q Mt      Q* = G* Q G*     Q*'= inv(Mt) Q* inv(M)
!!--..
!!--..   A symmetry operator R is equivalent to a transformation
!!--..   M = inv(Rt) acting on basis vectors => G' = inv(Rt) G inv(R) = G
!!--..   The anisotropic temperature factors Beta is defined in reciprocal
!!--..   space: is a tensor like Q*, the transformation of beta under
!!--..   a symmetry operator is then :
!!--..
!!--..           Beta' = Inv(Mt) Beta inv(M) = R Beta Rt
!!--..
!!----
!!---- DEPENDENCIES
!!--++    Use CFML_GlobalDeps,    only: Cp, Eps, Pi
!!--++    Use CFML_Math_General, only: Cosd, Sind, Acosd, Co_Prime, swap, Sort, atand, &
!!--++                                 Co_Linear
!!--++    Use CFML_Math_3D,      only : Matrix_Inverse, determ_A, determ_V, Cross_Product
!!----
!!---- VARIABLES
!!----    CRYSTAL_CELL_TYPE
!!----    TWOFOLD_AXES_TYPE
!!----    ZONE_AXIS_TYPE
!!----    ERR_CRYS
!!----    ERR_CRYS_MESS
!!--++    IDENTITY                       [Private]
!!--++    TPI2                           [Private]
!!----
!!---- PROCEDURES
!!----    Functions:
!!----       CART_U_VECTOR
!!----       CART_VECTOR
!!----       CELL_VOLUME_SIGMA
!!----       CONVERT_B_BETAS
!!----       CONVERT_B_U
!!----       CONVERT_BETAS_B
!!----       CONVERT_BETAS_U
!!----       CONVERT_U_B
!!----       CONVERT_U_BETAS
!!----       GET_BETAS_FROM_BISO
!!--++       METRICS                     [Private]
!!----       ROT_MATRIX
!!----       U_EQUIV
!!----
!!----    Subroutines:
!!----       CHANGE_SETTING_CELL
!!----       GET_BASIS_FROM_UVW
!!----       GET_CONVENTIONAL_CELL
!!----       GET_CRYST_FAMILY
!!--++       GET_CRYST_ORTHOG_MATRIX     [Private]
!!----       GET_DERIV_ORTH_CELL
!!----       GET_PRIMITIVE_CELL
!!----       GET_TRANSFM_MATRIX
!!----       GET_TWOFOLD_AXES
!!----       INIT_ERR_CRYS
!!----       NIGGLI_CELL                 [Overloaded]
!!--++       NIGGLI_CELL_ABC             [Private]
!!--++       NIGGLI_CELL_NIGGLIMAT       [Private]
!!--++       NIGGLI_CELL_PARAMS          [Private]
!!--++       NIGGLI_CELL_TYPE            [Private]
!!--++       NIGGLI_CELL_VECT            [Private]
!!----       READ_BIN_CRYSTAL_CELL
!!--++       RECIP                       [Private]
!!----       SET_CRYSTAL_CELL
!!----       VOLUME_SIGMA_FROM_CELL
!!----       WRITE_BIN_CRYSTAL_CELL
!!----       WRITE_CRYSTAL_CELL
!!----
!!
 Module CFML_Crystal_Metrics

    !---- Use files ----!
    Use CFML_GlobalDeps,   only : Cp, Eps, Pi, TO_RAD
    Use CFML_Math_General, only : Cosd, Sind, Acosd, Co_Prime, swap, Sort, atand, Co_Linear
    Use CFML_Math_3D,      only : Matrix_Inverse, determ_A, determ_V, Cross_Product

    implicit none

    private

    !---- List of public variables ----!

    !---- List of public functions ----!
    public :: Cart_u_vector, Cart_vector, Convert_B_Betas, Convert_B_U, &
              Convert_Betas_B, Convert_Betas_U, Convert_U_B,            &
              Convert_U_Betas, Rot_matrix, U_Equiv, Cell_Volume_Sigma,  &
              Get_Betas_From_Biso

    !---- List of public overloaded procedures: functions ----!

    !---- List of public subroutines ----!
    public :: Init_Err_Crys, Change_Setting_Cell,Set_Crystal_Cell,           &
              Get_Cryst_Family, Write_Crystal_Cell, Get_Deriv_Orth_Cell,     &
              Get_Primitive_Cell, Get_TwoFold_Axes, Get_Conventional_Cell,   &
              Get_Transfm_Matrix, Get_basis_from_uvw, Volume_Sigma_from_Cell,&
              Read_Bin_Crystal_Cell,Write_Bin_Crystal_Cell


    !---- List of public overloaded procedures: subroutines ----!

    public  :: Niggli_Cell

    !---- List of private functions ----!
    private :: metrics

    !---- List of private Subroutines ----!
    private :: Recip, Get_Cryst_Orthog_Matrix, Niggli_Cell_Vect, Niggli_Cell_Params, &
               Niggli_Cell_type, Niggli_Cell_abc,  Niggli_Cell_nigglimat

    !---- Definitions ----!

    !!----
    !!----  TYPE :: CRYSTAL_CELL_TYPE
    !!--..
    !!----  Type, public :: Crystal_Cell_Type
    !!----     real(kind=cp),dimension(3)   :: cell, ang          ! Direct cell parameters
    !!----     integer,      dimension(3)   :: lcell, lang        ! Code number for refinement in optimization procedures
    !!----     real(kind=cp),dimension(3)   :: cell_std, ang_std  ! Standar deviations cell parameters
    !!----     real(kind=cp),dimension(3)   :: rcell,rang         ! Reciprocal cell parameters
    !!----     real(kind=cp),dimension(3,3) :: GD,GR              ! Direct and reciprocal Metric Tensors
    !!----     real(kind=cp),dimension(3,3) :: Cr_Orth_cel        ! P-Matrix transforming Orthonormal
    !!----                                                        ! basis to direct Crytal cell (as I.T.)
    !!----                                                        ! (or crystallographic components to
    !!----                                                        !  Cartesian components: XC = Cr_Orth_cel X -> XC,X: column vectors)
    !!----     real(kind=cp),dimension(3,3) :: Orth_Cr_cel        ! Inv(Cr_Orth_cel) -> Cartesian to cryst. components
    !!----     real(kind=cp),dimension(3,3) :: BL_M               ! Busing-Levy B-matrix (transforms hkl to  a
    !!----                                                          Cartesian system with x//a*, y in (a*,b*) and z//c
    !!----     real(kind=cp),dimension(3,3) :: BL_Minv            ! Inverse of the Busing-Levy B-matrix
    !!----     real(kind=cp)                :: CellVol            ! Direct and Reciprocal
    !!----     real(kind=cp)                :: RCellVol           ! Cell volumes
    !!----     Character (len=1)            :: CartType           ! Cartesian Frame type: if CartType='A'
    !!----                                                        ! the Cartesian Frame has x // a.
    !!----  End Type Crystal_Cell_Type
    !!----
    !!---- Updated: November - 2013 (adding lcell and lang components)
    !!
    Type, public :: Crystal_Cell_Type
       real(kind=cp),dimension(3)   :: cell, ang
       integer,      dimension(3)   :: lcell, lang
       real(kind=cp),dimension(3)   :: cell_std, ang_std
       real(kind=cp),dimension(3)   :: rcell, rang
       real(kind=cp),dimension(3,3) :: GD,GR
       real(kind=cp),dimension(3,3) :: Cr_Orth_cel
       real(kind=cp),dimension(3,3) :: Orth_Cr_cel
       real(kind=cp),dimension(3,3) :: BL_M
       real(kind=cp),dimension(3,3) :: BL_Minv
       real(kind=cp)                :: CellVol
       real(kind=cp)                :: RCellVol
       character (len=1)            :: CartType
    End Type Crystal_Cell_Type

    !!----
    !!----  TYPE :: TWOFOLD_AXES_TYPE
    !!--..
    !!----  Type, public :: Twofold_Axes_Type
    !!----     integer                       :: ntwo        ! Number of two-fold axes
    !!----     real(kind=cp)                 :: tol         ! Angular tolerance (ca 3 degrees)
    !!----     real(kind=cp),dimension(3,12) :: caxes       ! Cartesian components of two-fold axes
    !!----     integer,dimension(3,12)       :: dtwofold    ! Direct indices of two-fold axes
    !!----     integer,dimension(3,12)       :: rtwofold    ! Reciprocal indices of two-fold axes
    !!----     integer,dimension(12)         :: dot         ! Scalar product of reciprocal and direct indices
    !!----     real(kind=cp),dimension(12)   :: cross       ! Angle between direct and reciprocal axes ( < tol)
    !!----     real(kind=cp),dimension(12)   :: maxes       ! Modulus of the zone axes (two-fold axes) vectors
    !!----     real(kind=cp),dimension(3)    :: a,b,c       ! Cartesian components of direct cell parameters
    !!----  End Type Twofold_Axes_Type
    !!----
    !!----  All components are initialised to zero in the type declaration
    !!----
    !!---- Update: October - 2008
    !!
    Type, public :: Twofold_Axes_Type
       integer                        :: ntwo=0
       real(kind=cp)                  :: tol=3.0
       real(kind=cp) ,dimension(3,12) :: caxes=0.0
       integer,dimension(3,12)        :: dtwofold=0
       integer,dimension(3,12)        :: rtwofold=0
       integer,dimension(12)          :: dot=0
       real(kind=cp), dimension(12)   :: cross=0.0
       real(kind=cp), dimension(12)   :: maxes=0.0
       real(kind=cp), dimension(3)    :: a=0.0,b=0.0,c=0.0
    End Type Twofold_Axes_Type

    !!----
    !!----  TYPE :: ZONE_AXIS_TYPE
    !!--..
    !!----  Type, public :: Zone_Axis_Type
    !!----    Integer               :: nlayer   ! number of the reciprocal layer considered normally nlayer=0
    !!----    Integer, dimension(3) :: uvw      ! Indices of the zone axis
    !!----    Integer, dimension(3) :: rx       ! Indices (reciprocal vector) of the basis vector 1
    !!----    Integer, dimension(3) :: ry       ! Indices (reciprocal vector) of the basis vector 2
    !!----  End Type Zone_Axis_Type
    !!----
    !!----
    !!----  This type comes from ResVis. It is useful to have it as a genereal type for
    !!----  many kinds of applications. Used in the subroutine Get_Basis_From_UVW.
    !!----
    !!---- Updated: February - 2012
    !!

    Type, public :: Zone_Axis_Type
      Integer               :: nlayer
      Integer, dimension(3) :: uvw
      Integer, dimension(3) :: rx
      Integer, dimension(3) :: ry
    End Type Zone_Axis_Type



    !!----
    !!---- ERR_CRYS
    !!----    logical, public :: Err_Crys
    !!----
    !!----    Logical Variable indicating an error in CFML_Crystal_Metrics module
    !!----
    !!---- Update: February - 2005
    !!
    logical, public          :: ERR_Crys

    !!----
    !!---- ERR_CRYS_MESS
    !!----    character(len=150), public :: ERR_Crys_Mess
    !!----
    !!----    String containing information about the last error
    !!----
    !!---- Update: February - 2005
    !!
    character(len=150), public :: ERR_Crys_Mess

    !!--++
    !!--++ IDENTITY
    !!--++    real(kind=cp), dimension(3,3), parameter :: identity=reshape ((/1.0,0.0,0.0,
    !!--++                                                                    0.0,1.0,0.0,
    !!--++                                                                    0.0,0.0,1.0/),(/3,3/))
    !!--++
    !!--++    (PRIVATE)
    !!--++    Identity matrix
    !!--++
    !!--++ Update: October - 2008
    !!
    real(kind=cp),dimension(3,3), parameter  :: identity=reshape ((/1.0,0.0,0.0, 0.0,1.0,0.0, 0.0,0.0,1.0/),(/3,3/))

    !!--++
    !!--++ TPI2
    !!--++    real(kind=cp), parameter :: tpi2=2.0*pi*pi
    !!--++
    !!--++    (PRIVATE)
    !!--++    Two times PI squared
    !!--++
    !!--++ Update: February - 2005
    !!
    real(kind=cp), parameter, private :: tpi2=2.0*pi*pi

    !---- Interfaces - Overloaded ----!

    !!--.. Three non coplanar vectors {a,b,c} generates a lattice using integer linear combinations
    !!--.. There are an infinite number of primitive unit cells generating the same lattice L.
    !!--.. N={a,b,c} is a Buerger cell if and only if |a|+|b|+|c| is a minimal value for all primitive
    !!--.. cells of L.
    !!--.. N is a Niggli cell of L if  (i) it is as Buerger cell of L and
    !!--..                            (ii) |90-alpha| + |90-beta| + |90-gamma| -> maximum
    !!--..                  / a.a  b.b  c.c \       /  s11  s22  s33 \
    !!--..   Niggli matrix  |               |   =   |                |
    !!--..                  \ b.c  a.c  a.b /       \  s23  s13  s12 /
    !!--..

    Interface  Niggli_Cell                   ! The first(s) argument(s) is(are)
      Module Procedure Niggli_Cell_abc       ! List of cell parameters passed as a 6D vector
      Module Procedure Niggli_Cell_nigglimat ! Niggli matrix passed as a 2x3 matrix (ultimately applying the algorithm)
      Module Procedure Niggli_Cell_Params    ! List of cell parameters a,b,c,alpha,beta,gamma
      Module Procedure Niggli_Cell_type      ! The object Cell is passed as argument
      Module Procedure Niggli_Cell_Vect      ! Input three vectors in Cartesian components
    End Interface  Niggli_Cell

 Contains

    !-------------------!
    !---- Functions ----!
    !-------------------!

    !!----
    !!---- Function Cart_U_Vector(Code,V,Celda) Result(Vc)
    !!----    character (len=*),             intent(in) :: code    !  In -> D: Direct, R: Reciprocal
    !!----    real(kind=cp), dimension(3),   intent(in) :: v       !  In -> Vector
    !!----    Type (Crystal_Cell_Type),      intent(in) :: Celda   !  In -> Cell Variable
    !!----    real(kind=cp),dimension(3)                :: vc      ! Out ->
    !!----
    !!----    Convert a vector in crystal space to unitary cartesian components
    !!----
    !!---- Update: February - 2005
    !!
    Function Cart_U_Vector(Code,V,Celda) Result(Vc)
       !---- Arguments ----!
       character (len=*),           intent(in) :: code
       real(kind=cp), dimension(3), intent(in) :: v
       type (Crystal_Cell_Type),    intent(in) :: Celda
       real(kind=cp), dimension(3)             :: vc

       !---- Local Variables ----!
       real(kind=cp) :: vmod

       vc=cart_vector(code,v,celda)
       vmod=sqrt(dot_product(vc,vc))
       if (vmod > 0.0) then
          vc=vc/vmod
       end if

       return
    End Function Cart_U_Vector

    !!----
    !!---- Function Cart_Vector(Code,V,Celda) Result(Vc)
    !!----    character (len=*),             intent(in) :: code     !  In -> D: Direct, R: Reciprocal
    !!----    real(kind=cp), dimension(3),   intent(in) :: v        !  In -> Vector
    !!----    Type (Crystal_Cell_Type),      intent(in) :: Celda    !  In -> Cell variable
    !!----    real(kind=cp) dimension(3)                :: vc       ! Out ->
    !!----
    !!----    Convert a vector in crystal space to cartesian components
    !!----    The value of code has been extended to use also the Busing-Levy
    !!----    Cartesian system as reference also for direct and reciprocal space.
    !!----    Codes:
    !!----    The Cartesian frame is that defined by the setting of the "Celda" object
    !!----         D: The components are given with respect to basis (a,b,c)
    !!----         R: The components are given with respect to basis (a*,b*,c*)
    !!----        BL: The components are given with respect to basis (a*,b*,c*) but
    !!----            the Cartesian frame is that defined by Busing and Levy
    !!----       BLD: The components are given with respect to basis (a,b,c) but
    !!----            the Cartesian frame is that defined by Busing and Levy
    !!----
    !!----
    !!---- Updated: June - 2012
    !!
    Function Cart_Vector(Code,V,Celda) Result(Vc)
       !---- Arguments ----!
       character (len=*),           intent(in) :: code
       real(kind=cp), dimension(3), intent(in) :: v
       type (Crystal_Cell_Type),    intent(in) :: Celda
       real(kind=cp), dimension(3)             :: vc

       select case (trim(code))
          case("d","D")
             vc = matmul(celda%Cr_Orth_cel,v)  !Direct conversion to Cartesian frame

          case ("r","R")
             vc = matmul(celda%GR,v)            !Converts to direct space
             vc = matmul(celda%Cr_Orth_cel,vc)  !Converts to Cartesian frame

          case ("bl","BL")
             vc = matmul(celda%BL_M,vc) !Direct conversion to BL Cartesian frame

          case ("bld","BLD")
             vc = matmul(celda%GD,v)   !Converts to reciprocal space
             vc = matmul(celda%BL_M,vc)!Converts to BL Cartesian frame

       end select

       return
    End Function Cart_Vector

    !!----
    !!---- Function Cell_Volume_Sigma(Cell) result(sigma)
    !!----   type(Crystal_Cell_Type), intent(in) :: Cell   !  In  ->  Cell variable
    !!----   real(kind=cp)                       :: sigma  !  Out ->  Sigma of volume
    !!----
    !!----    Calculates the standard deviation of the unit cell volume
    !!----    from the standard deviations of cell parameters. The input
    !!----    variable is of type Crytal_Cell_Type, if the standard deviations of
    !!----    of both cell axes and cell angles are zero the result is sigma=0.0,
    !!----    otherwise the calculation is performed
    !!----    It is assumed that there is no correlation (covariance terms) between
    !!----    the standard deviations of the different cell parameters.
    !!----
    !!---- Updated: January - 2013 (JRC)
    !!
    Function Cell_Volume_Sigma(Cell) result(sigma)
       !---- Arguments ----!
       type(Crystal_Cell_Type), intent(in) :: Cell
       real(kind=cp)                       :: sigma

       !--- Local variables ---!
       integer                     :: i
       real(kind=cp)               :: q,ca,cb,cc,vc,sa,sb,sc
       real(kind=cp), dimension(3) :: var_ang

       !> Check
       sigma=0.0
       if(sum(abs(Cell%cell_std)) < eps .and. sum(abs(Cell%ang_std)) < eps ) return

       vc=0.0
       do i=1,3
          q=Cell%cell_std(i)/Cell%cell(i)
          vc=vc+q*q
       end do
       if (sum(abs(Cell%ang_std)) > eps) then
          ca=cosd(Cell%ang(1)) ;  sa=sind(Cell%ang(1))
          cb=cosd(Cell%ang(2)) ;  sb=sind(Cell%ang(2))
          cc=cosd(Cell%ang(3)) ;  sc=sind(Cell%ang(3))
          q=1.0-ca*ca-cb*cb-cc*cc+2.0*ca*cb*cc
          var_ang = (Cell%ang_std * TO_RAD)**2/q
          vc=vc+ (ca-cb*cc)*(ca-cb*cc)*sa*sa * var_ang(1)
          vc=vc+ (cb-ca*cc)*(cb-ca*cc)*sb*sb * var_ang(2)
          vc=vc+ (cc-ca*cb)*(cc-ca*cb)*sc*sc * var_ang(3)
       end if

       sigma=Cell%Cellvol*sqrt(vc)

       return
    End Function Cell_Volume_Sigma

    !!--..
    !!--.. Betas are defined by the following expression of the temperature factor:
    !!--.. Taniso= exp( -(beta11 h^2 + beta22 k^2 + beta33 l^2 + 2 (beta12 h k + beta13 h l + beta23 k l)) )
    !!--.. Taniso= exp( -(bet(1) h^2 + bet(2) k^2 + bet(3) l^2 + 2 (bet(4) h k + bet(5) h l + bet(6) k l)) )
    !!--..
    !!--.. Us are defined by the following expression of the temperature factor:
    !!--.. Taniso= exp( -2pi^2 (h^2 (a*)^2 U11+ k^2 (b*)^2 U22+ l^2 (c*)^2 U33+
    !!--..                2 (h k (a*) (b*) U12+ h l (a*) (c*) U13+  k l (b*) (c*) U23)) )
    !!--..

    !!----
    !!---- Function Convert_B_Betas(B,Cell) Result(Beta)
    !!----    real(kind=cp),dimension(6), intent(in)  :: B
    !!----    type (Crystal_cell_Type),   intent(in)  :: Cell
    !!----    real(kind=cp),dimension(6)              :: Beta
    !!----
    !!----    Convert Thermal factors from B to Betas
    !!----
    !!---- Update: February - 2003
    !!
    Function Convert_B_Betas(B,Cell) Result(Beta)
       !---- Arguments ----!
       real(kind=cp),dimension(6), intent(in)  :: B
       type (Crystal_cell_Type),   intent(in)  :: Cell
       real(kind=cp),dimension(6)              :: Beta

       beta(1)=0.25*b(1)*cell%gr(1,1)                ! beta11
       beta(2)=0.25*b(2)*cell%gr(2,2)                ! beta22
       beta(3)=0.25*b(3)*cell%gr(3,3)                ! beta33
       beta(4)=0.25*b(4)*cell%rcell(1)*cell%rcell(2) ! beta12
       beta(5)=0.25*b(5)*cell%rcell(1)*cell%rcell(3) ! beta13
       beta(6)=0.25*b(6)*cell%rcell(2)*cell%rcell(3) ! beta23

       return
    End Function Convert_B_Betas

    !!----
    !!---- Function Convert_B_U(B) Result(U)
    !!----    real(kind=cp),dimension(6), intent(in)  :: B
    !!----    real(kind=cp),dimension(6)              :: U
    !!----
    !!----    Convert Thermal factors from B to U
    !!----
    !!---- Update: February - 2003
    !!
    Function Convert_B_U(B) Result(U)
       !---- Arguments ----!
       real(kind=cp),dimension(6),  intent(in)  :: B
       real(kind=cp),dimension(6)               :: U

       u=b/(4.0*tpi2)

       return
    End Function Convert_B_U

    !!----
    !!---- Function Convert_Betas_B(Beta,Cell) Result(B)
    !!----    real(kind=cp),dimension(6), intent(in)  :: Beta
    !!----    type (Crystal_cell_Type),   intent(in)  :: Cell
    !!----    real(kind=cp),dimension(6)              :: B
    !!----
    !!----    Convert Thermal factors from Betas to B
    !!----
    !!---- Update: February - 2003
    !!
    Function Convert_Betas_B(Beta,Cell) Result(B)
       !---- Arguments ----!
       real(kind=cp),dimension(6), intent(in)  :: Beta
       type (Crystal_cell_Type),   intent(in)  :: Cell
       real(kind=cp),dimension(6)              :: B

       b(1)=4.0*beta(1)/cell%gr(1,1)                  ! B11
       b(2)=4.0*beta(2)/cell%gr(2,2)                  ! B22
       b(3)=4.0*beta(3)/cell%gr(3,3)                  ! B33
       b(4)=4.0*beta(4)/(cell%rcell(1)*cell%rcell(2)) ! B12
       b(5)=4.0*beta(5)/(cell%rcell(1)*cell%rcell(3)) ! B13
       b(6)=4.0*beta(6)/(cell%rcell(2)*cell%rcell(3)) ! B23

       return
    End Function Convert_Betas_B

    !!----
    !!---- Function Convert_Betas_U(Beta,Cell) Result(U)
    !!----    real(kind=cp),dimension(6), intent(in)  :: Beta
    !!----    type (Crystal_cell_Type),   intent(in)  :: Cell
    !!----    real(kind=cp),dimension(6)              :: U
    !!----
    !!----    Convert Thermal factors from Betas to U
    !!----
    !!---- Update: February - 2003
    !!
    Function Convert_Betas_U(Beta,Cell) Result(U)
       !---- Arguments ----!
       real(kind=cp),dimension(6),intent(in)  :: Beta
       type (Crystal_cell_Type),  intent(in)  :: Cell
       real(kind=cp),dimension(6)             :: U

       u(1)=beta(1)/(tpi2*cell%gr(1,1))                ! U11
       u(2)=beta(2)/(tpi2*cell%gr(2,2))                ! U22
       u(3)=beta(3)/(tpi2*cell%gr(3,3))                ! U33
       u(4)=beta(4)/(tpi2*cell%rcell(1)*cell%rcell(2)) ! U12
       u(5)=beta(5)/(tpi2*cell%rcell(1)*cell%rcell(3)) ! U13
       u(6)=beta(6)/(tpi2*cell%rcell(2)*cell%rcell(3)) ! U23

       return
    End Function Convert_Betas_U

    !!----
    !!---- Function Convert_U_B(U) Result(B)
    !!----    real(kind=cp),dimension(6), intent(in)  :: U
    !!----    real(kind=cp),dimension(6)              :: B
    !!----
    !!----    Convert Thermal factors from U to B
    !!----
    !!---- Update: February - 2003
    !!
    Function Convert_U_B(U) Result(B)
       !---- Arguments ----!
       real(kind=cp),dimension(6),        intent(in)  :: U
       real(kind=cp),dimension(6)                     :: B

       b=4.0*tpi2*u

       return
    End Function Convert_U_B

    !!----
    !!---- Function Convert_U_Betas(U,Cell) Result(Beta)
    !!----    real(kind=cp),dimension(6), intent(in)  :: U
    !!----    type (Crystal_cell_Type),   intent(in)  :: Cell
    !!----    real(kind=cp),dimension(6)              :: Beta
    !!----
    !!----    Convert Thermal factors from U to Betas
    !!----
    !!---- Update: February - 2003
    !!
    Function Convert_U_Betas(U,Cell) Result(Beta)
       !---- Arguments ----!
       real(kind=cp),dimension(6),intent(in)  :: U
       type (Crystal_cell_Type),  intent(in)  :: Cell
       real(kind=cp),dimension(6)             :: Beta

       beta(1)=tpi2*u(1)*cell%gr(1,1)                ! beta11
       beta(2)=tpi2*u(2)*cell%gr(2,2)                ! beta22
       beta(3)=tpi2*u(3)*cell%gr(3,3)                ! beta33
       beta(4)=tpi2*u(4)*cell%rcell(1)*cell%rcell(2) ! beta12
       beta(5)=tpi2*u(5)*cell%rcell(1)*cell%rcell(3) ! beta13
       beta(6)=tpi2*u(6)*cell%rcell(2)*cell%rcell(3) ! beta23

       return
    End Function Convert_U_Betas

    !!----
    !!---- Function Get_Betas_from_Biso(Biso,Cell) Result(Betas)
    !!----    real(kind=cp),             intent(in)  :: Biso
    !!----    type (Crystal_cell_Type),  intent(in)  :: Cell
    !!----    real(kind=cp),dimension(6)             :: Betas
    !!----
    !!----    Get Betas from Biso
    !!----
    !!---- Update: April - 2013
    !!
    Function Get_Betas_from_Biso(Biso,Cell) Result(Betas)
       !--- Argument ----!
       real(kind=cp),             intent(in)  :: Biso
       type (Crystal_cell_Type),  intent(in)  :: Cell
       real(kind=cp),dimension(6)             :: Betas

       !---- Local variables ----!
       real(kind=cp), dimension (3,3) :: L,LT,U,bet
       integer                        :: i

       betas=0.0

       l=Cell%Orth_Cr_cel
       lt=Transpose(l)
       u = 0.0
       do i=1,3
          u(i,i) = 0.25*biso
       end do
       bet= matmul (l,lt)
       bet= matmul (bet,u)
       do i=1,3
          betas(i) = bet(i,i)
       end do

       betas(4) = bet(1,2)
       betas(5) = bet(1,3)
       betas(6) = bet(2,3)

       return
    End Function Get_Betas_from_Biso

    !!--++
    !!--++ Function Metrics(A,B) Result(G)
    !!--++    real(kind=cp), dimension(3)  , intent(in ) :: a   !  In -> Cell Parameters
    !!--++    real(kind=cp), dimension(3)  , intent(in ) :: b   !  In -> Ang Parameters
    !!--++    real(kind=cp), dimension(3,3)              :: g   ! Out -> Metrics array
    !!--++
    !!--++    (PRIVATE)
    !!--++    Constructs the metric tensor
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Metrics(A,B) Result(G)
       !---- Arguments ----!
       real(kind=cp), dimension(3)  , intent(in ) :: a
       real(kind=cp), dimension(3)  , intent(in ) :: b
       real(kind=cp), dimension(3,3)              :: g

       !---- Local Variables ----!
       integer :: i

       G(1,2)= a(1)*a(2)*cosd(b(3))
       G(1,3)= a(1)*a(3)*cosd(b(2))
       G(2,3)= a(2)*a(3)*cosd(b(1))

       do i=1,3
          G(i,i)= a(i)*a(i)
       end do

       G(2,1)=G(1,2)
       G(3,1)=G(1,3)
       G(3,2)=G(2,3)

       return
    End Function Metrics

    !!----
    !!---- Function Rot_Matrix(U, Phi, Celda)
    !!----    real(kind=cp), dimension(3),        intent(in) :: U
    !!----    real(kind=cp),                      intent(in) :: Phi
    !!----    type (Crystal_Cell_Type), optional, intent(in) :: Celda
    !!----    real(kind=cp), dimension(3,3)                  :: Rm
    !!----
    !!----    Returns the matrix (Gibbs matrix) of the active rotation of "phi" degrees
    !!----    along the "U" direction: R v = v', the vector v is tranformed to vector v'
    !!----    keeping the reference frame unchanged.
    !!----
    !!----    If one wants to calculate the components of the vector "v" in a rotated
    !!----    reference frame it suffices to invoke the function using "-phi".
    !!----    If "Celda" is present, "U" is in "Celda" coordinates,
    !!----    if not "U" is in cartesian coordinates.
    !!----
    !!----
    !!---- Update: February - 2005
    !!
    Function Rot_Matrix(U,Phi,Celda) Result(Rm)
       !---- Argument ----!
       real(kind=cp), dimension(3), intent(in)        :: U
       real(kind=cp), intent(in)                      :: phi
       type (Crystal_Cell_Type), optional, intent(in) :: Celda
       real(kind=cp), dimension(3,3)                  :: RM

       !---- Local variables ----!
       real(kind=cp)               :: c, s, umc, umod
       real(kind=cp), dimension(3) :: UU


       if (present(celda)) then
          uu= matmul(celda%cr_orth_cel,u)
       else
          uu=u
       end if

       umod=sqrt(dot_product(uu,uu))

       if (umod < tiny(1.0)) then
          uu=(/0.0,0.0,1.0/)
       else
          uu= uu/umod
       end if

       c= cosd(phi)
       s= sind(phi)
       umc = 1.0-c
       rm(1,1)= c+ umc*uu(1)**2
       rm(1,2)= umc*uu(1)*uu(2)- s*uu(3)
       rm(1,3)= umc*uu(1)*uu(3)+ s*uu(2)

       rm(2,1)= umc*uu(2)*uu(1)+ s*uu(3)
       rm(2,2)= c+ umc*uu(2)**2
       rm(2,3)= umc*uu(2)*uu(3)- s*uu(1)

       rm(3,1)= umc*uu(3)*uu(1)- s*uu(2)
       rm(3,2)= umc*uu(3)*uu(2)+ s*uu(1)
       rm(3,3)= c+ umc*uu(3)**2

       return
    End Function Rot_Matrix

    !!----
    !!---- Function U_Equiv(Cell, Th_U) Result(Uequi)
    !!----    type(Crystal_Cell_Type),    intent(in)     :: Cell    !  In -> Cell variable
    !!----    real(kind=cp), dimension(6),intent(in)     :: Th_U    !  In -> U parameters
    !!----
    !!----    Subroutine to obtain the U equiv from U11 U22 U33 U12 U13 U23
    !!----
    !!---- Update: February - 2005
    !!
    Function U_Equiv(Cell, Th_U) Result(Uequi)
       !---- Arguments ----!
       type (Crystal_cell_Type),    intent(in)  :: Cell
       real(kind=cp), dimension(6), intent(in)  :: Th_U
       real(kind=cp)                            :: Uequi

       !---- Local variables ----!
       real(kind=cp)    :: a, b, c, as, bs, cs, cosa, cosb, cosg
       real(kind=cp)    :: u11, u22, u33, u23, u13, u12

       a  =cell%cell(1)
       b  =cell%cell(2)
       c  =cell%cell(3)
       as =cell%rcell(1)
       bs =cell%rcell(2)
       cs =cell%rcell(3)
       cosa=cosd(cell%ang(1))
       cosb=cosd(cell%ang(2))
       cosg=cosd(cell%ang(3))

       u11=Th_u(1)
       u22=Th_u(2)
       u33=Th_u(3)
       u12=Th_u(4)
       u13=Th_u(5)
       u23=Th_u(6)
       uequi= (1.0/3.0) * (u11 * a * a * as * as + &
                           u22 * b * b * bs * bs + &
                           u33 * c * c * cs * cs + &
                           2.0*u12 * a * b * as * bs * cosg + &
                           2.0*u13 * a * c * as * cs * cosb + &
                           2.0*u23 * b * c * bs * cs * cosa )

       return
    End Function U_Equiv

    !---------------------!
    !---- Subroutines ----!
    !---------------------!

    !!----
    !!---- Subroutine Change_Setting_Cell(Cell,Mat,Celln,Matkind)
    !!----    type (Crystal_Cell_Type),      intent( in)    :: Cell
    !!----    real(kind=cp), dimension (3,3),intent( in)    :: Mat
    !!----    type (Crystal_Cell_Type),      intent(out)    :: Celln
    !!----    character (len=*), optional,   intent (in)    :: matkind
    !!----
    !!---- Calculates a new cell giving the transformation matrix.
    !!---- The input matrix can be given as the S-matrix in International
    !!---- Tables or its transposed (default) that corresponds to the matrix
    !!---- relating formal column matrices containing the basis vectors.
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Change_Setting_Cell(Cell,Mat,Celln,Matkind)
       !---- Arguments ----!
       type (Crystal_Cell_Type),      intent( in)    :: Cell
       real(kind=cp), dimension (3,3),intent( in)    :: Mat
       type (Crystal_Cell_Type),      intent(out)    :: Celln
       character(len=*),  optional,   intent (in)    :: Matkind

       !--- Local variables ---!
       integer                       :: i
       real(kind=cp), dimension(3)   :: cellv,angl
       real(kind=cp), dimension(3,3) :: S,Gn,ST

       if (present(matkind)) then
          if (matkind(1:2) == "it" .or. matkind(1:2) == "IT" ) then
             S=Mat
            ST=transpose(Mat)
          else
             S=transpose(Mat)
            ST=Mat
          end if
       else
          S=transpose(Mat)
         ST=Mat
       end if

       !---- Get the new metric tensor
       !---- GDN= Mat GD MatT  or GDN= ST GD S
       gn=matmul(ST,matmul(Cell%GD,S))

       !---- Calculate new cell parameters from the new metric tensor
       do i=1,3
          Cellv(i)=sqrt(gn(i,i))
       end do
       angl(1)=acosd(Gn(2,3)/(cellv(2)*cellv(3)))
       angl(2)=acosd(Gn(1,3)/(cellv(1)*cellv(3)))
       angl(3)=acosd(Gn(1,2)/(cellv(1)*cellv(2)))

       !---- Construct the new cell
       call Set_Crystal_Cell(cellv,angl,Celln)

       return
    End Subroutine Change_Setting_Cell

    !!----
    !!---- Subroutine Get_basis_from_uvw(dmin,u,cell,ZoneB,ok,mode)
    !!----    real(kind=cp)             intent(in) :: dmin  !minimum d-spacing (smax=1/dmin)
    !!----    integer, dimension(3),    intent(in) :: u     !Zone axis indices
    !!----    type (Crystal_Cell_Type), intent(in) :: cell
    !!----    type (Zone_Axis_Type),    intent(out):: ZoneB !Object containing u and basis vector in the plane
    !!----    logical,                  intent(out):: ok
    !!----    character(len=*),optional,intent(in) :: mode
    !!----
    !!----  Subroutine to construct ZA of type Zone_Axis. This subroutine picks up two reciprocal
    !!----  lattice vectors satisfying the equation
    !!----                            hu+kv+lw=0
    !!----  The two reciprocal lattice vectors have no coprime factors and
    !!----  constitute the basis of a reciprocal lattice plane. They are
    !!----  obtained as the shortest two reciprocal lattice vectors satisfying
    !!----  the above equation. If mode is provided and mode="R", we interpret
    !!----  that the input zone axis is a reciprocal lattice vector and what we
    !!----  obtain is the basis of a direct plane in terms of lattice vectors.
    !!----  If mode="R", dmin corresponds n(uvw)max
    !!----  This subroutine has been imported from resvis_proc.f90.
    !!----
    !!----  Created: February 2006 (Imported from old programs for electron diffraction, Thesis JRC)
    !!----  Updated: February 2012 (JRC)
    !!----
    Subroutine Get_basis_from_uvw(dmin,u,cell,ZoneB,ok,mode)
       !--- Arguments ---!
       real(kind=cp),            intent(in) :: dmin
       integer, dimension(3),    intent(in) :: u
       type (Crystal_Cell_Type), intent(in) :: cell
       type (Zone_Axis_Type),    intent(out):: ZoneB
       logical,                  intent(out):: ok
       character(len=*),optional,intent(in) :: mode

       !--- Local Variables ---!
       integer                :: n,ik,il,um,iv,i1,i2,i,coun01,coun02,coun1,coun2
       integer,dimension(1)   :: i0
       integer                :: kmin,kmax,lmin,lmax
       integer,dimension(3)   :: au,h,mu
       real, dimension(2)     :: rm
       real, dimension(3,3)   :: mat
       integer,dimension(3,2) :: bas
       real                   :: rv,s2max

       ZoneB%nlayer=0
       ZoneB%uvw=u
       ok=.false.

       au=abs(u)
       um=3*maxval(au)
       i0=maxloc(au)

       i=i0(1)
       iv=u(i)
       mu=u
       if (iv < 0) then
         mu=-u
         iv=-iv
       end if

       Select Case (i)
         Case(1)
           i1=2; i2=3
         Case(2)
           i1=1; i2=3
         Case(3)
           i1=1; i2=2
       End Select

       rm(1)=100000.0; rm(2)=rm(1)
       bas(:,1) = (/ 71,121, 113/)
       bas(:,2) = (/117, 91,-111/)

       if(present(mode)) then
         s2max=dmin*dmin   !here dmin is really n_max
         kmax=nint(dmin/Cell%cell(i1)+1.0)
         lmax=nint(dmin/Cell%cell(i2)+1.0)
         kmax=min(um,kmax)
         lmax=min(um,lmax)
         mat=cell%gd
       else
         s2max=1.0/(dmin*dmin)
         kmax=nint(Cell%cell(i1)/dmin+1.0)
         lmax=nint(Cell%cell(i2)/dmin+1.0)
         kmax=min(um,kmax)
         lmax=min(um,lmax)
         mat=cell%gr
       end if

       kmin=-kmax; lmin=-lmax
       coun1=0; coun2=0
       do ik=kmax,kmin,-1
          do il=lmax,lmin,-1
             if (ik == 0 .and. il == 0) cycle
             n=-ik*mu(i1)-il*mu(i2)
             if (mod(n,iv) == 0) then               !n is multiple of iv
                h(i)= n/iv ; h(i1)=ik ; h(i2) = il  !h is solution of hu+kv+lw=0
                rv=dot_product(real(h),matmul(mat,real(h)))
                if (rv > s2max  .or. rv < 1.0e-20) cycle
                if (rv < rm(1)) then
                   if (.not. co_linear(bas(:,1),h,3) ) then
                      bas(:,2)=bas(:,1)
                      rm(2) = rm(1)
                      if (coun1 >=1) coun2=coun2+1
                   end if
                   bas(:,1)=h
                   rm(1) = rv
                   coun1=coun1+1
                else if (rv < rm(2) .and. .not. co_linear(bas(:,1),h,3) ) then
                   bas(:,2)=h
                   rm(2) = rv
                   coun2=coun2+1
                end if
             end if
          end do
       end do
       ZoneB%rx=bas(:,1)
       ZoneB%ry=bas(:,2)
       if (coun1 >= 1 .and. coun2 >=1) ok=.true.
       coun01=0; coun02=0; coun1=0; coun2=0
       do i=1,3
          if (ZoneB%rx(i) < 0) coun1=coun1+1
          if (ZoneB%ry(i) < 0) coun2=coun2+1
          if (ZoneB%rx(i) == 0) coun01=coun01+1
          if (ZoneB%ry(i) == 0) coun02=coun02+1
       end do
       if (coun1 >= 2 .or. (coun1 == 1 .and. coun01 == 2)) ZoneB%rx=-ZoneB%rx
       if (coun2 >= 2 .or. (coun2 == 1 .and. coun02 == 2)) ZoneB%ry=-ZoneB%ry

       return
    End Subroutine Get_Basis_From_Uvw

    !!----
    !!---- Subroutine Get_Conventional_Cell(Twofold,Cell,Tr,Message,Ok,told)
    !!----   Type(Twofold_Axes_Type), intent(in)  :: twofold
    !!----   Type(Crystal_Cell_Type), intent(out) :: Cell
    !!----   integer, dimension(3,3), intent(out) :: tr
    !!----   character(len=*),        intent(out) :: message
    !!----   logical,                 intent(out) :: ok
    !!----   real(kind=cp), optional, intent(in)  :: told
    !!----
    !!----  This subroutine provides the "conventional" (or quasi! being still tested )
    !!----  from the supplied object "twofold" that has been obtained from a previous
    !!----  call to Get_TwoFold_Axes. The conventional unit cell can be deduced from
    !!----  the distribution of two-fold axes in the lattice. The cell produced in this
    !!----  procedure applies some rules for obtaining the conventional cell, for instance
    !!----  in monoclinic lattices (a single two-fold axis) the two-fold axis is along
    !!----  b and the final cell is right handed with a <= c and beta >= 90. It may be
    !!----  A,C or I centred. The convertion to the C-centred setting in the A and I
    !!----  centring, is not attempted. The angular tolerance for accepting a two-fold
    !!----  axis, or higher order axes, as such has been previously set into twofold%tol
    !!----  component. The output Tr-matrix is the transpose of the IT convention.
    !!----  It corresponds to the transformation between formal column matrices containing
    !!----  the basis vectors.
    !!----  The tolerance for comparing distances in angstroms told is optional.
    !!----- By default the used tolerance is 0.2 angstroms.
    !!----
    !!---- Update: November - 2008
    !!----
    Subroutine Get_Conventional_Cell(Twofold,Cell,Tr,Message,Ok,told)
       !---- Arguments ----!
       Type(Twofold_Axes_Type), intent(in)  :: Twofold
       Type(Crystal_Cell_Type), intent(out) :: Cell
       integer, dimension(3,3), intent(out) :: tr
       character(len=*),        intent(out) :: message
       logical,                 intent(out) :: ok
       real(kind=cp), optional, intent(in)  :: told

       !---- Local variables ----!
       integer, dimension(1)          :: ix
       integer, dimension(2)          :: ab
       integer, dimension(3)          :: rw,h1,h2
       integer, dimension(66)         :: inp
       integer, dimension(3,48)       :: row
       real(kind=cp), dimension(3)    :: u,v1,v2,v3,a,b,c,vec,vi,vj,vk
       real(kind=cp), dimension(48)   :: mv
       real(kind=cp), dimension(66)   :: ang
       integer                        :: iu,iv,iw,nax,i,j,k,m,namina,naminb,naminc,ia
       real(kind=cp)                  :: dot,ep,domina,dominb,dominc,aij,aik,ajk
       real(kind=cp)                  :: delt,tola
       logical                        :: hexap, hexac

       a=twofold%a; b=twofold%b; c=twofold%c
       delt=twofold%tol
       ep=cosd(90.0-delt)
       domina=9.0e+30; dominc=domina
       tr=reshape((/1,0,0,0,1,0,0,0,1/),(/3,3/))
       ab=0; mv=0.0; ang=0.0; row=0; inp=0
       ok=.true.
       tola=0.2
       if(present(told)) tola=told

       Select Case(twofold%ntwo)
          Case (1)    !Monoclinic
             v2=twofold%caxes(:,1)
             u = v2/twofold%maxes(1)
             tr(2,:)=twofold%dtwofold(:,1)
             nax=0
             do iu=-3,3
                do iv=-3,3
                   do_iw: do iw=0,3
                      rw=(/iu,iv,iw/)
                      ! if(iu == 0 .and. iv == 0 .and. iw == 0) cycle
                      if (.not. Co_prime(rw,3)) cycle
                      vec=real(iu)*a+real(iv)*b+real(iw)*c
                      dot=sqrt(dot_product(vec,vec))
                      vec=vec/dot
                      if (abs(dot_product(u,vec)) < ep) then
                         do m=1,nax
                            if(co_linear(rw,row(:,m),3)) cycle do_iw
                         end do
                         nax=nax+1
                         row(:,nax) = rw
                         mv(nax) = dot
                         if (dot < domina) then
                            domina=dot
                            namina=nax
                            tr(1,:)=rw
                            v1=real(iu)*a+real(iv)*b+real(iw)*c
                         end if
                      end if
                   end do do_iw
                end do
             end do

             do i=1,nax
                if (i == namina) cycle
                if (mv(i) < dominc) then
                   dominc=mv(i)
                   naminc=i
                end if
             end do
             tr(3,:)=row(:,naminc)
             v3=row(1,naminc)*a+row(2,naminc)*b+row(3,naminc)*c

             !Length of the three basis vectors should be stored in mv(1),mv(2),mv(3)
             mv(1)=sqrt(dot_product(v1,v1))
             mv(2)=sqrt(dot_product(v2,v2))
             mv(3)=sqrt(dot_product(v3,v3))

             !The two shortest vectors perpendicular to the primary twofold axis have been found
             !and the transformation matrix has been constructed
             namina=determ_A(tr)
             if (namina < 0) then   !right handed system
                tr(2,:)=-tr(2,:)
                v2=-v2
                namina=-namina
             end if

             !Test if beta is lower than 90 in such a case invert c and b
             dominb=dot_product(v1/mv(1),v3/mv(3))
             if (dominb > 0.0) then  !angle beta < 90
                tr(2,:)=-tr(2,:)
                v2=-v2
                tr(3,:)=-tr(3,:)
                v3=-v3
             end if

             Select Case (namina)
                Case(1)
                   message="Monoclinic, primitive cell"
                Case(2)
                   rw=matmul((/0,1,1/),tr)
                   if (.not. co_prime(rw,3)) then
                      message="Monoclinic, A-centred cell"
                   else
                      rw=matmul((/1,1,1/),tr)
                      if (.not. co_prime(rw,3)) then
                         message="Monoclinic, I-centred cell"
                      else
                         rw=matmul((/1,1,0/),tr)
                         if(.not. co_prime(rw,3)) message="Monoclinic, C-centred cell"
                      end if
                   end if

                Case(3:)
                   message="Error in monoclinic cell"
                   ok=.false.
             End Select

          Case (3)    !Orthorhombic/Trigonal
             u(1:3)=twofold%maxes(1:3)
             ix=minloc(u)
             namina=ix(1)
             ix=maxloc(u)
             naminc=ix(1)
             if (naminc == namina) then
                namina=1; naminb=2; naminc=3
             else
                do i=1,3
                   if(i == namina) cycle
                   if(i == naminc) cycle
                   naminb=i
                   exit
                end do
             end if
             tr(1,:) = twofold%dtwofold(:,namina)
             tr(2,:) = twofold%dtwofold(:,naminb)
             tr(3,:) = twofold%dtwofold(:,naminc)
             v1 = twofold%caxes(:,namina)
             v2 = twofold%caxes(:,naminb)
             v3 = twofold%caxes(:,naminc)
             mv(1)=twofold%maxes(namina)
             mv(2)=twofold%maxes(naminb)
             mv(3)=twofold%maxes(naminc)

             !Check the system by verifying that the two-fold axes form 90 (orthorhombic)
             !or 120 degrees (Trigonal)
             domina=dot_product(v2/mv(2),v3/mv(3))
             dominb=dot_product(v1/mv(1),v3/mv(3))
             dominc=dot_product(v1/mv(1),v2/mv(2))

             if (abs(domina) < ep .and. abs(dominb) < ep .and. abs(dominc) < ep) then !orthorhombic
                namina=determ_A(tr)
                if (namina < 0) then
                   tr(3,:)=-tr(3,:)
                   v3=-v3
                   namina=-namina
                end if
                Select Case (namina)
                   Case(1)
                      message="Orthorhombic, Primitive cell"

                   Case(2)
                      rw=matmul((/0,1,1/),tr)
                      if (.not. co_prime(rw,3)) then
                         message="Orthorhombic, A-centred cell"
                      else
                         rw=matmul((/1,1,1/),tr)
                         if (.not. co_prime(rw,3)) then
                            message="Orthorhombic, I-centred cell"
                         else
                            rw=matmul((/1,1,0/),tr)
                            if (.not. co_prime(rw,3)) then
                               message="Orthorhombic, C-centred cell"
                            else
                               rw=matmul((/1,0,1/),tr)
                               if (.not. co_prime(rw,3)) message="Orthorhombic, B-centred cell"
                            end if
                         end if
                      end if

                   Case(3:)
                      message="Orthorhombic, F-centred cell"
                End Select

             else !Rhombohedral/Trigonal

                !In the Trigonal system the two-fold axes are in the plane perpendicular to
                !the three-fold axis, and valid a,b, vectors can be chosen among any two two-fold
                !axes forming an angle of 120 degrees
                !verify that 1 and 2 form 120
                ang(1)=acosd(domina)    !2-3
                ang(2)=acosd(dominb)    !1-3
                ang(3)=acosd(dominc)    !1-2
                dot=1.0
                iu=1
                j=0
                do i=1,3
                   if (abs(ang(i)-120.0) < delt) then
                      j=i
                      exit
                   end if
                end do

                if ( j == 0) then
                   do i=1,3
                      if (abs(ang(i)-60.0) < delt) then
                         j=i
                         dot=-1.0
                         iu=-1
                         exit
                      end if
                   end do
                End if

                if ( j == 0) then
                   message="Trigonal/Rhombohedral test failed! Supply only one two-fold axis"
                   ok=.false.
                   return
                else
                   Select Case (j)
                      case(1)
                         vi=v2
                         vj=dot*v3
                         h1=tr(2,:); h2=iu*tr(3,:)
                         tr(3,:)=tr(1,:)
                         tr(1,:)=h1
                         tr(2,:)=h2

                      case(2)
                         vi=v1
                         vj=dot*v3
                         h2=iu*tr(3,:)
                         tr(3,:)=tr(2,:)
                         tr(2,:)=h2

                      case(3)
                         vi=v1
                         vj=dot*v2
                         tr(2,:)=iu*tr(2,:)

                   End Select

                   v1 = vi
                   v2 = vj
                   mv(1)=sqrt(dot_product(v1,v1))
                   mv(2)=sqrt(dot_product(v2,v2))
                   vi=v1/mv(1)
                   vj=v2/mv(2)
                   ok=.false.

                   do_iu: do iu=-3,3
                      do iv=-3,3
                         do iw=0,3
                            rw=(/iu,iv,iw/)
                            if (.not. Co_prime(rw,3)) cycle
                            vec=real(iu)*a+real(iv)*b+real(iw)*c
                            dot=sqrt(dot_product(vec,vec))
                            vec=vec/dot
                            if (abs(dot_product(vi,vec)) < ep  .and. abs(dot_product(vj,vec)) < ep) then
                               tr(3,:)=rw
                               ok=.true.
                               exit do_iu
                            end if
                         end do
                      end do
                   end do do_iu

                   If (ok) then
                      namina=determ_A(tr)
                      if (namina < 0) then
                         tr(3,:)=-tr(3,:)
                         namina=-namina
                      end if
                      v3 = tr(3,1)*a+tr(3,2)*b+tr(3,3)*c
                      mv(3)=sqrt(dot_product(v3,v3))
                      Select Case (namina)
                         case(1)
                            message="Primitive hexagonal cell"
                         case(3)
                            rw=matmul((/2,1,1/),tr)
                            if (.not. co_prime(rw,3)) then
                               message="Rhombohedral, obverse setting cell"
                            else
                               message="Rhombohedral, reverse setting cell"
                            end if
                      End Select

                   Else
                      message="Trigonal/Rhombohedral test failed! Supply only one two-fold axis"
                      ok=.false.
                      return
                   End if
                End if !j==0
             End if  !orthorhombic test

          Case (5)    !Tetragonal
             m=0
             inp=0
             mv(1:5)=twofold%maxes(1:5)
             do i=1,twofold%ntwo-1
                vi=twofold%caxes(:,i)/twofold%maxes(i)
                do j=i+1,twofold%ntwo
                   vj=twofold%caxes(:,j)/twofold%maxes(j)
                   m=m+1
                   ang(m)=acosd(dot_product(vi,vj))
                   if (abs(ang(m)-45.0) < delt .or. abs(ang(m)-135.0) < delt) then
                      inp(i)=1
                      inp(j)=1
                      if (mv(i) > mv(j)) then
                         ia=j
                      else
                         ia=i
                      end if
                      if (ab(1) == 0) then
                         ab(1) = ia
                      else
                         ab(2) = ia
                      end if
                   end if
                end do
             end do

             !Determination of the c-axis (that making 90 degree with all the others)
             ix=minloc(inp)
             naminc=ix(1)

             !The two axes forming a,b are those of indices ab(1) and ab(2)
             namina=ab(1)
             naminb=ab(2)
             if (namina == 0 .or. naminb == 0) then
                ok=.false.
                message="Basis vectors a-b not found!"
                return
             end if

             tr(1,:) = twofold%dtwofold(:,namina)
             tr(2,:) = twofold%dtwofold(:,naminb)
             tr(3,:) = twofold%dtwofold(:,naminc)
             v1 = twofold%caxes(:,namina)
             v2 = twofold%caxes(:,naminb)
             v3 = twofold%caxes(:,naminc)
             mv(1)=twofold%maxes(namina)
             mv(2)=twofold%maxes(naminb)
             mv(3)=twofold%maxes(naminc)
             namina=determ_A(tr)
             if (namina < 0) then
                tr(3,:)=-tr(3,:)
                v3=-v3
                namina=-namina
             end if

             Select Case (namina)
                Case(1)
                   message="Tetragonal, Primitive cell"
                Case(2)
                   message="Tetragonal, I-centred cell"
                Case(3:)
                   message="Error in tetragonal cell"
                   ok=.false.
                   return
             End Select

          Case (7)    !Hexagonal

             m=0
             inp=0
             mv(1:7)=twofold%maxes(1:7)
             hexap=.false.;  hexac=.false.

             !Search tha a-b plane
             do_ii:do i=1,twofold%ntwo-1
                vi=twofold%caxes(:,i)/twofold%maxes(i)
                do j=i+1,twofold%ntwo
                   vj=twofold%caxes(:,j)/twofold%maxes(j)
                   aij=acosd(dot_product(vi,vj))
                   if (abs(aij-120.0) < delt) then
                      if (abs(mv(i)-mv(j)) < tola .and. .not. hexap ) then
                         rw(1)=i; rw(2)=j
                         u(1)=mv(i); u(2)=mv(j)
                         hexap=.true.
                         exit do_ii
                      end if
                   end if
                end do
             end do do_ii

             if (hexap) then ! Search the c-axis, it should be also a two-fold axis!
                             ! because Op(6).Op(6).Op(6)=Op(2)
                v1 = twofold%caxes(:,rw(1))
                v2 = twofold%caxes(:,rw(2))
                vj=v1/u(1)
                vk=v2/u(2)
                do i=1,twofold%ntwo
                   vi=twofold%caxes(:,i)/twofold%maxes(i)
                   aij=acosd(dot_product(vi,vj))
                   aik=acosd(dot_product(vi,vk))
                   if (abs(aij-90.0) < delt .and. abs(aik-90.0) < delt ) then
                      rw(3)=i
                      u(3)= mv(i)
                      hexac=.true.
                      exit
                   end if
                end do
             else
                ok=.false.
                return
             end if

             if (hexac) then
                do i=1,3
                   tr(i,:) = twofold%dtwofold(:,rw(i))
                   mv(i)=u(i)
                end do
                v3 = twofold%caxes(:,rw(3))
                namina=determ_A(tr)
                if (namina < 0) then
                   tr(3,:)=-tr(3,:)
                   v3=-v3
                   namina=-namina
                end if

                Select Case (namina)
                   Case(1)
                      message="Hexagonal, Primitive cell"
                   Case(2:)
                      message="Hexagonal, centred cell? possible mistake"
                End Select

             else
                ok=.false.
                message="The c-axis of a hexagonal cell was not found!"
                return
             end if

          Case (9)   !Cubic
             m=0
             inp=0
             mv(1:9)=twofold%maxes(1:9)
             do_i:do i=1,twofold%ntwo-2
                vi=twofold%caxes(:,i)/twofold%maxes(i)
                do j=i+1,twofold%ntwo-1
                   vj=twofold%caxes(:,j)/twofold%maxes(j)
                   do k=j+1,twofold%ntwo
                      vk=twofold%caxes(:,k)/twofold%maxes(k)
                      aij=acosd(dot_product(vi,vj))
                      aik=acosd(dot_product(vi,vk))
                      ajk=acosd(dot_product(vj,vk))
                      if (abs(aij-90.0) < delt .and. abs(aik-90.0) < delt .and. abs(ajk-90.0) < delt ) then
                         if (abs(mv(i)-mv(j)) < tola .and. abs(mv(i)-mv(k)) < tola .and. abs(mv(j)-mv(k)) < tola ) then
                            rw(1)=i; rw(2)=j; rw(3)=k
                            u(1)=mv(i); u(2)=mv(j); u(3)=mv(k)
                            exit do_i
                         end if
                      end if
                   end do
                end do
             end do do_i

             do i=1,3
                tr(i,:) = twofold%dtwofold(:,rw(i))
                mv(i)=u(i)
             end do
             v1 = twofold%caxes(:,rw(1))
             v2 = twofold%caxes(:,rw(2))
             v3 = twofold%caxes(:,rw(3))
             namina=determ_A(tr)
             if (namina < 0) then
                tr(3,:)=-tr(3,:)
                v3=-v3
                namina=-namina
             end if

             Select Case (namina)
                Case(0)
                  write(unit=message,fmt="(a)") "Pseudo-cubic but tolerance too small ... "
                  ok=.false.
                  return
                Case(1)
                   message="Cubic, Primitive cell"
                Case(2)
                   rw=matmul((/0,1,1/),tr)
                   if (.not. co_prime(rw,3)) then
                      message="Cubic, A-centred cell"
                   else
                      rw=matmul((/1,1,1/),tr)
                      if (.not. co_prime(rw,3)) then
                         message="Cubic, I-centred cell"
                      else
                         rw=matmul((/1,1,0/),tr)
                         if (.not. co_prime(rw,3)) then
                            message="Cubic, C-centred cell"
                         else
                            rw=matmul((/1,0,1/),tr)
                            if (.not. co_prime(rw,3)) message="Cubic, B-centred cell"
                         end if
                      end if
                   end if

                Case(3:)
                  message="Cubic, F-centred cell"
             End Select

          case default
             write(unit=message,fmt="(a,i3)") "Wrong number of two-fold axes! ",twofold%ntwo
             ok=.false.
             return

      End Select

      !Calculation of the new cell
      ang(1)=acosd(dot_product(v2/mv(2),v3/mv(3)))
      ang(2)=acosd(dot_product(v1/mv(1),v3/mv(3)))
      ang(3)=acosd(dot_product(v1/mv(1),v2/mv(2)))
      Call Set_Crystal_Cell(mv(1:3),ang(1:3),Cell)
      ok=.true.

      return
    End Subroutine Get_Conventional_Cell

    !!----
    !!---- Subroutine Get_Cryst_Family(Cell,Car_Family,Car_Symbol,Car_System)
    !!----    type(Crystal_Cell_type),         intent(in ) :: Cell
    !!----    character(len=*),                intent(out) :: Car_Family
    !!----    character(len=*),                intent(out) :: Car_Symbol
    !!----    character(len=*),                intent(out) :: Car_System
    !!----
    !!---- Obtain the Crystal Family, Symbol and System from cell parameters
    !!----
    !!---- Update: May - 2005
    !!----
    Subroutine Get_Cryst_Family(Cell,Car_Family,Car_Symbol,Car_System)
       !---- Arguments ----!
       type(Crystal_Cell_type),   intent(in ) :: Cell
       character(len=*),          intent(out) :: Car_Family
       character(len=*),          intent(out) :: Car_Symbol
       character(len=*),          intent(out) :: Car_System

       !---- Local variables ----!
       integer, dimension(3) :: icodp, icoda
       integer               :: n1,n2

       Car_Family=" "
       Car_Symbol=" "
       Car_System=" "

       icodp=0
       icoda=0

       !---- Cell Parameters ----!

       !---- a ----!
       icodp(1)=1

       !---- b ----!
       if (abs(cell%cell(2)-cell%cell(1)) <= 0.0001) then
          icodp(2)=icodp(1)
       else
          icodp(2)=2
       end if

       !---- c ----!
       if (abs(cell%cell(3)-cell%cell(1)) <= 0.0001) then
          icodp(3)=icodp(1)
       else
          icodp(3)=3
       end if

       !---- Angles Parameters ----!

       !---- alpha ----!
       icoda(1)=1

       !---- beta ----!
       if (abs(cell%ang(2)-cell%ang(1)) <= 0.0001) then
          icoda(2)=icoda(1)
       else
          icoda(2)=2
       end if

       !---- gamma ----!
       if (abs(cell%ang(3)-cell%ang(1)) <= 0.0001) then
          icoda(3)=icoda(1)
       else
          icoda(3)=3
       end if


       n1=count(icoda==icoda(1))
       n2=count(icodp==icodp(1))
       select case (n1)
          case (1) ! all are differents
             if (n2 ==1) then
                Car_Family="Triclinic"
                Car_Symbol ="a"
                Car_System ="Triclinic"
             else
                Err_Crys=.true.
                ERR_Crys_Mess=" Error obtaining Crystal Familiy"
             end if

          case (2) ! two angles are equal
             if (icoda(1) == icoda(2)) then
                if (abs(cell%ang(3)-120.0) <= 0.0001) then
                   if (icodp(1)==icodp(2)) then
                      !---- Hexagonal ----!
                      Car_Family="Hexagonal"
                      Car_Symbol ="h"
                      Car_System ="Hexagonal"
                   else
                      Err_Crys=.true.
                      ERR_Crys_Mess=" Error obtaining Crystal Familiy"
                   end if
                else
                   !---- Monoclinic ----!
                   Car_Family="Monoclinic"
                   Car_Symbol ="m"
                   Car_System ="Monoclinic"
                end if

             else
                !---- Monoclic b-unique setting ----!
                if (abs(cell%ang(1)-90.0) <= 0.0001) then
                   Car_Family="Monoclinic"
                   Car_Symbol ="m"
                   Car_System ="Monoclinic"
                else
                   Err_Crys=.true.
                   ERR_Crys_Mess=" Error obtaining Crystal Familiy"
                end if
             end if

          case (3) ! all are the same angle
             if (abs(cell%ang(1) - 90.000) <= 0.0001) then
                select case (n2)
                   case (1)
                      !---- Orthorhombic ----!
                      Car_Family="Orthorhombic"
                      Car_Symbol ="o"
                      Car_System ="Orthorhombic"

                   case (2)
                      !---- Tetragonal ----!
                      if (icodp(1)==icodp(2)) then
                         Car_Family="Tetragonal"
                         Car_Symbol ="t"
                         Car_System ="Tetragonal"
                      else
                         err_crys=.true.
                         ERR_Crys_Mess=" Error obtaining Crystal Familiy"
                      end if

                   case (3)
                      !---- Cubic ----!
                      Car_Family="Cubic"
                      Car_Symbol ="c"
                      Car_System ="Cubic"
                end select

             else
                if (n2 == 3) then
                   !---- Hexagonal with rhombohedral axes ----!
                   Car_Family="Hexagonal"
                   Car_Symbol ="h"
                   Car_System ="Trigonal"
                else
                   Err_Crys=.true.
                   ERR_Crys_Mess=" Error obtaining Crystal Familiy"
                end if
             end if

       end select ! n

       return
    End Subroutine Get_Cryst_Family

    !!--++
    !!--++ Subroutine Get_Cryst_Orthog_Matrix(Cellv,Ang, Crystort,Cartype)
    !!--++    real(kind=cp), dimension(3  ), intent (in ) :: cellv           !  In ->  a,b,c parameters
    !!--++    real(kind=cp), dimension(3  ), intent (in ) :: ang             !  In ->  angles parameters of cell
    !!--++    real(kind=cp), dimension(3,3), intent (out) :: CrystOrt        ! Out ->  Conversion matrix (a) = (e) CrystOrt
    !!--++    character (len=1), optional,   intent (in)  :: CarType         !  In ->  Type of Cartesian axes
    !!--++
    !!--++    (PRIVATE)
    !!--++    Obtains the matrix giving the crystallographic basis in
    !!--++    direct space in terms of a Cartesian basis. The output matrix
    !!--++    can be directly used for transforming crystallographic components
    !!--++    to Cartesian components of the components of a vector considered
    !!--++    as a column vector:   XC = CrystOrt X.
    !!--++
    !!--++    If CartType is not present, or if it is not equal to 'A',
    !!--++    the cartesian system is defined as:
    !!--++          z // c; y is in the bc-plane; x is y ^ z
    !!--++    a = (a sinbeta singamma*, -a sinbeta cosgamma*, a cosbeta )
    !!--++    b = (         0         ,     b sinalpha      , b cosalpha)
    !!--++    c = (         0         ,         0           , c         )
    !!--++
    !!--++    If CartType = 'A', the Cartesian system is defined as:
    !!--++         x // a; y is in the ab-plane; z is x ^ z
    !!--++    a = (       a   ,         0           ,       0             )
    !!--++    b = ( b cosgamma,    b singamma       ,       0             )
    !!--++    c = (  c cosbeta, -c sinbeta cosalpha*, c sinbeta sinalpha* )
    !!--++
    !!--++    The output matrix is the tranposed of the above one(s) so that the
    !!--++    matrix can directly be used for transforming "components" given
    !!--++    in a crystallographic basis to "components" in cartesian basis
    !!--++    when the components are used as "column" vectors.
    !!--++
    !!--++      [a] = C [e] , In [a],[e] basis vectors are in column form
    !!--++      (a) = (e) CT, In (a),(e) basis vectors are in row form
    !!--++      CrystOrt = CT  => (a) = (e) CystOrt, in ITC: (a) = (e) P
    !!--++
    !!--++    Remember that  C.CT = GD (direct cell metrics)
    !!--++
    !!--++
    !!--++      Xc = CrystOrt X (Xc Cartesian components, X crystallographic components)
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Get_Cryst_Orthog_Matrix(Cellv,Ang, Crystort,CarType)
       !---- Arguments ----!
       real(kind=cp), dimension(3  ), intent (in ) :: cellv,ang
       real(kind=cp), dimension(3,3), intent (out) :: CrystOrt
       character (len=1), optional,   intent (in ) :: CarType

       !---- Local Variables ----!
       real(kind=cp) :: cosgas, singas

       if (present(CarType)) then
          if (CarType == "A" .or. CarType == "a" ) then  ! x//a
             !  Transponse of the following matrix:
             !    a = (       a   ,         0           ,       0             )
             !    b = ( b cosgamma,    b singamma       ,       0             )
             !    c = (  c cosbeta, -c sinbeta cosalpha*, c sinbeta sinalpha* )
             cosgas =(cosd(ang(3))*cosd(ang(2))-cosd(ang(1)))/(sind(ang(3))*sind(ang(2)))
             singas = sqrt(1.0-cosgas**2)
             CrystOrt(1,1) = cellv(1)
             CrystOrt(1,2) = cellv(2)*cosd(ang(3))
             CrystOrt(1,3) = cellv(3)*cosd(ang(2))
             CrystOrt(2,1) = 0.0
             CrystOrt(2,2) = cellv(2)*sind(ang(3))
             CrystOrt(2,3) =-cellv(3)*sind(ang(2))*cosgas
             CrystOrt(3,1) = 0.0
             CrystOrt(3,2) = 0.0
             CrystOrt(3,3) = cellv(3)*sind(ang(2))*singas
             return
          end if
       end if

       !
       !  By default, the cartesian frame is such as z//c
       !  Transponse of the following matrix:
       !    a = (a sinbeta singamma*, -a sinbeta cosgamma*, a cosbeta )
       !    b = (         0         ,     b sinalpha      , b cosalpha)
       !    c = (         0         ,         0           , c         )
       cosgas =(cosd(ang(1))*cosd(ang(2))-cosd(ang(3)))/(sind(ang(1))*sind(ang(2)))
       singas = sqrt(1.0-cosgas**2)
       CrystOrt(1,1) = cellv(1)*sind(ang(2))*singas
       CrystOrt(1,2) = 0.0
       CrystOrt(1,3) = 0.0
       CrystOrt(2,1) =-cellv(1)*sind(ang(2))*cosgas
       CrystOrt(2,2) = cellv(2)*sind(ang(1))
       CrystOrt(2,3) = 0.0
       CrystOrt(3,1) = cellv(1)*cosd(ang(2))
       CrystOrt(3,2) = cellv(2)*cosd(ang(1))
       CrystOrt(3,3) = cellv(3)

       return
    End Subroutine Get_Cryst_Orthog_Matrix

    !!----
    !!---- Subroutine Get_Deriv_Orth_Cell(Cellp,De_Orthcell,Cartype)
    !!----    type(Crystal_Cell_type),         intent(in ) :: cellp
    !!----    real(kind=cp), dimension(3,3,6), intent(out) :: de_Orthcell
    !!----    character (len=1), optional,     intent(in ) :: CarType
    !!----
    !!----    Subroutine to get derivative matrix of the transformation matrix
    !!----    to orthogonal frame. Useful for calculations of standard deviations
    !!----    of distances and angles. The specialised subroutine calculating
    !!----    sigmas of distances "distance_and_sigma" is in Atom_mod.
    !!----    The output matrices "de_Orthcell" are the derivatives of, with
    !!----    respect to a(1),b(2),c(3),alpha(4),beta(5) and gamma(6) of the
    !!----    matrix   "Cellp%Cr_Orth_cel".
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Get_Deriv_Orth_Cell(Cellp,De_Orthcell,Cartype)
       !---- Arguments ----!
       type(Crystal_Cell_type),         intent(in ) :: cellp
       real(kind=cp), dimension(3,3,6), intent(out) :: de_Orthcell
       character (len=1), optional,     intent(in ) :: CarType

       !---- Local Variables ----!
       real(kind=cp) ::  ca,cb,cg,sa,sb,sg,f,g, fa,fb,fc,ga,gb,gc

       de_Orthcell=0.0
       ca=cosd(cellp%ang(1))
       cb=cosd(cellp%ang(2))
       cg=cosd(cellp%ang(3))
       sa=sind(cellp%ang(1))
       sb=sind(cellp%ang(2))
       sg=sind(cellp%ang(3))

       if (present(CarType)) then
          if (CarType == "A" .or. CarType == "a" ) then  ! x//a

             f=(ca-cb*cg)/sg    !-cosgas*sinbeta
             g=SQRT(sb*sb-f*f)  ! singas*sinbeta
             fa=-sa/sg          ! df/dalpha
             fb=sb*cg/sg        ! df/dbeta
             fc=cb/sg**2        ! df/dgamma
             ga=-f*fa/g         ! dg/dalpha
             gb=(sb*cb-f*fb)/g  ! dg/dbeta
             gc=f/g*fc          ! dg/dgamma

             ! M: Transponse of the following matrix:
             !    a = (       a   ,         0           ,       0             )
             !    b = ( b cosgamma,    b singamma       ,       0             )
             !    c = (  c cosbeta, -c sinbeta cosalpha*, c sinbeta sinalpha* )

             !
             !        (   a         b*cg        c*cb )
             !    M = (   0         b*sg        c*f  )
             !        (   0          0          c*g  )
             !
             !           (   1      0      0 )
             !  dM_da =  (   0      0      0 )
             !           (   0      0      0 )
             de_Orthcell(1,1,1) = 1.0

             !           (   0      cg     0 )
             !  dM_db =  (   0      sg     0 )
             !           (   0      0      0 )
             de_Orthcell(1,2,2) = cg
             de_Orthcell(2,2,2) = sg

             !
             !            (   0          0          cb )
             !  dM_dc =   (   0          0          f  )
             !            (   0          0          g  )
             de_Orthcell(1,3,3) = cb
             de_Orthcell(2,3,3) = f
             de_Orthcell(3,3,3) = g

             !
             !             (   0          0           0   )
             ! dM_dalpha=  (   0          0          c*fa )
             !             (   0          0          c*ga )
             !
             de_Orthcell(2,3,4) = cellp%cell(3)*fa
             de_Orthcell(3,3,4) = cellp%cell(3)*ga

             !
             !             (   0          0         -c*sb )
             ! dM_dbeta =  (   0          0          c*fb )
             !             (   0          0          c*gb )
             !
             de_Orthcell(1,3,5) = -cellp%cell(3)*sb
             de_Orthcell(2,3,5) =  cellp%cell(3)*fb
             de_Orthcell(3,3,5) =  cellp%cell(3)*gb

             !
             !              (   0        -b*sg         0   )
             ! dM_dgamma =  (   0         b*cg        c*fc )
             !              (   0          0          c*gc )
             !
             de_Orthcell(1,2,6) = -cellp%cell(2)*sg
             de_Orthcell(2,2,6) =  cellp%cell(2)*cg
             de_Orthcell(2,3,6) =  cellp%cell(3)*fc
             de_Orthcell(3,3,6) =  cellp%cell(3)*gc

             return
          end if
       end if

       !
       !  By default, the cartesian frame is such as z//c
       !  Transponse of the following matrix:
       !    a = (a sinbeta singamma*, -a sinbeta cosgamma*, a cosbeta )
       !    b = (         0         ,     b sinalpha      , b cosalpha)
       !    c = (         0         ,         0           , c         )

       !         ( a sinbeta singamma*          0             0 )
       !    M =  (-a sinbeta cosgamma*      b sinalpha        0 )
       !         ( a cosbeta                b cosalpha        c )

       f=(cg-ca*cb)/sa    !-sinbeta . cosgamma*
       g=SQRT(sb*sb-f*f)  ! sinbeta . singamma*
       fa= cb/sa**2       ! df/dalpha
       fb=sb*ca/sa        ! df/dbeta
       fc=-sb/sa          ! df/dgamma
       ga=-f*fa/g         ! dg/dalpha
       gb=(sb*cb-f*fb)/g  ! dg/dbeta
       gc=f/g*fc          ! dg/dgamma

       !         ( a*g        0         0 )
       !    M =  ( a*f      b*sa        0 )
       !         ( a*cb     b*ca        c )

       !
       !           (   g       0      0 )
       !  dM_da =  (   f       0      0 )
       !           (   cb      0      0 )
       de_Orthcell(1,1,1) = g
       de_Orthcell(1,2,1) = f
       de_Orthcell(1,3,1) = cb

       !           (   0      0      0 )
       !  dM_db =  (   0      sa     0 )
       !           (   0      ca     0 )
       de_Orthcell(1,2,2) = sa
       de_Orthcell(3,2,2) = ca

       !
       !            (   0      0      0  )
       !  dM_dc =   (   0      0      0  )
       !            (   0      0      1  )
       de_Orthcell(3,3,3) = 1

       !
       !             ( a*ga         0          0 )
       ! dM_dalpha=  ( a*fa       -b*ca        0 )
       !             (   0         b*sa        0 )
       !
       de_Orthcell(1,1,4) = cellp%cell(1)*ga
       de_Orthcell(2,1,4) = cellp%cell(1)*fa
       de_Orthcell(2,2,4) =-cellp%cell(2)*ca
       de_Orthcell(3,2,4) = cellp%cell(2)*sa

       !
       !             (  a*gb        0         0 )
       ! dM_dbeta =  (  a*fb        0         0 )
       !             ( -a*sb        0         0 )
       !
       de_Orthcell(1,1,5) = cellp%cell(1)*gb
       de_Orthcell(2,1,5) = cellp%cell(1)*fb
       de_Orthcell(3,1,5) =-cellp%cell(1)*sb

       !
       !              (  a*gc     0      0   )
       ! dM_dgamma =  (  a*fc     0      0   )
       !              (   0       0      0   )
       !
       de_Orthcell(1,1,6) = cellp%cell(1)*gc
       de_Orthcell(2,1,6) = cellp%cell(1)*fc

       return
    End Subroutine Get_Deriv_Orth_Cell

    !!----
    !!---- Subroutine Get_Primitive_Cell(Lat_Type,Centred_Cell,Primitive_Cell,Transfm)
    !!----    character(len=*),               intent(in)  :: lat_type
    !!----    type(Crystal_Cell_Type),        intent(in)  :: centred_cell
    !!----    type(Crystal_Cell_Type),        intent(out) :: primitive_cell
    !!----    real(kind=cp), dimension(3,3),  intent(out) :: transfm
    !!----
    !!----    Subroutine for getting the primitive cell from a centred cell
    !!----    On input Lat_type is the lattice type: P,A,B,C,I,R or F
    !!----    Centred_cell is the Crystal_Cell_Type of the input lattice
    !!----    The subroutine calculates the transformation matric "transfm"
    !!----    and provides the complete description of the primitive cell
    !!----    in the object, of type Crystal_Cell_Type, primitive_cell.
    !!----
    !!---- Update: April - 2008
    !!
    Subroutine Get_Primitive_Cell(Lat_Type,Centred_Cell,Primitive_Cell,Transfm)
       !---- Arguments ----!
       character(len=*),              intent(in)  :: lat_type
       type(Crystal_Cell_Type),       intent(in)  :: centred_cell
       type(Crystal_Cell_Type),       intent(out) :: primitive_cell
       real(kind=cp), dimension(3,3), intent(out) :: transfm

       !---- Local variables ----!
       integer                       :: i
       real(kind=cp), dimension(3)   :: celp,celang
       real(kind=cp), dimension(3,3) :: cart,metric
       character(len=1)              :: lat

       lat=adjustl(lat_type)
       Select Case(lat)
          case("a","A")
             transfm= reshape((/1.0,0.0,0.0,  0.0,0.5,0.5,  0.0,-0.5,0.5/),(/3,3/))
          case("b","B")
             transfm= reshape((/0.5,0.0,0.5,  0.0,1.0,0.0, -0.5, 0.0,0.5/),(/3,3/))
          case("c","C")
             transfm= reshape((/0.5,0.5,0.0, -0.5,0.5,0.0,  0.0, 0.0,1.0/),(/3,3/))
          case("i","I")
             transfm= reshape((/1.0,0.0,0.0,  0.0,1.0,0.0,  0.5, 0.5,0.5/),(/3,3/))
          case("r","R")
             transfm= reshape((/2.0/3.0, 1.0/3.0, 1.0/3.0,  &
                               -1.0/3.0, 1.0/3.0, 1.0/3.0,  &
                               -1.0/3.0,-2.0/3.0, 1.0/3.0/),(/3,3/))
          case("f","F")
             transfm= reshape((/0.5,0.0,0.5,  0.5,0.5,0.0,  0.0, 0.5,0.5/),(/3,3/))
          case default  !assumed primitive
             primitive_cell=centred_cell
             transfm= reshape((/1.0,0.0,0.0,  0.0,1.0,0.0,  0.0,0.0,1.0/),(/3,3/))
             return
       End Select
       transfm=transpose(transfm)
       cart=matmul(transfm,transpose(Centred_Cell%Cr_Orth_cel))
       metric=matmul(cart,transpose(cart))

       !---- Calculate new cell parameters from the new metric tensor
       do i=1,3
          Celp(i)=sqrt(metric(i,i))
       end do

       celang(1)=acosd(metric(2,3)/(celp(2)*celp(3)))
       celang(2)=acosd(metric(1,3)/(celp(1)*celp(3)))
       celang(3)=acosd(metric(1,2)/(celp(1)*celp(2)))
       call Set_Crystal_Cell(celp,celang,primitive_cell)

       return
    End Subroutine Get_Primitive_Cell

    !!----
    !!---- Subroutine Get_Transfm_Matrix(cella,cellb,trm,ok,tol)
    !!----    type(Crystal_Cell_Type),     intent(in) :: cella,cellb
    !!----    real(kind=cp),dimension(3,3),intent(out):: trm
    !!----    Logical,                     intent(out):: ok
    !!----    real(kind=cp),optional,      intent(in) :: tol
    !!----
    !!----    Subroutine for getting the transformation matrix between two
    !!----    primitive unit cells (the range of indices is fixed to -2 to 2)
    !!----
    !!---- Update: January - 2011
    !!
    Subroutine Get_Transfm_Matrix(cella,cellb,trm,ok,tol)
       !---- Arguments ----!
       type(Crystal_Cell_Type),     intent(in) :: cella,cellb
       real(kind=cp),dimension(3,3),intent(out):: trm
       Logical,                     intent(out):: ok
       real(kind=cp),optional,      intent(in) :: tol

       !---- Local variables ----!
       type(Crystal_Cell_Type) :: Cellt
       integer,dimension(3,3)  :: Nu
       integer                 :: j,i1,i2,i3,i4,i5,i6,i7,i8,i9
       real(kind=cp)           :: tolt

       tolt=0.3
       if(present(tol)) tolt=tol
       ok=.false.
       dox: do i1=-2,2                     !         |i1  i4  i7|
          do i2=-2,2                       !    Nu = |i2  i5  i8|
             do i3=-2,2                    !         |i3  i6  i9|
                do i4=-2,2
                   do i5=-2,2
                      do i6=-2,2
                         do i7=-2,2
                            do i8=-2,2
                               do i9=-2,2
                                  j=i1*i5*i9+i4*i8*i3+i2*i6*i7-i3*i5*i7-i8*i6*i1-i2*i4*i9     !determinant (much faster than calling determ_A)
                                  if ( j /= 1) cycle
                                  Nu=reshape((/i1,i2,i3,i4,i5,i6,i7,i8,i9/),(/3,3/))
                                  Trm=real(Nu)
                                  call Change_Setting_Cell(Cella,Trm,Cellt)
                                  if (Sum(abs(Cellt%cell(:)-Cellb%cell(:)))+Sum(abs(Cellt%ang(:)-Cellb%ang(:))) < tolt  ) then
                                     ok=.true.
                                     exit dox
                                  end if
                               end do    !i9
                            end do     !i8
                         end do      !i7
                      end do       !i6
                   end do        !i5
                end do         !i4
             end do          !i3
          end do           !i2
       end do  dox       !i1

       return
    End Subroutine Get_Transfm_Matrix

    !!----
    !!---- Subroutine Get_TwoFold_Axes(Celln,Tol,Twofold)
    !!----    type(Crystal_Cell_Type), intent (in) :: Celln
    !!----    real(kind=cp),           intent (in) :: tol !angular tolerance in degrees
    !!----    Type(Twofold_Axes_Type), intent(out) :: twofold
    !!----
    !!----    Subroutine for getting the possible two-fold axes (within an
    !!----    angular tolerance tol) existing in the lattice generated by the
    !!----    unit cell "Celln". Strictly independent two-fold axes are stored
    !!----    in the variable "twofold" that is of type Twofold_Axes_Type
    !!----    The output order of the two-fold axes is ascending in their
    !!----    modulus. Shorter vectors appears before longer ones.
    !!----    The conditions for a reciprocal or direct row to be a two-fold
    !!----    axis are discussed by Y. Le Page in J.Appl.Cryst. 15, 255 (1982).
    !!----
    !!----
    !!---- Update: November - 2008
    !!
    Subroutine Get_TwoFold_Axes(Celln,Tol,Twofold)
       !---- Arguments ----!
       type(Crystal_Cell_Type), intent (in) :: Celln
       real(kind=cp),           intent (in) :: Tol !angular tolerance in degrees
       Type(twofold_axes_type), intent(out) :: Twofold

       !---- Local variables ----!
       integer                        :: i,j,n,m, ih,ik,il,iu,iv,iw,imax,ntwo
       real(kind=cp), dimension(3)    :: dv, rv, a, b, c, as, bs, cs, cross
       real(kind=cp), dimension(  12) :: maxes,crossa
       integer, dimension(  12)       :: dota,ind
       real(kind=cp), dimension(3,12) :: caxes
       integer, dimension(3,12)       :: dtw,rtw
       integer, dimension(3)          :: v,h
       real(kind=cp)                  :: dot,crossm

       maxes=0.0; crossa=0.0; dota=0; caxes=0.0; dtw=0; rtw=0
       a=Celln%Cr_Orth_cel(:,1)
       b=Celln%Cr_Orth_cel(:,2)
       c=Celln%Cr_Orth_cel(:,3)
       twofold%a=a
       twofold%b=b
       twofold%c=c
       as=cross_product(b,c)/Celln%CellVol !Reciprocal lattice vectors in
       bs=cross_product(c,a)/Celln%CellVol !Cartesian components
       cs=cross_product(a,b)/Celln%CellVol
       ntwo=0
       imax=2   !Is inough if the input cell is the Buerger or Niggli cell

       do_iu: do iu=imax, 0,-1
          do iv=imax,-imax,-1
             do iw=imax,-imax,-1
                v=(/iu,iv,iw/)
                if (.not. Co_Prime(v,2)) cycle
                do ih=imax,0,-1
                   do ik=imax,-imax,-1
                      do_il:do il=imax,-imax,-1
                         h=(/ih,ik,il/)
                         if (.not. Co_Prime(h,2)) cycle
                         n=abs(ih*iu+ik*iv+il*iw)
                         if ( n == 2 .or. n == 1) then
                            dv=real(iu)*a+real(iv)*b+real(iw)*c
                            rv=real(ih)*as+real(ik)*bs+real(il)*cs
                            cross=cross_product(dv,rv)
                            dot=sqrt(dot_product(cross,cross))
                            crossm=atand(dot/real(n))
                            if (abs(crossm) <= tol) then
                               do m=1,ntwo
                                  if (determ_V((/17,41,71/),v,dtw(:,m) ) == 0) cycle do_il
                               end do
                               ntwo=ntwo+1
                               dtw(:,ntwo)= v
                               dv=v(1)*a+v(2)*b+v(3)*c
                               caxes(:,ntwo)=dv
                               maxes(ntwo)=sqrt(dot_product(dv,dv))
                               rtw(:,ntwo)= h
                               dota(ntwo)=n
                               crossa(ntwo)=crossm
                            end if
                            if (ntwo == 12) exit do_iu
                         end if
                      end do do_il
                   end do
                end do
             end do
          end do
       end do do_iu
       call sort(maxes,ntwo,ind)
       do i=1,ntwo
          j=ind(i)
          twofold%dtwofold(:,i)= dtw(:,j)
          twofold%caxes(:,i)= caxes(:,j)
          twofold%maxes(i)= maxes(j)
          twofold%rtwofold(:,i)= rtw(:,j)
          twofold%dot(i)= dota(j)
          twofold%cross(i)= crossa(j)
       End do
       twofold%ntwo=ntwo
       twofold%tol=tol

       return
    End Subroutine Get_TwoFold_Axes

    !!----
    !!---- SUBROUTINE INIT_ERR_CRYS()
    !!----
    !!----    Initialize Flags of Errors in this module
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Init_Err_Crys()

       Err_Crys=.false.
       ERR_Crys_Mess=" "

       return
    End Subroutine Init_Err_Crys

    !!----
    !!---- Subroutine Niggli_Cell(XXX,Niggli_Point,Celln,Trans)
    !!----   XXX is one of:
    !!----   real(kind=cp),dimension(6),              intent(in out) :: Ad             ! Cell Parameters
    !!----   or
    !!----   real(kind=cp),dimension(2,3),            intent(in out) :: N_Mat          ! Niggli Matrix
    !!----   or
    !!----   real(kind=cp)                            intent(in out) :: A, B, C, Alfa, Beta, Gamma
    !!----   or
    !!----   type(Crystal_Cell_Type),                 intent(in out ):: cell
    !!----   or
    !!----   real(kind=cp),dimension(3),              intent(in)     :: A,B,C         ! 3 vectors
    !!----   real(kind=cp),dimension(5), optional,    intent(out)    :: Niggli_Point
    !!----   type(Crystal_Cell_Type),optional,        intent(out)    :: Celln
    !!----   real(kind=cp), dimension(3,3), optional, intent(out)    :: Trans
    !!----
    !!----    Calculates the Niggli cell
    !!----
    !!---- Update: October - 2008
    !!

    !!--++
    !!--++ Subroutine Niggli_Cell_ABC(Ad,Niggli_Point,Celln,Trans)
    !!--++    real(kind=cp),dimension(6),              intent(in out) :: Ad
    !!--++    real(kind=cp),dimension(5), optional,    intent(out)    :: Niggli_Point
    !!--++    type(Crystal_Cell_Type),optional,        intent(out)    :: celln
    !!--++    real(kind=cp), dimension(3,3), optional, intent(out)    :: trans
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Calculates the Niggli cell when the input is the list of cell parameters
    !!--++    provided as a 6D vector. Calls the subroutine Niggli_Cell_Nigglimat for
    !!--++    the effective calculations
    !!--++
    !!--++ Update: October - 2008
    !!
    Subroutine Niggli_Cell_ABC(Ad,Niggli_Point,Celln,Trans)    !Scalar algorithm
       !---- Arguments ----!
       real(kind=cp),dimension(6),              intent(in out) :: ad
       real(kind=cp),dimension(5), optional,    intent(out)    :: Niggli_Point
       type(Crystal_Cell_Type),optional,        intent(out)    :: celln
       real(kind=cp), dimension(3,3), optional, intent(out)    :: trans

       !---- Local variables ----!
       real(kind=cp), dimension(2,3)    :: n_mat
       type(Crystal_Cell_Type)          :: celda

       n_mat(1,1)=ad(1)*ad(1)
       n_mat(1,2)=ad(2)*ad(2)
       n_mat(1,3)=ad(3)*ad(3)
       n_mat(2,1)=ad(2)*ad(3)*cosd(ad(4))
       n_mat(2,2)=ad(1)*ad(3)*cosd(ad(5))
       n_mat(2,3)=ad(1)*ad(2)*cosd(ad(6))

       if (present(Niggli_Point)) then
          if (present(trans)) then
             call Niggli_Cell_nigglimat(n_mat,Niggli_Point,celda,trans)
          else
             call Niggli_Cell_nigglimat(n_mat,Niggli_Point,celda)
          end if
       else if(present(trans)) then
          call Niggli_Cell_nigglimat(n_mat,celln=celda,trans=trans)
       else
          call Niggli_Cell_nigglimat(n_mat,celln=celda)
       end if

       if (Err_Crys) return
       if (present(celln)) celln=celda

       !Reconstruct the new cell (Niggli Cell)
       ad(1) = sqrt(n_mat(1,1))
       ad(2) = sqrt(n_mat(1,2))
       ad(3) = sqrt(n_mat(1,3))
       ad(4) = acosd(n_mat(2,1)/(ad(2)*ad(3)))
       ad(5) = acosd(n_mat(2,2)/(ad(1)*ad(3)))
       ad(6) = acosd(n_mat(2,3)/(ad(1)*ad(2)))

       return
    End Subroutine Niggli_Cell_abc

    !!--++
    !!--++ Subroutine Niggli_Cell_Nigglimat(N_Mat,Niggli_Point,Celln,Trans)    !Scalar algorithm
    !!--++    real(kind=cp),dimension(2,3),              intent(in out) :: n_mat
    !!--++    real(kind=cp),dimension(5),      optional, intent(out)    :: Niggli_Point
    !!--++    type(Crystal_Cell_Type), optional,         intent(out)    :: celln
    !!--++    real(kind=cp), dimension(3,3),   optional, intent(out)    :: trans
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Calculates the Niggli cell when the input is the Niggli Matrix (part of the metrics)
    !!--++    of a primitive cell. Applies the scalar algorithm of
    !!--++    I. Krivy and B. Gruber, Acta Cryst A32, 297 (1976)
    !!--++    If Trans is present, Celln should also be present.
    !!--++
    !!--++ Update: January - 2011
    !!
    Subroutine Niggli_Cell_Nigglimat(N_Mat,Niggli_Point,Celln,Trans)    !Scalar algorithm
       !---- Arguments ----!
       real(kind=cp),dimension(2,3),              intent(in out) :: n_mat
       real(kind=cp),dimension(5),      optional, intent(out)    :: Niggli_Point
       type(Crystal_Cell_Type),         optional, intent(out)    :: celln
       real(kind=cp), dimension(3,3),   optional, intent(out)    :: trans

       !--- Local variables ---!
       type(Crystal_Cell_Type)       :: Cellp
       real(kind=cp)                 :: A,B,C,u,v,w,eps
       real(kind=cp), dimension(3,3) :: trm
       real(kind=cp), dimension(3)   :: cel,ang
       integer                       :: iu,iv,iw, ncount ! ncount is the counter no more that Numiter=100
                                                         ! iterations are permitted. In case of exhausting
                                                         ! the iteration Err_Crys=.true. but the current
                                                         ! cell is output anyway
       real(kind=cp),parameter        :: epr=0.0001      !Relative epsilon
       integer, parameter             :: numiter=100
       logical                        :: ok

       ! N is a Niggli cell of L if  (i) it is as Buerger cell of L and
       !                            (ii) |90-alpha| + |90-beta| + |90-gamma| -> maximum
       !                  / a.a  b.b  c.c \       /  s11  s22  s33 \
       !   Niggli matrix  |               |   =   |                |
       !                  \ b.c  a.c  a.b /       \  s23  s13  s12 /
       !
       ! I. Krivy and B. Gruber, Acta Cryst A32, 297 (1976)
       ! Krivy-Gruber algorithms safely implemented (suggestion of Ralf Grosse-Kunsleve)
       ! R.W. Grosse-Kunstleve, N. K. Sauter and P. D. Adams, Acta Cryst A60, 1-6 (2004)
       ! Epsilon: e
       !    x < y -> x < y-e;    x > y -> y < x-e
       !   x <= y -> .not. y < x-e;   x >= y -> .not. x < y-e
       !   x == y -> .not. (x < y-e .or. y < x-e)
       !
       A=n_mat(1,1)
       B=n_mat(1,2)
       C=n_mat(1,3)
       u=2.0*n_mat(2,1)
       v=2.0*n_mat(2,2)
       w=2.0*n_mat(2,3)
       eps=epr*(A*B*C)**(1.0/6.0)
       ncount=0
       ok=.true.
       if (present(trans)) then
          !Construct the input cell Cellp from its Niggli parameters
          cel(1) = sqrt(A)
          cel(2) = sqrt(B)
          cel(3) = sqrt(C)
          ang(1) = acosd(u/(cel(2)*cel(3)*2.0))
          ang(2) = acosd(v/(cel(1)*cel(3)*2.0))
          ang(3) = acosd(w/(cel(1)*cel(2)*2.0))
          call Set_Crystal_Cell(cel,ang, Cellp)
       end if

       do
          ncount=ncount+1
          if (ncount > numiter) then
             ok=.false.
             exit
          end if

          !---- if(A > B .or. ( A == B  .and. abs(u) > abs(v)) ) then  ! A1
          if (B < A-eps .or. ( .not.( A < B-eps .or. B < A-eps)  .and. abs(v) < abs(u)-eps ) ) then  ! A1
             call swap(A,B)
             call swap(u,v)
          end if

          !---- if(B > C .or. ( B == C .and. abs(v) > abs(w)) ) then  ! A2
          if (C < B-eps .or. ( .not.( C < B-eps .or. B < C-eps) .and. abs(w) < abs(v)-eps) ) then  ! A2
             call swap(B,C)
             call swap(v,w)
             cycle
          end if

          !---- if (u*v*w > 0.0) then                                 ! A3
          iu=1; iv=1; iw=1
          if ( u < -eps) iu=-1
          if ( v < -eps) iv=-1
          if ( w < -eps) iw=-1
          if (abs(u) < eps) iu=0
          if (abs(v) < eps) iv=0
          if (abs(w) < eps) iw=0
          if (iu*iv*iw > 0) then                                      ! A3
             u=abs(u)
             v=abs(v)
             w=abs(w)
          else                                                        ! A4
             u=-abs(u)
             v=-abs(v)
             w=-abs(w)
          end if

          !---- if( abs(u) > B .or. ( u == B .and. 2.0*v < w) .or. ( u == -B .and. w < 0.0)) then  ! A5
          if ( B < abs(u)-eps  .or. ( .not.(u < B-eps .or. B < u-eps) .and. 2.0*v < w-eps) .or. &
             ( .not.(u < -B-eps .or. -B < u-eps) .and. w < -eps)) then  ! A5
             iu=1; if( u < -eps) iu=-1
             C = B+C - u * iu
             v =  v  - w * iu
             u = u - 2.0*B*iu
             cycle
          end if

          !---- if( abs(v) > A .or. ( v == A .and. 2.0*u < w) .or. ( v == -A .and. w < 0.0)) then  ! A6
          if ( A < abs(v)-eps .or. (.not. (v < A-eps .or. A < v-eps) .and. 2.0*u < w-eps) .or. &
             ( .not.( v < -A-eps .or. -A < v-eps) .and. w < -eps)) then  ! A6
             iv=1; if( v < -eps) iv=-1
             C = A+C - v * iv
             u =  u  - w * iv
             v = v - 2.0*A*iv
             cycle
          end if

          !---- if( abs(w) > A .or. ( w == A .and. 2.0*u < v) .or. ( w == -A .and. v < 0.0)) then  ! A7
          if ( A < abs(w)-eps .or. ( .not. (w < A-eps .or. A < w-eps) .and. 2.0*u < v-eps) .or. &
             ( .not. (w < -A-eps .or. -A < w-eps) .and. v < -eps)) then  ! A7
             iw=1; if( w < -eps) iw=-1
             B = A+B - w * iw
             u =  u  - v * iw
             w = w - 2.0*A*iw
             cycle
          end if

          !---- if(u+v+w+A+B < 0.0 .or. (u+v+w+A+B == 0.0 .and. 2.0*(A+v)+w > 0.0 )) then  ! A8
          if (u+v+w+A+B < -eps .or. ( abs(u+v+w+A+B) < eps .and. 2.0*(A+v)+w > eps )) then  ! A8
             C=A+B+C+u+v+w
             u=2.0*B+u+w
             v=2.0*A+v+w
             cycle
          end if
          exit
       end do

       !---- Reconstruct the new Niggli matrix
       n_mat(1,1)=A; n_mat(1,2)=B; n_mat(1,3)=C
       n_mat(2,1)=0.5*u; n_mat(2,2)=0.5*v; n_mat(2,3)=0.5*w

       if (.not. ok) Then
          Err_Crys=.true.
          ERR_Crys_Mess=" The limit of iterations in Niggli_Cell_NiggliMat has been reached!"
          return
       end if

       if (present(Niggli_point)) then
          Niggli_point(1)= A/C
          Niggli_point(2)= B/C
          Niggli_point(3)= u/C
          Niggli_point(4)= v/C
          Niggli_point(5)= w/C
       end if

       if (present(celln)) then
          !Reconstruct the new cell (Niggli Cell)
          cel(1) = sqrt(A)
          cel(2) = sqrt(B)
          cel(3) = sqrt(C)
          ang(1) = acosd(u/(cel(2)*cel(3)*2.0))
          ang(2) = acosd(v/(cel(1)*cel(3)*2.0))
          ang(3) = acosd(w/(cel(1)*cel(2)*2.0))
          call Set_Crystal_Cell(cel,ang, Celln)
          if (present(trans)) then
            Call Get_Transfm_Matrix(cellp,celln,trm,ok)
            if(ok) then
              trans=trm
            else
              trans=identity
            end if
          end if
       end if

       return
    End Subroutine Niggli_Cell_nigglimat

    !!--++
    !!--++ Subroutine Niggli_Cell_Params(A,B,C,Al,Be,Ga,Niggli_Point,Celln,Trans)
    !!--++    real(kind=cp),                           intent (in out)  :: a,b,c,al,be,ga
    !!--++    real(kind=cp),dimension(5), optional,    intent(out)      :: Niggli_Point
    !!--++    type(Crystal_Cell_Type),optional,        intent(out)      :: celln
    !!--++    real(kind=cp), dimension(3,3), optional, intent(out)      :: trans
    !!--++
    !!--++    (OVERLOAD)
    !!--++     Calculates the Niggli cell when the input is the list of cell parameters
    !!--++     provided as six scalars.
    !!--++     Calls the subroutine Niggli_Cell_Nigglimat for the effective calculations
    !!--++
    !!--++ Update: October - 2008
    !!
    Subroutine Niggli_Cell_Params(A,B,C,Al,Be,Ga,Niggli_Point,Celln,Trans)
       !---- Arguments ----!
       real(kind=cp),                           intent (in out)  :: a,b,c,al,be,ga
       real(kind=cp),dimension(5), optional,    intent(out)      :: Niggli_Point
       type(Crystal_Cell_Type), optional,       intent(out)      :: celln
       real(kind=cp), dimension(3,3), optional, intent(out)      :: trans

       !--- Local variables ---!
       type(Crystal_Cell_Type)          :: celda
       real(kind=cp), dimension(2,3)    :: n_mat


       call Init_Err_Crys()
       if ( al+be < ga+1.0  .or. al+ga < be+1.0 .or. be+ga < al+1.0) then
          Err_Crys=.true.
          ERR_Crys_Mess=" The provided angles cannot set a unit cell!"
          return
       end if

       call Set_Crystal_Cell((/a,b,c/),(/al,be,ga/), Celda)
       if (Err_Crys) return

       n_mat(1,1)=Celda%GD(1,1); n_mat(1,2)=Celda%GD(2,2); n_mat(1,3)=Celda%GD(3,3)
       n_mat(2,1)=Celda%GD(2,3); n_mat(2,2)=Celda%GD(1,3); n_mat(2,3)=Celda%GD(1,2)

       if (present(Niggli_Point)) then
          if (present(trans)) then
             call Niggli_Cell_nigglimat(n_mat,Niggli_Point,celda,trans)
          else
             call Niggli_Cell_nigglimat(n_mat,Niggli_Point,celda)
          end if
       else if(present(trans)) then
          call Niggli_Cell_nigglimat(n_mat,celln=celda,trans=trans)
       else
          call Niggli_Cell_nigglimat(n_mat,celln=celda)
       end if
       if (Err_Crys) return

       if (present(celln)) then
          celln=celda
       else
           a=celda%cell(1); b=celda%cell(2); c=celda%cell(3)
          al=celda%ang(1); be=celda%ang(2); ga=celda%ang(3)
       end if

       return
    End Subroutine Niggli_Cell_Params

    !!--++
    !!--++ Subroutine Niggli_Cell_Type(Cell,Niggli_Point,Celln,Trans)
    !!--++    type(Crystal_Cell_Type),                 intent(in out ) :: cell
    !!--++    real(kind=cp),dimension(5),    optional, intent(out)     :: Niggli_Point
    !!--++    type(Crystal_Cell_Type),       optional, intent(out)     :: celln
    !!--++    real(kind=cp), dimension(3,3), optional, intent(out)     :: trans
    !!--++
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Calculates the Niggli cell when the input is an object of type Crystal_Cell_Type
    !!--++    Calls the subroutine Niggli_Cell_Nigglimat for the effective calculations
    !!--++
    !!--++ Update: October - 2008
    !!
    Subroutine Niggli_Cell_Type(Cell,Niggli_Point,Celln,Trans)
       !---- Arguments ----!
       type(Crystal_Cell_Type),                 intent(in out ) :: cell
       real(kind=cp),dimension(5),    optional, intent(out)     :: Niggli_Point
       type(Crystal_Cell_Type),       optional, intent(out)     :: celln
       real(kind=cp), dimension(3,3), optional, intent(out)     :: trans

       !--- Local variables ---!
       type(Crystal_Cell_Type)         :: celda
       real(kind=cp), dimension(2,3)   :: n_mat

       call Init_Err_Crys()
       celda=cell
       n_mat(1,1)=Celda%GD(1,1); n_mat(1,2)=Celda%GD(2,2); n_mat(1,3)=Celda%GD(3,3)
       n_mat(2,1)=Celda%GD(2,3); n_mat(2,2)=Celda%GD(1,3); n_mat(2,3)=Celda%GD(1,2)

       if (present(Niggli_Point)) then
          if (present(trans)) then
             call Niggli_Cell_nigglimat(n_mat,Niggli_Point,celda,trans)
          else
             call Niggli_Cell_nigglimat(n_mat,Niggli_Point,celda)
          end if
       else if(present(trans)) then
          call Niggli_Cell_nigglimat(n_mat,celln=celda,trans=trans)
       else
          call Niggli_Cell_nigglimat(n_mat,celln=celda)
       end if
       if (Err_Crys) return

       if (present(celln)) then
          celln=celda
       else
          cell=celda
       end if

       return
    End Subroutine Niggli_Cell_Type

    !!--++
    !!--++ Subroutine Niggli_Cell_Vect(A,B,C,Niggli_Point,Celln,Trans)
    !!--++    real(kind=cp),dimension(3),                intent(in)     :: a,b,c
    !!--++    real(kind=cp),dimension(5),      optional, intent(out)    :: Niggli_Point
    !!--++    type(Crystal_Cell_Type),         optional, intent(out)    :: celln
    !!--++    real(kind=cp), dimension(3,3),   optional, intent(out)    :: trans
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Calculates the Niggli cell when the input is given as three vectors
    !!--++    in Cartesian components. A test of linear indenpendency is performed.
    !!--++    Calls the subroutine Niggli_Cell_Nigglimat for the effective calculations
    !!--++
    !!--++ Update: October - 2008
    !!
    Subroutine Niggli_Cell_Vect(A,B,C,Niggli_Point,Celln,Trans)
       !---- Arguments ----!
       real(kind=cp),dimension(3),                intent(in)     :: a,b,c
       real(kind=cp),dimension(5),      optional, intent(out)    :: Niggli_Point
       type(Crystal_Cell_Type),         optional, intent(out)    :: celln
       real(kind=cp), dimension(3,3),   optional, intent(out)    :: trans

       !--- Local variables ---!
       type(Crystal_Cell_Type)       :: celda
       real(kind=cp), dimension(2,3) :: n_mat
       real(kind=cp)                 :: det

       det=determ_V(a,b,c)
       if (abs(det) < 0.0001) then
          Err_Crys=.true.
          ERR_Crys_Mess=" The three input vectors are nor linearly independent!"
          return
       end if
       n_mat(1,1)=dot_product(a,a); n_mat(1,2)=dot_product(b,b); n_mat(1,3)=dot_product(c,c)
       n_mat(2,1)=dot_product(b,c); n_mat(2,2)=dot_product(a,c); n_mat(2,3)=dot_product(a,b)

       if (present(Niggli_Point)) then
          if (present(trans)) then
             call Niggli_Cell_nigglimat(n_mat,Niggli_Point,celda,trans)
          else
             call Niggli_Cell_nigglimat(n_mat,Niggli_Point,celda)
          end if
       else if(present(trans)) then
          call Niggli_Cell_nigglimat(n_mat,celln=celda,trans=trans)
       else
          call Niggli_Cell_nigglimat(n_mat,celln=celda)
       end if
       if (Err_Crys) return
       if (present(celln)) celln=celda

       return
    End Subroutine Niggli_Cell_Vect

    !!----
    !!---- Subroutine Read_Bin_Crystal_Cell(Celda,Lun,ok)
    !!----    Type (Crystal_Cell_Type),  intent(out) :: Celda   ! Out -> Cell variable
    !!----    Integer,                   intent(in)  :: lun     !  In -> Unit to write
    !!----    logical,                   intent(out) :: ok
    !!----
    !!----    Reads the cell characteristics in a binary file associated to the
    !!----    logical unit lun. The file is supposed to be opened with form="unformatted",
    !!----    access="stream" or equivalent
    !!----
    !!----    Updated: February - 2013
    !!
    Subroutine Read_Bin_Crystal_Cell(Celda,Lun,ok)
       !---- Arguments ----!
       Type (Crystal_Cell_Type),  intent(out) :: Celda
       Integer,                   intent(in)  :: Lun
       logical,                   intent(out) :: ok
       integer :: ier
       ok=.true.
       read(unit=lun,iostat=ier)             &
                       Celda%cell,           &
                       Celda%ang,            &
                       Celda%cell_std,       &
                       Celda%ang_std,        &
                       Celda%rcell,          &
                       Celda%rang,           &
                       Celda%GD,Celda%GR,    &
                       Celda%Cr_Orth_cel,    &
                       Celda%Orth_Cr_cel,    &
                       Celda%BL_M,           &
                       Celda%BL_Minv,        &
                       Celda%CellVol,        &
                       Celda%RCellVol,       &
                       Celda%CartType
       if( ier /= 0) ok=.false.
       return
    End Subroutine Read_Bin_Crystal_Cell


    !!--++
    !!--++ Subroutine Recip(A,Ang,Ar,Angr,Vol,Volr)
    !!--++    real(kind=cp), dimension(3), intent(in ) :: a        !  In -> a,b,c
    !!--++    real(kind=cp), dimension(3), intent(in ) :: ang      !  In -> alpha,beta,gamma
    !!--++    real(kind=cp), dimension(3), intent(out) :: ar       !  In -> a*,b*,c*
    !!--++    real(kind=cp), dimension(3), intent(out) :: angr     !  In -> alpha*,beta*,gamma*
    !!--++    real(kind=cp),               intent(out) :: vol      ! Out -> Vol
    !!--++    real(kind=cp),               intent(out) :: volr     ! Out -> Vol*
    !!--++
    !!--++    (PRIVATE)
    !!--++    Calculates the reciprocal lattice vectors and cell volume
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Recip(A,Ang,Ar,Angr,Vol,Volr)
       !---- Arguments ----!
       real(kind=cp), dimension(3), intent(in ) :: a,ang
       real(kind=cp), dimension(3), intent(out) :: ar,angr
       real(kind=cp),               intent(out) :: vol,volr

       !---- Local Variables ----!
       integer        :: i
       real(kind=cp)  :: s,p,cose

       p=1.0
       s=1.0
       do i=1,3
          cose=cosd(ang(i))
          p=p*cose
          s=s-cose*cose
       end do
       vol=sqrt(abs(s+2.0*p))

       do i=1,3
          vol=vol*a(i)
       end do
       volr=1.0/vol

       ar(1)=a(2)*a(3)*sind(ang(1))/vol
       ar(2)=a(3)*a(1)*sind(ang(2))/vol
       ar(3)=a(1)*a(2)*sind(ang(3))/vol
       angr(1)=(cosd(ang(2))*cosd(ang(3))-cosd(ang(1)))/(sind(ang(2))*sind(ang(3)))
       angr(2)=(cosd(ang(1))*cosd(ang(3))-cosd(ang(2)))/(sind(ang(1))*sind(ang(3)))
       angr(3)=(cosd(ang(2))*cosd(ang(1))-cosd(ang(3)))/(sind(ang(2))*sind(ang(1)))
       do i=1,3
          angr(i)=acosd(angr(i))
       end do

       return
    End Subroutine Recip

    !!----
    !!---- Subroutine Set_Crystal_Cell(Cellv,Angl,Celda,Cartype,Scell,Sangl)
    !!----    real(kind=cp), dimension (3),        intent(in ) :: cellv   !  In -> a,b,c
    !!----    real(kind=cp), dimension (3),        intent(in ) :: angl    !  In -> angles of cell parameters
    !!----    Type (Crystal_Cell_Type),            intent(out) :: Celda   !  Out-> Celda components
    !!----    character (len=1),          optional,intent(in ) :: CarType !  In -> Type of Cartesian Frame
    !!----    real(kind=cp), dimension(3),optional,intent(in ) :: scell,sangl
    !!----
    !!----    Constructs the object "Celda" of type Crystal_Cell. Control for error
    !!----    is present
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Set_Crystal_Cell(Cellv,Angl,Celda,Cartype,Scell,Sangl)
       !---- Arguments ----!
       real(kind=cp), dimension (3),        intent(in ) :: cellv, angl
       Type (Crystal_Cell_Type),            intent(out) :: Celda
       character (len=1),          optional,intent(in ) :: CarType
       real(kind=cp), dimension(3),optional,intent(in ) :: scell,sangl

       !---- Local Variables ----!
       integer :: ifail

       call Init_Err_Crys()

       if (present(scell) .and. present(sangl)) then
          Celda%cell_std=scell
          Celda%ang_std=sangl
       else
          Celda%cell_std=0.0
          Celda%ang_std=0.0
          Celda%lcell=0    !These codes are attributed in refinement programs
          Celda%lang=0     !In order to preserve the values given by these programs the
       end if              !procedure should be invoked with standard deviations

       Celda%cell=cellv
       Celda%ang=angl
       where(Celda%ang < eps) Celda%ang =90.0
       call recip(cellv,angl,Celda%rcell,Celda%rang,Celda%CellVol,Celda%RCellVol)
       if (present(CarType)) then
          call Get_Cryst_Orthog_matrix(cellv,angl,Celda%Cr_Orth_cel,CarType)
          Celda%CartType=CarType
       else
          call Get_Cryst_Orthog_matrix(cellv,angl,Celda%Cr_Orth_cel)
          Celda%CartType="C"
       end if
       call matrix_inverse(Celda%Cr_Orth_cel,Celda%Orth_Cr_cel,ifail)

       if (ifail /= 0) then
          err_crys=.true.
          ERR_Crys_Mess=" Bad cell parameters "
          return
       end if

       Celda%GD=Metrics(cellv,angl)
       Celda%GR=Metrics(Celda%rcell,Celda%rang)

       ! Busing-Levy matrix component
       !(it corresponds to the transpose of Orth_Cr_cel when Celda%CartType="C")
       If (Celda%CartType == "C") then
          Celda%bl_m=Transpose(Celda%Orth_Cr_cel)
          Celda%bl_minv=Transpose(Celda%Cr_Orth_cel)
       else
          Celda%bl_m(1,1)=celda%rcell(1)
          Celda%bl_m(1,2)=celda%rcell(2)*cosd(celda%rang(3))
          Celda%bl_m(1,3)=celda%rcell(3)*cosd(celda%rang(2))
          Celda%bl_m(2,2)=celda%rcell(2)*sind(celda%rang(3))
          Celda%bl_m(2,3)=-(celda%rcell(3)*sind(celda%rang(2))*cosd(celda%ang(1)))
          Celda%bl_m(3,3)=1.0/celda%cell(3)
          Celda%bl_m(2,1)=0.0
          Celda%bl_m(3,1)=0.0
          Celda%bl_m(3,2)=0.0
          call matrix_inverse(Celda%bl_m,Celda%bl_minv,ifail)

          if (ifail /= 0) then
             err_crys=.true.
             ERR_Crys_Mess=" Bad cell parameters "
             return
          end if
       end if

       return
    End Subroutine Set_Crystal_Cell

    !!----
    !!---- Subroutine Volume_Sigma_from_Cell(cell,ang,sigc,siga,volume,sigv)
    !!----    real(kind=cp), dimension(3),  intent(in) :: Cell   !  In  ->  a,b,c parameters
    !!----    real(kind=cp), dimension(3),  intent(in) :: Ang    !  In  -> alpha, beta, gamma
    !!----    real(kind=cp), dimension(3),  intent(in) :: SigC   !  In  -> sigmas for a ,b and c
    !!----    real(kind=cp), dimension(3),  intent(in) :: SigA   !  In  -> sigmas for angles
    !!----    real(kind=cp),                intent(out):: Volume ! Out  -> Volume from cell parameters
    !!----    real(kind=cp),                intent(out):: SigV   ! Out  -> Sigma for Volume
    !!----
    !!----    Calculates the volume and their standard deviation from unit cell
    !!----    parameters. If the standard deviations of cell parameters are zero
    !!----    the result is sigma=0.0, otherwise the calculation is performed.
    !!----    It is assumed that there is no correlation (covariance terms) between
    !!----    the standard deviations of the different cell parameters.
    !!----
    !!---- Updated: January - 2013 (JGP)
    !!
    Subroutine Volume_Sigma_from_Cell(cell,ang,sigc,siga,volume,sigv)
       !---- Arguments ----!
       real(kind=cp), dimension(3),  intent(in) :: Cell   !  In  ->  a,b,c parameters
       real(kind=cp), dimension(3),  intent(in) :: Ang    !  In  -> alpha, beta, gamma
       real(kind=cp), dimension(3),  intent(in) :: SigC   !  In  -> sigmas for a ,b and c
       real(kind=cp), dimension(3),  intent(in) :: SigA   !  In  -> sigmas for angles
       real(kind=cp),                intent(out):: Volume ! Out  -> Volume from cell parameters
       real(kind=cp),                intent(out):: SigV   ! Out  -> Sigma for Volume

       !---- Local Variables ----!
       real(kind=cp) :: a,b,c,ca,cb,cg,sa,sb,sg
       real(kind=cp) :: t, dvda, dvdb, dvdc, dvdalpha, dvdbeta, dvdgamma

       !> Init
       volume=0.0
       sigv=0.0

       a=cell(1)
       b=cell(2)
       c=cell(3)
       ca=cosd(ang(1))
       cb=cosd(ang(2))
       cg=cosd(ang(3))
       sa=sind(ang(1))
       sb=sind(ang(2))
       sg=sind(ang(3))

       t=sqrt(1.0 - ca**2 - cb**2 - cg**2 + 2.0*ca*cb*cg)

       volume=a*b*c*t

       if(sum(abs(sigc)) < eps .and. sum(abs(siga)) < eps ) return

       dvda=b*c*t
       dvdb=a*c*t
       dvdc=a*b*t

       dvdalpha=(a*b*c)*( (sa/t)*(ca-cb*cg) )
       dvdbeta= (a*b*c)*( (sb/t)*(cb-ca*cg) )
       dvdgamma=(a*b*c)*( (sg/t)*(cg-ca*cb) )

       sigv= (dvda*sigc(1))**2 + (dvdb*sigc(2))**2 + (dvdc*sigc(3))**2 +  &
             (dvdalpha*siga(1)*to_rad)**2 + (dvdbeta*siga(2)*to_rad)**2 + &
             (dvdgamma*siga(3)*to_rad)**2

       sigv=sqrt(sigv)

       return
    End Subroutine Volume_Sigma_from_Cell

    !!----
    !!---- Subroutine Write_Crystal_Cell(Celda,Lun)
    !!----    Type (Crystal_Cell_Type),  intent(in)  :: Celda   !  In -> Cell variable
    !!----    Integer,                   intent(in)  :: lun     !  In -> Unit to write
    !!----
    !!----    Writes the cell characteristics in a binary file associated to the
    !!----    logical unit lun. The file is supposed to be opened with form="unformatted",
    !!----    access="stream" or equivalent
    !!----
    !!---- Update: February - 2013
    !!
    Subroutine Write_Bin_Crystal_Cell(Celda,Lun)
       !---- Arguments ----!
       Type (Crystal_Cell_Type),  intent(in) :: Celda
       Integer,                   intent(in) :: Lun
       write(unit=lun) Celda%cell,           &
                       Celda%ang,            &
                       Celda%cell_std,       &
                       Celda%ang_std,        &
                       Celda%rcell,          &
                       Celda%rang,           &
                       Celda%GD,Celda%GR,    &
                       Celda%Cr_Orth_cel,    &
                       Celda%Orth_Cr_cel,    &
                       Celda%BL_M,           &
                       Celda%BL_Minv,        &
                       Celda%CellVol,        &
                       Celda%RCellVol,       &
                       Celda%CartType
       return
    End Subroutine Write_Bin_Crystal_Cell

    !!----
    !!---- Subroutine Write_Crystal_Cell(Celda,Lun)
    !!----    Type (Crystal_Cell_Type),  intent(in)  :: Celda   !  In -> Cell variable
    !!----    Integer,optional           intent(in)  :: lun     !  In -> Unit to write
    !!----
    !!----    Writes the cell characteristics in a file associated to the
    !!----    logical unit lun
    !!----
    !!---- Update: January - 2011
    !!
    Subroutine Write_Crystal_Cell(Celda,Lun)
       !---- Arguments ----!
       Type (Crystal_Cell_Type),  intent(in) :: Celda
       Integer,optional,          intent(in) :: Lun

       !---- Local variables ----!
       integer            :: iunit
       integer            :: i,j

       iunit=6
       if (present(lun)) iunit=lun

       Write(unit=iunit,fmt="(/,a)")    "        Metric information:"
       Write(unit=iunit,fmt="(a,/)")    "        -------------------"
       Write(unit=iunit,fmt="(a,/)")    " => Direct cell parameters:"
       Write(unit=iunit,fmt="(3(a,f12.4))")"         a = ", Celda%cell(1),"      b = ", Celda%cell(2), "      c = ", Celda%cell(3)
       Write(unit=iunit,fmt="(3(a,f12.3))")"     alpha = ", Celda%ang(1) ,"   beta = ", Celda%ang(2) , "  gamma = ", Celda%ang(3)
       Write(unit=iunit,fmt="(a,f12.4)")   "                        Direct Cell Volume = ",Celda%CellVol
       Write(unit=iunit,fmt="(/,a,/)")     " => Reciprocal cell parameters:"
       Write(unit=iunit,fmt="(3(a,f12.6))")"         a*= ", Celda%rcell(1),"      b*= ",Celda%rcell(2),"      c*= ", Celda%rcell(3)
       Write(unit=iunit,fmt="(3(a,f12.3))")"     alpha*= ", Celda%rang(1) ,"   beta*= ",Celda%rang(2) ,"  gamma*= ", Celda%rang(3)
       Write(unit=iunit,fmt="(a,f12.8)")   "                    Reciprocal Cell Volume = ",Celda%RCellVol
       Write(unit=iunit,fmt="(/,a,/)")     " => Direct and Reciprocal Metric Tensors:"
       Write(unit=iunit,fmt="(a)")         "                   GD                                       GR"

       do i=1,3
          Write(unit=iunit,fmt="(3f12.4,a,3f12.6)") (Celda%GD(i,j),j=1,3),"      ", (Celda%GR(i,j),j=1,3)
       end do

       if (Celda%CartType == "A") then
          Write(unit=iunit,fmt="(/,a,/)") " =>  Cartesian frame: x // a; y is in the ab-plane; z is x ^ y   "
       else
          Write(unit=iunit,fmt="(/,a,/)") " =>  Cartesian frame: z // c; y is in the bc-plane; x is y ^ z   "
       end if

       Write(unit=iunit,fmt="(a)")       "     Crystal_to_Orthonormal_Matrix              Orthonormal_to_Crystal Matrix"
       Write(unit=iunit,fmt="(a)")       "              Cr_Orth_cel                               Orth_Cr_cel  "
       do i=1,3
          Write(unit=iunit,fmt="(3f12.4,a,3f12.6)") (Celda%Cr_Orth_cel(i,j),j=1,3),"      ", (Celda%Orth_Cr_cel(i,j),j=1,3)
       end do

       Write(unit=iunit,fmt="(/,a)")     "     Busing-Levy B-matrix: Hc=B.H            Inverse of the Busing-Levy B-matrix"
       Write(unit=iunit,fmt="(a)")       "                BL_M                                      BL_Minv  "
       do i=1,3
          Write(unit=iunit,fmt="(3f12.6,a,3f12.4)") (Celda%BL_M(i,j),j=1,3),"      ", (Celda%BL_Minv(i,j),j=1,3)
       end do

       return
    End Subroutine Write_Crystal_Cell

 End Module CFML_Crystal_Metrics
!!-------------------------------------------------------
!!---- Crystallographic Fortran Modules Library (CrysFML)
!!-------------------------------------------------------
!!---- The CrysFML project is distributed under LGPL. In agreement with the
!!---- Intergovernmental Convention of the ILL, this software cannot be used
!!---- in military applications.
!!----
!!---- Copyright (C) 1999-2012  Institut Laue-Langevin (ILL), Grenoble, FRANCE
!!----                          Universidad de La Laguna (ULL), Tenerife, SPAIN
!!----                          Laboratoire Leon Brillouin(LLB), Saclay, FRANCE
!!----
!!---- Authors: Juan Rodriguez-Carvajal (ILL)
!!----          Javier Gonzalez-Platas  (ULL)
!!----
!!---- Contributors: Laurent Chapon     (ILL)
!!----               Marc Janoschek     (Los Alamos National Laboratory, USA)
!!----               Oksana Zaharko     (Paul Scherrer Institute, Switzerland)
!!----               Tierry Roisnel     (CDIFX,Rennes France)
!!----               Eric Pellegrini    (ILL)
!!----
!!---- This library is free software; you can redistribute it and/or
!!---- modify it under the terms of the GNU Lesser General Public
!!---- License as published by the Free Software Foundation; either
!!---- version 3.0 of the License, or (at your option) any later version.
!!----
!!---- This library is distributed in the hope that it will be useful,
!!---- but WITHOUT ANY WARRANTY; without even the implied warranty of
!!---- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
!!---- Lesser General Public License for more details.
!!----
!!---- You should have received a copy of the GNU Lesser General Public
!!---- License along with this library; if not, see <http://www.gnu.org/licenses/>.
!!----
!!----
!!---- MODULE: CFML_Reflections_Utilities
!!----   INFO: Series of procedures handling operation with
!!----         Bragg reflections
!!----
!!---- HISTORY
!!----    Update: 06/03/2011
!!----
!!---- DEPENDENCIES
!!----
!!--++    Use CFML_GlobalDeps,                only: sp, cp, pi
!!--++    Use CFML_Math_General,              only: sort
!!--++    Use CFML_String_Utilities,          only: l_case,Get_LogUnit
!!--++    Use CFML_Crystallographic_Symmetry, only: Sym_Oper_Type, Space_Group_Type
!!--++    Use CFML_Crystal_Metrics,           only: Crystal_Cell_Type
!!----
!!---- VARIABLES
!!--++    EPS_REF                  [Private]
!!----    ERR_REFL
!!----    ERR_REFL_MESS
!!--++    HKL_REF_COND_INI         [Private]
!!----    HKL_REF_COND
!!----    REFLECT_TYPE
!!----    REFLECTION_TYPE
!!----    REFLECTION_LIST_TYPE
!!----
!!---- PUBLIC PROCEDURES
!!----    Functions:
!!----       ASU_HKL
!!--++       ASU_HKL_CUBIC         [Private]
!!--++       ASU_HKL_HEXAGONAL     [Private]
!!--++       ASU_HKL_MONOCLINIC    [Private]
!!--++       ASU_HKL_ORTHORHOMBIC  [Private]
!!--++       ASU_HKL_TETRAGONAL    [Private]
!!--++       ASU_HKL_TRICLINIC     [Private]
!!--++       ASU_HKL_TRIGONAL      [Private]
!!----       GET_HEQUIV_ASU
!!----       GET_MAXNUMREF
!!----       HKL_ABSENT
!!--++       HKL_ABSENTI           [Overloaded]
!!--++       HKL_ABSENTR           [Overloaded]
!!----       HKL_EQUAL
!!--++       HKL_EQUALI            [Overloaded]
!!--++       HKL_EQUALR            [Overloaded]
!!----       HKL_EQUIV
!!--++       HKL_EQUIVI            [Overloaded]
!!--++       HKL_EQUIVR            [Overloaded]
!!----       HKL_LAT_ABSENT
!!----       HKL_MULT
!!--++       HKL_MULTI             [Overloaded]
!!--++       HKL_MULTR             [Overloaded]
!!----       HKL_R
!!--++       HR_I                  [Overloaded]
!!--++       HR_R                  [Overloaded]
!!----       HKL_S
!!--++       HS_I                  [Overloaded]
!!--++       HS_R                  [Overloaded]
!!----       UNIT_CART_HKL
!!--++       UNIT_CART_HKLI        [Overloaded]
!!--++       UNIT_CART_HKLR        [Overloaded]
!!----
!!----    Subroutines:
!!--++       GLIDE_PLANES_CONDITIONS  [Private]
!!----       HKL_EQUIV_LIST
!!--++       HKL_EQUIV_LISTI       [Overloaded]
!!--++       HKL_EQUIV_LISTR       [Overloaded]
!!----       HKL_GEN
!!----       HKL_GEN_SXTAL
!!--++       HKL_GEN_SXTAL_REFLECTION    [Overloaded]
!!--++       HKL_GEN_SXTAL_LIST          [Overloaded]
!!----       HKL_RP
!!--++       HKL_RPI               [Overloaded]
!!--++       HKL_RPR               [Overloaded]
!!----       HKL_UNI
!!--++       HKL_UNI_REFLECT       [Overloaded]
!!--++       HKL_UNI_REFLECTION    [Overloaded]
!!--++       HKL_UNI_REFLLIST      [Overloaded]
!!----       INIT_ERR_REFL
!!----       INIT_REFLIST
!!--++       INIT_REF_COND         [Private]
!!--++       INTEGRAL_CONDITIONS   [Private]
!!--++       SCREW_AXIS_CONDITIONS [Private]
!!----       SEARCH_EXTINCTIONS
!!--++       SEARCH_EXTINCTIONS_IUNIT [Overloaded]
!!--++       SEARCH_EXTINCTIONS_FILE [Overloaded]
!!----       WRITE_ASU
!!----       WRITE_REFLIST_INFO
!!----
!!----
!!
 Module CFML_Reflections_Utilities

    !---- Use Modules ----!
    Use CFML_GlobalDeps,                only: sp, cp, pi
    Use CFML_Math_General,              only: sort
    Use CFML_String_Utilities,          only: l_case,Get_LogUnit
    Use CFML_Crystallographic_Symmetry, only: Sym_Oper_Type, Space_Group_Type, Lattice_Centring_Type, &
                                              Allocate_Lattice_Centring
    Use CFML_Crystal_Metrics,           only: Crystal_Cell_Type

    !---- Variables ----!
    implicit none

    private

    !---- List of public variables ----!

    !---- List of public functions ----!
    public :: Asu_Hkl,Get_MaxNumRef, Hkl_Absent, Hkl_Equal, Hkl_Equiv, Hkl_Mult,   &
              Get_Hequiv_Asu,Hkl_R, Hkl_S, Unit_Cart_Hkl, Hkl_Lat_Absent

    !---- List of public overloaded procedures: functions ----!

    !---- 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

    !---- List of public overloaded procedures: subroutines ----!

    !---- List of private functions ----!
    private :: Asu_Hkl_Cubic, Asu_Hkl_Hexagonal, Asu_Hkl_Monoclinic, Asu_Hkl_Orthorhombic,   &
               Asu_Hkl_Tetragonal, Asu_Hkl_Triclinic, Asu_Hkl_Trigonal, Hkl_AbsentI, hkl_equalI, &
               hkl_equivi, Hkl_MultI, HR_I, HS_I, Unit_Cart_HklI, Hkl_AbsentR, Hkl_EqualR, hkl_Equivr, &
               Hkl_MultR, HR_R, HS_R, Unit_Cart_HklR

    !---- List of private subroutines ----!
    private :: Hkl_Equiv_Listi, Hkl_Equiv_Listr, Hkl_RpI, Hkl_RpR, Hkl_Uni_reflect, &
               Hkl_Uni_reflection, Glide_Planes_Conditions, Integral_Conditions, Screw_Axis_Conditions,&
               Init_Ref_Cond, Hkl_uni_refllist, Hkl_Gen_Sxtal_list,Hkl_Gen_Sxtal_reflection, &
               Search_Extinctions_Iunit, Search_Extinctions_File

    !---- Definitions ----!

    !---- Local Variables ----!

    !!--++
    !!--++ eps_ref
    !!--++    real(kind=cp), parameter, private :: eps_ref
    !!--++
    !!--++    (PRIVATE)
    !!--++    Epsilon for comparisons within this module. Increased w.r.t. previous versions.
    !!--++
    !!--++ Update: December - 2010
    !!
    real(kind=cp), parameter, private :: eps_ref  = 0.0002_cp

    !!----
    !!---- ERR_REFL
    !!----    logical, public :: err_refl
    !!----
    !!----    Logical Variable indicating an error in CFML_Reflections_Utilities module
    !!----
    !!---- Update: February - 2005
    !!
    logical, public :: ERR_Refl

    !!----
    !!---- ERR_REFL_MESS
    !!----    character(len=150), public :: ERR_Refl_Mess
    !!----
    !!----    String containing information about the last error
    !!----
    !!---- Update: February - 2005
    !!
    character(len=150), public :: ERR_Refl_Mess

    !!--++
    !!--++ HKL_REF_COND_INI
    !!--++    logical, public :: hkl_ref_cond_ini
    !!--++
    !!--++    Logical Variable indicating if the reflection conditions
    !!--++    array has been initialized
    !!--++
    !!--++ Update: August - 2005
    !!
    logical, private:: hkl_ref_cond_ini=.false.

    !!----
    !!---- HKL_REF_CONDITIONS
    !!----    character(len=*), dimension(58), public :: Hkl_Ref_Conditions
    !!----
    !!----    Reflection conditions for Lattices, glide planes, screw axes
    !!--..
    !!--..
    !!--.. International tables vol. A, Fourth, revised edition (1996) p27-28-29
    !!--..
    !!--.. Table 2.1.3.1: integral reflection conditions for centred cells (lattices)
    !!--..
    !!--..        reflection condition          Centring type of cell               Centring symbol
    !!--..
    !!--..         none                         primitive                           P
    !!--..                                                                          R (rhomboedral axes)
    !!--..         h+k   = 2n                   C-face centred                      C
    !!--..         k+l   = 2n                   A-face centred                      A
    !!--..         h+l   = 2n                   B-face centred                      B
    !!--..         h+k+l = 2n                   Body centred                        I
    !!--..
    !!--..         h+k   = 2n
    !!--..     and k+l   = 2n
    !!--..     and h+l   = 2n                   All-face centred                    F
    !!--..    or h,k,l all odd
    !!--..    or h,k,l all even
    !!--..
    !!--..        -h+k+l = 3n                   Rhombohedrally centred,             R
    !!--..                                      obverse setting
    !!--..
    !!--..         h-k+l = 3n                   Rhombohedrally centred,             R
    !!--..                                      reverse setting
    !!--..
    !!--.. Glide Planes and Screw Axes: Table 2.13.2
    !!--..
    !!--..         0 k l:    k=2n    b/2             monoclinic, orthorhombic, tetragonal and cubic
    !!--..         0 k l:    l=2n    c/2             monoclinic, orthorhombic, tetragonal and cubic
    !!--..         0 k l:  k+l=2n    b/2 +  c/2      monoclinic, orthorhombic, tetragonal and cubic
    !!--..         0 k l:  k+l=4n    b/4 +- c/4      orthorhombic and cubic
    !!--..
    !!--..         h 0 l:    h=2n    a/2             monoclinic, orthorhombic, tetragonal and cubic
    !!--..         h 0 l:    l=2n    c/2             monoclinic, orthorhombic, tetragonal and cubic
    !!--..         h 0 l:  l+h=2n    c/2 +  a/2      monoclinic, orthorhombic, tetragonal and cubic
    !!--..         h 0 l:  l+h=4n    c/4 +- a/4      orthorhombic and cubic
    !!--..
    !!--..         h k 0:    h=2n    a/2             monoclinic, orthorhombic, tetragonal and cubic
    !!--..         h k 0:    k=2n    b/2             monoclinic, orthorhombic, tetragonal and cubic
    !!--..         h k 0:  h+k=2n    a/2 +  b/2      monoclinic, orthorhombic, tetragonal and cubic
    !!--..         h k 0:  h+k=4n    a/4 +- b/4      monoclinic, orthorhombic, tetragonal and cubic
    !!--..
    !!--..         h  -h   0 l:  l=2n    c/2      hexagonal   (c)
    !!--..         0   k  -k l:  l=2n    c/2      hexagonal   (c)
    !!--..        -h   0   h l:  l=2n    c/2      hexagonal   (c)
    !!--..         h   h -2h l:  l=2n    c/2      hexagonal   (c)
    !!--..       -2h   h   h l:  l=2n    c/2      hexagonal   (c)
    !!--..         h -2h   h l:  l=2n    c/2      hexagonal   (c)
    !!--..
    !!--..         h    h    l:   l=2n    c/2    (1-10)   rhomboedral
    !!--..         h    k    k:   h=2n    c/2    (01-1)   rhomboedral
    !!--..         h    k    h:   k=2n    c/2    (-101)   rhomboedral
    !!--..
    !!--..         h    h    l:    l=2n    c/2                  (1-10)   (c,n) tetragonal and cubic
    !!--..         h    h    l: 2h+l=4n    a/4 +- b/4 +- c/4    (1-10)   (d)   tetragonal and cubic
    !!--..         h   -h    l:    l=2n    c/2                  (110)    (c,n) tetragonal and cubic
    !!--..         h   -h    l: 2h+l=4n    a/4 +- b/4 +- c/4    (110)    (d)   tetragonal and cubic
    !!--..
    !!--..         h    k    k:    h=2n    a/2                  (01-1)   (a,n) cubic
    !!--..         h    k    k: 2k+h=4n  +-a/4 + b/4 +- c/4     (01-1)   (d)   cubic
    !!--..         h    k   -k:    h=2n    a/2                  (011)    (a,n) cubic
    !!--..         h    k   -k: 2k+h=4n  +-a/4 + b/4 +- c/4     (011)    (d)   cubic
    !!--..
    !!--..         h    k    h:    k=2n    b/2                  (-101)   (b,n) cubic
    !!--..         h    k    h: 2h+k=4n  +-a/4 +-b/4 +- c/4     (-101)   (d)   cubic
    !!--..        -h    k    h:    k=2n    b/2                  (101)    (b,n) cubic
    !!--..        -h    k    h: 2h+k=4n  +-a/4 + b/4 +- c/4     (011)    (d)   cubic
    !!--..
    !!--..
    !!--.. Screw Axes:      33 extinctions
    !!--..
    !!--..            axe//x  [100]        axe//y [010]        axe//z [001]
    !!--..
    !!--..   21     h 0 0:  h=2n           0 k 0:  k=2n        0 0 l:   l=2n         mono, ortho, tetra, cubic
    !!--..   42     h 0 0:  h=2n           0 k 0:  k=2n        0 0 l:   l=2n         cubic
    !!--..
    !!--..   41     h 0 0:  h=4n           0 k 0:  k=4n        0 0 l:   l=4n         cubic
    !!--..   43     h 0 0:  h=4n           0 k 0:  k=4n        0 0 l:   l=4n         cubic
    !!--..
    !!--..   63                                              0 0 0 l:   l=2n         hexa
    !!--..   31                                              0 0 0 l:   l=3n         hexa
    !!--..   32                                              0 0 0 l:   l=3n         hexa
    !!--..   62                                              0 0 0 l:   l=3n         hexa
    !!--..   64                                              0 0 0 l:   l=3n         hexa
    !!--..
    !!--..   61                                              0 0 0 l:   l=6n         hexa
    !!--..   65                                              0 0 0 l:   l=6n         hexa
    !!--..
    !!----
    !!---- Update: May - 2005
    !!
    character(len=80), dimension(58),  public :: Hkl_Ref_Conditions

    !!----
    !!---- TYPE :: REFLECT_TYPE
    !!--..
    !!---- Type, public :: Reflect_Type
    !!----    integer,dimension(3) :: H    ! H
    !!----    integer              :: Mult ! mutiplicity
    !!----    real(kind=cp)        :: S    ! Sin(Theta)/lambda
    !!---- End Type Reflect_Type
    !!----
    !!---- Update: February - 2005
    !!
    Type, public :: Reflect_Type
       integer,dimension(3) :: H     ! H
       integer              :: Mult  ! mutiplicity
       real(kind=cp)        :: S     ! Sin(Theta)/lambda=1/2d
    End Type Reflect_Type

    !!----
    !!---- TYPE :: REFLECTION_TYPE
    !!--..
    !!---- Type, public :: Reflection_Type
    !!----    integer,dimension(3) :: H    ! H
    !!----    integer              :: Mult ! mutiplicity
    !!----    real(kind=cp)        :: Fo   ! Observed Structure Factor
    !!----    real(kind=cp)        :: Fc   ! Calculated Structure Factor
    !!----    real(kind=cp)        :: SFo  ! Sigma of  Fo
    !!----    real(kind=cp)        :: S    ! Sin(Theta)/lambda
    !!----    real(kind=cp)        :: W    ! Weight
    !!----    real(kind=cp)        :: Phase! Phase in degrees
    !!----    real(kind=cp)        :: A    ! real part of the Structure Factor
    !!----    real(kind=cp)        :: B    ! Imaginary part of the Structure Factor
    !!----    real(kind=cp)        :: AA   ! Free
    !!----    real(kind=cp)        :: BB   ! Free
    !!---- End Type Reflection_Type
    !!----
    !!---- Update: February - 2005
    !!
    Type, public :: Reflection_Type
       integer,dimension(3) :: H     ! H
       integer              :: Mult  ! mutiplicity
       real(kind=cp)        :: Fo    ! Observed Structure Factor
       real(kind=cp)        :: Fc    ! Calculated Structure Factor
       real(kind=cp)        :: SFo   ! Sigma of  Fo
       real(kind=cp)        :: S     ! Sin(Theta)/lambda
       real(kind=cp)        :: W     ! Weight
       real(kind=cp)        :: Phase ! Phase in degrees
       real(kind=cp)        :: A     ! real part of the Structure Factor
       real(kind=cp)        :: B     ! Imaginary part of the Structure Factor
       real(kind=cp)        :: AA    ! Free
       real(kind=cp)        :: BB    ! Free
    End Type Reflection_Type

    !!----
    !!---- TYPE :: REFLECTION_LIST_TYPE
    !!--..
    !!---- Type, public :: Reflection_List_Type
    !!----    integer                                        :: NRef ! Number of Reflections
    !!----    type(reflection_type),allocatable,dimension(:) :: Ref  ! Reflection List
    !!---- End Type Reflection_List_Type
    !!----
    !!---- Update: February - 2005
    !!
    Type, public :: Reflection_List_Type
       integer                                         :: NRef  ! Number of Reflections
       type(reflection_type),allocatable, dimension(:) :: Ref ! Reflection List
    End Type Reflection_List_Type

    !---- Interfaces Definitions for Overload ----!

    Interface Hkl_Absent
       Module Procedure hkl_AbsentI
       Module Procedure hkl_AbsentR
    End Interface Hkl_Absent

    Interface Hkl_Equal
       Module Procedure Hkl_EqualI
       Module Procedure Hkl_EqualR
    End Interface Hkl_Equal

    Interface Hkl_Equiv
       Module Procedure Hkl_EquivI
       Module Procedure Hkl_EquivR
    End Interface Hkl_Equiv

    Interface Hkl_Mult
       Module Procedure Hkl_MultI
       Module Procedure Hkl_MultR
    End Interface Hkl_Mult

    Interface Hkl_R
       Module Procedure HR_I
       Module Procedure HR_R
    End Interface Hkl_R

    Interface Hkl_S
       Module Procedure HS_I
       Module Procedure HS_R
    End Interface Hkl_S

    Interface Hkl_Equiv_List
       Module Procedure Hkl_Equiv_ListI
       Module Procedure Hkl_Equiv_ListR
    End Interface Hkl_Equiv_List

    Interface Hkl_Rp
       Module Procedure Hkl_RpI
       Module Procedure Hkl_RpR
    End Interface Hkl_Rp

    Interface HKL_GEN_SXTAL
       Module Procedure HKL_GEN_SXTAL_reflection
       Module Procedure HKL_GEN_SXTAL_list
    End Interface HKL_GEN_SXTAL

    Interface Hkl_Uni
       Module Procedure Hkl_Uni_reflect
       Module Procedure Hkl_Uni_reflection
       Module Procedure Hkl_Uni_ReflList
    End Interface Hkl_Uni

    Interface Search_Extinctions
       Module Procedure Search_Extinctions_Iunit
       Module Procedure Search_Extinctions_File
    End Interface Search_Extinctions

    Interface Unit_Cart_Hkl
       Module Procedure Unit_Cart_HklI
       Module Procedure Unit_Cart_HklR
    End Interface Unit_Cart_Hkl

 Contains

    !---- Functions ----!

    !!----
    !!---- Function Asu_Hkl(H, Spacegroup) Result(K)
    !!----    integer, dimension (3),  intent(in) :: h
    !!----    type (Space_Group_Type), intent(in) :: Spacegroup
    !!----    integer, dimension(3)               :: k
    !!----
    !!----    Obtain an equivalent reflection in asymmetric unit using
    !!----    simple transformation rules for each crystal system.
    !!----    When these rules are not satisfied the output is the
    !!----    (0,0,0) reflection. For obtaining a reflection within
    !!----    the asymmetric unit given an input reflection the best
    !!----    is to use the function: Get_Hequiv_Asu
    !!----
    !!--<<
    !!----    We assumed that F(hkl)=F(-h -k -l).
    !!-->>
    !!----    If and error occurs, the function returns also (0,0,0).
    !!----
    !!---- Update: February - 2005
    !!
    Function Asu_Hkl(H,Spacegroup) Result(K)
       !---- Arguments ----!
       integer, dimension (3),  intent(in) :: h
       type (Space_Group_Type), intent(in) :: SpaceGroup
       integer, dimension(3)               :: k

       !---- Local  variables ----!
       character(len=2)  :: inf

       k=0
       if (SpaceGroup%NumSpg > 0 .and. SpaceGroup%NumSpg <= 231) then
          select case (SpaceGroup%NumSpg)
             case (1:2)
                k=asu_hkl_triclinic(h)

             case (3:15)
                inf(1:2)=adjustl(Spacegroup%info(1:2))
                if(inf(1:1) == "-") inf(1:1)=inf(2:2)
                select case (inf(1:1))
                   case ("b")
                      k=asu_hkl_monoclinic(h,"b")
                   case ("c")
                      k=asu_hkl_monoclinic(h,"c")
                   case ("a")
                      k=asu_hkl_monoclinic(h,"a")
                   case default
                      k=asu_hkl_monoclinic(h,"b")
                end select

             case (16:74)
                k=asu_hkl_orthorhombic(h)

             case (75:88)
                k=asu_hkl_tetragonal(h,"4/m  ")

             case (89:142)
                k=asu_hkl_tetragonal(h,"4/mmm")

             case (143:148)
                k=asu_hkl_trigonal(h,"-3  ")

             case (149,151,153,157,159,162,163)
                k=asu_hkl_trigonal(h,"-31m")

             case (150,152,154,155,156,158,160,161,164,165,166,167)
                k=asu_hkl_trigonal(h,"-3m")

             case (168:176)
                k=asu_hkl_hexagonal(h,"6/m  ")

             case (177:194)
                k=asu_hkl_hexagonal(h,"6/mmm")

             case (195:206)
                k=asu_hkl_cubic(h,"m-3 ")

             case (207:230)
                k=asu_hkl_cubic(h,"m-3m")

          end select

       else

          !---- General ----!
          select case(SpaceGroup%Laue)
             case("-1   ")
                k=asu_hkl_triclinic(h)
             case("2/m  ")
                k=asu_hkl_monoclinic(h,"b")
             case("mmm  ")
                k=asu_hkl_orthorhombic(h)
             case("4/m  ")
                k=asu_hkl_tetragonal(h,"4/m  ")
             case("4/mmm")
                k=asu_hkl_tetragonal(h,"4/mmm")
             case("-3   ")
                k=asu_hkl_trigonal(h,"-3  ")
             case("-3m  ")
                k=asu_hkl_trigonal(h,"-3m")
             case("6/m  ")
                k=asu_hkl_hexagonal(h,"6/m  ")
             case("6/mmm")
                k=asu_hkl_hexagonal(h,"6/mmm")
             case("m-3  ")
                k=asu_hkl_cubic(h,"m-3 ")
             case("m-3m ")
                k=asu_hkl_cubic(h,"m-3m")
             case default
               return
          end select

       end if

       return
    End Function Asu_Hkl

    !!--++
    !!--++ Function Asu_Hkl_Cubic(H,Mode) Result(K)
    !!--++    integer, dimension (3),  intent(in) :: h
    !!--++    character(len=*),        intent(in) :: Mode
    !!--++    integer, dimension(3)               :: k
    !!--++
    !!--++    (PRIVATE)
    !!--++    Obtain a reflection in asymmetric unit for Cubic
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Asu_Hkl_Cubic(H,Mode) Result(K)
       !---- Argument ----!
       integer, dimension(3), intent(in) :: h
       character(len=*),      intent(in) :: Mode
       integer, dimension(3)             :: k

       !---- Local Variable ----!
       character(len=4)      :: mod_laue
       integer, dimension(3) :: hh

       k=0
       mod_laue=l_case(adjustl(Mode))
       if (len_trim(mod_laue) == 0) then
          return
       end if

       select case(mod_laue)
          case("m-3  ")
             !---- Laue: m-3 ----!
             !---- hkl: h>l, k>l, l>=0 ; hkk: k>=0 h>=k ----!
             select case (h(1))
                case (:-1)
                   hh=-h
                case (0)
                   select case (h(2))
                      case (:-1)
                         hh=-h
                      case (0)
                         if (h(3) >= 0) then
                            hh=h
                         else
                            hh=-h
                         end if
                      case (1:)
                         hh=h
                   end select
                case (1:)
                   hh=h
             end select
             if (hh(3) >=0 .and. hh(1) >= hh(3) .and. hh(2) == hh(3)) k=hh
             if (hh(3) >=0 .and. hh(1) >  hh(3) .and. hh(2) >  hh(3)) k=hh

          case("m-3m ")
             !---- Laue: m-3m ----!
             !---- hkl: h >=0, k >=0, l >=0, h >=k, k >=l ----!
             select case (h(1))
                case (:-1)
                   hh=-h
                case (0)
                   select case (h(2))
                      case (:-1)
                         hh=-h
                      case (0)
                         if (h(3) >= 0) then
                            hh=h
                         else
                            hh=-h
                         end if
                      case (1:)
                         hh=h
                   end select
                case (1:)
                   hh=h
             end select
             if (hh(3) >= 0 .and. hh(2) >= hh(3) .and. hh(1) >= hh(2)) k=hh

          case default
             return
       end select

       return
    End Function Asu_Hkl_Cubic

    !!--++
    !!--++ Function Asu_Hkl_Hexagonal(H,Mode) Result(K)
    !!--++    integer, dimension (3),  intent(in) :: h
    !!--++    character(len=*),        intent(in) :: Mode
    !!--++    integer, dimension(3)               :: k
    !!--++
    !!--++    (PRIVATE)
    !!--++    Obtain a reflection in asymmetric unit for Hexagonal
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Asu_Hkl_Hexagonal(H,Mode) Result(K)
       !---- Argument ----!
       integer, dimension(3), intent(in) :: h
       character(len=*),      intent(in) :: Mode
       integer, dimension(3)             :: k

       !---- Local Variable ----!
       character(len=5)      :: mod_laue
       integer, dimension(3) :: hh

       k=0
       mod_laue=l_case(adjustl(Mode))
       if (len_trim(mod_laue) == 0) then
          return
       end if

       select case(mod_laue)
          case("6/m  ")
             !---- Laue: 6/m ----!
             !---- hkl: h>0,k>0,l>=0;  0kl k>=0,l>=0 ----!
             select case (h(1))
                case (:-1)
                   hh=-h
                case (0)
                   select case (h(2))
                      case (:-1)
                         hh=-h
                      case (0)
                         if (h(3) >= 0) then
                            hh=h
                         else
                            hh=-h
                         end if
                      case (1:)
                         hh=h
                   end select
                case (1:)
                   hh=h
             end select
             if (hh(1) > 0 .and. hh(2) > 0 .and. hh(3) >= 0) k=hh
             if (hh(1) == 0 .and. hh(2) >= 0 .and. hh(3) >= 0) k=hh

          case("6/mmm")
             !---- Laue: 6/mmm ----!
             !---- hkl: h >=0, k >=0, l >=0, h >=k ----!
             select case (h(1))
                case (:-1)
                   hh=-h
                case (0)
                   select case (h(2))
                      case (:-1)
                         hh=-h
                      case (0)
                         if (h(3) >= 0) then
                            hh=h
                         else
                            hh=-h
                         end if
                      case (1:)
                         hh=h
                   end select
                case (1:)
                   hh=h
             end select
             if (hh(2) >=0 .and. hh(1) >= hh(2) .and. hh(3) >= 0) k=hh

          case default
             return
       end select

       return
    End Function Asu_Hkl_Hexagonal

    !!--++
    !!--++ Function Asu_Hkl_Monoclinic(H,Axis) Result(K)
    !!--++    integer, dimension (3),     intent(in) :: h
    !!--++    character(len=*), optional, intent(in) :: axis
    !!--++    integer, dimension(3)                  :: k
    !!--++
    !!--++    (PRIVATE)
    !!--++    Obtain a reflection in asymmetric unit for Monoclinic
    !!--++    Unique axis b: hkl: k >=0, l >=0    hk0: h >=0
    !!--++    Unique axis c: hkl: k >=0, l >=0    h0l: h >=0
    !!--++    Unique axis a: hkl: h >=0, l >=0    0kl: l >=0
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Asu_Hkl_Monoclinic(H,Mode) Result(K)
       !---- Argument ----!
       integer, dimension(3),      intent(in) :: h
       character(len=*), optional, intent(in) :: mode
       integer, dimension(3)                  :: k

       !---- Local Variable ----!
       character(len=1)     :: ax
       integer,dimension(3) :: hh

       k=0
       if (present(mode)) then
          ax=l_case(adjustl(mode))
          if (ax ==" ") ax="b"
       else
          ax="b"
       end if

       select case (ax)
          !---- Laue: 2/m     Unique Axis: b ----!
          !---- hkl: k >=0, l >=0    hk0: h >=0
          case ("b")
             select case (h(3))
                case (:-1)
                   hh=-h
                case (0)
                   select case (h(2))
                      case (:-1)
                         hh=-h
                      case (0)
                         if (h(1) >=0) then
                            hh=h
                         else
                            hh=-h
                         end if
                      case (1:)
                         hh=h
                   end select
                case (1:)
                   hh=h
             end select

             if (hh(3) == 0) then
                if (hh(1) >=0 ) k=hh
             else
                if (hh(2) >=0 .and. hh(3) >=0) k=hh
             end if

          !---- Laue: 2/m     Unique Axis: c ----!
          !---- hkl: k >=0, l >=0    h0l: h >=0
          case ("c")
             select case (h(3))
                case (:-1)
                   hh=-h
                case (0)
                   select case (h(2))
                      case (:-1)
                         hh=-h
                      case (0)
                         if (h(1) >= 0) then
                            hh=h
                         else
                            hh=-h
                         end if
                      case (1:)
                         hh=h
                   end select
                case (1:)
                   hh=h
             end select

             if (hh(2) == 0) then
                if (hh(1) >= 0) k=hh
             else
                if (hh(2) >=0 .and. hh(3) >=0) k=hh
             end if

          !---- Laue: 2/m     Unique Axis: c ----!
          !---- hkl: h >=0, l >=0    0kl: l >=0
          case ("a")
             select case (h(1))
                case (:-1)
                   hh=-h
                case (0)
                   select case (h(3))
                      case (:-1)
                         hh=-h
                      case (0)
                         if (h(2) >= 0) then
                            hh=h
                         else
                            hh=-h
                         end if
                      case (1:)
                         hh=h
                   end select
                case (1:)
                   hh=h
             end select

             if (hh(1) == 0) then
                if (hh(2) >= 0) k=hh
             else
                if (hh(1) >=0 .and. hh(3) >=0) k=hh
             end if

       end select

       return
    End Function Asu_Hkl_Monoclinic

    !!--++
    !!--++ Function Asu_Hkl_Orthorhombic(H) Result(K)
    !!--++    integer, dimension (3),  intent(in) :: h
    !!--++    integer, dimension(3)               :: k
    !!--++
    !!--++    (PRIVATE)
    !!--++    Obtain a reflection in asymmetric unit for Orthorhombic
    !!--++    hkl: h >=0, k >=0, l >=0
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Asu_Hkl_Orthorhombic(H) Result(K)
       !---- Argument ----!
       integer, dimension(3), intent(in) :: h
       integer, dimension(3)             :: k

       !---- Local Variable ----!
       integer, dimension(3) :: hh

       k=0
       !---- Laue: mmm ----!
       !---- hkl: h >=0, k >=0, l >=0 ----!
       select case (h(1))
          case (:-1)
             hh=-h
          case (0)
             select case (h(2))
                case (:-1)
                   hh=-h
                case (0)
                   if (h(3) >= 0) then
                      hh=h
                   else
                      hh=-h
                   end if
                case (1:)
                   hh=h
             end select
          case (1:)
             hh=h
       end select

       if (hh(1) >= 0 .and. hh(2) >= 0 .and. hh(3) >= 0) k=hh

       return
    End Function Asu_Hkl_Orthorhombic

    !!--++
    !!--++ Function Asu_Hkl_Tetragonal(H,Mode) Result(K)
    !!--++    integer, dimension (3),  intent(in) :: h
    !!--++    character(len=*),        intent(in) :: Mode
    !!--++    integer, dimension(3)               :: k
    !!--++
    !!--++    (PRIVATE)
    !!--++    Obtain a reflection in asymmetric unit for Tetragonal
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Asu_Hkl_Tetragonal(H,Mode) Result(K)
       !---- Argument ----!
       integer, dimension(3), intent(in) :: h
       character(len=*),      intent(in) :: Mode
       integer, dimension(3)             :: k

       !---- Local Variable ----!
       character(len=5)     :: mod_laue
       integer,dimension(3) :: hh

       k=0
       mod_laue=l_case(adjustl(Mode))
       if (len_trim(mod_laue) == 0) then
          return
       end if

       select case(mod_laue)
          case("4/m  ")
             !---- Laue: 4/m ----!
             !---- hkl: h >=0, l >=0, k >=0 if h = 0 ----!
             select case (h(1))
                case (:-1)
                   hh=-h
                case (0)
                   select case (h(2))
                      case (:-1)
                         hh=-h
                      case (0)
                         if (h(3) >= 0) then
                            hh=h
                         else
                            hh=-h
                         end if
                      case (1:)
                         hh=h
                   end select
                case (1:)
                   hh=h
             end select
             if (hh(1) == 0 .and. hh(2) >= 0 .and. hh(3) >=0) k=hh
             if (hh(1)  > 0 .and. hh(2) >  0 .and. hh(3) >=0) k=hh

          case("4/mmm")
             !---- Laue: 4/mmm ----!
             !---- hkl: h >=0, l >=0, h >=k   (k >=0) ----!
             select case (h(1))
                case (:-1)
                   hh=-h
                case (0)
                   select case (h(2))
                      case (:-1)
                         hh=-h
                      case (0)
                         if (h(3) >= 0) then
                            hh=h
                         else
                            hh=-h
                         end if
                      case (1:)
                         hh=h
                   end select
                case (1:)
                   hh=h
             end select
             if (hh(1) >=0 .and. hh(2) >=0 .and. hh(3) >=0 .and. hh(1) >= hh(2)) k=hh

          case default
             return
       end select

       return
    End Function Asu_Hkl_Tetragonal

    !!--++
    !!--++ Function Asu_Hkl_Triclinic(H) Result(K)
    !!--++    integer, dimension (3),  intent(in) :: h
    !!--++    integer, dimension(3)               :: k
    !!--++
    !!--++    (PRIVATE)
    !!--++    Obtain a reflection in asymmetric unit for Triclinic
    !!--++    hkl: l >=0    hk0: h >=0    0k0: k >=0
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Asu_Hkl_Triclinic(H) Result(K)
       !---- Argument ----!
       integer, dimension(3), intent(in) :: h
       integer, dimension(3)             :: k

       k=0
       !---- Laue: -1 ----!
       !---- hkl: l >=0    hk0: h >=0    0k0: k >=0
       select case (h(3))
          case (:-1)
             k=-h
          case (0)
             select case (h(1))
                case (:-1)
                   k=-h
                case (0)
                   if (h(2) < 0) then
                      k=-h
                   else
                      k=h
                   end if
                case (1:)
                   k=h
             end select
          case (1:)
             k=h
       end select

       return
    End Function Asu_Hkl_Triclinic

    !!--++
    !!--++ Function Asu_Hkl_Trigonal(H,Mode) Result(K)
    !!--++    integer, dimension (3),  intent(in) :: h
    !!--++    character(len=*),        intent(in) :: Mode
    !!--++    integer, dimension(3)               :: k
    !!--++
    !!--++    (PRIVATE)
    !!--++    Obtain a reflection in asymmetric unit for Trigonal
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Asu_Hkl_Trigonal(H,Mode) Result(K)
       !---- Argument ----!
       integer, dimension(3), intent(in) :: h
       character(len=*),      intent(in) :: Mode
       integer, dimension(3)             :: k

       !---- Local Variable ----!
       character(len=4)      :: mod_laue
       integer, dimension(3) :: hh

       k=0
       mod_laue=l_case(adjustl(Mode))
       if (len_trim(mod_laue) == 0) then
          return
       end if

       select case(mod_laue)
          case("-3  ")
             !---- Laue: -3 ----!
             !---- hkl: h+k>0, l>0 ; hk0:h>0, k>=0
             select case (h(1))
                case (:-1)
                   hh=-h
                case (0)
                   select case (h(2))
                      case (:-1)
                         hh=-h
                      case (0)
                         if (h(3) >= 0) then
                            hh=h
                         else
                            hh=-h
                         end if
                      case (1:)
                         hh=h

                   end select
                case (1:)
                   hh=h
             end select
             if (hh(1) == 0 .and. hh(2) == 0 .and. hh(3) > 0) k=hh
             if (hh(1)+hh(2) > 0 .and. hh(3) > 0 ) k=hh
             if (hh(1) > 0  .and. hh(2) >= 0  .and. hh(3) == 0) k=hh

          case("-3m ")
             !---- Laue: -3m ----!
             !---- hkl: h>=0, h>=k ; hhl: h>=0,l>=0 ----!
             select case (h(1))
                case (:-1)
                   hh=-h
                case (0)
                   select case (h(2))
                      case (:-1)
                         hh=-h
                      case (0)
                         if (h(3) >= 0) then
                            hh=h
                         else
                            hh=-h
                         end if
                      case (1:)
                         hh=h
                   end select
                case (1:)
                   hh=h
             end select
             if (hh(1) >= hh(2) .and.  hh(2) >= 0 ) k=hh
             if (hh(1) >= 0 .and. hh(2) > 0 .and. hh(3) > 0 ) k=hh
             if (hh(1) >= 0 .and. hh(2) == hh(1) .and. hh(3) >=0) k=hh

          case("-31m")
             !---- Laue: -31m ----!
             !---- hkl: h>=0,h>=k>0 ; h0l: h>=0,l>=0 ----!
             select case (h(1))
                case (:-1)
                   hh=-h
                case (0)
                   select case (h(2))
                      case (:-1)
                         hh=-h
                      case (0)
                         if (h(3) >= 0) then
                            hh=h
                         else
                            hh=-h
                         end if
                      case (1:)
                           hh=h
                   end select
                case (1:)
                   hh=h
             end select
             if (hh(1) >= hh(2) .and. hh(1) >=0 .and. hh(2) > 0) k=hh
             if (hh(1) >= 0 .and. hh(2) ==0 .and. hh(3) >= 0) k=hh

          case default
             return
       end select

       return
    End Function Asu_Hkl_Trigonal

    !!----
    !!---- Function  Get_Hequiv_Asu(h,SpaceGroup) result(k)
    !!----    integer, dimension (3),  intent(in) :: h
    !!----    type (Space_Group_Type), intent(in) :: SpaceGroup
    !!----    integer, dimension(3)               :: k
    !!----
    !!----    Provides a reflection equivalent to the input one but
    !!----    within the asymmetric unit
    !!----
    !!---- Update: December - 2005
    !!
    Function Get_Hequiv_Asu(H,Spacegroup) Result(k)
       !---- Arguments ----!
       integer, dimension (3),  intent(in) :: h
       type (Space_Group_Type), intent(in) :: SpaceGroup
       integer, dimension(3)               :: k

       !---- Local Variables ----!
       integer                             :: i
       integer, dimension(3)               :: kk,nul

       k=h
       nul=(/0,0,0/)
       do i=1,SpaceGroup%NumOps
         k=matmul(h,SpaceGroup%SymOp(i)%Rot)
         kk=asu_hkl(k,SpaceGroup)
         if (hkl_equal(kk,nul)) cycle
         k=kk
         exit
       end do
       return
    End Function Get_Hequiv_Asu

    !!----
    !!---- Function  Get_MaxNumRef(SinTLMax, VolCell, SinTLMin, Mult) result(numref)
    !!----    real(kind=cp),           intent(in) :: SinTLMax !Maximum sinTheta/Lambda
    !!----    real(kind=cp),           intent(in) :: VolCell  !Direct Cell Volume
    !!----    real(kind=cp), optional, intent(in) :: SinTLMin !Minimum sinTheta/Lambda
    !!----    Integer,       optional, intent(in) :: Mult     !General Multiplicity
    !!----    Integer                             :: numref
    !!----
    !!----    Provides un upper limit of the expected maximum number of
    !!----    reflections up to SinTLMax for a volume VolCell of the
    !!----    primitive cell. If the optional argument SinTLMin is given,
    !!----    the result is the number of reflections in the interval (SinTLMin,SinTLMax).
    !!----    If Mult is provided the result is divided by half this multiplicity
    !!----    so we obtain an estimation of the expected mumber of unique reflections.
    !!----
    !!---- Update: February - 2005
    !!
    Function Get_MaxNumRef(SinTLMax, VolCell, SinTLMin, Mult) Result(numref)
       !---- Arguments ----!
       real(kind=cp),           intent(in) :: SinTLMax
       real(kind=cp),           intent(in) :: VolCell
       real(kind=cp), optional, intent(in) :: SinTLMin
       integer,       optional, intent(in) :: Mult
       integer                             :: numref

       !---- Local Variables ----!
       real(kind=cp)                      :: r3

       r3=8.0*SinTLMax*SinTLMax*SinTLMax*1.05

       if (present(SinTLMin)) r3= r3-8.0*SinTLMin*SinTLMin*SinTLMin

       numref=4.0*pi*r3*VolCell/3.0
       !The factor 2 is given because, for high symmetry, sometimes the obtained number is
       !not enough for allocating the real number of reflections
       if (present(Mult)) numref=2*numref/max(1,Mult)

       return
    End Function Get_MaxNumRef

    !!----
    !!---- Function  Hkl_Absen(H, Spacegroup)
    !!----    integer/real(kind=cp), dimension(3), intent(in) :: h
    !!----    type (Space_Group_Type),             intent(in) :: SpaceGroup
    !!----
    !!----    Returns the value ".true." if the reflection is absent.
    !!----
    !!---- Update: February - 2005
    !!

    !!--++
    !!--++ Logical Function  Hkl_AbsentI(H, Spacegroup)
    !!--++    integer, dimension(3),   intent(in) :: h
    !!--++    Type (Space_Group_Type), intent(in) :: SpaceGroup
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Calculate if the reflection is an absence
    !!--++
    !!--++  Update: February - 2005
    !!
    Function Hkl_AbsentI(H,Spacegroup) Result(Info)
       !---- Arguments ----!
       integer, dimension(3),   intent (in) :: h
       Type (Space_Group_Type), intent (in) :: SpaceGroup
       logical                              :: info

       !---- Local Variables ----!
       integer, dimension(3)              :: k
       integer                            :: i
       real(kind=cp)                      :: r1,r2

       info=.false.

       do i=1,SpaceGroup%multip
          k = hkl_r(h,SpaceGroup%SymOp(i))
          if (hkl_equal(h,k)) then
             r1=dot_product(SpaceGroup%SymOp(i)%Tr,real(h))
             r2=nint(r1)
             if (abs(r1-r2) > eps_ref) then
                info=.true.
                exit
             end if
          end if
       end do

       return
    End Function Hkl_AbsentI

    !!--++
    !!--++ Logical Function Hkl_AbsentR(H, Spacegroup)
    !!--++    real(kind=cp), dimension(3), intent(in) :: h
    !!--++    Type (Space_Group_Type),     intent(in) :: SpaceGroup
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Calculate if the reflection is an absence
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Hkl_AbsentR(H,Spacegroup) Result(Info)
       !---- Arguments ----!
       real(kind=cp), dimension(3), intent (in) :: h
       Type (Space_Group_Type),     intent (in) :: SpaceGroup
       logical                                  :: info

       !---- Local Variables ----!
       integer                      :: i
       real(kind=cp), dimension(3)  :: k
       real(kind=cp)                :: r1,r2

       info=.false.
       do i=1,SpaceGroup%multip
          k = hkl_r(h,SpaceGroup%SymOp(i))
          if (hkl_equal(h,k)) then
             r1=dot_product(SpaceGroup%SymOp(i)%Tr,h)
             r2=nint(r1)
             if (abs(r1-r2) > eps_ref) then
                info=.true.
                exit
             end if
          end if
       end do

       return
    End Function Hkl_AbsentR

    !!----
    !!---- Logical Function  Hkl_Equal(H,K)
    !!----    integer/real(kind=cp), dimension(3), intent(in) :: h
    !!----    integer/real(kind=cp), dimension(3), intent(in) :: k
    !!----
    !!----    Calculate if two reflections are equal
    !!----
    !!---- Update: February - 2005
    !!

    !!--++
    !!--++ Logical Function  Hkl_EqualI(H,K)
    !!--++    integer, dimension(3), intent(in) :: h
    !!--++    integer, dimension(3), intent(in) :: k
    !!--++
    !!--++    (OVERLOADED)
    !!--++    True if 2 reflections are equal
    !!--++
    !!--++  Update: February - 2005
    !!
    Function Hkl_EqualI(H,K) Result (Info)
       !---- Arguments ----!
       integer, dimension(3), intent(in) :: h,k
       logical                           :: info

       info=.false.
       if (h(1)==k(1) .and. h(2)==k(2) .and. h(3)==k(3)) info=.true.

       return
    End Function Hkl_EqualI

    !!--++
    !!--++ Logical Function  Hkl_EqualR(H,K)
    !!--++    real(kind=cp), dimension(3), intent(in) :: h
    !!--++    real(kind=cp), dimension(3), intent(in) :: k
    !!--++
    !!--++    (OVERLOADED)
    !!--++    True if 2 reflections are equal
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Hkl_EqualR(H,K) Result (Info)
       !---- Arguments ----!
       real(kind=cp), dimension(3), intent(in) :: h,k
       logical                                 :: info

       info=.false.
       if (abs(h(1)-k(1)) <= eps_ref .and. abs(h(2)-k(2)) <= eps_ref .and. &
           abs(h(3)-k(3)) <= eps_ref) info=.true.

       return
    End Function Hkl_EqualR

    !!----
    !!---- Logical Function  Hkl_Equiv(H,K,Spacegroup,Friedel)
    !!----    integer/real(kind=cp), dimension(3), intent(in) :: h
    !!----    integer/real(kind=cp), dimension(3), intent(in) :: k
    !!----    type (Space_Group_Type),             intent(in) :: SpaceGroup
    !!----    Logical, optional ,                  intent(in) :: Friedel
    !!----
    !!----    Calculate if two reflections are equivalent
    !!----
    !!---- Update: February - 2005
    !!

    !!--++
    !!--++ Logical Function  Hkl_EquivI(H,K, Spacegroup,Friedel)
    !!--++    integer, dimension(3),   intent(in) :: h
    !!--++    integer, dimension(3),   intent(in) :: k
    !!--++    Type (Space_Group_Type), intent(in) :: SpaceGroup
    !!--++    logical, optional,       intent(in) :: Friedel
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Calculate if the reflections are equivalent
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Hkl_EquivI(H,K,Spacegroup,Friedel) Result (Info)
       !---- Arguments ----!
       integer, dimension(3),    intent(in)  :: h,k
       Type (Space_Group_Type),  intent (in) :: SpaceGroup
       logical, optional,        intent(in)  :: Friedel
       logical                               :: info

       !---- Local Variables ----!
       integer                           :: i, nops
       integer, dimension(3)             :: hh

       info=.false.
       nops= SpaceGroup%numops*max(SpaceGroup%centred,1)
       do i=1,nops
          hh = hkl_r(h,SpaceGroup%SymOp(i))
          if (hkl_equal(k,hh)) then
             info=.true.
             exit
          end if
          if (present(Friedel)) then
             if (Friedel) then
                if (hkl_equal(k,-hh)) then
                   info=.true.
                   exit
                end if
             end if
          end if
       end do

       return
    End Function Hkl_EquivI

    !!--++
    !!--++ Logical Function  Hkl_EquivR(H,K, Spacegroup,Friedel)
    !!--++    real(kind=cp), dimension(3),      intent(in) :: h
    !!--++    real(kind=cp), dimension(3),      intent(in) :: k
    !!--++    Type (Space_Group_Type),          intent(in) :: SpaceGroup
    !!--++    logical, optional,                intent(in) :: Friedel
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Calculate if the reflections are equivalent
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Hkl_EquivR(H,K,Spacegroup,Friedel) Result (Info)
       !---- Arguments ----!
       real(kind=cp), dimension(3), intent(in) :: h,k
       Type (Space_Group_Type),     intent(in) :: SpaceGroup
       logical, optional,           intent(in) :: Friedel
       logical                                 :: info

       !---- Local Variables ----!
       integer                            :: i, nops
       real(kind=cp), dimension(3)        :: hh

       info=.false.
       nops= SpaceGroup%numops*max(SpaceGroup%centred,1)
       do i=1, nops
          hh = hkl_r(h,SpaceGroup%SymOp(i))
          if (hkl_equal(k,hh)) then
             info=.true.
             exit
          end if
          if (present(Friedel)) then
             if (Friedel) then
                if (hkl_equal(k,-hh)) then
                   info=.true.
                   exit
                end if
             end if
          end if
       end do

       return
    End Function Hkl_EquivR

    !!--++
    !!--++ Logical Function  Hkl_AbsentI(H, Spacegroup)
    !!--++    integer, dimension(3),   intent(in) :: h
    !!--++    Type (Space_Group_Type), intent(in) :: SpaceGroup
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Calculate if the reflection is a lattice absence
    !!--++
    !!--++  Update: February - 2005
    !!
    Function Hkl_Lat_Absent(H,Latt) Result(Info)
       !---- Arguments ----!
       integer, dimension(3),        intent (in) :: h
       Type (Lattice_Centring_Type), intent (in) :: Latt
       logical                                   :: info

       !---- Local Variables ----!
       integer               :: k,i
       logical               :: tinv
       real(kind=cp)         :: r1,r2

       info=.false.
       if(.not. Latt%set) return
       tinv=.false.
       if(ubound(Latt%Ltr,1) == 4) tinv=.true.
       do i=1,Latt%n_lat
          r1=dot_product(Latt%Ltr(1:3,i),real(h))
          r2=nint(r1)
          k=nint(2.0*r1)
          if(tinv) then  !Time inversion is considered
             if(Latt%Ltr(4,i) > 0.0) then  !No time inversion, lattice centring
               if(mod(k,2) /= 0) info=.true.
               exit
             else !now time inversion is associated with the translation (Anti-translation)
               if (abs(r1-r2) < eps_ref) info=.true.
               exit
             end if
          else  !No time inversion is considered only normal lattice centring vectors
             if(mod(k,2) /= 0) info=.true.
             exit
          end if
       end do
       return
    End Function Hkl_Lat_Absent

    !!----
    !!---- Function  Hkl_Mult(H, Spacegroup, Friedel)
    !!----    integer/real(kind=cp), dimension(3), intent(in) :: h
    !!----    type (Space_Group_Type),             intent(in) :: SpaceGroup
    !!----    Logical,                             intent(in) :: Friedel
    !!----
    !!----    Calculate the multiplicity of the reflection
    !!----
    !!---- Update: February - 2005
    !!

    !!--++
    !!--++ Function  Hkl_MultI(H, Spacegroup,Friedel)
    !!--++    integer, dimension(3),   intent(in) :: h
    !!--++    Type (Space_Group_Type), intent(in) :: SpaceGroup
    !!--++    Logical,                 intent(in) :: Friedel
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Calculate the multiplicity of the reflection
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Hkl_MultI(H,Spacegroup,Friedel) Result(N)
       !---- Arguments ----!
       integer, dimension(3),   intent (in) :: h
       Type (Space_Group_Type), intent (in) :: SpaceGroup
       Logical,                 intent (in) :: Friedel
       integer                              :: N

       !---- Local Variables ----!
       logical                                :: esta
       integer, dimension(3)                  :: k
       integer                                :: i,j,ng
       integer, dimension(3,SpaceGroup%numops):: klist

       ng=SpaceGroup%numops
       n=1

       !if NG = 0 (strange case), skip it, fix by Petr
       if (ng > 1) then
           klist(:,1)=h(:)

           do i=2,ng
              k = hkl_r(h,SpaceGroup%SymOp(i))
              esta=.false.
              do j=1,n
                 if (hkl_equal(k,klist(:,j)) .or. hkl_equal(-k,klist(:,j))) then
                    esta=.true.
                    exit
                 end if
              end do
              if (esta) cycle
              n=n+1
              klist(:,n) = k
           end do
       end if
       if (Friedel .or. SpaceGroup%centred == 2) then
           n=n*2
       end if

       return
    End Function Hkl_MultI

    !!--++
    !!--++ Function  Hkl_MultR(H, Spacegroup,Friedel)
    !!--++    real(kind=cp), dimension(3),      intent(in) :: h
    !!--++    Type (Space_Group_Type),          intent(in) :: SpaceGroup
    !!--++    Logical,                          intent(in) :: Friedel
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Calculate the multiplicity of the reflection
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Hkl_MultR(H,Spacegroup,Friedel) Result(N)
       !---- Arguments ----!
       real(kind=cp), dimension(3), intent (in) :: h
       Type (Space_Group_Type),     intent (in) :: SpaceGroup
       Logical,                     intent (in) :: Friedel
       integer                                  :: n

       !---- Local Variables ----!
       logical :: esta
       real(kind=cp), dimension(3)   :: k
       integer                       :: i,j,ng
       real(kind=cp), dimension(3,SpaceGroup%numops):: klist

       ng=SpaceGroup%numops
       n=1
       klist(:,1)=h(:)
       do i=2,ng
          k = hkl_r(h,SpaceGroup%SymOp(i))
          esta=.false.
          do j=1,n
             if (hkl_equal(k,klist(:,j)) .or. hkl_equal(-k,klist(:,j))) then
                esta=.true.
                exit
             end if
          end do
          if (esta) cycle
          n=n+1
          klist(:,n) = k
       end do
       if (Friedel .or. SpaceGroup%centred == 2) n=n*2

       return
    End Function Hkl_MultR

    !!----
    !!---- Function  Hkl_R(H,Op)
    !!----    integer/real(kind=cp), dimension(3), intent(in) :: h
    !!----    type (Sym_Oper_Type),                intent(in) :: Op
    !!----
    !!----    Calculate the equivalent reflection
    !!----
    !!---- Update: February - 2005
    !!

    !!--++
    !!--++ Function  Hr_I(H,Op)
    !!--++    integer, dimension(3), intent(in) :: h
    !!--++    type (Sym_Oper_Type),  intent(in) :: Op
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Calculate the equivalent reflection
    !!--++
    !!--++ Update: February - 2005
    !!
    Function HR_I(H,Op) Result(K)
       !---- Arguments ----!
       integer, dimension(3), intent(in) :: h
       Type(Sym_Oper_Type),   intent(in) :: Op
       integer, dimension(3)             :: k

       k = matmul(h,Op%Rot)

    End Function HR_I

    !!--++
    !!--++ Function  Hr_R(H,Op)
    !!--++    real(kind=cp),    dimension(3), intent(in) :: h
    !!--++    type (Sym_Oper_Type),           intent(in) :: Op
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Calculate the equivalent reflection
    !!--++
    !!--++ Update: February - 2005
    !!
    Function HR_R(H,Op) Result(K)
       !---- Arguments ----!
       real(kind=cp), dimension(3),  intent(in) :: h
       Type(Sym_Oper_Type),          intent(in) :: Op
       real(kind=cp), dimension(3)              :: k

       k = matmul(h,Op%Rot)

       return
    End Function HR_R

    !!----
    !!---- Function  Hkl_S(H, Crystalcell)
    !!----    integer/real(kind=cp), dimension(3), intent(in) :: h
    !!----    type (Crystal_Cell_Type),            intent(in) :: CrystalCell
    !!--<<
    !!----    Calculates: sin_theta/lamda = 1/(2d)
    !!-->>
    !!----
    !!----  Update: February - 2005
    !!

    !!--++
    !!--++ FUNCTION  HS_I(h, CrystalCell)
    !!--++    integer, dimension(3),    intent(in) :: h
    !!--++    Type (Crystal_Cell_Type), intent(in) :: CrystalCell
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Calculate sin_theta/lamda = 1/ (2d)
    !!--++
    !!--++ Update: February - 2005
    !!
    Function HS_I(H,Crystalcell) Result(S)
       !---- Arguments ----!
       integer, dimension(3),    intent(in)  :: h
       type (Crystal_Cell_Type), intent (in) :: CrystalCell
       real(kind=cp)                         :: s

       s= 0.5*sqrt( h(1)*h(1)*CrystalCell%GR(1,1) + h(2)*h(2)*CrystalCell%GR(2,2) + &
                    h(3)*h(3)*CrystalCell%GR(3,3) + 2.0*h(1)*h(2)*CrystalCell%GR(1,2) + &
                2.0*h(1)*h(3)*CrystalCell%GR(1,3) + 2.0*h(2)*h(3)*CrystalCell%GR(2,3) )

       return
    End Function HS_I

    !!--++
    !!--++ Function  HS_R(H, Crystalcell)
    !!--++    real(kind=cp), dimension(3),       intent(in) :: h
    !!--++    Type (Crystal_Cell_Type),          intent(in) :: CrystalCell
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Calculate sin_theta/lamda = 1/ (2d)
    !!--++
    !!--++ Update: February - 2005
    !!
    Function HS_R(H,Crystalcell) Result(S)
       !---- Arguments ----!
       real(kind=cp), dimension(3),intent(in)  :: h
       type (Crystal_Cell_Type),   intent (in) :: CrystalCell
       real(kind=cp)                           :: s

       s= 0.5*sqrt( h(1)*h(1)*CrystalCell%GR(1,1) + h(2)*h(2)*CrystalCell%GR(2,2) + &
                    h(3)*h(3)*CrystalCell%GR(3,3) + 2.0*h(1)*h(2)*CrystalCell%GR(1,2) + &
                2.0*h(1)*h(3)*CrystalCell%GR(1,3) + 2.0*h(2)*h(3)*CrystalCell%GR(2,3) )

       return

    End Function HS_R

    !!----
    !!----  Function  Unit_Cart_Hkl(H, Crystalcell) Result (U)
    !!----     integer/real(kind=cp), dimension(3), intent(in) :: h
    !!----     type (Crystal_Cell_Type),            intent(in) :: CrystalCell
    !!----
    !!----     Calculate a unitary vector in the cartesian crystal frame
    !!----     along a reciprocal vector hkl (reciprocal lattice)
    !!----
    !!---- Update: February - 2005
    !!

    !!--++
    !!--++ Function Unit_Cart_Hkli(H, Crystalcell) Result (U)
    !!--++    integer, dimension(3),    intent(in) :: h
    !!--++    Type (Crystal_Cell_Type), intent(in) :: CrystalCell
    !!--++    real(kind=cp),dimension(3)           :: u
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Calculate a unitary vector in the cartesian crystal
    !!--++    frame along a reciprocal vector hkl (reciprocal lattice)
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Unit_Cart_HklI(H, Crystalcell) Result (U)
       !---- Arguments ----!
       integer, dimension(3),    intent(in)  :: h
       type (Crystal_Cell_Type), intent (in) :: CrystalCell
       real(kind=cp), dimension(3)           :: u

       !---- Local Variables ----!
       real(kind=cp), dimension(3)           :: v

       v=matmul(CrystalCell%GR,real(h))     ![L-2]
       u=matmul(CrystalCell%Cr_Orth_cel,v)  ![L-1]
       u=u/sqrt(u(1)*u(1)+u(2)*u(2)+u(3)*u(3))

       return
    End Function Unit_Cart_HklI


    !!--++
    !!--++ Function Unit_Cart_HklR(H, Crystalcell) Result (U)
    !!--++    real(kind=cp), dimension(3),       intent(in) :: h
    !!--++    Type (Crystal_Cell_Type),          intent(in) :: CrystalCell
    !!--++    real(kind=cp),dimension(3)                    :: u
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Calculate a unitary vector in the cartesian crystal
    !!--++    frame along a reciprocal vector hkl (reciprocal lattice)
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Unit_Cart_HklR(H, Crystalcell) Result (U)
       !---- Arguments ----!
       real(kind=cp), dimension(3),intent(in)  :: h
       type (Crystal_Cell_Type),   intent (in) :: CrystalCell
       real(kind=cp), dimension(3)             :: u

       !---- Local Variables ----!
       real(kind=cp), dimension(3)             :: v

       v=matmul(CrystalCell%GR,h)
       u=matmul(CrystalCell%Cr_Orth_cel,v)
       u=u/sqrt(u(1)*u(1)+u(2)*u(2)+u(3)*u(3))

       return
    End Function Unit_Cart_HklR

    !---- Subroutines ----!

    !!--++
    !!--++ Subroutine Glide_Planes_Conditions(Spacegroup, iunit)
    !!--++    type (Space_Group_Type), intent(in) :: Spacegroup
    !!--++    integer,optional,        intent(in) :: iunit
    !!--++
    !!--++    Reflections Conditions according with I.T. Table 2.2.13.2
    !!--++    space.
    !!--++
    !!--++ Update: May - 2005
    !!
    Subroutine Glide_Planes_Conditions(Spacegroup,Iunit)
       !---- Arguments ----!
       type (Space_Group_Type), intent(in)     :: spacegroup
       integer, optional,       intent(in)     :: iunit

       !---- Local variables ----!
       integer               :: h, k,l, m
       integer               :: n, n_ext
       integer, dimension(3) :: hh
       integer               :: num_exti
       logical               :: zonal_condition

       zonal_condition   = .false.

       if (present(iunit) ) then
          write(unit=iunit,fmt=*) " "
          write(unit=iunit,fmt=*) " >>> Zonal reflections conditions for glide planes:"
          write(unit=iunit,fmt=*) "---------------------------------------------------"
          write(unit=iunit,fmt=*) " "
       end if

       !GLIDE PLANES and screw axes: table 2.13.2
       !-------------
       !
       !        0 k l:    k=2n    b/2             monoclinic, orthorhombic, tetragonal and cubic
       !        0 k l:    l=2n    c/2             monoclinic, orthorhombic, tetragonal and cubic
       !        0 k l:  k+l=2n    b/2 +  c/2      monoclinic, orthorhombic, tetragonal and cubic
       !        0 k l:  k+l=4n    b/4 +- c/4      orthorhombic and cubic
       !
       !
       !        h 0 l:    h=2n    a/2             monoclinic, orthorhombic, tetragonal and cubic
       !        h 0 l:    l=2n    c/2             monoclinic, orthorhombic, tetragonal and cubic
       !        h 0 l:  l+h=2n    c/2 +  a/2      monoclinic, orthorhombic, tetragonal and cubic
       !        h 0 l:  l+h=4n    c/4 +- a/4      orthorhombic and cubic
       !
       !        h k 0:    h=2n    a/2             monoclinic, orthorhombic, tetragonal and cubic
       !        h k 0:    k=2n    b/2             monoclinic, orthorhombic, tetragonal and cubic
       !        h k 0:  h+k=2n    a/2 +  b/2      monoclinic, orthorhombic, tetragonal and cubic
       !        h k 0:  h+k=4n    a/4 +- b/4      monoclinic, orthorhombic, tetragonal and cubic

       if (SpaceGroup%CrystalSys(1:10) == "Monoclinic"   .or. SpaceGroup%CrystalSys(1:10) == "Tetragonal" .or.     &
           SpaceGroup%CrystalSys(1:12) == "Orthorhombic" .or. SpaceGroup%CrystalSys(1:5)  == "Cubic") then

          !---- glide plane b/2:
          ! Hkl_Ref_Conditions(7)  =   "(0 k l)      k=2n : 0yz glide plane with b/2 translation"
          num_exti = 7
          n = 0       ! nombre de reflections pouvant obeir a la regle d"extinction
          n_ext = 0   ! nombre de reflecions obeissant a la regle
          do k=-6, 6
             do l=-6, 6
                hh(1)=0
                hh(2)=k
                hh(3)=l
                m =  k
                if (m /= int(m/2)*2) then
                   n=n+1
                   if (hkl_absent(hh,Spacegroup)) n_ext=n_ext+1
                end if
             end do   ! l loop
          end do    ! k loop
          if (n==n_ext) then
             if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti,": ", Hkl_Ref_Conditions(num_exti)
             zonal_condition = .true.
          end if

          !---- glide plane c/2:
          ! Hkl_Ref_Conditions(8)  =   "(0 k l)      l=2n : 0yz glide plane with c/2 translation"
          num_exti = 8
          n = 0       ! nombre de reflections pouvant obeir a la regle d"extinction
          n_ext = 0   ! nombre de reflecions obeissant a la regle
          do k=-6, 6
             do l=-6, 6
                hh(1)=0
                hh(2)=k
                hh(3)=l
                m =  l
                if (m /= int(m/2)*2) then
                   n=n+1
                   if (hkl_absent(hh,Spacegroup)) n_ext=n_ext+1
                end if
             end do   ! l loop
          end do    ! k loop
          if (n==n_ext) then
             if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti,": ", Hkl_Ref_Conditions(num_exti)
             zonal_condition = .true.
          end if

          !---- glide plane b/2 + c/2:
          !Hkl_Ref_Conditions(9)  =   "(0 k l)    k+l=2n : 0yz glide plane with b/2 + c/2 translation"
          num_exti = 9
          n = 0       ! nombre de reflections pouvant obeir a la regle d"extinction
          n_ext = 0   ! nombre de reflecions obeissant a la regle
          do k=-6, 6
             do l=-6, 6
                hh(1)=0
                hh(2)=k
                hh(3)=l
                m =  k+l
                if (m /= int(m/2)*2) then
                   n=n+1
                   if (hkl_absent(hh,Spacegroup)) n_ext=n_ext+1
                end if
             end do   ! l loop
          end do    ! k loop
          if (n==n_ext) then
             if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti,": ", Hkl_Ref_Conditions(num_exti)
             zonal_condition = .true.
          end if
       end if    ! fin de la condition "if monoclinic, tetragonal, ortho, cubic


       if (SpaceGroup%CrystalSys(1:12) == "Orthorhombic" .or. SpaceGroup%CrystalSys(1:5)  == "Cubic") then
          !---- glide plane b/4 + c/4:
          ! Hkl_Ref_Conditions(10)  =   "(0 k l)    k+l=4n : 0yz glide plane with b/4 +- c/4 translation"
          num_exti = 10
          n = 0       ! nombre de reflections pouvant obeir a la regle d"extinction
          n_ext = 0   ! nombre de reflecions obeissant a la regle
          do k=-6, 6, 1
             do l=-6, 6, 1
                hh(1)=0
                hh(2)=k
                hh(3)=l
                m =  k+l
                if (m /= int(m/4)*4) then
                   n=n+1
                   if (hkl_absent(hh,Spacegroup)) n_ext=n_ext+1
                end if
             end do   ! l loop
          end do    ! k loop
          if (n==n_ext) then
             if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti,": ", Hkl_Ref_Conditions(num_exti)
             zonal_condition = .true.
          end if
       end if ! fin de la condition "if ortho, cubic

       if (SpaceGroup%CrystalSys(1:10) == "Monoclinic"   .or. SpaceGroup%CrystalSys(1:10) == "Tetragonal" .or.     &
          SpaceGroup%CrystalSys(1:12) == "Orthorhombic" .or. SpaceGroup%CrystalSys(1:5)  == "Cubic") then

          !---- glide plane a/2:
          !  Hkl_Ref_Conditions(11)  =   "(h 0 l)      h=2n : x0z glide plane with a/2 translation"
          num_exti = 11
          n = 0       ! nombre de reflections pouvant obeir a la regle d"extinction
          n_ext = 0   ! nombre de reflecions obeissant a la regle
          do h=-6, 6
             do l=-6, 6
                hh(1)=h
                hh(2)=0
                hh(3)=l
                m =  h
                if (m /= int(m/2)*2) then
                   n=n+1
                   if (hkl_absent(hh,Spacegroup)) n_ext=n_ext+1
                end if
             end do   ! l loop
          end do     ! h loop
          if (n==n_ext) then
             if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti,": ", Hkl_Ref_Conditions(num_exti)
             zonal_condition = .true.
          end if

          !---- glide plane c/2:
          ! Hkl_Ref_Conditions(12) =   "(h 0 l)      l=2n : x0z glide plane with c/2 translation"
          num_exti = 12
          n = 0       ! nombre de reflections pouvant obeir a la regle d"extinction
          n_ext = 0   ! nombre de reflecions obeissant a la regle
          do h=-6, 6
             do l=-6, 6
                hh(1)=h
                hh(2)=0
                hh(3)=l
                m =  l
                if (m /= int(m/2)*2) then
                   n=n+1
                   if (hkl_absent(hh,Spacegroup)) n_ext=n_ext+1
                end if
             end do   ! l loop
          end do     ! h loop
          if (n==n_ext) then
             if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti,": ", Hkl_Ref_Conditions(num_exti)
             zonal_condition = .true.
          end if

          !---- glide plane c/2 + a/2:
          ! Hkl_Ref_Conditions(13) =   "(h 0 l)    l+h=2n : x0z glide plane with a/2 + c/2 translations"
          num_exti = 13
          n = 0       ! nombre de reflections pouvant obeir a la regle d"extinction
          n_ext = 0   ! nombre de reflecions obeissant a la regle
          do h=-6, 6
             do l=-6, 6
                hh(1)=h
                hh(2)=0
                hh(3)=l
                m =  h+l
                if (m /= int(m/2)*2) then
                   n=n+1
                   if (hkl_absent(hh,Spacegroup)) n_ext=n_ext+1
                end if
             end do   ! l loop
          end do     ! h loop
          if (n==n_ext) then
             if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti,": ", Hkl_Ref_Conditions(num_exti)
             zonal_condition = .true.
          end if
       end if  ! fin de la condition "if monoclinic, tetragonal, ortho, cubic

       if (SpaceGroup%CrystalSys(1:12) == "Orthorhombic" .or. SpaceGroup%CrystalSys(1:5)  == "Cubic") then

          !---- glide plane c/4 + a/4:
          ! Hkl_Ref_Conditions(14) =   "(h 0 l)    l+h=4n : x0z glide plane with a/4 +- c/4 translations"
          num_exti = 14
          n = 0       ! nombre de reflections pouvant obeir a la regle d"extinction
          n_ext = 0   ! nombre de reflecions obeissant a la regle
          do h=-6, 6
             do l=-6, 6
                hh(1)=h
                hh(2)=0
                hh(3)=l
                m =  h+l
                if (m /= int(m/4)*4) then
                   n=n+1
                   if (hkl_absent(hh,Spacegroup)) n_ext=n_ext+1
                end if
             end do   ! l loop
          end do     ! h loop
          if (n==n_ext) then
             if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti,": ", Hkl_Ref_Conditions(num_exti)
             zonal_condition = .true.
          end if
       end if ! fin de la condition "if ortho, cubic

       if (SpaceGroup%CrystalSys(1:10) == "Monoclinic"   .or. SpaceGroup%CrystalSys(1:10) == "Tetragonal" .or.     &
          SpaceGroup%CrystalSys(1:12) == "Orthorhombic" .or. SpaceGroup%CrystalSys(1:5)  == "Cubic") then

          !---- glide plane a/2:
          ! Hkl_Ref_Conditions(15) =   "(h k 0)      h=2n : xy0 glide plane with a/2 translation"
          num_exti = 15
          n = 0       ! nombre de reflections pouvant obeir a la regle d"extinction
          n_ext = 0   ! nombre de reflecions obeissant a la regle
          do h=-6, 6
             do k=-6, 6
                hh(1)=h
                hh(2)=k
                hh(3)=0
                m =  h
                if (m /= int(m/2)*2) then
                   n=n+1
                   if (hkl_absent(hh,Spacegroup)) n_ext=n_ext+1
                end if
             end do    ! k loop
          end do     ! h loop
          if (n==n_ext) then
             if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti,": ", Hkl_Ref_Conditions(num_exti)
             zonal_condition = .true.
          end if

          !---- glide plane b/2:
          !Hkl_Ref_Conditions(16) =   "(h k 0)      k=2n : xy0 glide plane with b/2 translation"
          num_exti = 16
          n = 0       ! nombre de reflections pouvant obeir a la regle d"extinction
          n_ext = 0   ! nombre de reflecions obeissant a la regle
          do h=-6, 6
             do k=-6, 6
                hh(1)=h
                hh(2)=k
                hh(3)=0
                m =  k
                if (m /= int(m/2)*2) then
                   n=n+1
                  if (hkl_absent(hh,Spacegroup)) n_ext=n_ext+1
                end if
             end do    ! k loop
          end do     ! h loop
          if (n==n_ext) then
             if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti,": ", Hkl_Ref_Conditions(num_exti)
             zonal_condition = .true.
          end if

          !---- glide plane a/2 + b/2:
          ! Hkl_Ref_Conditions(17) =   "(h k 0)    h+k=2n : xy0 glide plane with a/2 + b/2 translations"
          num_exti = 17
          n = 0       ! nombre de reflections pouvant obeir a la regle d"extinction
          n_ext = 0   ! nombre de reflecions obeissant a la regle
          do h=-6, 6
             do k=-6, 6
                hh(1)=h
                hh(2)=k
                hh(3)=0
                m =  h+k
                if (m /= int(m/2)*2) then
                   n=n+1
                   if (hkl_absent(hh,Spacegroup)) n_ext=n_ext+1
                end if
             end do    ! k loop
          end do     ! h loop
          if (n==n_ext) then
             if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti,": ", Hkl_Ref_Conditions(num_exti)
             zonal_condition = .true.
          end if
       end if  ! fin de la condition "if monoclinic, tetragonal, ortho, cubic

       if (SpaceGroup%CrystalSys(1:12) == "Orthorhombic" .or. SpaceGroup%CrystalSys(1:5)  == "Cubic") then
          !---- glide plane a/4 + b/4:
          ! Hkl_Ref_Conditions(18) =   "(h k 0)    h+k=4n : xy0 glide plane with a/4 +- b/4 translations"
          num_exti = 18
          n = 0       ! nombre de reflections pouvant obeir a la regle d"extinction
          n_ext = 0   ! nombre de reflecions obeissant a la regle
          do h=-6, 6, 1
             do k=-6, 6, 1
                hh(1)=h
                hh(2)=k
                hh(3)=0
                m =  h+k
                if (m /= int(m/4)*4) then
                   n=n+1
                   if (hkl_absent(hh,Spacegroup)) n_ext=n_ext+1
                end if
             end do    ! k loop
          end do     ! h loop
          if (n==n_ext) then
             if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti,": ", Hkl_Ref_Conditions(num_exti)
             zonal_condition = .true.
          end if
       end if  ! fin de la condition "if ortho, cubic

       if (SpaceGroup%SPG_Latsy(1:1) == "h") then
          !---- glide plane with c/2 translation: hexagonal
          !  Hkl_Ref_Conditions(19) =   "(  h  -h   0 l) l=2n : (11-20) glide plane with c/2 translation (c)"
          num_exti = 19
          n = 0
          n_ext = 0
          do h=-6, +6, 1
             do l=-6, +6, 1
                hh(1)=h
                hh(2)=-h
                hh(3)=l
                m=l
                if (m /=int(m/2)*2) then
                   n=n+1
                   if (hkl_absent(hh, spacegroup)) n_ext=n_ext+1
                end if
             end do  ! l loop
          end do   ! h loop
          if (n==n_ext) then
             if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti,": ", Hkl_Ref_Conditions(num_exti)
             zonal_condition = .true.
          end if

          !---- glide plane with c/2 translation: hexagonal
          !  Hkl_Ref_Conditions(20) =   "(  0   k  -k l) l=2n : (-2110) glide plane with c/2 translation (c)"
          num_exti = 20
          n = 0
          n_ext = 0
          do k=-6, +6, 1
             do l=-6, +6, 1
                hh(1)=0
                hh(2)=k
                hh(3)=l
                m=l
                if (m /=int(m/2)*2) then
                   n=n+1
                   if (hkl_absent(hh, spacegroup)) n_ext=n_ext+1
                end if
             end do  ! l loop
          end do   ! h loop
          if (n==n_ext) then
             if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti,": ", Hkl_Ref_Conditions(num_exti)
             zonal_condition = .true.
          end if

          !---- glide plane with c/2 translation: hexagonal
          !Hkl_Ref_Conditions(21) =   "( -h   0   h l) l=2n : (1-210) glide plane with c/2 translation (c)"
          num_exti = 21
          n = 0
          n_ext = 0
          do h=-6, 6
             do l=-6, 6
                hh(1)=-h
                hh(2)=0
                hh(3)=l
                m=l
                if (m /=int(m/2)*2) then
                   n=n+1
                   if (hkl_absent(hh, spacegroup)) n_ext=n_ext+1
                end if
             end do  ! l loop
          end do   ! h loop
          if (n==n_ext) then
             if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti,": ", Hkl_Ref_Conditions(num_exti)
             zonal_condition = .true.
          end if

          !---- glide plane with c/2 translation: hexagonal
          ! Hkl_Ref_Conditions(22) =   "(  h   h -2h l) l=2n : (1-100) glide plane with c/2 translation (c)"
          num_exti = 22
          n = 0
          n_ext = 0
          do h=-6, +6, 1
             do l=-6, +6, 1
                hh(1)=h
                hh(2)=h
                hh(3)=l
                m=l
                if (m /=int(m/2)*2) then
                   n=n+1
                   if (hkl_absent(hh, spacegroup)) n_ext=n_ext+1
                end if
             end do  ! l loop
          end do   ! h loop
          if (n==n_ext) then
             if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti,": ", Hkl_Ref_Conditions(num_exti)
             zonal_condition = .true.
          end if

          !---- glide plane with c/2 translation: hexagonal
          !  Hkl_Ref_Conditions(23) =   "(-2h   h   h l) l=2n : (01-10) glide plane with c/2 translation (c)"
          num_exti = 23
          n = 0
          n_ext = 0
          do h=-6, +6, 1
             do l=-6, +6, 1
                hh(1)=-2*h
                hh(2)=h
                hh(3)=l
                m=l
                if (m /=int(m/2)*2) then
                   n=n+1
                   if (hkl_absent(hh, spacegroup)) n_ext=n_ext+1
                end if
             end do  ! l loop
          end do   ! h loop
          if (n==n_ext) then
             if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti,": ", Hkl_Ref_Conditions(num_exti)
             zonal_condition = .true.
          end if

          !---- glide plane with c/2 translation: hexagonal
          !  Hkl_Ref_Conditions(24) =   "(  h -2h   h l) l=2n : (-1010) glide plane with c/2 translation (c)"
          num_exti = 24
          n = 0
          n_ext = 0
          do h=-6, +6, 1
             do l=-6, +6, 1
                hh(1)=h
                hh(2)=-2*h
                hh(3)=l
                m=l
                if (m /=int(m/2)*2) then
                   n=n+1
                   if (hkl_absent(hh, spacegroup)) n_ext=n_ext+1
                end if
             end do  ! l loop
          end do   ! h loop
          if (n==n_ext) then
             if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti,": ", Hkl_Ref_Conditions(num_exti)
             zonal_condition = .true.
          end if
       end if ! fin de la condition if hexagonal

       !25: glide plane with c/2 translation: rhomboedral
       !  Hkl_Ref_Conditions(25) =  "(  h  h  l) l=2n : (1-10) glide plane with c/2 translation (c,n)"
       num_exti = 25
       n = 0
       n_ext = 0
       do h=-6, +6, 1
          do l=-6, +6, 1
             hh(1)=h
             hh(2)=h
             hh(3)=l
             m=l
             if (m /=int(m/2)*2) then
                n=n+1
                if (hkl_absent(hh, spacegroup)) n_ext=n_ext+1
             end if
          end do  ! l loop
       end do   ! h loop
       if (n==n_ext) then
          if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti,": ", Hkl_Ref_Conditions(num_exti)
          zonal_condition = .true.
       end if

       !---- glide plane with c/2 translation: rhomboedral
       !  Hkl_Ref_Conditions(26) =  "(  h  k  k) h=2n : (01-1) glide plane with a/2 translation (a,n)"
       num_exti = 26
       n = 0
       n_ext = 0
       do h=-6, +6, 1
          do k=-6, +6, 1
             hh(1)=h
             hh(2)=k
             hh(3)=k
             m=h
             if (m /=int(m/2)*2) then
                n=n+1
                if (hkl_absent(hh, spacegroup)) n_ext=n_ext+1
             end if
          end do  ! l loop
       end do   ! h loop
       if (n==n_ext) then
          if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti,": ", Hkl_Ref_Conditions(num_exti)
          zonal_condition = .true.
       end if

       !27: glide plane with c/2 translation: rhomboedral
       !  Hkl_Ref_Conditions(27) =  "(  h  k  h) k=2n : (-101) glide plane with b/2 translation (b,n)"
       num_exti = 27
       n = 0
       n_ext = 0
       do h=-6, +6, 1
          do k=-6, +6, 1
             hh(1)=h
             hh(2)=k
             hh(3)=h
             m=k
             if (m /=int(m/2)*2) then
                n=n+1
                if (hkl_absent(hh, spacegroup)) n_ext=n_ext+1
             end if
          end do  ! l loop
       end do   ! h loop
       if (n==n_ext) then
          if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti,": ", Hkl_Ref_Conditions(num_exti)
          zonal_condition = .true.
       end if

       if (SpaceGroup%CrystalSys(1:10) == "Tetragonal" .or. SpaceGroup%CrystalSys(1:5) == "Cubic") then
          !---- glide plane with c/2 translation: tetragonal + cubic
          !  Hkl_Ref_Conditions(28) =  "(  h  h  l)    l=2n : (1-10) glide plane with c/2 translation (c,n)"
          num_exti = 28
          n = 0
          n_ext = 0
          do h=-6, +6, 1
             do l=-6, +6, 1
                hh(1)=h
                hh(2)=h
                hh(3)=l
                m=l
                if (m /=int(m/2)*2) then
                   n=n+1
                   if (hkl_absent(hh, spacegroup)) n_ext=n_ext+1
                end if
             end do  ! l loop
          end do   ! h loop
          if (n==n_ext) then
             if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti,": ", Hkl_Ref_Conditions(num_exti)
             zonal_condition = .true.
          end if

          !---- glide plane with a/4 +- b/4 +- c/4 translation: tetragonal + cubic
          !  Hkl_Ref_Conditions(29) =  "(  h  h  l) 2h+l=4n : (1-10) glide plane with a/4 +- b/4 +- c/4 translation (d)"
          num_exti = 29
          n = 0
          n_ext = 0
          do h=-6, +6, 1
             do l=-6, +6, 1
                hh(1)=h
                hh(2)=h
                hh(3)=l
                m=2*h+l
                if (m /=int(m/4)*4) then
                   n=n+1
                   if (hkl_absent(hh, spacegroup)) n_ext=n_ext+1
                end if
             end do  ! l loop
          end do   ! h loop
          if (n==n_ext) then
             if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti,": ", Hkl_Ref_Conditions(num_exti)
             zonal_condition = .true.
          end if

          !30: glide plane with c/2 translation: tetragonal + cubic
          !  Hkl_Ref_Conditions(30) =  "(  h -h  l)    l=2n : (110)  glide plane with c/2 translation (c,n)"
          num_exti = 30
          n = 0
          n_ext = 0
          do h=-6, +6, 1
             do l=-6, +6, 1
                hh(1)=h
                hh(2)=-h
                hh(3)=l
                m=l
                if (m /=int(m/2)*2) then
                   n=n+1
                   if (hkl_absent(hh, spacegroup)) n_ext=n_ext+1
                end if
             end do  ! l loop
          end do   ! h loop
          if (n==n_ext) then
             if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti,": ", Hkl_Ref_Conditions(num_exti)
             zonal_condition = .true.
          end if

          ! 31: glide plane with a/4 +- b/4 +- c/4 translation: tetragonal + cubic
          !  Hkl_Ref_Conditions(31) = "(  h -h  l) 2h+l=4n : (110)  glide plane with a/4 +- b/4 +- c/4 translation (d)"
          num_exti = 31
          n = 0
          n_ext = 0
          do h=-6, +6, 1
             do l=-6, +6, 1
                hh(1)=h
                hh(2)=-h
                hh(3)=l
                m=2*h+l
                if (m /=int(m/4)*4) then
                   n=n+1
                   if (hkl_absent(hh, spacegroup)) n_ext=n_ext+1
                end if
             end do  ! l loop
          end do   ! h loop
          if (n==n_ext) then
             if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti,": ", Hkl_Ref_Conditions(num_exti)
             zonal_condition = .true.
          end if
       end if   ! fin de la condition "if tetragonal .or. cubic

       if (SpaceGroup%CrystalSys(1:5) == "Cubic") then
          !---- glide plane with a/2 translation: tetragonal + cubic
          !  Hkl_Ref_Conditions(32) = "(  h  k  k)    h=2n : (01-1) glide plane with a/2 translation (a,n)"
          num_exti = 32
          n = 0
          n_ext = 0
          do h=-6, +6, 1
             do k=-6, +6, 1
                hh(1)=h
                hh(2)=k
                hh(3)=k
                m=h
                if (m /=int(m/2)*2) then
                   n=n+1
                   if (hkl_absent(hh, spacegroup)) n_ext=n_ext+1
                end if
             end do  ! l loop
          end do   ! h loop
          if (n==n_ext) then
             if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti,": ", Hkl_Ref_Conditions(num_exti)
             zonal_condition = .true.
          end if

          !---- glide plane with +-a/4 +- b/4 +- c/4 translation: tetragonal + cubic
          !  Hkl_Ref_Conditions(33) = "(  h  k  k) 2k+h=4n : (01-1) glide plane with +-a/4 + b/4 +- c/4 translation (d)"
          num_exti = 33
          n = 0
          n_ext = 0
          do h=-6, +6, 1
             do k=-6, +6, 1
                hh(1)=h
                hh(2)=k
                hh(3)=k
                m=2*k+h
                if (m /=int(m/4)*4) then
                   n=n+1
                   if (hkl_absent(hh, spacegroup)) n_ext=n_ext+1
                end if
             end do  ! l loop
          end do   ! h loop
          if (n==n_ext) then
             if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti,": ", Hkl_Ref_Conditions(num_exti)
             zonal_condition = .true.
          end if

          !34: glide plane with a/2 translation: tetragonal + cubic
          !  Hkl_Ref_Conditions(34) =  "(  h  k -k)    h=2n : (011)  glide plane with a/2 translation (a,n)"
          num_exti = 34
          n = 0
          n_ext = 0
          do h=-6, +6, 1
             do k=-6, +6, 1
                hh(1)=h
                hh(2)=k
                hh(3)=-k
                m=h
                if (m /=int(m/2)*2) then
                   n=n+1
                   if (hkl_absent(hh, spacegroup)) n_ext=n_ext+1
                end if
             end do  ! l loop
          end do   ! h loop
          if (n==n_ext) then
             if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti,": ", Hkl_Ref_Conditions(num_exti)
             zonal_condition = .true.
          end if

          ! 35: glide plane with a/4 +- b/4 +- c/4 translation: tetragonal + cubic
          !  Hkl_Ref_Conditions(351) = "(  h  k -k) 2k+h=4n : (011)  glide plane with +-a/4 + b/4 +- c/4 translation (d)"
          num_exti = 35
          n = 0
          n_ext = 0
          do h=-6, +6, 1
             do k=-6, +6, 1
                hh(1)=h
                hh(2)=k
                hh(3)=-k
                m=2*k+h
                if (m /=int(m/4)*4) then
                   n=n+1
                   if (hkl_absent(hh, spacegroup)) n_ext=n_ext+1
                end if
             end do  ! l loop
          end do   ! h loop
          if (n==n_ext) then
             if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti,": ", Hkl_Ref_Conditions(num_exti)
             zonal_condition = .true.
          end if

          !36: glide plane with b/2 translation: tetragonal + cubic
          !  Hkl_Ref_Conditions(36) = "(  h  k  h)    k=2n : (-101) glide plane with b/2 translation (b,n)"
          num_exti = 36
          n = 0
          n_ext = 0
          do h=-6, +6, 1
             do k=-6, +6, 1
                hh(1)=h
                hh(2)=k
                hh(3)=h
                m=k
                if (m /=int(m/2)*2) then
                   n=n+1
                   if (hkl_absent(hh, spacegroup)) n_ext=n_ext+1
                end if
             end do  ! l loop
          end do   ! h loop
          if (n==n_ext) then
             if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti,": ", Hkl_Ref_Conditions(num_exti)
             zonal_condition = .true.
          end if

          !37: glide plane with +-a/4 +- b/4 +- c/4 translation: tetragonal + cubic
          !  Hkl_Ref_Conditions(33) = "(  h  k  h) 2h+k=4n : (-101) glide plane with +-a/4 + b/4 +- c/4 translation (d)"
          num_exti = 37
          n = 0
          n_ext = 0
          do h=-6, +6, 1
             do k=-6, +6, 1
                hh(1)=h
                hh(2)=k
                hh(3)=h
                m=2*h+k
                if (m /=int(m/4)*4) then
                   n=n+1
                   if (hkl_absent(hh, spacegroup)) n_ext=n_ext+1
                end if
             end do  ! l loop
          end do   ! h loop
          if (n==n_ext) then
             if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti,": ", Hkl_Ref_Conditions(num_exti)
             zonal_condition = .true.
          end if

          !38: glide plane with b/2 translation: tetragonal + cubic
          !  Hkl_Ref_Conditions(38) = "( -h  k  h)    k=2n : (101)  glide plane with b/2 translation (b,n)"
          num_exti = 38
          n = 0
          n_ext = 0
          do h=-6, +6, 1
             do k=-6, +6, 1
                hh(1)=-h
                hh(2)=k
                hh(3)=h
                m=k
                if (m /=int(m/2)*2) then
                   n=n+1
                   if (hkl_absent(hh, spacegroup)) n_ext=n_ext+1
                end if
             end do  ! l loop
          end do   ! h loop
          if (n==n_ext) then
             if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti,": ", Hkl_Ref_Conditions(num_exti)
             zonal_condition = .true.
          end if

          ! 39: glide plane with a/4 +- b/4 +- c/4 translation: tetragonal + cubic
          !  Hkl_Ref_Conditions(39) = "( -h  k  h) 2h+k=4n : (101)  glide plane with +-a/4 + b/4 +- c/4 translation (d)"
          num_exti = 39
          n = 0
          n_ext = 0
          do h=-6, +6, 1
             do k=-6, +6, 1
                hh(1)=-h
                hh(2)=k
                hh(3)=h
                m=2*h+k
                if (m /=int(m/4)*4) then
                   n=n+1
                   if (hkl_absent(hh, spacegroup)) n_ext=n_ext+1
                end if
             end do  ! l loop
          end do   ! h loop
          if (n==n_ext) then
             if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti,": ", Hkl_Ref_Conditions(num_exti)
             zonal_condition = .true.
          end if
       end if  ! fin de la condition "if cubic

       if (.not. zonal_condition)   then
          if (present(iunit)) write(unit=iunit,fmt=*) "     =====>>> no zonal reflection condition"
       end if

       return
    End Subroutine Glide_Planes_Conditions

    !!----
    !!---- Subroutine Hkl_Equiv_List(H,Spacegroup,Friedel,Mul,Hlist)
    !!----    integer/real(kind=cp), dimension(3),                    intent(in) :: h
    !!----    type (Space_Group_Type),                                intent(in) :: SpaceGroup
    !!----    logical,                                                intent(in) :: Friedel
    !!----    integer,                                                intent(out):: mul
    !!----    integer/real(kind=cp),dimension(3,SpaceGroup%numops*2), intent(out):: hlist
    !!----
    !!----    Calculate the multiplicity of the reflection and the list of all
    !!----    equivalent reflections. Friedel law assumed if Friedel=.true.
    !!----
    !!---- Update: February - 2005
    !!

    !!--++
    !!--++ Subroutine Hkl_Equiv_ListI(H,Spacegroup,Friedel,Mul,Hlist)
    !!--++    integer, dimension(3),                    intent(in) :: h
    !!--++    type (Space_Group_Type),                  intent(in) :: SpaceGroup
    !!--++    logical,                                  intent(in) :: Friedel
    !!--++    integer,                                  intent(out):: mul
    !!--++    integer,dimension(3,SpaceGroup%numops*2), intent(out):: hlist
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Calculate the multiplicity of the reflection and the list of all
    !!--++    equivalent reflections. Friedel law assumed if Friedel=.true.
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Hkl_Equiv_Listi(H,Spacegroup,Friedel,Mul,Hlist)
       !---- Arguments ----!
       integer, dimension(3),                     intent (in) :: h
       Type (Space_Group_Type),                   intent (in) :: SpaceGroup
       Logical,                                   intent (in) :: Friedel
       integer,                                   intent(out) :: mul
       integer, dimension(3,SpaceGroup%numops*2), intent(out) :: hlist

       !---- Local Variables ----!
       logical              :: esta
       integer, dimension(3):: k
       integer              :: i,j,ng

       hlist = 0
       ng=SpaceGroup%numops
       mul=1
       hlist(:,1)=h(:)
       do i=2,ng
          k = hkl_r(h,SpaceGroup%SymOp(i))
          esta=.false.
          do j=1,mul
             if (hkl_equal(k,hlist(:,j)) .or. (hkl_equal(-k,hlist(:,j)) .and. Friedel)) then
                esta=.true.
                exit
             end if
          end do
          if (esta) cycle
          mul=mul+1
          hlist(:,mul) = k
       end do

       if (Friedel .or. SpaceGroup%centred == 2) then
          j=mul
          mul=mul*2
          do i=j+1,mul
             hlist(:,i)=-hlist(:,i-j)
          end do
       end if

       return
    End Subroutine Hkl_Equiv_Listi

    !!--++
    !!--++ Subroutine Hkl_Equiv_ListR(H,Spacegroup,Friedel,Mul,Hlist)
    !!--++    real(kind=cp),    dimension(3),                    intent(in) :: h
    !!--++    type (Space_Group_Type),                           intent(in) :: SpaceGroup
    !!--++    Logical,                                           intent(in) :: Friedel
    !!--++    integer,                                           intent(out):: mul     !multiplicity
    !!--++    real(kind=cp),   dimension(3,SpaceGroup%numops*2), intent(out):: hlist
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Calculate the multiplicity of the reflection and the list of all
    !!--++    equivalent reflections. Friedel law assumed if Friedel=.true.
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Hkl_Equiv_ListR(H,Spacegroup,Friedel,Mul,Hlist)
       !---- Arguments ----!
       real(kind=cp), dimension(3),                     intent (in) :: h
       Type (Space_Group_Type),                         intent (in) :: SpaceGroup
       Logical,                                         intent (in) :: Friedel
       integer,                                         intent(out) :: mul
       real(kind=cp), dimension(3,SpaceGroup%numops*2), intent (out) :: hlist

       !---- Local Variables ----!
       logical                    :: esta
       real(kind=cp), dimension(3):: k
       integer                    :: i,j,ng

       hlist = 0.0
       ng=SpaceGroup%numops
       mul=1
       hlist(:,1)=h(:)
       do i=2,ng
          k = hkl_r(h,SpaceGroup%SymOp(i))
          esta=.false.
          do j=1,mul
             if (hkl_equal(k,hlist(:,j)) .or. (hkl_equal(-k,hlist(:,j)) .and. Friedel)) then
                esta=.true.
                exit
             end if
          end do
          if (esta) cycle
          mul=mul+1
          hlist(:,mul) = k
       end do
       if (Friedel .or. SpaceGroup%centred == 2) then
          j=mul
          mul=mul*2
          do i=j+1,mul
             hlist(:,i)=-hlist(:,i-j)
          end do
       end if

       return
    End Subroutine Hkl_Equiv_Listr

    !!----
    !!---- Subroutine  Hkl_Gen(Crystalcell,Spacegroup,Friedel,Value1,Value2,Num_Ref,Reflex)
    !!----    Type (Crystal_Cell_Type),          intent(in) :: CrystalCell     !Unit cell object
    !!----    Type (Space_Group_Type) ,          intent(in) :: SpaceGroup      !Space Group object
    !!----    Logical,                           intent(in) :: Friedel         !If true, Friedel law applied
    !!----    real(kind=cp),                     intent(in) :: value1,value2   !Range in SinTheta/Lambda
    !!----    Integer            ,               intent(out):: Num_Ref         !Number of generated reflections
    !!----    Type (Reflect_Type), dimension(:), intent(out):: Reflex          !List of generated hkl,mult, s
    !!----
    !!----    Calculate unique reflections between two values of
    !!----    sin_theta/lambda.  The output is not ordered.
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Hkl_Gen(Crystalcell,Spacegroup,Friedel,Value1,Value2,Num_Ref,Reflex)
       !---- Arguments ----!
       type (Crystal_Cell_Type),          intent(in)     :: crystalcell
       type (Space_Group_Type) ,          intent(in)     :: spacegroup
       Logical,                           intent(in)     :: Friedel
       real(kind=cp),                     intent(in)     :: value1,value2
       integer,                           intent(out)    :: num_ref
       type (Reflect_Type), dimension(:), intent(out)    :: reflex

       !---- Local variables ----!
       real(kind=cp)         :: vmin,vmax,sval
       integer               :: h,k,l,hmin,kmin,lmin,hmax,kmax,lmax, maxref
       integer, dimension(3) :: hh,kk,nulo
       character(len=2)      :: inf

       nulo=0
       maxref=size(reflex)
       vmin=min(value1,value2)
       vmax=max(value1,value2)
       hmax=nint(CrystalCell%cell(1)*2.0*vmax+1.0)
       kmax=nint(CrystalCell%cell(2)*2.0*vmax+1.0)
       lmax=nint(CrystalCell%cell(3)*2.0*vmax+1.0)
       lmin= 0  ! l positive or zero except for -3 1 m (see below)

       !---- Select approximate region to generate reflections depending
       !---- on the space group. This allows a faster generation.
       select Case(SpaceGroup%NumSpg)
          case (1:2)                 ! -1    -> hkl: l >=0; hk0: h >=0; 0k0: k >=0
             hmin=-hmax
             kmin=-kmax

          case (3:15)                ! 2/m
             inf(1:2)=adjustl(Spacegroup%info(1:2))
             if(inf(1:1) == "-") inf(1:1)=inf(2:2)
             select case (inf(1:1))
                case ("b")     !       -> hkl: k >=0, l >=0; hk0: h >=0
                   hmin=-hmax
                   kmin=0
                case ("c")     !       -> hkl: k >=0, l >=0; h0l: h >=0
                   hmin=-hmax
                   kmin=0
                case ("a")     !       -> hkl: h >=0, l >=0; 0kl: l >=0  Provisional (to be tested)
                   kmin=-kmax
                   hmin=0
                case default
                   hmin=-hmax
                   kmin=0
             end select

          case (16:74)         ! mmm   -> hkl: h >=0, k >=0, l >=0
             hmin=0
             kmin=0

          case (75:88)         ! 4/m   -> hkl: h >=0, l >=0, k >=0 if h = 0
                               !                             k > 0 if h > 0
             hmin=0
             kmin=0

          case (89:142)        ! 4/mmm -> hkl: h >=0, k>=0, l>=0, h >=k
             hmin=0
             kmin=0

          case (143:148)       ! -3    -> hkl: h+k>0, l>0 ;  hk0: h>0, k>=0
             hmin=0
             kmin=-kmax

          case (149,151,153,157,159,162,163) ! -3 1 m  -> hkl: h>=0,h>=k>0 ; h0l: h>=0,l>=0
             hmin=0
             kmin=0
             lmin=-lmax

          case (150,152,154,155,156,158,160,161,164,165,166,167)
                              ! -3 m   -> hkl: h>=0 h>=k ; hhl: h>=0,l>=0
             hmin=0
             kmin=0

          case (168:176)    ! 6/m   -> hkl: h>0,k>0,l>=0;  0kl k>=0,l>=0
             hmin=0
             kmin=0

          case (177:194)    ! 6/mmm -> hkl: h >=0, k >=0, l >=0, h >=k
             hmin=0
             kmin=0

          case (195:206)    ! m-3   -> hkl: h > l, k > l, l >=0 ; hkk: k>=0 h>=k
             hmin=0
             kmin=0

          case (207:230)    ! m-3m  -> hkl: h >=0, k >=0, l >=0, h >=k, k >=l
             hmin=0
             kmin=0

          case default      ! Assumed -1
             hmin=-hmax
             kmin=-kmax
       end Select

       num_ref=0
       ext_do: do h=hmin,hmax
          do k=kmin,kmax
             do l=lmin,lmax

                hh(1)=h
                hh(2)=k
                hh(3)=l

                if (hkl_equal(hh,nulo)) cycle
                sval=hkl_s(hh,crystalcell)
                if (sval > vmax .or. sval < vmin) cycle
                if (hkl_absent(hh,Spacegroup)) cycle

                kk=asu_hkl(hh,Spacegroup)
                if (hkl_equal(kk,nulo)) cycle
                if (hkl_equal(kk,-hh)) cycle

                num_ref=num_ref+1
                if(num_ref > maxref) then
                   num_ref=maxref
                   exit ext_do
                end if
                reflex(num_ref)%h    = kk
                reflex(num_ref)%mult = hkl_mult(kk,SpaceGroup,friedel)
                reflex(num_ref)%S    = sval
             end do
          end do
       end do ext_do

       return
    End Subroutine Hkl_Gen

    !!----
    !!---- Subroutine  Hkl_Gen_Sxtal (Crystalcell,Spacegroup,stlmin,stlmax,Num_Ref,Reflex,ord,hlim)
    !!----    Type (Crystal_Cell_Type),          intent(in) :: CrystalCell     !Unit cell object
    !!----    Type (Space_Group_Type) ,          intent(in) :: SpaceGroup      !Space Group object
    !!----    real(kind=cp),                     intent(in) :: stlmin,stlmax   !Minimum and Maximum SinTheta/Lambda
    !!----    Integer            ,               intent(out):: Num_Ref         !Number of generated reflections
    !!----    Type (Reflect_Type), dimension(:), intent(out):: Reflex          !List of generated hkl,mult, s
    !!----    or
    !!----    Type (Reflection_List_Type),       intent(out):: Reflex          !List of generated hkl,mult, s
    !!----    Integer, dimension(3),   optional, intent(in) :: ord             !Order for loop of hkl-indices
    !!----    Integer, dimension(3,2), optional, intent(in) :: hlim            !hkl-limits
    !!----
    !!----    Calculate all allowed reflections between a minimum and a maximum value of sin_theta/lambda.
    !!----    If the limits of indices are provided in hlim, only the reflections verifying the prescription
    !!----    are finally kept. hlim(:,1) and hlim(:,2) contain the minimum and maximum values respectively.
    !!----    The output is not ordered but the user can obtain the reflections generated
    !!----    in a particular way by providing the integer vector "ord", containing a permutation
    !!----    of the three numbers 1,2,3. By default the loop generating the hkl-indices uses
    !!----    the vector ord=(/3,2,1/), this means that the inner loop (more rapidly changing index)
    !!----    is the l-index, then the k-index and finally the h-index.
    !!----
    !!---- Update: May - 2006
    !!

    !!--++
    !!--++ Subroutine  Hkl_Gen_Sxtal_Reflection(Crystalcell,Spacegroup,stlmin,stlmax,Num_Ref,Reflex,ord,hlim)
    !!--++    Type (Crystal_Cell_Type),          intent(in) :: CrystalCell     !Unit cell object
    !!--++    Type (Space_Group_Type) ,          intent(in) :: SpaceGroup      !Space Group object
    !!--++    real(kind=cp),                     intent(in) :: stlmin,stlmax   !Minimum and Maximum SinTheta/Lambda
    !!--++    Integer            ,               intent(out):: Num_Ref         !Number of generated reflections
    !!--++    Type (Reflect_Type), dimension(:), intent(out):: Reflex          !List of generated hkl,mult, s
    !!--++    Integer, dimension(3),   optional, intent(in) :: ord             !Order for loop of hkl-indices
    !!--++    Integer, dimension(3,2), optional, intent(in) :: hlim            !hkl-limits
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Calculate all allowed reflections between a minimum and a maximum value of sin_theta/lambda.
    !!--++    If the limits of indices are provided in hlim, only the reflections verifying the prescription
    !!--++    are finally kept. hlim(:,1) and hlim(:,2) contain the minimum and maximum values respectively.
    !!--++    The reflections are stored in the array Reflex, with components of type: Reflect_Type
    !!--++    The output is not ordered but the user can obtain the reflections generated
    !!--++    in a particular way by providing the integer vector "ord", containing a permutation
    !!--++    of the three numbers 1,2,3. By default the loop generating the hkl-indices uses
    !!--++    the vector ord=(/3,2,1/), this means that the inner loop (more rapidly changing index)
    !!--++    is the l-index, then the k-index and finally the h-index.
    !!--++
    !!--++ Update: May - 2006
    !!
    Subroutine Hkl_Gen_Sxtal_Reflection(Crystalcell,Spacegroup,stlmin,stlmax,Num_Ref,Reflex,ord,hlim)
       !---- Arguments ----!
       type (Crystal_Cell_Type),          intent(in)  :: crystalcell
       type (Space_Group_Type) ,          intent(in)  :: spacegroup
       real(kind=cp),                     intent(in)  :: stlmin,stlmax
       integer,                           intent(out) :: num_ref
       type (Reflect_Type), dimension(:), intent(out) :: reflex
       Integer, dimension(3),   optional, intent(in)  :: ord
       Integer, dimension(3,2), optional, intent(in)  :: hlim
       !---- Local variables ----!
       real(kind=cp)         :: sval
       integer               :: h,k,l,hmax,kmax,lmax, maxref
       integer, dimension(3) :: hh,nulo,od,imin,imax

       nulo=0
       maxref=size(reflex)
       hmax=nint(CrystalCell%cell(1)*2.0*stlmax+1.0)
       kmax=nint(CrystalCell%cell(2)*2.0*stlmax+1.0)
       lmax=nint(CrystalCell%cell(3)*2.0*stlmax+1.0)
       if(present(hlim)) then
         imin=hlim(:,1)
         imax=hlim(:,2)
       else
         imin=(/-hmax,-kmax,-lmax/)
         imax=(/ hmax, kmax, lmax/)
       end if
       od=(/3,2,1/)
       if(present(ord)) od=ord

       num_ref=0
       ext_do: do h=imin(od(3)),imax(od(3))
          do k=imin(od(2)),imax(od(2))
             do l=imin(od(1)),imax(od(1))
                hh(od(3))=h
                hh(od(2))=k
                hh(od(1))=l
                if (hkl_equal(hh,nulo)) cycle
                sval=hkl_s(hh,crystalcell)
                if (sval > stlmax .or. sval < stlmin) cycle
                if (hkl_absent(hh,Spacegroup)) cycle
                num_ref=num_ref+1
                if(num_ref > maxref) then
                   num_ref=maxref
                   exit ext_do
                end if
                reflex(num_ref)%h    = hh
                reflex(num_ref)%mult = hkl_mult(hh,SpaceGroup,.false.)
                reflex(num_ref)%S    = sval
            end do
          end do
       end do ext_do

       return
    End Subroutine Hkl_Gen_Sxtal_Reflection

    !!--++
    !!--++ Subroutine  Hkl_Gen_Sxtal_list(Crystalcell,Spacegroup,stlmin,stlmax,Num_Ref,Reflex,ord,hlim)
    !!--++    Type (Crystal_Cell_Type),          intent(in) :: CrystalCell     !Unit cell object
    !!--++    Type (Space_Group_Type) ,          intent(in) :: SpaceGroup      !Space Group object
    !!--++    real(kind=cp),                     intent(in) :: stlmin,stlmax   !Minimum and Maximum SinTheta/Lambda
    !!--++    Integer            ,               intent(out):: Num_Ref         !Number of generated reflections
    !!--++    Type(Reflection_List_Type),        intent(out):: reflex          !Generated set of reflections
    !!--++    Integer, dimension(3),   optional, intent(in) :: ord             !Order for loop of hkl-indices
    !!--++    Integer, dimension(3,2), optional, intent(in) :: hlim            !hkl-limits
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Calculate all allowed reflections between a minimum and a maximum value of sin_theta/lambda.
    !!--++    If the limits of indices are provided in hlim, only the reflections verifying the prescription
    !!--++    are finally kept. hlim(:,1) and hlim(:,2) contain the minimum and maximum values respectively.
    !!--++    The reflections are stored in the scalar object Reflex of type: Reflection_List_Type
    !!--++    The output is not ordered but the user can obtain the reflections generated
    !!--++    in a particular way by providing the integer vector "ord", containing a permutation
    !!--++    of the three numbers 1,2,3. By default the loop generating the hkl-indices uses
    !!--++    the vector ord=(/3,2,1/), this means that the inner loop (more rapidly changing index)
    !!--++    is the l-index, then the k-index and finally the h-index.
    !!--++
    !!--++ Update: May - 2006
    !!
    Subroutine Hkl_Gen_Sxtal_List(Crystalcell,Spacegroup,stlmin,stlmax,Num_Ref,Reflex,ord,hlim)
       !---- Arguments ----!
       type (Crystal_Cell_Type),          intent(in)  :: crystalcell
       type (Space_Group_Type) ,          intent(in)  :: spacegroup
       real(kind=cp),                     intent(in)  :: stlmin,stlmax
       integer,                           intent(out) :: num_ref
       Type(Reflection_List_Type),        intent(out) :: reflex   !Ordered set of reflections
       Integer, dimension(3),   optional, intent(in)  :: ord
       Integer, dimension(3,2), optional, intent(in)  :: hlim

       !---- Local variables ----!
       real(kind=cp)         :: sval
       integer               :: h,k,l,hmax,kmax,lmax, maxref,i
       integer, dimension(3) :: hh,nulo,od,imin,imax
       Type(Reflection_Type), dimension(:), allocatable :: tmp_reflex

       nulo=0

       hmax=nint(CrystalCell%cell(1)*2.0*stlmax+1.0)
       kmax=nint(CrystalCell%cell(2)*2.0*stlmax+1.0)
       lmax=nint(CrystalCell%cell(3)*2.0*stlmax+1.0)
       if(present(hlim)) then
         imin=hlim(:,1)
         imax=hlim(:,2)
       else
         imin=(/-hmax,-kmax,-lmax/)
         imax=(/ hmax, kmax, lmax/)
       end if
       od=(/3,2,1/)
       if(present(ord)) od=ord

       maxref=(2*hmax+1)*(2*kmax+1)*(2*lmax+1)
       if(allocated(tmp_reflex)) deallocate(tmp_reflex)
       allocate(tmp_reflex(maxref))

       num_ref=0
       ext_do: do h=imin(od(3)),imax(od(3))
          do k=imin(od(2)),imax(od(2))
             do l=imin(od(1)),imax(od(1))
                hh(od(3))=h
                hh(od(2))=k
                hh(od(1))=l
                if (hkl_equal(hh,nulo)) cycle
                sval=hkl_s(hh,crystalcell)
                if (sval > stlmax .or. sval < stlmin) cycle
                if (hkl_absent(hh,Spacegroup)) cycle
                num_ref=num_ref+1
                if(num_ref > maxref) then
                   num_ref=maxref
                   exit ext_do
                end if

                tmp_reflex(num_ref)%h    = hh
                tmp_reflex(num_ref)%mult = hkl_mult(hh,SpaceGroup,.false.)
                tmp_reflex(num_ref)%S    = sval

             end do
          end do
       end do ext_do

       if(allocated(reflex%ref)) deallocate(reflex%ref)
       allocate(reflex%ref(num_ref))
       reflex%nref= num_ref

       do i=1,num_ref
          reflex%Ref(i)%h    = tmp_reflex(i)%h
          reflex%Ref(i)%mult = tmp_reflex(i)%mult
          reflex%Ref(i)%S    = tmp_reflex(i)%S
          reflex%Ref(i)%fo    =0.0
          reflex%Ref(i)%sfo   =0.0
          reflex%Ref(i)%fc    =0.0
          reflex%Ref(i)%w     =0.0
          reflex%Ref(i)%phase =0.0
          reflex%Ref(i)%a     =0.0
          reflex%Ref(i)%b     =0.0
          reflex%Ref(i)%aa    =0.0
          reflex%Ref(i)%bb    =0.0
       end do

       return
    End Subroutine Hkl_Gen_Sxtal_list


    !!----
    !!---- Subroutine  Hkl_Rp(H,Phase, Op,K, Phasen)
    !!----    integer/real(kind=cp), dimension(3), intent(in)  :: h
    !!----    real(kind=cp),                       intent(in)  :: phase
    !!----    type (Sym_Oper_Type),                intent(in)  :: Op
    !!----    integer/real(kind=cp), dimension(3), intent(out) :: k
    !!----    real(kind=cp),                       intent(out) :: phasen
    !!----
    !!----    Calculate the equivalent reflection and Phase
    !!----
    !!---- Update: February - 2005
    !!

    !!--++
    !!--++ Subroutine Hkl_RpI(H,Phase,Op,K,Phasen)
    !!--++    integer,dimension(3),   intent(in) :: h
    !!--++    real(kind=cp),          intent(in) :: phase
    !!--++    type (Sym_Oper_Type),   intent(in) :: Op
    !!--++    integer,dimension(3),   intent(out):: k
    !!--++    real(kind=cp),          intent(out):: phasen
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Calculate the equivalent reflection and new phase
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Hkl_RpI(H, Phase, Op, K, Phasen)
       !---- Arguments ----!
       integer, dimension(3), intent (in) :: h
       real(kind=cp),         intent (in) :: phase
       Type(Sym_Oper_Type),   intent (in) :: Op
       integer, dimension(3), intent (out):: k
       real(kind=cp),         intent (out):: phasen

       k = matmul(h,Op%Rot)
       phasen= phase - 360.0_cp*dot_product(Op%Tr,real(h))
       phasen=mod(phasen+3600.0_cp,360.0_cp)

       return
    End Subroutine Hkl_RpI

    !!--++
    !!--++ Subroutine Hkl_RpR(H,Phase,Op,K,Phasen)
    !!--++     real(kind=cp),dimension(3),   intent(in) :: h
    !!--++     real(kind=cp),                intent(in) :: phase
    !!--++     type (Sym_Oper_Type),         intent(in) :: Op
    !!--++     real(kind=cp),dimension(3),   intent(out):: k
    !!--++     real(kind=cp),                intent(out):: phasen
    !!--++
    !!--++     (OVERLOADED)
    !!--++     Calculate the equivalent reflection and new phase
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Hkl_RpR(h, phase, Op, k, phasen)
       !---- Arguments ----!
       real(kind=cp), dimension(3),intent (in) :: h
       real(kind=cp),              intent (in) :: phase
       Type(Sym_Oper_Type),        intent(in)  :: Op
       real(kind=cp), dimension(3),intent (out):: k
       real(kind=cp),              intent (out):: phasen

       k = matmul(h,Op%Rot)
       phasen= phase - 360.0_cp*dot_product(Op%Tr,h)
       phasen=mod(phasen+3600.0_cp,360.0_cp)

       return
    End Subroutine Hkl_RpR

    !!----
    !!---- Subroutine  Hkl_Uni(Crystalcell, Spacegroup,Friedel,Value1,Value2,Code,Num_Ref,Reflex, no_order)
    !!----    Type (Crystal_Cell_Type),          intent(in) :: CrystalCell  !Cell Objet
    !!----    Type (Space_Group_Type) ,          intent(in) :: SpaceGroup   !Space group Object
    !!----    Logical,                           intent(in) :: Friedel
    !!----    real(kind=cp),                     intent(in) :: value1,value2 !Range in sintheta/Lambda
    !!----    character(len=1),                  intent(in) :: code     !If code="r", d-spacing are input
    !!----    Integer            ,               intent(out):: num_Ref  !Number of generated reflections
    !!----    Type (Reflect_Type), dimension(:), intent(out):: reflex   !Ordered set of reflections
    !!----         or
    !!----    Type (Reflection_Type), dimension(:), intent(out):: reflex !Ordered set of reflections
    !!----         or
    !!----    Type(Reflection_List_Type),        intent(out):: reflex   !Ordered set of reflections
    !!----    logical,                optional,  intent(in) :: no_order
    !!----
    !!----    Calculate unique reflections between two values (value1,value2)
    !!----    of sin_theta/lambda. If no_order is present and .true. the sort subroutine
    !!----    is not invoked.
    !!----
    !!---- Update: December - 2011
    !!

    !!--++
    !!--++ Subroutine  Hkl_Uni_Reflect(Crystalcell, Spacegroup,Friedel,Value1,Value2,Code,Num_Ref,Reflex,no_order)
    !!--++    Type (Crystal_Cell_Type),          intent(in) :: CrystalCell  !Cell Objet
    !!--++    Type (Space_Group_Type) ,          intent(in) :: SpaceGroup   !Space group Object
    !!--++    Logical,                           intent(in) :: Friedel
    !!--++    real(kind=cp),                     intent(in) :: value1,value2 !Range in sintheta/Lambda
    !!--++    character(len=1),                  intent(in) :: code     !If code="r", d-spacing are input
    !!--++    Integer            ,               intent(out):: num_Ref  !Number of generated reflections
    !!--++    Type (Reflect_Type), dimension(:), intent(out):: reflex   !Ordered set of reflections
    !!--++    logical,                optional,  intent(in) :: no_order
    !!--++
    !!--++    (Overloaded)
    !!--++    Calculate unique reflections between two values (value1,value2)
    !!--++    of sin_theta/lambda. If no_order is present and .true. the sort subroutine
    !!--++    is not invoked.
    !!--++
    !!--++ Update: December - 2011
    !!
    Subroutine Hkl_Uni_Reflect(Crystalcell,Spacegroup,Friedel,Value1,Value2,Code,Num_Ref,Reflex,no_order)
       !---- Arguments ----!
       type (Crystal_Cell_Type),             intent(in)     :: crystalcell
       type (Space_Group_Type) ,             intent(in)     :: spacegroup
       Logical,                              intent(in)     :: Friedel
       real(kind=cp),                        intent(in)     :: value1,value2
       character(len=1),                     intent(in)     :: code
       integer,                              intent(out)    :: num_ref
       type (Reflect_Type),    dimension(:), intent(out)    :: reflex
       logical,                   optional,  intent(in)     :: no_order

       !---- Local variables ----!
       real(kind=cp)                         :: vmin,vmax,sval
       integer                               :: h,k,l,hmin,kmin,lmin,hmax,kmax,lmax, i, maxref
       integer, dimension(3)                 :: hh,kk,nulo
       integer,  dimension(  size(reflex))   :: ind
       integer,  dimension(  size(reflex))   :: mul
       integer,  dimension(3,size(reflex))   :: hkl
       real(kind=cp),dimension(size(reflex)) :: sv
       character(len=2)                      :: inf

       nulo=0
       maxref=size(reflex)
       vmin=min(value1,value2)
       vmax=max(value1,value2)
       if (code =="r" .or. code=="R") then
          vmin=1.0/(2.0*max(value1,value2))
          vmax=1.0/(2.0*min(value1,value2))
       end if

       hmax=nint(CrystalCell%cell(1)*2.0*vmax+1.0)
       kmax=nint(CrystalCell%cell(2)*2.0*vmax+1.0)
       lmax=nint(CrystalCell%cell(3)*2.0*vmax+1.0)
       lmin= 0  !l positive or zero except for -3 1 m (see below)

       !---- Select approximate region to generate reflections depending
       !---- on the space group. This allows a faster generation.
       Select Case(SpaceGroup%NumSpg)
          case (1:2)                   ! -1    -> hkl: l >=0; hk0: h >=0; 0k0: k >=0
             hmin=-hmax
             kmin=-kmax
             if(SpaceGroup%NumSpg == 1 .and. .not. Friedel) lmin=-lmax

          case (3:15)                  ! 2/m
             inf=Spacegroup%info(1:2)
             if (inf(1:1) == "-") inf(1:1)=inf(2:2)
             select case (inf(1:1))
                case ("b")     !       -> hkl: k >=0, l >=0; hk0: h >=0
                   hmin=-hmax
                   kmin=0
                case ("c")     !       -> hkl: k >=0, l >=0; h0l: h >=0
                   hmin=-hmax
                   kmin=0
                case ("a")     !       -> hkl: h >=0, l >=0; 0kl: l >=0  Provisional (to be tested)
                   kmin=-kmax
                   hmin=0
             end select

          case (16:74)         ! mmm   -> hkl: h >=0, k >=0, l >=0
             hmin=0
             kmin=0

          case (75:88)         ! 4/m   -> hkl: h >=0, l >=0, k >=0 if h = 0
                               !                             k > 0 if h > 0
             hmin=0
             kmin=0

          case (89:142)        ! 4/mmm -> hkl: h >=0, k>=0, l>=0, h >=k
             hmin=0
             kmin=0

          case (143:148)       ! -3    -> hkl: h+k>0, l>0 ;  hk0: h>0, k>=0
             hmin=0
             kmin=-kmax

          case (149,151,153,157,159,162,163) ! -3 1 m  -> hkl: h>=0,h>=k>0 ; h0l: h>=0,l>=0
             hmin=0
             kmin=0
             lmin=-lmax

          case (150,152,154,155,156,158,160,161,164,165,166,167)
                              ! -3 m   -> hkl: h>=0 h>=k ; hhl: h>=0,l>=0
             hmin=0
             kmin=0

          case (168:176)    ! 6/m   -> hkl: h>0,k>0,l>=0;  0kl k>=0,l>=0
             hmin=0
             kmin=0

          case (177:194)    ! 6/mmm -> hkl: h >=0, k >=0, l >=0, h >=k
             hmin=0
             kmin=0

          case (195:206)    ! m-3   -> hkl: h > l, k > l, l >=0 ; hkk: k>=0 h>=k
             hmin=0
             kmin=0

          case (207:230)    ! m-3m  -> hkl: h >=0, k >=0, l >=0, h >=k, k >=l
             hmin=0
             kmin=0

          case default      ! Assumed -1
             hmin=-hmax
             kmin=-kmax
       end select

       num_ref=0
       ext_do: do h=hmin,hmax
          do k=kmin,kmax
             do l=lmin,lmax

                hh(1)=h
                hh(2)=k
                hh(3)=l

                if (hkl_equal(hh,nulo)) cycle
                sval=hkl_s(hh,crystalcell)
                if (sval > vmax .or. sval < vmin) cycle
                if (hkl_absent(hh,Spacegroup)) cycle

                kk=asu_hkl(hh,Spacegroup)
                if (hkl_equal(kk,nulo)) cycle
                if (hkl_equal(kk,-hh) .and. Friedel) cycle

                num_ref=num_ref+1
                if(num_ref > maxref) then
                   num_ref=maxref
                   exit ext_do
                end if
                hkl(:,num_ref)= kk
                mul(num_ref)  = hkl_mult(kk,SpaceGroup,friedel)
                sv(num_ref)   = sval
             end do
          end do
       end do ext_do

       if(present(no_order)) then
         if(no_order) then
          ind=(/(i,i=1,num_ref)/)
         else
          call sort(sv,num_ref,ind)
         end if
       else
         call sort(sv,num_ref,ind)
       end if

       do i=1,num_ref
          reflex(i)%h   = hkl(:,ind(i))
          reflex(i)%mult= mul(ind(i))
          reflex(i)%S   = sv(ind(i))
       end do
       return
    End Subroutine Hkl_Uni_reflect

    !!--++
    !!--++ Subroutine  Hkl_Uni_Reflection(Crystalcell, Spacegroup,Friedel,Value1,Value2,Code,Num_Ref,Reflex, no_order)
    !!--++    Type (Crystal_Cell_Type),          intent(in) :: CrystalCell  !Cell Objet
    !!--++    Type (Space_Group_Type) ,          intent(in) :: SpaceGroup   !Space group Object
    !!--++    Logical,                           intent(in) :: Friedel
    !!--++    real(kind=cp),                     intent(in) :: value1,value2 !Range in sintheta/Lambda
    !!--++    character(len=1),                  intent(in) :: code     !If code="r", d-spacing are input
    !!--++    Integer            ,               intent(out):: num_Ref  !Number of generated reflections
    !!--++    Type (Reflect_Type), dimension(:), intent(out):: reflex   !Ordered set of reflections
    !!--++    logical,                optional,  intent(in) :: no_order
    !!--++
    !!--++    (Overloaded)
    !!--++    Calculate unique reflections between two values (value1,value2)
    !!--++    of sin_theta/lambda. If no_order is present and .true. the sort subroutine
    !!--++    is not invoked.
    !!--++
    !!--++ Update: December - 2011
    !!
    Subroutine Hkl_Uni_Reflection(Crystalcell,Spacegroup,Friedel,Value1,Value2,Code,Num_Ref,Reflex,no_order)
       !---- Arguments ----!
       type (Crystal_Cell_Type),             intent(in)     :: crystalcell
       type (Space_Group_Type) ,             intent(in)     :: spacegroup
       Logical,                              intent(in)     :: Friedel
       real(kind=cp),                        intent(in)     :: value1,value2
       character(len=1),                     intent(in)     :: code
       integer,                              intent(out)    :: num_ref
       type (Reflection_Type), dimension(:), intent(out)    :: reflex
       logical,                   optional,  intent(in)     :: no_order

       !---- Local variables ----!
       real(kind=cp)                         :: vmin,vmax,sval
       integer                               :: h,k,l,hmin,kmin,lmin,hmax,kmax,lmax, i, maxref
       integer, dimension(3)                 :: hh,kk,nulo
       integer,  dimension(  size(reflex))   :: ind
       integer,  dimension(  size(reflex))   :: mul
       integer,  dimension(3,size(reflex))   :: hkl
       real(kind=cp),dimension(size(reflex)) :: sv
       character(len=2)                      :: inf

       nulo=0
       maxref=size(reflex)
       vmin=min(value1,value2)
       vmax=max(value1,value2)
       if (code =="r" .or. code=="R") then
          vmin=1.0/(2.0*max(value1,value2))
          vmax=1.0/(2.0*min(value1,value2))
       end if

       hmax=nint(CrystalCell%cell(1)*2.0*vmax+1.0)
       kmax=nint(CrystalCell%cell(2)*2.0*vmax+1.0)
       lmax=nint(CrystalCell%cell(3)*2.0*vmax+1.0)
       lmin= 0  !l positive or zero except for -3 1 m (see below)

       !---- Select approximate region to generate reflections depending
       !---- on the space group. This allows a faster generation.
       Select Case(SpaceGroup%NumSpg)
          case (1:2)                 ! -1    -> hkl: l >=0; hk0: h >=0; 0k0: k >=0
             hmin=-hmax
             kmin=-kmax
             if(SpaceGroup%NumSpg == 1 .and. .not. Friedel) lmin=-lmax

          case (3:15)                ! 2/m
             inf=Spacegroup%info(1:2)
             if (inf(1:1) == "-") inf(1:1)=inf(2:2)
             select case (inf(1:1))
                case ("b")     !       -> hkl: k >=0, l >=0; hk0: h >=0
                   hmin=-hmax
                   kmin=0
                case ("c")     !       -> hkl: k >=0, l >=0; h0l: h >=0
                   hmin=-hmax
                   kmin=0
                case ("a")     !       -> hkl: h >=0, l >=0; 0kl: l >=0  Provisional (to be tested)
                   kmin=-kmax
                   hmin=0
             end select

          case (16:74)         ! mmm   -> hkl: h >=0, k >=0, l >=0
             hmin=0
             kmin=0

          case (75:88)         ! 4/m   -> hkl: h >=0, l >=0, k >=0 if h = 0
                               !                             k > 0 if h > 0
             hmin=0
             kmin=0

          case (89:142)        ! 4/mmm -> hkl: h >=0, k>=0, l>=0, h >=k
             hmin=0
             kmin=0

          case (143:148)       ! -3    -> hkl: h+k>0, l>0 ;  hk0: h>0, k>=0
             hmin=0
             kmin=-kmax

          case (149,151,153,157,159,162,163) ! -3 1 m  -> hkl: h>=0,h>=k>0 ; h0l: h>=0,l>=0
             hmin=0
             kmin=0
             lmin=-lmax

          case (150,152,154,155,156,158,160,161,164,165,166,167)
                              ! -3 m   -> hkl: h>=0 h>=k ; hhl: h>=0,l>=0
             hmin=0
             kmin=0

          case (168:176)    ! 6/m   -> hkl: h>0,k>0,l>=0;  0kl k>=0,l>=0
             hmin=0
             kmin=0

          case (177:194)    ! 6/mmm -> hkl: h >=0, k >=0, l >=0, h >=k
             hmin=0
             kmin=0

          case (195:206)    ! m-3   -> hkl: h > l, k > l, l >=0 ; hkk: k>=0 h>=k
             hmin=0
             kmin=0

          case (207:230)    ! m-3m  -> hkl: h >=0, k >=0, l >=0, h >=k, k >=l
             hmin=0
             kmin=0

          case default      ! Assumed -1
             hmin=-hmax
             kmin=-kmax
       end select

       num_ref=0
       ext_do: do h=hmin,hmax
          do k=kmin,kmax
             do l=lmin,lmax

                hh(1)=h
                hh(2)=k
                hh(3)=l

                if (hkl_equal(hh,nulo)) cycle
                sval=hkl_s(hh,crystalcell)
                if (sval > vmax .or. sval < vmin) cycle
                if (hkl_absent(hh,Spacegroup)) cycle

                kk=asu_hkl(hh,Spacegroup)
                if (hkl_equal(kk,nulo)) cycle
                if (hkl_equal(kk,-hh) .and. Friedel) cycle

                num_ref=num_ref+1
                if(num_ref > maxref) then
                   num_ref=maxref
                   exit ext_do
                end if
                hkl(:,num_ref)=kk
                mul(num_ref)  =hkl_mult(kk,SpaceGroup,friedel)
                sv(num_ref)   = sval
             end do
          end do
       end do ext_do

       if(present(no_order)) then
         if(no_order) then
          ind=(/(i,i=1,num_ref)/)
         else
          call sort(sv,num_ref,ind)
         end if
       else
         call sort(sv,num_ref,ind)
       end if

       do i=1,num_ref
          reflex(i)%h= hkl(:,ind(i))
          reflex(i)%mult= mul(ind(i))
          reflex(i)%S   = sv(ind(i))
       end do

       return
    End Subroutine Hkl_Uni_Reflection

    !!--++
    !!--++ Subroutine  Hkl_Uni_ReflList(Crystalcell, Spacegroup,Friedel,Value1,Value2,Code,MaxRef,Reflex,no_order)
    !!--++    Type (Crystal_Cell_Type),          intent(in) :: CrystalCell  !Cell Objet
    !!--++    Type (Space_Group_Type) ,          intent(in) :: SpaceGroup   !Space group Object
    !!--++    Logical,                           intent(in) :: Friedel
    !!--++    real(kind=cp),                     intent(in) :: value1,value2 !Range in sintheta/Lambda
    !!--++    character(len=1),                  intent(in) :: code     !If code="r", d-spacing are input
    !!--++    Integer            ,               intent(in) :: MaxRef   !Maximum Number of reflections to be generated
    !!--++    Type(Reflection_List_Type),        intent(out):: reflex   !Ordered set of reflections
    !!--++    logical,                optional,  intent(in) :: no_order
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Calculate unique reflections between two values (value1,value2)
    !!--++    of sin_theta/lambda. If no_order is present and .true. the sort subroutine
    !!--++    is not invoked.
    !!--++
    !!--++ Update: December - 2011
    !!
    Subroutine Hkl_Uni_ReflList(Crystalcell,Spacegroup,Friedel,Value1,Value2,Code,MaxRef,Reflex,no_order)
       !---- Arguments ----!
       type (Crystal_Cell_Type),       intent(in)     :: crystalcell
       type (Space_Group_Type) ,       intent(in)     :: spacegroup
       Logical,                        intent(in)     :: Friedel
       real(kind=cp),                  intent(in)     :: value1,value2
       character(len=1),               intent(in)     :: code
       integer,                        intent(in)     :: MaxRef
       type (Reflection_List_Type),    intent(out)    :: reflex
       logical,             optional,  intent(in)     :: no_order

       !---- Local variables ----!
       real(kind=cp)                   :: vmin,vmax,sval
       integer                         :: h,k,l,hmin,kmin,lmin,hmax,kmax,lmax, i, num_ref
       integer, dimension(3)           :: hh,kk,nulo
       integer,  dimension(  MaxRef)   :: ind
       integer,  dimension(  MaxRef)   :: mul
       integer,  dimension(3,MaxRef)   :: hkl
       real(kind=cp),dimension(MaxRef) :: sv
       character(len=2)                :: inf

       nulo=0
       vmin=min(value1,value2)
       vmax=max(value1,value2)
       if (code =="r" .or. code=="R") then
          vmin=1.0/(2.0*max(value1,value2))
          vmax=1.0/(2.0*min(value1,value2))
       end if

       hmax=nint(CrystalCell%cell(1)*2.0*vmax+1.0)
       kmax=nint(CrystalCell%cell(2)*2.0*vmax+1.0)
       lmax=nint(CrystalCell%cell(3)*2.0*vmax+1.0)
       lmin= 0  !l positive or zero except for -3 1 m (see below)

       !---- Select approximate region to generate reflections depending
       !---- on the space group. This allows a faster generation.
       Select Case(SpaceGroup%NumSpg)
          case (1:2)                 ! -1    -> hkl: l >=0; hk0: h >=0; 0k0: k >=0
             hmin=-hmax
             kmin=-kmax
             if(SpaceGroup%NumSpg == 1 .and. .not. Friedel) lmin=-lmax

          case (3:15)                ! 2/m
             inf=Spacegroup%info(1:2)
             if (inf(1:1) == "-") inf(1:1)=inf(2:2)
             select case (inf(1:1))
                case ("b")     !       -> hkl: k >=0, l >=0; hk0: h >=0
                   hmin=-hmax
                   kmin=0
                case ("c")     !       -> hkl: k >=0, l >=0; h0l: h >=0
                   hmin=-hmax
                   kmin=0
                case ("a")     !       -> hkl: h >=0, l >=0; 0kl: l >=0  Provisional (to be tested)
                   kmin=-kmax
                   hmin=0
             end select

          case (16:74)         ! mmm   -> hkl: h >=0, k >=0, l >=0
             hmin=0
             kmin=0

          case (75:88)         ! 4/m   -> hkl: h >=0, l >=0, k >=0 if h = 0
                               !                             k > 0 if h > 0
             hmin=0
             kmin=0

          case (89:142)        ! 4/mmm -> hkl: h >=0, k>=0, l>=0, h >=k
             hmin=0
             kmin=0

          case (143:148)       ! -3    -> hkl: h+k>0, l>0 ;  hk0: h>0, k>=0
             hmin=0
             kmin=-kmax

          case (149,151,153,157,159,162,163) ! -3 1 m  -> hkl: h>=0,h>=k>0 ; h0l: h>=0,l>=0
             hmin=0
             kmin=0
             lmin=-lmax

          case (150,152,154,155,156,158,160,161,164,165,166,167)
                              ! -3 m   -> hkl: h>=0 h>=k ; hhl: h>=0,l>=0
             hmin=0
             kmin=0

          case (168:176)    ! 6/m   -> hkl: h>0,k>0,l>=0;  0kl k>=0,l>=0
             hmin=0
             kmin=0

          case (177:194)    ! 6/mmm -> hkl: h >=0, k >=0, l >=0, h >=k
             hmin=0
             kmin=0

          case (195:206)    ! m-3   -> hkl: h > l, k > l, l >=0 ; hkk: k>=0 h>=k
             hmin=0
             kmin=0

          case (207:230)    ! m-3m  -> hkl: h >=0, k >=0, l >=0, h >=k, k >=l
             hmin=0
             kmin=0

          case default      ! Assumed -1
             hmin=-hmax
             kmin=-kmax
       end select

       num_ref=0
       ext_do: do h=hmin,hmax
          do k=kmin,kmax
             do l=lmin,lmax

                hh(1)=h
                hh(2)=k
                hh(3)=l

                if (hkl_equal(hh,nulo)) cycle
                sval=hkl_s(hh,crystalcell)
                if (sval > vmax .or. sval < vmin) cycle
                if (hkl_absent(hh,Spacegroup)) cycle

                kk=asu_hkl(hh,Spacegroup)
                if (hkl_equal(kk,nulo)) cycle
                if (hkl_equal(kk,-hh) .and. Friedel) cycle

                num_ref=num_ref+1
                if(num_ref > maxref) then
                   num_ref=maxref
                   exit ext_do
                end if
                hkl(:,num_ref)=kk
                mul(num_ref)  =hkl_mult(kk,SpaceGroup,friedel)
                sv(num_ref)   = sval
             end do
          end do
       end do ext_do

       if(present(no_order)) then
         if(no_order) then
          ind=(/(i,i=1,num_ref)/)
         else
          call sort(sv,num_ref,ind)
         end if
       else
         call sort(sv,num_ref,ind)
       end if

       if(allocated(reflex%ref)) deallocate(reflex%ref)
       allocate(reflex%ref(num_ref))
       reflex%nref= num_ref

       do i=1,num_ref
          reflex%Ref(i)%h    = hkl(:,ind(i))
          reflex%Ref(i)%mult = mul(ind(i))
          reflex%Ref(i)%S    = sv(ind(i))
          reflex%Ref(i)%fo    =0.0
          reflex%Ref(i)%sfo   =0.0
          reflex%Ref(i)%fc    =0.0
          reflex%Ref(i)%w     =0.0
          reflex%Ref(i)%phase =0.0
          reflex%Ref(i)%a     =0.0
          reflex%Ref(i)%b     =0.0
          reflex%Ref(i)%aa    =0.0
          reflex%Ref(i)%bb    =0.0
       end do

       return
    End Subroutine Hkl_Uni_ReflList


    !!----
    !!---- SUBROUTINE INIT_ERR_REFL()
    !!----
    !!----    Initialize the errors flags in this Module
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Init_Err_Refl()

       err_refl=.false.
       ERR_Refl_Mess=" "

       return
    End Subroutine Init_Err_Refl

    !!----
    !!---- SUBROUTINE INIT_REFLIST()
    !!----
    !!----    Initialize the Reflection List Variable
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Init_RefList(Reflex,N)
       !---- Arguments ----!
       type(reflection_list_type), intent(out) :: Reflex
       integer, optional,          intent(in) :: N

       !---- Local Variables ----!
       integer :: i

       if (allocated(reflex%ref)) deallocate(reflex%ref)
       if (present(n)) then
          reflex%nref=n
          if (n > 0) then
             allocate(reflex%ref(n))
             do i=1,n
                reflex%ref(i)%h     =0
                reflex%ref(i)%mult  =0
                reflex%ref(i)%fo    =0.0
                reflex%ref(i)%sfo   =0.0
                reflex%ref(i)%fc    =0.0
                reflex%ref(i)%w     =0.0
                reflex%ref(i)%phase =0.0
                reflex%ref(i)%a     =0.0
                reflex%ref(i)%b     =0.0
                reflex%ref(i)%aa    =0.0
                reflex%ref(i)%bb    =0.0
             end do
          end if
       else
          reflex%nref=0
       end if

       return
    End Subroutine Init_RefList


    !!--++
    !!--++ SUBROUTINE INIT_REF_COND()
    !!--++
    !!--++    Initialize the Reflection conditions information array
    !!--++
    !!--++ Update: August - 2005
    !!
    Subroutine Init_Ref_Cond()

       Hkl_Ref_Conditions(1:20)(1:80)   = (/  &
             "(h k l)    h+k=2n : xy0 centred face (C)                                        " , &
             "(h k l)    k+l=2n : 0yz centred face (A)                                        " , &
             "(h k l)    h+l=2n : x0z centred face (B)                                        " , &
             "(h k l)  h+k+l=2n : body centred (I)                                            " , &
             "(h k l)  h,k,l same parity: all-face centred (F)                                " , &
             "(h k l) -h+k+l=3n : rhombohedrally centred (R)                                  " , &
             "(  0  k  l)     k=2n : (100) glide plane with b/2 translation (b)               " , &
             "(  0  k  l)     l=2n : (100) glide plane with c/2 translation (c)               " , &
             "(  0  k  l)   k+l=2n : (100) glide plane with b/2 + c/2 translations (n)        " , &
             "(  0  k  l)   k+l=4n : (100) glide plane with b/4 +- c/4 translations (d)       " , &
             "(  h  0  l)     h=2n : (010) glide plane with a/2 translation (a)               " , &
             "(  h  0  l)     l=2n : (010) glide plane with c/2 translation (c)               " , &
             "(  h  0  l)   l+h=2n : (010) glide plane with c/2 + a/2 translations (n)        " , &
             "(  h  0  l)   l+h=4n : (010) glide plane with c/4 +- a/4 translations (d)       " , &
             "(  h  k  0)     h=2n : (001) glide plane with a/2 translation (a)               " , &
             "(  h  k  0)     k=2n : (001) glide plane with b/2 translation (b)               " , &
             "(  h  k  0)   h+k=2n : (001) glide plane with a/2 + b/2 translations (n)        " , &
             "(  h  k  0)   h+k=4n : (001) glide plane with a/4 +- b/4 translations (d)       " , &
             "(  h  -h   0 l) l=2n : (11-20) glide plane with c/2 translation (c)             " , &
             "(  0   k  -k l) l=2n : (-2110) glide plane with c/2 translation (c)             " /)
       Hkl_Ref_Conditions(21:39)(1:80)   = (/  &
             "( -h   0   h l) l=2n : (1-210) glide plane with c/2 translation (c)             " , &
             "(  h   h -2h l) l=2n : (1-100) glide plane with c/2 translation (c)             " , &
             "(-2h   h   h l) l=2n : (01-10) glide plane with c/2 translation (c)             " , &
             "(  h -2h   h l) l=2n : (-1010) glide plane with c/2 translation (c)             " , &
             "(  h  h  l)     l=2n : (1-10) glide plane with c/2 translation (c,n)            " , &
             "(  h  k  k)     h=2n : (01-1) glide plane with a/2 translation (a,n)            " , &
             "(  h  k  h)     k=2n : (-101) glide plane with b/2 translation (b,n)            " , &
             "(  h  h  l)     l=2n : (1-10) glide plane with c/2 translation (c,n)            " , &
             "(  h  h  l)  2h+l=4n : (1-10) glide plane with a/4 +- b/4 +- c/4 translation (d)" , &
             "(  h -h  l)     l=2n : (110)  glide plane with c/2 translation (c,n)            " , &
             "(  h -h  l)  2h+l=4n : (110)  glide plane with a/4 +- b/4 +- c/4 translation (d)" , &
             "(  h  k  k)     h=2n : (01-1) glide plane with a/2 translation (a,n)            " , &
             "(  h  k  k)  2k+h=4n : (01-1) glide plane with +-a/4 + b/4 +- c/4 translation(d)" , &
             "(  h  k -k)     h=2n : (011)  glide plane with a/2 translation (a,n)            " , &
             "(  h  k -k)  2k+h=4n : (011)  glide plane with +-a/4 + b/4 +- c/4 translation(d)" , &
             "(  h  k  h)     k=2n : (-101) glide plane with b/2 translation (b,n)            " , &
             "(  h  k  h)  2h+k=4n : (-101) glide plane with +-a/4 +- b/4 + c/4 translation(d)" , &
             "( -h  k  h)     k=2n : (101)  glide plane with b/2 translation (b,n)            " , &
             "( -h  k  h)  2h+k=4n : (101)  glide plane with +-a/4 +- b/4 + c/4 translation(d)" /)
         Hkl_Ref_Conditions(40:58)(1:80)   = (/  &
             "(h 0 0)      h=2n : screw axis // [100] with  a/2 translation (21)              " , & ! monoclinic, ortho., tetra and cubic
             "(h 0 0)      h=2n : screw axis // [100] with 2a/4 translation (42)              " , & ! cubic
             "(h 0 0)      h=4n : screw axis // [100] with  a/4 translation (41)              " , & ! cubic
             "(h 0 0)      h=4n : screw axis // [100] with 3a/4 translation (43)              " , & ! cubic
             "(0 k 0)      k=2n : screw axis // [010] with  b/2 translation (21)              " , & ! monoclinic, ortho., tetra and cubic
             "(0 k 0)      k=2n : screw axis // [010] with 2b/4 translation (42)              " , & ! cubic
             "(0 k 0)      k=4n : screw axis // [010] with  b/4 translation (41)              " , & ! cubic
             "(0 k 0)      k=4n : screw axis // [010] with 3b/4 translation (43)              " , & ! cubic
             "(0 0 l)      l=2n : screw axis // [00l] with  c/2 translation (21)              " , & ! monoclinic, ortho., tetra and cubic
             "(0 0 l)      l=2n : screw axis // [00l] with 2c/4 translation (42)              " , & ! tetragonal and cubic
             "(0 0 l)      l=4n : screw axis // [00l] with  c/4 translation (41)              " , & ! tetragonal and cubic
             "(0 0 l)      l=4n : screw axis // [00l] with 3c/4 translation (43)              " , & ! tetragonal and cubic
             "(0 0 0 l)    l=2n : screw axis // [00l] axis with 3c/6 translation (63)         " , &
             "(0 0 0 l)    l=3n : screw axis // [00l] axis with  c/3 translation (31)         " , &
             "(0 0 0 l)    l=3n : screw axis // [00l] axis with 2c/3 translation (32)         " , &
             "(0 0 0 l)    l=3n : screw axis // [00l] axis with 2c/6 translation (62)         " , &
             "(0 0 0 l)    l=3n : screw axis // [00l] axis with 4c/6 translation (64)         " , &
             "(0 0 0 l)    l=6n : screw axis // [00l] axis with  c/6 translation (61)         " , &
             "(0 0 0 l)    l=6n : screw axis // [00l] axis with 5c/6 translation (65)         " /)

       return
    End Subroutine Init_Ref_Cond

    !!--++
    !!--++ Subroutine Integral_Conditions(Spacegroup, iunit)
    !!--++    type (Space_Group_Type), intent(in) :: Spacegroup
    !!--++    integer,optional,        intent(in) :: iunit
    !!--++
    !!--++    (PRIVATE)
    !!--++    Integral Conditions according with I.T. Table 2.2.13.1
    !!--++    space.
    !!--++
    !!--++ Update: May - 2005
    !!
    Subroutine Integral_Conditions(Spacegroup,iunit)
       !---- Arguments ----!
       type (Space_Group_Type),  intent(in)     :: spacegroup
       integer, optional,        intent(in)     :: iunit

       !---- local variables ----!
       integer               :: h, k,l, m
       integer               :: n, n_ext
       integer, dimension(3) :: hh
       integer               :: num_exti
       logical               :: integral_condition

       integral_condition   = .false.

       ! 1.       h+k   = 2n                   C-face centred                      C
       ! 2.       k+l   = 2n                   A-face centred                      A
       ! 3.       h+l   = 2n                   B-face centred                      B
       ! 4.       h+k+l = 2n                   Body centred                        I
       !
       ! 5.       h+k   = 2n
       !      and k+l   = 2n
       !      and h+l   = 2n                   All-face centred                    F
       !     or h,k,l all odd
       !     or h,k,l all even
       !
       ! 6.      -h+k+l = 3n                   Rhombohedrally centred,             R
       !                                     obverse setting

       if (present(iunit)) then
          write(unit=iunit,fmt=*) " "
          write(unit=iunit,fmt=*) " >>> Integral reflections conditions for centred lattices:"
          write(unit=iunit,fmt=*) "----------------------------------------------------------"
          write(unit=iunit,fmt=*) " "
       end if

       !---- C-face centred ----!
       !  Hkl_Ref_Conditions(1) =   "(h k l)  h+k=2n           : xy0 centered base"
       num_exti = 1
       n = 0       ! nombre de reflections pouvant obeir a la regle d"extinction
       n_ext = 0   ! nombre de reflecions obeissant a la regle
       do h=-6, 6
          do k=-6, 6
             do l=-6, 6
                hh(1)=h
                hh(2)=k
                hh(3)=l
                m =  h+k
                if (m /= int(m/2)*2) then
                   n=n+1
                   if (hkl_absent(hh,Spacegroup)) n_ext=n_ext+1
                end if
             end do   ! l loop
          end do    ! k loop
       end do     ! h loop
       if (n==n_ext) then
          if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti,": ", Hkl_Ref_Conditions(num_exti)
          integral_condition = .true.
       end if

       !---- A-face centred ----!
       !   Hkl_Ref_Conditions(2) =   "(h k l)  k+l=2n           : 0yz centered base"
       num_exti = 2
       n = 0       ! nombre de reflections pouvant obeir a la regle d"extinction
       n_ext = 0   ! nombre de reflecions obeissant a la regle
       do h=-6, 6
          do k=-6, 6
             do l=-6, 6
                hh(1)=h
                hh(2)=k
                hh(3)=l
                m =  k+l
                if (m /= int(m/2)*2) then
                   n=n+1
                   if (hkl_absent(hh,Spacegroup)) n_ext=n_ext+1
                end if
             end do   ! l loop
          end do    ! k loop
       end do     ! h loop
       if (n==n_ext) then
          if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti,": ", Hkl_Ref_Conditions(num_exti)
          integral_condition = .true.
       end if

       !---- B-face centred ----!
       !  Hkl_Ref_Conditions(3) =   "(h k l)  h+l=2n           : x0z centered base"
       num_exti = 3
       n = 0       ! nombre de reflections pouvant obeir a la regle d"extinction
       n_ext = 0   ! nombre de reflecions obeissant a la regle
       do h=-6, 6
          do k=-6, 6
             do l=-6, 6
                hh(1)=h
                hh(2)=k
                hh(3)=l
                m =  h+l
                if (m /= int(m/2)*2) then
                   n=n+1
                   if (hkl_absent(hh,Spacegroup)) n_ext=n_ext+1
                end if
             end do   ! l loop
          end do    ! k loop
       end do     ! h loop
       if (n==n_ext) then
          if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti,": ", Hkl_Ref_Conditions(num_exti)
          integral_condition = .true.
       end if

       !---- Body centred (I) ----!
       !  Hkl_Ref_Conditions(4) =   "(h k l)  h+k+l=2n         : body centred"
       num_exti = 4
       n = 0       ! nombre de reflections pouvant obeir a la regle d"extinction
       n_ext = 0   ! nombre de reflecions obeissant a la regle
       do h=-6, 6
          do k=-6, 6
             do l=-6, 6
                hh(1)=h
                hh(2)=k
                hh(3)=l
                m =  h+k+l
                if (m /= int(m/2)*2) then
                   n=n+1
                   if (hkl_absent(hh,Spacegroup)) n_ext=n_ext+1
                end if
             end do   ! l loop
          end do    ! k loop
       end do     ! h loop
       if (n==n_ext) then
          if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti,": ", Hkl_Ref_Conditions(num_exti)
          integral_condition = .true.
       end if

       !---- all-face centred (F) ----!
       ! Hkl_Ref_Conditions(5) =   "(h k l)  h,k,l same parity: all-face centred"
       num_exti = 5
       n = 0       ! nombre de reflections pouvant obeir a la regle d"extinction
       n_ext = 0   ! nombre de reflecions obeissant a la regle
       do h=-6, 6
          do k=-6, 6
             do l=-6, 6
                hh(1)=h
                hh(2)=k
                hh(3)=l
                if (h /= int(h/2)*2 .and.  k /= int(k/2)*2 .and. l == int(l/2)*2 ) then
                   n=n+1
                   if (hkl_absent(hh,Spacegroup)) n_ext=n_ext+1

                else if(h /= int(h/2)*2 .and.  k == int(k/2)*2 .and. l /= int(l/2)*2 ) then
                   n=n+1
                   if (hkl_absent(hh,Spacegroup)) n_ext=n_ext+1

                else if(h == int(h/2)*2 .and.  k /= int(k/2)*2 .and. l /= int(l/2)*2 ) then
                   n=n+1
                   if (hkl_absent(hh,Spacegroup)) n_ext=n_ext+1

                else if(h == int(h/2)*2 .and.  k == int(k/2)*2 .and. l /= int(l/2)*2 ) then
                   n=n+1
                   if (hkl_absent(hh,Spacegroup)) n_ext=n_ext+1

                else if(h == int(h/2)*2 .and.  k /= int(k/2)*2 .and. l == int(l/2)*2 ) then
                   n=n+1
                   if (hkl_absent(hh,Spacegroup)) n_ext=n_ext+1

                else if(h /= int(h/2)*2 .and.  k == int(k/2)*2 .and. l == int(l/2)*2 ) then
                   n=n+1
                   if (hkl_absent(hh,Spacegroup)) n_ext=n_ext+1
                end if
             end do   ! l loop
          end do    ! k loop
       end do     ! h loop
       if (n==n_ext) then
          if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti,": ", Hkl_Ref_Conditions(num_exti)
          integral_condition = .true.
       end if

       !---- R network ----!
       !  Hkl_Ref_Conditions(6) =   "(h k l) -h+k+l=3n         : Rhombohedrally centred (R)"
       num_exti = 6
       n = 0       ! nombre de reflections pouvant obeir a la regle d"extinction
       n_ext = 0   ! nombre de reflecions obeissant a la regle
       do h=-6, 6
          do k=-6, 6
             do l=-6, 6
                hh(1)=h
                hh(2)=k
                hh(3)=l
                m =  -h+k+l
                if (m /= int(m/3)*3) then
                   n=n+1
                   if (hkl_absent(hh,Spacegroup)) n_ext=n_ext+1
                end if
             end do   ! l loop
          end do    ! k loop
       end do     ! h loop
       if (n==n_ext) then
          if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti,": ", Hkl_Ref_Conditions(num_exti)
          integral_condition = .true.
       end if

       if (.not. integral_condition)   then
          if (present(iunit)) write(unit=iunit,fmt=*) "     =====>>> no general reflection condition"
       end if

       return
    End Subroutine Integral_Conditions

    !!--++
    !!--++ Subroutine Screw_Axis_Conditions(Spacegroup, iunit)
    !!--++    type (Space_Group_Type), intent(in) :: Spacegroup
    !!--++    integer,optional,        intent(in) :: iunit
    !!--++
    !!--++    (PRIVATE)
    !!--++    Reflections conditions for Screw axes Table 2.2.13.2
    !!--++
    !!--++ Update: May - 2005
    !!
    Subroutine Screw_Axis_Conditions(Spacegroup,Iunit)
       !---- Arguments ----!
       type (Space_Group_Type),       intent(in)     :: spacegroup
       integer, optional,             intent(in)     :: iunit

       !---- Local variables ----!
       integer               :: h, k,l
       integer               :: n, n_ext
       integer, dimension(3) :: hh
       integer               :: num_exti
       logical               :: serial_condition

       serial_condition   = .false.

       if (present(iunit)) then
          write(unit=iunit,fmt=*) " "
          write(unit=iunit,fmt=*) " >>> Serial reflections conditions for screw axes:"
          write(unit=iunit,fmt=*) "---------------------------------------------------"
          write(unit=iunit,fmt=*) " "
       end if

       !SCREW AXES:      33 extinctions

       if (SpaceGroup%CrystalSys(1:10) == "Monoclinic" .or. SpaceGroup%CrystalSys(1:12) == "Orthorhombic" .or.   &
          SpaceGroup%CrystalSys(1:10) == "Tetragonal" .or. SpaceGroup%CrystalSys(1:5)  == "Cubic" ) then

          ! Hkl_Ref_Conditions(40) =   "(h 0 0)      h=2n : screw axis // [100] with  a/2 translation (21)"   ! monoclinic, ortho., tetra or cubic
          num_exti = 40
          n = 0       ! nombre de reflections pouvant obeir a la regle d"extinction
          n_ext = 0   ! nombre de reflecions obeissant a la regle
          do h=-6, 6
             hh(1)=h
             hh(2)=0
             hh(3)=0
             if (h /= int(h/2)*2) then
                n=n+1
                if (hkl_absent(hh,Spacegroup)) n_ext=n_ext+1
             end if
          end do     ! h loop
          if (n==n_ext) then
             if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti,": ", Hkl_Ref_Conditions(num_exti)
             serial_condition = .true.
          end if
       end if ! fin de la condition "if monoclinic, ortho, tetragonal, cubic

       if (SpaceGroup%CrystalSys(1:5) == "Cubic") then
          ! 41
          ! Hkl_Ref_Conditions(41) =   "(h 0 0)      h=2n : screw axis // [100] with  2a/4 translation (42)"   !  cubic
          num_exti = 41
          n = 0       ! nombre de reflections pouvant obeir a la regle d"extinction
          n_ext = 0   ! nombre de reflecions obeissant a la regle
          do h=-6, 6, 1
             hh(1)=h
             hh(2)=0
             hh(3)=0
             if (h /= int(h/2)*2) then
                n=n+1
                if (hkl_absent(hh,Spacegroup)) n_ext=n_ext+1
             end if
          end do     ! h loop
          if (n==n_ext) then
             if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti,": ", Hkl_Ref_Conditions(num_exti)
             serial_condition = .true.
          end if

          ! Hkl_Ref_Conditions(42) =   "(h 0 0)      h=4n : screw axis // [100] with  a/4 translation (41)"   ! cubic
          ! Hkl_Ref_Conditions(43) =   "(h 0 0)      h=4n : screw axis // [100] with 3a/4 translation (43)"   ! cubic
          num_exti = 42
          n = 0       ! nombre de reflections pouvant obeir a la regle d"extinction
          n_ext = 0   ! nombre de reflecions obeissant a la regle
          do h=-6, 6, 1
             hh(1)=h
             hh(2)=0
             hh(3)=0
             if (h /= int(h/4)*4) then
                n=n+1
                if (hkl_absent(hh,Spacegroup)) n_ext=n_ext+1
             end if
          end do     ! h loop
          if (n==n_ext) then
             if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti,": ", Hkl_Ref_Conditions(num_exti)
             if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti+1,": ", Hkl_Ref_Conditions(num_exti+1)
             serial_condition = .true.
          end if
       end if ! fin de la condition "if cubic

       if (SpaceGroup%CrystalSys(1:10) == "Monoclinic" .or. SpaceGroup%CrystalSys(1:12) == "Orthorhombic" .or.   &
          SpaceGroup%CrystalSys(1:10) == "Tetragonal" .or. SpaceGroup%CrystalSys(1:5)  == "Cubic" ) then
          ! Hkl_Ref_Conditions(44) =   "(0 k 0)      k=2n : screw axis // [010] with  b/2 translation (21)"   ! monoclinic, ortho., tetra and cubic
          num_exti = 44
          n = 0       ! nombre de reflections pouvant obeir a la regle d"extinction
          n_ext = 0   ! nombre de reflecions obeissant a la regle
          do k=-6, 6, 1
             hh(1)=0
             hh(2)=k
             hh(3)=0
             if (k /= int(k/2)*2) then
                n=n+1
                if (hkl_absent(hh,Spacegroup)) n_ext=n_ext+1
             end if
          end do     ! h loop
          if (n==n_ext) then
             if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti,": ", Hkl_Ref_Conditions(num_exti)
             serial_condition = .true.
          end if
       end if   ! fin de la condition "if mono, ortho, tetra, cubic

       if (SpaceGroup%CrystalSys(1:5) == "Cubic") then
          ! Hkl_Ref_Conditions(45) =   "(0 k 0)      k=2n : screw axis // [010] with  2b/4 translation (42)"   ! cubic
          num_exti = 45
          n = 0       ! nombre de reflections pouvant obeir a la regle d"extinction
          n_ext = 0   ! nombre de reflecions obeissant a la regle
          do k=-6, 6, 1
             hh(1)=0
             hh(2)=k
             hh(3)=0
             if (k /= int(k/2)*2) then
                n=n+1
                if (hkl_absent(hh,Spacegroup)) n_ext=n_ext+1
             end if
          end do     ! h loop
          if (n==n_ext) then
             if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti,": ", Hkl_Ref_Conditions(num_exti)
             serial_condition = .true.
          end if

          ! Hkl_Ref_Conditions(46) =   "(0 k 0)      k=4n : screw axis // [010] with  b/4 translation (41)"   ! cubic
          ! Hkl_Ref_Conditions(47) =   "(0 k 0)      k=4n : screw axis // [010] with 3b/4 translation (43)"   ! cubic
          num_exti = 46
          n = 0       ! nombre de reflections pouvant obeir a la regle d"extinction
          n_ext = 0   ! nombre de reflecions obeissant a la regle
          do k=-6, 6, 1
             hh(1)=0
             hh(2)=k
             hh(3)=0
             if (k /= int(k/4)*4) then
                n=n+1
                if (hkl_absent(hh,Spacegroup)) n_ext=n_ext+1
             end if
          end do     ! h loop
          if (n==n_ext) then
             if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti,": ", Hkl_Ref_Conditions(num_exti)
             if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti+1,": ", Hkl_Ref_Conditions(num_exti+1)
             serial_condition = .true.
          end if
       end if ! fin de la condition "if cubic

       if (SpaceGroup%CrystalSys(1:10) == "Monoclinic" .or. SpaceGroup%CrystalSys(1:12) == "Orthorhombic" .or.   &
          SpaceGroup%CrystalSys(1:5)  == "Cubic" ) then
          ! Hkl_Ref_Conditions(48) =   "(0 0 l)      l=2n : screw axis // [00l] with  c/2 translation (21)"   ! monoclinic, ortho. and cubic
          num_exti = 48
          n = 0       ! nombre de reflections pouvant obeir a la regle d"extinction
          n_ext = 0   ! nombre de reflecions obeissant a la regle
          do l=-6, 6, 1
             hh(1)=0
             hh(2)=0
             hh(3)=l
             if (l /= int(l/2)*2) then
                n=n+1
                if (hkl_absent(hh,Spacegroup)) n_ext=n_ext+1
             end if
          end do     ! h loop
          if (n==n_ext) then
             if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti,": ", Hkl_Ref_Conditions(num_exti)
             serial_condition = .true.
          end if
       end if  ! fin de la condition mono, ortho, tetra, cubic

       if (SpaceGroup%CrystalSys(1:5) == "Cubic" .or. SpaceGroup%CrystalSys(1:10) == "Tetragonal") then
          ! 49
          ! Hkl_Ref_Conditions(49) =   "(0 0 l)      l=2n : screw axis // [00l] with  c/2 translation (21)"   ! monoclinic, ortho. and cubic
          num_exti = 49
          n = 0       ! nombre de reflections pouvant obeir a la regle d"extinction
          n_ext = 0   ! nombre de reflecions obeissant a la regle
          do l=-6, 6, 1
             hh(1)=0
             hh(2)=0
             hh(3)=l
             if (l /= int(l/2)*2) then
                n=n+1
                if (hkl_absent(hh,Spacegroup)) n_ext=n_ext+1
             end if
          end do     ! h loop
          if (n==n_ext) then
             if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti,": ", Hkl_Ref_Conditions(num_exti)
             serial_condition = .true.
          end if

          ! 50 51
          ! Hkl_Ref_Conditions(50) =  "(0 0 l)      l=4n : screw axis // [00l] with  c/4 translation (41)"   ! tetragonal and cubic
          ! Hkl_Ref_Conditions(51) =  "(0 0 l)      l=4n : screw axis // [00l] with 3c/4 translation (43)"   ! tetragonal and cubic
          num_exti = 50
          n = 0       ! nombre de reflections pouvant obeir a la regle d"extinction
          n_ext = 0   ! nombre de reflecions obeissant a la regle
          do l=-6, 6, 1
             hh(1)=0
             hh(2)=0
             hh(3)=l
             if (l /= int(l/4)*4) then
                n=n+1
                if (hkl_absent(hh,Spacegroup)) n_ext=n_ext+1
             end if
          end do     ! h loop
          if (n==n_ext) then
             if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti,": ", Hkl_Ref_Conditions(num_exti)
             if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti+1,": ", Hkl_Ref_Conditions(num_exti+1)
             serial_condition = .true.
          end if
       end if ! fin de la condition "if cubic

       if (SpaceGroup%SPG_Latsy(1:1) == "h") then

          !52:
          ! Hkl_Ref_Conditions(52) =   "(0 0 0 l)    l=2n : screw axis // [00l] axis with 3c/6 translation (63)"
          num_exti = 52
          n = 0       ! nombre de reflections pouvant obeir a la regle d"extinction
          n_ext = 0   ! nombre de reflecions obeissant a la regle
          do l=-6, 6, 1
             hh(1)=0
             hh(2)=0
             hh(3)=l
             if (l /= int(l/2)*2) then
                n=n+1
                if (hkl_absent(hh,Spacegroup)) n_ext=n_ext+1
             end if
          end do     ! h loop
          if (n==n_ext) then
             if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti,": ", Hkl_Ref_Conditions(num_exti)
             serial_condition = .true.
          end if

          !53 54 55 56
          ! Hkl_Ref_Conditions(53) =   "(0 0 0 l)    l=3n : screw axis // [00l] axis with  c/3 translation (31)"
          ! Hkl_Ref_Conditions(54) =   "(0 0 0 l)    l=3n : screw axis // [00l] axis with 2c/3 translation (32)"
          ! Hkl_Ref_Conditions(55) =   "(0 0 0 l)    l=3n : screw axis // [00l] axis with 2c/6 translation (62)"
          ! Hkl_Ref_Conditions(56) =   "(0 0 0 l)    l=3n : screw axis // [00l] axis with 4c/6 translation (64)"
          num_exti = 53
          n = 0       ! nombre de reflections pouvant obeir a la regle d"extinction
          n_ext = 0   ! nombre de reflecions obeissant a la regle
          do l=-6, 6, 1
             hh(1)=0
             hh(2)=0
             hh(3)=l
             if (l /= int(l/3)*3) then
                n=n+1
                if (hkl_absent(hh,Spacegroup)) n_ext=n_ext+1
             end if
          end do     ! h loop

          if (n==n_ext) then
                 if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti,": ", Hkl_Ref_Conditions(num_exti)
             if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti+1,": ", Hkl_Ref_Conditions(num_exti+1)
             if (SpaceGroup%laue(1:3) == "6/m") then
                  if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti+2,": ", Hkl_Ref_Conditions(num_exti+2)
                if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti+3,": ", Hkl_Ref_Conditions(num_exti+3)
             end if ! fin de la condition "6/m
             serial_condition   = .true.
          end if

          if (SpaceGroup%laue(1:3) == "6/m") then
             !57 58:
             ! Hkl_Ref_Conditions(57) =   "(0 0 0 l)    l=6n : screw axis // [00l] axis with  c/6 translation (61)"
             ! Hkl_Ref_Conditions(58) =   "(0 0 0 l)    l=6n : screw axis // [00l] axis with 5c/6 translation (65)"
             num_exti = 57
             n = 0       ! nombre de reflections pouvant obeir a la regle d"extinction
             n_ext = 0   ! nombre de reflecions obeissant a la regle
             do l=-6, 6, 1
                hh(1)=0
                hh(2)=0
                hh(3)=l
                if (l /= int(l/6)*6) then
                   n=n+1
                   if (hkl_absent(hh,Spacegroup)) n_ext=n_ext+1
                end if
             end do     ! h loop
             if (n==n_ext) then
                  if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti,": ", Hkl_Ref_Conditions(num_exti)
                if (present(iunit)) write(unit=iunit,fmt="(tr5,a,i2,2a)")  "#",num_exti+1,": ", Hkl_Ref_Conditions(num_exti+1)
                serial_condition   = .true.
             end if
          end if ! fin de la condition "6/m
       end if  ! fin de la condition "if hexagonal

       if (.not. serial_condition)   then
          if (present(iunit)) write(unit=iunit,fmt=*) "     =====>>> no serial reflection condition"
       end if

       return
    End Subroutine Screw_Axis_Conditions

    !!----
    !!---- Subroutine Search_Extintions(Spacegroup, iunit)
    !!----    type (Space_Group_Type), intent(in) :: Spacegroup
    !!----    integer,                 intent(in) :: iunit
    !!----    or
    !!----    type (Space_Group_Type),         intent(in) :: Spacegroup
    !!----    integer,                         intent(out):: nlines
    !!----    character(len=80), dimension(:), intent(out) :: filevar
    !!----
    !!----    Write information about the Reflections Extintion for SpaceGroup
    !!----
    !!---- Update: May - 2005
    !!

    !!--++
    !!--++ Subroutine Search_Extintions_Iunit(Spacegroup, iunit)
    !!--++    type (Space_Group_Type), intent(in) :: Spacegroup
    !!--++    integer,                 intent(in) :: iunit
    !!--++
    !!--++    (Overloaded)
    !!--++    Write information about the Reflections Extintion for SpaceGroup
    !!--++
    !!--++ Update: May - 2005
    !!
    Subroutine Search_Extinctions_Iunit(Spacegroup, Iunit)
       !---- Arguments ----!
       type (Space_Group_Type), intent(in)     :: spacegroup
       integer,                 intent(in)     :: Iunit

       if (.not. hkl_ref_cond_ini) then
          call init_ref_cond()
          hkl_ref_cond_ini=.true.
       end if
       call integral_conditions(spacegroup,iunit)
       call glide_planes_conditions(spacegroup,iunit)
       call screw_axis_conditions(spacegroup,iunit)

       return
    End Subroutine Search_Extinctions_Iunit

    !!--++
    !!--++ Subroutine Search_Extinctions_File(Spacegroup, nlines, filevar)
    !!--++    type (Space_Group_Type),        intent(in)  :: Spacegroup
    !!--++    integer,                        intent(out) :: nlines
    !!--++    character(len=80),dimension(:), intent(out) :: filevar
    !!--++
    !!--++    (Overloaded)
    !!--++    Write information about the Reflections Extintion for SpaceGroup
    !!--++    in filevar variable
    !!--++
    !!--++ Update: April - 2009
    !!
    Subroutine Search_Extinctions_File(Spacegroup, nlines, filevar)
       !---- Arguments ----!
       type (Space_Group_Type), intent(in)          :: Spacegroup
       integer,                 intent(out)         :: nlines
       character(len=*), dimension(:), intent(out)  :: filevar

       !---- Local Variables ----!
       integer            :: iunit,ierr
       character(len=132) :: line

       ! Init
       nlines=0
       filevar=' '

       ! Load Information
       if (.not. hkl_ref_cond_ini) then
          call init_ref_cond()
          hkl_ref_cond_ini=.true.
       end if

       call Get_LogUnit(iunit)
       open(unit=iunit,file='search_extin_xyx.tmp')

       call integral_conditions(spacegroup,iunit)
       call glide_planes_conditions(spacegroup,iunit)
       call screw_axis_conditions(spacegroup,iunit)

       rewind(unit=iunit)
       do
          read(unit=iunit,fmt='(a)', iostat=ierr) line
          if (ierr /=0) exit
          nlines=nlines+1
          filevar(nlines)=trim(line)
       end do
       close(unit=iunit, status='delete')

       return
    End Subroutine Search_Extinctions_File

    !!----
    !!---- Subroutine Write_Asu(Spacegroup, iunit)
    !!----    type (Space_Group_Type), intent(in) :: Spacegroup
    !!----    integer,optional,        intent(in) :: iunit
    !!----
    !!----    Write information about the asymmetric unit for reciprocal
    !!----    space.
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Write_Asu(Spacegroup, iunit)
       !---- Arguments ----!
       type (space_group_type), intent(in) :: Spacegroup
       integer,optional,        intent(in) :: iunit

       !---- Local Variables ----!
       character(len=120)                  :: line
       character(len=2)                    :: inf
       integer                             :: lun

       if (present(iunit)) then
         lun=iunit
       else
         lun=6
       end if

       line(1:10)=" [     ]  "
       line(3:7)=spacegroup%laue

       if (spacegroup%numspg > 0 .and. spacegroup%numspg <= 231) then
          select case (spacegroup%numspg)
             case (1:2)       ! -1
                line(11:)="hkl: l >=0    hk0: h >=0    0k0: k >=0"

             case (3:15)      ! 2/m
                inf(1:2)=adjustl(Spacegroup%info(1:2))
                if(inf(1:1) == "-") inf(1:1)=inf(2:2)
                select case (inf(1:1))
                   case ("b")    ! 1 2/m 1
                      line(11:)="hkl: k >=0, l >=0   hk0: h >=0"
                   case ("c")    ! 1 1 2/m
                      line(11:)="hkl: k >=0, l >=0   h0l: h >=0"
                   case ("a")    ! 2/m 1 1
                      line(11:)="hkl: h >=0, l >=0   0kl: l >=0" !  Provisional (to be tested)
                end select

             case (16:74)      ! mmm
                line(11:)="hkl: h >=0, k >=0, l >=0"

             case (75:88)      ! 4/m
                line(11:)="hkl: h >=0, l >=0 with k >=0 if h =0 and k >0 if h >0"

             case (89:142)     ! 4/mmm
                line(11:)="hkl: h >=0, k >=0, l >=0 and h >=k"

             case (143:148)    ! -3
                line(11:)="hkl: h+k>0, l>0    hk0: h>0, k>=0"

             case (149,151,153,157,159,162,163)  ! -3 1 m
                line(11:)="hkl: h >=0, h >=k >0   and  h0l: h >=0, l >=0"

             case (150,152,154,155,156,158,160,161,164,165,166,167)   ! -3 m
                line(11:)="hkl: h >=0  h >=k  and   hhl: h >=0, l >=0 "

             case (168:176)  ! 6/m
                line(11:)="hkl: h > 0, k > 0, l >=0   and  0kl: k >=0, l >=0 "

             case (177:194)  ! 6/mmmm
                line(11:)="hkl: h >=0, k >=0, l >=0 with h >=k"

             case (195:206)  ! m-3
                line(11:)="hkl: h > l, k > l, l >=0  and   hkk: k >=0, h >=k"

             case (207:230)  ! m-3m
                line(11:)="hkl: h >=0, k >=0, l >=0 with h >=k  and k >=l"

          end select
       else
          select case(SpaceGroup%Laue)
             case("-1   ")
                line(11:)="hkl: l >=0    hk0: h >=0    0k0: k >=0"
             case("2/m  ")
                line(11:)="hkl: k >=0, l >=0   hk0: h >=0"
             case("mmm  ")
                line(11:)="hkl: h >=0, k >=0, l >=0"
             case("4/m  ")
                line(11:)="hkl: h >=0, l >=0 with k >=0 if h =0 and k >0 if h >0"
             case("4/mmm")
                 line(11:)="hkl: h >=0, k >=0, l >=0 and h >=k"
             case("-3   ")
                line(11:)="hkl: h+k>0, l>0    hk0: h>0, k>=0"
             case("-3m  ")
                line(11:)="hkl: h >=0  h >=k  and   hhl: h >=0, l >=0 "
             case("-31m ")
                line(11:)="hkl: h >=0, h >=k >0   and  h0l: h >=0, l >=0"
             case("6/m  ")
                line(11:)="hkl: h > 0, k > 0, l >=0   and  0kl: k >=0, l >=0 "
             case("6/mmm")
                line(11:)="hkl: h >=0, k >=0, l >=0 with h >=k"
             case("m-3  ")
                line(11:)="hkl: h > l, k > l, l >=0  and   hkk: k >=0, h >=k"
             case("m-3m ")
                line(11:)="hkl: h >=0, k >=0, l >=0 with h >=k  and k >=l"
             case default
                err_refl=.true.
                ERR_Refl_Mess=" SpaceGroup Laue Wrong"
                return
          end select
       end if

       write(unit=lun,fmt="(a)") " => Reciprocal Asymmetric Unit "
       write(unit=lun,fmt="(a)") "   "//line

       return
    End Subroutine Write_Asu

    !!----
    !!---- Subroutine Write_RefList_Info(Reflex, iunit)
    !!----    type (Reflection_List_Type), intent(in) :: Reflex
    !!----    integer,optional,            intent(in) :: iunit
    !!----
    !!----    Write information about the Reflection List
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Write_RefList_Info(Rfl, Iunit, Mode)
       !---- Arguments ----!
       type (Reflection_List_Type), intent(in) :: Rfl
       integer,optional,            intent(in) :: iunit
       character(len=*), optional,  intent(in) :: Mode

       !---- Local variables ----!
       integer :: i,lun
       integer :: hmax,kmax,lmax,hmin,kmin,lmin
       real    :: delta

       lun=6
       if (present(iunit)) lun=iunit

       if (present(mode)) then
          Select Case (mode(1:3))
             Case("NUC","nuc")
                write(unit=lun,fmt="(/,/,a)") "    LIST OF REFLECTIONS AND STRUCTURE FACTORS(NEUTRONS)"
                write(unit=lun,fmt="(a)")     "    ==================================================="
             Case default
                write(unit=lun,fmt="(/,/,a)") "    LIST OF REFLECTIONS AND STRUCTURE FACTORS(X-RAYS)"
                write(unit=lun,fmt="(a)")     "    ================================================="
          End Select

       else
          write(unit=lun,fmt="(a)")   "    LIST OF REFLECTIONS AND STRUCTURE FACTORS(X-RAYS)"
          write(unit=lun,fmt="(a)")   "    ================================================="
       end if

       hmax=maxval(rfl%ref%h(1))
       kmax=maxval(rfl%ref%h(2))
       lmax=maxval(rfl%ref%h(3))

       hmin=minval(rfl%ref%h(1))
       kmin=minval(rfl%ref%h(2))
       lmin=minval(rfl%ref%h(3))

       write(unit=lun,fmt="(/,a,/)") "   H   K   L   Mult  SinTh/Lda    |Fobs|      SFobs        |Fc|       Delta"
       do i=1,rfl%Nref
          delta=rfl%ref(i)%Fo-rfl%ref(i)%Fc
          write(unit=lun,fmt="(3i4,i5,5f12.5)") rfl%ref(i)%h, rfl%ref(i)%mult,     &
              rfl%ref(i)%S, rfl%ref(i)%Fo,rfl%ref(i)%SFo, rfl%ref(i)%Fc, delta
       end do

       write(unit=lun,fmt="(a)") " "
       write(unit=lun,fmt="(a)") " "
       write(unit=lun,fmt="(a,i6)") " => Number of Reflections: ", rfl%nref
       write(unit=lun,fmt="(a,i4,tr3,a,i4,tr3,a,i4)") " => H_max: ",hmax," K_max: ",kmax," L_max: ",lmax
       write(unit=lun,fmt="(a,i4,tr3,a,i4,tr3,a,i4)") " => H_min: ",hmin," K_min: ",kmin," L_min: ",lmin
       write(unit=lun,fmt="(a)") " "

       return
    End Subroutine Write_RefList_Info

 End Module CFML_Reflections_Utilities

!!-------------------------------------------------------
!!---- Crystallographic Fortran Modules Library (CrysFML)
!!-------------------------------------------------------
!!---- The CrysFML project is distributed under LGPL. In agreement with the
!!---- Intergovernmental Convention of the ILL, this software cannot be used
!!---- in military applications.
!!----
!!---- Copyright (C) 1999-2012  Institut Laue-Langevin (ILL), Grenoble, FRANCE
!!----                          Universidad de La Laguna (ULL), Tenerife, SPAIN
!!----                          Laboratoire Leon Brillouin(LLB), Saclay, FRANCE
!!----
!!---- Authors: Juan Rodriguez-Carvajal (ILL)
!!----          Javier Gonzalez-Platas  (ULL)
!!----
!!---- Contributors: Laurent Chapon     (ILL)
!!----               Marc Janoschek     (Los Alamos National Laboratory, USA)
!!----               Oksana Zaharko     (Paul Scherrer Institute, Switzerland)
!!----               Tierry Roisnel     (CDIFX,Rennes France)
!!----               Eric Pellegrini    (ILL)
!!----
!!---- This library is free software; you can redistribute it and/or
!!---- modify it under the terms of the GNU Lesser General Public
!!---- License as published by the Free Software Foundation; either
!!---- version 3.0 of the License, or (at your option) any later version.
!!----
!!---- This library is distributed in the hope that it will be useful,
!!---- but WITHOUT ANY WARRANTY; without even the implied warranty of
!!---- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
!!---- Lesser General Public License for more details.
!!----
!!---- You should have received a copy of the GNU Lesser General Public
!!---- License along with this library; if not, see <http://www.gnu.org/licenses/>.
!!----
!!---- MODULE: CFML_Atom_TypeDef
!!----   INFO: Subroutines related to Atoms definitions
!!----
!!---- HISTORY
!!----    Update: 06/03/2011
!!----
!!----
!!---- DEPENDENCIES
!!----
!!--++    Use CFML_GlobalDeps,                only: Cp, Pi
!!--++    Use CFML_Math_General,              only: Modulo_Lat, Equal_Vector
!!--++    Use CFML_Math_3D,                   only: matrix_diageigen, determ_a,
!!--++    Use CFML_String_Utilities,          only: setnum_std
!!--++    Use CFML_Crystal_Metrics,           only: Crystal_Cell_Type, convert_b_betas,    &
!!--++                                              convert_b_u, convert_betas_b,          &
!!--++                                              convert_betas_u, convert_u_b,          &
!!--++                                              convert_u_betas, u_equiv
!!--++    Use CFML_Crystallographic_Symmetry, only: Space_Group_Type, ApplySo, Lattice_Trans, &
!!--++                                              Get_Multip_Pos, Get_Stabilizer
!!--++
!!----
!!---- VARIABLES
!!----    ATOM_TYPE
!!----    ATOMS_CELL_TYPE
!!----    ATOM_LIST_TYPE
!!----    MATOM_TYPE
!!----    MATOM_LIST_TYPE
!!----    ERR_ATMD
!!----    ERR_ATMD_MESS
!!--++    R_ATOM           [Private]
!!----
!!---- PROCEDURES
!!----    Functions:
!!----       EQUIV_ATM
!!----       WRT_LAB
!!----
!!----    Subroutines:
!!----       ALLOCATE_ATOMS_CELL
!!----       ALLOCATE_ATOM_LIST
!!----       ALLOCATE_MATOM_LIST
!!----       ATLIST1_EXTENCELL_ATLIST2
!!----       ATOMS_CELL_TO_LIST
!!----       ATOM_LIST_TO_CELL
!!----       ATOM_UEQUI_LIST
!!----       COPY_ATOM_LIST
!!----       DEALLOCATE_ATOMS_CELL
!!----       DEALLOCATE_ATOM_LIST
!!----       DEALLOCATE_MATOM_LIST
!!----       GET_ATOM_2ND_TENSOR_CTR
!!----       INIT_ATOM_TYPE
!!----       INIT_ERR_ATMD
!!----       MERGE_ATOMS_PEAKS
!!----       MULTI
!!----       READ_BIN_ATOM_LIST
!!----       SET_ATOM_EQUIV_LIST
!!----       WRITE_ATOM_LIST
!!----       WRITE_BIN_ATOM_LIST
!!----
!!
 Module CFML_Atom_TypeDef

    !---- Use Modules ----!
    Use CFML_GlobalDeps,                only: Cp, Pi
    Use CFML_Math_General,              only: Modulo_Lat, Equal_Vector
    Use CFML_String_Utilities,          only: setnum_std
    Use CFML_Math_3D,                   only: matrix_diageigen
    Use CFML_Crystal_Metrics,           only: Crystal_Cell_Type, convert_b_betas,    &
                                              Convert_b_u, convert_betas_b,          &
                                              convert_betas_u, convert_u_b,          &
                                              convert_u_betas, u_equiv
    Use CFML_Crystallographic_Symmetry, only: Space_Group_Type, ApplySo, Lattice_Trans, &
                                              Get_Multip_Pos, Get_Stabilizer

    !---- Variables ----!
    implicit none

    private

    !---- List of public overloaded procedures: subroutines ----!

    !---- List of public functions ----!
    public :: Equiv_Atm, Wrt_Lab

    !---- List of public subroutines ----!
    public :: Allocate_Atoms_Cell, Allocate_Atom_List, Atlist1_Extencell_Atlist2,     &
              Atoms_Cell_To_List, Atom_List_To_Cell, Atom_Uequi_List, Copy_Atom_list, &
              Deallocate_Atoms_Cell, Deallocate_Atom_List, Init_Atom_Type,            &
              Init_Err_Atmd, Merge_Atoms_Peaks, Multi, Write_Atom_List,               &
              Allocate_mAtom_list, Deallocate_mAtom_list,                             &
              Init_mAtom_Type, Read_Bin_Atom_List, Write_Bin_Atom_List,               &
              Set_Atom_Equiv_List, Get_Atom_2nd_Tensor_Ctr

    !---- List of private Subroutines ----!

    !---- Definitions ----!

     !!---- 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 :: ATOM_TYPE
    !!--..
    !!---- Type, public :: Atom_Type
    !!----    character(len=20)                       :: Lab           ! Label
    !!----    character(len=2)                        :: ChemSymb      ! Chemical Symbol
    !!----    character(len=4)                        :: SfacSymb      ! Symbol for Scattering Factor
    !!----    character(len=1)                        :: wyck          ! Wyckoff letter
    !!----    logical                                 :: active        ! Control for different purposes
    !!----    integer                                 :: Z             ! Atomic number
    !!----    integer                                 :: mult          ! multiplicity of the site
    !!----    real(kind=cp),dimension(3)              :: x             ! Fractional coordinates
    !!----    real(kind=cp),dimension(3)              :: x_std         ! Standard deviations
    !!----    real(kind=cp),dimension(3)              :: mx            ! Multiplier parameters of coordinates
    !!----    integer,      dimension(3)              :: lx            ! Numbers in the LSQ list of LSQ parameters for coordinates
    !!----    real(kind=cp)                           :: occ           ! occupation factor
    !!----    real(kind=cp)                           :: occ_std       ! Standard deviation of occupation factor
    !!----    real(kind=cp)                           :: mOcc          !
    !!----    integer                                 :: lOcc          !
    !!----    real(kind=cp)                           :: Biso          ! Isotropic B-factor
    !!----    real(kind=cp)                           :: Biso_std      ! Standard deviation of Isotropic B-factor
    !!----    real(kind=cp)                           :: mBiso         !
    !!----    integer                                 :: lBiso         !
    !!----    character(len=4)                        :: utype         ! type of anisotropic thermal parameters: u_ij, b_ij, beta, none
    !!----    character(len=5)                        :: thtype        ! "isotr","aniso","other"
    !!----    real(kind=cp),dimension(6)              :: U             ! U11, U22, U33, U12, U13, U23
    !!----    real(kind=cp),dimension(6)              :: U_std         ! Standar_Deviations of U"s
    !!----    real(kind=cp)                           :: Ueq           ! Uequiv
    !!----    real(kind=cp),dimension(6)              :: mU            !
    !!----    integer,dimension(6)                    :: lU            !
    !!----    real(kind=cp)                           :: Charge        ! Charge
    !!----    real(kind=cp)                           :: Moment        ! Moment
    !!----    integer, dimension(5)                   :: Ind           ! Index for different purposes
    !!----    integer                                 :: Nvar          !
    !!----    real(kind=cp),dimension(25)             :: VarF          ! Free variables used for different purposes (1,2,3 reserved for occupations, not refinable)
    !!----    real(kind=cp),dimension(25)             :: MVarF         ! Multiplier parameters
    !!----    integer,      dimension(25)             :: LVarF         ! Numbers
    !!----    character(len=40)                       :: AtmInfo       ! Information string
    !!---- End Type Atom_Type
    !!----
    !!---- Update: May - 2009
    !!
    Type, public :: Atom_Type
       character(len=20)                        :: Lab
       character(len=2)                         :: ChemSymb
       character(len=4)                         :: SfacSymb
       character(len=1)                         :: wyck
       logical                                  :: Active
       integer                                  :: Z
       integer                                  :: Mult
       real(kind=cp),dimension(3)               :: X
       real(kind=cp),dimension(3)               :: X_Std
       real(kind=cp),dimension(3)               :: MX
       integer,      dimension(3)               :: LX
       real(kind=cp)                            :: Occ
       real(kind=cp)                            :: Occ_Std
       real(kind=cp)                            :: MOcc
       integer                                  :: LOcc
       real(kind=cp)                            :: Biso
       real(kind=cp)                            :: Biso_std
       real(kind=cp)                            :: MBiso
       integer                                  :: LBiso
       character(len=4)                         :: Utype
       character(len=5)                         :: ThType
       real(kind=cp),dimension(6)               :: U
       real(kind=cp),dimension(6)               :: U_std
       real(kind=cp)                            :: Ueq
       real(kind=cp),dimension(6)               :: MU
       integer,      dimension(6)               :: LU
       real(kind=cp)                            :: Charge
       real(kind=cp)                            :: Moment
       integer, dimension(5)                    :: Ind
       integer                                  :: NVar
       real(kind=cp),dimension(25)              :: VarF
       real(kind=cp),dimension(25)              :: MVarF
       integer,      dimension(25)              :: LVarF
       character(len=40)                        :: AtmInfo
    End Type Atom_Type

    !!----
    !!---- TYPE :: atoms_cell_type
    !!--..
    !!---- Type, public :: atoms_cell_type
    !!----    integer                                      :: nat         ! -> Total number of atoms
    !!----    character(len=20), dimension(:), allocatable :: noms        ! -> Name of atoms   (nat)
    !!----    real(kind=cp),   dimension(:,:), allocatable :: xyz         ! -> Fractional coordinates (3,nat)
    !!----    real(kind=cp),     dimension(:), allocatable :: charge
    !!----    real(kind=cp),     dimension(:), allocatable :: moment
    !!----    real(kind=cp),   dimension(:,:), allocatable :: Var_free    ! -> Free variables (10,nat)
    !!----    integer,           dimension(:), allocatable :: neighb      ! -> Number of neighbours (nat)
    !!----    integer,        dimension( :,:), allocatable :: neighb_atom ! -> Ptr.->neighbour (# in list)(nat,idp)
    !!----    real(kind=cp),  dimension( :,:), allocatable :: distance    ! -> Corresponding distances (nat,idp)
    !!----    real(kind=cp),dimension(:, :,:), allocatable :: trans       ! -> Lattice translations   (3,nat,idp)
    !!----    integer                                      :: ndist       ! -> Number of distinct distances
    !!----    real(kind=cp),     dimension(:), allocatable :: ddist       ! -> List of distinct distances(nat*idp)
    !!----    character(len=20), dimension(:), allocatable :: ddlab       ! -> Labels of atoms at ddist (nat*idp)
    !!---- End Type atoms_cell_type
    !!----
    !!---- This type is mostly used for distance-angle and Bond-valence calculations.
    !!---- It holds the position and coordination of all the atoms in the conventional
    !!---- unit cell as well as their distances to neighbours atoms.
    !!----
    !!---- Update: February - 2005
    !!
    Type, public :: Atoms_Cell_Type
       integer                                            :: nat
       character (len=20),      dimension(:), allocatable :: noms
       real(kind=cp),         dimension(:,:), allocatable :: xyz
       real(kind=cp),           dimension(:), allocatable :: charge
       real(kind=cp),           dimension(:), allocatable :: moment
       real(kind=cp),         dimension(:,:), allocatable :: var_free
       integer,                 dimension(:), allocatable :: neighb
       integer,              dimension( :,:), allocatable :: neighb_atom
       real(kind=cp),        dimension( :,:), allocatable :: distance
       real(kind=cp),      dimension(:, :,:), allocatable :: trans
       integer                                            :: ndist
       real(kind=cp),           dimension(:), allocatable :: ddist
       character (len=20),      dimension(:), allocatable :: ddlab
    End Type Atoms_Cell_Type

    !!----
    !!---- TYPE :: ATOM_LIST_TYPE
    !!--..
    !!---- Type, public :: atom_list_type
    !!----    integer                                    :: natoms  ! total number of atoms in the list
    !!----    type(Atom_Type),dimension(:),allocatable   :: atom    ! individual atoms
    !!---- End Type atom_list_type
    !!----
    !!---- Update: February - 2005
    !!
    Type, public :: Atom_List_Type
       integer                                  :: natoms
       type(Atom_Type),dimension(:),allocatable :: atom
    End type Atom_List_Type

    !!----
    !!---- TYPE :: MATOM_TYPE
    !!--..
    !!---- Type, public :: mAtom_Type
    !!----    character(len=10)                       :: Lab           ! Label
    !!----    character(len=2)                        :: ChemSymb      ! Chemical Symbol
    !!----    character(len=4)                        :: SfacSymb      ! Chemical Symbol for SF
    !!----    character(len=1)                        :: wyck          ! Wyckoff letter
    !!----    logical                                 :: active        ! Control for different purposes
    !!----    integer                                 :: Z             ! Atomic number
    !!----    integer                                 :: mult          ! multiplicity of the site
    !!----    real(kind=cp),dimension(3)              :: x             ! Fractional coordinates
    !!----    real(kind=cp),dimension(3)              :: x_std         ! Standar deviations
    !!----    real(kind=cp),dimension(3)              :: mx            ! Multiplier parameters of coordinates
    !!----    integer,      dimension(3)              :: lx            ! Numbers of LSQ parameters for coordinates
    !!----    real(kind=cp)                           :: occ           ! occupation factor
    !!----    real(kind=cp)                           :: occ_std       ! Standard deviation of occupation factor
    !!----    real(kind=cp)                           :: mOcc          !
    !!----    integer                                 :: lOcc          !
    !!----    real(kind=cp)                           :: Biso          ! Isotropic B-factor
    !!----    real(kind=cp)                           :: Biso_std      ! Standard deviation of Isotropic B-factor
    !!----    real(kind=cp)                           :: mBiso         !
    !!----    integer                                 :: lBiso         !
    !!----    character(len=4)                        :: utype         ! type of anisotropic thermal parameters: u_ij, b_ij, beta, none
    !!----    character(len=5)                        :: thtype        ! "isotr","aniso","other"
    !!----    real(kind=cp),dimension(6)              :: U             ! U11, U22, U33, U12, U13, U23
    !!----    real(kind=cp),dimension(6)              :: U_std         ! Standar_Deviations of U"s
    !!----    real(kind=cp)                           :: Ueq           ! Uequiv
    !!----    real(kind=cp),dimension(6)              :: mU            !
    !!----    real(kind=cp),dimension(6)              :: lU            !
    !!----    real(kind=cp)                           :: Charge        ! Charge
    !!----    real(kind=cp)                           :: Moment        ! Moment
    !!----    integer, dimension(5)                   :: Ind           ! Index for different purposes
    !!----    integer                                 :: Nvar          !
    !!----    real(kind=cp),dimension(25)             :: VarF          ! Free parameters to load
    !!----    real(kind=cp),dimension(25)             :: mVarF
    !!----    integer,      dimension(25)             :: LVarF
    !!----    character(len=40)                       :: AtmInfo       ! Information string
    !!----                           ===================
    !!----                           Magnetic parameters
    !!----                           ===================
    !!----    integer                                 :: nvk           ! Number of propagation vectors (excluding -k)
    !!----    integer,      dimension(12)             :: imat          ! Number of the magnetic matrices/irrep set to be applied
    !!----    real(kind=cp),dimension(3,12)           :: SkR           ! Real part of Fourier Coefficient
    !!----    real(kind=cp),dimension(3,12)           :: SkR_std       ! Standard deviations of the Real part of Fourier Coefficient
    !!----    real(kind=cp),dimension(3,12)           :: Spher_SkR     ! Real part of Fourier Coefficient in spherical components
    !!----    real(kind=cp),dimension(3,12)           :: Spher_SkR_std ! Standard deviations of Real part of Fourier Coefficient in spherical components
    !!----    real(kind=cp),dimension(3,12)           :: mSkR          ! Multipliers for the real part of Fourier coefficients
    !!----    integer,      dimension(3,12)           :: lskr          ! Numbers in the list of LSQ parameters
    !!----    real(kind=cp),dimension(3,12)           :: SkI           ! Imaginary part of Fourier Coefficient
    !!----    real(kind=cp),dimension(3,12)           :: SkI_std       ! Standard deviations of Imaginary part of Fourier Coefficient
    !!----    real(kind=cp),dimension(3,12)           :: Spher_SkI     ! Imaginary part of Fourier Coefficient in spherical components
    !!----    real(kind=cp),dimension(3,12)           :: Spher_SkI_std ! Standard deviations of Imaginary part of Fourier Coefficient in spherical components
    !!----    real(kind=cp),dimension(3,12)           :: mSki          ! Multipliers for the imaginary part of Fourier coefficients
    !!----    integer,      dimension(3,12)           :: lski          ! Numbers in the list of LSQ parameters
    !!----    real(kind=cp),dimension(12)             :: mphas         ! Magnetic Phase in fractions of 2pi
    !!----    real(kind=cp),dimension(12)             :: mphas_std     ! Standard deviations of Magnetic Phase in fractions of 2pi
    !!----    real(kind=cp),dimension(12)             :: mmphas        ! Multiplier for the magnetic phase
    !!----    integer,dimension(12)                   :: lmphas        ! Number in the list of LSQ parameters
    !!----    real(kind=cp),dimension(12,12)          :: cbas          ! Coefficients of the basis functions of irreps, the second index is 1:nvk
    !!----    real(kind=cp),dimension(12,12)          :: cbas_std      ! Standard deviations of Coefficients of the basis functions of irreps, the second index is 1:nvk
    !!----    real(kind=cp),dimension(12,12)          :: mbas          ! multiplier for the coefficients of the basis functions of irreps
    !!----    integer,dimension(12,12)                :: lbas          ! Numbers in the list of LSQ parameters
    !!----    character(len=5)                        :: chitype       ! "isotr","aniso"
    !!----    real(kind=cp),dimension(6)              :: chi           ! chi11, chi22, chi33, chi12, chi13, chi23
    !!----    real(kind=cp),dimension(6)              :: chi_std       ! Standar_Deviations of chi's
    !!----    real(kind=cp)                           :: Chieq         ! Chi equiv
    !!----    real(kind=cp),dimension(6)              :: mchi          !
    !!----    real(kind=cp),dimension(6)              :: lchi          !
    !!---- End Type mAtom_Type
    !!----
    !!---- Updated: April - 2005
    !!---- Updated: November 3, 2013 (include standard deviations of magnetic parameters,JRC)
    !!---- Updated: June 25, 2014 (include local magnetic susceptibility tensor,JRC)
    !!
    Type, public :: mAtom_Type
       character(len=10)                        :: Lab
       character(len=2)                         :: ChemSymb
       character(len=4)                         :: SfacSymb
       character(len=1)                         :: wyck
       logical                                  :: Active
       integer                                  :: Z
       integer                                  :: Mult
       real(kind=cp),dimension(3)               :: X
       real(kind=cp),dimension(3)               :: X_Std
       real(kind=cp),dimension(3)               :: MX
       integer,      dimension(3)               :: LX
       real(kind=cp)                            :: Occ
       real(kind=cp)                            :: Occ_Std
       real(kind=cp)                            :: MOcc
       integer                                  :: LOcc
       real(kind=cp)                            :: Biso
       real(kind=cp)                            :: Biso_std
       real(kind=cp)                            :: MBiso
       integer                                  :: LBiso
       character(len=4)                         :: Utype
       character(len=5)                         :: ThType
       real(kind=cp),dimension(6)               :: U
       real(kind=cp),dimension(6)               :: U_std
       real(kind=cp)                            :: Ueq
       real(kind=cp),dimension(6)               :: MU
       integer,      dimension(6)               :: LU
       real(kind=cp)                            :: Charge
       real(kind=cp)                            :: Moment
       integer, dimension(5)                    :: Ind
       integer                                  :: NVar
       real(kind=cp),dimension(25)              :: VarF
       real(kind=cp),dimension(25)              :: mVarF
       integer,      dimension(25)              :: LVarF
       character(len=40)                        :: AtmInfo

       integer                                 :: nvk
       integer,      dimension(12)             :: imat

       real(kind=cp),dimension(3,12)           :: SkR
       real(kind=cp),dimension(3,12)           :: SkR_std
       real(kind=cp),dimension(3,12)           :: Spher_SkR
       real(kind=cp),dimension(3,12)           :: Spher_SkR_std
       real(kind=cp),dimension(3,12)           :: mSkR
       integer,      dimension(3,12)           :: lskr

       real(kind=cp),dimension(3,12)           :: SkI
       real(kind=cp),dimension(3,12)           :: SkI_std
       real(kind=cp),dimension(3,12)           :: Spher_SkI
       real(kind=cp),dimension(3,12)           :: Spher_SkI_std
       real(kind=cp),dimension(3,12)           :: mSki
       integer,      dimension(3,12)           :: lski

       real(kind=cp),dimension(12)             :: mphas
       real(kind=cp),dimension(12)             :: mphas_std
       real(kind=cp),dimension(12)             :: mmphas
       integer,dimension(12)                   :: lmphas

       real(kind=cp),dimension(12,12)          :: cbas
       real(kind=cp),dimension(12,12)          :: cbas_std
       real(kind=cp),dimension(12,12)          :: mbas
       integer,dimension(12,12)                :: lbas

       character(len=5)                        :: chitype
       real(kind=cp),dimension(6)              :: chi
       real(kind=cp),dimension(6)              :: chi_std
       real(kind=cp)                           :: Chieq
       real(kind=cp),dimension(6)              :: mchi
       real(kind=cp),dimension(6)              :: lchi

    End Type mAtom_Type

    !!----
    !!---- TYPE :: MATOM_LIST_TYPE
    !!--..
    !!---- Type, public :: mAtom_list_type
    !!----    integer                                   :: natoms     ! total number of atoms in the list
    !!----    logical                                   :: suscept    ! true if magnetic moments are calculated from local susceptibility
    !!----    real(kind=cp)                             :: MagField   ! Applied magnetic field strength in Tesla
    !!----    real(kind=cp), dimension(3)               :: dir_MField ! Direction of magnetic field in crystallographic system
    !!----    type(mAtom_Type),dimension(:),allocatable :: Atom       ! individual atoms
    !!---- End Type mAtom_list_type
    !!----
    !!---- Updated: April - 2005, June - 2014
    !!
    Type, public :: mAtom_List_Type
       integer                                   :: natoms
       logical                                   :: suscept    ! true if magnetic moments are calculated from local susceptibility
       real(kind=cp)                             :: MagField   ! Applied magnetic field strength in Tesla
       real(kind=cp), dimension(3)               :: dir_MField ! Direction of magnetic field in crystallographic system
       type(mAtom_Type),dimension(:),allocatable :: Atom
    End type mAtom_List_Type
    !!----
    !!---- ERR_ATMD
    !!----    logical, public  :: err_atmd
    !!----
    !!----    Logical Variable taking the value .true. if an error in the module ATOM_DISTANCES occurs.
    !!----
    !!---- Update: February - 2005
    !!
    logical, public  :: ERR_Atmd

    !!----
    !!---- ERR_ATMD_MESS
    !!----    character(len=150), public:: Err_Atmd_Mess
    !!----
    !!----    String containing information about the last error
    !!----
    !!---- Update: February - 2005
    !!
    character(len=150), public :: Err_Atmd_Mess

    !!--++
    !!--++ R_ATOM
    !!--++    real(kind=cp), parameter, private :: r_atom=1.1
    !!--++
    !!--++    (PRIVATE)
    !!--++    Average atomic radius. Value taken for internal calculations.
    !!--++
    !!--++ Update: February - 2005
    !!
    real(kind=cp), parameter, private :: r_atom=1.1

Contains

    !---- Functions ----!

    !!----
    !!---- Logical 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
    !!
    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

       return
    End Function Equiv_Atm

    !!----
    !!---- 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
    !!
    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

       return
    End Function Wrt_Lab

    !---- Subroutines ----!

    !!----
    !!---- Subroutine Allocate_Atoms_Cell(Nasu,Mul,Dmax,Ac)
    !!----    integer, intent(in)                      :: nasu    !  In -> Number of atoms in asymmetric unit
    !!----    integer, intent(in)                      :: mul     !  In -> General multiplicity of the Space Group
    !!----    real(kind=cp),    intent(in)             :: dmax    !  In -> Maximun distance to be calculated
    !!----    type (atoms_cell_type), intent(in out)   :: Ac      !  In -> Object of type atoms_cell_type
    !!----                                                          Out -> Allocated and initialized object Ac
    !!----
    !!----    Allocation of objet "Ac" of type Atoms_Cell. "Ac" contains
    !!----    components with ALLOCATABLE attribute with dimension depending
    !!----    on the input arguments "Nasu", "Mul" and "Dmax". The variables used for calculating the
    !!----    de dimensions are:
    !!--<<
    !!----          natcel=nasu*mul       and      id=idp=nint(0.74048*(dmax/r_atom)**3)
    !!-->>
    !!----    This subroutine should be called before using the subroutines of this module with
    !!----    dummy arguments of type Atoms_Cell.
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Allocate_Atoms_Cell(Nasu,Mul,Dmax,Ac)
       !---- Arguments ----!
       integer,                intent(in)     :: nasu
       integer,                intent(in)     :: mul
       real(kind=cp),          intent(in)     :: dmax
       type (atoms_cell_type), intent(in out) :: Ac

       !---- local variables ----!
       integer :: natcel,id

       natcel=nasu*mul
       id=nint(0.74048*(dmax/r_atom)**3)
       id=max(id,natcel)

       if (.not. allocated(Ac%noms        ))   allocate (Ac%noms          (natcel))
       if (.not. allocated(Ac%xyz         ))   allocate (Ac%xyz         (3,natcel))
       if (.not. allocated(Ac%charge      ))   allocate (Ac%charge        (natcel))
       if (.not. allocated(Ac%moment      ))   allocate (Ac%moment        (natcel))
       if (.not. allocated(Ac%var_free    ))   allocate (Ac%var_free   (10,natcel))
       if (.not. allocated(Ac%neighb      ))   allocate (Ac%neighb        (natcel))
       if (.not. allocated(Ac%neighb_atom ))   allocate (Ac%neighb_atom(id,natcel))
       if (.not. allocated(Ac%distance    ))   allocate (Ac%distance   (id,natcel))
       if (.not. allocated(Ac%trans       ))   allocate (Ac%trans    (3,id,natcel))
       if (.not. allocated(Ac%ddist       ))   allocate (Ac%ddist      (natcel*id))
       if (.not. allocated(Ac%ddlab       ))   allocate (Ac%ddlab      (natcel*id))

       Ac%nat         = natcel
       Ac%noms        = " "
       Ac%xyz         = 0.0
       Ac%charge      = 0.0
       Ac%moment      = 0.0
       Ac%var_free    = 0.0
       Ac%neighb      = 0
       Ac%neighb_atom = 0
       Ac%distance    = 0.0
       Ac%trans       = 0
       Ac%ddist       = 0.0
       Ac%ddlab       = " "

       return
    End Subroutine Allocate_Atoms_Cell

    !!----
    !!---- Subroutine Allocate_Atom_List(N,A, Fail)
    !!----    integer, intent(in)                    :: n    !  In -> Number of elements of A
    !!----    type (atom_list_type), intent(in out)  :: A    !  In -> Objet to be allocated
    !!----    logical, optional,     intent(out)     :: fail
    !!----
    !!----    Allocation of objet A of type atom_list. This subroutine
    !!----    should be called before using an object of type atom_list.
    !!----
    !!---- Update: March - 2005
    !!
    Subroutine Allocate_Atom_List(N,A,Fail)
       !---- Arguments ----!
       integer,               intent(in)       :: n  !# atoms in asymmetric unit
       type (atom_list_type), intent(in out)   :: A  !Objet to be allocated
       logical, optional,     intent(out)      :: fail

       !---- Local Variables ----!
       integer :: i,ier

       A%natoms = n
       if (present(fail)) fail=.false.
       if (allocated(A%Atom)) deallocate(A%Atom)
       allocate (A%atom(n),stat=ier)
       if (ier /= 0) then
          A%natoms = 0
          if (present(fail)) fail=.true.
          return
       end if
       do i=1,n
          call init_atom_type(A%atom(i))
       end do

       return
    End Subroutine Allocate_atom_list

    !!----
    !!---- Subroutine Allocate_Matom_List(N,A)
    !!----    integer,                              intent(in)     :: n    !  In -> Number of elements of A
    !!----    type (mAtom_list_type),               intent(in out) :: A    !  In -> Objet to be allocated
    !!----    real(kind=cp), optional,              intent(in)     :: MField
    !!----    real(kind=cp), optional,dimension(3), intent(in)     :: dirF
    !!----
    !!----    Allocation of objet A of type mAtom_list. This subroutine
    !!----    should be called before using an object of type mAtom_list.
    !!----
    !!---- Updated: April - 2005, June -2014
    !!
    Subroutine Allocate_Matom_List(N,A,MField,dirF)
       !---- Arguments ----!
       integer,                              intent(in)     :: n  !# atoms in asymmetric magnetic unit
       type (mAtom_list_type),               intent(in out) :: A  !Objet to be allocated
       real(kind=cp), optional,              intent(in)     :: MField
       real(kind=cp), optional,dimension(3), intent(in)     :: dirF

       !---- Local Variables ----!
       integer :: i

       A%natoms = n
       A%suscept=.false.
       A%MagField=0.0
       A%dir_MField=(/0.0,0.0,1.0/)
       if (allocated(A%Atom)) deallocate(A%Atom)
       allocate (A%Atom(n))
       if(present(MField)) then
          A%suscept=.true.
          A%MagField=MField
       end if
       if(present(dirF))   A%dir_MField=dirF

       do i=1,n
          call init_mAtom_type(A%Atom(i))
       end do

       return
    End Subroutine Allocate_mAtom_list

    !!----
    !!---- Subroutine Atlist1_Extencell_Atlist2(Spg,A,B,Conven)
    !!----    type(Space_Group_Type), intent(in)     :: SpG       !  In -> Space Group Information
    !!----    type(atom_list_type),  intent(in)      :: A         !  In -> Atom List (asymmetric unit)
    !!----    type(atom_list_type),  intent(out)     :: B         ! Out -> Atoms in unit cell
    !!----    logical,                intent(in)     :: conven    !  In -> .true. for using the whole conventional unit cell
    !!----
    !!----    Subroutine to generate atoms in the primitive (conven=.false.) or the conventional
    !!----    unit cell (conven=.true.), Excluding atoms with A%atom(:)%active=.false.
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine AtList1_ExtenCell_AtList2(Spg,A,C,Conven)
       !---- Arguments ----!
       type(Space_Group_Type), intent(in)     :: SpG
       type(atom_list_type),   intent(in)     :: A
       type(atom_list_type),   intent(out)    :: C
       logical,                intent(in)     :: Conven

       !---- Local Variables ----!
       type(atom_list_type)                  :: b
       real(kind=cp),dimension(3)            :: xo,xx
       real(kind=cp),dimension(3,Spg%multip) :: u
       integer                               :: k,j,l,nt,npeq,n
       character(len=4)                      :: fmm

       npeq=SpG%numops
       if (SpG%centred == 2) npeq=npeq*2
       if (conven) npeq=SpG%multip

       !---- Init proccess ----!
       call allocate_atom_list(npeq*A%natoms,b)

       n=0
       do k=1,A%natoms
          if (.not. A%atom(k)%active) cycle
          l=1
          n=n+1
          B%Atom(n)=A%Atom(k)
          xo    = modulo_lat(A%atom(k)%x)
          u(:,l)= xo
          B%Atom(n)%x=xo

          do_eq:do j=2,npeq
             xx=ApplySO(SpG%SymOp(j),xo)
             xx=modulo_lat(xx)
             do nt=1,l
                if (equal_vector(u(:,nt),xx,3)) then
                   B%atom(n-(l-nt))%occ=B%atom(n-(l-nt))%occ+A%atom(k)%occ
                   cycle do_eq
                end if
             end do
             l=l+1
             u(:,l)=xx(:)
             n=n+1
             select case (l)
                case(:9)
                   write(unit=fmm,fmt="(i1)") l
                case(10:99)
                   write(unit=fmm,fmt="(i2)") l
                case(100:999)
                   write(unit=fmm,fmt="(i3)") l
             end select
             B%Atom(n)=A%Atom(k)

             B%Atom(n)%lab      =trim(A%Atom(k)%lab)//"_"//adjustl(fmm)
             B%Atom(n)%x        =xx
             B%Atom(n)%active   =.true.
             B%Atom(n)%Mult     =1.0

          end do do_eq
       end do

       B%natoms=n

       call allocate_atom_list(n,C)

       C%natoms=n
       C%atom(1:n)=B%atom(1:n)

       call deallocate_atom_list(B)

       return
    End Subroutine AtList1_ExtenCell_AtList2

    !!----
    !!---- Subroutine Atoms_Cell_To_List(Ac,A)
    !!----    Type(atoms_cell_type),  Intent(In)        :: Ac   !  In -> instance of atoms_cell_type
    !!----    type(atom_list_type),   intent(in out)    :: A    !  In -> instance of atom_list_type
    !!----                                                         Out-> Initialize atom_list_type components
    !!----
    !!----    Subroutine to construct an Atom List object "A" from an Atoms_Cell
    !!----    object "Ac". It is supposed that both objects have been previouly
    !!----    allocated using the appropriate procedures: direct allocation
    !!----    for A and call to Allocate_Atoms_Cell for Ac.
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Atoms_Cell_To_List(Ac,A)
       !---- Arguments ----!
       type(atoms_cell_type), intent(in)       :: Ac
       type(atom_list_type),  intent(in out)   :: A

       !---- Local Variables ----!
       integer :: i

       A%natoms=Ac%nat
       do i=1,Ac%nat
          A%atom(i)%Lab      = Ac%noms(i)
          A%atom(i)%ChemSymb = Ac%noms(i)(1:2)
          A%atom(i)%x(:)     = Ac%xyz(:,i)
          A%atom(i)%occ      = 1.0
          A%atom(i)%Biso     = 0.0
          A%atom(i)%mult     = 1.0
          A%atom(i)%Z        = 0
          A%atom(i)%varf     = Ac%var_free(:,i)
          A%atom(i)%charge   = Ac%charge(i)
          A%atom(i)%moment   = Ac%moment(i)
       end do

       return
    End Subroutine Atoms_Cell_To_List

    !!----
    !!---- Subroutine atom_list_To_Cell(A,Ac)
    !!----    type(atom_list_type),  intent(in)         :: A    !  In -> instance of atom_list_type
    !!----    type(atoms_cell_type),  intent(in out)    :: Ac   !  In -> instance of atoms_cell_type
    !!----                                                         Out-> Initialize atoms_cell_type components
    !!----
    !!----    Subroutine to construct an Atom Cell object "Ac" from an atom_list
    !!----    object "A". It is supposed that both objects have been previouly
    !!----    allocated using the appropriate procedures.
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Atom_List_To_Cell(A,Ac)
       !---- Arguments ----!
       type(atom_list_type),  intent(in)        :: A
       type(atoms_cell_type), intent(in out)    :: Ac

       !---- Local Variables ----!
       integer :: i

       Ac%nat=A%natoms
       do i=1,Ac%nat
          Ac%noms(i)        = A%atom(i)%lab
          Ac%xyz (:,i)      = A%Atom(i)%x
          Ac%var_free(:,i)  = A%Atom(i)%varf
       end do

       return
    End Subroutine atom_list_To_Cell

    !!----
    !!---- Subroutine Atom_Uequi_List(Cell, Ac)
    !!----    type(Crystal_Cell_Type), intent(in)    :: Cell    !  In -> Cell variable
    !!----    type(atom_list_type),   intent(in out) :: Ac      !  In -> Atom list
    !!----                                                         Out ->
    !!----
    !!----    Subroutine to obtain the U equiv from U11 U22 U33 U12 U13 U23
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Atom_Uequi_List(Cell, Ac)
       !---- Arguments ----!
       type (Crystal_cell_type), intent(in)       :: Cell
       type (atom_list_type),    intent(in out)   :: Ac

       !---- Local variables ----!
       integer                    :: i
       real(kind=cp),dimension(6) :: u

       do i=1,Ac%natoms
          u=Ac%atom(i)%u(1:6)
          Ac%atom(i)%Ueq = U_Equiv(Cell,u)
       end do

       return
    End Subroutine Atom_Uequi_List

    !!----
    !!---- Subroutine Copy_Atom_List(A, Ac)
    !!----    type(atom_list_type),   intent(in)  :: A      !  In -> Atom list
    !!----    type(atom_list_type),   intent(out) :: Ac     !   Out -> Atom list
    !!----
    !!----
    !!----    Subroutine to copy an atom list to another one
    !!----
    !!---- Update: May - 2009
    !!
    Subroutine Copy_Atom_List(A, Ac)
       !---- Arguments ----!
       type (atom_list_type),    intent(in)   :: A
       type (atom_list_type),    intent(out)  :: Ac

       !---- Local variables ----!
       integer                    :: n

       n=A%natoms
       call Allocate_Atom_List(n,Ac)
       Ac%atom(1:n)=A%atom(1:n)
       return
    End Subroutine Copy_Atom_List

    !!----
    !!---- Subroutine Deallocate_Atoms_Cell(Ac)
    !!----    type (atoms_cell_type), intent(in out)   :: Ac   !  In -> Object of atoms_cell_type
    !!----                                                     ! Out -> The object is removed from memory.
    !!----
    !!----    Deallocation of objet Ac of type Atoms_Cell.  Ac contains
    !!----    components with ALLOCATABLE attribute. This subroutine should
    !!----    be called after using this module.
    !!----
    !!---- Update: February - 2003
    !!
    Subroutine Deallocate_Atoms_Cell(Ac)
       !---- Arguments ----!
       type (atoms_cell_type), intent(in out)   :: Ac

       if (allocated(Ac%noms)       )   deallocate (Ac%noms)
       if (allocated(Ac%xyz)        )   deallocate (Ac%xyz)
       if (allocated(Ac%var_free)   )   deallocate (Ac%var_free)
       if (allocated(Ac%neighb)     )   deallocate (Ac%neighb)
       if (allocated(Ac%neighb_atom))   deallocate (Ac%neighb_atom)
       if (allocated(Ac%distance)   )   deallocate (Ac%distance)
       if (allocated(Ac%trans)      )   deallocate (Ac%trans)
       if (allocated(Ac%ddist)      )   deallocate (Ac%ddist)
       if (allocated(Ac%ddlab)      )   deallocate (Ac%ddlab)

       return
    End Subroutine Deallocate_Atoms_Cell

    !!----
    !!---- Subroutine Deallocate_atom_list(A)
    !!----    type (atom_list_type), intent(in out)   :: A  ! In/ Out -> Objet to be deallocated
    !!----
    !!----    De-allocation of objet A of type atom_list. This subroutine
    !!----    should be after using an object of type atom_list that is no
    !!----    more needed.
    !!----
    !!---- Update: February - 2003
    !!
    Subroutine Deallocate_atom_list(A)
       !---- Arguments ----!
       type (atom_list_type), intent(in out)   :: A  !Objet to be deallocated

       if (allocated(A%atom)) deallocate (A%atom)

       return
    End Subroutine Deallocate_atom_list

    !!----
    !!---- Subroutine Deallocate_mAtom_list(A)
    !!----    type (mAtom_list_type), intent(in out)   :: A  ! In/ Out -> Objet to be deallocated
    !!----
    !!----    De-allocation of objet A of type atom_list. This subroutine
    !!----    should be invoked after using an object of type mAtom_list
    !!----    that is no more needed.
    !!----
    !!---- Update: April - 2005
    !!
    Subroutine Deallocate_mAtom_list(A)
       !---- Arguments ----!
       type (mAtom_list_type), intent(in out)   :: A  !Objet to be deallocated

       if (allocated(A%Atom)) deallocate (A%Atom)

       return
    End Subroutine Deallocate_mAtom_list

    !!----
    !!----  Subroutine Get_Atom_2nd_Tensor_Ctr(x,TensVal,Spgr,Codini,Icodes,Multip,Ord,Ss,Ipr)
    !!----     real(kind=cp), dimension(3),             intent(in    ) :: x         !Atom position (fractional coordinates)
    !!----     real(kind=cp), dimension(6),             intent(in out) :: TensVal   !Second order symmetric tensor
    !!----     type(Space_Group_type),                  intent(ix    ) :: Spgr      !Space Group
    !!----     Integer,                                 intent(in out) :: Codini    !Last attributed parameter
    !!----     Integer, dimension(6),                   intent(in out) :: Icodes    !codewords for TensVal only number
    !!----     real(kind=cp), dimension(6),             intent(in out) :: Multip    !Multipliers
    !!----     integer,                       optional, intent(in    ) :: Ord       !Order of the stabilizer
    !!----     integer, dimension(:),         optional, intent(in    ) :: Ss        !Pointer to SymmOp. of stabilizer
    !!----     integer,                       optional, intent(in    ) :: Ipr       !Printing unit for debug
    !!----
    !!----  Subroutine to get the appropriate constraints in the refinement codes of
    !!----  second order symmetric tensor atomic property parameters.
    !!----  New algorithm based in the Wigner theorem.
    !!----  The matrix Bet = Sum { R Beta RT} displays the symmetry constraints to be
    !!----  applied to the 2nd order symmetric tensor components. The sum runs over all rotational
    !!----  symmetry operators of the stabilizer of the particular atom position in the given
    !!----  space group.
    !!----  There are a total of 29 kind of relations that may appear in the Bet matrix:
    !!----
    !!----     1    A A A 0   0   0  -> m-3m, -43m, 432, m-3,23, 3[111].2[001]
    !!----     2    A A C 0   0   0  -> 4/mmm, -42m, 4mm, 422, 4/m, -4,4, 4[001]
    !!----     3    A B A 0   0   0  -> 4[010]
    !!----     4    A B B 0   0   0  -> 4[100]
    !!----     5    A A A D   D   D  -> -3m, 3m, 32, -3, 3   3[111]
    !!----     6    A A A D  -D  -D  -> 3[11-1]
    !!----     7    A A A D  -D   D  -> 3[1-11]
    !!----     8    A A A D   D  -D  -> 3[-111]
    !!----     9    A A C A/2 0   0  -> 6/mmm, -6m2, 6mm, 622, 6/m, 6,-6,-3m, 32,-3, 3:  h 3[001]
    !!----    10    A B C 0   0   0  -> mmm, mm2, 222  2[001] 2[100]
    !!----    11    A A C D   0   0  -> 2[001], 2[110]    w
    !!----    12    A B A 0   E   0  -> 2[010], 2[101]
    !!----    13    A B B 0   0   F  -> 2[100], 2[011]
    !!----    14    A B C B/2 0   0  -> 2[001], 2[100]    h
    !!----    15    A B C A/2 0   0  -> 2[001], 2[010]    h
    !!----    16    A B C D   0   0  -> 2/m, m, 2: 2[001] w
    !!----    17    A B C 0   E   0  -> 2[010]
    !!----    18    A B C 0   0   F  -> 2[100]
    !!----    19    A A C D   E  -E  -> 2[110]            w
    !!----    20    A A C D   E   E  -> 2[1-10]           w
    !!----    21    A B A D   E  -D  -> 2[101]
    !!----    22    A B A D   E   D  -> 2[10-1]
    !!----    23    A B B D  -D   F  -> 2[011]
    !!----    24    A B B D   D   F  -> 2[01-1]
    !!----    25    A B C B/2 F/2 F  -> 2[100]            h
    !!----    26    A B C A/2 0   F  -> 2[210]            h
    !!----    27    A B C B/2 E   0  -> 2[120]            h
    !!----    28    A B C A/2 E   E/2-> 2[010]            h
    !!----    29    A B C D   E   F  -> 1, -1
    !!----
    !!----   Updated: 27 June 2014 (JRC)
    !!----
    Subroutine Get_Atom_2nd_Tensor_Ctr(x,TensVal,Spgr,Codini,Icodes,Multip,Ord,Ss,Ipr)
       real(kind=cp), dimension(3),             intent(in    ) :: x
       real(kind=cp), dimension(6),             intent(in out) :: TensVal
       type(Space_Group_type),                  intent(in    ) :: Spgr
       Integer,                                 intent(in out) :: Codini
       Integer, dimension(6),                   intent(in out) :: Icodes
       real(kind=cp), dimension(6),             intent(in out) :: Multip
       integer,                       optional, intent(in    ) :: Ord
       integer, dimension(:),         optional, intent(in    ) :: Ss
       integer,                       optional, intent(in    ) :: Ipr

       ! Local variables
       character (len=1), dimension(6)   :: cdd
       integer                           :: i,j,order
       integer,           dimension(48)  :: ss_ptr
       integer,           dimension(6)   :: codd
       integer,           dimension(3,3) :: Rsym
       real(kind=cp),     dimension(3,3) :: bet,bett,Rs
       real(kind=cp),     dimension(6)   :: cod
       real(kind=cp),     dimension(3,48):: atr
       real(kind=cp),     parameter      :: epss=0.01_cp

       cod=real(icodes)

       do j=1,6
          if (cod(j) < 1.0 .and. abs(multip(j)) > epss)  then
             codini=codini+1
             cod(j) = real(codini)
          end if
       end do

       if (present(ord) .and. present(ss)) then
          order=ord
          ss_ptr(1:order) = ss(1:ord)
       else
          call get_stabilizer(x,Spgr,order,ss_ptr,atr)
       end if

       bet=reshape((/17.0, 7.0,3.0,  &
                     7.0,13.0,5.0,  &
                     3.0, 5.0,11.0/),(/3,3/))
       bett=bet
       if (order > 1 ) then
          do j=2,order
             Rsym=Spgr%SymOp(ss_ptr(j))%Rot
             Rs=real(Rsym)
             bett=bett+ matmul(Rs,matmul(bet,transpose(Rs)))
          end do
       end if
       Rsym=nint(1000.0*bett)
       codd=(/Rsym(1,1),Rsym(2,2),Rsym(3,3),Rsym(1,2),Rsym(1,3),Rsym(2,3)/)
       cdd=(/'a','b','c','d','e','f'/)
       multip=1.0
       !Search systematically all the possible constraints

       if(codd(1) == codd(2) .and. codd(1) == codd(3)) then ! a a a
         if(codd(4) == codd(5) .and. codd(4) == codd(6) ) then ! a a a d d d
           if(codd(4) == 0) then
             cdd=(/'a','a','a','0','0','0'/)     ! 1 A A A 0   0   0
             multip=(/1.0,1.0,1.0,0.0,0.0,0.0/)
             TensVal(4:6)=0.0
             TensVal(2:3)=TensVal(1)
             cod(2:3)=cod(1); cod(4:6)=0.0
           else
             cdd=(/'a','a','a','d','d','d'/)     ! 5 A A A D   D   D
             multip=(/1.0,1.0,1.0,1.0,1.0,1.0/)
             TensVal(5:6)=TensVal(4)
             TensVal(2:3)=TensVal(1)
             cod(2:3)=cod(1); cod(5:6)=cod(4)
           end if
         else if(codd(4) == -codd(5) .and. codd(4) == -codd(6) ) then !a a a d -d -d
           cdd=(/'a','a','a','d','d','d'/)       ! 6 A A A D  -D  -D
           multip=(/1.0,1.0,1.0,1.0,-1.0,-1.0/)
           TensVal(5:6)=-TensVal(4)
           TensVal(2:3)=TensVal(1)
           cod(2:3)=cod(1); cod(5:6)=cod(4)
         else if(codd(4) == -codd(5) .and. codd(4) ==  codd(6) ) then !a a a d -d  d
           cdd=(/'a','a','a','d','d','d'/)       ! 7 A A A D  -D   D
           multip=(/1.0,1.0,1.0,1.0,-1.0, 1.0/)
           TensVal(5)=-TensVal(4); TensVal(6)=TensVal(4)
           TensVal(2:3)=TensVal(1)
           cod(2:3)=cod(1); cod(5:6)= cod(4)
         else if(codd(4) ==  codd(5) .and. codd(4) == -codd(6) ) then !a a a d  d -d
           cdd=(/'a','a','a','d','d','d'/)       ! 8 A A A D   D  -D
           multip=(/1.0,1.0,1.0,1.0, 1.0,-1.0/)
           TensVal(6)=-TensVal(4); TensVal(5)=TensVal(4)
           TensVal(2:3)=TensVal(1)
           cod(2:3)=cod(1); cod(5:6)= cod(4)
         end if

       else if(codd(1) == codd(2)) then ! a a c
         if(codd(4) == codd(5) .and. codd(4) == codd(6) .and. codd(4) == 0) then ! a a c 0 0 0
             cdd=(/'a','a','c','0','0','0'/)     ! 2 A A C 0   0   0
             multip=(/1.0,1.0,1.0,0.0,0.0,0.0/)
             TensVal(4:6)=0.0
             TensVal(2)=TensVal(1)
             cod(2)=cod(1); cod(4:6)= 0.0
         else if(codd(5) == codd(6) .and. codd(5) == 0) then ! a a c x 0 0
             if(codd(4) == codd(1)/2) then
               cdd=(/'a','a','c','a','0','0'/)     ! 9 A A C A/2 0   0
               multip=(/1.0,1.0,1.0,0.5,0.0,0.0/)
               TensVal(5:6)=0.0; TensVal(4)=TensVal(1)*0.5
               TensVal(2)=TensVal(1)
               cod(2)=cod(1); cod(4)= cod(1); cod(5:6)=0.0
             else
               cdd=(/'a','a','c','d','0','0'/)     !11 A A C D   0   0
               multip=(/1.0,1.0,1.0,1.0,0.0,0.0/)
               TensVal(5:6)=0.0
               TensVal(2)=TensVal(1)
               cod(2)=cod(1); cod(5:6)=0.0
             end if
         else
             if(codd(5) == codd(6)) then  ! a a c d e e
               cdd=(/'a','a','c','d','e','e'/)     !20 A A C D   E   E
               multip=(/1.0,1.0,1.0,1.0,1.0,1.0/)
               TensVal(6)=TensVal(5)
               TensVal(2)=TensVal(1)
               cod(2)=cod(1); cod(6)=cod(5)
             else if(codd(5) == -codd(6)) then  ! a a c d e -e
               cdd=(/'a','a','c','d','e','e'/)     !19 A A C D   E  -E
               multip=(/1.0,1.0,1.0,1.0,1.0,-1.0/)
               TensVal(6)=-TensVal(5)
               TensVal(2)=TensVal(1)
               cod(2)=cod(1); cod(6)=cod(5)
             end if
         end if

       else if(codd(1) == codd(3)) then ! a b a
         if(codd(4) == codd(6)) then    ! a b a d x d
           if(codd(4) == 0) then  ! a b a 0 x 0
             if(codd(5) == 0) then ! a b a 0 0 0
               cdd=(/'a','b','a','0','0','0'/)     ! 3 A B A 0   0   0
               multip=(/1.0,1.0,1.0,0.0,0.0,0.0/)
               TensVal(4:6)=0.0
               TensVal(3)=TensVal(1)
               cod(3)=cod(1); cod(4:6)=0.0
             else                  ! a b a 0 e 0
               cdd=(/'a','b','a','0','e','0'/)     !12 A B A 0   E   0
               multip=(/1.0,1.0,1.0,0.0,1.0,0.0/)
               TensVal(4)=0.0;  TensVal(6)=0.0
               TensVal(3)=TensVal(1)
               cod(3)=cod(1); cod(4)=0.0;  cod(6)=0.0
             end if
           else  !! a b a d e d
             cdd=(/'a','b','a','d','e','d'/)       !22 A B A D   E   D
             multip=(/1.0,1.0,1.0,1.0,1.0,1.0/)
             TensVal(6)=TensVal(4)
             TensVal(3)=TensVal(1)
             cod(3)=cod(1); cod(6)=cod(4)
          end if

         else if(codd(4) == -codd(6)) then ! a b a d e -d
           cdd=(/'a','b','a','d','e','d'/)         !21 A B A D   E  -D
           multip=(/1.0,1.0,1.0,1.0,1.0,-1.0/)
           TensVal(6)=-TensVal(4)
           TensVal(3)=TensVal(1)
           cod(3)=cod(1); cod(6)=cod(4)
         end if

       else if(codd(2) == codd(3)) then ! a b b
         if(codd(4) == codd(5)) then    ! a b b d d x
           if(codd(4) == 0) then  ! a b b 0 0 x
             if(codd(6) == 0) then ! a b b 0 0 0
               cdd=(/'a','b','b','0','0','0'/)     ! 4 A B B 0   0   0
               multip=(/1.0,1.0,1.0,0.0,0.0,0.0/)
               TensVal(4:6)=0.0
               TensVal(3)=TensVal(2)
               cod(3)=cod(2); cod(4:6)=0.0
             else                  ! a b b 0 0 f
               cdd=(/'a','b','b','0','0','f'/)     !13 A B B 0   0   F
               multip=(/1.0,1.0,1.0,0.0,0.0,1.0/)
               TensVal(4:5)=0.0
               TensVal(3)=TensVal(2)
               cod(3)=cod(2); cod(4:5)=0.0
             end if
           else  !! a b b d d f
             cdd=(/'a','b','b','d','d','f'/)       !24 A B B D   D   F
             multip=(/1.0,1.0,1.0,1.0,1.0,1.0/)
             TensVal(5)=TensVal(4)
             TensVal(3)=TensVal(2)
             cod(3)=cod(2); cod(5)=cod(4)
           end if
         else if(codd(4) == -codd(5)) then ! a b b d -d e
           cdd=(/'a','b','b','d','d','f'/)         !23 A B B D  -D   F
           multip=(/1.0,1.0,1.0,1.0,-1.0,1.0/)
           TensVal(5)=-TensVal(4)
           TensVal(3)=TensVal(2)
           cod(3)=cod(2); cod(5)=cod(4)
         end if

       else !Now a /= b /= c

         if(codd(4) == codd(5) .and. codd(4) == 0) then ! a b c 0 0 x
           if(codd(6) == 0) then ! a b c 0 0 0
             cdd=(/'a','b','c','0','0','0'/)          !10 A B C 0   0   0
             multip=(/1.0,1.0,1.0,0.0,0.0,0.0/)
             TensVal(4:6)=0.0
             cod(4:6)=0.0
           else
             cdd=(/'a','b','c','0','0','f'/)          !18 A B C 0   0   F
             multip=(/1.0,1.0,1.0,0.0,0.0,1.0/)
             TensVal(4:5)=0.0
             cod(4:5)=0.0
           end  if
         else if(codd(5) == codd(6) .and. codd(5) == 0) then  ! a b c x 0 0
           if(codd(4) == codd(1)/2) then ! a b c a/2 0 0
             cdd=(/'a','b','c','a','0','0'/)          !15 A B C A/2 0   0
             multip=(/1.0,1.0,1.0,0.5,0.0,0.0/)
             TensVal(5:6)=0.0; TensVal(4)=TensVal(1)*0.5
             cod(4)=cod(1); cod(5:6)=0.0
           else if(codd(4) == codd(2)/2) then    !a b c b/2 0 0
             cdd=(/'a','b','c','b','0','0'/)          !14 A B C B/2 0   0
             multip=(/1.0,1.0,1.0,0.5,0.0,0.0/)
             TensVal(5:6)=0.0; TensVal(4)=TensVal(2)*0.5
             cod(4)=cod(2); cod(5:6)=0.0
           else
             cdd=(/'a','b','c','d','0','0'/)          !16 A B C D   0   0
             multip=(/1.0,1.0,1.0,1.0,0.0,0.0/)
             TensVal(5:6)=0.0
             cod(5:6)=0.0
           end  if
         else if(codd(4) == codd(6) .and. codd(4) == 0) then !a b c 0 e 0
           cdd=(/'a','b','c','0','e','0'/)            !17 A B C 0   E   0
           multip=(/1.0,1.0,1.0,0.0,1.0,0.0/)
           TensVal(4)=0.0; TensVal(6)=0.0
           cod(4)=0.0; cod(6)=0.0
         else if(codd(4) == codd(1)/2 .and. codd(5) == 0) then !a b c a/2 0 f
           cdd=(/'a','b','c','a','0','f'/)            !26 A B C A/2 0   F
           multip=(/1.0,1.0,1.0,0.5,0.0,1.0/)
           TensVal(4)=TensVal(1)*0.5; TensVal(5)=0.0
           cod(4)=cod(1); cod(5)=0.0
         else if(codd(4) == codd(2)/2 .and. codd(6) == 0) then !a b c b/2 e 0
           cdd=(/'a','b','c','b','e','0'/)            !27 A B C B/2 E   0
           multip=(/1.0,1.0,1.0,0.5,1.0,0.0/)
           TensVal(4)=TensVal(2)*0.5; TensVal(6)=0.0
           cod(4)=cod(2); cod(6)=0.0
         else if(codd(4) == codd(2)/2 .and. codd(5) == codd(6)/2) then !a b c b/2 f/2 f
           cdd=(/'a','b','c','b','f','f'/)            !25 A B C B/2 F/2 F
           multip=(/1.0,1.0,1.0,0.5,0.5,1.0/)
           TensVal(4)=TensVal(2)*0.5; TensVal(5)=TensVal(6)*0.5
           cod(4)=cod(2); cod(5)=cod(6)
         else if(codd(4) == codd(1)/2 .and. codd(6) == codd(5)/2) then !a b c a/2 e e/2
           cdd=(/'a','b','c','a','e','e'/)            !28 A B C A/2 E   E/2
           multip=(/1.0,1.0,1.0,0.5,1.0,0.5/)
           TensVal(4)=TensVal(1)*0.5; TensVal(6)=TensVal(5)*0.5
           cod(4)=cod(1); cod(6)=cod(5)
         else
           cdd=(/'a','b','c','d','e','f'/)            !29 A B C D   E   F
           multip=(/1.0,1.0,1.0,1.0,1.0,1.0/)
         end if
       end if

       do j=1,6
          if (multip(j) < epss .or. cdd(j) == "0" ) then
             icodes(j) = 0
          else
             icodes(j) = nint(cod(j))
          end if
       end do

       if(present(Ipr)) then
         Write(Ipr,'(a,6i5)')           '     Codes on TensVal       :  ',Icodes
         Write(Ipr,'(a,6(a,1x),6f7.3)') '     Codes and multipliers:  ',cdd,multip
         Write(Ipr,'(a)')               '     Tensor_TOT matrix:  '
         Do I=1,3
          Write(Ipr,'(a,3f12.4)')       '                      ',bett(i,:)
         End Do
       end if
       return
    End Subroutine Get_Atom_2nd_Tensor_Ctr

    !!----
    !!---- Subroutine Init_Atom_Type(A)
    !!----    type (Atom_Type),  intent(in out) :: A   ! In / Out -> Atom type
    !!----
    !!----    Initialize Atom_Type
    !!----
    !!---- Update: March - 2005
    !!
    Subroutine Init_Atom_Type(A)
       !---- Arguments ----!
       type (Atom_Type), intent(in out)   :: A

       A%Lab      =" "
       A%ChemSymb =" "
       A%SfacSymb =" "
       A%Wyck     ="."
       A%Active   =.true.
       A%Z        =0
       A%Mult     =0
       A%X        =0.0
       A%X_Std    =0.0
       A%MX       =0.0
       A%LX       =0
       A%Occ      =0.0
       A%Occ_Std  =0.0
       A%MOcc     =0.0
       A%LOcc     =0
       A%Biso     =0.0
       A%Biso_std =0.0
       A%MBiso    =0.0
       A%LBiso    =0
       A%Utype    ="none"
       A%ThType   ="isotr"
       A%U        =0.0
       A%U_std    =0.0
       A%Ueq      =0.0
       A%MU       =0.0
       A%LU       =0
       A%Charge   =0.0
       A%Moment   =0.0
       A%Ind      =0
       A%NVar     =0
       A%VarF     =0.0
       A%LVarF    =0
       A%mVarF    =0.0
       A%AtmInfo  ="None"
       return
    End Subroutine Init_Atom_Type

    !!----
    !!---- Subroutine Init_mAtom_Type(A)
    !!----    type (mAtom_Type),  intent(in out) :: A   ! In / Out -> mAtom type
    !!----
    !!----    Initialize mAtom_Type
    !!----
    !!---- Updated: November 3 - 2013
    !!
    Subroutine Init_mAtom_Type(A)
       !---- Arguments ----!
       type (mAtom_Type), intent(in out)   :: A

       A%Lab      =" "
       A%ChemSymb =" "
       A%SfacSymb =" "
       A%Wyck     ="."
       A%Active   =.true.
       A%Z =0; A%Mult=1
       A%X=0.0; A%X_Std=0.0; A%MX=0.0; A%LX=0
       A%Occ=0.0; A%Occ_Std=0.0; A%MOcc=0.0; A%LOcc=0
       A%Biso=0.0; A%Biso_std=0.0; A%MBiso=0.0; A%LBiso=0
       A%Utype    ="none"
       A%ThType   ="isotr"
       A%U=0.0; A%U_std=0.0; A%Ueq=0.0; A%MU=0.0; A%LU=0
       A%Charge=0.0; A%Moment=0.0
       A%Ind=0
       A%NVar=0; A%VarF=0.0
       A%AtmInfo  =" "
       !Magnetic parameters
       A%nvk =0
       A%imat=0
       A%SkR=0.0; A%SkR_std=0.0; A%Spher_SkR=0.0; A%Spher_SkR_std=0.0; A%mSkR=0.0; A%lSkR=0
       A%SkI=0.0; A%SkI_std=0.0; A%Spher_SkI=0.0; A%Spher_SkI_std=0.0; A%mSkI=0.0; A%lSkI=0
       A%mphas=0.0; A%mphas_std=0.0; A%mmphas=0.0; A%lmphas=0
       A%cbas=0.0; A%cbas_std=0.0; A%mbas=0.0; A%lbas=0
       A%chitype="none"
       A%chi=0.0; A%chi_std=0.0; A%mchi=0.0; A%lchi=0; A%Chieq=0.0

       return
    End Subroutine Init_mAtom_Type

    !!----
    !!---- Subroutine Init_Err_Atmd()
    !!----
    !!----    Initialize the errors flags in this Module
    !!----
    !!---- Update: February - 2003
    !!
    Subroutine Init_Err_Atmd()

       ERR_Atmd=.false.
       ERR_Atmd_Mess=" "

       return
    End Subroutine Init_Err_Atmd

    !!----
    !!---- Subroutine Merge_Atoms_Peaks(Cell,Atm,Npks,Pks,Grp,NAtm)
    !!----    type(Crystal_Cell_Type),        intent(in) :: Cell  ! Cell object
    !!----    type(atom_list_type),           intent(in) :: Atm   ! Atoms List
    !!----    integer,                        intent(in) :: Npks  ! Number of Peaks on Pks
    !!----    real(kind=cp), dimension(:,:),  intent(in) :: Pks   ! Lis of Peaks
    !!----    type(Space_Group_Type),         intent(in) :: Grp   ! Space Group Information
    !!----    type(atom_list_type),           intent(out):: NAtm  ! New Atoms+Peaks List
    !!----
    !!----    This routine merge atoms and peaks on a new List.
    !!--<<        Atom        Peak    -->        Label      Symb
    !!----    ------------------------------------------------------
    !!----         *            *                Atom       "Pk"
    !!----         *            -                 Atom information
    !!----         -            *                "Pks"        "**"
    !!-->>
    !!---- Update: February - 2005
    !!
    Subroutine Merge_Atoms_Peaks(Cell,Atm,Npks,Pks,Grp,NAtm)
       !---- Arguments ----!
       type(Crystal_Cell_Type),       intent(in) :: Cell
       type(atom_list_type),          intent(in) :: Atm
       integer,                       intent(in) :: Npks
       real(kind=cp), dimension(:,:), intent(in) :: Pks
       type(Space_Group_Type),        intent(in) :: Grp
       type(atom_list_type),          intent(out):: NAtm

       !---- Local variables ----!
       character(len=4)                   :: car
       integer                            :: i,j,k,nc,ntot,ier
       integer, dimension(:), allocatable :: np
       real(kind=cp)                      :: dis
       real(kind=cp), dimension(3)        :: pto1,pto2,xr

       !---- Calculating the new dimension for NAtm ----!
       if (allocated(np)) deallocate(np)
       if (atm%natoms > 0) then
          allocate(np(atm%natoms))
          np=0
       end if

       nc=0
       do i=1,atm%natoms
          pto1=mod(atm%atom(i)%x+10.0_cp,1.0_cp)
          do j=1,npks
             do k=1,grp%multip
                pto2=ApplySO(grp%Symop(k),pks(1:3,j))
                pto2=mod(pto2+10.0_cp,1.0_cp)
                xr = matmul(cell%Cr_Orth_cel,pto2-pto1)
                dis=sqrt(dot_product(xr,xr))
                if (dis <= 0.25_cp) then
                   nc=nc+1
                   np(i)=j
                   exit
                end if
             end do
          end do
       end do

       ntot=0
       if (atm%natoms > 0) then   !New way to calculate ntot
         ntot=atm%natoms          !in order to avoid that nc>ntot below
         do i=1,npks
            k=0
            do j=1,atm%natoms
               if (np(j)==i) k=j
            end do
            if (k /= 0) cycle
            ntot=ntot+1
         end do
       else
         ntot=npks
       end if

       call Deallocate_atom_list(NAtm)
       call Allocate_atom_list(ntot,NAtm)

       nc=0
       if (atm%natoms > 0) then
         !---- Atoms & Peak Information ----!
          do i=1,atm%natoms
             if (np(i) == 0) cycle
             nc=nc+1
             Natm%atom(nc)=atm%atom(i)
             write(unit=Natm%atom(nc)%ChemSymb,fmt="(i2)",iostat=ier) np(i)
             if(ier /= 0) cycle
          end do

          !---- Only Atoms Information ----!
          do i=1,atm%natoms
             if (np(i) /= 0) cycle
             nc=nc+1
             Natm%atom(nc)=atm%atom(i)
          end do

          !---- Only Peaks Information ----!
          do i=1,npks
             k=0
             do j=1,atm%natoms
                if (np(j)==i) k=j
             end do
             if (k /= 0) cycle
             nc=nc+1
             write(unit=car,fmt="(i4)") nc
             natm%atom(nc)%lab="Pk_"//adjustl(car)
             natm%atom(nc)%ChemSymb="**"
             natm%atom(nc)%x=pks(1:3,i)
             natm%atom(nc)%occ=pks(4,i)
             natm%atom(nc)%active=.true.
             natm%atom(nc)%Mult=Get_Multip_Pos(pks(1:3,i),Grp)
          end do
       else
          do i=1,npks
             nc=nc+1
             write(unit=car,fmt="(i4)") nc
             natm%atom(nc)%lab="Pk_"//adjustl(car)
             natm%atom(nc)%ChemSymb="**"
             natm%atom(nc)%x=pks(1:3,i)
             natm%atom(nc)%occ=pks(4,i)
             natm%atom(nc)%active=.true.
             natm%atom(nc)%Mult=Get_Multip_Pos(pks(1:3,i),Grp)
          end do
       end if

       return
    End Subroutine Merge_Atoms_Peaks

    !!----
    !!---- Subroutine Multi(Lun,Iprin,Conven,Spg,A,Ac)
    !!----    integer,                intent(in)     :: lun     !  In -> Logical Unit for writing
    !!----    logical,                intent(in)     :: iprin   !  In -> .true. for writing in Lun
    !!----    logical,                intent(in)     :: conven  !  In -> .true. for using the whole conventional unit cell
    !!----    type(Space_Group_Type), intent(in)     :: SpG     !  In -> Space Group Information
    !!----    type(atom_list_type),  intent(in out) :: A        !  In -> Atom List (asymmetric unit)
    !!----                                                        Out -> Updated Atom List (multiplicity of sites)
    !!----    type(atoms_cell_type),  intent(out)    :: Ac      ! Out -> Atoms in unit cell
    !!----
    !!----    Subroutine to obtain multiplicities and coordinates of all atoms in
    !!----    the conventional unit cell. Calculates  "A%At(k)%mult" and constructs,
    !!----    partially, the object "Ac" of type "Atoms_Cell". The generated atoms constitute the
    !!----    content of the primitive (conven=.false.) or the conventional unit cell (conven=.true.).
    !!----
    !!---- Update: February - 2003
    !!
    Subroutine Multi(Lun,Iprin,Conven,Spg,A,Ac)
       !---- Arguments ----!
       integer,                intent(in)     :: lun
       logical,                intent(in)     :: iprin,conven
       type(Space_Group_Type), intent(in)     :: SpG
       type(atom_list_type),   intent(in out) :: A
       type(atoms_cell_type),  intent(in out) :: Ac

       !---- Local Variables ----!
       real(kind=cp),dimension(3)            :: xx,xo,v
       integer                               :: k,j,l,nt,npeq,n
       character (len=6)                     :: fmm
       character (len=5)                     :: nam, namn, nami
       real(kind=cp)                         :: qc, mom, qcn, momn
       real(kind=cp),dimension(3,Spg%multip) :: u

       npeq=SpG%numops
       if (SpG%centred == 2) npeq=npeq*2
       if (conven) npeq=SpG%multip
       n=0
       if (iprin)  then
          if (conven) then
             write(unit=lun,fmt="(/,a)") "     LIST OF ATOMS INSIDE THE CONVENTIONAL UNIT CELL "
             write(unit=lun,fmt="(a,/)") "     =============================================== "
          else
             write(unit=lun,fmt="(/,a)") "     LIST OF ATOMS CONTAINED IN A PRIMITIVE CELL "
             write(unit=lun,fmt="(a,/)") "     =========================================== "
          end if
       end if
       do k=1,A%natoms
          L=1
          n=n+1
          u(:,L)=a%atom(k)%x
          xo(:)=A%atom(k)%x(:)
          nami=A%atom(k)%lab
          if (iprin) write(unit=lun,fmt="(/,a,a)") " => Equivalent positions of atom: ",nami
          mom=A%atom(k)%moment
          qc=A%atom(k)%charge
          fmm="(a,i1)"
          write(unit=Ac%noms(n),fmt=fmm) trim(A%Atom(k)%lab)//"_",L
          nam= Ac%noms(n)
          if (iprin) write(unit=lun,fmt="(a,a,a,3f10.5,2(a,f6.3))")"       ",   &
                           nam,"  ", xo(:), "   M = ", mom ," Q = ", qc
          Ac%xyz(:,n)=xo(:)
          Ac%charge(n)=qc
          Ac%moment(n)=mom
          do_eq:DO j=2,npeq
             xx=ApplySO(SpG%SymOp(j),xo)
             xx=modulo_lat(xx)
             DO nt=1,L
                v=u(:,nt)-xx(:)
                if (Lattice_trans(v,SpG%spg_lat)) cycle do_eq
             END DO
             L=L+1
             u(:,L)=xx(:)
             n=n+1
             if ( L > 9) fmm="(a,i2)"
             write(unit=Ac%noms(n),fmt=fmm) trim(A%Atom(k)%lab)//"_",L
             Ac%xyz(:,n)=xx(:)
             Ac%charge(n)=A%Atom(k)%charge
             Ac%moment(n)=A%Atom(k)%moment
             namn=Ac%noms(n)
             momn=Ac%moment(n)
             qcn=Ac%charge(n)
             if (iprin) WRITE(unit=lun,fmt="(a,a,a,3f10.5,2(a,f6.3))")"       ",   &
                              namn, "  ", xx(:), "   M = ", momn ," Q = ", qcn
          end do do_eq
          A%Atom(k)%mult=L
       end do
       if (iprin)  write(unit=lun,fmt="(/)")
       Ac%nat=n

       return
    End Subroutine Multi

    !!----
    !!---- Subroutine Read_Bin_Atom_List(Ats,Lun,ok)
    !!----    Type (atom_list_type),dimension(:),  intent(in out) :: Ats     !  In out -> Atom List
    !!----    integer,                             intent(in)     :: lun     !  In -> Unit to write
    !!----    logical,                             intent(out)    :: ok      ! True is everything is OK!
    !!----
    !!----    Reads the atoms in the asymmetric unit in a binary file of logical unit Lun.
    !!----    The file should have been opened with the access="stream" attribute. The procedure
    !!----    reads in the given order a series of bytes corresponding to the components of the
    !!----    type Ats. The full structure is re-allocated inside the procedure before reading the
    !!----    components. The number of atoms is the first element read in the file.
    !!----
    !!---- Update: February - 2013
    !!
    Subroutine Read_Bin_Atom_List(Ats,Lun,ok)
       !---- Arguments ----!
       type (atom_list_type),            intent(in out) :: Ats
       integer,                          intent(in)     :: Lun
       logical,                          intent(out)    :: ok
       !---- Local Variables ----!
       integer                        :: i,ier
       logical                        :: Fail

       ok=.true.
       read(unit=lun,iostat=ier) Ats%natoms    !Number of atoms in the list
       if(ier /= 0) then
         ok=.false.
         return
       end if
       if( Ats%natoms == 0) return
       call Allocate_Atom_List(ats%natoms,Ats,Fail)
       if(Fail) then
        ok=.false.
        return
       end if
       do i=1,ats%natoms
         read(unit=lun,iostat=ier)     &
           Ats%atom(i)%Lab,            &
           Ats%atom(i)%ChemSymb,       &
           Ats%atom(i)%SfacSymb,       &
           Ats%atom(i)%Active,         &
           Ats%atom(i)%Z,              &
           Ats%atom(i)%Mult,           &
           Ats%atom(i)%X,              &
           Ats%atom(i)%X_Std,          &
           Ats%atom(i)%MX,             &
           Ats%atom(i)%LX,             &
           Ats%atom(i)%Occ,            &
           Ats%atom(i)%Occ_Std,        &
           Ats%atom(i)%MOcc,           &
           Ats%atom(i)%LOcc,           &
           Ats%atom(i)%Biso,           &
           Ats%atom(i)%Biso_std,       &
           Ats%atom(i)%MBiso,          &
           Ats%atom(i)%LBiso,          &
           Ats%atom(i)%Utype,          &
           Ats%atom(i)%ThType,         &
           Ats%atom(i)%U,              &
           Ats%atom(i)%U_std,          &
           Ats%atom(i)%Ueq,            &
           Ats%atom(i)%MU,             &
           Ats%atom(i)%LU,             &
           Ats%atom(i)%Charge,         &
           Ats%atom(i)%Moment,         &
           Ats%atom(i)%Ind,            &
           Ats%atom(i)%NVar,           &
           Ats%atom(i)%VarF,           &
           Ats%atom(i)%mVarF,          &
           Ats%atom(i)%LVarF,          &
           Ats%atom(i)%AtmInfo
           if(ier /= 0) then
             ok=.false.
             return
           end if
       end do
       return
    End Subroutine Read_Bin_atom_list

    !!----
    !!----    Subroutine Set_Atom_Equiv_List(SpG,cell,A,Ate,lun)
    !!----      type(Crystal_Cell_Type),    intent(in) :: Cell
    !!----      type(Space_Group_Type) ,    intent(in) :: SpG
    !!----      type(Atom_list_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
    !!---- the fractional coordinates of all the atoms in the cell.
    !!----
    !!---- Updated: January 2014
    !!
    Subroutine Set_Atom_Equiv_List(SpG,cell,A,Ate,lun)
     type(Crystal_Cell_Type),    intent(in) :: Cell
     type(Space_Group_Type) ,    intent(in) :: SpG
     type(Atom_list_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,192) :: u
     character(len=20),dimension(192) :: 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(:)
        !!!!Ate%atm(k)%x(:,L)= xo(:)
        xc =matmul(cell%Cr_Orth_cel,xo)
    !    Ate%atm(k)%c_coord(:,L)=xc
        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=Ate%atm(k)%lab(L),fmt=fmm) trim(A%Atom(k)%lab)//"_",L
        write(unit=label(L),fmt=fmm) trim(A%Atom(k)%lab)//"_",L
        !!!!nam=Ate%atm(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=ApplySO(SpG%SymOp(j),xo)
           xx=modulo_lat(xx)
           DO nt=1,L
              v=u(:,nt)-xx(:)
             ! if (Lattice_trans(v,SpG%spg_lat)) cycle do_eq
               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=Ate%atm(k)%lab(L),fmt=fmm) trim(A%Atom(k)%lab)//"_",L
           write(unit=label(L),fmt=fmm) trim(A%Atom(k)%lab)//"_",L
           !!!nam=Ate%atm(k)%lab(L)
           nam=Label(L)
           !!! Ate%atm(k)%x(:,L)=xx(:)
           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="(/)")
     return
    End Subroutine Set_Atom_Equiv_List

    !!----
    !!---- Subroutine Write_Atom_List(Ats,Level,Lun,Cell)
    !!----    Type (atom_list_type),dimension(:),  intent(in) :: Ats     !  In -> Atom List
    !!----    integer, optional,                   intent(in) :: Level   !  In -> Level of printed information
    !!----    integer, optional,                   intent(in) :: lun     !  In -> Unit to write
    !!----    Type(Crystal_Cell_Type), optional,   intent(in) :: Cell    !  In -> Transform to thermal parameters
    !!----
    !!----    Write the atoms in the asymmetric unit
    !!----
    !!---- Update: February - 2003
    !!
    Subroutine Write_Atom_List(Ats,Level,Lun,Cell)
       !---- Arguments ----!
       type (atom_list_type),            intent(in) :: Ats
       integer, optional,                intent(in) :: Level
       integer, optional,                intent(in) :: Lun
       Type(Crystal_Cell_Type), optional,intent(in) :: Cell

       !---- Local Variables ----!
       character(len=1)               :: car
       integer                        :: i, j, lv,iunit
       real(kind=cp)                  :: biso
       real(kind=cp), dimension(3)    :: rms
       real(kind=cp), dimension(6)    :: u,b,bet
       real(kind=cp), dimension(3,3)  :: beta,eigen
       logical                        :: aniso


       iunit=6
       if (present(lun)) iunit=lun
       if(ats%natoms == 0) then
         write(unit=iunit,fmt="(/,a,/)") "  => No atoms provided!"
         return
       end if

       lv=0
       if (present(level)) lv=level
       write(unit=iunit,fmt="(/,a)")    "        Atoms information:"
       write(unit=iunit,fmt="(a,/)")    "        ------------------"

       select case (lv)
          case (0)
             write (unit=iunit,fmt="(T5,a)") &
                   "Atom      Chem        x/a       y/b       z/c       Biso     Occ       Mult"
             write (unit=iunit,fmt="(T5,a)") &
                   "==========================================================================="
          case (1)
             write (unit=iunit,fmt="(T5,a)") &
                   "Atom      Chem        x/a       y/b       z/c       Biso      Occ     Moment    Charge   Active   Mult"
             write (unit=iunit,fmt="(T5,a)") &
                   "======================================================================================================"
       end select

       aniso=.false.
       do i=1,ats%natoms
          car=" "
          if (.not. ats%atom(i)%active) car="-"
          if(ats%atom(i)%thtype == "aniso") aniso=.true.
          select case (lv)
             case (0)
                write(unit=iunit,fmt="(T5,a,T16,a,T21,5f10.4,i9,a)") &
                     ats%atom(i)%lab, ats%atom(i)%chemsymb, ats%atom(i)%x, &
                     ats%atom(i)%biso,ats%atom(i)%occ,ats%atom(i)%mult,trim("  "//ats%atom(i)%AtmInfo)
             case (1)
                write(unit=iunit,fmt="(T5,a,T16,a,T21,7f10.4,T96,a,t97,i9,a)") &
                     ats%atom(i)%lab, ats%atom(i)%chemsymb, ats%atom(i)%x, &
                     ats%atom(i)%biso,ats%atom(i)%occ,ats%atom(i)%moment,ats%atom(i)%charge,&
                     car,ats%atom(i)%mult,trim("  "//ats%atom(i)%AtmInfo)
          end select
       end do

       if (aniso) then
          write(unit=iunit,fmt="(/,/,T5,a)") &
               "Atom       Type      T_11        T_22        T_33        T_12        T_13        T_23"
          write (unit=iunit,fmt="(T5,a)") &
               "====================================================================================="
          do i=1,ats%natoms
             if (ats%atom(i)%thtype == "aniso") then

                if (ats%atom(i)%utype == "beta") then
                   bet=ats%atom(i)%u(1:6)
                   write(unit=iunit,fmt="(T5,a,t16,a,6f12.6)") ats%atom(i)%lab,ats%atom(i)%utype, bet
                   if (present(Cell)) then
                      u=convert_betas_u(bet,cell)
                      write(unit=iunit,fmt="(T16,a,6f12.6)") "U_ij", u
                      b=convert_betas_b(bet,cell)
                      write(unit=iunit,fmt="(T16,a,6f12.6)") "B_ij", b
                   end if
                else if(ats%atom(i)%thtype == "u_ij") then
                   u=ats%atom(i)%u(1:6)
                   write(unit=iunit,fmt="(T5,a,t16,a,6f12.6)") ats%atom(i)%lab,ats%atom(i)%utype, u
                   b=convert_u_b(u)
                   write(unit=iunit,fmt="(T16,a,6f12.6,a)") "B_ij", b
                   if (present(Cell)) then
                      bet=convert_u_betas(u,cell)
                      write(unit=iunit,fmt="(T16,a,6f12.6,a)") "Beta", bet
                   end if
                else if(ats%atom(i)%thtype == "b_ij") then
                   b=ats%atom(i)%u(1:6)
                   write(unit=iunit,fmt="(T5,a,t16,a,6f12.6)") ats%atom(i)%lab,ats%atom(i)%utype, b
                   u=convert_b_u(b)
                   write(unit=iunit,fmt="(T16,a,6f12.6,a)") "U_ij", u
                   if (present(Cell)) then
                      bet=convert_b_betas(b,cell)
                      write(unit=iunit,fmt="(T16,a,6f12.6,a)") "Beta", bet
                   end if
                end if

                if (present(cell)) then
                  beta=reshape((/bet(1),bet(4),bet(5), bet(4),bet(2),bet(6), bet(5),bet(6),bet(3) /),(/3,3/))
                   beta=beta*0.5/pi/pi
                   beta=matmul(matmul(Cell%Cr_Orth_cel,beta),transpose(Cell%Cr_Orth_cel))
                   call matrix_diageigen(beta,rms,eigen)
                   write(unit=lun,fmt="(a)")  &
                        "               U-Eigen Value(A**2) ----       Eigen vector(Orth. syst.)     R.M.S (Angstroms)"
                   do j =1,3
                      if (rms(j) < 0.0)  then
                         write(unit=iunit,fmt="((t16,f10.5,a,3(tr1,f10.5),a))")     rms(j), &
                              "          --- ", eigen(:,j),"   -> Matrix U non-positive definite!"
                      else
                         write(unit=iunit,fmt="((t16,f10.5,a,3(tr1,f10.5),a,f14.5))") rms(j),&
                              "          ---(", eigen(:,j),")", sqrt(rms(j))
                      end if
                   end do
                   biso=sum(rms)/3.0
                   write(unit=iunit,fmt="(a,f8.4)") "               Isotropic temperature factor Uequiv(A**2): ",biso
                   biso=biso*8.0*pi*pi
                   write(unit=iunit,fmt="(a,f8.4,/)") "               Isotropic temperature factor Bequiv(A**2): ",biso
                end if

             end if
          end do
       end if

       return
    End Subroutine Write_atom_list
    !!----
    !!---- Subroutine Write_Bin_Atom_List(Ats,Lun)
    !!----    Type (atom_list_type),dimension(:),  intent(in) :: Ats     !  In -> Atom List
    !!----    integer,                             intent(in) :: lun     !  In -> Unit to write
    !!----
    !!----    Write the atoms in the asymmetric unit in a binary file of logical unit Lun.
    !!----    The file should have been opened with the access="stream" attribute. The procedure
    !!----    writes in the given order a series of bytes corresponding to the components of the
    !!----    type Ats. For reading back an atom list from a binary file the subroutine Read_Bin_Atom_List
    !!----    has to be used.
    !!----
    !!---- Update: February - 2013
    !!
    Subroutine Write_Bin_Atom_List(Ats,Lun)
       !---- Arguments ----!
       type (atom_list_type),            intent(in) :: Ats
       integer,                          intent(in) :: Lun
       !---- Local Variables ----!
       integer                        :: i

       write(unit=lun) ats%natoms    !Number of atoms in the list
       do i=1,ats%natoms
         write(unit=lun)               &
           ats%atom(i)%Lab,            &
           ats%atom(i)%ChemSymb,       &
           ats%atom(i)%SfacSymb,       &
           ats%atom(i)%Active,         &
           ats%atom(i)%Z,              &
           ats%atom(i)%Mult,           &
           ats%atom(i)%X,              &
           ats%atom(i)%X_Std,          &
           ats%atom(i)%MX,             &
           ats%atom(i)%LX,             &
           ats%atom(i)%Occ,            &
           ats%atom(i)%Occ_Std,        &
           ats%atom(i)%MOcc,           &
           ats%atom(i)%LOcc,           &
           ats%atom(i)%Biso,           &
           ats%atom(i)%Biso_std,       &
           ats%atom(i)%MBiso,          &
           ats%atom(i)%LBiso,          &
           ats%atom(i)%Utype,          &
           ats%atom(i)%ThType,         &
           ats%atom(i)%U,              &
           ats%atom(i)%U_std,          &
           ats%atom(i)%Ueq,            &
           ats%atom(i)%MU,             &
           ats%atom(i)%LU,             &
           ats%atom(i)%Charge,         &
           ats%atom(i)%Moment,         &
           ats%atom(i)%Ind,            &
           ats%atom(i)%NVar,           &
           ats%atom(i)%VarF,           &
           ats%atom(i)%mVarF,          &
           ats%atom(i)%LVarF,          &
           ats%atom(i)%AtmInfo
       end do
       return
    End Subroutine Write_Bin_atom_list

 End Module CFML_Atom_TypeDef
!!-------------------------------------------------------
!!---- Crystallographic Fortran Modules Library (CrysFML)
!!-------------------------------------------------------
!!---- The CrysFML project is distributed under LGPL. In agreement with the
!!---- Intergovernmental Convention of the ILL, this software cannot be used
!!---- in military applications.
!!----
!!---- Copyright (C) 1999-2012  Institut Laue-Langevin (ILL), Grenoble, FRANCE
!!----                          Universidad de La Laguna (ULL), Tenerife, SPAIN
!!----                          Laboratoire Leon Brillouin(LLB), Saclay, FRANCE
!!----
!!---- Authors: Juan Rodriguez-Carvajal (ILL)
!!----          Javier Gonzalez-Platas  (ULL)
!!----
!!---- Contributors: Laurent Chapon     (ILL)
!!----               Marc Janoschek     (Los Alamos National Laboratory, USA)
!!----               Oksana Zaharko     (Paul Scherrer Institute, Switzerland)
!!----               Tierry Roisnel     (CDIFX,Rennes France)
!!----               Eric Pellegrini    (ILL)
!!----
!!---- This library is free software; you can redistribute it and/or
!!---- modify it under the terms of the GNU Lesser General Public
!!---- License as published by the Free Software Foundation; either
!!---- version 3.0 of the License, or (at your option) any later version.
!!----
!!---- This library is distributed in the hope that it will be useful,
!!---- but WITHOUT ANY WARRANTY; without even the implied warranty of
!!---- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
!!---- Lesser General Public License for more details.
!!----
!!---- You should have received a copy of the GNU Lesser General Public
!!---- License along with this library; if not, see <http://www.gnu.org/licenses/>.
!!----
!!----
!!---- MODULE: CFML_Geometry_Calc
!!----   INFO: Routines for Geometry Calculations
!!----
!!---- HISTORY
!!----    Update: 06/03/2011
!!----
!!----
!!---- DEPENDENCIES
!!--++    CFML_Math_3D:  Cross_Product
!!--++    CFML_GlobalDeps: Eps, Pi, Cp, Sp, To_Rad, To_Deg
!!--++    CFML_Math_General: Acosd, Cosd, Sind
!!--++    CFML_Crystal_Metrics: Crystal_Cell_Type
!!----
!!---- VARIABLES
!!----    COORDINATION_TYPE
!!----    COORD_INFO
!!--++    EPSI
!!----    ERR_GEOM
!!----    ERR_GEOM_MESS
!!----    POINT_LIST_TYPE
!!----
!!---- PROCEDURES
!!----    Functions:
!!----       ANGLE_DIHEDRAL
!!--++       ANGLE_DIHEDRAL_IJKN            [Overloaded]
!!--++       ANGLE_DIHEDRAL_UVW             [Overloaded]
!!----       ANGLE_MOD
!!--++       ANGLE_MODN                     [Overloaded]
!!--++       ANGLE_MODV                     [Overloaded]
!!----       ANGLE_UV
!!--++       ANGLE_UVI                      [Overloaded]
!!--++       ANGLE_UVR                      [Overloaded]
!!----       COORD_MOD
!!--++       COORD_MODN                     [Overloaded]
!!--++       COORD_MODV                     [Overloaded]
!!----       DISTANCE
!!--++       DISTANCE_FR                    [Overloaded]
!!--++       DISTANCE_FR_DP                 [Overloaded]
!!--++       DISTANCE_SC                    [Overloaded]
!!----       MATRIX_PHITHECHI
!!----       MATRIX_RX
!!----       MATRIX_RY
!!----       MATRIX_RZ
!!----
!!----    Subroutines:
!!----       ALLOCATE_COORDINATION_TYPE
!!----       ALLOCATE_POINT_LIST
!!----       CALC_DIST_ANGLE
!!----       CALC_DIST_ANGLE_SIGMA
!!----       DEALLOCATE_COORDINATION_TYPE
!!----       DEALLOCATE_POINT_LIST
!!----       DISTANCE_AND_SIGMA
!!----       GET_ANGLEN_AXIS_FROM_ROTMAT
!!----       GET_EULER_FROM_FRACT
!!----       GET_MATRIX_MOVING_V_TO_U
!!----       GET_OMEGACHIPHI
!!----       GET_PHITHECHI
!!----       GET_TRANSF_LIST
!!----       INIT_ERR_GEOM
!!----       P1_DIST
!!----       PRINT_DISTANCES
!!----       SET_NEW_ASYMUNIT
!!----       SET_ORBITS_INLIST
!!----       SET_ROTATION_MATRIX
!!----       SET_TDIST_COORDINATION
!!----       SET_TDIST_PARTIAL_COORDINATION
!!----
!!
 Module CFML_Geometry_Calc

    !---- Use Modules ----!
    use CFML_GlobalDeps,                 only: Sp, Cp, dp, eps, pi, to_rad, to_deg
    use CFML_Math_General,               only: acosd, cosd, sind, Modulo_Lat
    use CFML_Math_3D,                    only: Cross_Product, Matrix_Inverse, determ_A
    use CFML_String_Utilities,           only: Frac_Trans_1Dig, L_Case,U_Case,pack_string,setnum_std, get_logunit
    use CFML_Crystal_Metrics,            only: Crystal_Cell_Type, Get_Deriv_Orth_Cell,Rot_Matrix
    use CFML_Atom_TypeDef,               only: atom_list_type,Atoms_Cell_Type,Equiv_Atm, Wrt_Lab, Atom_Equiv_List_Type, &
                                               allocate_atom_list
    use CFML_Crystallographic_Symmetry,  only: Space_Group_Type, ApplySo, Lattice_Trans, Get_Multip_Pos, &
                                               searchop, Read_SymTrans_Code, Write_SymTrans_Code, Get_Orbit

    implicit none

    private

    !---- List of public functions ----!

    !---- List of public overloaded procedures: functions ----!
    public :: Angle_Dihedral, Angle_Mod, Angle_Uv, Coord_Mod, Distance, Matrix_PhiTheChi, Matrix_Rx, &
              Matrix_Ry, Matrix_Rz

    !---- List of public subroutines ----!
    public :: Allocate_Coordination_Type, Allocate_Point_List, Calc_Dist_Angle, Calc_Dist_Angle_Sigma, &
              Deallocate_Coordination_Type, Deallocate_Point_List, Distance_and_Sigma, Get_Euler_From_Fract, &
              Get_PhiTheChi, init_err_geom, P1_Dist, Print_Distances, Set_Orbits_InList, Set_TDist_Coordination, &
              Get_Transf_List, Set_TDist_Partial_Coordination, Get_Anglen_Axis_From_RotMat, Get_Matrix_moving_v_to_u, &
              Get_OmegaChiPhi, Set_Rotation_Matrix, Set_New_AsymUnit

    !---- List of public overloaded procedures: subroutines ----!

    !---- List of private functions ----!
    private :: Angle_Dihedral_Uvw,  Angle_Dihedral_Ijkn, Angle_Uvi, Angle_Uvr, Angle_Modn, Angle_Modv, &
               Coord_Modn, Coord_Modv, Distance_fr, Distance_fr_dp, Distance_sc

    !---- Definitions ----!

    !!----
    !!---- TYPE :: COORDINATION_TYPE
    !!--..
    !!---- Type, public :: Coordination_Type
    !!----    integer                                      :: Natoms    ! number of atoms
    !!----    integer                                      :: Max_Coor  ! Maximum number of connected atoms to a given one
    !!----    integer,       dimension(:),     allocatable :: Coord_Num ! Counter of distances connected to the current atom
    !!----    integer,       dimension(:,:),   allocatable :: N_Cooatm  ! Pointer to the ordinal number in the list of the attached
    !!----                                                              ! atom to the atom given by the first index
    !!----    integer,       dimension(:,:),   allocatable :: N_Sym     !
    !!----    real(kind=cp), dimension(:,:),   allocatable :: Dist      ! List of distances related to an atom
    !!----    real(kind=cp), dimension(:,:),   allocatable :: S_Dist    ! List of Sigma(distances)
    !!----    real(kind=cp), dimension(:,:,:), allocatable :: Tr_coo    !
    !!---- End type Coordination_Type
    !!----
    !!---- Update: February - 2005
    !!
    Type, public :: Coordination_Type
       integer                                      :: Natoms    ! number of atoms
       integer                                      :: Max_Coor  ! Maximum number of connected atoms to a given one
       integer,       dimension(:),     allocatable :: Coord_Num ! Counter of distances connected to the current atom
       integer,       dimension(:,:),   allocatable :: N_Cooatm  ! Pointer to the ordinal number in the list of the attached
                                                                 ! atom to the atom given by the first index
       integer,       dimension(:,:),   allocatable :: N_Sym     ! Number of symmetry operator to apply to N_Cooatm
       real(kind=cp), dimension(:,:),   allocatable :: Dist      ! List of distances related to an atom
       real(kind=cp), dimension(:,:),   allocatable :: S_Dist    ! List of Sigma(distances)
       real(kind=cp), dimension(:,:,:), allocatable :: Tr_coo
    End type Coordination_Type

    !!----
    !!---- COORD_INFO
    !!----    type(Coordination_Type), public :: coord_info
    !!----
    !!----    Coordination Information
    !!----
    !!---- Update: March - 2005
    !!
    type(Coordination_Type), public :: coord_info

    !!--++
    !!--++ EPSI
    !!--++    real(kind=cp), parameter :: epsi=0.001
    !!--++
    !!--++    (PRIVATE)
    !!--++    Epsilon for roughly comparing distances
    !!--++
    !!--++ Update: February - 2005
    !!
    real(kind=cp), parameter, private :: epsi=0.001

    !!----
    !!---- ERR_GEOM
    !!----    logical, public  :: err_geom
    !!----
    !!----    Logical Variable indicating an error in CFML_Geometry_Calc module
    !!----
    !!---- Update: February - 2005
    !!
    logical, public  :: err_geom

    !!----
    !!---- ERR_Geom_Mess
    !!----    character(len=150), public :: ERR_Geom_Mess
    !!----
    !!----    String containing information about the last error
    !!----
    !!---- Update: February - 2005
    !!
    character(len=150), public :: ERR_Geom_Mess


    !!----
    !!---- TYPE :: POINT_LIST_TYPE
    !!--..
    !!---- Type, public :: Point_List_Type
    !!----    integer                                       :: np   !number of points in list
    !!----    character(len=12), dimension(:),  allocatable :: nam  !name/label associated to each point
    !!----    integer,           dimension(:),  allocatable :: p    !integer pointer for various purposes
    !!----    real(kind=cp)      dimension(:,:),allocatable :: x    !fractional coordinates of points
    !!---- End type Point_List_Type
    !!----
    !!---- Update: February - 2005
    !!
    Type, public :: point_list_type
       integer                                       :: np   !number of points in list
       character(len=12), dimension(:),  allocatable :: nam  !name/label associated to each point
       integer,           dimension(:),  allocatable :: p    !integer pointer for various purposes
       real(kind=cp),     dimension(:,:),allocatable :: x    !fractional coordinates of points
    End type point_list_type


    !---- Interfaces - Overlapp ----!
    Interface  Angle_Dihedral
       Module Procedure Angle_Dihedral_Ijkn
       Module Procedure Angle_Dihedral_Uvw
    End Interface

    Interface  Angle_Uv
       Module Procedure Angle_UvI
       Module Procedure Angle_UvR
    End Interface

    Interface  Angle_Mod
       Module Procedure Angle_ModN
       Module Procedure Angle_ModV
    End Interface

    Interface  Coord_Mod
       Module Procedure Coord_ModN
       Module Procedure Coord_ModV
    End Interface

    Interface  Distance
       Module Procedure Distance_FR_DP
       Module Procedure Distance_FR
       Module Procedure Distance_SC
    End Interface

 Contains

    !---- Functions ----!

    !!----
    !!---- Function Angle_Dihedral(U,V,W) Or (Ri,Rj,Rk,Rn)   Result(Angle)
    !!----    real(kind=cp), dimension(3), intent( in) :: u       !  In -> Vector 1
    !!----    real(kind=cp), dimension(3), intent( in) :: v       !  In -> Vector 2
    !!----    real(kind=cp), dimension(3), intent( in) :: w       !  In -> Vector 3
    !!----    or
    !!----    real(kind=cp), dimension(3), intent( in) :: ri      !  In -> Vector position ri
    !!----    real(kind=cp), dimension(3), intent( in) :: rj      !  In -> Vector position rj
    !!----    real(kind=cp), dimension(3), intent( in) :: rk      !  In -> Vector position rk
    !!----    real(kind=cp), dimension(3), intent( in) :: rl      !  In -> Vector position rn
    !!----    real(kind=cp)                            :: angle   ! Out -> Dihedral angle
    !!----
    !!----    Calculates the dihedral angle between planes "u-v" and "v-w", where vectors U,V,W
    !!----    are given in cartesian components.
    !!----    Calculates the dihedral angle corresponding to the four points (ri,rj,rk,rn)
    !!----    given in cartesian components. The definition used for the dihedral angle
    !!----    is the following:
    !!--<<
    !!----    Phi(i,j,k,n) = acos { (rij x rjk) (rjk x rkn) / |rij x rjk| / |rjk x rkn| }
    !!----
    !!----    with this definition the sign of Phi is positive if the vector product
    !!----    (rij x rjk) x (rjk x rkn) is in the same direction as rjk, and negative if
    !!----    the direction is opposite.
    !!-->>
    !!----
    !!---- Update: February - 2005
    !!

    !!--++
    !!--++ Function Angle_Dihedral_Ijkn(Ri,Rj,Rk,Rn) Result(Angle)
    !!--++    real(kind=cp), dimension(3), intent( in) :: ri       !  In -> Vector position ri
    !!--++    real(kind=cp), dimension(3), intent( in) :: rj       !  In -> Vector position rj
    !!--++    real(kind=cp), dimension(3), intent( in) :: rk       !  In -> Vector position rk
    !!--++    real(kind=cp), dimension(3), intent( in) :: rl       !  In -> Vector position rn
    !!--++    real(kind=cp)                            :: angle    ! Out -> Dihedral angle
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Calculates the dihedral angle corresponding to the four points (ri,rj,rk,rn)
    !!--++    given in cartesian components. The definition used for the dihedral angle
    !!--++    is the following:
    !!--++
    !!--++    Phi(i,j,k,n) = acos { (rij x rjk) (rjk x rkn) / |rij x rjk| / |rjk x rkn| }
    !!--++
    !!--++    with this definition the sign of Phi is positive if the vector product
    !!--++    (rij x rjk) x (rjk x rkn) is in the same direction as rjk, and negative if
    !!--++    the direction is opposite.
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Angle_Dihedral_Ijkn(ri,rj,rk,rn) result(angle)
       !---- Arguments ----!
       real(kind=cp), dimension(3), intent( in) :: ri,rj,rk,rn
       real(kind=cp)                            :: angle

       angle=Angle_Dihedral_Uvw(rj-ri ,rk-rj, rn-rk )

       return
    End Function Angle_Dihedral_Ijkn

    !!--++
    !!--++ Function Angle_Dihedral_Uvw(U,V,W) Result(Angle)
    !!--++    real(kind=cp), dimension(3), intent( in) :: u       !  In -> Vector 1
    !!--++    real(kind=cp), dimension(3), intent( in) :: v       !  In -> Vector 2
    !!--++    real(kind=cp), dimension(3), intent( in) :: w       !  In -> Vector 3
    !!--++    real(kind=cp)                            :: angle   ! Out -> Dihedral angle
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Calculates the dihedral angle between planes u-v and v-w
    !!--++    Vectors u,v,w are given in cartesian components.
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Angle_Dihedral_Uvw(u,v,w) result(angle)
       !---- Argument ----!
       real(kind=cp), dimension(3), intent( in) :: u,v,w
       real(kind=cp)                            :: angle

       !---- Local variables ----!
       real(kind=cp)               :: uvmod, vwmod, sig
       real(kind=cp), dimension(3) :: uv,vw

       angle=0.0

       uv=cross_product(u,v)
       vw=cross_product(v,w)
       sig = -sign(1.0_cp, dot_product(cross_product(uv,vw),v))
       uvmod=sqrt(dot_product(uv,uv))
       vwmod=sqrt(dot_product(vw,vw))
       if (uvmod < eps .or. vwmod < eps) return
       angle=acosd(dot_product(uv,vw)/uvmod/vwmod)*sig

       return
    End Function Angle_Dihedral_Uvw

    !!----
    !!---- Function Angle_Mod(X) Result (Y)
    !!----     real(kind=cp),               intent(in) :: x
    !!----                  or
    !!----     real(kind=cp), dimension(:), intent(in) :: x
    !!----
    !!----     Calculates the angle [-pi,pi)
    !!----
    !!---- Update: February - 2005
    !!

    !!--++
    !!--++ Function Angle_Modn(Angle) Result(AngMod)
    !!--++    real(kind=cp), intent(in) :: Angle    !  In/Out -> Angle
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Transforms angle in radians between -pi and +pi
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Angle_ModN(Angle) Result(AngMod)
       !---- Arguments ----!
       real(kind=cp), intent(in) :: Angle
       real(kind=cp)             :: AngMod

       AngMod=mod(angle+6.0*pi,2.0*pi)
       if (angmod > pi) angmod=angmod-2.0*pi

       return
    End Function Angle_ModN

    !!--++
    !!--++ Function Angle_Modv(V_Angle) Result(VAngMod)
    !!--++    real(kind=cp), dimension(:), intent(in) :: V_Angle
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Transforms angles in radians between -pi and +pi
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Angle_ModV(V_Angle) Result(VAngMod)
       !---- Arguments ----!
       real(kind=cp), dimension(:),intent(in) :: V_Angle
       real(kind=cp), dimension(size(V_Angle)):: VAngMod

       !---- Local Variables ----!
       integer :: i

       VAngMod=mod(V_Angle+6.0*pi,2.0*pi)
       do i=1,size(V_Angle)
          if (VAngMod(i) > pi) VAngMod(i)=VAngMod(i)-2.0*pi
       end do

       return
    End Function Angle_ModV

    !!----
    !!---- Function Angle_Uv(U,V,G) Result(Angle)
    !!----    integer/real(kind=cp), dimension(:), intent( in)     :: u      !  In -> Vector 1
    !!----    integer/real(kind=cp), dimension(:), intent( in)     :: v      !  In -> Vector 2
    !!----    real(kind=cp), dimension(:,:), intent( in), optional :: g      !  In -> Metric tensor
    !!----    real(kind=cp)                                        :: angle  ! Out -> Angle
    !!----
    !!----    Calculates the angle between vectors u and v given in cartesian
    !!----    components. If g is not given cartesian components are assumed.
    !!----
    !!---- Update: February - 2005
    !!

    !!--++
    !!--++ Function Angle_UvI(Ui,Vi,G) Result(Angle)
    !!--++    integer, dimension(:),                   intent(in) :: ui      !  In -> Vector 1
    !!--++    integer, dimension(:),                   intent(in) :: vi      !  In -> Vector 2
    !!--++    real(kind=cp), dimension(:,:), optional, intent(in) :: g       !  In -> Metric tensor
    !!--++    real(kind=cp)                                       :: angle   ! Out -> Angle
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Calculates the angle between vectors u and v given in cartesians
    !!--++    or fractional components. If g is not given cartesian components
    !!--++    are assumed.
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Angle_UvI(Ui,Vi,G) Result(Angle)
       !---- Argument ----!
       integer, dimension(:),   intent( in)                 :: ui
       integer, dimension(:),   intent( in)                 :: vi
       real(kind=cp), dimension(:,:), intent( in), optional :: g   !metric tensor
       real(kind=cp)                                        :: angle

       !---- Local variables ----!
       real(kind=cp)                      :: umod, vmod
       real(kind=cp), dimension(size(ui)) :: u
       real(kind=cp), dimension(size(vi)) :: v

       angle=0.0

       u=real(ui)
       v=real(vi)

       if (present(g)) then
          umod = sqrt(dot_product(u,matmul(g,u)))
          vmod = sqrt(dot_product(v,matmul(g,v)))
          if (umod < eps .or. vmod < eps) return
          angle=acosd(dot_product(u,matmul(g,v))/umod/vmod)
       else
          umod=sqrt(dot_product(u,u))
          vmod=sqrt(dot_product(v,v))
          if (umod < eps .or. vmod < eps) return
          angle=acosd(dot_product(u,v)/umod/vmod)
       end if

       return
    End Function Angle_uvi

    !!--++
    !!--++ Function Angle_Uvr(U,V,G) Result(Angle)
    !!--++    real(kind=cp), dimension(:), intent( in)             :: u      !  In -> Vector 1
    !!--++    real(kind=cp), dimension(:), intent( in)             :: v      !  In -> Vector 2
    !!--++    real(kind=cp), dimension(:,:), intent( in), optional :: g      !  In -> Metric tensor
    !!--++    real(kind=cp)                                        :: angle  ! Out -> Angle
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Calculates the angle between vectors u and v given in cartesian
    !!--++    or fractional components. If g is not given cartesian components
    !!--++    are assumed.
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Angle_UvR(u,v,g) result(angle)
       !---- Argument ----!
       real(kind=cp), dimension(:),   intent( in)           :: u
       real(kind=cp), dimension(:),   intent( in)           :: v
       real(kind=cp), dimension(:,:), intent( in), optional :: g   !metric tensor
       real(kind=cp)                                        :: angle

       !---- Local variables ----!
       real(kind=cp)   :: umod, vmod

       angle=0.0

       if (present(g)) then
          umod = sqrt(dot_product(u,matmul(g,u)))
          vmod = sqrt(dot_product(v,matmul(g,v)))
          if (umod < eps .or. vmod < eps) return
          angle=acosd(dot_product(u,matmul(g,v))/umod/vmod)
       else
          umod=sqrt(dot_product(u,u))
          vmod=sqrt(dot_product(v,v))
          if (umod < eps .or. vmod < eps) return
          angle=acosd(dot_product(u,v)/umod/vmod)
       end if

       return
    End Function Angle_uvr

    !!----
    !!---- Function Coord_Mod(X) Result (Y)
    !!----    Real(Kind=Cp),               intent(in) :: x
    !!----                  or
    !!----    real(kind=cp), dimension(:), intent(in) :: x
    !!----
    !!----    Calculates the coordinates between [0,1)
    !!----
    !!---- Update: February - 2005
    !!

    !!--++
    !!--++ Function Coord_Modn(X) Result (XMod)
    !!--++    real(kind=cp), intent(in) :: x
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Transforms reduced the value between 0 and 1
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Coord_ModN(x) result(Xmod)
       !---- Arguments ----!
       real(kind=cp), intent(in) :: x
       real(kind=cp)             :: xmod

       xmod=mod(x+10.0_cp,1.0_cp)

       return
    End Function Coord_ModN

    !!--++
    !!--++ Function Coord_Modv(X) Result(XMod)
    !!--++    real(kind=cp), dimension(:), intent(in) :: x
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Transforms reduced coordinate between 0 and 1
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Coord_ModV(x) Result(Xmod)
       !---- Arguments ----!
       real(kind=cp), dimension(:), intent(in) :: x
       real(kind=cp), dimension(size(x))       :: xmod

       xmod=mod(x+10.0_cp,1.0_cp)

       return
    End Function Coord_ModV

    !!----
    !!---- Function Distance(X0,X1,Cell or Code) Result(D)
    !!----    real(kind=cp), dimension(3),        intent(in) :: x0     !  In -> Point 1
    !!----    real(kind=cp), dimension(3),        intent(in) :: x1     !  In -> Point 2
    !!----    Type (Crystal_Cell_Type),           intent(in) :: Cell   !  In -> Cell parameters
    !!----    Or
    !!----    real(kind=dp), dimension(3),        intent(in) :: x0     !  In -> Point 1
    !!----    real(kind=dp), dimension(3),        intent(in) :: x1     !  In -> Point 2
    !!----    Type (Crystal_Cell_Type),           intent(in) :: Cell   !  In -> Cell parameters
    !!----    Or
    !!----    character(len=*), optional,         intent(in) :: Code
    !!----    real(kind=cp)                                  :: d      ! Out -> Distance
    !!----
    !!----    Calculate distance between two points.
    !!----       Fractional Coordinates: Use Cell
    !!----       Cartesian Coordiantes: Code="C" or Code=" "
    !!----       Spherical Coordinates: Code="S"
    !!----
    !!---- Update: February - 2005
    !!

    !!--++
    !!--++ Function Distance_Fr(X0,X1,Celda) Result(D)
    !!--++    real(kind=cp), dimension(3),  intent(in) :: x0     !  In -> Point 1
    !!--++    real(kind=cp), dimension(3),  intent(in) :: x1     !  In -> Point 2
    !!--++    Type (Crystal_Cell_Type),     intent(in) :: Celda  !  In -> Cell parameters
    !!--++    real(kind=cp)                                  :: d      ! Put -> Distance
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Calculate distance between two points in Fractional
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Distance_Fr(X0,X1,Celda) Result(Dis)
       !---- Arguments ----!
       real(kind=cp), dimension(3), intent(in) :: x0,x1
       type (Crystal_Cell_Type),    intent(in) :: Celda
       real(kind=cp)                           :: dis

       !---- Local Variables ----!
       real(kind=cp), dimension(3) :: xr

       xr = matmul(celda%Cr_Orth_cel,x1-x0)
       dis=sqrt(dot_product(xr,xr))

       return
    End Function Distance_Fr

    !!--++
    !!--++ Function Distance_Fr_dp(X0,X1,Celda) Result(D)
    !!--++    real(kind=dp), dimension(3),  intent(in) :: x0     !  In -> Point 1
    !!--++    real(kind=dp), dimension(3),  intent(in) :: x1     !  In -> Point 2
    !!--++    Type (Crystal_Cell_Type),     intent(in) :: Celda  !  In -> Cell parameters
    !!--++    real(kind=dp)                            :: d      ! Put -> Distance
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Calculate distance between two points in Fractional
    !!--++
    !!--++ Update: February - 2015
    !!
    Function Distance_Fr_dp(X0,X1,Celda) Result(Dis)
       !---- Arguments ----!
       real(kind=dp), dimension(3), intent(in) :: x0,x1
       type (Crystal_Cell_Type),    intent(in) :: Celda
       real(kind=dp)                           :: dis

       !---- Local Variables ----!
       real(kind=dp), dimension(3) :: xr

       xr = matmul(celda%Cr_Orth_cel,x1-x0)
       dis=sqrt(dot_product(xr,xr))

       return
    End Function Distance_Fr_dp

    !!--++
    !!--++ Function Distance_SC(X0,X1,Code) Result(D)
    !!--++    real(kind=cp), dimension(3),        intent(in) :: x0     !  In -> Point 1
    !!--++    real(kind=cp), dimension(3),        intent(in) :: x1     !  In -> Point 2
    !!--++    character(len=*), optional,         intent(in) :: Code
    !!--++    real(kind=cp)                                  :: d      ! Put -> Distance
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Calculate distance between two points in Cartesian or Spherical
    !!--++    If Code =="C" or Blank or not present then the coordinates are Cartesian.
    !!--++    If Code =="S" then the coordinates are spherical (R, Theta, Phi).
    !!--++
    !!--++ Update: February - 2005
    !!
    Function Distance_SC(X0,X1,Code) Result(Dis)
       !---- Arguments ----!
       real(kind=cp), dimension(3), intent(in) :: x0,x1
       character(len=*), optional,  intent(in) :: Code
       real(kind=cp)                           :: dis

       !---- Local Variables ----!
       real(kind=cp), dimension(3) :: xr,xi,xj

       xr=0.0
       if (present(code)) then
          select case (code(1:1))
             case("S","s") ! Spherical
                xi(1)=x0(1)*cosd(x0(3))*sind(x0(2))  ! R * cos(Phi) * sin(Theta)
                xi(2)=x0(1)*sind(x0(3))*sind(x0(2))  ! R * sin(Phi) * sin(Theta)
                xi(3)=x0(1)*cosd(x0(2))              ! R * cos(Theta)

                xj(1)=x1(1)*cosd(x1(3))*sind(x1(2))  ! R * cos(Phi) * sin(Theta)
                xj(2)=x1(1)*sind(x1(3))*sind(x1(2))  ! R * sin(Phi) * sin(Theta)
                xj(3)=x1(1)*cosd(x1(2))              ! R * cos(Theta)

                xr=xi-xj
             case("C","c") ! Cartesian
                xr=x1-x0
          end select
       else
          !---- Cartesian ----!
          xr=x1-x0
       end if
       dis=sqrt(dot_product(xr,xr))

       return
    End Function Distance_SC

    !!----
    !!---- Function Matrix_Phithechi(Phi,Theta,Chi,Code) Result(M)
    !!----    real(kind=cp),                intent(in) :: Phi
    !!----    real(kind=cp),                intent(in) :: Theta
    !!----    real(kind=cp),                intent(in) :: Chi
    !!----    character(len=*), optional,   intent(in) :: Code
    !!----    real(kind=cp), dimension(3,3)            :: M    ! Put -> Active Rotation Matrix
    !!----
    !!----    Calculate the active rotation matrix corresponding to the composition
    !!----    of a positive rotation around z of angle Chi, followed by a positive rotation
    !!----    of angle Theta around the y-axis and a subsequent positive rotation of angle Phi
    !!----    around z. "Positive" means counter-clockwise.
    !!----    The matrix is M = Rz(Phi) . Ry(Theta) . Rz(Chi)
    !!----    The colums represent the components of the unitary vectors {u,v,w} that
    !!----    may be considered as an alternative orthonormal frame to the canonical {i,j,k}.
    !!----    Applying the matrix M to a point in {i,j,k} gives another point in {i,j,k} obtained
    !!----    by the successive application of the three rotations given above. The transpose
    !!----    (inverse) of the M-matrix, when applied to a point in {i,j,k}, gives the coordinates
    !!----    of the same point referred to the frame {u,v,w}. This transpose matrix corresponds
    !!----    to a passive (change or Cartesian frame) rotation leaving the points in the same
    !!----    position with respect to the  {i,j,k} frame.
    !!----    The matrix M when applied to a column vector containing the coordinates of a point
    !!----    with respect to the {u,v,w} frame provides the coordinates of the same point with
    !!----    respect to the {i,j,k} frame.
    !!----    If Code =="R" or Blank or not present then the input angles are given in radians.
    !!----    If Code =="D" then the input angles are given in degrees (Phi, Theta, Chi).
    !!----
    !!---- Update: February - 2005
    !!
    Function Matrix_Phithechi(Phi,Theta,Chi,Code) Result(Mt)
       !---- Arguments ----!
       real(kind=cp),                intent(in) :: Phi
       real(kind=cp),                intent(in) :: Theta
       real(kind=cp),                intent(in) :: Chi
       character(len=*), optional,   intent(in) :: Code
       real(kind=cp), dimension(3,3)            :: Mt

       !---- Local Variables ----!
       real(kind=cp) :: p,t,c

       if (present(code)) then
          select case (code(1:1))
             case("D","d") ! degrees
                p=Phi*to_rad
                t=Theta*to_rad
                c=Chi*to_rad
             case default ! radians
                p=Phi
                t=Theta
                c=Chi
          end select
       else
          !---- radians ----!
          p=Phi
          t=Theta
          c=Chi
       end if
       Mt(1,1)= cos(p)*cos(t)*cos(c)-sin(p)*sin(c)    !
       Mt(2,1)= sin(p)*cos(t)*cos(c)+cos(p)*sin(c)    !  u
       Mt(3,1)=-sin(t)*cos(c)                         !
       Mt(1,2)=-cos(p)*cos(t)*sin(c)-sin(p)*cos(c)    !
       Mt(2,2)=-sin(p)*cos(t)*sin(c)+cos(p)*cos(c)    !  v
       Mt(3,2)= sin(t)*sin(c)                         !
       Mt(1,3)= cos(p)*sin(t)                         !
       Mt(2,3)= sin(p)*sin(t)                         !  w
       Mt(3,3)= cos(t)                                !

       return
    End Function Matrix_Phithechi

    !!----
    !!---- Function Matrix_Rx(Ang,Code) Result(M)
    !!----    real(kind=cp),                      intent(in) :: Ang
    !!----    character(len=*), optional,         intent(in) :: Code
    !!----    real(kind=cp), dimension(3,3)                  :: M    ! Put -> Active Rotation Matrix
    !!----
    !!----    Calculate the active rotation matrix corresponding to the positive rotation
    !!----    of an angle Phi around the x-axis. The transpose matrix corresponds to a
    !!----    passive rotation that changes the orthogonal system to {u,v,w} leaving the point
    !!----    at the same position w.r.t. the canonical {i,j,k} frame.
    !!----    If Code =="R" or Blank or not present then the input angle is given in radians.
    !!----    If Code =="D" then the input angle is given in degrees.
    !!----
    !!---- Update: February - 2005
    !!
    Function Matrix_Rx(Ang,Code) Result(Mt)
       !---- Arguments ----!
       real(kind=cp),               intent(in) :: Ang
       character(len=*), optional,  intent(in) :: Code
       real(kind=cp), dimension(3,3)           :: Mt

       !---- Local Variables ----!
       real(kind=cp) :: p

       if (present(code)) then
          select case (code(1:1))
             case("D","d") ! degrees
                p=Ang*to_rad
             case default ! radians
                p=Ang
          end select
       else
          !---- radians ----!
          p=Ang
       end if
       Mt(1,1)= 1.0        !              1  0  0
       Mt(2,1)= 0.0        !  u           0  c -s     Rx
       Mt(3,1)= 0.0        !              0  s  c
       Mt(1,2)= 0.0        !
       Mt(2,2)= cos(p)     !  v
       Mt(3,2)= sin(p)     !
       Mt(1,3)= 0.0        !
       Mt(2,3)=-sin(p)     !  w
       Mt(3,3)= cos(p)     !

       return
    End Function Matrix_Rx

    !!----
    !!---- Function Matrix_Ry(Ang,Code) Result(M)
    !!----    real(kind=cp),                      intent(in) :: Ang
    !!----    character(len=*), optional,         intent(in) :: Code
    !!----    real(kind=cp), dimension(3,3)                  :: M    ! Put -> Active Rotation Matrix
    !!----
    !!----    Calculate the active rotation matrix corresponding to the positive rotation
    !!----    of an angle Phi around the y-axis. The transpose matrix corresponds to a
    !!----    passive rotation that changes the orthogonal system to {u,v,w} leaving the point
    !!----    at the same position w.r.t. the canonical {i,j,k} frame.
    !!----    If Code =="R" or Blank or not present then the input angle is given in radians.
    !!----    If Code =="D" then the input angle is given in degrees.
    !!----
    !!---- Update: February - 2005
    !!
    Function Matrix_Ry(Ang,Code) Result(Mt)
       !---- Arguments ----!
       real(kind=cp),               intent(in) :: Ang
       character(len=*), optional,  intent(in) :: Code
       real(kind=cp), dimension(3,3)           :: Mt

       !---- Local Variables ----!
       real(kind=cp) :: p

       if (present(code)) then
          select case (code(1:1))
             case("D","d") ! degrees
                p=Ang*to_rad
             case default ! radians
                p=Ang
          end select
       else
          !---- radians ----!
          p=Ang
       end if
       Mt(1,1)= cos(p)  !             c  0  s
       Mt(2,1)= 0.0     !  u          0  1  0      Ry
       Mt(3,1)=-sin(p)  !            -s  0  c
       Mt(1,2)= 0.0     !
       Mt(2,2)= 1.0     !  v
       Mt(3,2)= 0.0     !
       Mt(1,3)= sin(p)  !
       Mt(2,3)= 0.0     !  w
       Mt(3,3)= cos(p)  !

       return
    End Function Matrix_Ry

    !!----
    !!---- Function Matrix_Rz(Ang,Code) Result(M)
    !!----    real(kind=cp),                      intent(in) :: Ang
    !!----    character(len=*), optional,         intent(in) :: Code
    !!----    real(kind=cp), dimension(3,3)                  :: M    ! Put -> Active Rotation Matrix
    !!----
    !!----    Calculate the active rotation matrix corresponding to the positive rotation
    !!----    of an angle Phi around the z-axis. The transpose matrix corresponds to a
    !!----    passive rotation that changes the orthogonal system to {u,v,w} leaving the point
    !!----    at the same position w.r.t. the canonical {i,j,k} frame.
    !!----    If Code =="R" or Blank or not present then the input angle is given in radians.
    !!----    If Code =="D" then the input angle is given in degrees.
    !!----
    !!---- Update: February - 2005
    !!
    Function Matrix_Rz(Ang,Code) Result(Mt)
       !---- Arguments ----!
       real(kind=cp),               intent(in) :: Ang
       character(len=*), optional,  intent(in) :: Code
       real(kind=cp), dimension(3,3)           :: Mt

       !---- Local Variables ----!
       real(kind=cp) :: p

       if (present(code)) then
          select case (code(1:1))
             case("D","d") ! degrees
                p=Ang*to_rad
             case default ! radians
                p=Ang
          end select
       else
          !---- radians ----!
          p=Ang
       end if
       Mt(1,1)= cos(p)  !                 c  -s  0
       Mt(2,1)= sin(p)  !  u              s   c  0    Rz
       Mt(3,1)= 0.0     !                 0   0  1
       Mt(1,2)=-sin(p)  !
       Mt(2,2)= cos(p)  !  v
       Mt(3,2)= 0.0     !
       Mt(1,3)= 0.0     !
       Mt(2,3)= 0.0     !  w
       Mt(3,3)= 1.0     !

       return
    End Function Matrix_Rz

    !---------------------!
    !---- Subroutines ----!
    !---------------------!

    !!----
    !!---- Subroutine Allocate_Coordination_Type(nasu,numops,dmax,Max_Coor)
    !!----    integer,       intent(in) :: nasu      !  In -> Number of atoms in asymmetric unit
    !!----    integer,       intent(in) :: numops    !  In -> Number of S.O. excluding lattice centerings
    !!----    real(kind=cp), intent(in) :: dmax      !  In -> Maximun distance to be calculated
    !!----    integer,      intent(out) :: Max_Coor  !  Maximum coordination allowed
    !!----
    !!----    Allocation of Coordination_Type.
    !!----    Should be called before using this module.
    !!----
    !!---- Update: March - 2005
    !!
    Subroutine Allocate_Coordination_Type(nasu,numops,dmax,Max_Coor)
       !---- Arguments ----!
       integer,       intent(in) :: nasu
       integer,       intent(in) :: numops
       real(kind=cp), intent(in) :: dmax
       integer,      intent(out) :: Max_Coor

       !---- local variables ----!
       real(kind=cp), parameter :: r_atom=0.4_cp !Radius of a typical atom

       if (allocated(Coord_Info%Coord_Num)) deallocate(Coord_Info%Coord_Num)
       if (allocated(Coord_Info%N_Cooatm))  deallocate(Coord_Info%N_Cooatm)
       if (allocated(Coord_Info%N_Sym))     deallocate(Coord_Info%N_Sym)
       if (allocated(Coord_Info%Dist))      deallocate(Coord_Info%Dist)
       if (allocated(Coord_Info%S_Dist))    deallocate(Coord_Info%S_Dist)
       if (allocated(Coord_Info%Tr_Coo))    deallocate(Coord_Info%Tr_Coo)


       max_coor= (dmax/r_atom)**3
       max_coor=max(max_coor,nasu*numops)

       !---- Assigninmg the new values ----!
       Coord_Info%Natoms=nasu
       Coord_Info%Max_Coor= max_coor

       allocate (Coord_Info%Coord_Num(nasu))
       allocate (Coord_Info%N_Cooatm(max_coor,nasu))
       allocate (Coord_Info%N_Sym(max_coor,nasu))
       allocate (Coord_Info%Dist(max_coor,nasu))
       allocate (Coord_Info%S_Dist(max_coor,nasu))
       allocate (Coord_Info%Tr_Coo(3,max_coor,nasu))

       Coord_Info%Coord_Num=0
       Coord_Info%N_Cooatm =0
       Coord_Info%N_Sym    =0
       Coord_Info%Dist     =0.0
       Coord_Info%S_Dist   =0.0
       Coord_Info%Tr_Coo   =0.0

       return
    End Subroutine Allocate_Coordination_Type

    !!----
    !!---- Subroutine Allocate_Point_List(N,Pl,Ier)
    !!----    integer,               intent(in)     :: n      !  In -> Dimension for allocating components of the type
    !!----    type(point_list_type), intent(in out) :: pl     !  In Out-> Type with allocatable components
    !!----    integer,               intent(out)    :: ier    !  Out -> if ier /= 0 an error occurred.
    !!----
    !!----    Allocation of an objet of type Point_List_Type
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Allocate_Point_List(n,Pl,Ier)
       !---- Arguments ----!
       integer,               intent(in)     :: n
       type(point_list_type), intent(in out) :: pl
       integer,               intent(out)    :: ier

       ier=0
       if (n <= 0) then
          ier=1
          return
       end if

       if ( .not. allocated(pl%nam) ) allocate(pl%nam(n),stat=ier)
       if ( .not. allocated(pl%p) )   allocate(pl%p(n),stat=ier)
       if ( .not. allocated(pl%x) )   allocate(pl%x(3,n),stat=ier)

       pl%nam= " "
       pl%np=0
       pl%p=0
       pl%x=0.0

       return
    End subroutine Allocate_Point_List

    !!----
    !!---- Subroutine Calc_Dist_Angle(Dmax, Dangl, Cell, Spg, A, Lun)
    !!----    real(kind=cp),            intent(in)             :: dmax   !  In -> Max. Distance to calculate
    !!----    real(kind=cp),            intent(in)             :: dangl  !  In -> Max. distance for angle calculations
    !!----    type (Crystal_cell_type), intent(in)             :: Cell   !  In -> Object of Crytal_Cell_Type
    !!----    type (Space_Group_type),  intent(in)             :: SpG    !  In -> Object of Space_Group_Type
    !!----    type (atom_list_type),   intent(in)             :: A      !  In -> Object of atom_list_type
    !!----    integer,                  optional, intent(in)   :: lun    !  In -> Logical Unit for writing
    !!----
    !!----    Subroutine to calculate distances and angles, below the prescribed distances
    !!----    "dmax" and "dangl" (angles of triplets at distance below "dangl" to an atom),
    !!----    without standard deviations. If dangl=0.0, no angle calculations are done.
    !!----    Needs as input the objects Cell (of type Crystal_cell), SpG (of type Space_Group)
    !!----    and A (of type atom_list, that should be allocated in the calling program).
    !!----    Writes results in file (unit=lun) if lun is present
    !!----    Control for error is present.
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Calc_Dist_Angle(Dmax, Dangl, Cell, Spg, A, Lun)
       !---- Arguments ----!
       real(kind=cp),            intent(in)   :: Dmax, Dangl
       type (Crystal_cell_Type), intent(in)   :: Cell
       type (Space_Group_Type),  intent(in)   :: SpG
       type (atom_list_type),    intent(in)   :: A
       integer, optional,        intent(in)   :: lun

       !---- Local Variables ----!
       logical                            :: iprin
       integer                            :: i,j,k,lk,i1,i2,i3,jl,npeq,nn,L,nlines, max_coor,ico
       character(len= 80), dimension(12)  :: texto = " "
       character(len=  5)                 :: nam,nam1,nam2
       character(len= 40)                 :: transla
       character(len=160)                 :: form3
       character(len= 90)                 :: form2= "(a,3I4,a,a,a,a,a,f9.4,a,3F8.4,a,t85,a)"  !  JRC feb 2014 &   ! TR 4 fev. 2013
                                           !  "("" "",3I4,""  ("",a,"")-("",a,""):"",f9.4,""   "",3F8.4,""  "",a,""  "",a)"
       integer, dimension(3)              :: ic1,ic2
       real(kind=cp),    dimension(3)     :: xx,x1,xo,Tn,xr, QD
       real(kind=cp)                      :: T,dd, da1,da2,da12,cang12,ang12,cang1,ang2,ang1

       real(kind=cp), allocatable,dimension(:,:) :: uu
       real(kind=cp), allocatable,dimension(:,:) :: bcoo

       iprin=.false.
       if (present(lun)) then
          if (lun > 0) iprin=.true.
       end if

       call init_err_geom()

       call allocate_coordination_type(A%natoms,Spg%multip,Dmax,Max_coor)
       if(allocated(uu)) deallocate(uu)
       allocate(uu(3,Max_coor))
       if(allocated(bcoo)) deallocate(bcoo)
       allocate(bcoo(3,Max_coor))

       qd(:)=1.0/cell%rcell(:)
       ic2(:)= nint(dmax/cell%cell(:)+2.5_cp)
       ic1(:)=-ic2(:)
       npeq=spg%numops
       if (dangl > epsi .and. iprin ) then
          form3="(""    ("",a,"")-("",a,"")-("",a,""):"",f8.3/"
          form3=trim(form3)//"""    ("",a,"")-("",a,"")-("",a,""):"",f8.3/"
          form3=trim(form3)//"""    ("",a,"")-("",a,"")-("",a,""):"",f8.3/"
          form3=trim(form3)//"""         ("",a,"") :"",3f8.4,""  ("",a,"") :"",3f8.4)"
       end if

       if (spg%centred == 2) then
          npeq=2*npeq
          if (iprin) then
             write(unit=lun,fmt="(/,a)")" => Symmetry operators combined with inversion centre:"
             nlines=1
             do i=SpG%NumOps+1,npeq
                if (mod(i,2) == 0) then
                   write(unit=texto(nlines)(36:70),fmt="(a,i2,a,a)") &
                               " => SYMM(",i,"): ",trim(SpG%SymopSymb(i))
                   nlines=nlines+1
                else
                   write(unit=texto(nlines)( 1:34),fmt="(a,i2,a,a)")  &
                               " => SYMM(",i,"): ",trim(SpG%SymopSymb(i))
                end if
             end do
             do i=1,min(nlines,12)
                write(unit=lun,fmt="(a)") texto(i)
             end do
          end if
       end if

       do i=1,a%natoms
          xo(:)=a%atom(i)%x(:)
          nam=a%atom(i)%lab
          if (iprin) then
             write(unit=lun,fmt="(/,/,a)")"    -------------------------------------------------------------------"
             write(unit=lun,fmt="(a,f8.4,a,a,3f8.4)")   &
                       "    Distances less than",dmax,"  to atom: ",nam, xo
             write(unit=lun,fmt="(a,/,/)")"    -------------------------------------------------------------------"
             write(unit=lun,fmt="(/,/,a,/,/)") & ! TR 4 fev. 2013
             " Orig. extr. p.equiv.           Distance      x_ext   y_ext   z_ext  (tx,ty,tz)     Sym. op."
          end if
          Coord_Info%Coord_Num(i)=0
          ico=0
          do k=1,a%natoms
             lk=1
             uu(:,lk)=xo(:)
             nam1=a%atom(k)%lab
             do j=1,npeq
                xx=ApplySO(Spg%SymOp(j),a%atom(k)%x)
                do i1=ic1(1),ic2(1)
                   do i2=ic1(2),ic2(2)
                      do i3=ic1(3),ic2(3)
                         do_jl:do jl=1,Spg%NumLat
                            Tn(:)=real((/i1,i2,i3/))+Spg%Latt_trans(:,jl)
                            x1(:)=xx(:)+tn(:)
                            do l=1,3
                               t=abs(x1(l)-xo(l))*qd(l)
                               if (t > dmax) cycle do_jl
                            end do
                            do nn=1,lk
                               if (sum(abs(uu(:,nn)-x1(:)))  <= epsi) cycle do_jl
                            end do
                            xr = matmul(cell%cr_orth_cel,x1-xo)
                            dd=sqrt(dot_product(xr,xr))
                            if (dd > dmax .or. dd < 0.001) cycle
                            ico=ico+1

                            if (Coord_Info%Coord_Num(i) > Coord_Info%Max_Coor) then
                               err_geom=.true.
                               ERR_Geom_Mess=" => Too many distances around atom: "//nam
                               return
                            end if

                            lk=lk+1
                            uu(:,lk)=x1(:)
                            Coord_Info%Dist(ico,i)=dd
                            Coord_Info%N_Cooatm(ico,i)=k
                            bcoo(:,ico)=x1(:)
                            Coord_Info%Tr_Coo(:,ico,i)=tn
                            if (iprin) then
                               call Frac_Trans_1Dig(tn,transla)
                               write(unit=lun,fmt=form2) " ",i,k,j,"  (",nam,")-(",nam1,"):",dd,"   ",x1(:), "  "//transla, &
                                                         trim(Spg%SymOpSymb(j)) !JRC Feb2014
                            end if
                         end do do_jl
                      end do !i3
                   end do !i2
                end do !i1
             end do !j
          end do !k

          Coord_Info%Coord_Num(i)=ico
          if (dangl <= epsi) cycle     !loop on "i" still running

          !---- Angle calculations for bonded atoms at distance lower than DANGL

          if (iprin) then
                write(unit=lun,fmt="(/,/,a)")       "   -------------------------------------------------------"
                write(unit=lun,fmt="(a,a,3f8.4)")   "   -  Angles around atom: ",nam, xo
                write(unit=lun,fmt="(a,/)")         "   -------------------------------------------------------"
          end if
          do j=1,Coord_Info%Coord_Num(i)
             if (Coord_Info%dist(j,i) < epsi .or. Coord_Info%dist(j,i) > dangl) cycle
             da1=Coord_Info%dist(j,i)
             i1=Coord_Info%N_Cooatm(j,i)
             nam1=a%atom(i1)%lab
             do k=j+1,Coord_Info%Coord_Num(i)
                if (Coord_Info%dist(k,i) < epsi .OR. Coord_Info%dist(k,i) > dangl) cycle
                da2=Coord_Info%dist(k,i)
                i2=Coord_Info%N_Cooatm(k,i)
                nam2=a%atom(i2)%lab
                xx(:)=bcoo(:,k)-bcoo(:,j)
                xr = matmul(Cell%Cr_Orth_cel,xx)
                da12=sqrt(dot_product(xr,xr))
                cang12=0.5_cp*(da1/da2+da2/da1-da12*da12/da1/da2)
                ang12=acosd(cang12)
                cang1=0.5_cp*(da12/da2+da2/da12-da1*da1/da12/da2)
                ang1=acosd(cang1)
                ang2=180.0_cp-ang1-ang12

                if (iprin) then
                    write(unit=lun,fmt="(/,3(a,f8.4))")  &
                         "     Atm-1   Atm-2   Atm-3            d12 =",da1,"  d23 =",da2,"   d13 =",da12
                    write(unit=lun,fmt=form3)  nam1,nam,nam2,ang12,   &
                         nam,nam2,nam1,ang1, nam,nam1,nam2,ang2,  &
                         nam1,bcoo(:,j),nam2, bcoo(:,k)
                end if
             end do !k
          end do !j
       end do !i

       return
    End Subroutine Calc_Dist_Angle

    !!----
    !!---- Subroutine Calc_Dist_Angle_Sigma(Dmax, Dangl, Cell, Spg, A, Lun, Lun_cons, Lun_cif,filen,rdmax,ramin)
    !!----    real(kind=cp),             intent(in)   :: dmax     !  In -> Max. Distance to calculate
    !!----    real(kind=cp),             intent(in)   :: dangl    !  In -> Max. distance for angle calculations
    !!----    type (Crystal_cell_type),  intent(in)   :: Cell     !  In -> Object of Crytal_Cell_Type
    !!----    type (Space_Group_type),   intent(in)   :: SpG      !  In -> Object of Space_Group_Type
    !!----    type (atom_list_type),     intent(in)   :: A        !  In -> Object of atom_list_type
    !!----    integer, optional,         intent(in)   :: lun      !  In -> Logical Unit for writing
    !!----    integer, optional,         intent(in)   :: lun_cons !  In -> Logical unit for writing restraints
    !!----    integer, optional,         intent(in)   :: lun_cif  !  In -> Logical unit for writing CIF file with distances and angles
    !!----    character(len=*), optional,intent(in)   :: filrest  !  In -> Name of file for writing restraints
    !!----    real(kind=cp),    optional,intent(in)   :: rdmax,ramin  !  Maximum distan and minimum angle for output in restraints file
    !!----
    !!----    Subroutine to calculate distances and angles, below the prescribed distances
    !!----    "dmax" and "dangl" (angles of triplets at distance below "dangl" to an atom),
    !!----    with standard deviations. If dangl=0.0, no angle calculations are done.
    !!----    Needs as input the objects Cell (of type Crystal_cell), SpG (of type Space_Group)
    !!----    and A (or type atom_list, that should be allocated in the calling program).
    !!----    Writes results in file (unit=lun) if the argument lun is present. In case
    !!----    lun_cif is provided, the program writes in the already opened CIF file (in
    !!----    the calling program) the items related to distances. If lun_cons is provided
    !!----    the program writes items containing restraints to the file CFML_restraints.tpcr
    !!----    or to file "filrest" if provided as argument.
    !!----    Control for error is present.
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Calc_Dist_Angle_Sigma(Dmax, Dangl, Cell, Spg, A, Lun, Lun_cons, Lun_cif,filrest,rdmax,ramin)
       !---- Arguments ----!
       real(kind=cp),             intent(in)   :: dmax, dangl
       type (Crystal_cell_Type),  intent(in)   :: Cell
       type (Space_Group_Type),   intent(in)   :: SpG
       type (Atom_list_type),     intent(in)   :: A
       integer, optional,         intent(in)   :: lun
       integer, optional,         intent(in)   :: lun_cons
       integer, optional,         intent(in)   :: lun_cif
       character(len=*), optional,intent(in)   :: filrest
       real(kind=cp),    optional,intent(in)   :: rdmax, ramin

       !---- Local Variables ----!
       logical                            :: iprin
       integer,parameter                  :: nconst=500
       integer                            :: i,j,k,lk,i1,i2,i3,jl,nn,L,&
                                             itnum1,itnum2,num_const, max_coor,num_angc,ico
       character(len=  6)                 :: nam,nam1,nam2
       character(len= 40)                 :: transla
       character(len= 20)                 :: text,tex,texton
       character(len=132)                 :: line
       character(len=160)                 :: form3
       character(len= 90)                 :: form2= "(a,3i4,a,a,a,a,a,a12,3F8.4,a,t85,a)"  !  JRC feb 2014 form2= &   ! TR 4 fev. 2013
                                             !"("" "",3I4,""  ("",a,"")-("",a,""):"",f9.4,""   "",3F8.4,""  "",a,""  "",a)"
       integer, dimension(3)              :: ic1,ic2
       integer, dimension(192)            :: itnum
       real(kind=cp),dimension(3,3,6)     :: DerM
       real(kind=cp),    dimension(3)     :: xx,x1,xo,Tn, QD,so,ss,s1,s2,x2,tr1,tr2
       real(kind=cp)                      :: T,dd, da1,da2,da12,cang12,ang12,cang1,ang2,ang1,rest_d,rest_a
       real(kind=cp)                      :: sdd,sda1,sda2,sda12,sang12,sang2,sang1,srel1,srel2,srel12

       real(kind=cp), allocatable, dimension(:,:) :: uu
       real(kind=cp), allocatable, dimension(:,:) :: bcoo
       real(kind=cp), allocatable, dimension(:,:) :: sbcoo
       real(kind=cp), allocatable, dimension(:,:) :: trcoo

       character(len=132), dimension(:), allocatable  :: const_text
       character(len=132), dimension(:), allocatable  :: dist_text
       character(len=132), dimension(:), allocatable  :: angl_text

       character(len=8) :: codesym
       logical :: esta

       !--- write CIF ---------------------------------------------------------------------
       integer, parameter                             :: max_cif_dist_text = 1500
       integer, parameter                             :: max_cif_angl_text = 6000
       integer                                        :: n_cif_dist_text
       integer                                        :: n_cif_angl_text
       character (len=12)                             :: CIF_bond_site_symm_2
       character (len=12)                             :: CIF_angle_site_symm_1
       character (len=12)                             :: CIF_angle_site_symm_3
       character (len=132), dimension(:), allocatable :: cif_dist_text
       character (len=132), dimension(:), allocatable :: cif_angl_text
       !-----------------------------------------------------------------------------------


       iprin=.false.
       if (present(lun)) then
          if (lun > 0) iprin=.true.
       end if
       rest_d=dmax
       rest_a=45.0
       if(present(rdmax)) rest_d=rdmax
       if(present(ramin)) rest_a=ramin
       call init_err_geom()
       call Allocate_Coordination_Type(A%natoms,Spg%Multip,Dmax,max_coor)

       if(allocated(uu)) deallocate(uu)
       allocate(uu(3,max_coor))
       if(allocated(bcoo)) deallocate(bcoo)
       allocate(bcoo(3,max_coor))
       if(allocated(sbcoo)) deallocate(sbcoo)
       allocate(sbcoo(3,max_coor))
       if(allocated(trcoo)) deallocate(trcoo)
       allocate(trcoo(3,max_coor))


       call get_deriv_Orth_cell(cell,DerM,"A")

       if (present(lun_cons)) then
          num_angc=0
          num_const=0
          if(present(filrest)) then
            open (unit=lun_cons, file=trim(filrest), status="replace", action="write")
          else
            open (unit=lun_cons, file="CFML_Restraints.tpcr", status="replace", action="write")
          end if
          write(unit=lun_cons,fmt="(a)") " FILE with lines for soft distance and angle constraints (restraints)."
          write(unit=lun_cons,fmt="(a)") " It is intended to help editing PCR files with restraints by pasting, "
          write(unit=lun_cons,fmt="(a)") " after correcting the values as wished, to the appropriate lines.  "
          write(unit=lun_cons,fmt="(a)") " Lines with repeated identical distances have been excluded because symmetry "
          write(unit=lun_cons,fmt="(a)") " already force a hard constraint."
          write(unit=lun_cons,fmt="(a)") " Accidental coincidences have also been excluded, check that in list of distances! "
          write(unit=lun_cons,fmt="(/,a)")   " Warning! "
          write(unit=lun_cons,fmt="(a,/,a/)") " Symmetry constrained angles have not been eliminated,",&
                                              " this has to be performed by hand!"

          !---- Set ITnum ----!
          i=0
          i1=1
          i2=24
          if (spg%hexa) then
             i1=25
             i2=36
          end if
          do j=1,Spg%multip
             call searchop(SpG%Symop(j)%Rot(:,:),i1,i2,i)
             Itnum(j)=i
          end do
          if (allocated(const_text)) deallocate(const_text)
          allocate(const_text(nconst)) !Maximum number of restraints
          const_text(:)(1:132)=" "
          if (allocated(dist_text)) deallocate(dist_text)
          allocate(dist_text(nconst)) !Maximum number of restraints
          dist_text(:)(1:132)=" "
          if (allocated(angl_text)) deallocate(angl_text)
          allocate(angl_text(nconst)) !Maximum number of restraints
          angl_text(:)(1:132)=" "
       end if

       if (present(lun_cif)) then
          write(unit=lun_cif, fmt='(a)') " "
          write(unit=lun_cif, fmt='(a)') "#=============================================================================#"
          write(unit=lun_cif, fmt='(a)') "#                      UNIT CELL INFORMATION                                  #"
          write(unit=lun_cif, fmt='(a)') "#=============================================================================#"
          write(unit=lun_cif, fmt='(a)') "_symmetry_cell_setting                "//trim(SPG%CrystalSys)
          write(unit=lun_cif, fmt='(a)') "_symmetry_space_group_name_H-M       '"//trim(SPG%SPG_symb)//"'"
          write(unit=lun_cif, fmt='(a)') "_symmetry_space_group_name_Hall      '"//trim(SPG%Hall)//"'"
          write(unit=lun_cif, fmt='(a)') " "
          write(unit=lun_cif, fmt='(a)') "loop_"
          write(unit=lun_cif, fmt='(a)') "    _symmetry_equiv_pos_as_xyz   #<--must include 'x,y,z'"

          do i=1,SPG%multip
             write(unit=lun_cif, fmt='(a)') "'"//trim(SPG%SymopSymb(i))//"'"
          end do
          write(unit=lun_cif, fmt='(a)') " "

          write(unit=lun_cif, fmt='(a)') "#=============================================================================#"
          write(unit=lun_cif, fmt='(a)') "#                       MOLECULAR GEOMETRY                                    #"
          write(unit=lun_cif, fmt='(a)') "#=============================================================================#"

          if (allocated(CIF_dist_text)) deallocate(CIF_dist_text)
          allocate(CIF_dist_text(max_cif_dist_text)) !Maximum number of distances
          CIF_dist_text(:)(1:132)=" "
          if (allocated(CIF_angl_text)) deallocate(CIF_angl_text)
          allocate(CIF_angl_text(max_cif_angl_text)) !Maximum number of angles
          CIF_angl_text(:)(1:132)=" "
          n_cif_dist_text = 0
          n_cif_angl_text = 0
       end if

       qd(:)=1.0/cell%rcell(:)
       ic2(:)= nint(dmax/cell%cell(:)+2.5_cp)
       ic1(:)=-ic2(:)
       if (dangl > epsi .and. iprin ) then
          form3=            "(""    ("",a,"")-("",a,"")-("",a,""):"",a12/"
          form3=trim(form3)//"""    ("",a,"")-("",a,"")-("",a,""):"",a12/"
          form3=trim(form3)//"""    ("",a,"")-("",a,"")-("",a,""):"",a12/"
          form3=trim(form3)//"""         ("",a,"") :"",3f9.5,""  ("",a,"") :"",3f9.5)"
       end if
       do i=1,a%natoms
          xo(:)=a%atom(i)%x(:)
          so(:)=a%atom(i)%x_std(:)
          nam=a%atom(i)%lab
          Select Case (len_trim(nam))
             case(1)
                nam="  "//trim(nam)
             case(2:5)
                nam=" "//trim(nam)
          End Select
          if (iprin) then
             write(unit=lun,fmt="(/,/,a)")"    -------------------------------------------------------------------"
             write(unit=lun,fmt="(a,f8.4,a,a,3f8.4)")   &
                       "    Distances less than",dmax,"  to atom: ",nam, xo
             write(unit=lun,fmt="(a,/,/)")"    -------------------------------------------------------------------"
             write(unit=lun,fmt="(/,/,a,/,/)") &		! TR 4 fev. 2013
                  " Orig. extr. p.equiv.           Distance      x_ext   y_ext   z_ext  (tx,ty,tz)     Sym. op."
          end if

          ico=0
          do k=1,a%natoms
             lk=1
             uu(:,lk)=xo(:)
             nam1=a%atom(k)%lab
             Select Case (len_trim(nam1))
               case(1)
                  nam1="  "//trim(nam1)
               case(2:5)
                  nam1=" "//trim(nam1)
             End Select
             ss(:)=A%atom(k)%x_std(:)
             do j=1,Spg%Multip
                xx=ApplySO(Spg%SymOp(j),a%atom(k)%x)

                do i1=ic1(1),ic2(1)
                   do i2=ic1(2),ic2(2)
                      do_i3:do i3=ic1(3),ic2(3)

                            Tn(:)=real((/i1,i2,i3/))
                            x1(:)=xx(:)+tn(:)
                            do l=1,3
                               t=abs(x1(l)-xo(l))*qd(l)
                               if (t > dmax) cycle  do_i3
                            end do
                            do nn=1,lk
                               if (sum(abs(uu(:,nn)-x1(:)))  <= epsi) cycle  do_i3
                            end do
                            call distance_and_sigma(Cell,DerM,xo,x1,so,ss,dd,sdd)
                            if (dd > dmax .or. dd < 0.001) cycle
                            ico=ico+1
                            if (Coord_Info%Coord_Num(i) > Coord_Info%Max_Coor) then
                               err_geom=.true.
                               ERR_Geom_Mess=" => Too many distances around atom: "//nam
                               return
                            end if
                            lk=lk+1
                            uu(:,lk)=x1(:)

                            Coord_Info%Dist(ico,i)=dd
                            Coord_Info%S_Dist(ico,i)=sdd
                            Coord_Info%N_Cooatm(ico,i)=k
                            Coord_Info%N_sym(ico,i)=j
                            Coord_Info%Tr_Coo(:,ico,i)=tn

                            bcoo(:,ico)=x1(:)
                            sbcoo(:,ico)=ss(:)
                            trcoo(:,ico)=Tn(:)
                            if (iprin) then
                               call Frac_Trans_1Dig(tn,transla)
                               call setnum_std(dd,sdd,text)
                               !write(unit=lun,fmt=form2) i,k,j,nam,nam1,dd,x1(:), transla, trim(Spg%SymOpSymb(j))! TR 4 fev. 2013
                               write(unit=lun,fmt=form2) " ",i,k,j,"  (",nam,")-(",nam1,"):",text,x1(:), "  "//transla, &
                                                         trim(Spg%SymOpSymb(j)) !JRC Feb2014
                            end if

                            if(present(lun_cons) .and. dd <= rest_d) then
                              esta=.false.
                              write(unit=line,fmt="(a4,tr2,a4,i5,3f10.5,tr5,2f7.4)") A%atom(i)%lab ,A%atom(k)%lab ,&
                                     Itnum(j), tn(:)+SpG%Symop(j)%tr(:) ,dd, sdd
                              if(num_const == 0) then
                                const_text(1)=line(1:132)
                                num_const=1
                                write(unit=dist_text(1),fmt="(a,2f9.5,a)") "DFIX ",dd,sdd, &
                                                                           "  "//trim(A%atom(i)%lab)//"  "//trim(A%atom(k)%lab)
                                call Write_SymTrans_Code(j,tn,codesym)
                                dist_text(1)=trim(dist_text(1))//codesym
                              else
                                do l=num_const,1,-1
                                 if( (line(1:4) == const_text(l)(1:4) .and. line(7:10) == const_text(l)(7:10)) .or. &
                                     (line(1:4) == const_text(l)(7:10) .and. line(7:10) == const_text(l)(1:4)) ) then
                                   if(line(51:132) == const_text(l)(51:132)) then
                                        esta=.true.
                                        exit
                                   end if
                                 end if
                                end do
                                if(.not. esta) then
                                  num_const=num_const+1
                                  if(num_const > NCONST) then
                                     num_const=num_const-1
                                  end if
                                  const_text(num_const)=line(1:132)
                                  write(unit=dist_text(num_const),fmt="(a,2f9.5,a)") "DFIX ",dd,sdd,&
                                        "  "//trim(A%atom(i)%lab)//"  "//trim(A%atom(k)%lab)
                                  call Write_SymTrans_Code(j,tn,codesym)
                                  dist_text(num_const)=trim(dist_text(num_const))//trim(codesym)
                                end if
                              end if
                            end if

                            if(present(lun_cif) .and. n_cif_dist_text < max_cif_dist_text) then
                               call setnum_std(dd,sdd,text)
                               n_cif_dist_text = n_cif_dist_text + 1

                               !if(i1==0 .and. i2==0 .and. i3==0 .and. j==1) then
                               ! write(unit=CIF_bond_site_symm_2, fmt='(a)') "       . ?"
                               !else
                                write(unit=CIF_bond_site_symm_2, fmt='(a,i3, a, 3i1,a)') " ", j, "_", nint(tn+5.0), " ?"
                               !end if

                               write(unit=CIF_dist_text(n_cif_dist_text), fmt='(6a)') &
                                     A%atom(i)%lab(1:4), "  ", A%atom(k)%lab(1:4), " ", text(1:12), CIF_bond_site_symm_2
                            end if
                      end do do_i3 !i3
                   end do !i2
                end do !i1
             end do !j
          end do !k

          Coord_Info%Coord_Num(i)=ico
          if (dangl <= epsi) cycle     !loop on "i" still running

          !---- Angle calculations for bonded atoms at distance lower than DANGL
          if (present(lun_cons)) write(unit=lun_cons,fmt="(a,a)")"=> Help for possible angle restraints around atom ",A%atom(i)%lab

          if (iprin) then
             write(unit=lun,fmt="(/,/,a)")       "   -------------------------------------------------------"
             write(unit=lun,fmt="(a,a,3f8.4)")   "   -  Angles around atom: ",nam, xo
             write(unit=lun,fmt="(a,/)")         "   -------------------------------------------------------"
          end if
          do j=1,Coord_Info%Coord_Num(i)
             if (Coord_Info%Dist(j,i) < epsi .or. Coord_Info%Dist(j,i) > dangl) cycle
             da1=Coord_Info%Dist(j,i)
             sda1=Coord_Info%S_Dist(j,i)
             i1=Coord_Info%N_Cooatm(j,i)
             nam1=a%atom(i1)%lab
             Select Case (len_trim(nam1))
               case(1)
                  nam1="  "//trim(nam1)
               case(2:5)
                  nam1=" "//trim(nam1)
             End Select
             if (present(lun_cons)) then
               itnum1=itnum(Coord_Info%N_sym(j,i))
               tr1(:)=trcoo(:,j)+SpG%Symop(Coord_Info%N_sym(j,i))%tr(:)
             end if
             do k=j+1,Coord_Info%Coord_Num(i)
                if (Coord_Info%Dist(k,i) < epsi .OR. Coord_Info%Dist(k,i) > dangl) cycle
                da2=Coord_Info%Dist(k,i)
                sda2=Coord_Info%S_Dist(k,i)
                i2=Coord_Info%N_Cooatm(k,i)
                nam2=a%atom(i2)%lab
                Select Case (len_trim(nam2))
                  case(1)
                     nam2="  "//trim(nam2)
                  case(2:5)
                     nam2=" "//trim(nam2)
                End Select
                if (present(lun_cons)) then
                  itnum2=itnum(Coord_Info%N_sym(k,i))
                  tr2(:)=trcoo(:,k)+SpG%Symop(Coord_Info%N_sym(k,i))%tr(:)
                end if
                x1(:)=bcoo(:,k)
                x2(:)=bcoo(:,j)
                s1(:)=sbcoo(:,k)
                s2(:)=sbcoo(:,j)
                call distance_and_sigma(Cell,derM,x1,x2,s1,s2,da12,sda12)
                if( da12 < 0.0001) cycle

                cang12=0.5_cp*(da1/da2+da2/da1-da12*da12/da1/da2)
                ang12=ACOSd(cang12)
                cang1=0.5_cp*(da12/da2+da2/da12-da1*da1/da12/da2)
                ang1=ACOSd(cang1)
                ang2=180.0_cp-ang1-ang12

               ! if(abs(abs(cang12)-1.0) < 0.0001) then
               !   sang12=0.0
               ! else
               !  dcang121=(1.0/da2-cang12/da1)**2
               !  dcang122=(1.0/da1-cang12/da2)**2
               !  dcang1212=(da12/da2/da1)**2
               !  sang12=sqrt((dcang121*sda1**2+dcang122*sda2**2+dcang1212*sda12**2)/(1.0-cang12**2))*to_deg
               ! end if
               ! if(abs(abs(cang1)-1.0) < 0.0001) then
               !   sang1=0.0
               ! else
               !  dcang112=(1.0/da2-cang1/da12)**2
               !  dcang12=(1.0/da12-cang1/da2)**2
               !  dcang11=(da1/da2/da12)**2
               !  sang1=sqrt((dcang11*sda1**2+dcang12*sda2**2+dcang112*sda12**2)/(1.0-cang1**2))*to_deg
               ! end if
               ! sang2=sqrt(sang1**2+sang12**2)


                !---- Alternative calculation of angles' sigmas ----!
                srel1=(sda1/da1)**2
                srel12=(sda12/da12)**2
                srel2=(sda2/da2)**2
                sang12=SQRT(srel1+srel2+(sda12*da12/da1/da2)**2)*to_deg
                sang1=SQRT(srel12+srel2+(sda1*da1/da2/da12)**2)*to_deg
                sang2=SQRT(srel12+srel1+(sda2*da2/da1/da12)**2)*to_deg

                if (iprin) then
                   call setnum_std(da1,sda1,tex)
                   call setnum_std(da2,sda2,text)
                   call setnum_std(da12,sda12,texton)
                   write(unit=lun,fmt="(/,a,3a21)")  &
                        "     Atm-1   Atm-2   Atm-3           "," d12 ="//tex,"  d23 ="//text,"   d13 ="//texton
                   call setnum_std(ang12,sang12,tex)
                   call setnum_std(ang1,sang1,text)
                   call setnum_std(ang2,sang2,texton)
                   write(unit=lun,fmt=form3)  nam1,nam,nam2,tex,    &
                                              nam,nam2,nam1,text,   &
                                              nam,nam1,nam2,texton, &
                                              nam1,bcoo(:,j),  nam2, bcoo(:,k)
                end if

                if (present(lun_cons)) then

                  if(ang2 >= rest_a) &
                  write(unit=lun_cons,fmt="(3(a6,tr1),i3,i4,tr1,3f8.4,tr1,3f8.4,2f7.2)") &
                  A%atom(i)%lab ,nam1 ,nam2 ,itnum1,itnum2,tr1(:),tr2(:),ang2,sang2

                  if(ang1 >= rest_a) &
                  write(unit=lun_cons,fmt="(3(a6,tr1),i3,i4,tr1,3f8.4,tr1,3f8.4,2f7.2)") &  !Another angle of the same triangle
                  A%atom(i)%lab ,nam2 ,nam1 ,itnum2,itnum1,tr2(:),tr1(:),ang1,sang1

                  if(ang12 >= rest_a .and. itnum1==1 .and. sum(abs(tr1)) < 0.001) & !Good constraint
                  write(unit=lun_cons,fmt="(3(a6,tr1),i3,i4,tr1,3f8.4,tr1,3f8.4,2f7.2)") &
                  adjustl(nam1),A%atom(i)%lab ,nam2 ,itnum1,itnum2,tr1(:),tr2(:),ang12,sang12

                  if(ang12 >= rest_a .and. itnum2==1 .and. sum(abs(tr2)) < 0.001) & !Good constraint
                  write(unit=lun_cons,fmt="(3(a6,tr1),i3,i4,tr1,3f8.4,tr1,3f8.4,2f7.2)") &  !Another angle of the same triangle
                  adjustl(nam2)," "//A%atom(i)%lab ,nam1 ,itnum2,itnum1,tr2(:),tr1(:),ang12,sang12

                  if(num_angc == 0) then

                    if(ang2 >= rest_a) then
                      num_angc=num_angc+1
                      line=" "
                      write(unit=line,fmt="(a,2f9.3,a)") "AFIX ",ang2,sang2,&
                                                         "  "//trim(A%atom(i)%lab)//" "//trim(nam1)
                      call Write_SymTrans_Code(Coord_Info%N_sym(j,i),trcoo(:,j),codesym)
                      line=trim(line)//trim(codesym)//" "//trim(nam2)
                      call Write_SymTrans_Code(Coord_Info%N_sym(k,i),trcoo(:,k),codesym)
                      line=trim(line)//trim(codesym)
                      angl_text(1)=line(1:132)
                    end if
                    !Repeating with another angle of the same triangle
                    if(ang1 >= rest_a) then
                      num_angc=num_angc+1
                      line=" "
                      write(unit=line,fmt="(a,2f9.3,a)") "AFIX ",ang1,sang1,&
                                                         "  "//trim(A%atom(i)%lab)//" "//trim(nam2)
                      call Write_SymTrans_Code(Coord_Info%N_sym(k,i),trcoo(:,k),codesym)
                      line=trim(line)//trim(codesym)//" "//trim(nam1)
                      call Write_SymTrans_Code(Coord_Info%N_sym(j,i),trcoo(:,j),codesym)
                      line=trim(line)//trim(codesym)
                      angl_text(num_angc)=line(1:132)
                    end if

                    if(ang12 >= rest_a .and. itnum1==1 .and. sum(abs(tr1)) < 0.001) then
                      num_angc=num_angc+1
                      line=" "
                      write(unit=line,fmt="(a,2f9.3,a)") "AFIX ",ang12,sang12,&
                                                         " "//trim(nam1)//"  "//trim(A%atom(i)%lab)
                      call Write_SymTrans_Code(1,(/0.0,0.0,0.0/),codesym)
                      line=trim(line)//trim(codesym)//" "//trim(nam2)
                      call Write_SymTrans_Code(Coord_Info%N_sym(k,i),trcoo(:,k),codesym)
                      line=trim(line)//trim(codesym)
                      angl_text(num_angc)=line(1:132)
                    end if

                    if(ang12 >= rest_a .and. itnum2==1 .and. sum(abs(tr2)) < 0.001) then
                      num_angc=num_angc+1
                      line=" "
                      write(unit=line,fmt="(a,2f9.3,a)") "AFIX ",ang12,sang12,&
                                                         " "//trim(nam2)//"  "//trim(A%atom(i)%lab)
                      call Write_SymTrans_Code(1,(/0.0,0.0,0.0/),codesym)
                      line=trim(line)//trim(codesym)//" "//trim(nam1)
                      call Write_SymTrans_Code(Coord_Info%N_sym(j,i),trcoo(:,j),codesym)
                      line=trim(line)//trim(codesym)
                      angl_text(num_angc)=line(1:132)
                    end if

                  else

                    if(ang2 >= rest_a) then
                      line=" "
                      write(unit=line,fmt="(a,2f9.3,a)") "AFIX ",ang2,sang2,&
                                                         "  "//trim(A%atom(i)%lab)//" "//trim(nam1)
                      call Write_SymTrans_Code(Coord_Info%N_sym(j,i),trcoo(:,j),codesym)
                      line=trim(line)//trim(codesym)//" "//trim(nam2)
                      call Write_SymTrans_Code(Coord_Info%N_sym(k,i),trcoo(:,k),codesym)
                      line=trim(line)//trim(codesym)

                      esta=.false.
                      jl=index(line,"_")
                      if(jl == 0) jl=len_trim(line)
                      do l=num_angc,1,-1
                       if( line(1:jl) == angl_text(l)(1:jl)) then
                           esta=.true.
                           exit
                       end if
                      end do
                      if(.not. esta) then
                        num_angc=num_angc+1
                        if(num_angc > NCONST) num_angc=NCONST
                        angl_text(num_angc)=line(1:132)
                      end if
                    end if

                    if(ang1 >= rest_a) then
                      !Repeating with another angle of the same triangle
                      line=" "
                      write(unit=line,fmt="(a,2f9.3,a)") "AFIX ",ang1,sang1,&
                                                         "  "//trim(A%atom(i)%lab)//" "//trim(nam2)
                      call Write_SymTrans_Code(Coord_Info%N_sym(k,i),trcoo(:,k),codesym)
                      line=trim(line)//trim(codesym)//" "//trim(nam1)
                      call Write_SymTrans_Code(Coord_Info%N_sym(j,i),trcoo(:,j),codesym)
                      line=trim(line)//trim(codesym)

                      esta=.false.
                      jl=index(line,"_")
                      if(jl == 0) jl=len_trim(line)
                      do l=num_angc,1,-1
                       if( line(1:jl) == angl_text(l)(1:jl)) then
                           esta=.true.
                           exit
                       end if
                      end do
                      if(.not. esta) then
                        num_angc=num_angc+1
                        if(num_angc > NCONST) num_angc=NCONST
                        angl_text(num_angc)=line(1:132)
                      end if
                    end if

                    if(ang12 >= rest_a .and. itnum1==1 .and. sum(abs(tr1)) < 0.001) then
                      !Repeating with another angle of the same triangle
                      line=" "
                      write(unit=line,fmt="(a,2f9.3,a)") "AFIX ",ang12,sang12,&
                                                          " "//trim(nam1)//"  "//trim(A%atom(i)%lab)
                      call Write_SymTrans_Code(1,(/0.0,0.0,0.0/),codesym)
                      line=trim(line)//trim(codesym)//" "//trim(nam2)
                      call Write_SymTrans_Code(Coord_Info%N_sym(k,i),trcoo(:,k),codesym)
                      line=trim(line)//trim(codesym)

                      esta=.false.
                      jl=index(line,"_")
                      if(jl == 0) jl=len_trim(line)
                      do l=num_angc,1,-1
                       if( line(1:jl) == angl_text(l)(1:jl)) then
                           esta=.true.
                           exit
                       end if
                      end do
                      if(.not. esta) then
                        num_angc=num_angc+1
                        if(num_angc > NCONST) num_angc=NCONST
                        angl_text(num_angc)=line(1:132)
                      end if
                    end if

                    if(ang12 >= rest_a .and. itnum1==2 .and. sum(abs(tr2)) < 0.001) then
                      !Repeating with another angle of the same triangle
                      line=" "
                      write(unit=line,fmt="(a,2f9.3,a)") "AFIX ",ang12,sang12,&
                                                          " "//trim(nam2)//"  "//trim(A%atom(i)%lab)
                      call Write_SymTrans_Code(1,(/0.0,0.0,0.0/),codesym)
                      line=trim(line)//trim(codesym)//" "//trim(nam1)
                      call Write_SymTrans_Code(Coord_Info%N_sym(j,i),trcoo(:,j),codesym)
                      line=trim(line)//trim(codesym)

                      esta=.false.
                      jl=index(line,"_")
                      if(jl == 0) jl=len_trim(line)
                      do l=num_angc,1,-1
                       if( line(1:jl) == angl_text(l)(1:jl)) then
                           esta=.true.
                           exit
                       end if
                      end do
                      if(.not. esta) then
                        num_angc=num_angc+1
                        if(num_angc > NCONST) num_angc=NCONST
                        angl_text(num_angc)=line(1:132)
                      end if
                    end if

                  end if

                end if !present(lun_cons)

                if (present(lun_cif) .and. n_cif_angl_text < max_cif_angl_text .and. ang12 > 45.0) then
                   !--- Change: I have included the condition ang12 > 45 for selecting the angle to write in
                   !            the CIF file, normally the angles below that value are irrelevant from the
                   !            chemical point of view.
                   ! j: indice de l'operateur de symetrie pour atome 1 ----! No!, Now j and k correspond to indices
                   ! k: indice de l'operateur de symetrie pour atome 2 ----!      running on coordination around atom i!
                   ! tr1: translation associee a op_j ----No!      =>  trcoo(:,j)!
                   ! tr2: translation associee a op_k ?  ----No!   =>  trcoo(:,k)!
                   n_cif_angl_text = n_cif_angl_text + 1

                   !  The commented lines correspond to wrong selections of translations!!!!!!!
                   !  Moreover the indices j and k were taken as the ordinal numbers of the
                   !  symmetry operators and that's not true!
                   !if (j==1 .and. nint(tr1(1))==0 .and. nint(tr1(2))==0 .and. nint(tr1(3))==0) then
                   !   write(unit=CIF_angle_site_symm_1, fmt='(a)') "       ."
                   !else
                   !   write(unit=CIF_angle_site_symm_1, fmt='(a,i3, a, 3I1)') " ", j, "_",  &
                   !         nint(tr1(1)+5.0), nint(tr1(2)+5.0), nint(tr1(3)+5.0)
                   !end if
                   !if (k==1 .and. nint(tr2(1))==0 .and. nint(tr2(2))==0 .and. nint(tr2(3))==0) then
                   !   write(unit=CIF_angle_site_symm_3, fmt='(a)') "  .  ?"
                   !else
                   !   write(unit=CIF_angle_site_symm_3, fmt='(a,i3, a, 3I1,a)') " ", k, "_", &
                   !         nint(tr2(1)+5.0), nint(tr2(2)+5.0), nint(tr2(3)+5.0), " ?"
                   !end if

                   write(unit=CIF_angle_site_symm_1, fmt='(a,i3, a, 3I1)') " ", &
                         Coord_Info%N_sym(j,i), "_", nint(trcoo(:,j)+5.0)
                   write(unit=CIF_angle_site_symm_3, fmt='(a,i3, a, 3I1,a)') " ", &
                         Coord_Info%N_sym(k,i), "_", nint(trcoo(:,k)+5.0), " ?"

                   write(unit=CIF_angl_text(n_cif_angl_text), fmt='(10a)')        &
                         nam1(1:4)," ", nam(1:4), " ",nam2, tex(1:12), " ",       &
                         trim(CIF_angle_site_symm_1), " ", trim(CIF_angle_site_symm_3)

                end if
             end do !k
          end do !j
       end do !i

       if (present(lun_cons)) then
          write(unit=lun_cons,fmt="(/,a,i5)")"=> Total number of independent distances: ",num_const
          write(unit=lun_cons,fmt="(a,/)")   "   List of possible restraints: "
          write(unit=lun_cons,fmt="(a)")" At1   At2  ITnum     T1        T2        T3          DIST   SIGMA"
          do i=1,num_const
             write(unit=lun_cons,fmt="(2x,a)") trim(const_text(i))
          end do

          write(unit=lun_cons,fmt="(/,a)")   "   ========================================= "
          write(unit=lun_cons,fmt="(a  )")   "   List of possible restraints in CFL format "
          write(unit=lun_cons,fmt="(a,/)")   "   ========================================= "


          write(unit=lun_cons,fmt="(/a,i5)")"=> Total number of independent distance restraints: ",num_const
          do i=1,num_const
             write(unit=lun_cons,fmt="(a)") trim(dist_text(i))
          end do
          write(unit=lun_cons,fmt="(/a,i5)")"=> Total number of possible angle restraints: ",num_angc
          do i=1,num_angc
             write(unit=lun_cons,fmt="(a)") trim(angl_text(i))
          end do
          close(unit=lun_cons)
       end if

       if (present(lun_cif)) then
          if (n_CIF_dist_text /=0) then
             write(unit=lun_cif, fmt='(a)') "loop_"
             write(unit=lun_cif, fmt='(a)') "   _geom_bond_atom_site_label_1"
             write(unit=lun_cif, fmt='(a)') "   _geom_bond_atom_site_label_2"
             write(unit=lun_cif, fmt='(a)') "   _geom_bond_distance"
             write(unit=lun_cif, fmt='(a)') "   _geom_bond_site_symmetry_2"
             write(unit=lun_cif, fmt='(a)') "   _geom_bond_publ_flag"

             do i=1, n_CIF_dist_text
                write(unit=lun_CIF, fmt='(a)') trim(CIF_dist_text(i))
             end do
          end if

          if (n_CIF_angl_text /=0) then
             write(unit=lun_cif, fmt='(a)') ""
             write(unit=lun_cif, fmt='(a)') "loop_"
             write(unit=lun_cif, fmt='(a)') "   _geom_angle_atom_site_label_1"
             write(unit=lun_cif, fmt='(a)') "   _geom_angle_atom_site_label_2"
             write(unit=lun_cif, fmt='(a)') "   _geom_angle_atom_site_label_3"
             write(unit=lun_cif, fmt='(a)') "   _geom_angle"
             write(unit=lun_cif, fmt='(a)') "   _geom_angle_site_symmetry_1"
             write(unit=lun_cif, fmt='(a)') "   _geom_angle_site_symmetry_3"
             write(unit=lun_cif, fmt='(a)') "   _geom_angle_publ_flag"

             do i=1, n_CIF_angl_text
              write(unit=lun_CIF, fmt='(a)') trim(CIF_angl_text(i))
             end do
          end if
       end if

       return
    End Subroutine Calc_Dist_Angle_Sigma

    !!----
    !!---- Subroutine Deallocate_Coordination_Type()
    !!----
    !!----    Deallocation of Coordination_Type.
    !!----
    !!---- Update: March - 2005
    !!
    Subroutine Deallocate_Coordination_Type()

       if (allocated(Coord_Info%Coord_Num)) deallocate(Coord_Info%Coord_Num)
       if (allocated(Coord_Info%N_Cooatm))  deallocate(Coord_Info%N_Cooatm)
       if (allocated(Coord_Info%N_Sym))     deallocate(Coord_Info%N_Sym)
       if (allocated(Coord_Info%Dist))      deallocate(Coord_Info%Dist)
       if (allocated(Coord_Info%S_Dist))    deallocate(Coord_Info%S_Dist)
       if (allocated(Coord_Info%Tr_Coo))    deallocate(Coord_Info%Tr_Coo)

       !---- Assigninmg the new values ----!
       Coord_Info%Natoms=0
       Coord_Info%Max_Coor= 0

       return
    End Subroutine Deallocate_Coordination_Type

    !!----
    !!---- Subroutine Deallocate_Point_List(Pl)
    !!----    type(point_list_type), intent(in out) :: pl  !  In Out-> Type with allocatable components
    !!----
    !!----     De-allocation of an objet of type point_list_type
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Deallocate_Point_List(Pl)
       !---- Arguments ----!
       type(point_list_type), intent(in out) :: pl

       if (allocated(pl%nam) ) deallocate(pl%nam)
       if (allocated(pl%p) )   deallocate(pl%p)
       if (allocated(pl%x) )   deallocate(pl%x)

       return
    End Subroutine Deallocate_Point_List

    !!----
    !!---- Subroutine Distance_and_Sigma(Cellp,DerM,x0,x1,s0,s1,dis,s)
    !!----    Type(Crystal_Cell_Type),         intent(in)  :: Cellp         ! Cell object
    !!----    real(kind=cp), dimension(3,3,6), intent(in)  :: DerM          ! Matrix of derivatives of Cellp%Cr_Orth_cel
    !!----    real(kind=cp), dimension(3),     intent(in)  :: x0,x1,s0,s1   ! Two points in fractional coordinates and sigmas
    !!----    real(kind=cp),                   intent(out) :: dis,s         ! Distance and sigma
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Distance_and_Sigma(Cellp,DerM,x0,x1,s0,s1,dis,s)
       !---- Arguments ----!
       Type(Crystal_Cell_Type),         intent(in)  :: Cellp         ! Cell object
       real(kind=cp), dimension(3,3,6), intent(in)  :: DerM          ! Matrix of derivatives of Cellp%Cr_Orth_cel
       real(kind=cp), dimension(3),     intent(in)  :: x0,x1,s0,s1   ! Two points in fractional coordinates and sigmas
       real(kind=cp),                   intent(out) :: dis,s         ! Distance and sigma

       !---- Local variables ----!
       integer                     :: i
       real(kind=cp), dimension(3) :: xc,xf
       real(kind=cp), dimension(6) :: dc,df

       xf=x1-x0
       xc = matmul(cellp%Cr_Orth_cel,xf)
       dis=sqrt(dot_product(xc,xc))
       do i=1,6
          dc(i) = dot_product(xc,matmul(DerM(:,:,i),xf))
       end do
       do i=1,3
          df(i) = dot_product(xc,Cellp%Cr_Orth_cel(:,i))
       end do
       df(4:6) =-df(1:3)
       s=0.0
       do i=1,3
          s = s + (dc(i)*Cellp%cell_std(i))**2
          s = s + (dc(i+3)*Cellp%ang_std(i)*to_rad)**2
          s = s + (df(i)*s1(i))**2 + (df(i+3)*s0(i))**2
       end do
       s=sqrt(s)/dis

       return
    End Subroutine Distance_and_Sigma

    !!----
    !!----  Subroutine Get_Anglen_Axis_From_RotMat(R,axis,angle)
    !!----    real(kind=cp), dimension(3,3), intent(in) :: R             !Input orthogonal matrix
    !!----    real(kind=cp), dimension(3),   intent(out):: axis          !Non normalized rotation axis
    !!----    real(kind=cp),                 intent(out):: angle         !Angle of rotation
    !!----
    !!----  Subroutine to obtain the axis and angle of rotation corresponding to
    !!----  an input orthogonal matrix. A Cartesian frame is assumed
    !!----
    !!---- Update: January - 2011
    !!----
    Subroutine Get_Anglen_Axis_From_RotMat(R,axis,angle)
      Real(kind=cp), dimension(3,3), intent(in) :: R
      Real(kind=cp), dimension(3),   intent(out):: axis
      Real(kind=cp),                 intent(out):: angle
      !--- Local variables ---!
      Real(kind=cp) :: va

      va=(R(1,1)+R(2,2)+R(3,3)-1.0_cp)*0.5_cp
      if(va < -1.0_cp) va=-1.0_cp
      if(va >  1.0_cp) va= 1.0_cp
      angle= acosd(va)
      if(abs(abs(angle)-180.0_cp) < epsi) then
         axis= (/                sqrt(R(1,1)+1.0_cp), &
                sign(1.0_cp,R(1,2))*sqrt(R(2,2)+1.0_cp), &
                sign(1.0_cp,R(1,3))*sqrt(R(3,3)+1.0_cp) /)
      else
         axis= (/  R(2,3)-R(3,2), &
                   R(3,1)-R(1,3), &
                   R(1,2)-R(2,1) /)
      end if
      return
    End Subroutine Get_Anglen_Axis_From_RotMat

    !!----
    !!----  Subroutine Get_Euler_From_Fract(X1,X2,X3,Mt,Phi,Theta,Chi,Eum,Code)
    !!----    real(kind=cp),           dimension(3),   intent (in) :: x1,x2,x3
    !!----    real(kind=cp),           dimension(3,3), intent (in) :: M !Matrix transforming to Cartesian coordinates
    !!----    real(kind=cp),                           intent(out) :: theta,phi,chi
    !!----    real(kind=cp), optional, dimension(3,3), intent(out) :: EuM
    !!----    character(len=*), optional,              intent (in) :: Code
    !!----
    !!----  Subroutine to obtain the Euler angles (2nd setting) of a Cartesian frame having
    !!----  as origin the point x3, the z-axis along x1-x3 and the "xz" plane coincident with
    !!----  the plane generated by the two vectors (x2-x3,x1-x3). The
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Get_Euler_From_Fract(X1,X2,X3,Mt,Phi,Theta,Chi,Eum,Code)
       !---- Arguments ----!
       real(kind=cp),           dimension(3),   intent (in) :: x1,x2,x3
       real(kind=cp),           dimension(3,3), intent (in) :: Mt
       real(kind=cp),                           intent(out) :: theta,phi,chi
       real(kind=cp), optional, dimension(3,3), intent(out) :: EuM
       character(len=*), optional,              intent (in) :: Code

       !---- Local variables ----!
       real(kind=cp), dimension(3)   :: u,v,w
       real(kind=cp), dimension(3,3) :: rot

!  U = ( cosPhi cosTheta cosChi - sinPhi sinChi,   sinPhi cosTheta cosChi+cosPhi sinChi,  -sinTheta cosChi)
!  V = (-sinPhi cosChi   - cosPhi cosTheta sinChi, cosPhi cosChi -sinPhi cosTheta sinChi,  sinTheta sinChi)
!  W = ( cosPhi sinTheta, sinPhi sinTheta,  cosTheta)
!
!     This corresponds to Euler angles defined in the following way:
!
!     In the starting position the cartesian frame (u,v,w) coincides with the crystallographic
!     cartesian frame (e1//a, e2 in the a-b plane and e3= e1 x e2). First a rotation Chi around
!     the e3 axis is applied, then a rotation Theta around the e2 axis and finally a rotation Phi
!     around e3. The total rotation matrix is
!
!          R(Phi,Theta,Chi) = R(e3,Phi) R(e2,Theta) R(e3,Chi) = [[ u, v, w]]
!
!     The columns of the active rotation matrix are the components of the unitary vectors u,v,w.

       w=matmul(Mt,x1-x3)
       w=w/sqrt(dot_product(w,w))
       u=matmul(Mt,x2-x3)
       u=u/sqrt(dot_product(u,u))
       v=cross_product(w,u)
       v=v/sqrt(dot_product(v,v))
       u=cross_product(v,w) !already normalized
       rot(:,1)=u; rot(:,2)=v;  rot(:,3)=w  !Matrix Rot ([u,v,w] columns)
       if (present(EuM)) EuM=rot
       if (present(Code)) then
          call get_PhiTheChi(rot,phi,theta,chi,Code)
       else
          call get_PhiTheChi(rot,phi,theta,chi)
       end if

       return
    End Subroutine Get_Euler_From_Fract

    !!---- Subroutine Get_Matrix_moving_v_to_u(v,u,R,w,ang)
    !!----   real(kind=cp), dimension(3),           intent(in)  :: v,u   !Starting and final vectors
    !!----   real(kind=cp), dimension(3,3),         intent(out) :: R     !Rotation matrix moving v to u:  u=Rv
    !!----   real(kind=cp), optional,               intent(out) :: ang   !angle between the two vectors
    !!----   real(kind=cp), optional,dimension(3),  intent(out) :: w     !axis normal to plane of the two vectors
    !!----
    !!----   Subroutine to get the orthogonal matrix that rotates a vector v
    !!----   to orient it along the vector u. Makes use of Cross_Product and
    !!----   Rot_matrix (Gibbs matrix)
    !!----
    !!----    Created: February 2010 (JRC)
    !!----    Updated: March 2013 (JRC)
    !!----
    !!
    Subroutine Get_Matrix_moving_v_to_u(v,u,R,w,ang)
      real(kind=cp), dimension(3),           intent(in)  :: v,u
      real(kind=cp), dimension(3,3),         intent(out) :: R
      real(kind=cp), optional,               intent(out) :: ang
      real(kind=cp), optional,dimension(3),  intent(out) :: w
      !--- Local variables ---!
      integer                        :: i,iu,iv
      real(kind=cp), parameter       :: ep=1.0e-5_cp
      real(kind=cp)                  :: mv,mu,mvu,phi,c
      logical                        :: co_linear
      real(kind=cp), dimension(3)    :: vu
      integer, dimension(1)          :: im
      real(kind=cp), parameter, dimension(3,3):: ident=reshape((/1.0_cp,0.0_cp,0.0_cp, &
                                                                 0.0_cp,1.0_cp,0.0_cp, &
                                                                 0.0_cp,0.0_cp,1.0_cp/),(/3,3/))

      if(present(ang)) ang=0.0
      if(present(w))   w=0.0
      !First determine if the two input vectors are co-linear
      im=maxloc(abs(v))
      iv=im(1)
      im=maxloc(abs(u))
      iu=im(1)
      co_linear=.true.
      if(iu == iv) then ! may be co-linear
        if(abs(u(iu)) > ep) then
          c=v(iv)/u(iu)
          do i=1,3
            if(abs( v(i)-c*u(i) ) > ep ) then
               co_linear=.false.
               exit
            end if
          end do
        end if
      else
        co_linear=.false.
      end if
      if(co_linear) then
        mvu=v(iv)*u(iu)
        if(mvu < 0.0) then   !opposed vectors
          R=-ident
        else                 !parallel vectors
          R=ident
        end if
      else
        ! non co-linear
        vu=Cross_Product(v,u)      !Rotation axis
        mv=sqrt(dot_product(v,v))
        mu=sqrt(dot_product(u,u))
        phi=dot_product(u,v)/mv/mu
        phi=acosd(phi)        !Angle between the two input vectors
        R=Rot_matrix(vu,phi)  !Gibbs matrix
        if(present(ang)) ang=phi
        if(present(w)) w=vu
      end if
      return
    End Subroutine Get_Matrix_moving_v_to_u

    !!----
    !!---- Subroutine Get_OmegaChiPhi(Mt,Omega,Chi,Phi,Code)
    !!----    real(kind=cp), dimension(3,3),intent(in)  :: Mt
    !!----    real(kind=cp),                intent(out) :: Omega
    !!----    real(kind=cp),                intent(out) :: Chi
    !!----    real(kind=cp),                intent(out) :: Phi
    !!----    character(len=*), optional,   intent(in)  :: Code
    !!----
    !!----    Calculate the Euler Angles corresponding to an orthogonal matrix
    !!----    The definition of the Euler angles in this case correspond to the
    !!----    rotation matrix of Busing and Levy for diffractometry obtained from
    !!----    the composition of a rotation around z of angle Phi, followed by a
    !!----    rotation of angle Chi around the y-axis and a subsequent rotation of angle
    !!----    Omega around z.
    !!----    The matrix is supposed to be of the form: M = Rz(Omega).Ry(Chi).Rz(Phi)
    !!----    If Code =="R" or not present then the output angles are provided in radians.
    !!----    If Code =="D" then the output angles are provided in degrees.
    !!----    A checking of the input matrix is given before calculating the angles.
    !!----    The user must check the logical variable "ERR_RotMat" after calling this
    !!----    subroutine. If ERR_RotMat=.true. it means that the input matrix is not orthogonal.
    !!----    The obtained rotations should be interpreted as changes of reference systems, the
    !!----    angles correspond to the motor settings to put a reciprocal vector in Cartesian
    !!----    coordinates w.r.t. the L-system (all angles equal to zero) in the position given
    !!----    by the active rotation matrix Mt:  z4= Mt z1.
    !!----
    !!---- Updated: March - 2013
    !!
    Subroutine Get_OmegaChiPhi(Mt,Omega,Chi,Phi,Code)  !Conventional Euler angles of diffractometry
       !---- Arguments ----!
       real(kind=cp), dimension(3,3),intent(in)  :: Mt
       real(kind=cp),                intent(out) :: Omega
       real(kind=cp),                intent(out) :: Chi
       real(kind=cp),                intent(out) :: Phi
       character(len=*), optional,   intent(in)  :: Code

       !---- Local Variables ----!
       real(kind=cp), dimension(3,3):: MTT
       real(kind=cp), parameter, dimension(3,3) :: &
                      identity = reshape ( (/1.0,0.0,0.0, 0.0,1.0,0.0, 0.0,0.0,1.0/),(/3,3/))

       MTT=transpose(Mt)
       MTT=matmul(MTT,Mt)-identity
       if (sum(abs(MTT)) > 5.0*eps) then
          ERR_Geom=.true.
          ERR_Geom_Mess=" Error in Get_OmegaChiPhi ... the input matrix is not orthogonal! "
          return
       end if
       if (abs(Mt(3,3)-1.0) < eps) then  !M(3,3)=cos(Chi)=1
          Chi=0.0
          Omega=0.0                       ! Omega and Phi have the same axis, we select Omega=0
          !Phi=acos(Mt(1,1))              ! M(1,1)=cos(Omega)cos(Chi)cos(Phi)-sin(Omega)sin(Phi)
          Phi=atan2(Mt(1,2),Mt(1,1))      ! M(1,2)=cos(Omega)cos(Chi)sin(Phi)+sin(Omega)cos(Phi)
       else if(abs(Mt(3,3)+1.0) < eps) then  !M(3,3)=cos(Chi)=-1
          Chi=pi
          Omega=0.0                       ! Omega and Phi have the same axis, we select Omega=0
          !Phi=acos(-Mt(1,1))             ! We use also the elements (11) and (12)
          Phi=atan2(-Mt(1,2),Mt(1,1))
       else
          !Chi=acos(Mt(3,3))  !Better use the relation below (In BL there is an error in eqn 48 for omega)
          Omega=atan2(-Mt(2,3),Mt(1,3))       !M(1,3)=  cos(Omega)sin(Chi)   M(2,3)= -sin(Omega)sin(Chi)
          Phi=atan2(-Mt(3,2),-Mt(3,1))        !M(3,1)= -sin(Chi)cos(Phi)     M(3,2)= -sin(Chi)sin(Phi)
          Chi=atan2( Sqrt(Mt(3,1)*Mt(3,1)+Mt(3,2)*Mt(3,2)), Mt(3,3) )
       end if
       if (present(Code)) then
          if (code(1:1)=="D" .or. code(1:1)=="d") then
             Phi=Phi*to_deg
             Omega=Omega*to_deg
             Chi=Chi*to_deg
          end if
       end if

       return
    End Subroutine Get_OmegaChiPhi

    !!----
    !!---- Subroutine Get_PhiTheChi(Mt,Phi,Theta,Chi,Code)
    !!----    real(kind=cp), dimension(3,3),intent(in)  :: Mt
    !!----    real(kind=cp),                intent(out) :: Phi
    !!----    real(kind=cp),                intent(out) :: Theta
    !!----    real(kind=cp),                intent(out) :: Chi
    !!----    character(len=*), optional,   intent(in)  :: Code
    !!----
    !!----    Calculate the Euler Angles corresponding to an orthogonal matrix
    !!----    The definition of the Euler angles in this case correspond to the
    !!----    active rotation matrix obtained from the composition of a rotation
    !!----    around z of angle Chi, followed by a rotation of angle Theta
    !!----    around the y-axis and a subsequent rotation of angle Phi around z.
    !!----    The matrix is supposed to be of the form: M = Rz(Phi).Ry(Theta).Rz(Chi)
    !!----    If Code =="R" or not present then the output angles are provided in radians.
    !!----    If Code =="D" then the output angles are provided in degrees.
    !!----    A checking of the input matrix is given before calculating the angles.
    !!----    The user must check the logical variable "err_geom" after calling this
    !!----    subroutine. If err_geom=.true. it means that the input matrix is not orthogonal.
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Get_PhiTheChi(Mt,Phi,Theta,Chi,Code)
       !---- Arguments ----!
       real(kind=cp), dimension(3,3),intent(in)  :: Mt
       real(kind=cp),                intent(out) :: Phi
       real(kind=cp),                intent(out) :: Theta
       real(kind=cp),                intent(out) :: Chi
       character(len=*), optional,   intent(in)  :: Code

       !---- Local Variables ----!
       real(kind=cp), dimension(3,3):: MTT
       real(kind=cp), parameter, dimension(3,3) :: &
                      identity = reshape ( (/1.0,0.0,0.0, 0.0,1.0,0.0, 0.0,0.0,1.0/),(/3,3/))

       MTT=transpose(Mt)
       MTT=matmul(MTT,Mt)-identity
       if (sum(abs(MTT)) > 5.0*eps) then
          err_geom=.true.
          ERR_Geom_Mess=" Error in Get_PhiTheChi ... the input matrix is not orthogonal! "
          return
       end if
       if (abs(Mt(3,3)-1.0) < eps) then  !M(3,3)=cos(Theta)
          Theta=0.0
          Phi=0.0
          Chi=acos(Mt(1,1))               !M(1,1)=cos(Phi)cos(Theta)cos(Chi)-sin(Phi)sin(Chi)
       else if(abs(Mt(3,3)+1.0) < eps) then
          Theta=pi
          Phi=0.0
          Chi=acos(-Mt(1,1))
       else
          Theta=acos(Mt(3,3))
          Phi=atan2(Mt(2,3),Mt(1,3))     !M(1,3)=cos(Phi)sin(Theta)  M(2,3)=sin(phi)sin(Theta)
          Chi=atan2(Mt(3,2),-Mt(3,1))    !M(3,1)= -sin(Theta)cos(Chi)   M(3,2)= sin(Theta)sin(Chi)
       end if
       if (present(Code)) then
          if (code(1:1)=="D" .or. code(1:1)=="d") then
             Phi=Phi*to_deg
             Theta=Theta*to_deg
             Chi=Chi*to_deg
          end if
       end if

       return
    End Subroutine Get_PhiTheChi

    !!----
    !!---- Subroutine Get_Transf_List(Trans,Ox,Pl,Npl,Ifail)
    !!----   real(kind=cp), dimension(3,3), intent(in)     :: trans   !Matrix transforming the basis
    !!----   real(kind=cp), dimension(3  ), intent(in)     :: ox      !Coordinates of origin of the new basis
    !!----   type(point_list_type),         intent(in)     :: pl      !Input List of points
    !!----   type(point_list_type),         intent(in out) :: npl     !Output list of transformed points
    !!----   integer,                       intent(out)    :: ifail   !If ifail/=0 matrix inversion failed
    !!----
    !!----  Subroutine to get the fractional coordinates of the points of the input list "pl" in the
    !!----  new transformed cell ( a'= trans a) displaced to the new origing "ox". The coordinates
    !!----  are generated using only lattice translations. All coordinates are reduced to be
    !!----  between 0.0 and 1.0, so that  0.0 <= x,y,z < 1.0
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Get_Transf_List(trans,ox,pl,npl,ifail)
       !---- Arguments ----!
       real(kind=cp),         dimension(3,3), intent(in)     :: trans
       real(kind=cp),         dimension(3  ), intent(in)     :: ox
       type(point_list_type),                 intent(in)     :: pl
       type(point_list_type),                 intent(in out) :: npl
       integer,                               intent(out)    :: ifail

       !---- local variables ----!
       integer                       :: i,j,ia,ib,ic,nat,mm
       integer, dimension(3)         :: mini,maxi
       real(kind=cp), dimension(7,3) :: vecpar
       real(kind=cp), dimension(3,3) :: si
       real(kind=cp), dimension(3  ) :: xx, xxn,v

       ifail=0
       call matrix_inverse(trans,si,ifail)
       if (ifail == 1) return

       !----  Construction of the 7 vertices of the new cell
       !----  1:a, 2:b, 3:c, 4:a+b, 5:a+c, 6:b+c 7:a+b+c
       do j=1,3
          do i=1,3
             vecpar(i,j)=trans(i,j)
          end do
          vecpar(4,j)=trans(1,j)+trans(2,j)
          vecpar(5,j)=trans(1,j)+trans(3,j)
          vecpar(6,j)=trans(2,j)+trans(3,j)
          vecpar(7,j)=trans(1,j)+trans(2,j)+trans(3,j)
       end do

       !---- Exploration of the vertex matrix
       mini(:)=1000
       maxi(:)=-1000
       do j=1,3
          do i=1,7
             if (vecpar(i,j) < mini(j)) mini(j)=nint(min(vecpar(i,j),0.0_cp))
             if (vecpar(i,j) > maxi(j)) maxi(j)=nint(max(vecpar(i,j),1.0_cp))
          end do
       end do

       !
       !   Explore the region  a-> min(1)---max(1)  where atoms will be generated
       !                       b-> min(2)---max(2)
       !                       c-> min(3)---max(3)
       !   and select those belonging to the interior of the new cell before
       !   translation to the new origin.
       !   set the translation to the new origin, put the atoms inside the new
       !   unit cell and, finally, print atoms coordinates
       !
       nat=0
       do mm=1,pl%np
          do ia=mini(1),maxi(1)
             xx(1)=pl%x(1,mm)+real(ia)
             do ib=mini(2),maxi(2)
                xx(2)=pl%x(2,mm)+real(ib)
                do_ic: do ic=mini(3),maxi(3)
                   xx(3)=pl%x(3,mm)+real(ic)
                   xxn=matmul(xx-ox,si)
                   xxn=Modulo_Lat(xxn)
                   do i=nat,1,-1
                      v=npl%x(:,i)-xxn(:)
                      if (Lattice_trans(v,"P") ) cycle do_ic
                   end do
                   nat=nat+1
                   npl%x(:,nat)= xxn
                   if ( nat < 10) then
                      write(unit=npl%nam(nat),fmt="(a,i1)") trim(pl%nam(mm))//"_",nat
                   else if( nat < 100) then
                      write(unit=npl%nam(nat),fmt="(a,i2)") trim(pl%nam(mm))//"_",nat
                   else
                      write(unit=npl%nam(nat),fmt="(a,i3)") trim(pl%nam(mm))//"_",nat
                   end if
                end do do_ic
             end do
          end do
       end do
       npl%np=nat

       return
    End Subroutine Get_Transf_List

    !!----
    !!---- Subroutine Init_Err_Geom()
    !!----
    !!----    Initialize the errors flags in CFML_Geometry_Calc
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Init_Err_Geom()

       err_geom=.false.
       ERR_Geom_Mess=" "

       return
    End Subroutine Init_Err_Geom

    !!----
    !!---- Subroutine P1_Dist(Dmax, Cell, Spg, Ac, Lun)
    !!----    real(kind=cp),            intent(in)    :: dmax      !  In -> Max. Distance to be calculated
    !!----    type (Crystal_cell_Type), intent(in)    :: Cell      !  In -> Object of Crystal_cell_Type
    !!----    type (Space_Group_Type),  intent(in)    :: SpG       !  In -> Object of Space_Group_Type
    !!----    type (Atoms_Cell_Type),   intent(in out):: Ac        !  In -> Object of Atoms_Cell_Type
    !!----                                                           Out -> Updated Object of Atoms_Cell_Type
    !!----    integer,optional,         intent(in)    :: lun       !  In -> Logical Unit for writing
    !!----
    !!----    Subroutine calculate distances, below the prescribed distances "dmax",
    !!----    without standard deviations. No symmetry is applied: only lattice translations.
    !!----    Need as input the objects "Cell" (of type Crystal_cell_type), "SpG" (of type Space_Group_Type)
    !!----    and "Ac" (or type Atoms_Cell). Complete the construction of Ac.
    !!----    Control for error is present.
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine P1_Dist(Dmax, Cell, Spg, Ac, Lun)
       !---- Arguments ----!
       real(kind=cp),            intent(in)       :: dmax
       type (Crystal_cell_Type), intent(in)       :: Cell
       type (Space_Group_Type),  intent(in)       :: SpG
       type (Atoms_Cell_Type),   intent(in out)   :: Ac
       integer, optional,        intent(in)       :: lun

       !---- Local Variables ----!
       logical                                :: iprint
       character(len=6 )                      :: nam,nam1
       character(len=40)                      :: transla
       character(len=90)                      :: form1,form2="(a,2i4,a,a,a,a,a,f10.4,a,t62,3F8.4)"
       integer                                :: i,k,lk,i1,i2,i3,jl,nn,L,inew,ne,id
       integer, dimension(3)                  :: ic1,ic2
       integer, dimension(Ac%nat,Ac%nat)      :: mn  !neighbouring matrix
       real(kind=cp)                          :: T,dd
       real(kind=cp), dimension(3)            :: xx,x1,xo,Tn,xr, QD
       real(kind=cp), dimension(3,Ac%nat*Ac%nat*spg%multip) :: u

       iprint=.false.
       if (present(lun)) then
          if (lun > 0) iprint=.true.
       end if
       call init_err_geom()
       id=3*nint(0.74048*(dmax/1.1)**3)

       qd(:)=1.0/cell%rcell(:)
       ic2(:)= nint(dmax/cell%cell(:)+3.0)
       ic1(:)=-ic2(:)
       mn(:,:) = 0
       inew=0
       do i=1,ac%nat
          xo(:)=Ac%xyz(:,i)
          nam= Ac%noms(i)
          if (iprint) then
             write(unit=lun,fmt="(/,/,a)")"    -------------------------------------------------------------------"
             write(unit=lun,fmt="(a,f8.4,a,a,3f8.4)")   &
                       "    Distances less than",dmax,"  to atom: ",nam, xo(:)
             write(unit=lun,fmt="(a,/,/)")"    -------------------------------------------------------------------"
             write(unit=lun,fmt="(/,/,a,/,/)") &
                       " Orig. extr.                    Distance     tx   ty   tz       x_ext   y_ext   z_ext"
          end if
          ne=0
          do k=1,Ac%nat
             lk=1
             u(:,lk)=xo(:)
             xx(:)=Ac%xyz(:,k)
             nam1= Ac%noms(k)
             do i1=ic1(1),ic2(1)
                do i2=ic1(2),ic2(2)
                   do i3=ic1(3),ic2(3)
                      do_jl:do jl=1,Spg%NumLat
                         Tn(:)=(/real(i1),real(i2),real(i3)/)+Spg%Latt_trans(:,jl)
                         x1(:)=xx(:)+tn(:)
                         do l=1,3
                            t=abs(x1(l)-xo(l))*qd(l)
                            if (t > dmax) cycle do_jl
                         end do
                         do nn=1,lk
                            if (sum(abs(u(:,nn)-x1(:)))  <= epsi) cycle do_jl
                         end do
                         xr = matmul(cell%cr_orth_cel,x1-xo)
                         dd=sqrt(dot_product(xr,xr))
                         if (dd > dmax .or. dd < 0.001) cycle
                         lk=lk+1
                         u(:,lk)=x1(:)
                         call Frac_Trans_1Dig(tn,transla)
                         if (iprint) write(unit=lun,fmt=form2)" ",i,k,"   (",nam,")-(",nam1,"):",dd,"  "//transla,x1(:)
                         mn(i,k)=mn(i,k)+1
                         ne=ne+1
                         IF (ne > id) THEN
                            err_geom=.true.
                            ERR_Geom_Mess="Too many connected atoms! in sub. P1_dist"
                            return
                         END IF
                         Ac%neighb_atom(ne,i)=k    !Pointer to the number of atom connected to i
                         Ac%distance   (ne,i)=dd   !Corresponding distance
                         Ac%trans(:,ne,i)=tn(:)    !corresponding lattice translation
                         do nn=1,inew
                            if (abs(dd-Ac%ddist(nn)) <= epsi) then
                               if (equiv_atm(nam,nam1,Ac%ddlab(nn)))  cycle do_jl
                            end if
                         end do
                         inew=inew+1
                         Ac%ddist(inew)=dd
                         Ac%ddlab(inew)=wrt_lab(nam,nam1)
                      end do do_jl
                   end do !i3
                end do !i2
             end do !i1
          end do !k
          Ac%neighb(i)=ne
       end do !i
       Ac%ndist=inew
       if (iprint) then
          write(unit=lun,fmt="(/,/,a)") " -------------------"
          write(unit=lun,fmt="(a)"  )   " Neighbouring matrix"
          write(unit=lun,fmt="(a)")     " -------------------"
          write(unit=lun,fmt="(a)")
          write(unit=form1,fmt="(a,i4,a)") "(a,",Ac%nat,"i3)"
          write(unit=lun,fmt=form1)"     ",(i,i=1,Ac%nat)
          write(unit=lun,fmt="(a)")
          write(unit=form1,fmt="(a,i4,a)") "(i3,a,",Ac%nat,"i3)"
          do i=1,ac%nat
             write(unit=lun,fmt=form1) i,"  ",(mn(i,k),k=1,Ac%nat)
          end do
          write(unit=lun,fmt="(a,/,/,/)")
       end if

       return
    End Subroutine P1_Dist

    !!----
    !!---- Subroutine Print_Distances(Lun, Dmax, Cell, Spg, A)
    !!----    integer,                  intent(in)   :: lun    !  In -> Logical Unit for writing
    !!----    real(kind=cp),            intent(in)   :: dmax   !  In -> Max. Distance to be calculated
    !!----    type (Crystal_cell_Type), intent(in)   :: Cell   !  In -> Object of Crystal_cell_Type
    !!----    type (Space_Group_Type),  intent(in)   :: SpG    !  In -> Object of Space_Group_Type
    !!----    type (atom_list_type),   intent(in)   :: A      !  In -> Object of atom_list_type
    !!----
    !!----    Subroutine to print distances, below the prescribed distances
    !!----    "dmax", without standard deviations.
    !!----    Need as input the objects "Cell" (of type Crystal_cell_type), "SpG"
    !!----    (of type Space_Group_type) and "A" (or type atom_list_type, that should be
    !!----    allocated in the calling program).
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Print_Distances(Lun, Dmax, Cell, Spg, A)
       !-- Arguments --!
       integer,                  intent(in)   :: lun
       real(kind=cp),            intent(in)   :: dmax
       type (Crystal_cell_Type), intent(in)   :: Cell
       type (Space_Group_Type),  intent(in)   :: SpG
       type (atom_list_type),    intent(in)   :: A

       !---- Local Variables ----!
       integer                           :: i,j,k,lk,i1,i2,i3,jl,npeq,nn,L,nlines
       character(len=80), dimension(12)  :: texto=" "
       character(len=5 )                 :: nam,nam1
       character(len=40)                 :: transla
       character(len=54)                 :: form2="(a,3i4,a,a,a,a,a,f10.4,a,t66,3F8.4)" !&
                                            !"("" "",3I4,""  ("",a,"")-("",a,""):"",f9.4,""   "",a,""  "",3F8.4)"
       integer,          dimension(3)    :: ic1,ic2
       real(kind=cp),    dimension(3)    :: xx,x1,xo,Tn,xr, QD
       real(kind=cp)                     :: T,dd
       real(kind=cp), dimension(3,A%Natoms*Spg%multip) :: uu

       qd(:)=1.0/cell%rcell(:)
       ic2(:)= nint(dmax/cell%cell(:)+1.0)
       ic1(:)=-ic2(:)
       npeq=spg%numops

       if (Spg%Centred == 2) then
          npeq=2*npeq
          write(unit=lun,fmt="(a)")" => Symmetry operators combined with inversion centre:"
          nlines=1
          do i=SpG%NumOps+1,npeq
             if (mod(i,2) == 0) then
                write(unit=texto(nlines)(36:70),fmt="(a,i2,a,a)") &
                                           " => SYMM(",i,"): ",trim(SpG%SymopSymb(i))
                nlines=nlines+1
             else
                write(unit=texto(nlines)( 1:34),fmt="(a,i2,a,a)")  &
                                           " => SYMM(",i,"): ",trim(SpG%SymopSymb(i))
             end if
          end do
          do i=1,min(nlines,12)
             write(unit=lun,fmt="(a)") texto(i)
          end do
       end if

       do i=1,A%natoms
          nam=a%atom(i)%lab
          xo(:)=a%atom(i)%x(:)
          write(unit=lun,fmt="(/,/,a)")"    -------------------------------------------------------------------"
          write(unit=lun,fmt="(a,f8.4,a,a,3f8.4)")   &
                    "    Distances less than",dmax,"  to atom: ",nam, xo(:)
          write(unit=lun,fmt="(a,/,/)")"    -------------------------------------------------------------------"
          write(unit=lun,fmt="(/,/,a,/,/)") &
                    " Orig. extr. p.equiv.           Distance     tx   ty   tz       x_ext   y_ext   z_ext"
          do k=1,a%natoms
             lk=1
             uu(:,lk)=xo(:)
             nam1=a%atom(k)%lab
             do j=1,npeq
                xx=ApplySO(Spg%SymOp(j),a%atom(k)%x)
                do i1=ic1(1),ic2(1)
                   do i2=ic1(2),ic2(2)
                      do i3=ic1(3),ic2(3)
                         do_jl:do jl=1,Spg%NumLat
                            Tn(:)=real((/i1,i2,i3/))+Spg%Latt_trans(:,jl)
                            x1(:)=xx(:)+tn(:)
                            do l=1,3
                               t=abs(x1(l)-xo(l))*qd(l)
                               if (t > dmax) cycle do_jl
                            end do
                            do nn=1,lk
                               if (sum(abs(uu(:,nn)-x1(:)))  <= epsi) cycle do_jl
                            end do
                            xr = matmul(cell%cr_orth_cel,x1-xo)
                            dd=sqrt(dot_product(xr,xr))
                            if (dd > dmax .or. dd < 0.001) cycle
                            lk=lk+1
                            uu(:,lk)=x1(:)
                            call Frac_Trans_1Dig(tn,transla)
                            write(unit=lun,fmt=form2)" ",i,k,j,"   (",nam,")-(",nam1,"):",dd,"  "//transla,x1(:)
                            !write(unit=lun,fmt=form2)i,k,j,nam ,nam1,dd,transla,x1(:)
                                        !    "("" "",3I4,""  ("",a,"")-("",a,""):"",f9.4,""   "",a,""  "",3F8.4)"
                         end do do_jl
                      end do !i3
                   end do !i2
                end do !i1
             end do !j
          end do !k
       end do !i

       return
    End Subroutine Print_Distances

    !!---- Subroutine Set_New_AsymUnit(SpGn,Ate,Mat,orig,A_n,matkind,debug)
    !!----    type (Space_Group_Type) ,      intent(in    ) :: SpGn    !New space group that has been previously set
    !!----    type (Atom_Equiv_List_Type),   intent(in    ) :: Ate     !In old group
    !!----    real(kind=cp), dimension (3,3),intent(in    ) :: Mat     !Transformation matrix from the old to the new setting
    !!----    real(kind=cp), dimension (  3),intent(in    ) :: orig    !Displacement of the origin in the old setting
    !!----    type (Atom_list_Type),         intent(in out) :: A_n     !New atom list
    !!----    character (len=*), optional,   intent(in    ) :: matkind !Kind of transformation matrix
    !!----    character (len=*), optional,   intent(in    ) :: debug
    !!----
    !!----    Updated: January 2014 (JRC)
    !!----
    !!----
    Subroutine Set_New_AsymUnit(SpGn,Ate,Mat,orig,A_n,matkind,debug)
       type (Space_Group_Type) ,      intent(in    ) :: SpGn
       type (Atom_Equiv_List_Type),   intent(in    ) :: Ate !In old group
       real(kind=cp), dimension (3,3),intent(in    ) :: Mat
       real(kind=cp), dimension (  3),intent(in    ) :: orig
       type (Atom_list_Type),         intent(out   ) :: A_n
       character (len=*), optional,   intent(in    ) :: matkind
       character (len=*), optional,   intent(in    ) :: debug
       ! Local variables
       integer                           :: i,j,k,m,ifail,L,n,Ls,ip,L1
       integer                           :: i1,i2,i3,maxa,maxp,maxm,mult
       real(kind=cp), dimension (3,3)    :: S,Sinv
       real(kind=cp)                     :: determ
       logical                           :: newp,fail
       real(kind=cp), dimension (  3)    :: pos
       real(kind=cp), dimension (3,192)  :: orb
       type(point_list_type)             :: pl
       type (Atom_list_Type)             :: A
       character(len=*),parameter,dimension(26) :: let=(/"a","b","c","d","e","f","g","h", &
          "i","j","k","l","m","n","o","p","q","r","s","t","u","v","w","x","y","z"/)
       real(kind=cp), allocatable, dimension (:,:) :: vec
       integer,parameter         :: lu=93
       real(kind=cp), parameter  :: epsi = 0.002

       if(present(matkind)) then
        if(matkind(1:2) == "it" .or. matkind(1:2) == "IT" ) then
          S=Mat             !Atoms positions X'=inv(Mat) (X-O)
        else
          S=transpose(Mat)  !Atoms positions X'=inv(MatT)(X-O)
        end if
       else
          S=transpose(Mat)
       end if
       call matrix_inverse(S,Sinv,ifail) !Atoms positions X'= Sinv X
       if (ifail /= 0) then
         err_geom=.true.
         err_geom_Mess= "Inversion Matrix Failed on: Change_Setting_SG"
         return
       end if
       if(present(debug)) then
         open(unit=lu,file="similar_debug.lis",status="replace",action="write")
         write(unit=lu,fmt="(a)")  "  Debugging SIMILAR calculations  "
         write(unit=lu,fmt="(a/)") "  ============================== "
       end if

       determ=determ_a(S)
       determ=abs(determ)

       m=0
       if(determ > 1.0001) then  !Generate indices for lattice translations to be applied
         i1=max(nint(maxval(abs(S(:,1))))-1,1)
         i2=max(nint(maxval(abs(S(:,2))))-1,1)
         i3=max(nint(maxval(abs(S(:,3))))-1,1)
         allocate(vec(3,(i1+1)*(i2+1)*(i3+1)))
         do i=0,i1
          do j=0,i2
           do k=0,i3
            if(i==0 .and.j==0 .and. k==0) cycle
            m=m+1
            vec(:,m) = real((/i,j,k/))
            !write(*,*) "  vect: ",m," :",vec(:,m)
           end do
          end do
         end do
       end if

       maxm=m    !maximum number of translations to be applied before changing the basis
       maxa=maxval(Ate%Atm(:)%mult)  !highest multiplicity of the atom sequence list
       !Factor 2
       maxp=2*maxa*determ    !maximum multiplicity in the new cell of a particular atom type
       !write(*,*) " Allocating atoms_list and Point list for ", maxp*Ate%nauas, " and ", maxp, " values"
       call Allocate_Atom_List(maxp*Ate%nauas,A)  !Atom list in the new cell, we must use "maxp"*Ate%nauas and not "maxa"
       Call Allocate_Point_List(maxp*Ate%nauas,Pl,Ifail)
       if(ifail /= 0) then
         !write(*,*) " Error allocating PL for ",maxp," values"
          err_geom=.true.
          write(unit=err_geom_Mess,fmt="(a,i8,a)")  " Error allocating PL for ",maxp," values"
          return
       end if
       Ls=0

       !write(*,*) " Allocating PL and A successful "

       do i=1,Ate%nauas
         Ls=Ls+1
         !Setting pl object
           ip=index(Ate%Atm(i)%Lab(1),"_")
           if(ip /= 0) then
              pl%nam(i)=Ate%Atm(i)%Lab(1)(1:ip-1)
           else
              pl%nam(i)=Ate%Atm(i)%Lab(1)
           end if
           pl%x=0.0
           pl%p=0.0
         !
         n=0
         do j=1,Ate%Atm(i)%mult
           n=n+1
           pos(:)    = Ate%Atm(i)%x(:,j)-orig(:)
           !write(*,*) " n=",n
           pl%x(:,n) = matmul(Sinv,pos)  !Complete list in new coordinate system of atoms of type i
           if(present(debug)) then
             write(unit=lu,fmt="(i4,2(a,3f8.4),a)") n,"  Atom: "//pl%nam(i)//" at (", &
                                         Ate%Atm(i)%x(:,j),") trasform to (",pl%x(:,n),")"
           end if
           pl%x(:,n) = Modulo_Lat(pl%x(:,n))  !Complete list in new coordinate system of atoms of type i
         end do
         if(determ > 1.0) then
          doj:do j=1,Ate%Atm(i)%mult
               do m=1,maxm
                 pos(:) = Ate%Atm(i)%x(:,j)-orig(:)+ vec(:,m)
                 pos(:) = Modulo_Lat(matmul(Sinv,pos))
                 newp=.true.
                 do k=1,n
                    if (sum(abs(pos(:)-pl%x(:,k))) < epsi) then
                       newp=.false.
                       exit
                    end if
                 end do
                 if (newp) then ! new position
                    n=n+1
                    !write(*,*) "  n=",n
                    pl%x(:,n) = pos(:)
                    if(present(debug)) then
                      write(unit=lu,fmt="(i4,2(a,3f8.4),a)") n,"  Atom: "//pl%nam(i)//" at (", &
                                                  Ate%Atm(i)%x(:,j),") trasform to (",pl%x(:,n),")"
                    end if
                    if(n == maxp) exit doj
                 end if
               end do
             end do doj
         end if

         pl%np=n
         A%atom(Ls)%Lab =pl%nam(i)
         A%atom(Ls)%x(:)=pl%x(:,1)
         !write(*,"(2i5,a,i5,a)") i,Ls, "  "//Ate%Atm(i)%Lab(1), Ate%Atm(i)%mult,"   "//A%atom(Ls)%Lab

         !Determine the number of independent orbits for this point
         call Set_Orbits_Inlist(Spgn,pl)
         L=1; L1=1
         do j=2,n
           if(pl%p(j) > L) then
            Ls=Ls+1
            A%atom(Ls)%x(:)=pl%x(:,j)
            !write(unit=let,fmt="(i3.3)") L
            A%atom(Ls)%Lab =trim(pl%nam(i))//let(L1)
           ! write(*,"(2i5,a,i5,a)") i,Ls, "  "//Ate%Atm(i)%Lab(1), Ate%Atm(i)%mult,"   "//A%atom(Ls)%Lab
            L=L+1
            L1=L1+1  !using a different counter for the label
            if(L1 > 26) L1=1 !re-start the labelling with the same letter
           end if
         end do

       end do  !i=1,Ate%nauas

       !write(*,*) "  Orbits correct"
       !write(*,*) "  Allocate_Atom_List for ",Ls," atoms"
       call Allocate_Atom_List(Ls,A_n,fail)
       if(fail) then
         if(present(debug)) then
          !write(*,*) "  Error on Allocate_Atom_List for ",A_n%natoms," atoms"
          write(unit=lu,fmt="(a,i4,a)") "  Error on Allocate_Atom_List for ",A_n%natoms," atoms"
         end if
       else
         ! write(*,*) "  Success on Allocate_Atom_List for ",A_n%natoms," atoms"
       end if
       do i=1,A_n%natoms
         A_n%atom(i)%x= A%atom(i)%x
         A_n%atom(i)%Lab= A%atom(i)%Lab
         call Get_Orbit(A_n%atom(i)%x,Spgn,Mult,orb)
         A_n%atom(i)%Mult=mult
         A_n%atom(i)%occ=real(mult)/real(Spgn%Multip)
       end do
       if(allocated(A%atom)) deallocate(A%atom)
       if(present(debug)) close(unit=lu)
       return
    End Subroutine Set_New_AsymUnit


    !!----
    !!---- Subroutine Set_Orbits_Inlist(Spg,Pl)
    !!----    type(space_group_type), intent(in)     :: SpG     !  In -> Space group
    !!----    type(point_list_type),  intent(in out) :: pl      !  In -> list of points
    !!----
    !!----    Set up of the integer pointer "pl%p" in the object "pl" of type point_list_type.
    !!----    Each point is associated with the number of an orbit. This pointer is useful
    !!----    to get the asymmetric unit with respect to the input space group of an arbitrary
    !!----    list of points (atom coordinates).
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Set_Orbits_Inlist(Spg,Pl)
       !---- Arguments ----!
       type(space_group_type), intent(in)     :: SpG
       type(point_list_type),  intent(in out) :: pl

       !--- Local variables ---!
       integer                     :: i,j,norb,nt
       real(kind=cp), dimension(3) :: x,xx,v

       norb=0
       pl%p=0
       do i=1,pl%np
          if (pl%p(i) == 0) then
             norb=norb+1
             pl%p(i)=norb
             x=pl%x(:,i)
             do j=1,Spg%multip
                xx=ApplySO(Spg%SymOp(j),x)
                xx=modulo_lat(xx)
                do nt=1,pl%np
                   if (pl%p(nt) /= 0) cycle
                   v=pl%x(:,nt)-xx(:)
                   if (Lattice_trans(v,Spg%spg_lat)) pl%p(nt)=norb
                end do
             end do
          end if
       end do

       return
    End Subroutine Set_Orbits_Inlist

    !!---- Subroutine Set_Rotation_Matrix(ang,Rot)
    !!----   real(kind=cp), dimension(3),   intent( in) :: ang
    !!----   real(kind=cp), dimension(3,3), intent(out) :: Rot
    !!----
    !!----  Subroutine calculating the rotation matrix Rot corresponding to
    !!----  the application (active rotations) of the following succesive rotations:
    !!----
    !!----  Rot = Rx(ang(3)) . Ry(ang(2)) . Rz(ang(1))
    !!----
    !!----    Created: October 2009  (JRC)
    !!----    Updated: March 2013 (JRC)
    !!----

    Subroutine Set_Rotation_Matrix(ang,Rot)
      real(kind=cp), dimension(3),   intent( in) :: ang
      real(kind=cp), dimension(3,3), intent(out) :: Rot
      !Local variables
      real(kind=cp), dimension(3,3) :: Rx,Ry,Rz
      Rx=Matrix_Rx(ang(1),"D")
      Ry=Matrix_Ry(ang(2),"D")
      Rz=Matrix_Rz(ang(3),"D")
      Rot=Matmul(Rx,matmul(Ry,Rz))
      return
    End Subroutine Set_Rotation_Matrix

    !!----
    !!---- Subroutine Set_TDist_Coordination(Max_coor,Dmax, Cell, Spg, A)
    !!----    integer,                  intent(in)   :: max_coor !  Maximum expected coordination
    !!----    real(kind=cp),            intent(in)   :: dmax     !  In -> Max. Distance to calculate
    !!----    real(kind=cp),            intent(in)   :: dangl    !  In -> Max. distance for angle calculations
    !!----    type (Crystal_cell_type), intent(in)   :: Cell     !  In -> Object of Crytal_Cell_Type
    !!----    type (Space_Group_type),  intent(in)   :: SpG      !  In -> Object of Space_Group_Type
    !!----    type (atom_list_type),   intent(in)    :: A        !  In -> Object of atom_list_type
    !!----
    !!----    Subroutine to calculate distances, below the prescribed distance "dmax"
    !!----    Sets up the coordination type: Coord_Info for each atom in the asymmetric unit
    !!----    Needs as input the objects Cell (of type Crystal_cell), SpG (of type Space_Group)
    !!----    and A (of type atom_list, that should be allocated in the calling program).
    !!----    The input argument Max_Coor is obtained, before calling the present procedure,
    !!----    by a call to Allocate_Coordination_Type with arguments:(A%natoms,Spg%Multip,Dmax,max_coor)
    !!----    Further calls to this routine do not need a previous call to Allocate_Coordination_Type.
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Set_TDist_Coordination(max_coor,Dmax, Cell, Spg, A)
       !---- Arguments ----!
       integer,                  intent(in)   :: max_coor
       real(kind=cp),            intent(in)   :: dmax
       type (Crystal_cell_Type), intent(in)   :: Cell
       type (Space_Group_Type),  intent(in)   :: SpG
       type (atom_list_type),    intent(in)   :: A

       !---- Local Variables ----!
       integer                              :: i,j,k,lk,i1,i2,i3,nn,L,ico
       integer,       dimension(3)          :: ic1,ic2
       real(kind=cp), dimension(3)          :: xx,x1,xo,Tn,xr, QD
       real(kind=cp)                        :: T,dd
       real(kind=cp), dimension(3,max_coor) :: uu

      ! call init_err_geom()  !Control of error

       qd(:)=1.0/cell%rcell(:)
       !ic2(:)= nint(dmax/cell%cell(:)+1.5)
       ic2(:)= int(dmax/cell%cell(:))+1
       ic1(:)=-ic2(:)
       do i=1,a%natoms
          xo(:)=a%atom(i)%x(:)

          ico=0
          do k=1,a%natoms
             lk=1
             uu(:,lk)=xo(:)
             do j=1,Spg%Multip
                xx=ApplySO(Spg%SymOp(j),a%atom(k)%x)
                do i1=ic1(1),ic2(1)
                   do i2=ic1(2),ic2(2)
                      do_i3:do i3=ic1(3),ic2(3)
                            Tn(1)=real(i1); Tn(2)=real(i2); Tn(3)=real(i3)
                            x1(:)=xx(:)+tn(:)
                            do l=1,3
                               t=abs(x1(l)-xo(l))*qd(l)
                               if (t > dmax) cycle  do_i3
                            end do
                            do nn=1,lk
                               if (sum(abs(uu(:,nn)-x1(:)))  <= epsi) cycle  do_i3
                            end do
                            xr = matmul(cell%cr_orth_cel,x1-xo)
                            dd=sqrt(dot_product(xr,xr))
                            if (dd > dmax .or. dd < 0.001) cycle
                            ico=ico+1
                           ! Control not performed ... it is supposed that max_coor is large enough
                           !if (Coord_Info%Coord_Num(i) > Coord_Info%Max_Coor) then
                           !   err_geom=.true.
                           !   ERR_Geom_Mess=" => Too many distances around an atom"
                           !   return
                           !end if
                            lk=lk+1
                            uu(:,lk)=x1(:)
                            Coord_Info%Dist(ico,i)=dd
                            Coord_Info%N_Cooatm(ico,i)=k
                            Coord_Info%N_sym(ico,i)=j

                            ! Added by JGP
                            Coord_Info%Tr_Coo(:,ico,i)=tn
                      end do do_i3 !i3
                   end do !i2
                end do !i1
             end do !j
          end do !k
          Coord_Info%Coord_Num(i)=ico
       end do !i

       return
    End Subroutine Set_TDist_Coordination

    !!----
    !!---- Subroutine Set_TDist_Partial_Coordination(List,Max_coor,Dmax, Cell, Spg, A)
    !!----    integer,                  intent(in)   :: List     !  Modified atom
    !!----    integer,                  intent(in)   :: max_coor !  Maximum expected coordination
    !!----    real(kind=cp),            intent(in)   :: dmax     !  In -> Max. Distance to calculate
    !!----    real(kind=cp),            intent(in)   :: dangl    !  In -> Max. distance for angle calculations
    !!----    type (Crystal_cell_type), intent(in)   :: Cell     !  In -> Object of Crytal_Cell_Type
    !!----    type (Space_Group_type),  intent(in)   :: SpG      !  In -> Object of Space_Group_Type
    !!----    type (atom_list_type),   intent(in)    :: A        !  In -> Object of atom_list_type
    !!----
    !!----    Modify the coordination type: Coord_Info for the atoms affected by the change of atom "List"
    !!----    Needs as input the objects Cell (of type Crystal_cell), SpG (of type Space_Group)
    !!----    and A (or type atom_list, that should be allocated in the calling program).
    !!----    This routine is a modification of Set_TDist_Coordination to avoid superfluous calculations
    !!----    in global optimization methods. It assumes that Set_TDist_Coordination has previously been
    !!----    called and the object "Coord_Info" has already been set.
    !!----
    !!---- Update: May - 2009
    !!
    Subroutine Set_TDist_Partial_Coordination(List,max_coor,Dmax, Cell, Spg, A)
       !---- Arguments ----!
       integer,                  intent(in)   :: List
       integer,                  intent(in)   :: max_coor
       real(kind=cp),            intent(in)   :: dmax
       type (Crystal_cell_Type), intent(in)   :: Cell
       type (Space_Group_Type),  intent(in)   :: SpG
       type (atom_list_type),    intent(in)   :: A

       !---- Local Variables ----!
       integer                              :: i,j,k,lk,i1,i2,i3,nn,L,ic,ico
       integer,       dimension(3)          :: ic1,ic2
       integer,       dimension(A%natoms)   :: po,pn
       real(kind=cp), dimension(3)          :: xx,x1,xo,Tn,xr, QD
       real(kind=cp)                        :: T,dd
       real(kind=cp), dimension(3,max_coor) :: uu

      ! call init_err_geom()  !Control of error

       po=0; pn=0
       po(List)=1 !This atom has a modified coordination sphere
       ic=Coord_Info%Coord_Num(List)
       do i=1,ic
         po(Coord_Info%N_Cooatm(i,List))=1  !This atom has a modified coordination sphere
       end do

       qd(:)=1.0/cell%rcell(:)
       ic2(:)= int(dmax/cell%cell(:))+1
       ic1(:)=-ic2(:)
       !Determine the new coordination sphere of the changed atom
       i=List
       xo(:)=a%atom(i)%x(:)

       ico=0
       do k=1,a%natoms
          lk=1
          uu(:,lk)=xo(:)
          do j=1,Spg%Multip
             xx=ApplySO(Spg%SymOp(j),a%atom(k)%x)
             do i1=ic1(1),ic2(1)
                do i2=ic1(2),ic2(2)
                   do_i3:do i3=ic1(3),ic2(3)
                         Tn(:)=real((/i1,i2,i3/))
                         x1(:)=xx(:)+tn(:)
                         do l=1,3
                            t=abs(x1(l)-xo(l))*qd(l)
                            if (t > dmax) cycle  do_i3
                         end do
                         do nn=1,lk
                            if (sum(abs(uu(:,nn)-x1(:)))  <= epsi) cycle  do_i3
                         end do
                         xr = matmul(cell%cr_orth_cel,x1-xo)
                         dd=sqrt(dot_product(xr,xr))
                         if (dd > dmax .or. dd < 0.001) cycle
                         ico=ico+1
                         lk=lk+1
                         uu(:,lk)=x1(:)
                         Coord_Info%Dist(ico,i)=dd
                         Coord_Info%N_Cooatm(ico,i)=k
                         Coord_Info%N_sym(ico,i)=j
                   end do do_i3 !i3
                end do !i2
             end do !i1
          end do !j
       end do !k
       Coord_Info%Coord_Num(i)=ico
       pn(list)=0
       po(list)=0

       ic=Coord_Info%Coord_Num(List)    !New coordination number of atom List
       do i=1,ic
         pn(Coord_Info%N_Cooatm(i,List))=1  !This atom has now a newly modified coordination sphere
       end do
       !Look now the changed coordinaion spheres
       do i=1,a%natoms
         if(pn(i) == 0 .and. po(i) == 0) cycle
         !if(po(i) == 1 .and. pn(i) == 1) then !the atom remains in the coordination sphere, only recalculation of distance is needed
         !  ic=Coord_Info%Coord_Num(i)
         !  do k=1,ic
         !   if(List == Coord_Info%N_Cooatm(k,i)) then
         !   end if
         !  end do
         !end if
         !DO ALL WAITING FOR A MORE EFFICIENT ALGORITHM
         xo(:)=a%atom(i)%x(:)

         ico=0
         do k=1,a%natoms
            lk=1
            uu(:,lk)=xo(:)
            do j=1,Spg%Multip
               xx=ApplySO(Spg%SymOp(j),a%atom(k)%x)
               do i1=ic1(1),ic2(1)
                  do i2=ic1(2),ic2(2)
                     do_inter:do i3=ic1(3),ic2(3)
                           Tn(:)=real((/i1,i2,i3/))
                           x1(:)=xx(:)+tn(:)
                           do l=1,3
                              t=abs(x1(l)-xo(l))*qd(l)
                              if (t > dmax) cycle  do_inter
                           end do
                           do nn=1,lk
                              if (sum(abs(uu(:,nn)-x1(:)))  <= epsi) cycle  do_inter
                           end do
                           xr = matmul(cell%cr_orth_cel,x1-xo)
                           dd=sqrt(dot_product(xr,xr))
                           if (dd > dmax .or. dd < 0.001) cycle
                           ico=ico+1
                           lk=lk+1
                           uu(:,lk)=x1(:)
                           Coord_Info%Dist(ico,i)=dd
                           Coord_Info%N_Cooatm(ico,i)=k
                           Coord_Info%N_sym(ico,i)=j
                     end do do_inter !i3
                  end do !i2
               end do !i1
            end do !j
         end do !k
         Coord_Info%Coord_Num(i)=ico
       end do !i

       return
    End Subroutine Set_TDist_Partial_Coordination

 End Module CFML_Geometry_Calc
!!-------------------------------------------------------
!!---- Crystallographic Fortran Modules Library (CrysFML)
!!-------------------------------------------------------
!!---- The CrysFML project is distributed under LGPL. In agreement with the
!!---- Intergovernmental Convention of the ILL, this software cannot be used
!!---- in military applications.
!!----
!!---- Copyright (C) 1999-2012  Institut Laue-Langevin (ILL), Grenoble, FRANCE
!!----                          Universidad de La Laguna (ULL), Tenerife, SPAIN
!!----                          Laboratoire Leon Brillouin(LLB), Saclay, FRANCE
!!----
!!---- Authors: Juan Rodriguez-Carvajal (ILL)
!!----          Javier Gonzalez-Platas  (ULL)
!!----
!!---- Contributors: Laurent Chapon     (ILL)
!!----               Marc Janoschek     (Los Alamos National Laboratory, USA)
!!----               Oksana Zaharko     (Paul Scherrer Institute, Switzerland)
!!----               Tierry Roisnel     (CDIFX,Rennes France)
!!----               Eric Pellegrini    (ILL)
!!----
!!---- This library is free software; you can redistribute it and/or
!!---- modify it under the terms of the GNU Lesser General Public
!!---- License as published by the Free Software Foundation; either
!!---- version 3.0 of the License, or (at your option) any later version.
!!----
!!---- This library is distributed in the hope that it will be useful,
!!---- but WITHOUT ANY WARRANTY; without even the implied warranty of
!!---- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
!!---- Lesser General Public License for more details.
!!----
!!---- You should have received a copy of the GNU Lesser General Public
!!---- License along with this library; if not, see <http://www.gnu.org/licenses/>.
!!----
!!----
!!---- MODULE: CFML_Molecular_Crystals
!!----   INFO: Module to define molecules on Crystals
!!----
!!---- HISTORY
!!----    Update: 07/03/2011
!!----
!!---- COMMENTARY
!!--..    Explanations about Eulerian angles, active and passive rotations
!!--..    Ref. Texture Analysis in Material Science, H.J. Bunge.
!!--..    Ed Butterworths London 1970?
!!--..
!!--..
!!--..    First variant:
!!--..    -------------
!!--..    Eulerian angles g={phi1,PHI,phi2}, positive rotations: anti-clockwise
!!--..
!!--..     1: Rotation around the common Z,Zm axis of an angle phi1
!!--..     2: Rotation around the new Xm axis of an angle PHI
!!--..     3: Rotation around the new Zm-axis of an angle phi2
!!--..
!!--..          g = gZm(phi2) . gXm(PHI) . gZm(Zm)
!!--..
!!--..
!!--..                   (  cosphi2  sinphi2    0  )                     (   1      0       0      )
!!--..
!!--..       gZm(phi2) =(  -sinphi2  cosphi2    0   )        gXm(PHI)  =(    0    cosPHI  sinPHI    )
!!--..
!!--..                   (    0         0       1  )                     (   0   -sinPHI  cosPHI   )
!!--..
!!--..
!!--..
!!--..                   (  cosphi1  sinphi1    0  )
!!--..
!!--..       gZm(phi1) =(  -sinphi1  cosphi1    0   )
!!--..
!!--..                   (    0         0       1  )
!!--..
!!--..
!!--..
!!--..    Second variant:
!!--..    ---------------
!!--..     Eulerian angles g={PSI,THETA,PHI}, positive rotations: anti-clockwise
!!--..
!!--..     1: Rotation around the common Z,Zm axis of an angle PSI   (PHI)
!!--..     2: Rotation around the new Ym axis of an angle THETA      (THETA) <--- FullProf
!!--..     3: Rotation around the new Zm-axis of an angle PHI        (CHI)
!!--..
!!--..       phi1=PSI+pi/2   PHI = THETA   phi2=PHI - pi/2
!!--..
!!--..
!!--..
!!--..    Rotation Axis and Rotation Angle
!!--..    --------------------------------
!!--..
!!--..    The rotation axis is given by the unit vector u represented by its polar
!!--..    coordinates (theta,phi) and the rotation angle (omega) around u, so that
!!--..    one can write the rotation g={u,omega}={theta,phi,omega}
!!--..
!!--..    Passive rotations: one looks for the coordinates of a unique point respect
!!--..                       to two rotated frames
!!--..
!!--..                             ( cosphi  sinphi)
!!--..         -----\--------  M = (               )     is the matrix relating the basis (e)=M(i)
!!--..         |\    \             (-sinphi  cosphi)
!!--..         | \    \
!!--..         |  \    r        The point r  has coordinates (x,y) and coordinates (x',y')
!!--..         |   \ /          w.r.t. the rotated axes the relation is:
!!--..         |    \
!!--..         | phi \          (x')   ( cosphi  sinphi)  (x)     x'= x cosphi + y sinphi
!!--..                          (  ) = (               )  ( )  => y'=-x sinphi + y cosphi
!!--..                          (y')   (-sinphi  cosphi)  (y)
!!--..
!!--..     Active  rotations: one looks for the new coordinates of a point respect
!!--..                       to the same frame when a rotation is applied
!!--..
!!--..
!!--..                             ( cosphi -sinphi)
!!--..         --------------  R = (               )
!!--..         |\                  ( sinphi  cosphi)
!!--..         | \
!!--..         |  \   r'           x'= x cosphi - y sinphi
!!--..         | r \               y'= x sinphi + y cosphi
!!--..         |    \
!!--..         | phi \
!!--..
!!--..
!!--..      The representative matrices are one the inverse of the other. R=Minv=Mt
!!--..
!!--..      In molecular crystals one looks for determining the position of each atom of
!!--..      the molecule in the crystallographic frame when one knows the internal coordinates
!!--..      of the atoms, the position of the origin of the internal frame in the crystallographic
!!--..      frame and the orientation (Euler or Euler-like angles) of the internal frame with
!!--..      respect to the crystallographic frame.
!!--..
!!--..      The problem is to define a simple set of orientational angles
!!--..
!!--..      We shall adopt the conventional definition of Euler angles but we will call then
!!--..      a=phi1, b=PHI, c=phi2. The above matrices correspond to passive rotations, so that
!!--..      when applied to a fixed point their product will give the coordinates of this point
!!--..      with respect to the rotated system. In our case will give the position of an external
!!--..      point (cartesian crystal  frame, CCF) w.r.t the cartesian molecular frame (CMF).
!!--..      Taking the transpose of the final matrix one obtains an active rotation matrix that
!!--..      applied to a point moves it to a new point referred to the CCF.
!!--..
!!--..
!!--..
!!--..               ( cosa cosc - sina sinc cosb     sina cosc + cosa sinc cosb    sinc sinb )
!!--..
!!--..    g(a,b,c) =( -cosa sinc - sina cosc cosb    -sina sinc + cosa cosc cosb    cosc sinb  )
!!--..
!!--..               (         sina  sinb                   -cosa sinb                 cosb   )
!!--..
!!--..
!!--..               ( cosa cosc - sina sinc cosb    -cosa sinc - sina cosc cosb    sina sinb )
!!--..
!!--..   gt(a,b,c) =(  sina cosc + cosa sinc cosb    -sina sinc + cosa cosc cosb   -cosa sinb  )
!!--..
!!--..               (      sinc sinb                      cosc sinb                   cosb   )
!!--..
!!--..
!!--..
!!--..     The matrix g applied to a point with coordinates given w.r.t. CCF, provides the coordinates
!!--..     w.r.t. CMF. If we take a point in the CMF and we apply the matrix gt we obtain the coordinates
!!--..     of this point w.r.t. CCF.
!!--..
!!--..     Orientational angles used in FullProf
!!--..     -------------------------------------
!!--..
!!--..     The molecular frame (CMF) is supposed to coincide at the begining with the Cartesian
!!--..     crystallographic frame (CCF). To position a molecule in an arbitrary position the
!!--..     total movement is decomposed in the following way:
!!--..
!!--..     1) Perform a rotation of angle CHI around the Z,Zm-axis : the rotation matrix relating
!!--..        the two unitary bases (Em and E in form of columns) is the following:
!!--..
!!--..                       (cosCHI    sinCHI   0 )            (e1)           (i)
!!--..                                                          (  )           ( )
!!--..             Rz(CHI) =(-sinCHI    cosCHI   0  )        Em=(e2) = Rz(CHI) (j) = Rz(CHI) E
!!--..                                                          (  )           ( )
!!--..                       (  0         0      1 )            (e3)           (k)
!!--..
!!--..        An active rotation is obtained transposing Rz(CHI)t = Az(CHI). This matrix is
!!--..        applied to a point in CCF and provides the new coordinates in the CCF after
!!--..        the rotation of angle CHI around Z.
!!--..
!!--..
!!--..     2) Perform a rotation of angle THE around the Y-axis : the rotation matrix relating
!!--..        the two unitary bases (Em and E in form of columns) is now the following:
!!--..
!!--..                       (cosTHE   0   -sinTHE )            (e1)           (i)
!!--..                                                          (  )           ( )
!!--..             Ry(THE) =(   0      1      0     )        Em=(e2) = Ry(THE) (j) = Ry(THE) E
!!--..                                                          (  )           ( )
!!--..                       (sinTHE   0    cosTHE )            (e3)           (k)
!!--..
!!--..        An active rotation is obtained transposing Ry(THE)t = Ay(THE). This matrix is
!!--..        applied to a point in CCF and provides the new coordinates in the CCF after
!!--..        the rotation of angle THE around Y.
!!--..
!!--..     3) Perform a rotation of angle PHI around the Z-axis : the rotation matrix relating
!!--..        the two unitary bases (Em and E in form of columns) is the following:
!!--..
!!--..                       (cosPHI    sinPHI   0 )            (e1)           (i)
!!--..                                                          (  )           ( )
!!--..             Rz(PHI) =(-sinPHI    cosPHI   0  )        Em=(e2) = Rz(PHI) (j) = Rz(PHI) E
!!--..                                                          (  )           ( )
!!--..                       (  0         0      1 )            (e3)           (k)
!!--..
!!--..        An active rotation is obtained transposing Rz(PHI)t = Az(PHI). This matrix is
!!--..        applied to a point in CCF and provides the new coordinates in the CCF after
!!--..        the rotation of angle PHI around Z.
!!--..
!!--..    With this rotational angles the interpretation of the angles (THE,PHI) correspond to
!!--..    the spherical angles of the CMF Zm-axis with respect to the CCF. The total active
!!--..    matrix to be applied to atoms of the molecule in the initial position (when the two
!!--..    frames coincide) to get the final coordinates is the following:
!!--..
!!--..
!!--..                 M = Az(PHI) . Ay(THE) . Az(CHI) =  XA(PHI,THE)  . XAp(CHI)
!!--..
!!--..
!!--..     In the initial state the Cartesian coordinates of atoms (x), in columns, are
!!--..     the same in both frames, the positions after the total rotation are given by:
!!--..
!!--..                         (x)-final =   M (x)
!!--..
!!--..     To obtain the internal coordinates of a point in the CCF one must apply the
!!--..     following formula:
!!--..
!!--..                   X-internal  =  Mt  X = XAp(CHI)t . XA(PHI,THE)t  X
!!--..
!!--..     the final expressions of the different matrices are the following:
!!--..
!!--..
!!--..                    (cosPHI cosTHE      -sinPHI      cosPHI sinTHE )
!!--..
!!--..     XA(PHI,THE) = ( sinPHI cosTHE       cosPHI      sinPHI sinTHE  )
!!--..
!!--..                    (  -sinTHE             0             cosTHE    )
!!--..
!!--..
!!--..                   (cosCHI   -sinCHI   0 )
!!--..
!!--..        XAp(CHI) =( sinCHI    cosCHI   0  )
!!--..
!!--..                   (  0         0      1 )
!!--..
!!--..
!!--..               ( cosa cosc - sina sinc cosb     sina cosc + cosa sinc cosb    sinc sinb )
!!--..
!!--..    g(a,b,c) =( -cosa sinc - sina cosc cosb    -sina sinc + cosa cosc cosb    cosc sinb  )
!!--..
!!--..               (         sina  sinb                   -cosa sinb                 cosb   )
!!--..
!!--..
!!--..               ( cosa cosc - sina sinc cosb    -cosa sinc - sina cosc cosb    sina sinb )
!!--..
!!--..   gt(a,b,c) =(  sina cosc + cosa sinc cosb    -sina sinc + cosa cosc cosb   -cosa sinb  )
!!--..
!!--..               (      sinc sinb                      cosc sinb                   cosb   )
!!--..
!!--..
!!--..
!!--..
!!--..
!!--..
!!--..  M(PHI,THE,CHI) =
!!--..
!!--..     (cosPHI cosTHE cosCHI - sinPHI sinCHI   -cosPHI cosTHE sinCHI - sinPHI cosCHI    cosPHI sinTHE)
!!--..
!!--..   =( sinPHI cosTHE cosCHI + cosPHI sinCHI   -sinPHI cosTHE sinCHI + cosPHI cosCHI    sinPHI sinTHE )
!!--..
!!--..     (       -sinTHE cosCHI                           sinTHE sinCHI                      cosTHE    )
!!--..
!!--..
!!--..
!!--..   Comparing the matrix M(THE,PHI,CHI) with the matrix gt(a,b,c)=gt(alpha,beta,gamma)=gt(phi1,PHI,phi2)
!!--..
!!--..   One can see that both matrices are identical if we take:
!!--..
!!--..        alpha=phi1=PHI+pi/2     beta=PHI=THETA   gamma=phi2=CHI-pi/2
!!--..
!!--..         (phi1=PSI+pi/2   PHI = THETA   phi2=PHI - pi/2)
!!--..
!!--..
!!--..      The angles used in FullProf correspond to the second variant of Euler angles making the
!!--..      sustitution:
!!--..
!!--..        (PSI,THETA,PHI)  --->   (PHI, THETA, CHI)
!!--..
!!--..            2nd variant   -->      FullProf
!!--..
!!--..      This is clear from the following. If we take passive rotations as for deriving the matrix
!!--..  corresponding to the Euler angles the matrix Mt should be the result
!!--..
!!--..      Mt = (  Az(PHI) . Ay(THE) . Az(CHI) )t = Rz(CHI) . Ry(THE) . Rz(PHI)
!!--..
!!--..  Then the interpretation of the rotations are strictly the same as given in the description
!!--..  of the second variant of Euler angles.
!!--..
!!--..
!!----
!!---- DEPENDENCIES
!!----
!!---- VARIABLES
!!----    ERR_MOLEC
!!----    ERR_MOLEC_MESS
!!----    MOLECULE_TYPE
!!----    MOLECULAR_CRYSTAL_TYPE
!!----
!!---- PROCEDURES
!!----    Functions:
!!----
!!----    Subroutines:
!!----       CARTESIAN_TO_FRACTIONAL
!!----       CARTESIAN_TO_SPHERICAL
!!----       CARTESIAN_TO_ZMATRIX
!!--++       CREATE_CONNECTIVITY_CARTESIAN   [Private]
!!----       EMPIRIC_FORMULA
!!--++       EMPIRIC_FORMULA_FATOM           [Overloaded]
!!--++       EMPIRIC_FORMULA_MOLCRYS         [Overloaded]
!!--++       EMPIRIC_FORMULA_MOLEC           [Overloaded]
!!----       FIX_REFERENCE
!!----       FIX_ORIENT_CARTESIAN
!!----       FRACTIONAL_TO_CARTESIAN
!!----       FRACTIONAL_TO_SPHERICAL
!!----       FRACTIONAL_TO_ZMATRIX
!!--++       GET_CARTESIAN_FROM_Z            [Private]
!!--++       GET_Z_FROM_CARTESIAN            [Private]
!!----       INIT_ERR_MOLEC
!!----       INIT_MOLECULE
!!----       MOLCRYS_TO_ATOMLIST
!!----       MOLEC_TO_ATOMLIST
!!----       READ_FREE_ATOMS
!!----       READ_MOLECULE
!!--++       READ_MOLECULE_IN_FILE           [Overloaded]
!!--++       READ_MOLECULE_IN_VAR            [Overloaded]
!!----       SET_EULER_MATRIX
!!----       SPHERICAL_TO_CARTESIAN
!!----       SPHERICAL_TO_FRACTIONAL
!!----       SPHERICAL_TO_ZMATRIX
!!----       WRITE_FREE_ATOMS
!!----       WRITE_MOLECULAR_CRYSTAL
!!----       WRITE_MOLECULE
!!----       ZMATRIX_TO_CARTESIAN
!!----       ZMATRIX_TO_FRACTIONAL
!!----       ZMATRIX_TO_SPHERICAL
!!----
!!
 Module CFML_Molecular_Crystals

    !---- Use Modules ----!
    use CFML_GlobalDeps,                only: cp, eps, to_rad
    use CFML_Math_General,              only: acosd, asind, cosd, sind
    use CFML_Math_3D,                   only: cross_product, Get_Spheric_Coord
    use CFML_Crystallographic_Symmetry, only: Space_Group_type, Write_SpaceGroup
    use CFML_Atom_TypeDef,              only: Atom_Type, Atom_List_Type, Allocate_Atom_List, Deallocate_Atom_List,&
                                              Init_Atom_Type
    use CFML_Crystal_Metrics,           only: Crystal_Cell_Type, Set_Crystal_Cell,Err_crys, Err_Crys_Mess, &
                                              Write_Crystal_Cell
    use CFML_String_Utilities,          only: u_case, l_case, getword, getnum, cutst
    use CFML_Geometry_Calc,             only: angle_dihedral,distance,Get_PhiTheChi
    use CFML_Scattering_Chemical_Tables,only: Num_Chem_Info,Chem_Info,Set_Chem_Info,Remove_Chem_Info,Get_ChemSymb

    implicit none

    private

    !---- List of public functions ----!

    !---- List of public overloaded procedures: functions ----!

    !---- List of public subroutines ----!
    public :: Init_Err_Molec, Init_Molecule, Read_Free_Atoms, Read_Molecule,             &
              Write_Molecule, Write_Molecular_Crystal, Write_Free_Atoms

    public :: Cartesian_to_Fractional, Cartesian_to_Spherical, Cartesian_to_Zmatrix,     &
              Fractional_to_Cartesian, Fractional_to_Spherical, Fractional_to_Zmatrix,   &
              Zmatrix_to_Cartesian, Zmatrix_to_Fractional, Zmatrix_to_Spherical,         &
              Spherical_to_Cartesian, Spherical_to_Zmatrix,Spherical_to_Fractional,      &
              Fix_Reference,Fix_Orient_Cartesian, Set_Euler_Matrix, Molcrys_to_AtomList, &
              Molec_to_AtomList, Empiric_Formula,Init_Mol_Crys

    !---- List of private functions ----!

    !---- List of private Subroutines ----!
    private :: Create_Connectivity_Cartesian, Get_Cartesian_From_Z, Get_Z_From_Cartesian, &
               Empiric_Formula_FAtom, Empiric_Formula_Molcrys, Empiric_Formula_Molec


    !---- Definitions ----!

    !!----
    !!---- ERR_MOLEC
    !!----    logical, public :: err_molec
    !!----
    !!----    Logical Variable indicating an error in MOLECULAR_CRYSTAL module
    !!----
    !!---- Update: February - 2005
    !!
    logical, public          :: Err_Molec

    !!----
    !!---- ERR_MOLEC_MESS
    !!----    character(len=150), public :: ERR_Molec_Mess
    !!----
    !!----    String containing information about the last error
    !!----
    !!---- Update: February - 2005
    !!
    character(len=150), public :: ERR_Molec_Mess

    !!----
    !!----  TYPE :: MOLECULE_TYPE
    !!--..
    !!----  Type, public :: Molecule_Type
    !!----     character(len=80)                               :: Name_mol     !Global name for the molecule
    !!----     integer                                         :: natoms       !Number of atoms
    !!----     logical                                         :: in_xtal      !True if global coordinates xcentre, orient are defined
    !!----     logical                                         :: is_EulerMat  !True if the Euler Matrix has been set
    !!----     logical                                         :: is_connect   !True if the connectivity is correct
    !!----     character(len=1)                                :: rot_type     !Type of rotational angles
    !!----                                                                     !"E": Conventional Euler angles (alpha,beta,gamma)
    !!----                                                                     !"P": Second variant of Euler angles (default)
    !!----                                                                     !     Polar:(theta,phi,chi)
    !!----     character(len=1)                                :: coor_type    !Type of internal coordinates
    !!----                                                                     !"Z": Z-matrix
    !!----                                                                     !"C": Cartesian
    !!----                                                                     !"S": Spherical
    !!----                                                                     !"F": Fractional coordinates (only if in_xtal = .true.)
    !!----     character(len=3)                                :: therm_type   !Type of thermal factor
    !!----                                                                     !"ISO": No collective motion
    !!----                                                                     !"T  ": Translational
    !!----                                                                     !"TL ": Translational + Librational
    !!----                                                                     !"TLS": Translational + Librational + Correlation
    !!----     real(kind=cp), dimension(3)                     :: xcentre      !Fractional coordinates of the centre
    !!----     real(kind=cp), dimension(3)                     :: mxcentre     !Refinement codes (or multipliers) of Fractional coordinates of the centre
    !!----     integer,       dimension(3)                     :: lxcentre     !Numbers of LSQ parameters for Fractional coordinates of the centre
    !!----     real(kind=cp), dimension(3)                     :: Orient       !Orientation angles (Euler angles or variant ...)
    !!----     real(kind=cp), dimension(3)                     :: mOrient      !Refinement codes (or multipliers) of Orientation angles (Euler angles or variant ...)
    !!----     integer,       dimension(3)                     :: lOrient      !Numbers of LSQ parameters for Orientation angles (Euler angles or variant ...)
    !!----     real(kind=cp), dimension(6)                     :: T_TLS        !Translational Thermal factor tensor
    !!----     real(kind=cp), dimension(6)                     :: mT_TLS       !Refinement codes (or multipliers) of Translational Thermal factor tensor
    !!----     integer,       dimension(6)                     :: lT_TLS       !Numbers of LSQ parameters for Translational Thermal factor tensor
    !!----     real(kind=cp), dimension(6)                     :: L_TLS        !Librational Thermal factor tensor
    !!----     real(kind=cp), dimension(6)                     :: mL_TLS       !Refinement codes (or multipliers) of Librational Thermal factor tensor
    !!----     integer,       dimension(6)                     :: lL_TLS       !Numbers of LSQ parameters for Librational Thermal factor tensor
    !!----     real(kind=cp), dimension(3,3)                   :: S_TLS        !TL-correlation Thermal factor
    !!----     real(kind=cp), dimension(3,3)                   :: mS_TLS       !Refinement codes (or multipliers) of TL-correlation Thermal factor
    !!----     integer,       dimension(3,3)                   :: lS_TLS       !Numbers of LSQ parameters for TL-correlation Thermal factor
    !!----     real(kind=cp), dimension(3,3)                   :: Euler        !Euler matrix
    !!----     character(len=6),  allocatable, dimension(  :)  :: AtName       !Atom Name
    !!----     character(len=4),  allocatable, dimension(  :)  :: AtSymb       !Atom species
    !!----     integer,           allocatable, dimension(  :)  :: AtZ          !Atomic Number
    !!----     integer,           allocatable, dimension(:,:)  :: Ptr          !Pointer to scat.factors (first index -> pattern)
    !!----     real(kind=cp),     allocatable, dimension(:,:)  :: I_coor       !Internal coordinates (d,ang,dang)
    !!----     real(kind=cp),     allocatable, dimension(:,:)  :: mI_coor      !Refinement codes (or multipliers) of internal coordinates
    !!----     integer,           allocatable, dimension(:,:)  :: lI_coor      !Numbers of LSQ parameters for internal coordinates
    !!----     real(kind=cp),     allocatable, dimension(  :)  :: biso         !Isotropic temperature factor
    !!----     real(kind=cp),     allocatable, dimension(  :)  :: mbiso        !Refinement codes (or multipliers) of Isotropic temperature factor
    !!----     integer,           allocatable, dimension(  :)  :: lbiso        !Numbers of LSQ parameters for Isotropic temperature factor
    !!----     real(kind=cp),     allocatable, dimension(  :)  :: occ          !Occupation factor
    !!----     real(kind=cp),     allocatable, dimension(  :)  :: mocc         !Refinement codes (or multipliers) of Occupation factor
    !!----     integer,           allocatable, dimension(  :)  :: locc         !Numbers of LSQ parameters for Occupation factor
    !!----     integer,           allocatable, dimension(  :)  :: Nb           !Number of neighbours
    !!----     integer,           allocatable, dimension(:,:)  :: inb          !Index of neighbours
    !!----     integer,           allocatable, dimension(:,:)  :: Tb           !Type of bonds
    !!----     integer,           allocatable, dimension(:,:)  :: conn         !Conectivity (N1,N2,N3)
    !!----  End Type Molecule_Type
    !!----
    !!---- Update: February - 2005
    !!
    Type, public :: Molecule_type
       character(len=80)                               :: Name_mol     !Global name for the molecule
       integer                                         :: natoms       !Number of atoms
       logical                                         :: in_xtal      !True if global coordinates xcentre, orient are defined
       logical                                         :: is_EulerMat  !True if the Euler Matrix has been set
       logical                                         :: is_connect   !True if the connectivity is given and correct
       character(len=1)                                :: rot_type     !Type of rotational angles
                                                                       !"E": Conventional Euler angles (alpha,beta,gamma)
                                                                       !"P": Second variant of Euler angles (default)
                                                                       !     Polar:(theta,phi,chi)
       character(len=1)                                :: coor_type    !Type of internal coordinates
                                                                       !"Z": Z-matrix
                                                                       !"C": Cartesian
                                                                       !"S": Spherical
                                                                       !"F": Fractional coordinates (only if in_xtal = .true.)
       character(len=3)                                :: therm_type   !Type of thermal factor
                                                                       !"ISO": No collective motion
                                                                       !"T  ": Translational
                                                                       !"TL ": Translational + Librational
                                                                       !"TLS": Translational + Librational + Correlation
       real(kind=cp), dimension(3)                     :: xcentre      !Fractional coordinates of the centre
       real(kind=cp), dimension(3)                     :: mxcentre     !Refinement codes (or multipliers) of Fractional coordinates of the centre
       integer,       dimension(3)                     :: lxcentre     !Numbers of LSQ parameters for Fractional coordinates of the centre
       real(kind=cp), dimension(3)                     :: Orient       !Orientation angles (Euler angles or variant ...)
       real(kind=cp), dimension(3)                     :: mOrient      !Refinement codes (or multipliers) of Orientation angles (Euler angles or variant ...)
       integer,       dimension(3)                     :: lOrient      !Numbers of LSQ parameters for Orientation angles (Euler angles or variant ...)
       real(kind=cp), dimension(6)                     :: T_TLS        !Translational Thermal factor tensor
       real(kind=cp), dimension(6)                     :: mT_TLS       !Refinement codes (or multipliers) of Translational Thermal factor tensor
       integer,       dimension(6)                     :: lT_TLS       !Numbers of LSQ parameters for Translational Thermal factor tensor
       real(kind=cp), dimension(6)                     :: L_TLS        !Librational Thermal factor tensor
       real(kind=cp), dimension(6)                     :: mL_TLS       !Refinement codes (or multipliers) of Librational Thermal factor tensor
       integer,       dimension(6)                     :: lL_TLS       !Numbers of LSQ parameters for Librational Thermal factor tensor
       real(kind=cp), dimension(3,3)                   :: S_TLS        !TL-correlation Thermal factor
       real(kind=cp), dimension(3,3)                   :: mS_TLS       !Refinement codes (or multipliers) of TL-correlation Thermal factor
       integer,       dimension(3,3)                   :: lS_TLS       !Numbers of LSQ parameters for TL-correlation Thermal factor
       real(kind=cp), dimension(3,3)                   :: Euler        !Euler matrix
       character(len=20), allocatable, dimension(  :)  :: AtName       !Atom Name
       character(len=4),  allocatable, dimension(  :)  :: AtSymb       !Atom species
       integer,           allocatable, dimension(  :)  :: AtZ          !Atomic Number
       integer,           allocatable, dimension(:,:)  :: Ptr          !Pointer to scat.factors (first index -> pattern)
       real(kind=cp),     allocatable, dimension(:,:)  :: I_coor       !Internal coordinates (d,ang,dang)
       real(kind=cp),     allocatable, dimension(:,:)  :: mI_Coor      !Refinement codes (or multipliers) of internal coordinates
       integer,           allocatable, dimension(:,:)  :: lI_coor      !Numbers of LSQ parameters for internal coordinates
       real(kind=cp),     allocatable, dimension(  :)  :: biso         !Isotropic temperature factor
       real(kind=cp),     allocatable, dimension(  :)  :: mbiso        !Refinement codes (or multipliers) of Isotropic temperature factor
       integer,           allocatable, dimension(  :)  :: lbiso        !Numbers of LSQ parameters for Isotropic temperature factor
       real(kind=cp),     allocatable, dimension(  :)  :: occ          !Occupation factor
       real(kind=cp),     allocatable, dimension(  :)  :: mocc         !Refinement codes (or multipliers) of Occupation factor
       integer,           allocatable, dimension(  :)  :: locc         !Numbers of LSQ parameters for Occupation factor
       integer,           allocatable, dimension(  :)  :: Nb           !Number of neighbours
       integer,           allocatable, dimension(:,:)  :: INb          !Index of neighbours
       integer,           allocatable, dimension(:,:)  :: Tb           !Type of Bonds
       integer,           allocatable, dimension(:,:)  :: Conn         !Conectivity (N1,N2,N3)
    End Type Molecule_type

    !!----
    !!----  TYPE :: MOLECULAR_CRYSTAL_TYPE
    !!--..
    !!----  Type, public :: Molecular_Crystal_Type
    !!----     integer                                              :: N_free      !Number of free atoms
    !!----     integer                                              :: N_mol       !Number of Molecules
    !!----     integer                                              :: N_species   !Number of species
    !!----     integer                                              :: Npat        !
    !!----     type(Crystal_Cell_type)                              :: Cell        !Cell Information
    !!----     type(Space_Group_type)                               :: SpG         !Space Group Information
    !!----     type(Atom_type),         allocatable, dimension(  :) :: Atm         !Free Atoms
    !!----     type(Molecule_type ),    allocatable, dimension(  :) :: Mol         !Molecules
    !!----  End type Molecular_Crystal_Type
    !!----
    !!---- Update: February - 2005
    !!
    Type, public :: Molecular_Crystal_Type
       integer                                              :: N_Free
       integer                                              :: N_Mol
       integer                                              :: N_Species
       integer                                              :: Npat
       type(Crystal_Cell_type)                              :: Cell
       type(Space_Group_type)                               :: SpG
       type(Atom_type),         allocatable, dimension(  :) :: Atm
       type(Molecule_type ),    allocatable, dimension(  :) :: Mol
    End type Molecular_Crystal_Type

    !---- Overloading Section ----!
    Interface Empiric_Formula
       Module Procedure Empiric_Formula_FAtom
       Module Procedure Empiric_Formula_Molec
       Module Procedure Empiric_Formula_Molcrys
    End Interface

    Interface Read_Molecule
       Module Procedure Read_Molecule_in_File
       Module Procedure Read_Molecule_in_Var
    End Interface

 Contains
    !---- Subroutines ----!

    !!----
    !!---- Subroutine Cartesian_to_Fractional(Molecule,Cell,NewMolecule)
    !!----    type (Molecule_type), intent(in out)           :: Molecule
    !!----    type (Crystal_Cell_Type), intent(in)           :: Cell
    !!----    type (Molecule_type), intent(   out), optional :: Newmolecule
    !!----
    !!----    Subroutine to transform the internal coordinates of a
    !!----    molecule from cartesian coordinates to  fractional coordinates.
    !!----    If a third argument is present the subroutine creates a new
    !!----    molecule (copy of the old one) with fractional coordinates,
    !!----    preserving the input molecule in Cartesian Coordinates. Otherwise
    !!----    the input molecule is changed on output.
    !!----    Control of error is present
    !!--..       Xc= Euler.Xic  (Cartesian in the crystal frame)
    !!--..       xf= Orth_Cr_cel Xc (fractional before translating to the centre)
    !!--..       Xf = Orth_Cr_cel (Euler.Xic) + Xo (final fractional coordinates)
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Cartesian_to_Fractional(Molecule,Cell,NewMolecule)
       !---- Arguments ----!
       type (Molecule_type), intent(in out)           :: Molecule
       type (Crystal_Cell_Type), intent(in)           :: Cell
       type (Molecule_type), intent(   out), optional :: NewMolecule

       !---- Local Variables ----!
       integer                       :: i,na
       real(kind=cp)                 :: phi,theta,chi
       real(kind=cp), dimension(3)   :: ci,xi
       real(kind=cp), dimension(3,3) :: Eu
       type (Molecule_type)          :: Newmol

       !---- Controls ----!
       if (molecule%coor_type /= "C") then
          err_molec=.true.
          ERR_Molec_Mess="Error in Cartesian_to_Fractional: the input molecule is not in Cartesian coordinates"
          return
       end if

       na=molecule%natoms
       if (na <=0) then
          err_molec=.true.
          ERR_Molec_Mess="Error in Cartesian_to_Fractional: No atoms are defined on molecule variable"
          return
       end if

       if (.not. molecule%in_xtal) then
          err_molec=.true.
          ERR_Molec_Mess="Error in Cartesian_to_Fractional: the input molecule haven't crystal information"
          return
       end if

       !---- Step 1----!
       call init_molecule(newmol,na)
       newmol=molecule

       !---- Frame after a rotation defined by the matrix M(theta,phi,Chi)
       phi   = newmol%orient(1)
       theta = newmol%orient(2)
       chi   = newmol%orient(3)
       if (newmol%is_EulerMat) then
          Eu=newmol%Euler
       else
          call Set_Euler_matrix(newmol%rot_type,phi,theta,chi,Eu)
          newmol%Euler=Eu
          newmol%is_EulerMat=.true.
       end if

       do i=1,na
          ci=matmul(Eu,newmol%I_coor(:,i))         !Cartesian components in the Crystal Frame
          xi=matmul(cell%Orth_Cr_cel,ci)           !Fractional coordinates before translation
          newmol%I_coor(:,i) = newmol%xcentre + xi !Final fractional coordinates
       end do
       newmol%coor_type = "F"

       !---- Step 3 ----!
       if (present(newmolecule)) then
          call Init_molecule(NewMolecule,na)
          if (NewMolecule%natoms <=0) then
             err_molec=.true.
             ERR_Molec_Mess="Error in Cartesian_to_Fractional: The optional variable was not dimensioned!"
             return
          end if
          NewMolecule=newmol
       else
          Molecule=newmol
       end if

       return
    End Subroutine Cartesian_to_Fractional

    !!----
    !!---- Subroutine Cartesian_to_Spherical(Molecule,NewMolecule)
    !!----    type (Molecule_type), intent(in out)           :: Molecule
    !!----    type (Molecule_type), intent(   out), optional :: Newmolecule
    !!----
    !!----    Subroutine to transform the internal coordinates of a
    !!----    molecule from cartesian coordinates to  spherical coordinaters.
    !!----    If a second argument is present the subroutine creates a new
    !!----    molecule (copy of the old one) with spherical coordinates,
    !!----    preserving the input molecule in Cartesian Coordinates. Otherwise
    !!----    the input molecule is changed on output.
    !!----    Control of error is present
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Cartesian_to_Spherical(Molecule,NewMolecule)
       !---- Arguments ----!
       type (Molecule_type), intent(in out)           :: Molecule
       type (Molecule_type), intent(   out), optional :: NewMolecule

       !---- Local variables -----!
       integer                     :: i,na
       real(kind=cp)               :: r, theta, phi
       real(kind=cp), dimension(3) :: ri
       type (Molecule_type)        :: Newmol

       !---- Controls ----!
       if (molecule%coor_type /= "C") then
          err_molec=.true.
          ERR_Molec_Mess="Error in Cartesian_to_Spherical: the input molecule is not in Cartesian coordinates"
          return
       end if

       na= Molecule%natoms
       if (na <= 0) then
          err_molec=.true.
          ERR_Molec_Mess="Error in Cartesian_to_Spherical: No atoms are defined"
          return
       end if

       !---- Start calculations for each atom of the molecule ----!
       call init_molecule(newmol,na)
       NewMol=Molecule

       do i=1,na
          ri=Molecule%I_Coor(:,i)
          call  Get_Spheric_Coord(ri,r,theta,phi,"D")
          NewMol%I_Coor(1,i) = r
          NewMol%I_Coor(2,i) = theta
          NewMol%I_Coor(3,i) = phi
       end do
       NewMol%coor_type="S"

       if (present(newmolecule)) then
          call Init_molecule(NewMolecule,na)
          if (NewMolecule%natoms <=0) then
             err_molec=.true.
             ERR_Molec_Mess="Error in Cartesian_to_Spherical: The optional variable was not dimensioned!"
             return
          end if
          NewMolecule=newmol
       else
          Molecule=newmol
       end if

       return
    End Subroutine Cartesian_to_Spherical

    !!----
    !!---- Subroutine Cartesian_to_Zmatrix(Molecule,NewMolecule,Cell, D_min,D_max)
    !!----    type (Molecule_type), intent(in out)           :: Molecule
    !!----    type (Molecule_type), intent(   out), optional :: NewMolecule
    !!----    Type(Crystal_Cell_Type), intent(in),  optional :: Cell
    !!----    real(kind=cp),        intent(in    ), optional :: D_min
    !!----    real(kind=cp),        intent(in    ), optional :: D_max
    !!----
    !!----    Subroutine to transform the internal coordinates of a molecule
    !!----    from cartesian coordinates to  Z-matrix.
    !!----    If a second argument is present the subroutine creates a new
    !!----    molecule (copy of the old one) with Z-matrix, preserving
    !!----    the input molecule in Cartesian Coordinates. Otherwise the input
    !!----    molecule is changed on output.
    !!----    The input cartesian coordinates may be defined with respect to another
    !!----    internal frame. The final internal frame is that defined for Z-matrices:
    !!----    the x-axis is from the first to the second atom and the x-y plane is formed
    !!----    by the three first atoms. The Euler matrix and the molecular centre in the
    !!----    crystallographic system is changed in consequence.
    !!----    Control of error is present
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Cartesian_to_Zmatrix(Molecule,NewMolecule,Cell,D_min,D_max)
       !---- Arguments ----!
       type (Molecule_type), intent(in out)           :: Molecule
       type (Molecule_type), intent(   out), optional :: NewMolecule
       Type(Crystal_Cell_Type), intent(in),  optional :: Cell
       real(kind=cp),        intent(in    ), optional :: D_min
       real(kind=cp),        intent(in    ), optional :: D_max

       !---- Local variables -----!
       integer                       :: i,na,j,k,n,mode
       real(kind=cp)                 :: dist, ang, phi, theta, chi
       real(kind=cp), dimension(3)   :: ci,ri,rj,rk,rn,u1,u2,u3
       real(kind=cp), dimension(3,3) :: Mat, Eu
       type (Molecule_type)          :: Newmol

       !---- Controls ----!
       if (molecule%coor_type /= "C") then
          err_molec=.true.
          ERR_Molec_Mess="Error in Cartesian_to_Zmatrix: the input molecule is not in Cartesian coordinates"
          return
       end if

       na= Molecule%natoms
       if (na <= 0) then
          err_molec=.true.
          ERR_Molec_Mess="Error in Cartesian_to_Zmatrix: Not atoms are defined"
          return
       end if

       if (na < 3) then
          err_molec=.true.
          ERR_Molec_Mess="Error in Cartesian_to_Zmatrix: You need at least three atoms"
          return
       end if

       !---- Call Connectivity if necessary ----!
       if (.not. molecule%is_connect) then
          mode=0
          if (present(d_min)) mode=1
          if (present(d_max)) mode=mode + 2
          select case (mode)
             case (0)
                call create_connectivity_cartesian(molecule)
             case (1)
                call create_connectivity_cartesian(molecule,dmin=d_min)
             case (2)
                call create_connectivity_cartesian(molecule,dmax=d_max)
             case (3)
                call create_connectivity_cartesian(molecule,dmin=d_min,dmax=d_max)
          end select
          if (err_molec) then
             ERR_Molec_Mess="Error in Cartesian_to_Zmatrix: the connectivity is wrong"
             return
          end if
          molecule%is_connect=.true.
       end if

       !---- Start calculations for each atom of the molecule ----!
       call init_molecule(newmol,na)
       newmol=molecule

       !---- First atom is always at origin (Z-matrix) ----!
       NewMol%I_Coor(:,1) = 0.0_cp
       NewMol%conn(:,1)   = 0

       !---- Second atom is always along "x" ----!
       ri=molecule%I_coor(:,2)-molecule%I_coor(:,1)
       dist=sqrt(dot_product(ri,ri))
       NewMol%I_Coor(1,2)   = dist
       NewMol%I_Coor(2:3,2) = 0.0_cp
       NewMol%conn(2:3,2)   = 0
       NewMol%conn(1,2)     = 1

       !---- Third atom is always in the "xy" plane ----!
       !---- A(i) d_ij  ang_ijk   dang_ijkl  j k l
       if (NewMol%conn(1,3) == 1) then
          NewMol%conn(2,3) = 2
          NewMol%conn(3,3) = 0
          ri=molecule%I_coor(:,3)-molecule%I_coor(:,1)
          rj=molecule%I_coor(:,2)-molecule%I_coor(:,1)
          dist= sqrt(dot_product(ri,ri))
          ang = acosd(dot_product(ri,rj)/dist/sqrt(dot_product(rj,rj)))
          NewMol%I_coor(1,3) = dist
          NewMol%I_coor(2,3) = ang
          NewMol%I_coor(3,3) = 0.0_cp
       else
          NewMol%conn(1,3) = 2
          NewMol%conn(2,3) = 1
          NewMol%conn(3,3) = 0
          ri=molecule%I_coor(:,3)-molecule%I_coor(:,2)
          rj=molecule%I_coor(:,1)-molecule%I_coor(:,2)
          dist= sqrt(dot_product(ri,ri))
          ang = acosd(dot_product(ri,rj)/dist/sqrt(dot_product(rj,rj)))
          NewMol%I_coor(1,3) = dist
          NewMol%I_coor(2,3) = ang
          NewMol%I_coor(3,3) = 0.0_cp
       end if

       if (Molecule%in_xtal) then    !Modify the Euler matrix, orientation angles and centre
          if (Molecule%is_EulerMat) then
             Eu=Molecule%Euler
          else
             phi=Molecule%orient(1)
             theta=Molecule%orient(2)
             chi=Molecule%orient(3)
             Call Set_Euler_matrix(Molecule%rot_type,phi,theta,chi,Eu)
          end if
          newmol%Euler=Eu
          newmol%is_EulerMat=.true.

          ri=molecule%I_coor(:,1)
          rj=molecule%I_coor(:,2)
          rk=molecule%I_coor(:,3)
          u1=rj-ri
          u1=u1/sqrt(dot_product(u1,u1))
          u3=cross_product(u1,rk-ri)
          u3=u3/sqrt(dot_product(u3,u3))
          u2=cross_product(u3,u1)
          Mat(:,1)=u1
          Mat(:,2)=u2  !Active matrix needed to get the new Euler matrix
          Mat(:,3)=u3

          newmol%Euler=matmul(Eu,Mat)  !New Euler Matrix
          call Get_PhiTheChi(newmol%Euler,Phi,Theta,Chi,"D")
          newmol%orient(1)=  phi
          newmol%orient(2)=theta
          newmol%orient(3)=  chi

          !---- New centre (?) Needs the Cell argument
          if (present(Cell)) then
             rj=Matmul(Mat,ri)
             newmol%xcentre=matmul(Cell%Orth_Cr_cel,rj)+molecule%xcentre
          else
             if (dot_product(ri,ri) > eps) then
                err_molec=.true.
                ERR_Molec_Mess="Error in Cartesian_to_Zmatrix: First atom not at the origin => a cell has to be provided "
                return
             end if
          end if
       end if

       do i=4,na                      !The result of this calculation is independent of the type of
          ri = molecule%I_coor(:,i)   !cartesian coordinates => it is not needed to transforn the input Cartesian!
          j  = molecule%conn(1,i)     !The connectivity is needed for the Z-matrix description
          k  = molecule%conn(2,i)     !If the connectivity is given it is possible to transform to
          n  = molecule%conn(3,i)     !Z-matrix if cartesian/spherical coordinates are given.
          if ( j == 0 .or. k == 0 .or. n == 0) then
             err_molec=.true.
             ERR_Molec_Mess="Error in Cartesian_to_Zmatrix: the connectivity is wrong for atom: " &
                            //molecule%Atname(i)
             return
          end if
          rj = molecule%I_coor(:,j)
          rk = molecule%I_coor(:,k)
          rn = molecule%I_coor(:,n)
          call get_Z_from_cartesian(ci,ri,rj,rk,rn)
          NewMol%I_coor(:,i) = ci
       end do
       NewMol%coor_type="Z"

       if (present(NewMolecule)) then
          call Init_molecule(NewMolecule,na)
          if (NewMolecule%natoms <=0) then
             err_molec=.true.
             ERR_Molec_Mess="Error in Cartesian_to_Zmatrix: The optional variable was not dimensioned!"
             return
          end if
          NewMolecule=newmol
       else
          Molecule=newmol
       end if

       return
    End Subroutine Cartesian_to_Zmatrix

    !!--++
    !!--++ Subroutine Create_Connectivity_Cartesian(Molecule, Dmin, Dmax)
    !!--++    type (Molecule_type),          intent(in out):: Molecule
    !!--++    real(kind=cp), optional,       intent(in)    :: Dmin
    !!--++    real(kind=cp), optional,       intent(in)    :: Dmax
    !!--++
    !!--++    (PRIVATE)
    !!--++    Subroutine that create the connectivity for the molecule.
    !!--++    The coordinates must be in Cartesian system. Control of
    !!--++    error is implemented.
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Create_Connectivity_Cartesian(Molecule,Dmin,Dmax)
       !---- Arguments ----!
       type (Molecule_type),          intent(in out):: Molecule
       real(kind=cp), optional,       intent(in)    :: Dmin
       real(kind=cp), optional,       intent(in)    :: Dmax

       !---- Local variables ----!
       logical                                                      :: re_order
       integer                                                      :: i,j,k,l,m,nc1,nc2,nc3
       integer, dimension(molecule%natoms,molecule%natoms)          :: T_Conn
       integer, dimension(3,molecule%natoms)                        :: T_N
       integer, dimension(molecule%natoms)                          :: T_Ind
       real(kind=cp),    dimension(molecule%natoms,molecule%natoms) :: T_Dist
       real(kind=cp)                                                :: d_min, d_max
       real(kind=cp)                                                :: dist !,ang,tors
       type (Molecule_type)                                         :: Newmol


       !---- Initialize ----!
       d_min=0.6
       d_max=3.0
       T_Conn=0
       T_N   =0
       T_Ind =0
       T_Dist=0.0
       if (present(dmin)) d_min=dmin
       if (present(dmax)) d_max=dmax

       !---- Controls ----!
       if (molecule%coor_type /= "C") then
          err_molec=.true.
          ERR_Molec_Mess="Error in Connectivity: the input molecule is not in Cartesian coordinates"
          return
       end if

       !---- Creating Tables ----!
       do i=1,molecule%natoms
          do j=i+1,molecule%natoms
             dist=distance(molecule%I_coor(:,i),molecule%I_coor(:,j))
             if (dist < d_min .or. dist > d_max) cycle
             if (adjustl(molecule%Atsymb(i)) == "H   " .and. &
                 adjustl(molecule%Atsymb(j)) == "H   ") cycle
             T_Conn(i,j)=i
             T_Conn(j,i)=i
             T_Dist(i,j)=dist
             T_Dist(j,i)=dist
          end do
       end do

       !---- Test for reorder atoms ----!
       re_order=.false.

       do i=2,molecule%natoms
          j=count(T_conn(i,1:i-1) > 0)
          if (j==0) re_order=.true.
       end do

       if (re_order) then
          m=1
          T_ind(m)=1
          do i=1,molecule%natoms
             do j=1,molecule%natoms
                if (T_Conn(i,j) <= 0) cycle
                l=0
                do k=1,m
                     if (j == T_ind(k)) then
                        l=1
                        exit
                     end if
                end do
                if (l > 0) cycle
                m=m+1
                T_ind(m)=j
             end do
          end do

          call init_molecule(newmol,molecule%natoms)
          newmol=molecule
          do i=2,newmol%natoms
             j=T_ind(i)
             newmol%AtName(i)=   molecule%AtName(j)
             newmol%AtSymb(i)=   molecule%AtSymb(j)
             newmol%AtZ(i)=      molecule%AtZ(j)
             newmol%Ptr(:,i)=    molecule%Ptr(:,j)
             newmol%I_Coor(:,i)= molecule%I_Coor(:,j)
             newmol%mI_Coor(:,i)=molecule%mI_Coor(:,j)
             newmol%lI_Coor(:,i)=molecule%lI_Coor(:,j)
             newmol%biso(i)=     molecule%biso(j)
             newmol%mbiso(i)=    molecule%mbiso(j)
             newmol%lbiso(i)=    molecule%lbiso(j)
             newmol%occ(i)=      molecule%occ(j)
             newmol%mocc(i)=     molecule%mocc(j)
             newmol%locc(i)=     molecule%locc(j)
             newmol%nb(i)=       molecule%nb(j)
             newmol%Inb(:,i)=    molecule%Inb(:,j)
             newmol%Tb(:,i)=     molecule%Tb(:,j)
             newmol%Conn(:,i)=   molecule%Conn(:,j)
          end do
          molecule=newmol
          call init_molecule(newmol,0)

          T_Conn=0
          T_Dist=0.0
          do i=1,molecule%natoms
             do j=i+1,molecule%natoms
                dist=distance(molecule%I_coor(:,i),molecule%I_coor(:,j))
                if (dist < d_min .or. dist > d_max) cycle
                if (adjustl(molecule%Atsymb(i)) == "H   " .and. &
                    adjustl(molecule%Atsymb(j)) == "H   ") cycle
                T_Conn(i,j)=i
                T_Conn(j,i)=i
                T_Dist(i,j)=dist
                T_Dist(j,i)=dist
             end do
          end do
       end if

       !---- Connectivity Info ----!
       do i=2, molecule%natoms

          !---- Distances: Fill N1 ----!
          j=minloc(T_Dist(i,1:i-1),dim=1,mask=(T_Dist(i,1:i-1) > 0.0))
          T_N(1,i)=j

          if (j == 0) then
             err_molec=.true.
             ERR_Molec_Mess="Error in Connectivity: Some Index are zeros"
             return
          end if

          !---- Angles: Fill N2 ----!
          if (i > 2) then
             nc1=count((T_Conn(j,1:i-1) > 0 .and. T_Conn(j,1:i-1) /=j),dim=1)
             nc2=count((T_Conn(i,1:i-1) > 0 .and. T_Conn(i,1:i-1) /=j),dim=1)
             k=0
             if (nc1 > 0) then
                do
                   k=minloc(T_Dist(j,1:i-1),dim=1, mask=(T_Dist(j,1:i-1) > 0.0))
                   if (k == j) then
                      T_Dist(j,k)=-T_Dist(j,k)
                      cycle
                   else
                      exit
                   end if
                end do
             elseif (nc2 > 0) then
                do
                   k=minloc(T_Dist(i,1:i-1),dim=1, mask=(T_Dist(i,1:i-1) > 0.0))
                   if (k == j) then
                      T_Dist(i,k)=-T_Dist(i,k)
                      cycle
                   else
                      exit
                   end if
                end do
             end if
             if (k == 0) then
                !---- Elegir uno cualquiera ----!
                do l=1,i-1
                   if (l == j) cycle
                   k=l
                   exit
                end do
             end if
             T_N(2,i)=k
          end if
          T_Dist=abs(T_Dist)

          !---- Torsion ----!
          if (i > 3) then
             nc1=count((T_Conn(k,1:i-1) > 0 .and. T_Conn(k,1:i-1) /=j .and. T_Conn(k,1:i-1) /=k),dim=1)
             nc2=count((T_Conn(j,1:i-1) > 0 .and. T_Conn(j,1:i-1) /=j .and. T_Conn(j,1:i-1) /=k),dim=1)
             nc3=count((T_Conn(i,1:i-1) > 0 .and. T_Conn(i,1:i-1) /=j .and. T_Conn(i,1:i-1) /=k),dim=1)

             l=0
             if (nc1 > 0) then
                do
                   l=minloc(T_Dist(k,1:i-1),dim=1, mask=(T_Dist(k,1:i-1) > 0.0))
                   if (l == j .or. l == k) then
                      T_Dist(k,l)=-T_Dist(k,l)
                      cycle
                   else
                      exit
                   end if
                end do
             elseif (nc2 > 0) then
                do
                   l=minloc(T_Dist(j,1:i-1),dim=1, mask=(T_Dist(j,1:i-1) > 0.0))
                   if (l == j .or. l == k) then
                      T_Dist(j,l)=-T_Dist(j,l)
                      cycle
                   else
                      exit
                   end if
                end do
             elseif (nc3 > 0) then
                do
                   l=minloc(T_Dist(i,1:i-1),dim=1, mask=(T_Dist(i,1:i-1) > 0.0))
                   if (l == j .or. l == k) then
                      T_Dist(i,l)=-T_Dist(i,l)
                      cycle
                   else
                      exit
                   end if
                end do
             end if
             if (l==0) then
                !---- Elegir uno cualquiera ----!
                do m=1,i-1
                   if (m == j .or. m == k) cycle
                   l=m
                   exit
                end do
             end if
             T_N(3,i)=l
          end if
          T_Dist=abs(T_Dist)

       end do

       !---- Final Part ----!
       do i=1, molecule%natoms
          molecule%Conn(:,i)=T_N(:,i)
          select case (i)
             case (2)
                if (T_N(1,i) == 0) then
                   err_molec=.true.
                   ERR_Molec_Mess="Error in Connectivity: Some Index are zeros"
                end if
             case (3)
                if (any(T_N(1:2,i) == 0)) then
                   err_molec=.true.
                   ERR_Molec_Mess="Error in Connectivity: Some Index are zeros"
                end if
             case (4:)
                if (any(T_N(:,i) == 0)) then
                   err_molec=.true.
                   ERR_Molec_Mess="Error in Connectivity: Some Index are zeros"
                end if
          end select
       end do

       return
    End Subroutine Create_Connectivity_Cartesian

    !!----
    !!---- Subroutine Fix_Reference(Molecule, NewMolecule, NAtom_O, NAtom_X, NAtom_XY)
    !!----    type (Molecule_type),     intent(in out)           :: Molecule
    !!----    type (Molecule_type),     intent(   out), optional :: Newmolecule
    !!----    integer,                  intent(in),     optional :: NAtom_O
    !!----    integer,                  intent(in),     optional :: NAtom_X
    !!----    integer,                  intent(in),     optional :: NAtom_XY
    !!----
    !!----    Subroutine to order the molecule choosing which atom is the origin,
    !!----    which define the X axis and which defines the XY Plane
    !!----    If the second argument is present the subroutine creates a new molecule
    !!----    preserving the input molecule in Cartesian. Otherwise the input molecule is
    !!----    changed on output.
    !!----    If Natom_0 is absent, then the first atom on the molecule will be the origin.
    !!----    If Natom_X is absent, then the second atom on the molecule will define the X axis.
    !!----    If Natom_XY is absent, then the third atom on the molecule will define the XY Plane.
    !!----    Control of error is present
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Fix_Reference(Molecule, NewMolecule, NAtom_O, NAtom_X, NAtom_XY)
       !---- Arguments ----!
       type (Molecule_type),     intent(in out)           :: Molecule
       type (Molecule_type),     intent(   out), optional :: Newmolecule
       integer,                  intent(in),     optional :: NAtom_O
       integer,                  intent(in),     optional :: NAtom_X
       integer,                  intent(in),     optional :: NAtom_XY

       !---- Local variables ----!
       integer                   :: n_or, n_x, n_xy
       integer                   :: i
       type (Molecule_type)      :: Newmol,SetMol

       !---- Initialize ----!
       n_or=1
       n_x =2
       n_xy=3
       if (present(natom_O))  n_or=natom_o
       if (present(natom_x))  n_x =natom_x
       if (present(natom_xy)) n_xy=natom_xy

       call Init_Err_Molec()

       if (n_x == n_or) then
          err_molec=.true.
          ERR_Molec_Mess="The atom defining origin and X axis is the same"
          return
       end if

       if (n_xy == n_or .or. n_xy ==n_x) then
          err_molec=.true.
          ERR_Molec_Mess="The atom defining the Plane XY is equal to the origin or that define the X axis"
          return
       end if

       if (molecule%natoms > 0) call Init_Molecule(Newmol,molecule%natoms)
       Newmol=molecule

       !---- Sorting the Atom List ----!
       call init_molecule(SetMol,1)

       !---- Fix Origin ----!
       if (n_or /= 1) then
          SetMol%AtName(1)    =NewMol%AtName(n_or)
          SetMol%AtSymb(1)    =NewMol%AtSymb(n_or)
          SetMol%AtZ(1)       =NewMol%AtZ(n_or)
          SetMol%Ptr(:,1)     =NewMol%Ptr(:,n_or)
          SetMol%I_Coor(:,1)  =NewMol%I_Coor(:,n_or)
          SetMol%mI_Coor(:,1) =NewMol%mI_Coor(:,n_or)
          SetMol%lI_Coor(:,1) =NewMol%lI_Coor(:,n_or)
          SetMol%Biso(1)      =NewMol%Biso(n_or)
          SetMol%mbiso(1)     =NewMol%mbiso(n_or)
          SetMol%lBiso(1)     =NewMol%lBiso(n_or)
          SetMol%Occ(1)       =NewMol%Occ(n_or)
          SetMol%mocc(1)      =NewMol%mocc(n_or)
          SetMol%lOcc(1)      =NewMol%lOcc(n_or)
          SetMol%Nb(1)        =NewMol%Nb(n_or)
          SetMol%INb(:,1)     =NewMol%INb(:,n_or)
          SetMol%Tb(:,1)      =NewMol%Tb(:,n_or)
          SetMol%Conn(:,1)    =NewMol%Conn(:,n_or)

          NewMol%AtName(2:n_or)    =NewMol%AtName(1:n_or-1)
          NewMol%AtSymb(2:n_or)    =NewMol%AtSymb(1:n_or-1)
          NewMol%AtZ(2:n_or)       =NewMol%AtZ(1:n_or-1)
          NewMol%Ptr(:,2:n_or)     =NewMol%Ptr(:,1:n_or-1)
          NewMol%I_Coor(:,2:n_or)  =NewMol%I_Coor(:,1:n_or-1)
          NewMol%mI_Coor(:,2:n_or) =NewMol%mI_Coor(:,1:n_or-1)
          NewMol%lI_Coor(:,2:n_or) =NewMol%lI_Coor(:,1:n_or-1)
          NewMol%Biso(2:n_or)      =NewMol%Biso(1:n_or-1)
          NewMol%mbiso(2:n_or)     =NewMol%mbiso(1:n_or-1)
          NewMol%lBiso(2:n_or)     =NewMol%lBiso(1:n_or-1)
          NewMol%Occ(2:n_or)       =NewMol%Occ(1:n_or-1)
          NewMol%mocc(2:n_or)      =NewMol%mocc(1:n_or-1)
          NewMol%lOcc(2:n_or)      =NewMol%lOcc(1:n_or-1)
          NewMol%Nb(2:n_or)        =NewMol%Nb(1:n_or-1)
          NewMol%INb(:,2:n_or)     =NewMol%INb(:,1:n_or-1)
          NewMol%Tb(:,2:n_or)      =NewMol%Tb(:,1:n_or-1)
          NewMol%Conn(:,2:n_or)    =NewMol%Conn(:,1:n_or-1)

          NewMol%AtName(1)    =SetMol%AtName(1)
          NewMol%AtSymb(1)    =SetMol%AtSymb(1)
          NewMol%AtZ(1)       =SetMol%AtZ(1)
          NewMol%Ptr(:,1)     =SetMol%Ptr(:,1)
          NewMol%I_Coor(:,1)  =SetMol%I_Coor(:,1)
          NewMol%mI_Coor(:,1) =SetMol%mI_Coor(:,1)
          NewMol%lI_Coor(:,1) =SetMol%lI_Coor(:,1)
          NewMol%Biso(1)      =SetMol%Biso(1)
          NewMol%mbiso(1)     =SetMol%mbiso(1)
          NewMol%lBiso(1)     =SetMol%lBiso(1)
          NewMol%Occ(1)       =SetMol%Occ(1)
          NewMol%mocc(1)      =SetMol%mocc(1)
          NewMol%lOcc(1)      =SetMol%lOcc(1)
          NewMol%Nb(1)        =SetMol%Nb(1)
          NewMol%INb(:,1)     =SetMol%INb(:,1)
          NewMol%Tb(:,1)      =SetMol%Tb(:,1)
          NewMol%Conn(:,1)    =SetMol%Conn(:,1)

          if (Newmol%is_connect) then
             do i=1,n_or
                if (newmol%conn(1,i) == n_or) then
                   newmol%conn(1,i)=1
                else if (newmol%conn(1,i) < n_or) then
                   newmol%conn(1,i)=newmol%conn(1,i)+1
                end if

                if (newmol%conn(2,i) == n_or) then
                   newmol%conn(2,i)=1
                else if (newmol%conn(2,i) < n_or) then
                   newmol%conn(2,i)=newmol%conn(2,i)+1
                end if

                if (newmol%conn(3,i) == n_or) then
                   newmol%conn(3,i)=1
                else if (newmol%conn(3,i) < n_or) then
                   newmol%conn(3,i)=newmol%conn(3,i)+1
                end if
             end do
          end if

          if (n_x < n_or) then
             n_x=n_x+1
          end if
          if (n_xy < n_or) then
             n_xy=n_xy+1
          end if
       end if

       !---- Fix X Axis ----!
       if (n_x /= 2) then

          SetMol%AtName(1)    =NewMol%AtName(n_x)
          SetMol%AtSymb(1)    =NewMol%AtSymb(n_x)
          SetMol%AtZ(1)       =NewMol%AtZ(n_x)
          SetMol%Ptr(:,1)     =NewMol%Ptr(:,n_x)
          SetMol%I_Coor(:,1)  =NewMol%I_Coor(:,n_x)
          SetMol%mI_Coor(:,1) =NewMol%mI_Coor(:,n_x)
          SetMol%lI_Coor(:,1) =NewMol%lI_Coor(:,n_x)
          SetMol%Biso(1)      =NewMol%Biso(n_x)
          SetMol%mbiso(1)     =NewMol%mbiso(n_x)
          SetMol%lBiso(1)     =NewMol%lBiso(n_x)
          SetMol%Occ(1)       =NewMol%Occ(n_x)
          SetMol%mocc(1)      =NewMol%mocc(n_x)
          SetMol%lOcc(1)      =NewMol%lOcc(n_x)
          SetMol%Nb(1)        =NewMol%Nb(n_x)
          SetMol%INb(:,1)     =NewMol%INb(:,n_x)
          SetMol%Tb(:,1)      =NewMol%Tb(:,n_x)
          SetMol%Conn(:,1)    =NewMol%Conn(:,n_x)

          NewMol%AtName(3:n_x)    =NewMol%AtName(2:n_x-1)
          NewMol%AtSymb(3:n_x)    =NewMol%AtSymb(2:n_x-1)
          NewMol%AtZ(3:n_x)       =NewMol%AtZ(2:n_x-1)
          NewMol%Ptr(:,3:n_x)     =NewMol%Ptr(:,2:n_x-1)
          NewMol%I_Coor(:,3:n_x)  =NewMol%I_Coor(:,2:n_x-1)
          NewMol%mI_Coor(:,3:n_x) =NewMol%mI_Coor(:,2:n_x-1)
          NewMol%lI_Coor(:,3:n_x) =NewMol%lI_Coor(:,2:n_x-1)
          NewMol%Biso(3:n_x)      =NewMol%Biso(2:n_x-1)
          NewMol%mbiso(3:n_x)     =NewMol%mbiso(2:n_x-1)
          NewMol%lBiso(3:n_x)     =NewMol%lBiso(2:n_x-1)
          NewMol%Occ(3:n_x)       =NewMol%Occ(2:n_x-1)
          NewMol%mocc(3:n_x)      =NewMol%mocc(2:n_x-1)
          NewMol%lOcc(3:n_x)      =NewMol%lOcc(2:n_x-1)
          NewMol%Nb(3:n_x)        =NewMol%Nb(2:n_x-1)
          NewMol%INb(:,3:n_x)     =NewMol%INb(:,2:n_x-1)
          NewMol%Tb(:,3:n_x)      =NewMol%Tb(:,2:n_x-1)
          NewMol%Conn(:,3:n_x)    =NewMol%Conn(:,2:n_x-1)

          NewMol%AtName(2)    =SetMol%AtName(1)
          NewMol%AtSymb(2)    =SetMol%AtSymb(1)
          NewMol%AtZ(2)       =SetMol%AtZ(1)
          NewMol%Ptr(:,2)     =SetMol%Ptr(:,1)
          NewMol%I_Coor(:,2)  =SetMol%I_Coor(:,1)
          NewMol%mI_Coor(:,2) =SetMol%mI_Coor(:,1)
          NewMol%lI_Coor(:,2) =SetMol%lI_Coor(:,1)
          NewMol%Biso(2)      =SetMol%Biso(1)
          NewMol%mbiso(2)     =SetMol%mbiso(1)
          NewMol%lBiso(2)     =SetMol%lBiso(1)
          NewMol%Occ(2)       =SetMol%Occ(1)
          NewMol%mocc(2)      =SetMol%mocc(1)
          NewMol%lOcc(2)      =SetMol%lOcc(1)
          NewMol%Nb(2)        =SetMol%Nb(1)
          NewMol%INb(:,2)     =SetMol%INb(:,1)
          NewMol%Tb(:,2)      =SetMol%Tb(:,1)
          NewMol%Conn(:,2)    =SetMol%Conn(:,1)

          if (Newmol%is_connect) then
             do i=1,n_x
                if (newmol%conn(1,i) == n_x) then
                   newmol%conn(1,i)=2
                else if (newmol%conn(1,i) < n_x .and. newmol%conn(1,i) > 1) then
                   newmol%conn(1,i)=newmol%conn(1,i)+1
                end if

                if (newmol%conn(2,i) == n_x) then
                   newmol%conn(2,i)=2
                else if (newmol%conn(2,i) < n_x .and. newmol%conn(2,i) > 1) then
                   newmol%conn(2,i)=newmol%conn(2,i)+1
                end if

                if (newmol%conn(3,i) == n_x) then
                   newmol%conn(3,i)=2
                else if (newmol%conn(3,i) < n_x .and. newmol%conn(3,i) > 1) then
                   newmol%conn(3,i)=newmol%conn(3,i)+1
                end if
             end do
          end if
          if (n_xy < n_x) then
             n_xy=n_xy+1
          end if
       end if

       !---- Fix XY Plane ----!
       if (n_xy /= 3) then

          SetMol%AtName(1)    =NewMol%AtName(n_xy)
          SetMol%AtSymb(1)    =NewMol%AtSymb(n_xy)
          SetMol%AtZ(1)       =NewMol%AtZ(n_xy)
          SetMol%Ptr(:,1)     =NewMol%Ptr(:,n_xy)
          SetMol%I_Coor(:,1)  =NewMol%I_Coor(:,n_xy)
          SetMol%mI_Coor(:,1) =NewMol%mI_Coor(:,n_xy)
          SetMol%lI_Coor(:,1) =NewMol%lI_Coor(:,n_xy)
          SetMol%Biso(1)      =NewMol%Biso(n_xy)
          SetMol%mbiso(1)     =NewMol%mbiso(n_xy)
          SetMol%lBiso(1)     =NewMol%lBiso(n_xy)
          SetMol%Occ(1)       =NewMol%Occ(n_xy)
          SetMol%mocc(1)      =NewMol%mocc(n_xy)
          SetMol%lOcc(1)      =NewMol%lOcc(n_xy)
          SetMol%Nb(1)        =NewMol%Nb(n_xy)
          SetMol%INb(:,1)     =NewMol%INb(:,n_xy)
          SetMol%Tb(:,1)      =NewMol%Tb(:,n_xy)
          SetMol%Conn(:,1)    =NewMol%Conn(:,n_xy)

          NewMol%AtName(4:n_xy)    =NewMol%AtName(3:n_xy-1)
          NewMol%AtSymb(4:n_xy)    =NewMol%AtSymb(3:n_xy-1)
          NewMol%AtZ(4:n_xy)       =NewMol%AtZ(3:n_xy-1)
          NewMol%Ptr(:,4:n_xy)     =NewMol%Ptr(:,3:n_xy-1)
          NewMol%I_Coor(:,4:n_xy)  =NewMol%I_Coor(:,3:n_xy-1)
          NewMol%mI_Coor(:,4:n_xy) =NewMol%mI_Coor(:,3:n_xy-1)
          NewMol%lI_Coor(:,4:n_xy) =NewMol%lI_Coor(:,3:n_xy-1)
          NewMol%Biso(4:n_xy)      =NewMol%Biso(3:n_xy-1)
          NewMol%mbiso(4:n_xy)     =NewMol%mbiso(3:n_xy-1)
          NewMol%lBiso(4:n_xy)     =NewMol%lBiso(3:n_xy-1)
          NewMol%Occ(4:n_xy)       =NewMol%Occ(3:n_xy-1)
          NewMol%mocc(4:n_xy)      =NewMol%mocc(3:n_xy-1)
          NewMol%lOcc(4:n_xy)      =NewMol%lOcc(3:n_xy-1)
          NewMol%Nb(4:n_xy)        =NewMol%Nb(3:n_xy-1)
          NewMol%INb(:,4:n_xy)     =NewMol%INb(:,3:n_xy-1)
          NewMol%Tb(:,4:n_xy)      =NewMol%Tb(:,3:n_xy-1)
          NewMol%Conn(:,4:n_xy)    =NewMol%Conn(:,3:n_xy-1)

          NewMol%AtName(3)    =SetMol%AtName(1)
          NewMol%AtSymb(3)    =SetMol%AtSymb(1)
          NewMol%AtZ(3)       =SetMol%AtZ(1)
          NewMol%Ptr(:,3)     =SetMol%Ptr(:,1)
          NewMol%I_Coor(:,3)  =SetMol%I_Coor(:,1)
          NewMol%mI_Coor(:,3) =SetMol%mI_Coor(:,1)
          NewMol%lI_Coor(:,3) =SetMol%lI_Coor(:,1)
          NewMol%Biso(3)      =SetMol%Biso(1)
          NewMol%mbiso(3)     =SetMol%mbiso(1)
          NewMol%lBiso(3)     =SetMol%lBiso(1)
          NewMol%Occ(3)       =SetMol%Occ(1)
          NewMol%mocc(3)      =SetMol%mocc(1)
          NewMol%lOcc(3)      =SetMol%lOcc(1)
          NewMol%Nb(3)        =SetMol%Nb(1)
          NewMol%INb(:,3)     =SetMol%INb(:,1)
          NewMol%Tb(:,3)      =SetMol%Tb(:,1)
          NewMol%Conn(:,3)    =SetMol%Conn(:,1)

          if (Newmol%is_connect) then
             do i=1,n_xy
                if (newmol%conn(1,i) == n_xy) then
                   newmol%conn(1,i)=3
                else if (newmol%conn(1,i) < n_xy .and. newmol%conn(1,i) > 2) then
                   newmol%conn(1,i)=newmol%conn(1,i)+1
                end if

                if (newmol%conn(2,i) == n_xy) then
                   newmol%conn(2,i)=3
                else if (newmol%conn(2,i) < n_xy .and. newmol%conn(2,i) > 2) then
                   newmol%conn(2,i)=newmol%conn(2,i)+1
                end if

                if (newmol%conn(3,i) == n_xy) then
                   newmol%conn(3,i)=3
                else if (newmol%conn(3,i) < n_xy .and. newmol%conn(3,i) > 2) then
                   newmol%conn(3,i)=newmol%conn(3,i)+1
                end if
             end do
          end if
       end if

       if (present(Newmolecule)) then
          call Init_molecule(NewMolecule,Newmol%natoms)
          if (NewMolecule%natoms <=0) then
             err_molec=.true.
             ERR_Molec_Mess="Error in Fix_Reference: The optional variable was not dimensioned!"
             return
          end if
          Newmolecule=Newmol
       else
          Molecule=Newmol
       end if

       return
    End Subroutine Fix_Reference

    !!----
    !!---- Subroutine Fix_Orient_Cartesian(Molecule, NewMolecule, NAtom_O, NAtom_X, NAtom_XY,Mat)
    !!----    type (Molecule_type),     intent(in out)           :: Molecule
    !!----    type (Molecule_type),     intent(   out), optional :: Newmolecule
    !!----    integer,                  intent(in),     optional :: NAtom_O
    !!----    integer,                  intent(in),     optional :: NAtom_X
    !!----    integer,                  intent(in),     optional :: NAtom_XY
    !!----    real(kind=cp),dimension(3,3),intent(out), optional :: Mat
    !!----
    !!----    Subroutine to transform the Cartesian coordinates of the molecule choosing
    !!----    which atom is the origin, which define the X axis and which defines the XY Plane
    !!----    If the second argument is present the subroutine creates a new molecule
    !!----    preserving the input molecule in Cartesian. Otherwise the input molecule is
    !!----    changed on output.
    !!----    If Natom_0 is absent, then the first atom on the molecule will be the origin.
    !!----    If Natom_X is absent, then the second atom on the molecule will define the X axis.
    !!----    If Natom_XY is absent, then the third atom on the molecule will define the XY Plane.
    !!----    The optional output matrix Mat is the active rotation matrix passing from the old
    !!----    Cartesian frame to the new one. The transpose matrix has served to transform the
    !!----    original Cartesian coordinates.
    !!----    Control of error is present
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Fix_Orient_Cartesian(Molecule, NewMolecule, NAtom_O, NAtom_X, NAtom_XY,Mat)
       !---- Arguments ----!
       type (Molecule_type),     intent(in out)           :: Molecule
       type (Molecule_type),     intent(   out), optional :: Newmolecule
       integer,                  intent(in),     optional :: NAtom_O
       integer,                  intent(in),     optional :: NAtom_X
       integer,                  intent(in),     optional :: NAtom_XY
       real(kind=cp),dimension(3,3),intent(out), optional :: Mat

       !---- Local variables ----!
       integer                       :: n_or, n_x, n_xy
       integer                       :: i
       real(kind=cp),dimension(3)    :: u1,u2,u3
       real(kind=cp),dimension(3,3)  :: R
       type (Molecule_type)          :: Newmol

       n_or=1
       n_x =2
       n_xy=3
       if (present(natom_O))  n_or=natom_o
       if (present(natom_x))  n_x =natom_x
       if (present(natom_xy)) n_xy=natom_xy

       if (molecule%natoms > 0) call Init_Molecule(Newmol,molecule%natoms)
       call Fix_Reference(Molecule,Newmol,n_or,n_x,n_xy)
       if (err_molec) return

       !---- Traslation the Origin ----!
       do i=2,Newmol%natoms
          newmol%I_coor(:,i)=newmol%I_coor(:,i)-newmol%I_coor(:,1)
       end do
       newmol%I_coor(:,1)=0.0

       u1=Newmol%I_coor(:,2)
       u1=u1/sqrt(dot_product(u1,u1))
       u2=Newmol%I_coor(:,3)
       u3=cross_product(u1,u2)
       u3=u3/sqrt(dot_product(u3,u3))
       u2=cross_product(u3,u1)
       R(1,:)=u1
       R(2,:)=u2  !Passive matrix needed to get the new coordinates
       R(3,:)=u3  !The active matrix can be output in the optional argument
       if (present(Mat)) Mat=transpose(R)

       do i=2,Newmol%natoms
          newmol%I_coor(:,i)=matmul(R,newmol%I_coor(:,i))
       end do

       if (present(Newmolecule)) then
          if (NewMol%natoms <=0) then
             err_molec=.true.
             ERR_Molec_Mess="Error in Fix_Orient_Cartesian: The optional variable was not dimensioned!"
             return
          end if
          Newmolecule=Newmol
       else
          Molecule=Newmol
       end if

       return
    End Subroutine Fix_Orient_Cartesian

    !!----
    !!---- Subroutine Empiric_Formula(Atm/Molcrys/Molecule,Formula,Form_Weight)
    !!----    type(Atom_List_Type),          intent(in)  :: Atm
    !!----    or
    !!----    type(molecular_crystal_type),  intent(in)  :: Molcrys
    !!----    or
    !!----    type(molecule_type),           intent(in)  :: Molecule
    !!----    character(len=*),              intent(out) :: Formula
    !!----    real(kind=cp), optional,       intent(out) :: Form_Weight
    !!----
    !!----    Obtain the Empiric Formula from Atm/Molcrys/Molecule variable
    !!----
    !!---- Update: February - 2005
    !!

    !!--++
    !!--++ Subroutine Empiric_Formula_FAtom(Atm,Formula,Form_Weight)
    !!--++    type(Atom_List_Type),    intent(in)  :: Atm
    !!--++    character(len=*),        intent(out) :: Formula
    !!--++    real(kind=cp), optional, intent(out) :: Form_Weight
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Obtain the Empiric Formula from Atm variable
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Empiric_Formula_FAtom(Atm,Formula,Form_Weight)
       !---- Arguments ----!
       type(Atom_List_Type),     intent(in)  :: Atm
       character(len=*),         intent(out) :: Formula
       real(kind=cp), optional,  intent(out) :: Form_Weight

       !---- Local variables ----!
       character(len=2)                  :: car
       character(len=5)                  :: numcar
       integer                           :: i,j
       integer, dimension(Num_Chem_Info) :: N_PT
       real(kind=cp)                     :: weight

       !---- Init ----!
       N_PT=0
       weight=0.0

       Formula=" "
       if (Atm%natoms <= 0) then
          if (present(Form_weight)) Form_weight=0.0
          return
       end if

       !---- Set Information Table ----!
       call Set_Chem_Info()

       do i=1,atm%natoms
          car=atm%atom(i)%chemsymb
          car=u_case(car)
          do j=1,Num_Chem_Info
             if (car == Chem_Info(j)%Symb) then
                n_pt(j)=n_pt(j)+1
                exit
             end if
          end do
       end do

       if (all (n_pt ==0)) then
          if (present(Form_weight)) Form_weight=0.0
          call Remove_Chem_Info()
          return
       end if

       do i=1,Num_Chem_Info
          if (n_pt(i) == 0) cycle
          car=Chem_Info(i)%Symb
          car(2:2)=l_case(car(2:2))
          write(unit=numcar,fmt="(i5)") n_pt(i)
          Formula=trim(Formula)//trim(car)//adjustl(numcar)
          weight=weight+n_pt(i)*Chem_Info(i)%atwe
       end do

       call Remove_Chem_Info()

       if (present(Form_weight)) Form_weight=weight

       return
    End Subroutine Empiric_Formula_FAtom

    !!--++
    !!--++ Subroutine Empiric_Formula_Molcrys(Molcrys,Formula,Form_Weight)
    !!--++    type(molecular_crystal_type), intent(in)  :: Molcrys
    !!--++    character(len=*),             intent(out) :: Formula
    !!--++    real(kind=cp), optional,      intent(out) :: Form_Weight
    !!--++
    !!--++    (Overloaded)
    !!--++    Obtain the Empiric Formula from Molecule variable and
    !!--++    the Weight is the variable is present.
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Empiric_Formula_Molcrys(Molcrys,Formula,Form_Weight)
       !---- Arguments ----!
       type(molecular_crystal_type), intent(in)  :: Molcrys
       character(len=*),             intent(out) :: Formula
       real(kind=cp), optional,      intent(out) :: Form_Weight

       !---- Local variables ----!
       character(len=2)                  :: car
       character(len=5)                  :: numcar
       integer                           :: i,j,k
       integer, dimension(Num_Chem_Info) :: N_PT
       real(kind=cp)                     :: weight


       !---- Init ----!
       N_PT=0
       weight=0.0

       Formula=" "

       if (molcrys%n_free <= 0 .and. molcrys%n_mol <=0) then
          if (present(Form_weight)) Form_weight=0.0
          return
       end if

       !---- Set Information Table ----!
       call Set_Chem_Info()

       do i=1,molcrys%n_free
          car=molcrys%atm(i)%chemsymb
          car=u_case(car)
          do j=1,Num_Chem_Info
             if (car == Chem_Info(j)%Symb) then
                n_pt(j)=n_pt(j)+1
                exit
             end if
          end do
       end do

       do k=1,molcrys%n_mol
          do i=1,molcrys%mol(k)%natoms
                 car=molcrys%mol(k)%atsymb(i)
             car=u_case(car)
             do j=1,Num_Chem_Info
                if (car == Chem_Info(j)%Symb) then
                   n_pt(j)=n_pt(j)+1
                   exit
                end if
             end do
          end do
       end do

       if (all (n_pt ==0)) then
          if (present(Form_weight)) Form_weight=0.0
          call Remove_Chem_Info()
          return
       end if

       do i=1,Num_Chem_Info
          if (n_pt(i) == 0) cycle
          car=Chem_Info(i)%Symb
          car(2:2)=l_case(car(2:2))
          write(unit=numcar,fmt="(i5)") n_pt(i)
          Formula=trim(Formula)//trim(car)//adjustl(numcar)
          weight=weight+n_pt(i)*Chem_Info(i)%atwe
       end do

       call Remove_Chem_Info()

       if (present(Form_weight)) Form_weight=weight

       return
    End Subroutine Empiric_Formula_Molcrys

    !!--++
    !!--++ Subroutine Empiric_Formula_Molec(Molecule,Formula,Form_Weight)
    !!--++    type(molecule_type),     intent(in)  :: Molecule
    !!--++    character(len=*),        intent(out) :: Formula
    !!--++    real(kind=cp), optional, intent(out) :: Form_Weight
    !!--++
    !!--++    (Overloaded)
    !!--++    Obtain the Empiric Formula from Molecule variable and
    !!--++    the Weight is the variable is present.
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Empiric_Formula_Molec(Molecule,Formula,Form_Weight)
       !---- Arguments ----!
       type(molecule_type),      intent(in)  :: Molecule
       character(len=*),         intent(out) :: Formula
       real(kind=cp), optional,  intent(out) :: Form_Weight

       !---- Local variables ----!
       character(len=2)                  :: car
       character(len=5)                  :: numcar
       integer                           :: i,j
       integer, dimension(Num_Chem_Info) :: N_PT
       real(kind=cp)                     :: weight

       !---- Init ----!
       N_PT=0
       weight=0.0

       Formula=" "
       if (molecule%natoms <= 0) then
          if (present(Form_weight)) Form_weight=0.0
          return
       end if

       !---- Set Information Table ----!
       call Set_Chem_Info()

       do i=1,molecule%natoms
          call Get_ChemSymb(molecule%atsymb(i),car)
          car=u_case(car)
          do j=1,Num_Chem_Info
             if (car == Chem_Info(j)%Symb) then
                n_pt(j)=n_pt(j)+1
                exit
             end if
          end do
       end do

       if (all (n_pt ==0)) then
          if (present(Form_weight)) Form_weight=0.0
          call Remove_Chem_Info()
          return
       end if

       do i=1,Num_Chem_Info
          if (n_pt(i) == 0) cycle
          car=Chem_Info(i)%Symb
          car(2:2)=l_case(car(2:2))
          write(unit=numcar,fmt="(i5)") n_pt(i)
          Formula=trim(Formula)//trim(car)//adjustl(numcar)
          weight=weight+n_pt(i)*Chem_Info(i)%atwe
       end do

       call Remove_Chem_Info()

       if (present(Form_weight)) Form_weight=weight

       return
    End Subroutine Empiric_Formula_Molec

    !!----
    !!---- Subroutine Fractional_to_Cartesian(Molecule,Cell,NewMolecule)
    !!----    type (Molecule_type),     intent(in out)           :: Molecule
    !!----    type (Crystal_Cell_Type), intent(in    )           :: Cell
    !!----    type (Molecule_type),     intent(   out), optional :: Newmolecule
    !!----
    !!----    Subroutine to transform the fractional coordinates to cartesian internal
    !!----    coordinates of a molecule.
    !!----    If Newmolecule is present the subroutine creates a new molecule
    !!----    (copy of the old one) with cartesian coordinates, preserving
    !!----    the input molecule in fractional. Otherwise the input molecule is
    !!----    changed on output.
    !!----    Control of error is present
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Fractional_to_Cartesian(Molecule,Cell,NewMolecule)
       !---- Arguments ----!
       type (Molecule_type),     intent(in out)           :: Molecule
       type (Crystal_Cell_Type), intent(in    )           :: Cell
       type (Molecule_type),     intent(   out), optional :: NewMolecule

       !---- Local variables -----!
       integer                       :: i, na
       real(kind=cp)                 :: phi,theta,chi
       real(kind=cp), dimension(3)   :: ci,xi
       real(kind=cp), dimension(3,3) :: Eu

       type (Molecule_type)          :: Newmol

       !---- Controls ----!
       if (molecule%coor_type /= "F") then
          err_molec=.true.
          ERR_Molec_Mess="Error in Fractional_to_Cartesian: the input molecule is not in fractional coordinates"
          return
       end if

       na= Molecule%natoms
       if (na <= 0) then
          err_molec=.true.
          ERR_Molec_Mess="Error in Fractional_to_Cartesian: No atoms are defined"
          return
       end if

       call Init_molecule(NewMol,na)
       NewMol=Molecule

       if (molecule%in_xtal) then
          if (newmol%is_EulerMat) then
             Eu=newmol%Euler
          else
             phi=newmol%orient(1)
             theta=newmol%orient(2)
             chi=newmol%orient(3)
             Call Set_Euler_matrix(newmol%rot_type,phi,theta,chi,Eu)
             newmol%Euler=Eu
             newmol%is_EulerMat=.true.
          end if

          !---- Newmol contains fractional coordinates ----!
          do i=1,newmol%natoms
             xi=newmol%I_coor(:,i) - newmol%xcentre !Fractional coordinates after removing translation
             ci=matmul(cell%Cr_Orth_cel,xi)       !Cartesian components in the Crystal Frame
             newmol%I_coor(1:3,i) = matmul(ci,Eu)   !Final Cartesian internal coordinates (use passive matrix!)
          end do
       else
          do i=1,newmol%natoms
             newmol%I_coor(:,i)=matmul(cell%cr_orth_cel,newmol%I_coor(:,i))
          end do
          call Fix_Orient_Cartesian(newmol)  ! Select the internal frame as needed for Z-matrices
       end if
       newmol%coor_type = "C"

       if (present(NewMolecule)) then
          call Init_molecule(NewMolecule,Newmol%natoms)
          if (NewMolecule%natoms <=0) then
             err_molec=.true.
             ERR_Molec_Mess="Error in Fractional to Cartesian: The optional variable was not dimensioned!"
             return
          end if
          NewMolecule=newmol
       else
          Molecule=newmol
       end if

       return
    End Subroutine Fractional_to_Cartesian

    !!----
    !!---- Subroutine Fractional_to_Spherical(Molecule,Cell,NewMolecule)
    !!----    type (Molecule_type), intent(in out)           :: Molecule
    !!----    type (Crystal_Cell_Type), intent(in)           :: Cell
    !!----    type (Molecule_type), intent(   out), optional :: Newmolecule
    !!----
    !!----    Subroutine to transform the internal coordinates of a
    !!----    molecule from Fractional coordinates to  Spherical coordinaters.
    !!----    If a third argument is present the subroutine creates a new
    !!----    molecule (copy of the old one) with Spherical coordinates,
    !!----    preserving the input molecule in Fractional Coordinates. Otherwise
    !!----    the input molecule is changed on output.
    !!----    Control of error is present
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Fractional_to_Spherical(Molecule, Cell, NewMolecule)
       !---- Arguments ----!
       type (Molecule_type), intent(in out)           :: Molecule
       type (Crystal_Cell_Type), intent(in)           :: Cell
       type (Molecule_type), intent(   out), optional :: NewMolecule

       !---- Local Variables ----!
       integer                     :: na
       type (Molecule_type)        :: Newmol

       !---- Controls ----!
       if (molecule%coor_type /= "F") then
          err_molec=.true.
          ERR_Molec_Mess="Error in Fractional_to_Spherical: the input molecule is not in Fractional coordinates"
          return
       end if

       na= Molecule%natoms
       if (na <= 0) then
          err_molec=.true.
          ERR_Molec_Mess="Error in Fractional_to_Spherical: No atoms are defined"
          return
       end if

       !---- Step 1----!
       call init_molecule(NewMol,na)
       NewMol= Molecule
       call Fractional_to_Cartesian(NewMol,Cell)
       if (err_molec) then
          ERR_Molec_Mess="Error in Fractional_to_Spherical: Intermediate procedure fail (I)!"
          return
       end if

       !---- Step 2 ----!
       call Cartesian_to_Spherical(NewMol)
       if (err_molec) then
          ERR_Molec_Mess="Error in Fractional_to_Spherical: Intermediate procedure fail (II)!"
          return
       end if

       !---- Step 3 ----!
       if (present(newmolecule)) then
          call Init_molecule(NewMolecule,Newmol%natoms)
          if (NewMolecule%natoms <=0) then
             err_molec=.true.
             ERR_Molec_Mess="Error in Fractional to Spherical: The optional variable was not dimensioned!"
             return
          end if
          NewMolecule=newmol
       else
          Molecule=newmol
       end if

       return
    End Subroutine Fractional_to_Spherical

    !!----
    !!---- Subroutine Fractional_to_Zmatrix(Molecule,Cell,NewMolecule)
    !!----    type (Molecule_type), intent(in out)           :: Molecule
    !!----    type (Crystal_Cell_Type), intent(in)           :: Cell
    !!----    type (Molecule_type), intent(   out), optional :: Newmolecule
    !!----
    !!----    Subroutine to transform the internal coordinates of a
    !!----    molecule from Fractional coordinates to  Zmatrix coordinaters.
    !!----    If a second argument is present the subroutine creates a new
    !!----    molecule (copy of the old one) with Zmatrix coordinates,
    !!----    preserving the input molecule in Fractional Coordinates. Otherwise
    !!----    the input molecule is changed on output.
    !!----    Control of error is present
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Fractional_to_Zmatrix(Molecule,Cell,NewMolecule)
       !---- Arguments ----!
       type (Molecule_type), intent(in out)           :: Molecule
       type (Crystal_Cell_Type), intent(in)           :: Cell
       type (Molecule_type), intent(   out), optional :: NewMolecule

       !---- Local Variables ----!
       integer                     :: na
       type (Molecule_type)        :: Newmol

       !---- Controls ----!
       if (molecule%coor_type /= "F") then
          err_molec=.true.
          ERR_Molec_Mess="Error in Fractional_to_Zmatrix: the input molecule is not in Fractional coordinates"
          return
       end if

       na= Molecule%natoms
       if (na <= 0) then
          err_molec=.true.
          ERR_Molec_Mess="Error in Fractional_to_Spherical: No atoms are defined"
          return
       end if

       !---- Step 1----!
       call Init_Molecule(NewMol,na)
       NewMol=Molecule
       call Fractional_to_Cartesian(NewMol,Cell)
       if (err_molec) then
          ERR_Molec_Mess="Error in Fractional_to_Zmatrix: Intermediate procedure fail (I)!"
          return
       end if

       !---- Step 2 ----!
       call Cartesian_to_Zmatrix(NewMol, Cell=Cell)  !The cell is needed to eventually take into account
       if (err_molec) then                           !a different Cartesian frame on the input molecule
          ERR_Molec_Mess="Error in Fractional_to_Zmatrix: Intermediate procedure fail (II)!"
          return
       end if

       !---- Step 3 ----!
       if (present(newmolecule)) then
          call Init_molecule(NewMolecule,na)
          if (NewMolecule%natoms <=0) then
             err_molec=.true.
             ERR_Molec_Mess="Error in Fractional to ZMatrix: The optional variable was not dimensioned!"
             return
          end if
          NewMolecule=newmol
       else
          Molecule=newmol
       end if

       return
    End Subroutine Fractional_to_Zmatrix

    !!--++
    !!--++ Subroutine Get_Cartesian_from_Z(ci,ri,rj,rk,rn)
    !!--++    real, dimension(3), intent ( in) :: ci,rj,rj,rn
    !!--++    real, dimension(3), intent (out) :: ri
    !!--++
    !!--++    Subroutine to calculate the cartesian coordinates of an atom (i)
    !!--++    when its distance (dij=ci(1)) to another atom (j), the angle (aijk=ci(2))
    !!--++    spanned with another atom (k) centred at (j), the torsion angle
    !!--++    (bijkn=ci(3)) with a fourth atom (n) and the coordinates of
    !!--++    the three atoms (jkn), rj,rk,rn are all given.
    !!--++
    !!--<<    The algorithm used to determine the Cartesian coordinates of atom (i) is the
    !!--++    following:
    !!--++       - Select a local Cartesian frame with (j) at origin, x-axis along (jk),
    !!--++         z-axis perpendicular to the plane (jkn), y-axis right-handled frame
    !!--++            e1 = rjk/djk, e2 = e3 x e1,  e3= rjk x rkn / djk/dkn
    !!--++       - The above system determine a matrix M = (e1,e2,e3), with components ei in columns
    !!--++         that serves to transform interatomic vector components back to the original system.
    !!--++       - In the above system the coordinates of atom (i) is given by
    !!--++            ri = rj + M ui
    !!--++
    !!--++         where
    !!--++            ui = d ( cos(aijk), cos(bijkn) sin(aijk), sqrt(1 - cos(aijk)^2 -(cos(bijkn) sin(aijk))^2))
    !!-->>
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Get_Cartesian_from_Z(ci,ri,rj,rk,rn)
       !---- Arguments ----!
       real(kind=cp), dimension(3), intent ( in) :: ci,rj,rk,rn
       real(kind=cp), dimension(3), intent (out) :: ri

       !--- Local variables ---!
       real(kind=cp)                 :: ca,cb,sa
       real(kind=cp), dimension(3)   :: r,e1,e2,e3
       real(kind=cp), dimension(3,3) :: M

       ca = cosd(ci(2))                  ! cos(aijk)
       sa = sqrt(abs(1.0_cp - ca*ca))    ! sin(aijk)
       cb = cosd(ci(3))                  ! cos(bijkn)
       r(1) = ci(1) * ca                 ! Coordinates in the local system
       r(2) = ci(1)*cb*sa
       r(3) = ci(1)*sqrt(abs(1.0_cp - ca*ca - sa*sa*cb*cb )) *sign(1.0_cp,ci(3))

       e1  = rk - rj
       e1  = e1/sqrt(dot_product(e1,e1))
       e3  = cross_product( rk - rj, rn - rk)
       e3  = e3/sqrt(dot_product(e3,e3))
       e2  = cross_product( e3, e1)
       M(:,1) = e1
       M(:,2) = e2
       M(:,3) = e3

       ri = rj + matmul(M,r)

       return
    End Subroutine Get_Cartesian_from_Z


    !!--++
    !!--++ Subroutine Get_Z_from_Cartesian(ci,ri,rj,rk,rn)
    !!--++    real, dimension(3), intent ( in) :: ri,rj,rj,rn
    !!--++    real, dimension(3), intent (out) :: ci
    !!--++
    !!--++     Subroutine to calculate the distance of an atom (i)
    !!--++     (dij=ci(1)) to another atom (j), the angle (aijk=ci(2))
    !!--++     spanned with another atom (k) centred at (j) and  the torsion angle
    !!--++     (bijkn=ci(3)) with a fourth atom (n) when the cartesian coordinates are given
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Get_Z_from_Cartesian(ci,ri,rj,rk,rn)
       !---- Arguments ----!
       real(kind=cp), dimension(3), intent ( in) :: ri,rj,rk,rn
       real(kind=cp), dimension(3), intent (out) :: ci

       !--- Local variables ---!
       real(kind=cp)                 :: dji,djk
       real(kind=cp), dimension(3)   :: rji,rjk

       rji = ri-rj
       ci(1) = sqrt(dot_product(rji,rji))
       rjk = rk-rj
       dji = ci(1)
       djk = sqrt(dot_product(rjk,rjk))
       ci(2) = acosd( dot_product(rji,rjk)/dji/djk)
       ci(3) = angle_dihedral(ri,rj,rk,rn)
       if (abs(ci(3)+180.00) <= 0.001) ci(3)=180.0

       return
    End Subroutine Get_Z_from_Cartesian

    !!----
    !!---- Subroutine Init_Err_Molec()
    !!----
    !!----    Initialize Flags of Errors in this module
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Init_Err_Molec()

       err_molec=.false.
       ERR_Molec_Mess=" "

       return
    End Subroutine Init_Err_Molec

    !!----
    !!---- Subroutine Init_Molecule(Molecule,Natm)
    !!----    type(Molecule_Type), intent(out) :: Molecule
    !!----    integer, optional,   intent(in)  :: Natm
    !!----
    !!----    Initialize the Variable Molecule
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Init_Molecule(Molecule,Natm)
       !---- Argument ----!
       type(Molecule_Type), intent(out) :: Molecule
       integer, optional,   intent(in)  :: Natm

       molecule%name_mol   =" "
       molecule%natoms     =0

       molecule%in_xtal    = .false.
       molecule%is_eulerMat= .false.
       molecule%is_connect = .false.
       molecule%rot_type   =" "
       molecule%coor_type  =" "
       molecule%therm_type =" "

       molecule%xcentre    =0.0
       molecule%mxcentre   =0.0
       molecule%lxcentre   =0

       molecule%orient     =0.0
       molecule%mOrient    =0.0
       molecule%lorient    =0

       molecule%t_tls      =0.0
       molecule%mT_TLS     =0.0
       molecule%lt_tls     =0

       molecule%l_tls      =0.0
       molecule%mL_TLS     =0.0
       molecule%ll_tls     =0

       molecule%s_tls      =0.0
       molecule%mS_TLS     =0.0
       molecule%ls_tls     =0

       molecule%euler      =0.0

       if (allocated(molecule%AtName))  deallocate(molecule%AtName)
       if (allocated(molecule%AtSymb))  deallocate(molecule%AtSymb)
       if (allocated(molecule%AtZ))     deallocate(molecule%AtZ)
       if (allocated(molecule%Ptr))     deallocate(molecule%Ptr)
       if (allocated(molecule%I_Coor))  deallocate(molecule%I_Coor)
       if (allocated(molecule%mI_Coor)) deallocate(molecule%mI_Coor)
       if (allocated(molecule%lI_Coor)) deallocate(molecule%lI_Coor)
       if (allocated(molecule%Biso))    deallocate(molecule%Biso)
       if (allocated(molecule%mbiso))   deallocate(molecule%mbiso)
       if (allocated(molecule%lBiso))   deallocate(molecule%lBiso)
       if (allocated(molecule%Occ))     deallocate(molecule%Occ)
       if (allocated(molecule%mocc))    deallocate(molecule%mocc)
       if (allocated(molecule%lOcc))    deallocate(molecule%lOcc)
       if (allocated(molecule%Nb))      deallocate(molecule%Nb)
       if (allocated(molecule%INb))     deallocate(molecule%INb)
       if (allocated(molecule%Tb))      deallocate(molecule%Tb)
       if (allocated(molecule%Conn))    deallocate(molecule%Conn)

       if (present(natm)) then
          if (natm > 0) then
             molecule%natoms=natm

             allocate(molecule%AtName(natm))
             allocate(molecule%AtSymb(natm))
             allocate(molecule%AtZ(natm))
             allocate(molecule%Ptr(2,natm))
             allocate(molecule%I_Coor(3,natm))
             allocate(molecule%mI_Coor(3,natm))
             allocate(molecule%lI_Coor(3,natm))
             allocate(molecule%Biso(natm))
             allocate(molecule%mbiso(natm))
             allocate(molecule%lBiso(natm))
             allocate(molecule%Occ(natm))
             allocate(molecule%mocc(natm))
             allocate(molecule%lOcc(natm))
             allocate(molecule%Nb(natm))
             allocate(molecule%INb(10,natm))
             allocate(molecule%Tb(10,natm))
             allocate(molecule%Conn(3,natm))

             molecule%AtName  =" "
             molecule%AtSymb  =" "
             molecule%AtZ     =0
             molecule%Ptr     =0
             molecule%I_Coor  =0.0
             molecule%mI_Coor =0.0
             molecule%lI_Coor =0
             molecule%Biso    =0.0
             molecule%mbiso   =0.0
             molecule%lBiso   =0
             molecule%Occ     =0.0
             molecule%mocc    =0.0
             molecule%lOcc    =0
             molecule%Nb      =0
             molecule%INb     =0
             molecule%Tb      =0
             molecule%Conn    =0


          end if
       end if

       return
    End Subroutine Init_Molecule
    !!----
    !!---- Subroutine Init_Molecule(Molx,Natm,Nmol)
    !!----    type(Molecular_Crystal_Type), intent(out) :: Molx
    !!----    integer, optional,            intent(in)  :: Natm
    !!----    integer, optional,            intent(in)  :: Nmol
    !!----
    !!----    Initialization for Molecular Crystal
    !!----
    !!---- Update: October - 2014
    !!
    Subroutine Init_Mol_Crys(Molx,Natm,Nmol)
        !---- Argument ----!
        type(Molecular_Crystal_Type), intent(out) :: Molx
        integer, optional,            intent(in)  :: Natm
        integer, optional,            intent(in)  :: Nmol

        integer :: i

        molx%N_Free    = 0
        molx%N_Mol     = 0
        molx%N_Species = 0
        molx%Npat      = 0

        if (allocated(molx%atm))  deallocate(molx%atm)
        if (allocated(molx%mol))  deallocate(molx%mol)

        if (present(nmol) .and. nmol > 0) then
            molx%N_Mol = nmol
            allocate(molx%mol(nmol))
            do i=1,nmol
                call init_molecule(molx%mol(i))
            end do
        end if

        if (present(natm) .and. natm > 0) then
            molx%N_Free = natm
            allocate (molx%atm(natm))
            do i=1,natm
                call init_atom_type(molx%atm(i))
            end do
        end if
        return
    End Subroutine Init_Mol_Crys
    !!----
    !!---- Subroutine Molcrys_to_AtomList(Molcrys,Atm)
    !!----    type (Molecular_Crystal_Type), intent(in)  :: Molec
    !!----    type (Atom_List_Type),         intent(out) :: Atm
    !!----
    !!---- Subroutine to pass all information from Molecular_Crystal_Type
    !!---- to Atom_List_Type
    !!----
    !!---- Update: April - 2005
    !!
    Subroutine Molcrys_to_AtomList(Molcrys,Atm)
       !---- Arguments ----!
       type (Molecular_Crystal_Type), intent(in)  :: Molcrys
       type (Atom_List_Type),         intent(out) :: Atm

       !---- Local variables ----!
       integer               :: i, n
       integer               :: Nat, NaF, NMol
       type (Atom_List_Type) :: A

       !---- Number of Atoms ----!
       NaF=molcrys%n_free
       NMol=molcrys%n_mol
       if (NMol > 0) then
          Nat=NaF+sum(molcrys%mol(1:NMol)%natoms)
       else
          Nat=NaF
       end if
       if (Nat <= 0) return

       !---- Allocating Atom_List_Type ----!
       call allocate_atom_list(Nat,Atm)

       !---- Fill information from Free atoms Part ----!
       if (naF > 0) Atm%Atom(1:NaF)=molcrys%atm(1:NaF)

       !---- Fill information from Molecules Part ----!
       n=naF
       do i=1,NMol
          if (molcrys%mol(i)%natoms <= 0) cycle
          if (.not. molcrys%mol(i)%in_xtal) cycle
          call molec_to_AtomList(molcrys%mol(i),A,"F",molcrys%cell)
          if (err_molec) return
          if (A%natoms <= 0) cycle
          Atm%Atom(n+1:n+A%natoms)=A%Atom(1:A%natoms)
          n=n+A%natoms
          call deallocate_atom_list(A)
       end do

       return
    End Subroutine Molcrys_to_AtomList

    !!----
    !!---- Subroutine Molec_to_AtomList(Molec,Atm, Coor_Type, Cell)
    !!----    type (Molecule_Type),               intent(in)  :: Molec
    !!----    type (Atom_List_Type),              intent(out) :: Atm
    !!----    character(len=*),         optional, intent(in)  :: Coor_type
    !!----    type (Crystal_Cell_type), optional, intent(in)  :: Cell
    !!----
    !!---- Subroutine to pass all information from Molecule_Type
    !!---- to Atom_List_Type. Coor_type determine the type of
    !!---- cordinates parameter in output. In general Cell if
    !!---- necessary to obtain on Output fractional coordinates or
    !!---- special case for ZMatrix.
    !!----
    !!---- Update: April - 2005
    !!
    Subroutine Molec_to_AtomList(Molec, Atm, Coor_Type, Cell)
       !---- Arguments ----!
       type (Molecule_Type),               intent(in)     :: Molec
       type (Atom_List_Type),              intent(out)    :: Atm
       character(len=*),         optional, intent(in)     :: Coor_type
       type (Crystal_Cell_type), optional, intent(in)     :: Cell

       !---- Local Variables ----!
       character(len=1)      :: car
       integer               :: i,nat
       type (Molecule_Type)  :: newmol

       !---- Number of Atoms ----!
       Nat=molec%natoms
       Atm%natoms=0
       if (Nat <= 0) return

       car="F"
       if (present(coor_type)) car=adjustl(coor_type)
       call init_molecule(newmol,nat)

       newmol=molec

       select case (car)
          case ("C")
             select case (molec%coor_type)
                case ("C")

                case ("F")
                   if (present(cell)) then
                      call Fractional_to_Cartesian(newmol,cell)
                      if (err_molec) then
                         call init_molecule(newmol)
                         return
                      end if
                   else
                      err_molec=.true.
                      ERR_Molec_Mess="You need the Cell_Type on this routine"
                      call init_molecule(newmol)
                      return
                   end if

                case ("S")
                   call Spherical_to_Cartesian(newmol)
                   if (err_molec) then
                      call init_molecule(newmol)
                      return
                   end if

                case ("Z")
                   call ZMatrix_to_Cartesian(newmol)
                   if (err_molec) then
                      call init_molecule(newmol)
                      return
                   end if

             end select

          case ("F")
             select case (molec%coor_type)
                case ("C")
                   if ( present(cell)) then
                      call Cartesian_to_Fractional(newmol,cell)
                      if (err_molec) then
                         call init_molecule(newmol)
                         return
                      end if
                   else
                      err_molec=.true.
                      ERR_Molec_Mess="You need the Cell_Type on this routine"
                      call init_molecule(newmol)
                      return
                   end if

                case ("F")

                case ("S")
                   if (present(cell)) then
                      call Spherical_to_Fractional(newmol,cell)
                      if (err_molec) then
                         call init_molecule(newmol)
                         return
                      end if
                   else
                      err_molec=.true.
                      ERR_Molec_Mess="You need the Cell_Type on this routine"
                      call init_molecule(newmol)
                      return
                   end if

                case ("Z")
                   if (present(cell)) then
                      call ZMatrix_to_Fractional(newmol,cell)
                      if (err_molec) then
                         call init_molecule(newmol)
                         return
                      end if
                   else
                      err_molec=.true.
                      ERR_Molec_Mess="You need the Cell_Type on this routine"
                      call init_molecule(newmol)
                      return
                   end if
             end select

          case ("S")
             select case (molec%coor_type)
                case ("C")
                   call Cartesian_to_Spherical(newmol)
                   if (err_molec) then
                      call init_molecule(newmol)
                      return
                   end if

                case ("F")
                   if (present(cell)) then
                      call Fractional_to_Spherical(newmol,cell)
                      if (err_molec) then
                         call init_molecule(newmol)
                         return
                      end if
                   else
                      err_molec=.true.
                      ERR_Molec_Mess="You need the Cell_Type on this routine"
                      call init_molecule(newmol)
                      return
                   end if

                case ("S")

                case ("Z")
                   call ZMatrix_to_Spherical(newmol)
                   if (err_molec) then
                      call init_molecule(newmol)
                      return
                   end if

             end select

          case ("Z")
             select case (molec%coor_type)
                case ("C")
                   if (present(cell)) then
                      call Cartesian_to_ZMatrix(newmol,cell=cell)
                   else
                      call Cartesian_to_ZMatrix(newmol)
                   end if
                   if (err_molec) then
                      call init_molecule(newmol)
                      return
                   end if

                case ("F")
                   if (present(cell)) then
                      call Fractional_to_ZMatrix(newmol,cell)
                      if (err_molec) then
                         call init_molecule(newmol)
                         return
                      end if
                   else
                      err_molec=.true.
                      ERR_Molec_Mess="You need the Cell_Type on this routine"
                      call init_molecule(newmol)
                      return
                   end if

                case ("S")
                   if (present(cell)) then
                      call Spherical_to_ZMatrix(newmol,cell=cell)
                   else
                      call Spherical_to_ZMatrix(newmol)
                   end if
                   if (err_molec) then
                      call init_molecule(newmol)
                      return
                   end if

                case ("Z")
             end select

       end select

       !---- Allocating Atom_List_Type ----!
       call allocate_atom_list(Nat,Atm)

       !---- Passing Information ----!
       Atm%Atom(1:Nat)%Lab      =Newmol%AtName(1:Nat)
       Atm%Atom(1:Nat)%SfacSymb =Newmol%AtSymb(1:Nat)
       Atm%Atom(1:Nat)%Active   =.true.
       Atm%Atom(1:Nat)%Z        =Newmol%AtZ(1:Nat)
       Atm%Atom(1:Nat)%Mult     =1
       !Atm%Atom(1:Nat)%X        =Newmol%I_Coor(:,1:Nat)
       !Atm%Atom(1:Nat)%X_Std    =0.0
       !Atm%Atom(1:Nat)%MX       =Newmol%mI_Coor(:,1:Nat)
       !Atm%Atom(1:Nat)%LX       =Newmol%lI_Coor(:,1:Nat)
       Atm%Atom(1:Nat)%Occ      =Newmol%Occ(1:Nat)
       Atm%Atom(1:Nat)%Occ_Std  =0.0
       Atm%Atom(1:Nat)%MOcc     =Newmol%mOcc(1:Nat)
       Atm%Atom(1:Nat)%LOcc     =Newmol%lOcc(1:Nat)
       Atm%Atom(1:Nat)%Biso     =Newmol%biso(1:Nat)
       Atm%Atom(1:Nat)%Biso_std =0.0
       Atm%Atom(1:Nat)%MBiso    =Newmol%mbiso(1:Nat)
       Atm%Atom(1:Nat)%LBiso    =Newmol%lbiso(1:Nat)
       Atm%Atom(1:Nat)%Utype    ="none"
       Atm%Atom(1:Nat)%ThType   ="isotr"
       !Atm%Atom(1:Nat)%U        =0.0
       !Atm%Atom(1:Nat)%U_std    =0.0
       Atm%Atom(1:Nat)%Ueq      =0.0
       !Atm%Atom(1:Nat)%MU       =0.0
       !Atm%Atom(1:Nat)%LU       =0
       Atm%Atom(1:Nat)%Charge   =0.0
       Atm%Atom(1:Nat)%Moment   =0.0
       !Atm%Atom(1:Nat)%Ind      =0
       Atm%Atom(1:Nat)%NVar     =0
       !Atm%Atom(1:Nat)%VarF     =0.0

       do i=1,Nat
          call Get_ChemSymb(Atm%Atom(i)%SfacSymb, Atm%Atom(i)%ChemSymb)
          Atm%Atom(i)%X=Newmol%I_Coor(:,i)
          Atm%Atom(i)%X_Std=0.0
          Atm%Atom(i)%mX=Newmol%mI_Coor(:,i)
          Atm%Atom(i)%lX=Newmol%lI_Coor(:,i)
          Atm%Atom(i)%U    =0.0
          Atm%Atom(i)%U_Std=0.0
          Atm%Atom(i)%mU   =0.0
          Atm%Atom(i)%lU   =0
          Atm%Atom(i)%Ind  =0
          Atm%Atom(i)%VarF =0.0
       end do

       call init_molecule(newmol)

       return
    End Subroutine Molec_to_AtomList

    !!----
    !!---- Subroutine Read_Free_Atoms(Lun,AtmF,N)
    !!----    integer,                       intent(in)   :: Lun        ! Logical unit to be rad
    !!----    type(Atom_Type), dimension(:), intent(out)  :: AtmF       ! Free atoms
    !!----    integer,                       intent(out)  :: N          ! Free atoms read
    !!----
    !!--<<    Subroutine to read a set of Free Atoms from a file.
    !!----    The format is:
    !!----        ATOMS N_Atoms
    !!----
    !!----    Internal Coordinates for Atoms (N_Atoms Lines)
    !!----        Atom_Name(6)  Atom_Specie(4)  Coordinates(3)  Biso  Occ [VARY]
    !!----
    !!----    if VARY is present as last option on the Internal Coordinates line,
    !!----    then an extra line is read
    !!----        Codes_Coordinates(3)   Code_BIso  Code_Occ
    !!-->>
    !!----
    !!----    Control of error is present
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Read_Free_Atoms(Lun, AtmF, N)
       !---- Arguments ----!
       integer,                       intent(in)   :: Lun    ! Logical unit to be rad
       type(Atom_Type), dimension(:), intent(out)  :: AtmF   ! Free atoms
       integer,                       intent(out)  :: N      ! Free atoms read

       !---- Local Variables ----!
       character(len=80)           :: line
       character(len=6)            :: label
       character(len=4)            :: var,symb
       integer                     :: i,ier,nlong,iv
       integer,       dimension(5) :: ivet
       real(kind=cp), dimension(5) :: vet

       call Init_Err_Molec()
       N=0
       do
          read(unit=lun,fmt="(a)",iostat=ier) line
          if (ier == 0) then
             line=adjustl(line)
             if (u_case(line(1:4)) /= "ATOM") cycle
          else
             err_molec=.true.
             ERR_Molec_Mess="Atoms Information not found in file! "
             return
          end if

          call cutst(line,nlong)
          call getnum(line,vet,ivet,iv)
          if (iv /= 1) then
             err_molec=.true.
             ERR_Molec_Mess="Number of Free atoms not found in file! "
             return
          end if
          N=ivet(1)
          exit
       end do

       do i=1,N
          read(unit=lun,fmt="(a)",iostat=ier) line
          if (ier /=0) then
             err_molec=.true.
             ERR_Molec_Mess="Free atoms Information was incomplete "
             return
          end if
          call cutst(line,nlong,label)
          call cutst(line,nlong,symb)

          line=u_case(line)
          var=" "
          iv=index(line,"VARY")
          if (iv /= 0) then
             line=line(1:iv-1)
             var="VARY"
          end if

          call getnum(line,vet,ivet,iv)
          select case (iv)
             case (:2)
                vet(1:3)=0.0
                vet(4)=0.0
                vet(5)=1.0
             case (3)
                vet(4)=0.0
                vet(5)=1.0
             case (4)
                vet(5)=1.0
          end select
          AtmF(i)%Lab =label
          AtmF(i)%ChemSymb=symb
          AtmF(i)%x=vet(1:3)
          AtmF(i)%biso=vet(4)
          AtmF(i)%occ =vet(5)

          if (var == "VARY") then
             do
                read(unit=lun,fmt="(a)", iostat=ier) line
                if (ier /= 0) then
                   err_molec=.true.
                   ERR_Molec_Mess="Error reading the refinement codes of free atoms "
                   return
                end if
                line=adjustl(line)
                if (line(1:1) =="!") cycle
                exit
             end do

             call getnum(line,vet,ivet,iv)
             select case (iv)
                case (3)
                   AtmF(i)%mx =vet(1:3)

                case (5)
                   AtmF(i)%mx    =vet(1:3)
                   AtmF(i)%mbiso =vet(4)
                   AtmF(i)%mocc  =vet(5)

                case default
                   err_molec=.true.
                   ERR_Molec_Mess="Error reading the refinement codes of free atoms  "
                   return
             end select
          end if

       end do

       return
    End Subroutine Read_Free_Atoms

    !!----
    !!---- Subroutine Read_Molecule(Lun,Molecule) or (File_Dat, N_Ini, N_End, Molecule)
    !!----    integer,              intent( in)           :: Lun         !  In -> Logical unit to be read
    !!----    or
    !!----    character(len=*), dimension(:), intent(in)  :: File_Dat
    !!----    integer,                        intent(in)  :: N_Ini
    !!----    integer,                        intent(in)  :: N_End
    !!----    and
    !!----    type (Molecule_type),           intent(out) :: Molecule    ! Out -> Molecule
    !!----
    !!--<<    Subroutine to read a molecule from a file
    !!----    The format is:
    !!----        MOLE[X] N_Atoms Molecule_Name Coordinates_Type
    !!----
    !!----    where:
    !!----        N_atoms             Number of atoms in the molecule definition
    !!----        Molecule_Name       Name for the molecule
    !!----        Coordinates_Type    C: Cartesian coordinates
    !!----                            F: Fractional coordinates
    !!----                            S: Spherical coordinates
    !!----                            Z: Z-Matrix coordinates
    !!----
    !!----    If keyword MOLEX is present, then the next line will be read (6 reals, 2 characters)
    !!----        Molecule_Centre(3), Molecule_Orient(3), Rotational_Angle Type(1), Thermal_Factor Type(1)
    !!----
    !!----    where:
    !!----        Molecule_Centre     Coordinate of Center of Molecule
    !!----        Molecule_Orient     Angles orientation
    !!----        Rotational Angle    E: Conventional Euler angles (alpha, beta, gamma)
    !!----                            P: Polar Euler angles (Phi, theta, Chi) (default)
    !!----        Thermal Factor    ISO: No collective motion
    !!----                          TLS: Traslational + Librational + Correlation
    !!----                           TL: Traslational + Librational
    !!----                            T: Traslational
    !!----
    !!----        According to Thermal Factors, next lines will be read
    !!----                          [T]: 6 Thermal Factors (Line1) + 6 Codes Thermal Factors (Line2)
    !!----
    !!----                         [TL]: 6 Thermal Factors (Line1) + 6 Codes Thermal Factors (Line2)
    !!----                               6 Thermal Factors (Line3) + 6 Codes Thermal Factors (Line4)
    !!----
    !!----                        [TLS]: 6 Thermal Factors (Line1) + 6 Codes Thermal Factors (Line2)
    !!----                               6 Thermal Factors (Line3) + 6 Codes Thermal Factors (Line4)
    !!----                               9 Thermal Factors (Line5) + 9 Codes Thermal Factors (Line6)
    !!----
    !!----    Internal Coordinates for Atoms (N_Atoms Lines)
    !!----        Atom_Name(6)  Atom_Specie(4)  Coordinates(3)  N1  N2  N3  Biso  Occ [VARY]
    !!----
    !!----    if VARY is present as last option on the Internal Coordinates line,
    !!----    then an extra line is read
    !!----        Codes_Coordinates(3)   Code_BIso  Code_Occ
    !!-->>
    !!----    Control of error is present
    !!----
    !!---- Update: February - 2005
    !!

    !!--++
    !!--++ Subroutine Read_Molecule_in_File(Lun,Molecule)
    !!--++    integer,              intent( in)                  :: Lun         !  In -> Logical unit to be read
    !!--++    type (Molecule_type), intent(out)                  :: Molecule    ! Out -> Molecule
    !!--++
    !!--++    (Overloaded)
    !!--++    Subroutine to read a molecule from a file.
    !!--++    The format is:
    !!--++        MOLE[X] N_Atoms Molecule_Name Coordinates_Type
    !!--++
    !!--++    where:
    !!--++        N_atoms             Number of atoms in the molecule definition
    !!--++        Molecule_Name       Name for the molecule
    !!--++        Coordinates_Type    C: Cartesian coordinates
    !!--++                            F: Fractional coordinates
    !!--++                            S: Spherical coordinates
    !!--++                            Z: Z-Matrix coordinates
    !!--++
    !!--++    If keyword MOLEX is present, then the next line will be read (6 reals, 2 characters)
    !!--++        Molecule_Centre(3), Molecule_Orient(3), Rotational_Angle Type(1), Thermal_Factor Type(1)
    !!--++
    !!--++    where:
    !!--++        Molecule_Centre     Coordinate of Center of Molecule
    !!--++        Molecule_Orient     Angles orientation
    !!--++        Rotational Angle    E: Conventional Euler angles (alpha, beta, gamma)
    !!--++                            P: Polar Euler angles (Phi, theta, Chi) (default)
    !!--++        Thermal Factor    ISO: No collective motion
    !!--++                          TLS: Traslational + Librational + Correlation
    !!--++                           TL: Traslational + Librational
    !!--++                            T: Traslational
    !!--++
    !!--++        According to Thermal Factors, next lines will be read
    !!--++                          [T]: 6 Thermal Factors (Line1) + 6 Codes Thermal Factors (Line2)
    !!--++
    !!--++                         [TL]: 6 Thermal Factors (Line1) + 6 Codes Thermal Factors (Line2)
    !!--++                               6 Thermal Factors (Line3) + 6 Codes Thermal Factors (Line4)
    !!--++
    !!--++                        [TLS]: 6 Thermal Factors (Line1) + 6 Codes Thermal Factors (Line2)
    !!--++                               6 Thermal Factors (Line3) + 6 Codes Thermal Factors (Line4)
    !!--++                               9 Thermal Factors (Line5) + 9 Codes Thermal Factors (Line6)
    !!--++
    !!--++    Internal Coordinates for Atoms (N_Atoms Lines)
    !!--++        Atom_Name(6)  Atom_Specie(4)  Coordinates(3)  N1  N2  N3  Biso  Occ [VARY]
    !!--++
    !!--++    if VARY is present as last option on the Internal Coordinates line,
    !!--++    then an extra line is read
    !!--++        Codes_Coordinates(3)   Code_BIso  Code_Occ
    !!--++
    !!--++    Control of error is present
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Read_Molecule_in_File(Lun,Molecule)
       !---- Arguments ----!
       integer,              intent(in    ) :: lun
       type (Molecule_type), intent(   out) :: Molecule

       !---- Local variables -----!
       character(len=150)              :: line
       character(len=20),dimension(10) :: dire
       character(len=4)                :: var
       integer                         :: i,j,ic,npos,na,ier
       integer,dimension(10)           :: ivet
       real(kind=cp), dimension(10)    :: vet
       real(kind=cp),dimension(3,3)    :: Eu
       logical                         :: in_xtal,mol_found

       in_xtal=.false.
       mol_found =.false.
       call Init_Err_Molec()

       do
          read(unit=lun,fmt="(a)", iostat=ier) line
          if (ier == 0) then
             line=adjustl(line)
             if (u_case(line(1:4)) /= "MOLE") cycle
          else
             if(.not. mol_found) then
              err_molec=.true.
              ERR_Molec_Mess="Molecule not found in file! "
             end if
             return
          end if

          mol_found =.true.
          if (u_case(line(1:5)) == "MOLEX") in_xtal=.true.
          i=index(line,"!")
          if( i /= 0 ) line=line(1:i-1)

          !---- Coordinates format ----!
          call getword(line,dire,ic)
          if (ic /= 4) then
             err_molec=.true.
             ERR_Molec_Mess="Instruction: MOLE[X] N_Atoms Molecule_Name Coordinates_Type, not found in file! "
             return
          end if

          !---- Name and Number of Atoms in the molecule ----!
          read(unit=dire(2),fmt=*,iostat=ier) na
          if (na > 0) then
             call init_molecule(molecule,na)
             Molecule%Name_mol =dire(3)
          else
             err_molec=.true.
             ERR_Molec_Mess="Error reading the number of atoms in a molecule: "//trim(line)
             return
          end if

          select case (dire(4)(1:1)) ! Coordinates_Type [C,S,F,Z]
             case ("C","c")
                molecule%coor_type="C"
             case ("F","f")
                molecule%coor_type="F"
             case ("S","s")
                molecule%coor_type="S"
             case ("Z","z")
                molecule%coor_type="Z"
             case default
                err_molec=.true.
                ERR_Molec_Mess="Coordinates Type for Molecule Unknown! "
                return
          end select ! dire
          exit !The molecule has been found
       end do

       !---- Initialize the crystal part of the molecule
       Molecule%xcentre    = 0.0_cp
       Molecule%orient     = 0.0_cp
       Molecule%therm_type = "   "
       Molecule%T_TLS      = 0.0_cp
       Molecule%L_TLS      = 0.0_cp
       Molecule%S_TLS      = 0.0_cp
       Molecule%in_xtal    = .false.
       Molecule%is_EulerMat=.false.

       if (in_xtal) then
          !---- Read the global coordinates of the centre of molecule and orientational angles
          do
             read(unit=lun,fmt="(a)", iostat=ier) line
             if (ier /= 0) then
                err_molec=.true.
                ERR_Molec_Mess="Error reading Molecule information! "
                return
             end if
             line=adjustl(line)
             if (line(1:1) =="!") cycle
             exit
          end do

          i=index(line,"!")
          if( i /= 0 ) line=line(1:i-1)

          call getword(line,dire,ic)
          if (ic /= 8) then
             err_molec=.true.
             ERR_Molec_Mess="Error reading the position and angles of the molecule: "//trim(Molecule%Name_mol)
             return
          end if

          line=trim(dire(1))//"   "//trim(dire(2))//"   "//trim(dire(3))
          call getnum(line,vet,ivet,ic)
          if (ic /= 3) then
             err_molec=.true.
             ERR_Molec_Mess="Error reading the position and angles of the molecule: "//trim(Molecule%Name_mol)
             return
          end if
          Molecule%xcentre=vet(1:3)

          line=trim(dire(4))//"   "//trim(dire(5))//"   "//trim(dire(6))
          call getnum(line,vet,ivet,ic)
          if (ic /= 3) then
             err_molec=.true.
             ERR_Molec_Mess="Error reading the position and angles of the molecule: "//trim(Molecule%Name_mol)
             return
          end if
          Molecule%orient=vet(1:3)

          Molecule%rot_type=adjustl(u_case(dire(7)))
          Molecule%therm_type=adjustl(u_case(dire(8)))

          do
             read(unit=lun,fmt="(a)", iostat=ier) line
             if (ier /= 0) then
                err_molec=.true.
                ERR_Molec_Mess="Error reading Molecule information! "
                return
             end if
             line=adjustl(line)
             if (line(1:1) =="!") cycle
             exit
          end do
          i=index(line,"!")
          if( i /= 0 ) line=line(1:i-1)

          call getnum(line,vet,ivet,ic)
          if (ic /= 6) then
             err_molec=.true.
             ERR_Molec_Mess="Error reading the position and angles of the molecule: "//trim(Molecule%Name_mol)
             return
          end if
          Molecule%mxcentre=vet(1:3)
          Molecule%mOrient =vet(4:6)

          Molecule%in_xtal = .true.

          !---- Set the Euler Matrix
          if (Molecule%rot_type /= "E") Molecule%rot_type="P"

          call Set_euler_matrix(Molecule%rot_type,  &
                                Molecule%orient(1),Molecule%orient(2),Molecule%orient(3),Eu)
                                !    Phi/alpha          Theta/beta          Chi/gamma
          Molecule%Euler=Eu
          Molecule%is_EulerMat=.true.

          !---- Read the THERMAL PARAMETERS
          if (Molecule%therm_type(1:1) == "T") then
             do
                read(unit=lun,fmt="(a)", iostat=ier) line
                if (ier /= 0) then
                   err_molec=.true.
                   ERR_Molec_Mess="Error reading Molecule information! "
                   return
                end if
                line=adjustl(line)
                if (line(1:1) =="!") cycle
                exit
             end do
             i=index(line,"!")
             if( i /= 0 ) line=line(1:i-1)

             call getnum(line,vet,ivet,ic)
             if (ic /= 6) then
                err_molec=.true.
                ERR_Molec_Mess="Error reading the tensor T of the molecule: "//trim(Molecule%Name_mol)
                return
             end if
             Molecule%T_TLS=vet(1:6)

             do
                read(unit=lun,fmt="(a)", iostat=ier) line
                if (ier /= 0) then
                   err_molec=.true.
                   ERR_Molec_Mess="Error reading Molecule information! "
                   return
                end if
                line=adjustl(line)
                if (line(1:1) =="!") cycle
                exit
             end do
             i=index(line,"!")
             if( i /= 0 ) line=line(1:i-1)

             call getnum(line,vet,ivet,ic)
             if (ic /= 6) then
                err_molec=.true.
                ERR_Molec_Mess="Error reading the codes of tensor T of the molecule: "//trim(Molecule%Name_mol)
                return
             end if
             Molecule%mT_TLS=vet(1:6)
          end if

          if (Molecule%therm_type(2:2) == "L") then
             do
                read(unit=lun,fmt="(a)", iostat=ier) line
                if (ier /= 0) then
                   err_molec=.true.
                   ERR_Molec_Mess="Error reading Molecule information! "
                   return
                end if
                line=adjustl(line)
                if (line(1:1) =="!") cycle
                exit
             end do
             i=index(line,"!")
             if( i /= 0 ) line=line(1:i-1)

             call getnum(line,vet,ivet,ic)
             if (ic /= 6) then
                err_molec=.true.
                ERR_Molec_Mess="Error reading the tensor L of the molecule: "//trim(Molecule%Name_mol)
                return
             end if
             Molecule%L_TLS=vet(1:6)

             do
                read(unit=lun,fmt="(a)", iostat=ier) line
                if (ier /= 0) then
                   err_molec=.true.
                   ERR_Molec_Mess="Error reading Molecule information! "
                   return
                end if
                line=adjustl(line)
                if (line(1:1) =="!") cycle
                exit
             end do
             i=index(line,"!")
             if( i /= 0 ) line=line(1:i-1)

             call getnum(line,vet,ivet,ic)
             if (ic /= 6) then
                err_molec=.true.
                ERR_Molec_Mess="Error reading the codes of the tensor L of the molecule: "//trim(Molecule%Name_mol)
                return
             end if
             Molecule%mL_TLS=vet(1:6)
          end if

          if (Molecule%therm_type(3:3) == "S") then
             do
                read(unit=lun,fmt="(a)", iostat=ier) line
                if (ier /= 0) then
                   err_molec=.true.
                   ERR_Molec_Mess="Error reading Molecule information! "
                   return
                end if
                line=adjustl(line)
                if (line(1:1) =="!") cycle
                exit
             end do
             i=index(line,"!")
             if( i /= 0 ) line=line(1:i-1)

             call getnum(line,vet,ivet,ic)
             if (ic /= 9) then
                err_molec=.true.
                ERR_Molec_Mess="Error reading the tensor S of the molecule: "//trim(Molecule%Name_mol)
                return
             end if
             Molecule%S_TLS(1,:)=vet(1:3)
             Molecule%S_TLS(2,:)=vet(4:6)
             Molecule%S_TLS(3,:)=vet(7:9)

             do
                read(unit=lun,fmt="(a)", iostat=ier) line
                if (ier /= 0) then
                   err_molec=.true.
                   ERR_Molec_Mess="Error reading Molecule information! "
                   return
                end if
                line=adjustl(line)
                if (line(1:1) =="!") cycle
                exit
             end do
             i=index(line,"!")
             if( i /= 0 ) line=line(1:i-1)

             call getnum(line,vet,ivet,ic)
             if (ic /= 9) then
                err_molec=.true.
                ERR_Molec_Mess="Error reading the code of tensor S of the molecule: "//trim(Molecule%Name_mol)
                return
             end if
             Molecule%mS_TLS(1,:)=vet(1:3)
             Molecule%mS_TLS(2,:)=vet(4:6)
             Molecule%mS_TLS(3,:)=vet(7:9)
          end if

       end if  !(in_xtal)

       !---- Read the internal coordinates of the atoms in the molecule
       !---- Read the Z-matrix/Cartesian/spherical/Fractional coordinates of the molecule
       molecule%is_connect=.true.
       do i=1,na
          do
             read(unit=lun,fmt="(a)", iostat=ier) line
             if (ier /= 0) then
                err_molec=.true.
                ERR_Molec_Mess="Error reading Molecule information! "
                return
             end if
             line=adjustl(line)
             if (line(1:1) =="!") cycle
             exit
          end do
          j=index(line,"!")
          if( j /= 0 ) line=line(1:j-1)

          !---- Atom Name ---!
          call Cutst(line,ic,Molecule%Atname(i))

          !---- Atom specie ----!
          call Cutst(line,ic,Molecule%Atsymb(i))

          !---- Passing Codes? ----!
          call getword(line,dire,ic)
          var=adjustl(dire(ic))
          var=u_case(var)
          if (var == "VARY") then
             ic=len_trim(line)
             npos=index(line(1:ic)," ",back=.true.)
             if (npos <=0) then
                err_molec=.true.
                ERR_Molec_Mess="Error reading Molecule information (II)! "
                return
             end if
             line=line(1:npos)
          end if

          !---- Rest of Information ----!
          vet =0.0
          ivet=0
          call getnum(line,vet,ivet,ic)
          select case (ic)
             case (0)
                Molecule%I_Coor(:,i)=0.0
                Molecule%Conn(:,i)  =0
                Molecule%Biso(i)    =0.5
                Molecule%Occ(i)     =1.0
             case (1)
                Molecule%I_Coor(1,i)  =vet(1)
                Molecule%I_Coor(2:3,i)=0.0
                Molecule%conn(:,i)    =0
                Molecule%biso(i)      =0.5
                Molecule%Occ(i)       =1.0

             case (2)
                Molecule%I_Coor(1:2,i)=vet(1:2)
                Molecule%I_Coor(3,i)  =0.0
                Molecule%conn(:,i)    =0
                Molecule%biso(i)      =0.5
                Molecule%Occ(i)       =1.0

             case (3)
                Molecule%I_Coor(:,i)  =vet(1:3)
                Molecule%conn(:,i)    =0
                Molecule%biso(i)      =0.5
                Molecule%Occ(i)       =1.0

             case (4)
                Molecule%I_Coor(:,i)  =vet(1:3)
                Molecule%conn(1,i)    =ivet(4)
                Molecule%conn(2:3,i)  =0
                Molecule%biso(i)      =0.5
                Molecule%Occ(i)       =1.0

             case (5)
                Molecule%I_Coor(:,i)  =vet(1:3)
                Molecule%conn(1:2,i)  =ivet(4:5)
                Molecule%conn(3,i)    =0
                Molecule%biso(i)      =0.5
                Molecule%Occ(i)       =1.0

             case (6)
                Molecule%I_Coor(:,i)  =vet(1:3)
                Molecule%conn(:,i)    =ivet(4:6)
                Molecule%biso(i)      =0.5
                Molecule%Occ(i)       =1.0

             case (7)
                Molecule%I_Coor(:,i)  =vet(1:3)
                Molecule%conn(:,i)    =ivet(4:6)
                Molecule%biso(i)      =vet(7)
                Molecule%Occ(i)       =1.0

             case (8)
                Molecule%I_Coor(:,i)  =vet(1:3)
                Molecule%conn(:,i)    =ivet(4:6)
                Molecule%biso(i)      =vet(7)
                Molecule%Occ(i)       =vet(8)

             case default
                err_molec=.true.
                ERR_Molec_Mess="Error reading the atoms in the molecule: "//trim(Molecule%Name_mol)
                return

          end select ! ic

          if (Molecule%coor_type == "Z") then

             if (i == 2 .and. (ivet(4) ==0 .and. ivet(5) ==0 .and. ivet(6) ==0)) then
                Molecule%conn(1,i)=1
             end if
             if(Molecule%I_Coor(3,i) > 180.0) Molecule%I_Coor(3,i) = Molecule%I_Coor(3,i) -360.0
             if(Molecule%I_Coor(3,i) <-180.0) Molecule%I_Coor(3,i) = Molecule%I_Coor(3,i) +360.0

             if (ivet(4) >= i .or. ivet(5) >= i .or. ivet(6) >= i )                err_molec=.true.
             if (i == 3 .and. (ivet(4) == 0 .or. ivet(5) == 0))                    err_molec=.true.
             if (i > 3 .and. (ivet(4) == 0 .or. ivet(5) == 0 .or. ivet(6) == 0))   err_molec=.true.
             if (err_molec) then
                ERR_Molec_Mess = "The Z-matrix connectivity is wrong: "//trim(line)
                return
             end if
          else
             if (ivet(4) >= i .or. ivet(5) >= i .or. ivet(6) >= i )               molecule%is_connect=.false.
             if (i == 3 .and. (ivet(4) == 0 .or. ivet(5) == 0))                   molecule%is_connect=.false.
             if (i > 3 .and. (ivet(4) == 0 .or. ivet(5) == 0 .or. ivet(6) == 0))  molecule%is_connect=.false.
          end if

          Molecule%mI_Coor(:,i)=0.0
          Molecule%mbiso(i)  =0.0
          Molecule%mocc(i)   =0.0

          if (var == "VARY") then
             do
                read(unit=lun,fmt="(a)", iostat=ier) line
                if (ier /= 0) then
                   err_molec=.true.
                   ERR_Molec_Mess="Error reading the refinement codes of atoms in the molecule: "//trim(Molecule%Name_mol)
                   return
                end if
                line=adjustl(line)
                if (line(1:1) =="!") cycle
                exit
             end do
             j=index(line,"!")
             if( j /= 0 ) line=line(1:j-1)

             call getnum(line,vet,ivet,ic)
             select case (ic)
                case (3)
                   Molecule%mI_Coor(:,i)=vet(1:3)

                case (5)
                   Molecule%mI_Coor(:,i)=vet(1:3)
                   Molecule%mbiso(i)  =vet(4)
                   Molecule%mocc(i)   =vet(5)

                case default
                   err_molec=.true.
                   ERR_Molec_Mess="Error reading the refinement codes of atoms in the molecule: "//trim(Molecule%Name_mol)
                   return
             end select
          end if

       end do

       return
    End Subroutine Read_Molecule_in_File

    !!--++
    !!--++ Subroutine Read_Molecule_in_Var(File_Dat, N_Ini, N_End, Molecule)
    !!--++    character(len=*), dimension(:), intent(in)  :: File_Dat
    !!--++    integer,                        intent(in)  :: N_Ini
    !!--++    integer,                        intent(in)  :: N_End
    !!--++    type (Molecule_type),           intent(out) :: Molecule    ! Out -> Molecule
    !!--++
    !!--++    (Overloaded)
    !!--++    Subroutine to read a molecule from a file.
    !!--++    The format is:
    !!--++        MOLE[X] N_Atoms Molecule_Name Coordinates_Type
    !!--++
    !!--++    where:
    !!--++        N_atoms             Number of atoms in the molecule definition
    !!--++        Molecule_Name       Name for the molecule
    !!--++        Coordinates_Type    C: Cartesian coordinates
    !!--++                            F: Fractional coordinates
    !!--++                            S: Spherical coordinates
    !!--++                            Z: Z-Matrix coordinates
    !!--++
    !!--++    If keyword MOLEX is present, then the next line will be read (6 reals, 2 characters)
    !!--++        Molecule_Centre(3), Molecule_Orient(3), Rotational_Angle Type(1), Thermal_Factor Type(1)
    !!--++
    !!--++    where:
    !!--++        Molecule_Centre     Coordinate of Center of Molecule
    !!--++        Molecule_Orient     Angles orientation
    !!--++        Rotational Angle    E: Conventional Euler angles (alpha, beta, gamma)
    !!--++                            P: Polar Euler angles (Phi, theta, Chi) (default)
    !!--++        Thermal Factor    ISO: No collective motion
    !!--++                          TLS: Traslational + Librational + Correlation
    !!--++                           TL: Traslational + Librational
    !!--++                            T: Traslational
    !!--++
    !!--++        According to Thermal Factors, next lines will be read
    !!--++                          [T]: 6 Thermal Factors (Line1) + 6 Codes Thermal Factors (Line2)
    !!--++
    !!--++                         [TL]: 6 Thermal Factors (Line1) + 6 Codes Thermal Factors (Line2)
    !!--++                               6 Thermal Factors (Line3) + 6 Codes Thermal Factors (Line4)
    !!--++
    !!--++                        [TLS]: 6 Thermal Factors (Line1) + 6 Codes Thermal Factors (Line2)
    !!--++                               6 Thermal Factors (Line3) + 6 Codes Thermal Factors (Line4)
    !!--++                               9 Thermal Factors (Line5) + 9 Codes Thermal Factors (Line6)
    !!--++
    !!--++    Internal Coordinates for Atoms (N_Atoms Lines)
    !!--++        Atom_Name(6)  Atom_Specie(4)  Coordinates(3)  N1  N2  N3  Biso  Occ [VARY]
    !!--++
    !!--++    if VARY is present as last option on the Internal Coordinates line,
    !!--++    then an extra line is read
    !!--++        Codes_Coordinates(3)   Code_BIso  Code_Occ
    !!--++
    !!--++    Control of error is present
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Read_Molecule_in_Var(File_dat,n_ini,n_end,Molecule)
       !---- Arguments ----!
       character(len=*), dimension(:), intent(in)      :: File_Dat
       integer,                        intent(in out)  :: N_Ini
       integer,                        intent(in)      :: N_End
       type (Molecule_type),           intent(out)     :: Molecule

       !---- Local variables -----!
       character(len=150)              :: line
       character(len=20),dimension(10) :: dire
       character(len=4)                :: var
       integer                         :: i,j,ic,npos,na,ier
       integer,dimension(10)           :: ivet
       real(kind=cp), dimension(10)    :: vet
       real(kind=cp),dimension(3,3)    :: Eu
       logical                         :: in_xtal

       in_xtal=.false.
       call Init_Err_Molec()

       n_ini=n_ini-1

       do
          n_ini=n_ini+1
          if (n_ini > n_end) then
             err_molec=.true.
             ERR_Molec_Mess="Not found Molecule"
             return
          end if
          line=adjustl(file_dat(n_ini))
          if (u_case(line(1:4)) /= "MOLE") cycle

          if (u_case(line(1:5)) == "MOLEX") in_xtal=.true.
          i=index(line,"!")
          if( i /= 0 ) line=line(1:i-1)

          !---- Coordinates format ----!
          call getword(line,dire,ic)
          if (ic /= 4) then
             err_molec=.true.
             ERR_Molec_Mess="Instruction: MOLE[X] N_Atoms Molecule_Name Coordinates_Type, not found! "
             return
          end if

          !---- Name and Number of Atoms in the molecule ----!
          read(unit=dire(2),fmt=*,iostat=ier) na
          if(ier /= 0) then
             err_molec=.true.
             ERR_Molec_Mess="Error reading the number of atoms in a molecule: "//trim(line)
             return
          else
             if (na > 0) then
                call init_molecule(molecule,na)
                Molecule%Name_mol =dire(3)
             else
                err_molec=.true.
                ERR_Molec_Mess="Error reading the number of atoms in a molecule: "//trim(line)
                return
             end if
          end if

          select case (dire(4)(1:1)) ! Coordinates_Type [C,S,F,Z]
             case ("C","c")
                molecule%coor_type="C"
             case ("F","f")
                molecule%coor_type="F"
             case ("S","s")
                molecule%coor_type="S"
             case ("Z","z")
                molecule%coor_type="Z"
             case default
                err_molec=.true.
                ERR_Molec_Mess="Coordinates Type for Molecule Unknown! "
                return
          end select ! dire

          exit !The molecule has been found

       end do

       !---- Initialize the crystal part of the molecule
       Molecule%xcentre    = 0.0_cp
       Molecule%orient     = 0.0_cp
       Molecule%therm_type = "   "
       Molecule%T_TLS      = 0.0_cp
       Molecule%L_TLS      = 0.0_cp
       Molecule%S_TLS      = 0.0_cp
       Molecule%in_xtal    = .false.
       Molecule%is_EulerMat=.false.

       if (in_xtal) then
          !---- Read the global coordinates of the centre of molecule and orientational angles
          do
             n_ini=n_ini+1
             if (n_ini > n_end) then
                err_molec=.true.
                ERR_Molec_Mess="Error reading Molecule information! "
                return
             end if
             line=adjustl(file_dat(n_ini))
             if (line(1:1) =="!") cycle
             exit
          end do

          i=index(line,"!")
          if( i /= 0 ) line=line(1:i-1)

          call getword(line,dire,ic)
          if (ic /= 8) then
             err_molec=.true.
             ERR_Molec_Mess="Error reading the position and angles of the molecule: "//trim(Molecule%Name_mol)
             return
          end if

          line=trim(dire(1))//"   "//trim(dire(2))//"   "//trim(dire(3))
          call getnum(line,vet,ivet,ic)
          if (ic /= 3) then
             err_molec=.true.
             ERR_Molec_Mess="Error reading the position and angles of the molecule: "//trim(Molecule%Name_mol)
             return
          end if
          Molecule%xcentre=vet(1:3)

          line=trim(dire(4))//"   "//trim(dire(5))//"   "//trim(dire(6))
          call getnum(line,vet,ivet,ic)
          if (ic /= 3) then
             err_molec=.true.
             ERR_Molec_Mess="Error reading the position and angles of the molecule: "//trim(Molecule%Name_mol)
             return
          end if
          Molecule%orient=vet(1:3)

          Molecule%rot_type=adjustl(u_case(dire(7)))
          Molecule%therm_type=adjustl(u_case(dire(8)))

          do
             n_ini=n_ini+1
             if (n_ini > n_end) then
                err_molec=.true.
                ERR_Molec_Mess="Error reading Molecule information! "
                return
             end if
             line=adjustl(file_dat(n_ini))
             if (line(1:1) =="!") cycle
             exit
          end do
          i=index(line,"!")
          if( i /= 0 ) line=line(1:i-1)

          call getnum(line,vet,ivet,ic)
          if (ic /= 6) then
             err_molec=.true.
             ERR_Molec_Mess="Error reading the position and angles of the molecule: "//trim(Molecule%Name_mol)
             return
          end if
          Molecule%mxcentre=vet(1:3)
          Molecule%mOrient =vet(4:6)

          Molecule%in_xtal = .true.

          !---- Set the Euler Matrix
          if (Molecule%rot_type /= "E") Molecule%rot_type="P"

          call Set_euler_matrix(Molecule%rot_type,  &
                                Molecule%orient(1),Molecule%orient(2),Molecule%orient(3),Eu)
                                !    Phi/alpha          Theta/beta          Chi/gamma
          Molecule%Euler=Eu
          Molecule%is_EulerMat=.true.

          !---- Read the THERMAL PARAMETERS
          if (Molecule%therm_type(1:1) == "T") then
             do
                n_ini=n_ini+1
                if (n_ini > n_end) then
                   err_molec=.true.
                   ERR_Molec_Mess="Error reading Molecule information! "
                   return
                end if
                line=adjustl(file_dat(n_ini))
                if (line(1:1) =="!") cycle
                exit
             end do
             i=index(line,"!")
             if( i /= 0 ) line=line(1:i-1)

             call getnum(line,vet,ivet,ic)
             if (ic /= 6) then
                err_molec=.true.
                ERR_Molec_Mess="Error reading the tensor T of the molecule: "//trim(Molecule%Name_mol)
                return
             end if
             Molecule%T_TLS=vet(1:6)

             do
                n_ini=n_ini+1
                if (n_ini > n_end) then
                   err_molec=.true.
                   ERR_Molec_Mess="Error reading Molecule information! "
                   return
                end if
                line=adjustl(file_dat(n_ini))
                if (line(1:1) =="!") cycle
                exit
             end do
             i=index(line,"!")
             if( i /= 0 ) line=line(1:i-1)

             call getnum(line,vet,ivet,ic)
             if (ic /= 6) then
                err_molec=.true.
                ERR_Molec_Mess="Error reading the codes of tensor T of the molecule: "//trim(Molecule%Name_mol)
                return
             end if
             Molecule%mT_TLS=vet(1:6)
          end if

          if (Molecule%therm_type(2:2) == "L") then
             do
                n_ini=n_ini+1
                if (n_ini > n_end) then
                   err_molec=.true.
                   ERR_Molec_Mess="Error reading Molecule information! "
                   return
                end if
                line=adjustl(file_dat(n_ini))
                if (line(1:1) =="!") cycle
                exit
             end do
             i=index(line,"!")
             if( i /= 0 ) line=line(1:i-1)

             call getnum(line,vet,ivet,ic)
             if (ic /= 6) then
                err_molec=.true.
                ERR_Molec_Mess="Error reading the tensor L of the molecule: "//trim(Molecule%Name_mol)
                return
             end if
             Molecule%L_TLS=vet(1:6)

             do
                n_ini=n_ini+1
                if (n_ini > n_end) then
                   err_molec=.true.
                   ERR_Molec_Mess="Error reading Molecule information! "
                   return
                end if
                line=adjustl(file_dat(n_ini))
                if (line(1:1) =="!") cycle
                exit
             end do
             i=index(line,"!")
             if( i /= 0 ) line=line(1:i-1)

             call getnum(line,vet,ivet,ic)
             if (ic /= 6) then
                err_molec=.true.
                ERR_Molec_Mess="Error reading the codes of the tensor L of the molecule: "//trim(Molecule%Name_mol)
                return
             end if
             Molecule%mL_TLS=vet(1:6)
          end if

          if (Molecule%therm_type(3:3) == "S") then
             do
                n_ini=n_ini+1
                if (n_ini > n_end) then
                   err_molec=.true.
                   ERR_Molec_Mess="Error reading Molecule information! "
                   return
                end if
                line=adjustl(file_dat(n_ini))
                if (line(1:1) =="!") cycle
                exit
             end do
             i=index(line,"!")
             if( i /= 0 ) line=line(1:i-1)

             call getnum(line,vet,ivet,ic)
             if (ic /= 9) then
                err_molec=.true.
                ERR_Molec_Mess="Error reading the tensor S of the molecule: "//trim(Molecule%Name_mol)
                return
             end if
             Molecule%S_TLS(1,:)=vet(1:3)
             Molecule%S_TLS(2,:)=vet(4:6)
             Molecule%S_TLS(3,:)=vet(7:9)

             do
                n_ini=n_ini+1
                if (n_ini > n_end) then
                   err_molec=.true.
                   ERR_Molec_Mess="Error reading Molecule information! "
                   return
                end if
                line=adjustl(file_dat(n_ini))
                if (line(1:1) =="!") cycle
                exit
             end do
             i=index(line,"!")
             if( i /= 0 ) line=line(1:i-1)

             call getnum(line,vet,ivet,ic)
             if (ic /= 9) then
                err_molec=.true.
                ERR_Molec_Mess="Error reading the code of tensor S of the molecule: "//trim(Molecule%Name_mol)
                return
             end if
             Molecule%mS_TLS(1,:)=vet(1:3)
             Molecule%mS_TLS(2,:)=vet(4:6)
             Molecule%mS_TLS(3,:)=vet(7:9)
          end if

       end if  !(in_xtal)

       !---- Read the internal coordinates of the atoms in the molecule
       !---- Read the Z-matrix/Cartesian/spherical/Fractional coordinates of the molecule
       molecule%is_connect=.true.
       do i=1,na
          do
             n_ini=n_ini+1
             if (n_ini > n_end) then
                err_molec=.true.
                ERR_Molec_Mess="Error reading Molecule information! "
                return
             end if
             line=adjustl(file_dat(n_ini))
             if (line(1:1) =="!") cycle
             exit
          end do
          j=index(line,"!")
          if( j /= 0 ) line=line(1:j-1)

          !---- Atom Name ---!
          call Cutst(line,ic,Molecule%Atname(i))

          !---- Atom specie ----!
          call Cutst(line,ic,Molecule%Atsymb(i))

          !---- Passing Codes? ----!
          call getword(line,dire,ic)
          var=adjustl(dire(ic))
          var=u_case(var)
          if (var == "VARY") then
             ic=len_trim(line)
             npos=index(line(1:ic)," ",back=.true.)
             if (npos <=0) then
                err_molec=.true.
                ERR_Molec_Mess="Error reading Molecule information (II)! "
                return
             end if
             line=line(1:npos)
          end if

          !---- Rest of Information ----!
          vet =0.0
          ivet=0
          call getnum(line,vet,ivet,ic)
          select case (ic)
             case (0)
                Molecule%I_Coor(:,i)=0.0
                Molecule%Conn(:,i)  =0
                Molecule%Biso(i)    =0.5
                Molecule%Occ(i)     =1.0
             case (1)
                Molecule%I_Coor(1,i)  =vet(1)
                Molecule%I_Coor(2:3,i)=0.0
                Molecule%conn(:,i)    =0
                Molecule%biso(i)      =0.5
                Molecule%Occ(i)       =1.0

             case (2)
                Molecule%I_Coor(1:2,i)=vet(1:2)
                Molecule%I_Coor(3,i)  =0.0
                Molecule%conn(:,i)    =0
                Molecule%biso(i)      =0.5
                Molecule%Occ(i)       =1.0

             case (3)
                Molecule%I_Coor(:,i)  =vet(1:3)
                Molecule%conn(:,i)    =0
                Molecule%biso(i)      =0.5
                Molecule%Occ(i)       =1.0

             case (4)
                Molecule%I_Coor(:,i)  =vet(1:3)
                Molecule%conn(1,i)    =ivet(4)
                Molecule%conn(2:3,i)  =0
                Molecule%biso(i)      =0.5
                Molecule%Occ(i)       =1.0

             case (5)
                Molecule%I_Coor(:,i)  =vet(1:3)
                Molecule%conn(1:2,i)  =ivet(4:5)
                Molecule%conn(3,i)    =0
                Molecule%biso(i)      =0.5
                Molecule%Occ(i)       =1.0

             case (6)
                Molecule%I_Coor(:,i)  =vet(1:3)
                Molecule%conn(:,i)    =ivet(4:6)
                Molecule%biso(i)      =0.5
                Molecule%Occ(i)       =1.0

             case (7)
                Molecule%I_Coor(:,i)  =vet(1:3)
                Molecule%conn(:,i)    =ivet(4:6)
                Molecule%biso(i)      =vet(7)
                Molecule%Occ(i)       =1.0

             case (8)
                Molecule%I_Coor(:,i)  =vet(1:3)
                Molecule%conn(:,i)    =ivet(4:6)
                Molecule%biso(i)      =vet(7)
                Molecule%Occ(i)       =vet(8)

             case default
                err_molec=.true.
                ERR_Molec_Mess="Error reading the atoms in the molecule: "//trim(Molecule%Name_mol)
                return

          end select ! ic

          if (Molecule%coor_type == "Z") then

             if (i == 2 .and. (ivet(4) ==0 .and. ivet(5) ==0 .and. ivet(6) ==0)) then
                Molecule%conn(1,i)=1
             end if

             if (ivet(4) >= i .or. ivet(5) >= i .or. ivet(6) >= i )                err_molec=.true.
             if (i == 3 .and. (ivet(4) == 0 .or. ivet(5) == 0))                    err_molec=.true.
             if (i > 3 .and. (ivet(4) == 0 .or. ivet(5) == 0 .or. ivet(6) == 0))   err_molec=.true.
             if (err_molec) then
                ERR_Molec_Mess = "The Z-matrix connectivity is wrong: "//trim(line)
                return
             end if
          else
             if (ivet(4) >= i .or. ivet(5) >= i .or. ivet(6) >= i )               molecule%is_connect=.false.
             if (i == 3 .and. (ivet(4) == 0 .or. ivet(5) == 0))                   molecule%is_connect=.false.
             if (i > 3 .and. (ivet(4) == 0 .or. ivet(5) == 0 .or. ivet(6) == 0))  molecule%is_connect=.false.
          end if

          Molecule%mI_Coor(:,i)=0.0
          Molecule%mbiso(i)  =0.0
          Molecule%mocc(i)   =0.0

          if (var == "VARY") then
             do
                n_ini=n_ini+1
                if (n_ini > n_end) then
                   err_molec=.true.
                   ERR_Molec_Mess="Error reading the refinement codes of atoms in the molecule: "//trim(Molecule%Name_mol)
                   return
                end if
                line=adjustl(file_dat(n_ini))
                if (line(1:1) =="!") cycle
                exit
             end do
             j=index(line,"!")
             if( j /= 0 ) line=line(1:j-1)

             call getnum(line,vet,ivet,ic)
             select case (ic)
                case (3)
                   Molecule%mI_Coor(:,i)=vet(1:3)

                case (5)
                   Molecule%mI_Coor(:,i)=vet(1:3)
                   Molecule%mbiso(i)  =vet(4)
                   Molecule%mocc(i)   =vet(5)

                case default
                   err_molec=.true.
                   ERR_Molec_Mess="Error reading the refinement codes of atoms in the molecule: "//trim(Molecule%Name_mol)
                   return
             end select
          end if

       end do

       return
    End Subroutine Read_Molecule_in_Var

    !!----
    !!---- Subroutine Set_Euler_Matrix(Rt,Phi,Theta,Chi,Eu)
    !!----    character(len=*),              intent ( in) :: Rt
    !!----    real(kind=cp),                 intent ( in) :: Phi,Theta,Chi
    !!----    real(kind=cp), dimension(3,3), intent (out) :: Eu
    !!----
    !!----    Subroutine to obtain the Euler active matrix to transform a point
    !!----    to another point. For instance the internal coordinates of a molecule
    !!----    can be transformed to absolute positions using columns vectors.
    !!----    If the Cartesian coordinates of an atom in the molecular frame is the
    !!----    column vector  Xm, the cartesian coordinates in the crystal frame X
    !!----    are obtained from:  X = Eu Xm
    !!----    The internal coordinates of a point are obtained from Xm = EuT X.
    !!----    The character variable "rt" indicates the type of Euler angles provided.
    !!----    If rt="E", the angles PHI,THETA,CHI correspond to the conventional
    !!----    Euler angles ALPHA, BETA, GAMMA. Otherwise, they correspond to the
    !!----    2nd setting, allowing to interpret PHI and THETA as the polar angles of
    !!----    the molecular frame Zm-axis, and CHI a rotation around Zm.
    !!----
    !!----   Update: February - 2005
    !!
    Subroutine Set_Euler_Matrix(Rt,Phi,Theta,Chi,Eu)
       !---- Arguments ----!
       character(len=*),              intent ( in) :: Rt
       real(kind=cp),                 intent ( in) :: Phi,Theta,Chi
       real(kind=cp), dimension(3,3), intent (out) :: Eu

       !---- Local Variables ----!
       real(kind=cp) :: PH,TH,CH

       TH=THETA
       if (rt(1:1) == "E") then
          PH=PHI+90.0_cp
          CH=CHI-90.0_cp
       else
          PH=PHI
          CH=CHI
       end if
       Eu(1,1) =  cosd(PH)* cosd(TH)* cosd(CH) - sind(PH)* sind(CH)
       Eu(1,2) = -cosd(PH)* cosd(TH)* sind(CH) - sind(PH)* cosd(CH)
       Eu(1,3) =  cosd(PH)* sind(TH)
       Eu(2,1) =  sind(PH)* cosd(TH)* cosd(CH) + cosd(PH)* sind(CH)
       Eu(2,2) = -sind(PH)* cosd(TH)* sind(CH) + cosd(PH)* cosd(CH)
       Eu(2,3) =  sind(PH)* sind(TH)
       Eu(3,1) = -cosd(CH)* sind(TH)
       Eu(3,2) =  sind(CH)* sind(TH)
       Eu(3,3) =            cosd(TH)

       return
    End Subroutine Set_Euler_Matrix

    !!----
    !!---- Subroutine Spherical_to_Cartesian(Molecule,NewMolecule)
    !!----    type (Molecule_type), intent(in out)           :: Molecule
    !!----    type (Molecule_type), intent(   out), optional :: Newmolecule
    !!----
    !!----    Subroutine to transform the internal coordinates of a molecule from Spherical
    !!----    coordinates to  cartesian coordinaters.
    !!----    If a second argument is present the subroutine creates a new molecule
    !!----    (copy of the old one) with spherical coordinates, preserving
    !!----    the input molecule in Cartesian Coordinates. Otherwise the input
    !!----    molecule is changed on output.
    !!----    Control of error is present
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Spherical_to_Cartesian(Molecule,NewMolecule)
       !---- Arguments ----!
       type (Molecule_type), intent(in out)           :: Molecule
       type (Molecule_type), intent(   out), optional :: Newmolecule

       !---- Local variables -----!
       integer                     :: i,na
       real(kind=cp)               :: r, theta, phi

       type (Molecule_type)        :: Newmol

       !---- Controls ----!
       if (molecule%coor_type /= "S") then
          err_molec=.true.
          ERR_Molec_Mess="Error in Spherical_to_Cartesian: the input molecule is not in Spherical coordinates"
          return
       end if

       na= Molecule%natoms
       if (na <= 0) then
          err_molec=.true.
          ERR_Molec_Mess="Error in Spherical_to_Cartesian: No atoms are defined"
          return
       end if

       call init_molecule(newmol,na)
       NewMol=Molecule

       !---- Start calculations for each atom of the molecule ----!
       do i=1,na
          r     = Molecule%I_coor(1,i)
          theta = Molecule%I_coor(2,i)
          phi   = Molecule%I_coor(3,i)
          NewMol%I_coor(1,i) = r*sind(theta)*cosd(phi)
          NewMol%I_coor(2,i) = r*sind(theta)*sind(phi)
          NewMol%I_coor(3,i) = r*cosd(theta)
       end do
       NewMol%coor_type="C"

       if (present(NewMolecule)) then
          call Init_molecule(NewMolecule,Newmol%natoms)
          if (NewMolecule%natoms <=0) then
             err_molec=.true.
             ERR_Molec_Mess="Error in Spherical to Cartesian: The optional variable was not dimensioned!"
             return
          end if
          NewMolecule=newmol
       else
          Molecule=newmol
       end if

       return
    End Subroutine Spherical_to_Cartesian

    !!----
    !!---- Subroutine Spherical_to_Fractional(Molecule,Cell,NewMolecule)
    !!----    type (Molecule_type), intent(in out)           :: Molecule
    !!----    type (Crystal_Cell_Type), intent(in)           :: Cell
    !!----    type (Molecule_type), intent(   out), optional :: Newmolecule
    !!----
    !!----    Subroutine to transform the internal coordinates of a
    !!----    molecule from Spherical coordinates to  Fractional coordinaters.
    !!----    If a second argument is present the subroutine creates a new
    !!----    molecule (copy of the old one) with Fractional coordinates,
    !!----    preserving the input molecule in Spherical Coordinates. Otherwise
    !!----    the input molecule is changed on output.
    !!----    Control of error is present
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Spherical_to_Fractional(Molecule, Cell, NewMolecule)
       !---- Arguments ----!
       type (Molecule_type), intent(in out)           :: Molecule
       type (Crystal_Cell_Type), intent(in)           :: Cell
       type (Molecule_type), intent(   out), optional :: NewMolecule

       !---- Local Variables ----!
       integer                     :: na
       type (Molecule_type)        :: Newmol

       !---- Controls ----!
       if (molecule%coor_type /= "S") then
          err_molec=.true.
          ERR_Molec_Mess="Error in Spherical_to_Fractional: the input molecule is not in Spherical coordinates"
          return
       end if

       na= Molecule%natoms
       if (na <= 0) then
          err_molec=.true.
          ERR_Molec_Mess="Error in Spherical_to_Fractional: No atoms are defined"
          return
       end if

       !---- Step 1----!
       call init_molecule(newmol,na)
       newmol=Molecule
       call Spherical_to_Cartesian(NewMol)
       if (err_molec) then
          ERR_Molec_Mess="Error in Spherical_to_Fractional: Intermediate procedure fail (I)!"
          return
       end if

       !---- Step 2 ----!
       call Cartesian_to_Fractional(NewMol,Cell)
       if (err_molec) then
          ERR_Molec_Mess="Error in Spherical_to_Fractional: Intermediate procedure fail (II)!"
          return
       end if

       !---- Step 3 ----!
       if (present(newmolecule)) then
          call Init_molecule(NewMolecule,na)
          if (NewMolecule%natoms <=0) then
             err_molec=.true.
             ERR_Molec_Mess="Error in Spherical to Fractional: The optional variable was not dimensioned!"
             return
          end if
          NewMolecule=newmol
       else
          Molecule=newmol
       end if

       return
    End Subroutine Spherical_to_Fractional

    !!----
    !!---- Subroutine Spherical_to_Zmatrix(Molecule,NewMolecule,Cell)
    !!----    type (Molecule_type), intent(in out)           :: Molecule
    !!----    type (Molecule_type), intent(   out), optional :: Newmolecule
    !!----    Type(Crystal_Cell_Type), intent(in),  optional :: Cell
    !!----
    !!----    Subroutine to transform the internal coordinates of a
    !!----    molecule from Spherical coordinates to  Zmatrix coordinaters.
    !!----    If a second argument is present the subroutine creates a new
    !!----    molecule (copy of the old one) with Zmatrix coordinates,
    !!----    preserving the input molecule in Spherical Coordinates. Otherwise
    !!----    the input molecule is changed on output.
    !!----    Control of error is present
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Spherical_to_Zmatrix(Molecule, NewMolecule,Cell)
       !---- Arguments ----!
       type (Molecule_type), intent(in out)           :: Molecule
       type (Molecule_type), intent(   out), optional :: NewMolecule
       Type(Crystal_Cell_Type), intent(in),  optional :: Cell

       !---- Local Variables ----!
       integer                     :: na
       type (Molecule_type)        :: Newmol

       !---- Controls ----!
       if (molecule%coor_type /= "S") then
          err_molec=.true.
          ERR_Molec_Mess="Error in Spherical_to_ZMatrix: the input molecule is not in Spherical coordinates"
          return
       end if

       na= Molecule%natoms
       if (na <= 0) then
          err_molec=.true.
          ERR_Molec_Mess="Error in Spherical_to_ZMatrix: No atoms are defined"
          return
       end if

       !---- Step 1----!
       call init_molecule(newmol,na)
       newmol= Molecule
       call Spherical_to_Cartesian(NewMol)
       if (err_molec) then
          ERR_Molec_Mess="Error in Spherical_to_Zmatrix: Intermediate procedure fail (I)!"
          return
       end if

       !---- Step 2 ----!
       if(present(Cell)) then
          call Cartesian_to_Zmatrix(NewMol,Cell=Cell)
       else
          call Cartesian_to_Zmatrix(NewMol)
       end if
       if (err_molec) then
          ERR_Molec_Mess="Error in Spherical_to_Zmatrix: Intermediate procedure fail (II)!"
          return
      end if

       !---- Step 3 ----!
       if (present(newmolecule)) then
          call Init_molecule(NewMolecule,na)
          if (NewMolecule%natoms <=0) then
             err_molec=.true.
             ERR_Molec_Mess="Error in Spherical to ZMatrix: The optional variable was not dimensioned!"
             return
          end if
          NewMolecule=newmol
       else
          Molecule=newmol
       end if

       return
    End Subroutine Spherical_to_Zmatrix

    !!----
    !!---- Subroutine Write_Free_Atoms(AtmF,N,Lun)
    !!----    type (Atom_type), dimension(:), intent(in) :: AtmF
    !!----    integer,                        intent(in) :: N
    !!----    integer, optional,              intent(in) :: Lun
    !!----
    !!----    Write information about Free Atoms for Molecular Crystal
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Write_Free_Atoms(AtmF,N,Lun)
       !---- Arguments ----!
       type (Atom_type), dimension(:), intent(in) :: AtmF
       integer,                        intent(in) :: N
       integer, optional,              intent(in) :: Lun

       !---- Local Variables ----!
       integer :: i,uni

       uni=6
       if (present(lun)) uni=lun

       write(unit=uni,fmt="(a)")     " "
       write(unit=uni,fmt="(a,i4)")  " => Number of Free Atoms: ",N
       write(unit=uni,fmt="(a)")     " "
       write (unit=uni,fmt="(T5,a)") " Atom      Chem        x/a        y/b        z/c       Occ     Biso"
       write (unit=uni,fmt="(T5,a)") "===================================================================="
       do i=1,N
          write(unit=uni,fmt="(T5,a,T16,a,T21,5f11.4)") atmF(i)%Lab,atmF(i)%chemsymb,atmF(i)%x,atmF(i)%occ,atmF(i)%biso
       end do

       return
    End Subroutine Write_Free_Atoms

    !!----
    !!---- Subroutine Write_Molecular_Crystal(MolCrys,Lun)
    !!----    type (Molecular_Crystal_type), intent(in) :: MolCrys
    !!----    integer, optional,             intent(in) :: Lun
    !!----
    !!----    Write information about Molecular Crystal
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Write_Molecular_Crystal(MolCrys,Lun)
       !---- Arguments ----!
       type(Molecular_Crystal_Type), intent(in) :: MolCrys
       integer, optional,            Intent(in) :: Lun

       !---- Local Variables ----!
       integer :: i,uni

       uni=6
       if (present(lun)) uni=lun

       write(unit=uni,fmt="(/,/,a)") "      Molecular Crystal Information  "
       write(unit=uni,fmt="(a)")     "      ----------------------------- "

       write(unit=uni,fmt="(a)")     " "
       call Write_Crystal_Cell(MolCrys%Cell,uni)
       write(unit=uni,fmt="(a)")     " "

       write(unit=uni,fmt="(a)")     " "
       call Write_SpaceGroup(MolCrys%SPG,uni)
       write(unit=uni,fmt="(a)")     " "

       if (MolCrys%N_Free > 0) then
          write(unit=uni,fmt="(a)")     " "
          call Write_Free_Atoms(MolCrys%Atm,MolCrys%N_Free,uni)
          write(unit=uni,fmt="(a)")     " "
       end if

       if (MolCrys%N_Mol > 0) then
          do i=1,MolCrys%N_Mol
             write(unit=uni,fmt="(a)")     " "
             call Write_Molecule(MolCrys%Mol(i),uni)
             write(unit=uni,fmt="(a)")     " "
          end do
       end if

       return
    End Subroutine Write_Molecular_Crystal

    !!----
    !!---- Subroutine Write_Molecule(Molecule,Lun)
    !!----    type (Molecule_type), intent(in)           :: Molecule
    !!----    integer,              intent(in), optional :: Lun
    !!----
    !!----    Write information about molecule
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Write_Molecule(Molecule,Lun)
       !---- Arguments ----!
       type (Molecule_type), intent(in):: Molecule
       integer,optional,     intent(in):: Lun

       !---- Local variables -----!
       integer            :: i,uni,j
       character(len=4)   :: var
       real(kind=cp), dimension(3  ) :: geom_cent

       uni=6
       if (present(lun)) uni=lun

       write(unit=uni,fmt="(/,/,a,a)")    " =>  MOLECULE of name :  ",trim(Molecule%Name_mol)
       select case (molecule%coor_type)
          case ("C","c")
             write(unit=uni,fmt="(a)")     "            Type of Molecular description: CARTESIAN COORDINATES"
          case ("F","f")
             write(unit=uni,fmt="(a)")     "            Type of Molecular description: FRACTIONAL COORDINATES"
          case ("S","s")
             write(unit=uni,fmt="(a)")     "            Type of Molecular description: SPHERICAL COORDINATES"
          case ("Z","z")
             write(unit=uni,fmt="(a)")     "            Type of Molecular description: Z-MATRIX"
          case default
             write(unit=uni,fmt="(a)")     "            Type of Molecular description: UNKNOWN "
       end select ! molecule%coor_type

       write(unit=uni,fmt="(a,i3)")     "                          Number of atoms: ",  Molecule%natoms
       if (Molecule%in_xtal) then
          write(unit=uni,fmt="(a,3f11.5)")   "         Fractional coordinates of centre: ",  Molecule%xcentre
          write(unit=uni,fmt="(a,3f11.5)")   "                         Refinement codes: ",  Molecule%mxcentre

          if (Molecule%rot_type == "E") then
             write(unit=uni,fmt="(a,3f11.5,a,3f9.5,a)") &
                                 "   Orientation EULER angles (alp,bet,gam): ",  Molecule%orient,&
                                 " (radians:", Molecule%orient*to_rad,")"
          else
             write(unit=uni,fmt="(a,3f11.5,a,3f9.5,a)") &
                                 "   Orientation POLAR angles (PHI,THE,CHI): ",  Molecule%orient,&
                                 " (radians:", Molecule%orient*to_rad,")"
          end if
          write(unit=uni,fmt="(a,3f11.5)") "                         Refinement codes: ",  Molecule%mOrient

          if (Molecule%therm_type(1:1) == "T") then
             write(unit=uni,fmt="(a,6f11.5)")"       T-tensor (T11,T22,T33,T12,T13,T23): ", Molecule%T_TLS
             write(unit=uni,fmt="(a,6f11.5)")"                         Refinement codes: ", Molecule%mT_TLS
          end if

          if (Molecule%therm_type(2:2) == "L") then
             write(unit=uni,fmt="(a,6f11.5)")"       L-tensor (L11,L22,L33,L12,L13,L23): ", Molecule%L_TLS
             write(unit=uni,fmt="(a,6f11.5)")"                         Refinement codes: ", Molecule%mL_TLS
          end if

          if (Molecule%therm_type(3:3) == "S") then
             write(unit=uni,fmt="(a,3f11.5,tr5,3f11.5)")"       S-tensor             (S11,S12,S13): ", &
                                              Molecule%S_TLS(1,:), Molecule%mS_TLS(1,:)
             write(unit=uni,fmt="(a,3f11.5,tr5,3f11.5)")"     + Refinement codes     (S21,S22,S23): ", &
                                              Molecule%S_TLS(2,:), Molecule%mS_TLS(2,:)
             write(unit=uni,fmt="(a,3f11.5,tr5,3f11.5)")"                            (S31,S32,S33): ", &
                                              Molecule%S_TLS(3,:), Molecule%mS_TLS(3,:)
          end if

          select case (Molecule%coor_type)
             case ("C","c")
                write(unit=uni,fmt="(t29,a)")"Atom    Type        XC          YC          ZC    N1  N2  N3      Biso        Occ "
             case ("F","f")
                write(unit=uni,fmt="(t29,a)")"Atom    Type        X           Y           Z     N1  N2  N3      Biso        Occ "
             case ("S","s")
                write(unit=uni,fmt="(t29,a)")"Atom    Type    distance      Theta       Phi     N1  N2  N3      Biso        Occ "
             case ("Z","z")
                write(unit=uni,fmt="(t29,a)")"Atom    Type    distance  Bond-Angle Torsion-Ang  N1  N2  N3      Biso        Occ "
             case default
                write(unit=uni,fmt="(t29,a)")"Atom    Type      Coor1       Coor2       Coor3   N1  N2  N3      Biso        Occ "
          end select ! Molecule%coor_type

       else  !(Molecule%in_xtal)

          select case (Molecule%coor_type)
             case ("C","c")
                write(unit=uni,fmt="(t29,a)")"Atom    Type        XC          YC          ZC    N1  N2  N3 "
             case ("F","f")
                write(unit=uni,fmt="(t29,a)")"Atom    Type        X           Y           Z     N1  N2  N3 "
             case ("S","s")
                write(unit=uni,fmt="(t29,a)")"Atom    Type    distance      Theta       Phi     N1  N2  N3 "
             case ("Z","z")
                write(unit=uni,fmt="(t29,a)")"Atom    Type    distance  Bond-Angle Torsion-Ang  N1  N2  N3 "
             case default
                write(unit=uni,fmt="(t29,a)")"Atom    Type      Coor1       Coor2       Coor3   N1  N2  N3 "
          end select ! Molecule%coor_type

       end if  !(Molecule%in_xtal)

          geom_cent=0.0_cp

          if (Molecule%in_xtal ) then
             do i=1,Molecule%natoms
                  if(Molecule%AtSymb(i) /= "ZE") geom_cent=geom_cent + Molecule%I_Coor(:,i)
                  write(unit=uni,fmt="(t29,a,tr2,a,3f12.5,3i4,2f12.5)")  &
                       Molecule%AtName(i), Molecule%AtSymb(i),Molecule%I_Coor(:,i),  &
                       Molecule%Conn(:,i), Molecule%Biso(i),  Molecule%Occ(i)
                  var="    "
                  do j=1,3
                     if (abs(Molecule%mI_Coor(j,i)) > eps) var="VARY"
                  end do
                  if (abs(Molecule%mbiso(i)) > eps)      var="VARY"
                  if (abs(Molecule%mocc(i))  > eps)      var="VARY"
                  if (var == "VARY") then
                     write(unit=uni,fmt="(t41,3f12.5,tr12,2f12.5)")  Molecule%mI_Coor(:,i), &
                          Molecule%mbiso(i),Molecule%mocc(i)
                  end if
             end do
          else
             do i=1,Molecule%natoms
                  if(Molecule%AtSymb(i) /= "DU") geom_cent=geom_cent + Molecule%I_Coor(:,i)
                  write(unit=uni,fmt="(t29,a,tr2,a,3f12.5,3i4       )")  &
                  Molecule%Atname(i), Molecule%Atsymb(i), Molecule%I_coor(:,i),  &
                  Molecule%conn(:,i)
             end do
          end if

       if(      molecule%coor_type == "C" .or. molecule%coor_type == "c" &
           .or. molecule%coor_type == "F" .or. molecule%coor_type == "f") then
           geom_cent=geom_cent/real(Molecule%natoms)
           write(unit=uni,fmt="(//,a,3F10.5)")  "  => Geometrical centre of molecule ( "//trim(Molecule%Name_mol)//" ):", geom_cent
       end if

       write(unit=uni,fmt="(/,a)")              "  => Euler Matrix of molecule ( "//trim(Molecule%Name_mol)//" ):"
       do i=1,3
          write(unit=uni,fmt="(t29,3f10.5)")  Molecule%Euler(i,:)
       end do

       return
    End Subroutine Write_Molecule

    !!----
    !!---- Subroutine Zmatrix_to_Cartesian(Molecule,NewMolecule)
    !!----    type (Molecule_type), intent(in out)           :: Molecule
    !!----    type (Molecule_type), intent(   out), optional :: NewMolecule
    !!----
    !!----    Subroutine to transform the internal coordinates of a molecule from
    !!----    Z-matrix to cartesian coordinates.
    !!----    If a second argument is present the subroutine creates a new molecule
    !!----    (copy of the old one) with cartesian coordinates, preserving
    !!----    the input molecule. Otherwise the input molecule is changed on output.
    !!----    Control of error is present
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Zmatrix_to_Cartesian(Molecule,NewMolecule)
       !---- Arguments ----!
       type (Molecule_type), intent(in out)           :: Molecule
       type (Molecule_type), intent(   out), optional :: NewMolecule

       !---- Local variables -----!
       integer                     :: i,na,j,k,n
       real(kind=cp)               :: dist, ang
       real(kind=cp), dimension(3) :: ci,ri,rj,rk,rn

       type (Molecule_type)        :: Newmol

       !---- Controls ----!
       if (molecule%coor_type /= "Z") then
          err_molec=.true.
          ERR_Molec_Mess="Error in Zmatrix_to_Cartesian: the input molecule is not a Z-matrix"
          return
       end if

       na= Molecule%natoms
       if (na <= 0) then
          err_molec=.true.
          ERR_Molec_Mess="Error in Zmatrix_to_Cartesian: Not atoms are defined"
          return
       end if

       call init_molecule(newmol,na)
       NewMol=Molecule

       !---- Start calculations for each atom of the molecule ----!

       !---- First atom is always at origin (Z-matrix)
       NewMol%I_coor(:,1) = 0.0_cp
       NewMol%conn(:,1) = 0

       !---- Second atom is always along "x"
       NewMol%I_coor(2:3,2) = 0.0
       NewMol%conn(2:3,2) = 0
       NewMol%conn(1,2)   = 1

       !--- Third atom is always in the "xy" plane       !A(i) d_ij  ang_ijk   dang_ijkl  j k l
       if (NewMol%conn(1,3) == 1) then
          NewMol%conn(2,3) = 2
          NewMol%conn(3,3) = 0
          dist= NewMol%I_coor(1,3)
          ang = NewMol%I_coor(2,3)
          NewMol%I_coor(1,3) = dist * cosd(ang)
          NewMol%I_coor(2,3) = dist * sind(ang)
          NewMol%I_coor(3,3) = 0.0_cp
       else
          NewMol%conn(1,3) = 2
          NewMol%conn(2,3) = 1
          NewMol%conn(3,3) = 0
          dist= NewMol%I_coor(1,3)
          ang = NewMol%I_coor(2,3)
          NewMol%I_coor(1,3) = dist * cosd(180.0_cp-ang) +  NewMol%I_coor(1,2)
          NewMol%I_coor(2,3) = dist * sind(180.0_cp-ang)
          NewMol%I_coor(3,3) = 0.0_cp
       end if

       do i=4,na
          ci(:) = NewMol%I_coor(:,i)
          j     = NewMol%conn(1,i)         !The connectivity is needed for the Z-matrix description
          k     = NewMol%conn(2,i)         !If the connectivity is given it is possible to transform to
          n     = NewMol%conn(3,i)         !Z-matrix if cartesian/spherical coordinates are given.
          if (j == 0 .or. k == 0 .or. n == 0) cycle
          rj(:) = NewMol%I_coor(:,j)
          rk(:) = NewMol%I_coor(:,k)
          rn(:) = NewMol%I_coor(:,n)
          call get_cartesian_from_Z(ci,ri,rj,rk,rn)
          NewMol%I_coor(:,i) = ri
       end do
       NewMol%coor_type="C"

       if (present(NewMolecule)) then
          call Init_molecule(NewMolecule,na)
          if (NewMolecule%natoms <=0) then
             err_molec=.true.
             ERR_Molec_Mess="Error in ZMatrix to Cartesian: The optional variable was not dimensioned!"
             return
          end if
          NewMolecule=newmol
       else
          Molecule=newmol
       end if

       return
    End Subroutine Zmatrix_to_Cartesian

    !!----
    !!---- Subroutine Zmatrix_to_Fractional(Molecule,Cell,NewMolecule)
    !!----    type (Molecule_type),     intent(in out)           :: Molecule
    !!----    type (Crystal_Cell_Type), intent(in    )           :: Cell
    !!----    type (Molecule_type),     intent(   out), optional :: NewMolecule
    !!----
    !!----    Subroutine to transform the internal coordinates of a molecule from
    !!----    Z-matrix to fractional coordinates.
    !!----    If a third argument is present the subroutine creates a new molecule
    !!----    (copy of the old one) with fractional coordinates, preserving
    !!----    the input molecule in Z-matrix. Otherwise the input molecule is changed on output.
    !!----    Control of error is present
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Zmatrix_to_Fractional(Molecule,Cell,NewMolecule)
       !---- Arguments ----!
       type (Molecule_type),     intent(in out)           :: Molecule
       type (Crystal_Cell_Type), intent(in    )           :: Cell
       type (Molecule_type),     intent(   out), optional :: NewMolecule

       !---- Local variables -----!
       integer                       :: na
       type (Molecule_type)          :: Newmol

       !---- Controls ----!
       if (molecule%coor_type /= "Z") then
          err_molec=.true.
          ERR_Molec_Mess="Error in Zmatrix_to_Fractional: the input molecule is not in Zmatrix coordinates"
          return
       end if

       na=molecule%natoms
       if (na <= 0) then
          err_molec=.true.
          ERR_Molec_Mess="Error in Zmatrix_to_Fractional: No atoms found"
          return
       end if

       call init_molecule(newmol,na)
       newmol= molecule
       call Zmatrix_to_Cartesian(newmol)
       call Cartesian_to_Fractional(newmol,cell)

       if (present(NewMolecule)) then
          call Init_molecule(NewMolecule,Newmol%natoms)
          if (NewMolecule%natoms <=0) then
             err_molec=.true.
             ERR_Molec_Mess="Error in ZMatrix_to_Fractional: The optional variable was not dimensioned!"
             return
          end if
          NewMolecule=newmol
       else
          Molecule=newmol
       end if

       return
    End Subroutine Zmatrix_to_Fractional

    !!----
    !!---- Subroutine Zmatrix_to_Spherical(Molecule,NewMolecule)
    !!----    type (Molecule_type), intent(in out)           :: Molecule
    !!----    type (Molecule_type), intent(   out), optional :: Newmolecule
    !!----
    !!----    Subroutine to transform the internal coordinates of a
    !!----    molecule from Zmatrix coordinates to  Spherical coordinaters.
    !!----    If a second argument is present the subroutine creates a new
    !!----    molecule (copy of the old one) with Spherical coordinates,
    !!----    preserving the input molecule in Zmatrix Coordinates. Otherwise
    !!----    the input molecule is changed on output.
    !!----    Control of error is present
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Zmatrix_to_Spherical(Molecule, NewMolecule)
       !---- Arguments ----!
       type (Molecule_type), intent(in out)           :: Molecule
       type (Molecule_type), intent(   out), optional :: NewMolecule

       !---- Local Variables ----!
       integer                     :: na
       type (Molecule_type)        :: Newmol

       !---- Controls ----!
       if (molecule%coor_type /= "Z") then
          err_molec=.true.
          ERR_Molec_Mess="Error in Zmatrix_to_Spherical: the input molecule is not in Zmatrix coordinates"
          return
       end if

       na=molecule%natoms
       if (na <= 0) then
          err_molec=.true.
          ERR_Molec_Mess="Error in Zmatrix_to_Fractional: No atoms found"
          return
       end if

       !---- Step 1----!
       call init_Molecule(newmol,na)
       newmol=Molecule
       call Zmatrix_to_Cartesian(NewMol)
       if (err_molec) then
          ERR_Molec_Mess="Error in Zmatrix_to_Spherical: Intermediate procedure fail (I)!"
          return
       end if

       !---- Step 2 ----!
       call Cartesian_to_Spherical(NewMol)
       if (err_molec) then
          ERR_Molec_Mess="Error in Zmatrix_to_Spherical: Intermediate procedure fail (II)!"
          return
       end if

       !---- Step 3 ----!
       if (present(newmolecule)) then
          call Init_molecule(NewMolecule,na)
          if (NewMolecule%natoms <=0) then
             err_molec=.true.
             ERR_Molec_Mess="Error in ZMatrix to Spherical: The optional variable was not dimensioned!"
             return
          end if
          NewMolecule=newmol
       else
          Molecule=newmol
       end if

       return
    End Subroutine Zmatrix_to_Spherical

 End Module CFML_Molecular_Crystals
!!-------------------------------------------------------
!!---- Crystallographic Fortran Modules Library (CrysFML)
!!-------------------------------------------------------
!!---- The CrysFML project is distributed under LGPL. In agreement with the
!!---- Intergovernmental Convention of the ILL, this software cannot be used
!!---- in military applications.
!!----
!!---- Copyright (C) 1999-2012  Institut Laue-Langevin (ILL), Grenoble, FRANCE
!!----                          Universidad de La Laguna (ULL), Tenerife, SPAIN
!!----                          Laboratoire Leon Brillouin(LLB), Saclay, FRANCE
!!----
!!---- Authors: Juan Rodriguez-Carvajal (ILL)
!!----          Javier Gonzalez-Platas  (ULL)
!!----
!!---- Contributors: Laurent Chapon     (ILL)
!!----               Marc Janoschek     (Los Alamos National Laboratory, USA)
!!----               Oksana Zaharko     (Paul Scherrer Institute, Switzerland)
!!----               Tierry Roisnel     (CDIFX,Rennes France)
!!----               Eric Pellegrini    (ILL)
!!----
!!---- This library is free software; you can redistribute it and/or
!!---- modify it under the terms of the GNU Lesser General Public
!!---- License as published by the Free Software Foundation; either
!!---- version 3.0 of the License, or (at your option) any later version.
!!----
!!---- This library is distributed in the hope that it will be useful,
!!---- but WITHOUT ANY WARRANTY; without even the implied warranty of
!!---- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
!!---- Lesser General Public License for more details.
!!----
!!---- You should have received a copy of the GNU Lesser General Public
!!---- License along with this library; if not, see <http://www.gnu.org/licenses/>.
!!----
!!----
!!---- MODULE: CFML_IO_Formats
!!----   INFO: Creation/Conversion for several formats
!!----
!!---- HISTORY
!!----    Update: 07/03/2011
!!----
!!----
!!---- DEPENDENCIES
!!----
!!---- VARIABLES
!!----    ERR_FORM
!!----    ERR_FORM_MESS
!!----    INTERVAL_TYPE
!!----    JOB_INFO_TYPE
!!----
!!---- PROCEDURES
!!----    Functions:
!!----
!!----    Subroutines:
!!----       FILE_TO_FILELIST
!!----       GET_JOB_INFO
!!----       GET_PHASES_FILE
!!--++       GET_NPHASES_CIFFILE
!!--++       GET_NPHASES_PCRFILE
!!----       INIT_ERR_FORM
!!----       READ_ATOM
!!----       READ_CELL
!!----       READ_CIF_ATOM
!!----       READ_CIF_CELL
!!----       READ_CIF_CHEMICALNAME
!!----       READ_CIF_CONT
!!----       READ_CIF_HALL
!!----       READ_CIF_HM
!!----       READ_CIF_LAMBDA
!!----       READ_CIF_SYMM
!!----       READ_CIF_TITLE
!!----       READ_CIF_Z
!!----       READ_FILE_ATOM
!!--++       READ_FILE_ATOMLIST             [Overloaded]
!!--++       READ_FILE_POINTLIST            [Overloaded]
!!----       READ_FILE_CELL
!!--++       READ_FILE_CELLc                [Overloaded]
!!--++       READ_FILE_CELLt                [Overloaded]
!!----       READ_FILE_LAMBDA
!!----       READ_FILE_RNGSINTL
!!----       READ_FILE_SPG
!!----       READ_FILE_TRANSF
!!----       READ_SHX_ATOM
!!----       READ_SHX_CELL
!!----       READ_SHX_CONT
!!----       READ_SHX_FVAR
!!----       READ_SHX_LATT
!!----       READ_SHX_SYMM
!!----       READ_SHX_TITL
!!----       READ_UVALS
!!--++       READN_SET_XTAL_CFL             [Private]
!!--++       READN_SET_XTAL_CFL_MOLEC       [Private]
!!--++       READN_SET_XTAL_CIF             [Private]
!!--++       READN_SET_XTAL_PCR             [Private]
!!--++       READN_SET_XTAL_SHX             [Private]
!!----       READN_SET_XTAL_STRUCTURE
!!--++       READN_SET_XTAL_STRUCTURE_MOLCR [Overloaded]
!!--++       READN_SET_XTAL_STRUCTURE_SPLIT [Overloaded]
!!----       WRITE_CIF_POWDER_PROFILE
!!----       WRITE_CIF_TEMPLATE
!!----       WRITE_SHX_TEMPLATE
!!----
!!
 Module CFML_IO_Formats

    !---- Use modules ----!
    Use CFML_GlobalDeps,                only: cp,sp,pi,eps
    Use CFML_Math_General,              only: sind
    Use CFML_String_Utilities
    Use CFML_Crystal_Metrics,           only: Crystal_Cell_Type, Set_Crystal_Cell, Convert_U_Betas, &
                                              Convert_B_Betas, U_Equiv, Convert_Betas_U
    Use CFML_Crystallographic_Symmetry, only: Space_Group_Type, Set_SpaceGroup, Get_Multip_Pos
    Use CFML_Atom_TypeDef,              only: Atom_Type, Init_Atom_Type,atom_list_type,         &
                                              Allocate_atom_list, Deallocate_atom_list
    Use CFML_Molecular_Crystals,        only: Err_Molec, Err_Molec_Mess,Molecular_Crystal_Type, &
                                              Read_Molecule, Set_Euler_Matrix, Write_Molecule
    Use CFML_Geometry_Calc,             only: Point_List_Type, Get_Euler_from_Fract

    !---- Variables ----!
    implicit none

    private


    !---- List of public functions ----!

    !---- List of public subroutines ----!
    public :: Init_Err_Form, Read_Atom, Read_Cell, Read_Cif_Atom, Read_Cif_Cell,                 &
              Read_Cif_Cont, Read_Cif_Hall, Read_Cif_Hm, Read_Cif_Lambda, Read_Cif_Symm,         &
              Read_Cif_Title, Read_Cif_Z, Read_File_Atom, Read_File_Spg, Read_Cif_ChemicalName,  &
              Read_File_Transf, Read_Shx_Atom, Read_Shx_Cell, Read_Shx_Cont, Read_Shx_Fvar,      &
              Read_Shx_Latt, Read_Shx_Symm, Read_Shx_Titl, Read_Uvals, Write_Cif_Powder_Profile, &
              Write_Cif_Template, Write_Shx_Template, Read_File_rngSINTL, Read_File_Lambda,      &
              Get_job_info, File_To_FileList, Get_Phases_File

    !---- List of public overloaded procedures: subroutines ----!
    public :: Read_File_Cell, Readn_Set_Xtal_Structure, Write_Atoms_CFL, Write_CFL

    !---- List of private functions ----!

    !---- List of private subroutines ----!
    private:: Read_File_Cellc, Read_File_Cellt, Read_File_Atomlist,Read_File_Pointlist,               &
              Readn_Set_Xtal_CFL, Readn_Set_Xtal_CIF, Readn_Set_Xtal_PCR,Readn_Set_Xtal_SHX,          &
              Readn_Set_Xtal_CFL_Molec, Readn_Set_Xtal_Structure_Split,                               &
              Readn_Set_Xtal_Structure_Molcr, Get_NPhases_CIFFile,Get_NPHases_PCRFile,                &
              Write_CFL_Molcrys, Write_CFL_Atom_List_Type, Write_Atoms_CFL_ATM, Write_Atoms_CFL_MOLX, &
              Write_Atoms_CFL_MOLX_orig

    !---- Definitions ----!


    !!----
    !!---- ERR_FORM
    !!----    logical, public :: err_form
    !!----
    !!----    Logical Variable indicating an error in CFML_IO_Formats
    !!----
    !!---- Update: February - 2005
    !!
    logical, public :: err_form

    !!----
    !!---- ERR_FORM_MESS
    !!----    character(len=150), public :: ERR_Form_Mess
    !!----
    !!----    String containing information about the last error
    !!----
    !!---- Update: February - 2005
    !!
    character(len=150),       public  :: ERR_Form_Mess

    !!----
    !!---- EPSS
    !!----    real(kind=cp), parameter, private :: epss=1.0e-5_cp
    !!----
    !!----    Private small real number for floating point comparisons
    !!----
    !!---- Update: February - 2011
    !!
    real(kind=cp), parameter, private :: epss=1.0e-5_cp

    !!----
    !!---- TYPE :: INTERVAL_TYPE
    !!--..
    !!---- Type, public :: interval_type
    !!----    real(kind=cp) :: mina  !low limit
    !!----    real(kind=cp) :: maxb  !high limit
    !!---- End Type interval_type
    !!----
    !!---- Update: February - 2005
    !!
    Type, public :: interval_type
       real(kind=cp) :: mina  !low limit
       real(kind=cp) :: maxb  !high limit
    End Type interval_type

    !!----
    !!---- TYPE :: JOB_INFO_TYPE
    !!--..
    !!---- Type, public :: Job_Info_type
    !!----    character(len=120)                            :: Title          ! Title
    !!----    integer                                       :: Num_Phases     ! Number of phases
    !!----    integer                                       :: Num_Patterns   ! Number of patterns
    !!----    integer                                       :: Num_cmd        ! Number of command lines
    !!----    character(len=16),  dimension(:), allocatable :: Patt_typ       ! Type of Pattern
    !!----    character(len=128), dimension(:), allocatable :: Phas_nam       ! Name of phases
    !!----    character(len=128), dimension(:), allocatable :: cmd            ! Command lines: text for actions
    !!----    type(interval_type),dimension(:), allocatable :: range_stl      ! Range in sinTheta/Lambda
    !!----    type(interval_type),dimension(:), allocatable :: range_q        ! Range in 4pi*sinTheta/Lambda
    !!----    type(interval_type),dimension(:), allocatable :: range_d        ! Range in d-spacing
    !!----    type(interval_type),dimension(:), allocatable :: range_2theta   ! Range in 2theta-spacing
    !!----    type(interval_type),dimension(:), allocatable :: range_Energy   ! Range in Energy
    !!----    type(interval_type),dimension(:), allocatable :: range_tof      ! Range in Time of Flight
    !!----    type(interval_type),dimension(:), allocatable :: Lambda         ! Lambda
    !!----    real(kind=cp)      ,dimension(:), allocatable :: ratio          ! ratio lambda2/lambda1
    !!----    real(kind=cp)      ,dimension(:), allocatable :: dtt1,dtt2      ! d-to-TOF coefficients
    !!---- End Type Job_Info_type
    !!----
    !!---- Update: February - 2005
    !!
    Type, public :: Job_Info_type
       character(len=120)                            :: Title
       integer                                       :: Num_Phases
       integer                                       :: Num_Patterns
       integer                                       :: Num_cmd
       character(len=16),  dimension(:), allocatable :: Patt_typ
       character(len=128), dimension(:), allocatable :: Phas_nam
       character(len=128), dimension(:), allocatable :: cmd
       type(interval_type),dimension(:), allocatable :: range_stl
       type(interval_type),dimension(:), allocatable :: range_q
       type(interval_type),dimension(:), allocatable :: range_d
       type(interval_type),dimension(:), allocatable :: range_2theta
       type(interval_type),dimension(:), allocatable :: range_Energy
       type(interval_type),dimension(:), allocatable :: range_tof
       type(interval_type),dimension(:), allocatable :: Lambda
       real(kind=cp)      ,dimension(:), allocatable :: ratio
       real(kind=cp)      ,dimension(:), allocatable :: dtt1,dtt2
    End Type Job_Info_type

    !!----
    !!---- TYPE :: FILE_LIST_TYPE
    !!--..
    !!---- Type,public :: File_List_Type
    !!----    integer                                       :: nlines ! Number of lines in the file
    !!----    character(len=256), allocatable, dimension(:) :: line   ! Content of the lines
    !!---- End Type file_list_type
    !!----
    !!---- Updated: February - 2005, November 2012
    !!
    Type,public :: File_List_Type
       integer                                       :: nlines
       character(len=256), allocatable, dimension(:) :: line
    End Type File_List_Type


    !---- Interfaces - Overloaded procedures--!
    Interface  Read_File_Cell
       Module Procedure Read_File_Cellc  !Last Output Argument Vector Of Six Component With The Cell Parameters
       Module Procedure Read_File_Cellt  !Last output argument object of type Crystal_cell_type
    End interface

    Interface Read_File_Atom
       Module Procedure Read_File_Atomlist   !Last Output Argument of type Atom_list_type
       Module Procedure Read_File_Pointlist  !Last output argument of type Point_list_type
    End Interface

    Interface Readn_Set_Xtal_Structure
       Module Procedure Readn_Set_Xtal_Structure_Molcr ! For Molecular Crystal Type
       Module Procedure Readn_Set_Xtal_Structure_Split ! For Cell, Spg, A types
    End Interface

    Interface Write_CFL
       Module Procedure Write_CFL_Molcrys        ! For Molecular Crystal Type
       Module Procedure Write_CFL_Atom_List_Type ! For Cell, Spg, A Types
    End Interface

    Interface Write_Atoms_CFL
       Module Procedure Write_Atoms_CFL_MOLX ! For Molecular Crystal Type
       Module Procedure Write_Atoms_CFL_ATM  ! For Cell, Spg, A Types
    End Interface

 Contains

    !---- Functions ----!

    !---- Subroutines ----!

    !!----
    !!---- Subroutine File_To_FileList(File_dat,File_list)
    !!----   character(len=*),     intent( in) :: file_dat  !Input data file
    !!----   type(file_list_type), intent(out) :: file_list !File list structure
    !!----
    !!----    Charge an external file to an object of File_List_Type.
    !!----
    !!---- Update: August - 2008
    !!
    Subroutine File_To_FileList(File_dat,File_list)
       !---- Arguments ----!
       character(len=*),      intent( in) :: file_dat
       type(file_list_type),  intent(out) :: file_list

       !---- Local Variables ----!
       integer                           :: nlines

       !---- Number of Lines in the input file ----!
       call Number_Lines(trim(File_dat), nlines)

       if (nlines==0) then
          err_form=.true.
          ERR_Form_Mess="The file "//trim(File_dat)//" contains nothing"
          return
       else
          file_list%nlines=nlines
          if (allocated(file_list%line)) deallocate(file_list%line)
          allocate(file_list%line(nlines))
          call reading_Lines(trim(File_dat),nlines,file_list%line)
       end if

       return
    End Subroutine File_To_FileList

    !!----
    !!---- Subroutine Get_Job_Info(file_dat,i_ini,i_end,Job_info)
    !!----   character(len=*), dimension(:), intent( in) :: file_dat     !Lines of text (content of a file)
    !!----   integer,                        intent( in) :: i_ini,i_end  !Lines to explore
    !!----   type(job_info_type),            intent(out) :: Job_info     !Object to be constructed here
    !!----
    !!----
    !!----    Constructor of the object Job_info. The arrary of strings file_dat
    !!----    have to be provided as input. It contains lines corresponding to the
    !!----    input control file. The analysis of the command lines is not given here.
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Get_Job_Info(file_dat,i_ini,i_end,Job_info)
       !---- Arguments ----!
       character(len=*), dimension(:), intent( in) :: file_dat
       integer,                        intent( in) :: i_ini,i_end
       type(job_info_type),            intent(out) :: Job_info

       !---- Local Variables ----!
       integer                           :: i,nphas, ncmd,n_pat,ier, j
       integer, dimension(i_end-i_ini+1) :: ip,ic,ipt
       real(kind=sp)                     :: a1,a2,a3,a4,a5
       character(len=120)                :: line, fmtfields, fmtformat

       !--- Initialize FindFMT
       call Init_FindFMT(i_ini)
       nphas=0
       ncmd=0
       n_pat=0
       ip=i_end
       ic=0
       ipt=0
       Job_info%title=" General Job: CrysFML"
       Job_info%Num_Patterns=1

       do i=i_ini,i_end
          line=u_case(adjustl(file_dat(i)))
          if (line(1:5) == "TITLE") Job_info%title=line(7:)
          if (line(1:5) == "NPATT") then
             read(unit=line(7:), fmt=*,iostat=ier) Job_info%Num_Patterns
             if (ier /= 0) Job_info%Num_Patterns=1
          end if
          if (line(1:6) == "PHASE_") then
             nphas=nphas+1
             ip(nphas)=i
          end if
          if (line(1:4) == "CMDL") then
             ncmd=ncmd+1
             ic(ncmd)=i
          end if
          if (line(1:5) == "PATT_") then
             n_pat=n_pat+1
             ipt(n_pat)=i
          end if
       end do

       if (nphas == 0) then
          nphas=1
          ip(nphas)=0
       end if
       if (n_pat == 0) then
          n_pat=1
          ipt(n_pat) = 0
       end if

       if (Job_info%Num_Patterns /= n_pat) Job_info%Num_Patterns = n_pat
       Job_info%Num_Phases=nphas
       Job_info%Num_Cmd=ncmd

       if (allocated(Job_Info%Patt_typ)) deallocate(Job_Info%Patt_typ)
       allocate(Job_Info%Patt_typ(n_pat))

       if (allocated(Job_Info%Phas_nam)) deallocate(Job_Info%Phas_nam)
       allocate(Job_Info%Phas_nam(nphas))

       if (allocated(Job_Info%range_stl)) deallocate(Job_Info%range_stl)
       allocate(Job_Info%range_stl(n_pat))

       if (allocated(Job_Info%range_q)) deallocate(Job_Info%range_q)
       allocate(Job_Info%range_q(n_pat))

       if (allocated(Job_Info%range_d)) deallocate(Job_Info%range_d)
       allocate(Job_Info%range_d(n_pat))

       if (allocated(Job_Info%range_2theta)) deallocate(Job_Info%range_2theta)
       allocate(Job_Info%range_2theta(n_pat))

       if (allocated(Job_Info%range_energy)) deallocate(Job_Info%range_energy)
       allocate(Job_Info%range_energy(n_pat))

       if (allocated(Job_Info%range_tof)) deallocate(Job_Info%range_tof)
       allocate(Job_Info%range_tof(n_pat))

       if (allocated(Job_Info%lambda)) deallocate(Job_Info%lambda)
       allocate(Job_Info%lambda(n_pat))

       if (allocated(Job_Info%ratio)) deallocate(Job_Info%ratio)
       allocate(Job_Info%ratio(n_pat))

       if (allocated(Job_Info%dtt1)) deallocate(Job_Info%dtt1)
       allocate(Job_Info%dtt1(n_pat))

       if (allocated(Job_Info%dtt2)) deallocate(Job_Info%dtt2)
       allocate(Job_Info%dtt2(n_pat))

       !---- Initialize all variables
       Job_Info%Patt_typ    =" "
       Job_Info%Phas_nam    =" "
       Job_Info%range_stl%mina=0.0
       Job_Info%range_stl%maxb=0.0
       Job_Info%range_q%mina=0.0
       Job_Info%range_q%maxb=0.0
       Job_Info%range_d%mina=0.0
       Job_Info%range_d%maxb=0.0
       Job_Info%range_2theta%mina=0.0
       Job_Info%range_2theta%maxb=0.0
       Job_Info%range_Energy%mina=0.0
       Job_Info%range_Energy%maxb=0.0
       Job_Info%range_tof%mina=0.0
       Job_Info%range_tof%maxb=0.0
       Job_Info%Lambda%mina=0.0
       Job_Info%Lambda%maxb=0.0
       Job_Info%ratio = 0.0
       Job_Info%dtt1 = 0.0
       Job_Info%dtt2 = 0.0
       if (ncmd > 0) then
          if (allocated(Job_Info%cmd)) deallocate(Job_Info%cmd)
          allocate(Job_Info%cmd(ncmd))
          Job_Info%cmd=" "
       end if

       !---- Fill the different fields of Job_Info
       !---- Start with patterns
       fmtfields = "9fffff"

       !---- First asks if there is a PATT_ card, if not a standard is taken
       if (ipt(1) /= 0) then
          do n_pat=1, Job_info%Num_Patterns
             i=ipt(n_pat)
             line=u_case(adjustl(file_dat(i)))
             line=line(8:)
             call findfmt(0,line,fmtfields,fmtformat)
             read(unit=line,fmt=fmtformat) Job_Info%Patt_typ(n_pat), a1,a2,a3,a4,a5
             if (ierr_fmt /= 0) return
             line=u_case(Job_Info%Patt_typ(n_pat))

             select case(line(1:9))
                case("XRAY_2THE","NEUT_2THE","XRAY_SXTA","NEUT_SXTA")
                   if ( a1 <= 0.000001) a1=1.5405
                   if ( a2 <= 0.000001) then
                      a2=a1
                      a3=0.0
                   end if
                   if (a5 <= a4) a5=120.0
                   Job_Info%Lambda(n_pat)%mina=a1
                   Job_Info%Lambda(n_pat)%maxb=a2
                   Job_Info%ratio(n_pat)=a3
                   Job_Info%range_2theta(n_pat)%mina=a4
                   Job_Info%range_2theta(n_pat)%maxb=a5
                   a4=sind(0.5*a4)/a1
                   a5=sind(0.5*a5)/a2
                   Job_Info%range_stl(n_pat)%mina=a4
                   Job_Info%range_stl(n_pat)%maxb=a5
                   Job_Info%range_q(n_pat)%mina=a4*4.0*pi
                   Job_Info%range_q(n_pat)%maxb=a5*4.0*pi
                   Job_Info%range_d(n_pat)%mina=0.5/a5
                   Job_Info%range_d(n_pat)%maxb=0.5/a4

                case("NEUT_TOF ")
                   if (a1 <= 0.000001) a1=1000.0
                   if (a4 <= a3) a4=2.0*abs(a3)
                   Job_Info%dtt1(n_pat)=a1
                   Job_Info%dtt2(n_pat)=a2
                   Job_Info%range_tof(n_pat)%mina=a3
                   Job_Info%range_tof(n_pat)%maxb=a4
                   Job_Info%range_d(n_pat)%mina=0.5*(-1.0+sqrt(1.0+4.0*a2*a3/a1/a1))
                   Job_Info%range_d(n_pat)%maxb=0.5*(-1.0+sqrt(1.0+4.0*a2*a4/a1/a1))
                   Job_Info%range_stl(n_pat)%mina=0.5/Job_Info%range_d(n_pat)%maxb
                   Job_Info%range_stl(n_pat)%maxb=0.5/Job_Info%range_d(n_pat)%mina
                   Job_Info%range_q(n_pat)%mina=Job_Info%range_stl(n_pat)%mina*4.0*pi
                   Job_Info%range_q(n_pat)%maxb=Job_Info%range_stl(n_pat)%maxb*4.0*pi

                case("XRAY_ENER")
                   if (a1 <= 0.000001) a1=12.4 !(=hc(keV.Angstr.)
                   Job_Info%dtt1(n_pat)=a1
                   Job_Info%dtt2(n_pat)=0.0
                   Job_Info%range_energy(n_pat)%mina=a3
                   Job_Info%range_energy(n_pat)%maxb=a4
                   if (a3 <= 0.00001) a3=0.01
                   if (a4 <= 0.00001) a4=2.00
                   Job_Info%range_d(n_pat)%mina=a1/a4
                   Job_Info%range_d(n_pat)%maxb=a1/a3
                   Job_Info%range_stl(n_pat)%mina=0.5/Job_Info%range_d(n_pat)%maxb
                   Job_Info%range_stl(n_pat)%maxb=0.5/Job_Info%range_d(n_pat)%mina
                   Job_Info%range_q(n_pat)%mina=Job_Info%range_stl(n_pat)%mina*4.0*pi
                   Job_Info%range_q(n_pat)%maxb=Job_Info%range_stl(n_pat)%maxb*4.0*pi

             end select
          end do

       else
          n_pat=1
          a1=1.5405
          a2=a1
          a3=0.0
          a4=0.0
          a5=120.0
          Job_Info%Patt_typ(n_pat)="XRAY_2THE"
          Job_Info%Lambda(n_pat)%mina=a1
          Job_Info%Lambda(n_pat)%maxb=a2
          Job_Info%ratio(n_pat)=a3
          Job_Info%range_2theta(n_pat)%mina=a4
          Job_Info%range_2theta(n_pat)%maxb=a5
          a4=sind(0.5*a4)/a1
          a5=sind(0.5*a5)/a2
          Job_Info%range_stl(n_pat)%mina=a4
          Job_Info%range_stl(n_pat)%maxb=a5
          Job_Info%range_q(n_pat)%mina=a4*4.0*pi
          Job_Info%range_q(n_pat)%maxb=a5*4.0*pi
          Job_Info%range_d(n_pat)%mina=0.5/a5
          Job_Info%range_d(n_pat)%maxb=0.5/a4
       end if

       !---- Phase names
       if (ip(1) /= 0) then
          do i=1,nphas
             j=ip(i)
             line=adjustl(file_dat(j))
             Job_Info%Phas_nam(i)=line(8:)
          end do
       else
          Job_Info%Phas_nam(1)= Job_info%title
       end if

       !---- Command Lines, stored but not analysed here
       do i=1,ncmd
          j=ic(i)
          line=adjustl(file_dat(j))
          Job_Info%cmd(i)=line(8:)
       end do

       return
    End Subroutine Get_Job_Info

    !!----
    !!---- Subroutine Init_Err_Form()
    !!----
    !!----    Initialize Errors Variable for this module
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Init_Err_Form()

       err_form=.false.
       ERR_Form_Mess=" "

       return
    End Subroutine Init_Err_Form

    !!----
    !!---- Subroutine Read_Atom(Line,Atomo)
    !!----    character(len=*), intent(in out ) :: line    !  In -> Input String with ATOM directive
    !!----    Type (Atom_Type), intent(out)     :: Atomo   ! Out -> Parameters on variable Atomo
    !!----
    !!----    Subroutine to read the atom parameters from a given "line"
    !!----    it construct the object Atomo of type Atom.
    !!----    Control of error is present
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Read_Atom(line,Atomo)
       !---- Arguments ----!
       character(len=*), intent(in out ) :: line
       Type (Atom_Type), intent(out)     :: Atomo

       !---- Local variables -----!
       integer                           :: iv, nlong1,n,ier,q
       real(kind=cp), dimension (10)     :: vet1
       real(kind=cp), dimension (10)     :: vet2
       character(len=4)                  :: dire
       character(len=5)                  :: label
       character(len=132), dimension(1)  :: filevar
       character(len=*), parameter       :: digpm="0123456789+-"

       !---- Init ----!
       call init_err_form()
       call init_atom_type(Atomo)
       q=0
       iv=index(line,"#")
       if(iv /= 0) atomo%AtmInfo=line(iv+1:)

       call cutst(line,nlong1,dire)
       if (u_case(dire) /= "ATOM") then
          err_form=.true.
          ERR_Form_Mess=" Error reading the ATOM keyword"
          return
       end if

       !---- Atom Label ----!
       call cutst(line,nlong1,label)
       atomo%lab=label(1:5)

       !---- Atom Type (Chemical symbol & Scattering Factor) ----!
       call cutst(line,nlong1,label)
       n=index(digpm,label(2:2))
       if (n /=0) then
         atomo%chemsymb=U_case(label(1:1))
       else
         atomo%chemsymb=U_case(label(1:1))//L_case(label(2:2))
       end if
       atomo%SfacSymb=label(1:4)

       !---- Parameters ----!
       filevar(1)="atm "//trim(line)

       n=1
       call Read_Key_ValueSTD(filevar,n,n,"atm",vet1,vet2,iv)
      ! call getnum(line,vet,ivet,iv)
       if (iv <= 0) then
          err_form=.true.
          ERR_Form_Mess= "Error reading parameters of atom:"//atomo%lab
          return
       end if

       !---- Coordinates  ----!
       if (iv < 3) then
          err_form=.true.
          ERR_Form_Mess= "Error reading Coordinates of atom:"//atomo%lab
          return
       end if

       atomo%x(:)=vet1(1:3)
       atomo%x_std(:)=vet2(1:3)

       !---- Biso ----!
       if (iv > 3) then
         atomo%biso=vet1(4)
         atomo%biso_std=vet2(4)
       end if

       !---- Occ ----!
       if (iv > 4) then
          atomo%occ=vet1(5)
          atomo%occ_std=vet2(5)
       end if

       !---- Moment ----!
       if (iv > 5) atomo%moment=vet1(6)

       !---- Charge ----!
       if (iv > 6) atomo%charge=vet1(7)

       !Attempt to get the oxidation state from "Label"
       if(abs(atomo%charge) < eps) then
         iv=index(label,"+")
         Select Case(iv)
           Case(0) !No + sign
             n=index(label,"-")
             Select Case(n)
               Case(2) !Element with a single character symbol F-1
                  read(unit=label(3:),fmt="(i1)",iostat=ier)  q
                  if (ier /= 0) q=0
               Case(3) !Element in the form: F1- or Br-1
                  read(unit=label(2:2),fmt="(i1)",iostat=ier)  q
                  if (ier /= 0) then
                        read(unit=label(4:4),fmt="(i1)",iostat=ier)  q
                        if (ier /= 0) q=0
                  end if
               Case(4) !Element in the form: Br1-
                  read(unit=label(3:3),fmt="(i1)",iostat=ier)  q
                  if (ier /= 0) q=0
             End Select
             q=-q   !anions
           Case(2) !Element with a single character symbol C+4
                  read(unit=label(3:),fmt="(i1)",iostat=ier)  q
                  if (ier /= 0) q=0
           Case(3) !Element in the form: C4+ or Fe+3
                  read(unit=label(2:2),fmt="(i1)",iostat=ier)  q
                  if (ier /= 0) then
                        read(unit=label(4:4),fmt="(i1)",iostat=ier)  q
                        if (ier /= 0) q=0
                  end if
           Case(4) !Element in the form: Fe3+
                  read(unit=label(3:3),fmt="(i1)",iostat=ier)  q
                  if (ier /= 0) q=0
         End Select
         atomo%charge=real(q)
       end if
       return
    End Subroutine Read_Atom

    !!----
    !!---- Subroutine Read_Cell(Line,Celda)
    !!----    character(len=*),          intent(in out ) :: line   !  In -> Input String with CELL Directive
    !!----    real(kind=cp),dimension(6),intent(out)     :: Celda  !  In -> Parameters on Celda Variable
    !!----
    !!----    Subroutine to read the cell parameters from a given "line"
    !!----    it construct the object Celda of type Crystal_Cell.
    !!----    Assumes the string "line" has been read from a file and
    !!----    starts with the word "cell", that is removed before reading
    !!----    the values of the parameters.
    !!----    Control of error is present
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Read_Cell(line,Celda)
       !---- Arguments ----!
       character(len=*),          intent(in out ) :: line
       real(kind=cp),dimension(6),intent(out)     :: Celda

       !---- Local variables -----!
       integer, dimension (6)               :: ivet
       real(kind=cp), dimension (6)         :: vet
       integer                              :: nlong1,iv
       character(len=4)                     :: dire

       call init_err_form()

       call cutst(line,nlong1,dire)
       if (u_case(dire) /= "CELL") then
          err_form=.true.
          ERR_Form_Mess=" Error reading the CELL keyword"
          return
       end if

       call getnum(line,vet,ivet,iv)
       if (iv /= 6 ) then
          err_form=.true.
          ERR_Form_Mess=" Error reading the Cell Parameters"
          return
       else
          celda=vet
       end if

       return
    End Subroutine Read_Cell

    !!----
    !!---- Subroutine Read_Cif_Atom(Filevar,Nline_Ini,Nline_End,N_Atom,Atm_List)
    !!----    character(len=*),dimension(:), intent(in)     :: filevar    !  In -> Input strings information
    !!----    integer,                       intent(in out) :: nline_ini  !  In -> Line to beginning search
    !!----                                                                   Out -> Current line on Filevar
    !!----    integer,                       intent(in)     :: nline_end  !  In -> Line to the End search
    !!----    integer,                       intent(out)    :: n_atom     ! Out -> Actual number of atom
    !!----    type (atom_list_type),        intent(out)    :: Atm_List   ! Out -> Atom list
    !!----
    !!----    Obtaining Atoms parameters from Cif file. A control error is present.
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Read_Cif_Atom(filevar,nline_ini,nline_end,n_atom,Atm_List)
       !---- Arguments ----!
       character(len=*), dimension(:),   intent(in)      :: filevar
       integer,                          intent(in out)  :: nline_ini
       integer,                          intent(in)      :: nline_end
       integer,                          intent(out)     :: n_atom
       type (atom_list_type),            intent(out)     :: Atm_List

       !---- Local Variables ----!
       character(len=len(filevar(1)))               :: string,cp_str
       character(len=20),dimension(15)              :: label

       integer                         :: i, j, nc, nct, nline, iv
       !integer, dimension(1)           :: ivet
       integer, dimension( 8)          :: lugar   !   1 -> label
                                                  !   2 -> Symbol
                                                  ! 3-5 -> coordinates
                                                  !   6 -> occupancy
                                                  !   7 -> Uequi
                                                  !   8 -> Biso
       real(kind=cp), dimension(1)     :: vet1,vet2
       type(atom_list_type)            :: Atm

       !---- Estimacion Inicial ----!
       lugar=0
       call allocate_atom_list(nline_end-nline_ini+1,Atm)

       n_atom=0
       call Read_Key_StrVal(filevar,nline_ini,nline_end,"_atom_site_",string)

       j=0
       do i=nline_ini,nline_end
          string=adjustl(filevar(i))
          if ("_atom_site_label" == string(1:16)) then
             j=j+1
             lugar(1)=j
             cycle
          end if
          if ("_atom_site_type_symbol" == string(1:22)) then
             j=j+1
             lugar(2)=j
             cycle
          end if
          if ("_atom_site_fract_x" == string(1:18)) then
             j=j+1
             lugar(3)=j
             cycle
          end if
          if ("_atom_site_fract_y" == string(1:18)) then
             j=j+1
             lugar(4)=j
             cycle
          end if
          if ("_atom_site_fract_z" == string(1:18)) then
             j=j+1
             lugar(5)=j
             cycle
          end if
          if ("_atom_site_occupancy" == string(1:20)) then
             j=j+1
             lugar(6)=j
             cycle
          end if
          if ("_atom_site_U_iso_or_equiv" == string(1:25)) then
             j=j+1
             lugar(7)=j
             cycle
          end if
          if ("_atom_site_B_iso_or_equiv" == string(1:25)) then
             j=j+1
             lugar(8)=j
             cycle
          end if
          if ("_atom_site_" == string(1:11)) then
             j=j+1
             cycle
          end if

          if ("_oxford_atom_site_" == string(1:18)) then
             j=j+1
             cycle
          end if

          nline=i
          exit
       end do

       if (any(lugar(3:5) == 0)) then
          err_form=.true.
          ERR_Form_Mess=" Error reading atoms"
          return
       end if
       nct=count(lugar > 0)

       nline_ini=nline
       string=" "
       do i=nline_ini,nline_end
          string=adjustl(trim(string)//" "//filevar(i))
          if (string(1:1) == "#" .or. string(1:1) == "?") cycle
          if (len_trim(string) == 0) exit
          if (string(1:1) == "_" .or. string(1:5) == "loop_") exit
          cp_str=string
          call getword(cp_str,label,nc)
          if (nc < nct) cycle

          n_atom=n_atom+1

          ! _atom_site_label
          atm%atom(n_atom)%lab=label(lugar(1))

          ! _atom_site_type_symbol
          if (lugar(2) /= 0) then
             atm%atom(n_atom)%SfacSymb=label(lugar(2))(1:4)
             if(index("1234567890+-",label(lugar(2))(2:2)) /= 0 ) then
                atm%atom(n_atom)%chemSymb=U_case(label(lugar(2))(1:1))
             else
                atm%atom(n_atom)%chemSymb=U_case(label(lugar(2))(1:1))//L_case(label(lugar(2))(2:2))
             end if
           !  call getnum(label(lugar(2))(2:2),vet1,ivet,iv)
           !  if (iv <= 0) then
           !     atm%atom(n_atom)%chemSymb=label(lugar(2))(1:2)
           !  else
           !     atm%atom(n_atom)%chemSymb=label(lugar(2))(1:1)
           !  end if
          else
             if(index("1234567890+-",label(lugar(1))(2:2)) /= 0 ) then
                atm%atom(n_atom)%chemSymb=U_case(label(lugar(1))(1:1))
             else
                atm%atom(n_atom)%chemSymb=U_case(label(lugar(1))(1:1))//L_case(label(lugar(1))(2:2))
             end if
             atm%atom(n_atom)%SfacSymb=atm%atom(n_atom)%chemSymb

           !   call getnum(label(lugar(1))(2:2),vet1,ivet,iv)
           !  if (iv <= 0) then
           !     atm%atom(n_atom)%chemSymb=label(lugar(1))(1:2)
           !  else
           !     atm%atom(n_atom)%chemSymb=label(lugar(1))(1:1)
           !  end if
          end if

          call getnum_std(label(lugar(3)),vet1,vet2,iv)    ! _atom_site_fract_x
          atm%atom(n_atom)%x(1)=vet1(1)
          atm%atom(n_atom)%x_std(1)=vet2(1)
          call getnum_std(label(lugar(4)),vet1,vet2,iv)    ! _atom_site_fract_y
          atm%atom(n_atom)%x(2)=vet1(1)
          atm%atom(n_atom)%x_std(2)=vet2(1)
          call getnum_std(label(lugar(5)),vet1,vet2,iv)    ! _atom_site_fract_z
          atm%atom(n_atom)%x(3)=vet1(1)
          atm%atom(n_atom)%x_std(3)=vet2(1)

          ! _atom_site_occupancy
          if (lugar(6) /= 0) then
             call getnum_std(label(lugar(6)),vet1,vet2,iv)
          else
             vet1=1.0
          end if
          atm%atom(n_atom)%occ=vet1(1)
          atm%atom(n_atom)%occ_std=vet2(1)

          if (lugar(7) /= 0) then
             call getnum_std(label(lugar(7)),vet1,vet2,iv)    ! _atom_site_U_iso_or_equiv
             atm%atom(n_atom)%ueq=vet1(1)
             atm%atom(n_atom)%Biso=vet1(1)*78.95683521     !If anisotropic they
             atm%atom(n_atom)%Biso_std=vet2(1)*78.95683521 !will be put to zero
          else if (lugar(8) /= 0) then
             call getnum_std(label(lugar(8)),vet1,vet2,iv)    ! _atom_site_B_iso_or_equiv
             atm%atom(n_atom)%ueq=vet1(1)/78.95683521
             atm%atom(n_atom)%Biso=vet1(1)     !If anisotropic they
             atm%atom(n_atom)%Biso_std=vet2(1) !will be put to zero
          else
             atm%atom(n_atom)%ueq=0.0
             atm%atom(n_atom)%Biso=0.0     !If anisotropic they
             atm%atom(n_atom)%Biso_std=0.0 !will be put to zero
          end if

          atm%atom(n_atom)%utype="u_ij"
          string=" "

       end do
       nline=i

       !---- Anisotropic parameters ----!
       nline_ini=nline
       lugar=0
       call Read_Key_StrVal(filevar,nline_ini,nline_end,"_atom_site_aniso_",string)

       j=0
       do i=nline_ini,nline_end
          string=adjustl(filevar(i))
          if ("_atom_site_aniso_label" == string(1:22)) then
             j=j+1
             lugar(1)=j
             cycle
          end if
          if ("_atom_site_aniso_U_11" == string(1:21)) then
             j=j+1
             lugar(2)=j
             cycle
          end if
          if ("_atom_site_aniso_U_22" == string(1:21)) then
             j=j+1
             lugar(3)=j
             cycle
          end if
          if ("_atom_site_aniso_U_33" == string(1:21)) then
             j=j+1
             lugar(4)=j
             cycle
          end if
          if ("_atom_site_aniso_U_12" == string(1:21)) then
             j=j+1
             lugar(5)=j
             cycle
          end if
          if ("_atom_site_aniso_U_13" == string(1:21)) then
             j=j+1
             lugar(6)=j
             cycle
          end if
          if ("_atom_site_aniso_U_23" == string(1:21)) then
             j=j+1
             lugar(7)=j
             cycle
          end if

          if ("_atom_site_aniso" == string(1:16) ) then
             j=j+1
             cycle
          end if

          nline=i
          exit
       end do

       if (all(lugar > 0)) then
          nct=count(lugar > 0)
          nline_ini=nline
          string=" "
          do i=nline_ini,nline_end
             string=adjustl(trim(string)//" "//filevar(i))
             if (string(1:1) == "#" .or. string(1:1) =="?") cycle
             if (len_trim(string) == 0) exit

             cp_str=string
             call getword(cp_str,label,nc)
             if (nc < nct) cycle

             do j=1,n_atom
                if (atm%atom(j)%lab(1:4) /= label(lugar(1))(1:4)) cycle

                call getnum_std(label(lugar(2)),vet1,vet2,iv)    ! _atom_site_aniso_U_11
                atm%atom(j)%u(1)=vet1(1)
                atm%atom(j)%u_std(1)=vet2(1)
                call getnum_std(label(lugar(3)),vet1,vet2,iv)    ! _atom_site_aniso_U_22
                atm%atom(j)%u(2)=vet1(1)
                atm%atom(j)%u_std(2)=vet2(1)
                call getnum_std(label(lugar(4)),vet1,vet2,iv)    ! _atom_site_aniso_U_33
                atm%atom(j)%u(3)=vet1(1)
                atm%atom(j)%u_std(3)=vet2(1)
                call getnum_std(label(lugar(5)),vet1,vet2,iv)    ! _atom_site_aniso_U_12
                atm%atom(j)%u(4)=vet1(1)
                atm%atom(j)%u_std(4)=vet2(1)
                call getnum_std(label(lugar(6)),vet1,vet2,iv)    ! _atom_site_aniso_U_13
                atm%atom(j)%u(5)=vet1(1)
                atm%atom(j)%u_std(5)=vet2(1)
                call getnum_std(label(lugar(7)),vet1,vet2,iv)    ! _atom_site_aniso_U_23
                atm%atom(j)%u(6)=vet1(1)
                atm%atom(j)%u_std(6)=vet2(1)

                atm%atom(j)%thtype="aniso"
                atm%atom(j)%Biso=0.0
                atm%atom(j)%Biso_std=0.0
                exit
             end do
             nline=i
             string=" "
          end do

       end if
       nline_ini=nline

       !---- Adjusting ... ----!
       if (n_atom > 0) then
          call allocate_atom_list(n_atom,Atm_list)
          atm_list%natoms=n_atom
          do i=1,n_atom
             atm_list%atom(i)=atm%atom(i)
          end do
       end if
       call Deallocate_atom_list(atm)

       return
    End Subroutine Read_Cif_Atom

    !!----
    !!---- Subroutine Read_Cif_Cell(Filevar,Nline_Ini,Nline_End,Celda,Stdcelda)
    !!----    character(len=*), dimension(:), intent(in)     :: filevar      !  In -> String vector input
    !!----    integer,                        intent(in out) :: nline_ini    !  In -> Line to start the search
    !!----                                                                      Out -> Current line on Filevar
    !!----    integer,                        intent(in)     :: nline_end    !  In -> Line to finish the search
    !!----    real(kind=cp),dimension(6),     intent (out)   :: Celda        ! Out -> Cell variable
    !!----    real(kind=cp),dimension(6),     intent (out)   :: StdCelda     ! Out -> Cell variable
    !!----
    !!----    Read Cell Parameters from Cif file
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Read_Cif_Cell(Filevar,Nline_Ini,Nline_End,Celda,StdCelda)
       !---- Arguments ----!
       character(len=*),  dimension(:),     intent(in)     :: filevar
       integer,                             intent(in out) :: nline_ini
       integer,                             intent(in)     :: nline_end
       real(kind=cp),dimension(6),          intent(out)    :: Celda
       real(kind=cp),dimension(6),optional, intent(out)    :: StdCelda

       !---- Local Variables ----!
       integer                     :: iv,initl
       real(kind=cp), dimension(1) :: vet1,vet2
       real(kind=cp), dimension(6) :: a

       !---- Valores iniciales ----!
       celda=(/1.0,1.0,1.0,90.0,90.0,90.0/)
       a=0.0
       if (present(stdcelda)) stdcelda=0.0

       !---- Celda ----!
       initl=nline_ini  !Preserve initial line => some CIF files have random order for cell parameters
       call read_key_valueSTD(filevar,nline_ini,nline_end,"_cell_length_a",vet1,vet2,iv)
       if (iv == 1) then
          Celda(1)   =vet1(1)
          a(1)=vet2(1)
       end if

       nline_ini=initl
       call read_key_valueSTD(filevar,nline_ini,nline_end,"_cell_length_b",vet1,vet2,iv)
       if (iv == 1) then
          Celda(2)   =vet1(1)
          a(2)=vet2(1)
       end if

       nline_ini=initl
       call read_key_valueSTD(filevar,nline_ini,nline_end,"_cell_length_c",vet1,vet2,iv)
       if (iv == 1) then
          Celda(3)   =vet1(1)
         a(3)=vet2(1)
       end if

       nline_ini=initl
       call read_key_valueSTD(filevar,nline_ini,nline_end,"_cell_angle_alpha",vet1,vet2,iv)
       if (iv == 1) then
          Celda(4)   =vet1(1)
          a(4)=vet2(1)
       end if

       nline_ini=initl
       call read_key_valueSTD(filevar,nline_ini,nline_end,"_cell_angle_beta",vet1,vet2,iv)
       if (iv == 1) then
          Celda(5)   =vet1(1)
          a(5)=vet2(1)
       end if

       nline_ini=initl
       call read_key_valueSTD(filevar,nline_ini,nline_end,"_cell_angle_gamma",vet1,vet2,iv)
       if (iv == 1) then
          Celda(6)   =vet1(1)
          a(6)=vet2(1)
       end if
       if (present(stdcelda)) stdcelda=a

       return
    End Subroutine Read_Cif_Cell

    !!----
    !!---- Subroutine Read_Cif_ChemicalName(Filevar,Nline_Ini,Nline_End,ChemName)
    !!----    character(len=*),  dimension(:), intent(in) :: filevar      !  In -> String vector
    !!----    integer,           intent(in out)           :: nline_ini    !  In -> Line to start the search
    !!----                                                                  Out -> Actual line on Filevar
    !!----    integer,           intent(in)               :: nline_end    !  In -> Line to finish the search
    !!----    character(len=*),  intent(out)              :: ChemName     ! Out -> Title string
    !!----
    !!----    Obtaining Chemical Name from Cif file
    !!----
    !!---- Update: March - 2009
    !!
    Subroutine Read_Cif_ChemicalName(Filevar,Nline_Ini,Nline_End,ChemName)
       !---- Arguments ----!
       character(len=*),  dimension(:), intent(in) :: filevar
       integer,           intent(in out)           :: nline_ini
       integer,           intent(in)               :: nline_end
       character(len=*),  intent(out)              :: ChemName

       !---- Local variables ----!
       integer :: np1, np2

       ChemName=" "
       call Read_Key_StrVal(filevar,nline_ini,nline_end, &
                            "_chemical_name_common",ChemName)

       if (len_trim(chemname) == 0) then
          call Read_Key_StrVal(filevar,nline_ini,nline_end, &
                            "_chemical_name_systematic",ChemName)
       end if

       if (len_trim(chemname) > 0) then
          if (trim(chemname) =="; ?" .or. trim(chemname)=="#") chemname=" "
          np1=index(chemname,"'")
          np2=index(chemname,"'",back=.true.)
          if (np1 > 0 .and. np2 > 0 .and. np2 > np1) then
             chemname=chemname(np1+1:np2-1)
          else
             np1=index(chemname,'"')
             np2=index(chemname,'"',back=.true.)
             if (np1 > 0 .and. np2 > 0 .and. np2 > np1) then
                chemname=chemname(np1+1:np2-1)
             end if
          end if
       end if

       return
    End Subroutine Read_Cif_ChemicalName

    !!----
    !!---- Subroutine Read_Cif_Cont(Filevar,Nline_Ini,Nline_End,N_Elem_Type,Elem_Type,N_Elem)
    !!----    character(len=*), dimension(:),      intent(in)      :: filevar       !  In -> String vector input
    !!----    integer,                             intent(in out)  :: nline_ini     !  In -> Line to start the search
    !!----                                                                             Out -> Actual line on Filevar
    !!----    integer,                             intent(in)      :: nline_end     !  In -> Line to finish the search
    !!----    integer,                             intent(out)     :: n_elem_type   ! Out -> N. of different elements
    !!----    character(len=*), dimension(:),      intent(out)     :: elem_type     ! Out -> String for Element type
    !!----    real(kind=cp), dimension(:),optional,intent(out)     :: n_elem        ! Out -> Number of elements
    !!----
    !!----    Obtaining the chemical contents from Cif file
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Read_Cif_Cont(Filevar,Nline_Ini,Nline_End,N_Elem_Type,Elem_Type,N_Elem)
       !---- Arguments ----!
       character(len=*), dimension(:),      intent(in)      :: filevar
       integer,                             intent(in out)  :: nline_ini
       integer,                             intent(in)      :: nline_end
       integer,                             intent(out)     :: n_elem_type
       character(len=*), dimension(:),      intent(out)     :: elem_type
       real(kind=cp), dimension(:),optional,intent(out)     :: n_elem

       !---- Local  variables ----!
       character(len=len(filevar(1)))      :: string
       character(len=10),dimension(15)     :: label

       integer                    :: iv
       integer                    :: i,np1,np2,nlabel,nlong
       integer, dimension(1)      :: ivet

       real(kind=cp),dimension(1) :: vet

       n_elem_type = 0
       elem_type   = " "
       if (present(n_elem)) n_elem = 0.0

       call Read_Key_StrVal(filevar,nline_ini,nline_end, &
                            "_chemical_formula_sum",string)
       if (len_trim(string) ==0) string=filevar(nline_ini+1)
       string=adjustl(string)
       if (string(1:1) == "?") return
       np1=index(string,"'")
       np2=index(string,"'",back=.true.)
       nlabel=0
       if (np1 /= 0 .and. np2 /= 0 .and. np2 > np1) then
          call getword(string(np1+1:np2-1),label,nlabel)
       end if
       if (nlabel /=0) then
          n_elem_type = nlabel
          do i=1,nlabel
             nlong=len_trim(label(i))
             select case (nlong)
                 case (1)
                    elem_type(i)=label(i)(1:1)
                    if (present(n_elem)) n_elem(i)   = 1.0

                 case (2)
                    call getnum(label(i)(2:),vet,ivet,iv)
                    if (iv == 1) then
                       elem_type(i)=label(i)(1:1)
                       if (present(n_elem)) n_elem(i)   =vet(1)
                    else
                       elem_type(i)=label(i)(1:2)
                       if (present(n_elem)) n_elem(i)   = 1.0
                    end if

                 case (3:)
                    call getnum(label(i)(2:),vet,ivet,iv)
                    if (iv == 1) then
                       elem_type(i)=label(i)(1:1)
                       if (present(n_elem)) n_elem(i)   =vet(1)
                    else
                       call getnum(label(i)(3:),vet,ivet,iv)
                       if (iv == 1) then
                          elem_type(i)=label(i)(1:2)
                          if (present(n_elem)) n_elem(i)   =vet(1)
                       else
                          elem_type(i)=label(i)(1:2)
                          if (present(n_elem)) n_elem(i)   = 1.0
                       end if

                    end if

             end select
          end do
       end if

       return
    End Subroutine Read_Cif_Cont

    !!----
    !!---- Subroutine Read_Cif_Hall(Filevar,Nline_Ini,Nline_End,Spgr_Ha)
    !!----    character(len=*), dimension(:), intent(in) :: filevar      !  In -> String vector input
    !!----    integer,          intent(in out)           :: nline_ini    !  In -> Line to start the search
    !!----                                                                 Out -> Actual line on Filevar
    !!----    integer,          intent(in)               :: nline_end    !  In -> Line to finish the search
    !!----    character(len=*), intent(out)              :: spgr_ha      ! Out -> Hall symbol
    !!----
    !!----    Obtaining the Hall symbol of the Space Group
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Read_Cif_Hall(Filevar,Nline_Ini,Nline_End,Spgr_Ha)
       !---- Arguments ----!
       character(len=*), dimension(:), intent(in) :: filevar
       integer,          intent(in out)           :: nline_ini
       integer,          intent(in)               :: nline_end
       character(len=*), intent(out)              :: spgr_ha

       !---- Local variables ----!
       integer :: np1, np2

       spgr_ha=" "
       call Read_Key_StrVal(filevar,nline_ini,nline_end, &
                            "_symmetry_space_group_name_Hall",spgr_ha)
       if (len_trim(spgr_ha)==0) spgr_ha=adjustl(filevar(nline_ini+1))
       ! TR  feb. 2015 .(re-reading the same item with another name)
       if(len_trim(spgr_ha) == 0) then
        spgr_ha=" "
        call Read_Key_StrVal(filevar,nline_ini,nline_end, "_space_group_name_Hall",spgr_ha)
        if (len_trim(spgr_ha)==0) spgr_ha=adjustl(filevar(nline_ini+1))
       end if

       if (spgr_ha =="?" .or. spgr_ha=="#") then
          spgr_ha=" "
       else
          np1=index(spgr_ha,"'")
          np2=index(spgr_ha,"'",back=.true.)
          if (np1 > 0 .and. np2 > 0 .and. np2 > np1) then
             spgr_ha=spgr_ha(np1+1:np2-1)
          else
             np1=index(spgr_ha,'"')
             np2=index(spgr_ha,'"',back=.true.)
             if (np1 > 0 .and. np2 > 0 .and. np2 > np1) then
                spgr_ha=spgr_ha(np1+1:np2-1)
             else
                spgr_ha=" "
             end if
          end if
       end if

       return
    End Subroutine Read_Cif_Hall

    !!----
    !!---- Subroutine Read_Cif_Hm(Filevar,Nline_Ini,Nline_End,Spgr_Hm)
    !!----    character(len=*),  dimension(:), intent(in) :: filevar     !  In -> String vector
    !!----    integer,           intent(in out)           :: nline_ini   !  In -> Line to start the search
    !!----                                                                 Out -> Actual Line on Filevar
    !!----    integer,           intent(in)               :: nline_end   !  In -> Line to finish the search
    !!----    character(len=*),  intent(out)              :: spgr_hm     ! Out -> Hermann-Mauguin symbol
    !!----
    !!----    Obtaining the Herman-Mauguin symbol of Space Group
    !!----
    !!---- Update: March - 2010
    !!
    Subroutine Read_Cif_Hm(Filevar,Nline_Ini,Nline_End,Spgr_Hm)
       !---- Arguments ----!
       character(len=*),  dimension(:), intent(in) :: filevar
       integer,           intent(in out)           :: nline_ini
       integer,           intent(in)               :: nline_end
       character(len=*),  intent(out)              :: spgr_hm

       !---- Local variables ----!
       character(len=1) :: csym, csym2
       integer          :: np1, np2

       spgr_hm=" "
       np1=nline_ini
       call Read_Key_Str(filevar,nline_ini,nline_end, &
                            "_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)
       if(len_trim(spgr_hm) == 0) then
        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))
       end if

       if (spgr_hm =="?" .or. spgr_hm=="#") then
          spgr_hm=" "
       else
          np1=index(spgr_hm,"'")
          np2=index(spgr_hm,"'",back=.true.)
          if (np1 > 0 .and. np2 > 0 .and. np2 > np1) then
             spgr_hm=spgr_hm(np1+1:np2-1)
          else
             np1=index(spgr_hm,'"')
             np2=index(spgr_hm,'"',back=.true.)
             if (np1 > 0 .and. np2 > 0 .and. np2 > np1) then
                spgr_hm=spgr_hm(np1+1:np2-1)
             else
                spgr_hm=" "
             end if
          end if
       end if

       !---- Adapting Nomenclature from ICSD to our model ----!
       np1=len_trim(spgr_hm)
       if (np1 > 0) then
          csym=u_case(spgr_hm(np1:np1))
          select case (csym)
             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"
                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)
                   case ("R")
                      spgr_hm=spgr_hm(:np1-2)//":R"
                   case default
                      spgr_hm=spgr_hm(:np1-1)
                end select

             case("R")
                csym2=u_case(spgr_hm(np1-1:np1-1))
                if (csym2 == "H" ) then
                   spgr_hm=spgr_hm(:np1-2)
                else
                   spgr_hm=spgr_hm(:np1-1)//":R"
                end if
          end select
       end if

       return
    End Subroutine Read_Cif_Hm

    !!----
    !!---- Subroutine Read_Cif_Lambda(Filevar,Nline_Ini,Nline_End,Lambda)
    !!----    character(len=*), dimension(:), intent(in) :: filevar      !  In -> String vector
    !!----    integer,           intent(in out)          :: nline_ini    !  In -> Line to start of search
    !!----                                                                  Out -> Actual line on Filevar
    !!----    integer,           intent(in)              :: nline_end    !  In -> Line to finish the search
    !!----    real(kind=cp),     intent(out)             :: lambda       !  Out -> lamda value
    !!----
    !!----    Radiation length
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Read_Cif_Lambda(Filevar,Nline_Ini,Nline_End,Lambda)
       !---- Arguments ----!
       character(len=*),  dimension(:), intent(in) :: filevar
       integer,           intent(in out)           :: nline_ini
       integer,           intent(in)               :: nline_end
       real(kind=cp),     intent(out)              :: lambda

       !---- Local Variables ----!
       integer                    :: iv
       integer,dimension(1)       :: ivet
       real(kind=cp), dimension(1):: vet

       lambda=0.71073    ! Mo

       call read_key_value(filevar,nline_ini,nline_end, &
                           "_diffrn_radiation_wavelength",vet,ivet,iv)
       if (iv == 1) then
          lambda=vet(1)
       end if

       return
    End Subroutine Read_Cif_Lambda

    !!----
    !!---- Subroutine Read_Cif_Symm(Filevar,Nline_Ini,Nline_End,N_Oper,Oper_Symm)
    !!----    character(len=*), dimension(:), intent(in) :: filevar       !  In -> String vector
    !!----    integer,          intent(in out)           :: nline_ini     !  In -> Line to start the search
    !!----                                                                  Out -> Actual line on Filevar
    !!----    integer,          intent(in)               :: nline_end     !  In -> Line to finish the search
    !!----    integer,          intent(out)              :: n_oper        ! Out -> Number of Operators
    !!----    character(len=*), dimension(:),intent(out) :: oper_symm     ! Out -> Vector with Symmetry Operators
    !!----
    !!----    Obtaining Symmetry Operators from Cif file
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Read_Cif_Symm(Filevar,Nline_Ini,Nline_End,N_Oper,Oper_Symm)
       !---- Arguments ----!
       character(len=*), dimension(:), intent(in) :: filevar
       integer,          intent(in out)           :: nline_ini
       integer,          intent(in)               :: nline_end
       integer,          intent(out)              :: n_oper
       character(len=*), dimension(:),intent(out) :: oper_symm

       !---- Local variables ----!
       character(len=len(filevar(1))) :: string
       integer                        :: i,np1,np2

       n_oper=0
       oper_symm=" "
       np1=nline_ini
       call Read_Key_StrVal(filevar,nline_ini,nline_end, &
                            "_symmetry_equiv_pos_as_xyz",string)
       nline_ini=np1
       ! TR  feb. 2015 .(re-reading the same item with another name)
       if(len_trim(string) == 0) then
        call Read_Key_StrVal(filevar,nline_ini,nline_end, "_space_group_symop_operation_xyz",string)
       end if

       if (len_trim(string) /=0) then
          string=adjustl(string)

          if (string(1:1) /="#" .and. string(1:1) /= "?") then      ! Comentario
             np1=index(string,"'")
             np2=index(string,"'",back=.true.)
             if (np1 > 0 .and. np2 > 0 .and. np2 > np1) then
                n_oper=n_oper+1
                oper_symm(n_oper)=string(np1+1:np2-1)
             else
                np1=index(string,'"')
                np2=index(string,'"',back=.true.)
                if (np1 > 0 .and. np2 > 0 .and. np2 > np1) then
                   n_oper=n_oper+1
                   oper_symm(n_oper)=string(np1+1:np2-1)
                end if
             end if
          end if
       end if

       do i=nline_ini+1,nline_end
          string=adjustl(filevar(i))
          if (len_trim(string) /=0) then
             if (string(1:1) /="#" .and. string(1:1) /= "?") then      ! Comentario o Vacio
                np1=index(string,"'")
                np2=index(string,"'",back=.true.)
                if (np1 > 0 .and. np2 > 0 .and. np2 > np1) then
                   n_oper=n_oper+1
                   oper_symm(n_oper)=string(np1+1:np2-1)
                else
                   np1=index(string,'"')
                   np2=index(string,'"',back=.true.)
                   if (np1 > 0 .and. np2 > 0 .and. np2 > np1) then
                      n_oper=n_oper+1
                      oper_symm(n_oper)=string(np1+1:np2-1)
                   end if
                end if
             end if
          else
             nline_ini=i+1
             exit
          end if
       end do

       return
    End Subroutine Read_Cif_Symm

    !!----
    !!---- Subroutine Read_Cif_Title(Filevar,Nline_Ini,Nline_End,Title)
    !!----    character(len=*),  dimension(:), intent(in) :: filevar      !  In -> String vector
    !!----    integer,           intent(in out)           :: nline_ini    !  In -> Line to start the search
    !!----                                                                  Out -> Actual line on Filevar
    !!----    integer,           intent(in)               :: nline_end    !  In -> Line to finish the search
    !!----    character(len=*),  intent(out)              :: title        ! Out -> Title string
    !!----
    !!----    Obtaining Title from Cif file
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Read_Cif_Title(Filevar,Nline_Ini,Nline_End,title)
       !---- Arguments ----!
       character(len=*),  dimension(:), intent(in) :: filevar
       integer,           intent(in out)           :: nline_ini
       integer,           intent(in)               :: nline_end
       character(len=*),  intent(out)              :: title

       !---- Local variables ----!
       integer :: np, np1, np2

       title=" "
       call Read_Key_StrVal(filevar,nline_ini,nline_end, &
                            "_publ_section_title",title)

       if (len_trim(title) ==0 ) title=adjustl(filevar(nline_ini+1))
       if (title =="; ?" .or. title=="#") then
          title=" "
       else
          np=len_trim(title)
          if (np <= 3) title=adjustl(filevar(nline_ini+2))
          np1=index(title,"'")
          np2=index(title,"'",back=.true.)
          if (np1 > 0 .and. np2 > 0 .and. np2 > np1) then
             title=title(np1+1:np2-1)
          else
             np1=index(title,'"')
             np2=index(title,'"',back=.true.)
             if (np1 > 0 .and. np2 > 0 .and. np2 > np1) then
                title=title(np1+1:np2-1)
             end if
          end if
       end if

       return
    End Subroutine Read_Cif_Title

    !!----
    !!---- Subroutine Read_Cif_Z(Filevar,Nline_Ini,Nline_End,Z)
    !!----    character(len=*), dimension(:), intent(in) :: filevar     !  In -> String vector
    !!----    integer,           intent(in out)          :: nline_ini   !  In -> Line to start the search
    !!----                                                                Out -> Actual line on Filevar
    !!----    integer,           intent(in)              :: nline_end   !  In -> Line to finish the search
    !!----    integer,           intent(out)             :: Z           ! Out -> Z value
    !!----
    !!----    Unit formula from Cif file
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Read_Cif_Z(filevar,nline_ini,nline_end,z)
       !---- Arguments ----!
       character(len=*),  dimension(:), intent(in) :: filevar
       integer,           intent(in out)           :: nline_ini
       integer,           intent(in)               :: nline_end
       integer,           intent(out)              :: z

       !---- Local Variables ----!
       integer                     :: iv
       integer,dimension(1)        :: ivet
       real(kind=cp), dimension(1) :: vet

       z=0
       call read_key_value(filevar,nline_ini,nline_end, &
                           "_cell_formula_units_Z",vet,ivet,iv)
       if (iv == 1) then
          z=ivet(1)
       end if

       return
    End Subroutine Read_Cif_Z

    !!----
    !!---- Subroutine Read_File_Atom(Filevar,Nline_Ini,Nline_End,Atomos)
    !!----    character(len=*),dimension(:), intent(in)       :: filevar     !  In -> String vector
    !!----    integer,                       intent(in)       :: nline_ini   !  In -> Line to start the search
    !!----                                                                     Out -> Actual line on Filevar
    !!----    integer,                       intent(in)       :: nline_end   !  In -> Line to finish the search
    !!----    type (atom_list_type),        intent(out)      :: Atomos      ! Out -> Atom list
    !!----           or
    !!----    type (Point_list_Type),        intent(out)      :: Atomos      ! Out -> point list
    !!----
    !!----     Subroutine to read an atom (or point) list from a file. Atomos should be previously allocated.
    !!----     Control of error is present.
    !!----
    !!---- Update: June - 2005
    !!

    !!--++
    !!--++ Subroutine Read_File_Atomlist(Filevar,Nline_Ini,Nline_End,Atomos)
    !!--++    character(len=*),dimension(:), intent(in)       :: filevar     !  In -> String vector
    !!--++    integer,                       intent(in)       :: nline_ini   !  In -> Line to start the search
    !!--++                                                                     Out -> Actual line on Filevar
    !!--++    integer,                       intent(in)       :: nline_end   !  In -> Line to finish the search
    !!--++    type (atom_list_type),        intent(out)       :: Atomos      ! Out -> Atom list
    !!--++
    !!--++     Subroutine to read an atom list from a file. Atomos should be previously allocated.
    !!--++     Control of error is present
    !!--++
    !!--++ Update: June - 2005
    !!
    Subroutine Read_File_Atomlist(filevar,nline_ini,nline_end,Atomos)
       !---- Arguments ----!
       character(len=*), dimension(:),   intent(in)      :: filevar
       integer,                          intent(in out)  :: nline_ini
       integer,                          intent(in)      :: nline_end
       type (atom_list_type),            intent(in out)  :: Atomos

       !---- Local variables -----!
       character(len=len(filevar(1))) :: line
       character(len=4)               :: dire
       integer                        :: i,na
       type (Atom_Type)               :: Atomo

       !---- Initial Values ----!
       na=0
       do i=nline_ini,nline_end
          dire=adjustl(u_case(filevar(i)(1:4)))
          if (dire /= "ATOM") cycle
          line=adjustl(filevar(i))
          call read_atom(line,atomo)
          if (err_form) cycle

          !---- Trial to read anisotropic thermal parameters ----!
          if( i < size(filevar) ) then
           line=adjustl(filevar(i+1))
           select case (u_case(line(1:4)))
             case ("U_IJ")
                call read_uvals(line,atomo, "u_ij")
             case ("B_IJ")
                call read_uvals(line,atomo, "b_ij")
             case ("BETA")
                call read_uvals(line,atomo, "beta")
           end select
           if (err_form) cycle
          end if
          na=na+1
          Atomos%atom(na)=atomo
       end do

       Atomos%natoms=na

       return
    End Subroutine Read_File_Atomlist

    !!----
    !!---- Subroutine Read_File_PointList(Filevar,Nline_Ini,Nline_End,Atomos)
    !!----    character(len=*),dimension(:), intent(in)       :: filevar     !  In -> String vector
    !!----    integer,                       intent(in)       :: nline_ini   !  In -> Line to start the search
    !!----                                                                     Out -> Actual line on Filevar
    !!----    integer,                       intent(in)       :: nline_end   !  In -> Line to finish the search
    !!----    type (Point_List_Type),        intent(out)      :: Atomos      ! Out -> point list
    !!----
    !!----     Subroutine to read an point list from a file. Atomos should be previously allocated.
    !!----     Control of error is present
    !!----
    !!---- Update: June - 2005
    !!
    Subroutine Read_File_PointList(filevar,nline_ini,nline_end,Atomos)
       !---- Arguments ----!
       character(len=*), dimension(:),   intent(in)      :: filevar
       integer,                          intent(in out)  :: nline_ini
       integer,                          intent(in)      :: nline_end
       type (Point_List_Type),           intent(in out)  :: Atomos

       !---- Local variables -----!
       character(len=len(filevar(1))) :: line
       character(len=4)               :: dire
       integer                        :: i,na
       type (Atom_Type)               :: Atomo

       !---- Initial Values ----!
       na=0

       do i=nline_ini,nline_end
          dire=adjustl(u_case(filevar(i)(1:4)))
          if (dire /= "ATOM") cycle
          line=adjustl(filevar(i))
          call read_atom(line,atomo)
          if (err_form) cycle
          na=na+1
          Atomos%x(:,na) =atomo%x(:)
          Atomos%p(na)   = 0
          Atomos%nam(na) = atomo%lab
       end do

       Atomos%np=na

       return
    End Subroutine Read_File_PointList

    !!----
    !!---- Subroutine Read_File_Cell(Filevar,Nline_Ini,Nline_End,Celda)
    !!----    character(len=*), dimension(:), intent(in) :: filevar      !  In -> String Vector
    !!----    integer,           intent(in out)          :: nline_ini    !  In -> Line to start the search
    !!----                                                                 Out -> Atual line on Filevar
    !!----    integer,           intent(in)              :: nline_end    !  In -> line to finish the search
    !!----
    !!----    real(kind=cp),dimension(6), intent (out)   :: Celda        ! Out -> Cell variable
    !!----                            or
    !!----    type (Crystal_Cell_Type), intent (out)     :: Celda        ! Out -> Cell variable
    !!----
    !!----    Read Cell Parameters from file. Control error is present
    !!----
    !!---- Update: February - 2005
    !!

    !!--++
    !!--++ Subroutine Read_File_Cellc(Filevar,Nline_Ini,Nline_End,Celda)
    !!--++    character(len=*), dimension(:), intent(in) :: filevar      !  In -> String Vector
    !!--++    integer,           intent(in out)          :: nline_ini    !  In -> Line to start the search
    !!--++                                                                 Out -> Atual line on Filevar
    !!--++    integer,           intent(in)              :: nline_end    !  In -> line to finish the search
    !!--++    real(kind=cp),dimension(6), intent (out)   :: Celda        ! Out -> Cell variable
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Read Cell Parameters from file. Control error is present
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Read_File_Cellc(filevar,nline_ini,nline_end,Celda)
       !---- Arguments ----!
       character(len=*),  dimension(:), intent(in)     :: filevar
       integer,                         intent(in)     :: nline_ini
       integer,                         intent(in)     :: nline_end
       real(kind=cp),dimension(6),      intent(out)    :: Celda

       !---- Local Variables ----!
       integer                     :: iv, i,j
       integer, dimension(6)       :: ivet
       real(kind=cp), dimension(6) :: vet

       !---- Valores iniciales ----!
       call init_err_form()

       i=nline_ini
       j=nline_end

       !---- Celda ----!
       call read_key_value(filevar,i,j,"cell",vet,ivet,iv)
       if (iv /=6) then
          err_form=.true.
          ERR_Form_Mess=" Bad Cell Parameters..."
          return
       else
          celda=vet(:)
       end if

       return
    End Subroutine Read_File_Cellc

    !!--++
    !!--++ Subroutine Read_File_Cellt(Filevar,Nline_Ini,Nline_End,Celda,CFrame)
    !!--++    character(len=*),  dimension(:), intent(in)     :: filevar     !  In -> String Vector
    !!--++    integer,                         intent(in)     :: nline_ini   !  In -> Line to start the search
    !!--++    integer,                         intent(in)     :: nline_end   !  In -> line to finish the search
    !!--++    type (Crystal_Cell_Type),        intent(out)    :: Celda       ! Out -> Cell structure
    !!--++    character(len=*),  optional,     intent(in)     :: CFrame      !  Cartesian Frame "A" or "C" (if absent -> "A")
    !!--++          ! Out -> Cell variable
    !!--++
    !!--++    (OVERLOADED)
    !!--++    Read Cell Parameters from file. Control error is present
    !!--++    The object Celda is constructed just after reading the cell parameters.
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Read_File_Cellt(filevar,nline_ini,nline_end,Celda,CFrame)
       !---- Arguments ----!
       character(len=*),  dimension(:), intent(in)     :: filevar
       integer,                         intent(in)     :: nline_ini
       integer,                         intent(in)     :: nline_end
       type (Crystal_Cell_Type),        intent(out)    :: Celda
       character(len=*),  optional,     intent(in)     :: CFrame

       !---- Local Variables ----!
       integer                     :: iv, i,j
       real(kind=cp), dimension(6) :: vet1,vet2

       !---- Valores iniciales ----!
       call init_err_form()

       i=nline_ini
       j=nline_end

       !---- Celda ----!

       call read_key_valueSTD(filevar,i,j,"cell",vet1,vet2,iv)
       if (iv /=6) then
          err_form=.true.
          ERR_Form_Mess=" Bad Cell Parameters..."
          return
       end if
       if(present(CFrame)) then
         call Set_Crystal_Cell(vet1(1:3),vet1(4:6),Celda,CFrame)
       else
         call Set_Crystal_Cell(vet1(1:3),vet1(4:6),Celda,"A")
       end if
       celda%cell_std=vet2(1:3)
       celda%ang_std=vet2(4:6)

       return
    End Subroutine Read_File_Cellt

    !!----
    !!---- Subroutine Read_File_lambda(Filevar,Nline_Ini,Nline_End,v1,v2,v3)
    !!----    character(len=*), dimension(:), intent(in)     :: filevar   !  In -> String Vector
    !!----    integer,                        intent(in out) :: nline_ini !  In -> Line to start the search
    !!----                                                                  Out -> Atual line on Filevar
    !!----    integer,                        intent(in)     :: nline_end !  In -> line to finish the search
    !!----    real(kind=cp),                  intent(   out) :: v1,v2,v3  ! Out -> Lambda1,lambda2,ratio
    !!----
    !!----    Read wavelengths and ratio.
    !!----    If no value is read, Lambda1=Lambda2=1.54056 Angstroms, ratio=0.0
    !!----    If only one value is read Lambda1=Lambda2=v1, ratio=0
    !!----    If only two values iare read Lambda1=v1, Lambda2=v2, ratio=0.5
    !!----    In other cases Lambda1=v1, Lambda2=v2, ratio=v3
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Read_File_Lambda(Filevar,Nline_Ini,Nline_End,v1,v2,v3)
       !---- Arguments ----!
       character(len=*), dimension(:), intent(in)     :: filevar
       integer,                        intent(in out) :: nline_ini
       integer,                        intent(in)     :: nline_end
       real(kind=cp),                  intent(   out) :: v1,v2,v3

       !---- Local Variables ----!
       integer                    :: iv, i,j
       integer, dimension(3)      :: ivet
       real(kind=cp), dimension(3):: vet

       !---- Valores iniciales ----!
       call init_err_form()

       i=nline_ini
       j=nline_end

       v3=0.0
       v1=1.54056
       !---- Read Lambda ----!
       call read_key_value(filevar,i,j,"wave",vet,ivet,iv)
       if      (iv == 0) then
         v2=1.54056
       else if (iv == 1) then
         v1=vet(1)
         v2=vet(1)
       else if (iv == 2) then
         v1=vet(1)
         v2=vet(2)
         v3=0.5
       else if (iv == 3) then
         v1=vet(1)
         v2=vet(2)
         v3=vet(3)
       end if

       return
    End Subroutine Read_File_Lambda

    !!----
    !!---- Subroutine Read_File_RngSintL(Filevar,Nline_Ini,Nline_End,v1,v2)
    !!----    character(len=*), dimension(:), intent(in)     :: filevar   !  In -> String Vector
    !!----    integer,                        intent(in out) :: nline_ini !  In -> Line to start the search
    !!----                                                                  Out -> Atual line on Filevar
    !!----    integer,                        intent(in)     :: nline_end !  In -> line to finish the search
    !!----    real(kind=cp),                  intent(   out) :: v1,v2     ! Out -> Interval [v1,v2] in sinT/Lambda
    !!----
    !!----    Read range for sintheta/lambda.
    !!----    If only one value is read v1=0 and v2= read value
    !!----    If the keyword RNGSL is not given in the file, the default
    !!----    values are v1=0.0, v2=1.0
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Read_File_RngSintL(Filevar,Nline_Ini,Nline_End,v1,v2)
       !---- Arguments ----!
       character(len=*), dimension(:), intent(in)     :: filevar
       integer,                        intent(in out) :: nline_ini
       integer,                        intent(in)     :: nline_end
       real(kind=cp),                  intent(   out) :: v1,v2

       !---- Local Variables ----!
       integer                     :: iv, i,j
       integer,       dimension(2) :: ivet
       real(kind=cp), dimension(2) :: vet

       !---- Valores iniciales ----!
       call init_err_form()

       i=nline_ini
       j=nline_end

       !---- Range in sinTheta/Lambda ----!
       call read_key_value(filevar,i,j,"rngsl",vet,ivet,iv)
       if      (iv == 0) then
         v1=0.0
         v2=1.0
       else if (iv == 1) then
         v1=0.0
         v2=vet(1)
       else if (iv == 2) then
         v1=vet(1)
         v2=vet(2)
       end if

       return
    End Subroutine Read_File_RngSintL

    !!----
    !!---- Subroutine Read_File_Spg (Filevar,Nline_Ini,Nline_End,Spg,Sub)
    !!----    character(len=*),  dimension(:), intent(in) :: filevar       !  In -> String vector
    !!----    integer,           intent(in)               :: nline_ini     !  In -> Line to start the search
    !!----                                                                   Out -> Actual line on Filevar
    !!----    integer,           intent(in)               :: nline_end     !  In -> Line to Finish the search
    !!----    character(len=*),  intent(out)              :: spg           ! Out -> Space Group symbol
    !!----    character(len=*),  intent(in ),optional     :: sub           ! in  -> The space sroup symbol is a subgroup
    !!----                                                                 !        of an already given space group
    !!----    Reads the cards "SPGR", "SPACEG" or "SUBG" in filvar. Control of error is present
    !!----
    !!---- Update: February - 2011
    !!
    Subroutine Read_File_Spg(filevar,nline_ini,nline_end,Spg,sub)
       !---- Arguments ----!
       character(len=*),  dimension(:), intent(in) :: filevar   ! Variable
       integer,           intent(in)               :: nline_ini
       integer,           intent(in)               :: nline_end
       character(len=*),  intent(out)              :: spg
       character(len=*),  intent(in),  optional    :: sub

       !--Local variables--!
       integer  :: i

       call init_err_form()
       i=nline_ini
       if(present(sub)) then
         call Read_Key_StrVal(filevar,i,nline_end, "subg",spg)
       else
         call Read_Key_StrVal(filevar,i,nline_end, "spgr",spg)
       end if
       if (len_trim(spg) == 0 ) then
         call Read_Key_StrVal(filevar,i,nline_end, "spaceg",spg)
         if (len_trim(spg) == 0 ) then
           err_form=.true.
           ERR_Form_Mess=" Problems reading the Space Group symbol/number"
           return
         end if
       end if

       return
    End Subroutine Read_File_Spg

    !!----
    !!---- Read_File_Transf(Filevar,Nline_Ini,Nline_End,Transf,Orig)
    !!----    character(len=*), dimension(:), intent(in)     :: filevar      !  In -> String Vector
    !!----    integer,                        intent(in out) :: nline_ini    !  In -> Line to start the search
    !!----                                                                     Out -> Atual line on Filevar
    !!----    integer,                        intent(in)     :: nline_end    !  In -> line to finish the search
    !!----    real(kind=cp),dimension(3,3),   intent(out)    :: transf       ! Out -> Cell variable
    !!----    real(kind=cp),dimension(3  ),   intent(out)    :: orig
    !!----
    !!----    Read transformation matrix for changing the space group or cell setting.
    !!----    First the matrix M is read row by row and then the origin in the old setting
    !!----    is finally read. A single line with 12 real numbers should be given.
    !!--<<
    !!----    e.g.: TRANS  m11 m12 m13  m21 m22 m33  m31 m32 m33   o1 o2 o3
    !!----
    !!----    That means       a'=m11 a + m12 b + m13 c
    !!----                     b'=m21 a + m22 b + m23 c
    !!----                     c'=m31 a + m32 b + m33 c
    !!----
    !!----                     X' = inv(Mt) (X-O)
    !!-->>
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Read_File_transf(filevar,nline_ini,nline_end,trans,orig)
       !---- Arguments ----!
       character(len=*),  dimension(:), intent(in)     :: filevar
       integer,                         intent(in)     :: nline_ini
       integer,                         intent(in)     :: nline_end
       real(kind=cp),dimension(3,3),    intent(out)    :: trans
       real(kind=cp),dimension(3  ),    intent(out)    :: orig

       !---- Local Variables ----!
       integer                      :: iv, i,j
       integer,       dimension(12) :: ivet
       real(kind=cp), dimension(12) :: vet
       character(len=80)            :: transf_key

       !---- Initial values ----!
       call init_err_form()

       i=nline_ini
       j=nline_end

       !---- transformation matrix ----!
       call read_key_value(filevar,i,j,"trans",vet,ivet,iv,"#",transf_key)
       if (iv /= 12 .or. err_string) then
          !Try to read the transformation from transf_key
          if(len_trim(transf_key) /= 0) then
            call Get_Transf(transf_key,trans,orig)
            if(err_string) then
               err_form=.true.
               ERR_Form_Mess=" Bad matrix/origin setting in string: "//trim(transf_key)//" -> "//trim(Err_String_Mess)
               return
            end if
          else
               err_form=.true.
               ERR_Form_Mess=" Bad matrix/origin setting..."
               return
          end if

       else
          trans(1,1:3)=vet(1:3)
          trans(2,1:3)=vet(4:6)
          trans(3,1:3)=vet(7:9)
          orig(1:3) = vet(10:12)
       end if

       return
    End Subroutine Read_File_transf

    !!----
    !!---- Subroutine Read_Shx_Atom(Filevar,Nline_Ini,Nline_End,N_Fvar,Fvar,Elem_Type,Celda,Atm_List)
    !!----    character(len=*), dimension(:), intent(in)      :: filevar        !  In -> String vector
    !!----    integer,                        intent(in out)  :: nline_ini      !  In -> Line to start the search
    !!----                                                                         Out -> Actual line on Filevar
    !!----    integer,                        intent(in)      :: nline_end      !  In -> Line to finish the search
    !!----    integer,                        intent(in)      :: n_fvar         !  In -> Number of parameters on FVAR
    !!----    real(kind=cp), dimension(:),    intent(in)      :: fvar           !  In -> Values for FVAR
    !!----    character(len=*), dimension(:), intent(in)      :: elem_type      !  In -> type of elements
    !!----    type (Crystal_Cell_Type),       intent(in)      :: Celda          !  In -> Cell type variable
    !!----    type (Atom_list_type),          intent(out)     :: Atm_List       ! Out -> number of atoms
    !!----         ! Out -> Atom List
    !!----
    !!----    Obtaining Atoms parameters from Shelx file (.ins or .res)
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Read_Shx_Atom(filevar,nline_ini,nline_end,n_fvar,fvar,elem_type,celda,Atm_List)
       !---- Arguments ----!
       character(len=*), dimension(:), intent(in)      :: filevar
       integer,                        intent(in out)  :: nline_ini
       integer,                        intent(in)      :: nline_end
       integer,                        intent(in)      :: n_fvar
       real(kind=cp), dimension(:),    intent(in)      :: fvar
       character(len=*), dimension(:), intent(in)      :: elem_type
       type (Crystal_Cell_Type),       intent(in)      :: Celda
       type (Atom_list_type),          intent(out)     :: Atm_List

       !---- Local Variables ----!
       character(len=80)               :: string
       character(len=30),dimension(15) :: label
       character(len=2)                :: el
       integer                         :: i, nc, iv
       integer                         :: j, n_atom
       integer, dimension(15)          :: ivet
       real(kind=cp)                   :: x, p, u
       real(kind=cp), dimension(15)    :: vet
       type(atom_list_type)            :: Atm

       call allocate_atom_list(nline_end-nline_ini+1,Atm)
       n_atom=0

       do i=nline_ini,nline_end
          string=filevar(i)
          if (len_trim(string) == 0) cycle
          call getword(string,label,nc)
          select case (nc)
             case (5) ! Atomname Sfac X Y Z
                call getnum(label(2),vet,ivet,iv)   ! Is Sfac integer?
                if (iv /= 1) cycle
                call getnum(label(3),vet,ivet,iv)   ! Is X real?
                if (iv /= 1) cycle
                call getnum(label(4),vet,ivet,iv)   ! Is Y real?
                if (iv /= 1) cycle
                call getnum(label(5),vet,ivet,iv)   ! Is Z real?
                if (iv /= 1) cycle

                n_atom=n_atom+1
                atm%atom(n_atom)%lab=label(1)(1:4)
                call getnum(label(2),vet,ivet,iv)
                el=elem_type(ivet(1))
                atm%atom(n_atom)%chemSymb=U_case(el(1:1))//L_case(el(2:2))
                call getnum(label(3),vet,ivet,iv)
                atm%atom(n_atom)%x(1)=vet(1)
                call getnum(label(4),vet,ivet,iv)
                atm%atom(n_atom)%x(2)=vet(1)
                call getnum(label(5),vet,ivet,iv)
                atm%atom(n_atom)%x(3)=vet(1)
                atm%atom(n_atom)%utype="u_ij"

             case (6) ! Atomname Sfac X Y Z Occ
                call getnum(label(2),vet,ivet,iv)   ! Is Sfac integer?
                if (iv /= 1) cycle
                call getnum(label(3),vet,ivet,iv)   ! Is X real?
                if (iv /= 1) cycle
                call getnum(label(4),vet,ivet,iv)   ! Is Y real?
                if (iv /= 1) cycle
                call getnum(label(5),vet,ivet,iv)   ! Is Z real?
                if (iv /= 1) cycle
                call getnum(label(6),vet,ivet,iv)   ! Is Occ real?
                if (iv /= 1) cycle

                n_atom=n_atom+1
                atm%atom(n_atom)%lab=label(1)(1:4)
                call getnum(label(2),vet,ivet,iv)
                el=elem_type(ivet(1))
                atm%atom(n_atom)%chemSymb=U_case(el(1:1))//L_case(el(2:2))
                call getnum(label(3),vet,ivet,iv)
                atm%atom(n_atom)%x(1)=vet(1)
                call getnum(label(4),vet,ivet,iv)
                atm%atom(n_atom)%x(2)=vet(1)
                call getnum(label(5),vet,ivet,iv)
                atm%atom(n_atom)%x(3)=vet(1)
                call getnum(label(6),vet,ivet,iv)
                atm%atom(n_atom)%occ=vet(1)
                atm%atom(n_atom)%utype="u_ij"

             case (7,8) ! Atomname Sfac X Y Z Occ Uiso   (TR: item 8 can be electronic density created by SHELXS)
                call getnum(label(2),vet,ivet,iv)   ! Is Sfac integer?
                if (iv /= 1) cycle
                call getnum(label(3),vet,ivet,iv)   ! Is X real?
                if (iv /= 1) cycle
                call getnum(label(4),vet,ivet,iv)   ! Is Y real?
                if (iv /= 1) cycle
                call getnum(label(5),vet,ivet,iv)   ! Is Z real?
                if (iv /= 1) cycle
                call getnum(label(6),vet,ivet,iv)   ! Is Occ real?
                if (iv /= 1) cycle
                call getnum(label(7),vet,ivet,iv)   ! Is Uiso real?
                if (iv /= 1) cycle

                n_atom=n_atom+1
                atm%atom(n_atom)%lab=label(1)(1:4)
                call getnum(label(2),vet,ivet,iv)
                el=elem_type(ivet(1))
                atm%atom(n_atom)%chemSymb=U_case(el(1:1))//L_case(el(2:2))
                call getnum(label(3),vet,ivet,iv)
                atm%atom(n_atom)%x(1)=vet(1)
                call getnum(label(4),vet,ivet,iv)
                atm%atom(n_atom)%x(2)=vet(1)
                call getnum(label(5),vet,ivet,iv)
                atm%atom(n_atom)%x(3)=vet(1)
                call getnum(label(6),vet,ivet,iv)
                atm%atom(n_atom)%occ=vet(1)
                call getnum(label(7),vet,ivet,iv)
                atm%atom(n_atom)%ueq=vet(1)
                atm%atom(n_atom)%utype="u_ij"
                atm%atom(n_atom)%thtype="isotr"

          case (9) ! Atomname Sfac X Y Z Occ U11 U22 = U33 U23 U13 U12
                call getnum(label(2),vet,ivet,iv)   ! Is Sfac integer?
                if (iv /= 1) cycle
                call getnum(label(3),vet,ivet,iv)   ! Is X real?
                if (iv /= 1) cycle
                call getnum(label(4),vet,ivet,iv)   ! Is Y real?
                if (iv /= 1) cycle
                call getnum(label(5),vet,ivet,iv)   ! Is Z real?
                if (iv /= 1) cycle
                call getnum(label(6),vet,ivet,iv)   ! Is Occ real?
                if (iv /= 1) cycle
                call getnum(label(7),vet,ivet,iv)   ! Is U11 real?
                if (iv /= 1) cycle
                call getnum(label(8),vet,ivet,iv)   ! Is U22 real?
                if (iv /= 1) cycle
                call getnum(filevar(i+1),vet,ivet,iv) ! Are U33 U23 U13 U12?
                if (iv /= 4) cycle

                n_atom=n_atom+1
                atm%atom(n_atom)%lab=label(1)(1:4)
                call getnum(label(2),vet,ivet,iv)
                el=elem_type(ivet(1))
                atm%atom(n_atom)%chemSymb=U_case(el(1:1))//L_case(el(2:2))
                call getnum(label(3),vet,ivet,iv)
                atm%atom(n_atom)%x(1)=vet(1)
                call getnum(label(4),vet,ivet,iv)
                atm%atom(n_atom)%x(2)=vet(1)
                call getnum(label(5),vet,ivet,iv)
                atm%atom(n_atom)%x(3)=vet(1)
                call getnum(label(6),vet,ivet,iv)
                atm%atom(n_atom)%occ=vet(1)
                !---- U11 U22 U33 U12 U13 U23 Order ----!
                call getnum(label(7),vet,ivet,iv)
                atm%atom(n_atom)%u(1)=vet(1)
                call getnum(label(8),vet,ivet,iv)
                atm%atom(n_atom)%u(2)=vet(1)
                call getnum(filevar(i+1),vet,ivet,iv)
                atm%atom(n_atom)%u(3)=vet(1)
                atm%atom(n_atom)%u(4)=vet(4)
                atm%atom(n_atom)%u(5)=vet(3)
                atm%atom(n_atom)%u(6)=vet(2)
                atm%atom(n_atom)%utype="u_ij"
                atm%atom(n_atom)%thtype="aniso"
             case default
                cycle
          end select
       end do

       !---- Adjusting ... ----!
       call allocate_atom_list(n_atom,Atm_list)
       do i=1,n_atom
          atm_list%atom(i)=atm%atom(i)
       end do
       call Deallocate_atom_list(atm)

       !---- Tratamiento de Datos del Shelx ----!
       do i=1,n_atom
          !---- coordinates ----!
          if (atm_list%atom(i)%x(1) >= 10.0) atm_list%atom(i)%x(1)=atm_list%atom(i)%x(1)-10.0
          if (atm_list%atom(i)%x(2) >= 10.0) atm_list%atom(i)%x(2)=atm_list%atom(i)%x(2)-10.0
          if (atm_list%atom(i)%x(3) >= 10.0) atm_list%atom(i)%x(3)=atm_list%atom(i)%x(3)-10.0

          !---- ocupancy ----!
          if (abs(atm_list%atom(i)%occ)  > 10.0) then
             x=atm_list%atom(i)%occ
             if (x > 10.0) then
                atm_list%atom(i)%occ=x-10.0
             else
                x=abs(atm_list%atom(i)%occ)
                do j=2,n_fvar
                   if (x > 10.0*real(j) .and. x < 10.0*real(j+1)) then
                      p=x-10.0*real(j)
                      if (atm_list%atom(i)%occ > 0.0) then
                         atm_list%atom(i)%occ=p*fvar(j)
                      else
                         atm_list%atom(i)%occ=p*(fvar(j)-1.0)
                      end if
                   end if
                end do
             end if
          end if

          !---- Thermal factors ----!
          if (atm_list%atom(i)%thtype == "aniso") then
             atm_list%atom(i)%ueq=U_Equiv(celda,atm_list%atom(i)%u(1:6))  ! Uequi
             atm_list%atom(i)%biso= atm_list%atom(i)%ueq*78.95683521
          else
             if (atm_list%atom(i)%ueq < 0.0) then
                u=-atm_list%atom(i)%ueq
                if (u <= 5.0 .and. u >= 0.5) then
                   do j=i-1,1,-1
                      if (atm_list%atom(j)%ChemSymb == "H " .or. atm_list%atom(j)%ChemSymb == "h " ) cycle
                      atm_list%atom(i)%ueq=u*U_Equiv(celda,atm_list%atom(j)%u(1:6))  ! Uequi
                      atm_list%atom(i)%biso= atm_list%atom(i)%ueq*78.95683521
                   end do
                end if
             end if
          end if

       end do

       return
    End Subroutine Read_Shx_Atom

    !!----
    !!---- Subroutine Read_Shx_Cell(Filevar,Nline_Ini,Nline_End,Celda,Stdcelda,Lambda,Z)
    !!----    character(len=*), dimension(:), intent(in)     :: filevar       !  In -> String vector
    !!----    integer,                        intent(in out) :: nline_ini     !  In -> Line to start the search
    !!----                                                                      Out -> Actual line on Filevar
    !!----    integer,                        intent(in)     :: nline_end     !  In -> Line to finish the search
    !!----    real(kind=cp),dimension(6),     intent(out)    :: celda         ! Out -> Cell Parameters
    !!----    real(kind=cp),dimension(6),     intent(out)    :: Stdcelda      ! Out -> Std Cell Parameters
    !!----    real(kind=cp),                  intent(out)    :: lambda        ! Out -> Lambda
    !!----    integer,                        intent(out)    :: Z             ! Out -> Z
    !!----
    !!----    Obtaining Cell Parameter from Shelx file
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Read_Shx_Cell(filevar,nline_ini,nline_end,Celda,StdCelda,lambda,z)
       !---- Arguments ----!
       character(len=*), dimension(:),     intent(in)     :: filevar
       integer,                            intent(in out) :: nline_ini
       integer,                            intent(in)     :: nline_end
       real(kind=cp),dimension(6),         intent(out)    :: Celda
       real(kind=cp),dimension(6),optional,intent(out)    :: StdCelda
       real(kind=cp),             optional,intent(out)    :: lambda
       integer,          optional,         intent(out)    :: z

       !---- Local Variables ----!
       integer                      :: iv,z_shx
       integer, dimension(10)       :: ivet
       real(kind=cp), dimension(10) :: vet
       real(kind=cp)                :: lambda_shx
       real(kind=cp),dimension(6)   :: std

       !---- Valores iniciales ----!
       celda=0.0
       if (present(stdcelda)) stdcelda=0.0
       if (present(Lambda))   lambda=0.0
       if (present(z))        z=0

       !---- CELL ----!
       call read_key_value(filevar,nline_ini,nline_end,"CELL",vet,ivet,iv)
       if (iv == 7) then
          lambda_shx = vet(1)
          celda      = vet(2:7)
       end if

       !---- Z, STD ----!
       call read_key_value(filevar,nline_ini,nline_end,"ZERR",vet,ivet,iv)
       if (iv == 7) then
          z_shx= ivet(1)
          std  = vet(2:7)
       end if

       if (present(stdcelda)) stdcelda=std
       if (present(lambda)) lambda=lambda_shx
       if (present(z)) z=z_shx

       return
    End Subroutine Read_Shx_Cell

    !!----
    !!---- Subroutine Read_Shx_Cont(Filevar,Nline_Ini,Nline_End,N_Elem_Type,Elem_Type,N_Elem)
    !!----    character(len=*),  dimension(:),    intent(in)    :: filevar       !  In -> String Vector
    !!----    integer,                            intent(in out):: nline_ini     !  In -> Line to start the search
    !!----                                                                         Out -> Actual Line on Filevar
    !!----    integer,                            intent(in)    :: nline_end     !  In -> Line to finish the search
    !!----    integer,                            intent(out)   :: n_elem_type   ! Out -> N. of different species
    !!----    character(len=*), dimension(:),     intent(out)   :: elem_type     ! Out -> Character to identify the specie
    !!----    real(kind=cp),dimension(:),optional,intent(out)   :: n_elem        ! Out -> Number of elements into the same species
    !!----
    !!----    Obtaining Chemical contents from Shelx file (.ins or .res)
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Read_Shx_Cont(filevar,nline_ini,nline_end,n_elem_type,elem_type,n_elem)
       !---- Arguments ----!
       character(len=*), dimension(:),     intent(in)      :: filevar
       integer,                            intent(in out)  :: nline_ini
       integer,                            intent(in)      :: nline_end
       integer,                            intent(out)     :: n_elem_type
       character(len=*), dimension(:),     intent(out)     :: elem_type
       real(kind=cp),dimension(:),optional,intent(out)     :: n_elem

       !---- Local  variables ----!
       character(len=len(filevar(1)))      :: string
       integer                     :: iv
       integer,      dimension(15) :: ivet
       real(kind=cp),dimension(15) :: vet

       n_elem_type = 0
       elem_type   = " "
       if (present(n_elem)) n_elem = 0.0

       call Read_Key_StrVal(filevar,nline_ini,nline_end,"SFAC",string)
       if (len_trim(string) /=0) then
          call getword(string,elem_type,n_elem_type)
       end if

       if (present(n_elem)) then
          call read_key_value(filevar,nline_ini,nline_end,"UNIT",vet,ivet,iv)
          if (iv /= 0) n_elem=vet
       end if

       return
    End Subroutine Read_Shx_Cont

    !!----
    !!---- Subroutine Read_Shx_Fvar(Filevar,Nline_Ini,Nline_End,N_Fvar,Fvar)
    !!----    character(len=*), dimension(:), intent(in)    :: filevar       !  In -> String vector
    !!----    integer,                        intent(in out):: nline_ini     !  In -> Line to start the search
    !!----                                                                   ! Out -> Actual line on Filevar
    !!----    integer,                        intent(in)    :: nline_end     !  In -> Line to finish the search
    !!----    integer,                        intent(out)   :: n_fvar        ! Out -> N. of parameters on FVAR
    !!----    real(kind=cp), dimension(:),    intent(out)   :: fvar          ! Out -> values of FVAR
    !!----
    !!----    Obtaining Fvar parameters from Shelx file (.ins or .res)
    !!----
    !!---- Update: February - 2003
    !!
    Subroutine Read_Shx_Fvar(filevar,nline_ini,nline_end,n_fvar,fvar)
       !---- Arguments ----!
       character(len=*), dimension(:), intent(in)    :: filevar
       integer,                        intent(in out):: nline_ini
       integer,                        intent(in)    :: nline_end
       integer,                        intent(out)   :: n_fvar
       real(kind=cp), dimension(:),    intent(out)   :: fvar

       !---- Local  variables ----!
       integer                      :: iv
       integer,       dimension(15) :: ivet
       real(kind=cp), dimension(15) :: vet

       n_fvar = 1
       fvar   = 1.0

       call read_key_value(filevar,nline_ini,nline_end,"FVAR",vet,ivet,iv)
       if (iv /= 0) then
          n_fvar=iv
          fvar=vet
       end if

       return
    End Subroutine Read_Shx_Fvar

    !!----
    !!---- Subroutine Read_Shx_Latt(Filevar,Nline_Ini,Nline_End,Latt)
    !!----    character(len=*), dimension(:), intent(in) :: filevar     !  In -> String Vector
    !!----    integer,           intent(in out)          :: nline_ini   !  In -> Line to start the search
    !!----                                                                Out -> Actual line on Filevar
    !!----    integer,           intent(in)              :: nline_end   !  In -> Line to finish the search
    !!----    integer,           intent(out)             :: latt        ! Out -> Lattice number
    !!----
    !!----    Obtaining lattice from Shelx file (.ins or .res)
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Read_Shx_Latt(filevar,nline_ini,nline_end,latt)
       !---- Arguments ----!
       character(len=*), dimension(:), intent(in) :: filevar
       integer,           intent(in out)          :: nline_ini
       integer,           intent(in)              :: nline_end
       integer,           intent(out)             :: latt

       !---- Local Variables ----!
       integer                     :: iv
       integer,       dimension(2) :: ivet
       real(kind=cp), dimension(2) :: vet

       latt=1
       call read_key_value(filevar,nline_ini,nline_end,"LATT",vet,ivet,iv)
       if (iv == 1) latt = ivet(1)

       return
    End Subroutine Read_Shx_Latt

    !!----
    !!---- Subroutine Read_Shx_Symm(Filevar,Nline_Ini,Nline_End,N_Oper,Oper_Symm)
    !!----    character(len=*), dimension(:), intent(in) :: filevar       !  In -> String Vector
    !!----    integer,           intent(in out)          :: nline_ini     !  In -> Line to start the search
    !!----                                                                  Out -> Actual Line on Filevar
    !!----    integer,           intent(in)              :: nline_end     !  In -> Line to finish the search
    !!----    integer,           intent(out)             :: n_oper        ! Out -> Number of Operators
    !!----    character(len=*), dimension(:),intent(out) :: oper_symm     ! Out -> String for Symmetry Operators
    !!----
    !!----    Obtaining Symmetry Operators from Shelx file (.ins or .res)
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Read_Shx_Symm(filevar,nline_ini,nline_end,n_oper,oper_symm)
       !---- Arguments ----!
       character(len=*), dimension(:), intent(in) :: filevar
       integer,          intent(in out)           :: nline_ini
       integer,          intent(in)               :: nline_end
       integer,          intent(out)              :: n_oper
       character(len=*), dimension(:),intent(out) :: oper_symm

       !---- Local variables ----!
       character(len=80) :: string
       integer           :: nline

       n_oper=0
       oper_symm=" "

       do
          call Read_Key_StrVal(filevar,nline_ini,nline_end,"SYMM",string)
          if (len_trim(string) /=0) then
             n_oper=n_oper+1
             oper_symm(n_oper)=string
             nline_ini=nline_ini+1
             nline=nline_ini
          else
             exit
          end if
       end do
       nline_ini=nline

       return
    End Subroutine Read_Shx_Symm

    !!----
    !!---- Subroutine Read_Shx_Titl(Filevar,Nline_Ini,Nline_End,Title)
    !!----    character(len=*),dimension(:), intent(in)     :: filevar      !  In -> String Vector
    !!----    integer,                       intent(in out) :: nline_ini    !  In -> Line to start the search
    !!----                                                                    Out -> Actual Line on Filevar
    !!----    integer,                       intent(in)     :: nline_end    !  In -> Line to finish the search
    !!----    character(len=*),              intent(out)    :: title        ! Out -> Title
    !!----
    !!----    Obtaining Title from Shelx file
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Read_Shx_Titl(filevar,nline_ini,nline_end,Title)
       !---- Arguments ----!
       character(len=*),dimension(:), intent(in)     :: filevar
       integer,                       intent(in out) :: nline_ini
       integer,                       intent(in)     :: nline_end
       character(len=*),              intent(out)    :: title

       call Read_Key_StrVal(filevar,nline_ini,nline_end,"TITL",title)

       return
    End Subroutine Read_Shx_Titl

    !!----
    !!---- Subroutine Read_Uvals(Line,Atomo,Ulabel)
    !!----    character(len=*),  intent(in out)  :: line      !  In -> String
    !!----    Type (Atom_Type),  intent(in out)  :: Atomo     !  In -> Atomo variable
    !!----                                                      Out ->
    !!----    character(len=4),  intent(in)      :: ulabel    !  In -> u_ij, b_ij, beta
    !!----
    !!----    Subroutine to read the anisotropic thermal parameters from a given Line
    !!----    it complets the object Atomo of type Atom.
    !!----    Assumes the string Line has been read from a file and
    !!----    starts with one of the words (u_ij, b_ij or beta), that is removed before reading
    !!----    the values of the parameters.
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Read_Uvals(Line,Atomo,Ulabel)
       !---- Arguments ----!
       character(len=*),  intent(in )     :: line
       Type (Atom_Type),  intent(in out)  :: Atomo
       character(len=4),  intent(in)      :: ulabel

       !---- Local variables -----!
       character(len=len(line)),dimension(1):: line2
       real(kind=cp), dimension (6)         :: vet1,vet2
       integer                              :: iv,n

       call init_err_form()

       atomo%utype    = ulabel
       line2(1)=line
       n=1
       call cutst(line2(1))
       line2(1)="Uval "//line2(1)
       call Read_Key_ValueSTD(line2,n,n,"Uval",vet1,vet2,iv)

        if (iv /= 6) then
          err_form=.true.
          ERR_Form_Mess="  Error reading the anisotropic thermal parameters of atom:"//atomo%lab
          return
       end if
       atomo%U(1:6)=vet1(1:6)
       atomo%U_std(1:6)=vet2(1:6)
       atomo%thtype="aniso"

       return
    End Subroutine Read_Uvals

    !!--++
    !!--++ Subroutine Readn_Set_XTal_CFL(file_dat,nlines,Cell,SpG,A,CFrame,NPhase,Job_Info)
    !!--++    character(len=*),dimension(:),intent(in)   :: file_dat
    !!--++    integer,                      intent(in)   :: nlines
    !!--++    Type (Crystal_Cell_Type),     intent(out)  :: Cell
    !!--++    Type (Space_Group_Type),      intent(out)  :: SpG
    !!--++    Type (atom_list_type),        intent(out)  :: A
    !!--++    character(len=*),    optional,intent(in)   :: CFrame
    !!--++    Integer,             optional,intent( in)  :: Nphase
    !!--++    Type(Job_Info_type), optional,intent(out)  :: Job_Info
    !!--++
    !!--++ (Private)
    !!--++ Read and Set Crystal Information in a CFL File
    !!--++
    !!--++ Update: April - 2005
    !!
    Subroutine Readn_Set_XTal_CFL(file_dat,nlines,Cell,SpG,A,CFrame,NPhase,Job_Info)
       !---- Arguments ----!
       character(len=*),dimension(:),intent(in)   :: file_dat
       integer,                      intent(in)   :: nlines
       Type (Crystal_Cell_Type),     intent(out)  :: Cell
       Type (Space_Group_Type),      intent(out)  :: SpG
       Type (atom_list_type),        intent(out)  :: A
       character(len=*),    optional,intent(in)   :: CFrame
       Integer,             optional,intent( in)  :: Nphase
       Type(Job_Info_type), optional,intent(out)  :: Job_Info

       !---- Local variables ----!
       character(len=132)               :: line
       character(len= 20)               :: Spp
       character(len= 40),dimension(192):: gen
       integer                          :: i, nauas, ndata, iph, n_ini,n_end,ngen,k,nsym
       integer, parameter               :: maxph=21  !Maximum number of phases "maxph-1"
       integer, dimension(maxph)        :: ip

       real(kind=cp),dimension(3):: vet

       !---- Standard CrysFML file *.CFL ----!
       nauas=0
       ndata=0
       ip=nlines
       ip(1)=1

       !---- Calculating number of Phases ----!
       do i=1,nlines
          line=adjustl(file_dat(i))
          if (l_case(line(1:6)) == "phase_")  then
             ndata=ndata+1
             ip(ndata)=i
          end if
       end do

       !---- Reading Phase Information ----!
       iph=1
       if (present(nphase)) iph=nphase
       if (present(Job_Info)) then
          n_ini=ip(iph)           !Updated values to handle non-conventional order
          n_end=ip(iph+1)
          call Get_Job_Info(file_dat,n_ini,n_end,Job_info)
       end if

       !---- Reading Cell Parameters ----!
       n_ini=ip(iph)           !Updated values to handle non-conventional order
       n_end=ip(iph+1)
       if(present(CFrame)) then
         call read_File_Cell(file_dat,n_ini,n_end,Cell,CFrame) !Read and construct Cell
       else
         call read_File_Cell(file_dat,n_ini,n_end,Cell) !Read and construct Cell
       end if
       if (err_form) return

       !---- Reading Space Group Information ----!
       n_ini=ip(iph)           !Updated values to handle non-conventional order
       n_end=ip(iph+1)
       call read_File_Spg (file_dat,n_ini,n_end,Spp)
       if (err_form) then !Try to read symmetry operators or generators
         ngen=0
         nsym=0
         do i=n_ini, n_end
           line=l_case(adjustl(file_dat(i)))
           if(line(1:4) == "symm") nsym=nsym+1
           if(line(1:3) == "gen")  ngen=ngen+1
         end do
         if(ngen > 0) then
           k=0
           do i=n_ini, n_end
             line=l_case(adjustl(file_dat(i)))
             if(line(1:3) == "gen")  then
              k=k+1
              gen(k)=adjustl(line(5:))
             end if
           end do
           call Set_SpaceGroup(" ",SpG,gen,ngen,"gen")   !Construct the space group from generators
         else if (nsym > 0) then
           k=0
           do i=n_ini, n_end
             line=l_case(adjustl(file_dat(i)))
             if(line(1:4) == "symm")  then
              k=k+1
              gen(k)=adjustl(line(6:))
             end if
           end do
           call Set_SpaceGroup(" ",SpG,gen,nsym,"fix")  !Construct the space group from fixed symmetry elements
         else
           return
         end if
       else
          call Set_SpaceGroup(Spp,SpG) !Construct the space group
       end if
       !---- Read Atoms Information ----!
       n_ini=ip(iph)           !Updated values to handle non-conventional order
       n_end=ip(iph+1)

       !---- Calculating number of Atoms in the Phase ----!
       do i=n_ini,n_end
          line=adjustl(file_dat(i))
          if (l_case(line(1:4)) == "atom")  nauas=nauas+1
       end do

       if (nauas > 0) then
          call Allocate_atom_list(nauas,A)  !allocation space for Atom list
          call read_File_Atom(file_dat,n_ini,n_end,A)
          if (err_form) return

          do i=1,A%natoms
             vet=A%atom(i)%x
             A%atom(i)%Mult=Get_Multip_Pos(vet,SpG)
             if(A%atom(i)%occ < epss) A%atom(i)%occ=real(A%atom(i)%Mult)/real(SpG%Multip)
             if (A%atom(i)%thtype == "aniso") then
                select case (A%atom(i)%Utype)
                   case ("u_ij")
                      A%atom(i)%u(1:6) =  Convert_U_Betas(A%atom(i)%u(1:6),Cell)
                   case ("b_ij")
                      A%atom(i)%u(1:6) =  Convert_B_Betas(A%atom(i)%u(1:6),Cell)
                end select
                A%atom(i)%Utype="beta"
             end if
          end do
       end if

       return
    End Subroutine Readn_Set_XTal_CFL

    !!--++
    !!--++ Subroutine Readn_Set_XTal_CFL_Molec(file_dat, nlines, Molcrys)
    !!--++    character(len=*),dimension(:),  intent(in)     :: file_dat
    !!--++    integer,                        intent(in)     :: nlines
    !!--++    Type (Molecular_Crystal_Type),  intent(in out) :: Molcrys
    !!--++
    !!--++ (Private)
    !!--++ Read Molecule Information in a CFL
    !!--++
    !!--++ Update: April - 2005
    !!
    Subroutine Readn_Set_XTal_CFL_Molec(file_dat, nlines, Molcrys, Nphase)
       !---- Arguments ----!
       character(len=*),dimension(:),  intent(in)     :: file_dat
       integer,                        intent(in)     :: nlines
       type (Molecular_Crystal_Type),  intent(in out) :: Molcrys
       Integer, optional,              intent(in)     :: Nphase

       !---- Local variables ----!
       character(len=132)            :: line
       integer                       :: i,n,nmol,npos,n_ini,n_end,ierr,nauas, iph, ndata
       integer, parameter               :: maxph=21  !Maximum number of phases "maxph-1"
       integer, dimension(maxph)        :: ip
       real(kind=cp)                 :: theta,phi,chi
       real(kind=cp), dimension(3)   :: x1f,x2f,x3f
       real(kind=cp), dimension(3,3) :: EuM

       !---- Standard CrysFML file *.CFL ----!
       nauas=0
       ndata=0
       ip=nlines
       ip(1)=1

       !---- Calculating number of Phases ----!
       do i=1,nlines
          line=adjustl(file_dat(i))
          if (l_case(line(1:6)) == "phase_")  then
             ndata=ndata+1
             ip(ndata)=i
          end if
       end do

       !---- Reading Phase Information ----!

       if (present(nphase)) then
           iph=nphase
       else
           iph=1
       end if

       n_ini=ip(iph)
       n_end=ip(iph+1)

       !---- Detecting the Molecules defined in the file ----!
       nmol=0
       do i=n_ini,n_end
          line=u_case(adjustl(file_dat(i)))
          if (line(1:1) == " ") cycle
          if (line(1:1) == "!") cycle
          npos=index(line,"MOLE")
          if (npos /= 0) nmol=nmol+1
       end do
       if (nmol==0) return

       !---- Allocating Memory for all molecules ----!
       if (allocated(molcrys%mol)) deallocate(molcrys%mol)
       molcrys%n_mol=nmol
       allocate(molcrys%mol(nmol))

       !---- Reading Molecules ----!

       do n=1,nmol
          !---- Read ----!
          do i=n_ini,n_end
             line=u_case(adjustl(file_dat(i)))
             if (line(1:1) == " ") cycle
             if (line(1:1) == "!") cycle
             npos=index(line,"MOLE")
             if (npos == 0) cycle
             call read_molecule(file_dat,n_ini,n_end,molcrys%mol(n))
             err_form=err_molec
             ERR_Form_Mess=err_molec_mess
             if (err_form) then
                molcrys%n_mol=n-1
                return
             end if
             exit
          end do

          !---- Search for three points (fractional coordinates) ----!
          !---- defining a Cartesian frame                       ----!
          do
             if (n_ini > n_end) exit
             line=adjustl(file_dat(n_ini))
             if (u_case(line(1:9)) == "XYZ_FRAME") then
                read(unit=line(10:),fmt=*,iostat=ierr) x1f,x2f,x3f
                if (ierr == 0) then
                   call get_euler_from_fract(x1f,x2f,x3f,molcrys%Cell%Cr_Orth_cel,phi,theta,chi,EuM, Code="D")
                   molcrys%mol(n)%orient(1)= phi
                   molcrys%mol(n)%orient(2)= theta
                   molcrys%mol(n)%orient(3)= chi
                   molcrys%mol(n)%xcentre= x3f
                   call Set_euler_matrix(molcrys%mol(n)%rot_type, phi,theta,chi,EuM)
                   molcrys%mol(n)%Euler=EuM
                   molcrys%mol(n)%is_EulerMat=.true.
                   molcrys%mol(n)%in_Xtal=.true.
                end if
                n_ini=n_ini+1
                exit
             else
                if (u_case(line(1:4)) =="MOLE") exit
                n_ini=n_ini+1
             end if
          end do

       end do

       return
    End Subroutine Readn_Set_XTal_CFL_Molec

    !!--++
    !!--++ Subroutine Readn_Set_XTal_CIF(file_dat, nlines, Cell, Spg, A, CFrame, NPhase)
    !!--++    character(len=*),dimension(:),intent(in)   :: file_dat
    !!--++    integer,                      intent(in)   :: nlines
    !!--++    Type (Crystal_Cell_Type),     intent(out)  :: Cell
    !!--++    Type (Space_Group_Type),      intent(out)  :: SpG
    !!--++    Type (atom_list_type),        intent(out)  :: A
    !!--++    Character(len=*),    optional,intent( in)  :: CFrame
    !!--++    Integer,             optional,intent( in)  :: Nphase
    !!--++
    !!--++ (Private)
    !!--++ Read and Set Crystal Information in a CIF File
    !!--++
    !!--++ Update: April - 2005
    !!
    Subroutine Readn_Set_XTal_CIF(file_dat, nlines, Cell, Spg, A, CFrame, NPhase)
       !---- Arguments ----!
       character(len=*),dimension(:),intent(in)   :: file_dat
       integer,                      intent(in)   :: nlines
       Type (Crystal_Cell_Type),     intent(out)  :: Cell
       Type (Space_Group_Type),      intent(out)  :: SpG
       Type (atom_list_type),        intent(out)  :: A
       Character(len=*),    optional,intent( in)  :: CFrame
       Integer,             optional,intent( in)  :: Nphase

       !---- Local Variables ----!
       character(len=132)                :: line
       character(len= 20)                :: Spp
       character(len=60), dimension(192) :: symm_car

       integer                   :: i, nauas, ndata, iph, n_ini,n_end,noper
       integer, parameter        :: maxph=21  !Maximum number of phases "maxph-1"
       integer, dimension(maxph) :: ip

       real(kind=cp),dimension(6):: vet,vet2

       ip=nlines
       ip(1)=1

       !---- First determine if there is more than one structure ----!
       do i=1,nlines
          line=adjustl(file_dat(i))
          if (l_case(line(1:5)) == "data_" .and. l_case(line(1:11)) /= "data_global" )  then
             n_ini=i
             ip(1)=i
             exit
          end if
       end do

       ndata=0
       do i=n_ini,nlines
          line=adjustl(file_dat(i))
          if (l_case(line(1:5)) == "data_")  then
             ndata=ndata+1
             if (ndata > maxph-1) then
                err_form=.true.
                ERR_Form_Mess=" => Too many phases in this file "
                return
             end if
             ip(ndata)=i   !Pointer to the number of the line starting a single phase
          end if
       end do

       iph=1
       if (present(nphase)) iph=nphase

       !---- Read Cell Parameters ----!
       n_ini=ip(iph)           !Updated values to handle non-conventional order
       n_end=ip(iph+1)
       call Read_Cif_Cell(file_dat,n_ini,n_end,vet,vet2)
       if (err_form) return
       if(present(CFrame)) then
         call Set_Crystal_Cell(vet(1:3),vet(4:6),Cell,CFrame,vet2(1:3),vet2(4:6))
       else
         call Set_Crystal_Cell(vet(1:3),vet(4:6),Cell,"A",vet2(1:3),vet2(4:6))
       end if
       !---- Read Atoms Information ----!
       n_ini=ip(iph)           !Updated values to handle non-conventional order
       n_end=ip(iph+1)
       call Read_Cif_Atom(file_dat,n_ini,n_end,nauas,A)
       if (err_form) return

       !---- SpaceGroup Information ----!
       n_ini=ip(iph)           !Updated values to handle non-conventional order
       n_end=ip(iph+1)
       call Read_Cif_Hm(file_dat,n_ini,n_end,Spp)

       n_ini=ip(iph)           !Updated values to handle non-conventional order
       n_end=ip(iph+1)
       if (len_trim(Spp) == 0) call Read_Cif_Hall(file_dat,n_ini,n_end,Spp)

       if (len_trim(Spp) == 0) then
          n_ini=ip(iph)           !Updated values to handle non-conventional order
          n_end=ip(iph+1)
          call Read_Cif_Symm(file_dat,n_ini,n_end,noper,symm_car)

          if (noper ==0) then
             err_form=.true.
             ERR_Form_Mess=" => No Space Group/No Symmetry information in this file "
             return
          else
             call Set_SpaceGroup("  ",SpG,symm_car,noper,"GEN")
          end if
       else
          call Set_SpaceGroup(Spp,SpG) !Construct the space group
       end if

       !---- Modify occupation factors and set multiplicity of atoms
       !---- in order to be in agreement with the definitions of Sfac in CrysFML
       !---- Convert Us to Betas and Uiso to Biso
       do i=1,A%natoms
          vet(1:3)=A%atom(i)%x
          A%atom(i)%Mult=Get_Multip_Pos(vet(1:3),SpG)
          A%atom(i)%Occ=A%atom(i)%Occ*real(A%atom(i)%Mult)/real(SpG%Multip)
          if(A%atom(i)%occ < epss) A%atom(i)%occ=real(A%atom(i)%Mult)/real(SpG%Multip)

          select case (A%atom(i)%thtype)
             case ("isotr")
                A%atom(i)%biso= A%atom(i)%ueq*78.95683521

             case ("aniso")
                select case (A%atom(i)%Utype)
                   case ("u_ij")
                      A%atom(i)%u(1:6) =  Convert_U_Betas(A%atom(i)%u(1:6),Cell)
                   case ("b_ij")
                      A%atom(i)%u(1:6) = Convert_B_Betas(A%atom(i)%u(1:6),Cell)
                end select
                A%atom(i)%Utype="beta"

             case default
                A%atom(i)%biso = A%atom(i)%ueq*78.95683521
                A%atom(i)%thtype = "isotr"
          end select
       end do

       return
    End Subroutine Readn_Set_XTal_CIF

    !!--++
    !!--++ Subroutine Readn_Set_XTal_PCR(file_dat, nlines, Cell, Spg, A, CFrame, NPhase)
    !!--++    character(len=*),dimension(:),intent(in)   :: file_dat
    !!--++    integer,                      intent(in)   :: nlines
    !!--++    Type (Crystal_Cell_Type),     intent(out)  :: Cell
    !!--++    Type (Space_Group_Type),      intent(out)  :: SpG
    !!--++    Type (atom_list_type),        intent(out)  :: A
    !!--++    character(len=*),    optional,intent(in)   :: CFrame
    !!--++    Integer,             optional,intent( in)  :: Nphase
    !!--++
    !!--++ (Private)
    !!--++ Read and Set Crystal Information in a PCR File
    !!--++
    !!--++ Update: 17/05/2010
    !!
    Subroutine Readn_Set_XTal_PCR(file_dat, nlines, Cell, Spg, A, CFrame, NPhase)
       !---- Arguments ----!
       character(len=*),dimension(:),intent(in)   :: file_dat
       integer,                      intent(in)   :: nlines
       Type (Crystal_Cell_Type),     intent(out)  :: Cell
       Type (Space_Group_Type),      intent(out)  :: SpG
       Type (atom_list_type),        intent(out)  :: A
       character(len=*),    optional,intent(in)   :: CFrame
       Integer,             optional,intent(in)   :: Nphase

       !---- Local Variables ----!
       logical                           :: multi,ask_phase,is_codewords
       character(len=132)                :: line
       character(len= 20)                :: Spp, label
       integer                           :: i,j, k,iv, nauas, ndata, iph, n_ini,n_end, nlong1
       integer, parameter                :: maxph=21  !Maximum number of phases "maxph-1"
       integer, dimension(maxph)         :: ip
       integer, dimension(30)            :: ivet

       real(kind=cp),dimension(30)       :: vet

       ip=nlines
       ip(1)=1

       !> Simple / Multi format
       multi=.false.
       do i=1,nlines
          line=adjustl(file_dat(i))
          if (line(1:1) =='!' .or. line(1:1)==' ') cycle
          if (index(line,'NPATT ') <=0) cycle
          multi=.true.
       end do

       !> Number of Phases
       if (.not. multi) then
          do i=2,nlines
             line=adjustl(file_dat(i))
             if (line(1:1) =='!' .or. line(1:1)==' ') cycle
             call getnum(line,vet,ivet,iv)
             if (iv > 3) then
                iph=ivet(3)
                exit
             end if
          end do

       else
          do i=1,nlines
             line=adjustl(file_dat(i))
             if (line(1:4) /='!Nph') cycle

             line=adjustl(file_dat(i+1))
             call getnum(line,vet,ivet,iv)
             if (iv > 1) then
                iph=ivet(1)
                exit
             end if
          end do
       end if
       if (iph == 0) then
          err_form=.true.
          ERR_Form_Mess=" No Phase information was found in this PCR file. Please, check it! "
          return
       end if

       !> Locate where begin each Phase
       k=0
       ask_phase=.true.

       do i=1,nlines
          line=adjustl(file_dat(i))
          if (ask_phase) then
             if (index(line,'Data for PHASE') <= 0) cycle
          else
             if (line(1:1) /='!') then
                k=k+1
                ip(k)=i
                if (k == iph) exit

                ask_phase=.true.
             end if
             cycle
          end if
          ask_phase=.false.
       end do
       if (iph /= k) then
          err_form=.true.
          ERR_Form_Mess=" Locating Phases failed in this PCR. Please, check it!"
          return
       end if

       !> Select the Phase
       iph=1
       if (present(nphase)) iph=nphase
       n_ini=ip(iph)
       n_end=ip(iph+1)

       !---- Read Cell Parameters ----!
       do i=n_ini,n_end
          if (index(file_dat(i),'alpha') /=0 .and. index(file_dat(i),'gamma') /=0) then
             do j=i+1,n_end
                line=adjustl(file_dat(j))
                if (line(1:1) == '!' .or. line(1:1) == ' ') cycle
                iv=index(line,'#')
                if (iv > 1) line=line(1:iv-1)

                call getnum(line, vet, ivet,iv)
                if (iv /= 6) then
                   err_form=.true.
                   ERR_Form_Mess=" => Problems reading Cell Parameters on PCR file "
                   return
                end if
                if(present(CFrame)) then
                  call Set_Crystal_Cell(vet(1:3),vet(4:6),Cell,CFrame)
                else
                  call Set_Crystal_Cell(vet(1:3),vet(4:6),Cell)
                end if
                exit
             end do
             exit
          end if
       end do

       !---- SpaceGroup Information ----!
       Spp=' '
       do i=n_ini,n_end
          line=adjustl(file_dat(i))
          if (line(1:1) == '!' .or. line(1:1)==' ') cycle
          if (index(file_dat(i),'<--Space') /=0) then
             j=index(file_dat(i),'<--Space')
             Spp=adjustl(file_dat(i)(1:j-1))
             if (len_trim(Spp) <= 0) then
                err_form=.true.
                ERR_Form_Mess=" => Problems reading Space group on PCR file "
                return
             end if
             call Set_SpaceGroup(Spp,SpG) !Construct the space group
             exit
          end if
       end do

       !---- Read Atoms Information ----!
       do i=n_ini,n_end
          line=adjustl(file_dat(i))
          if (line(1:4) /= '!Nat') cycle
          do j=i+1,n_end
             line=adjustl(file_dat(j))
             if (line(1:1) == '!' .or. line(1:1)==' ') cycle
             call getnum(line(1:5),vet,ivet,iv)
             ndata=ivet(1)
             exit
          end do
          exit
       end do

       if (ndata > 0) then
          call allocate_atom_list(ndata,A)

          is_codewords=.false.
          nauas=0

          do i=n_ini,n_end
             line=adjustl(file_dat(i))
             if (index(line,'!Atom') == 0 .or. index(line,'Typ') == 0) cycle

             do j=i+1,n_end
                line=adjustl(file_dat(j))
                if (line(1:1) == '!' .or. line(1:1)==' ') cycle
                if (is_codewords) then
                   is_codewords=.false.
                   cycle
                end if

                iv=index(line,'#')
                if (iv > 1) line=line(1:iv-1)

                nauas=nauas+1
                ! Atom Label
                call cutst(line,nlong1,label)
                A%atom(nauas)%lab=trim(label)

                ! Atom Type
                call cutst(line,nlong1,label)
                A%Atom(nauas)%chemsymb=U_case(label(1:1))//L_case(label(2:2))

                ! Atom Coordinates,Biso and Occ
                call getnum(line,vet,ivet,iv)
                if (iv < 5) then    !Line reading for the second time anisotropic temperature factors
                   nauas = nauas -1 !see below
                   is_codewords=.true.
                   cycle
                end if

                A%atom(nauas)%x=vet(1:3)
                A%atom(nauas)%Mult=Get_Multip_Pos(vet(1:3),SpG)
                A%atom(nauas)%biso=vet(4)
                A%atom(nauas)%occ=vet(5)
                A%atom(nauas)%thtype='isotr'
                A%atom(nauas)%Utype="beta"
                if (ivet(8) == 2) then    ! Anisotropic reading
                   A%atom(nauas)%thtype='aniso'
                   call getnum(file_dat(j+2),vet,ivet,iv)
                   A%atom(nauas)%u(1:6)=vet(1:6)
                end if
                is_codewords=.true.
                if (nauas == ndata) exit
             end do
             exit
          end do
       end if

       return
    End Subroutine Readn_Set_XTal_PCR

    !!--++
    !!--++ Subroutine Readn_Set_XTal_SHX(file_dat,nlines,Cell,SpG,A,CFrame)
    !!--++    character(len=*),dimension(:),intent(in)   :: file_dat
    !!--++    integer,                      intent(in)   :: nlines
    !!--++    Type (Crystal_Cell_Type),     intent(out)  :: Cell
    !!--++    Type (Space_Group_Type),      intent(out)  :: SpG
    !!--++    Type (Atom_list_type),        intent(out)  :: A
    !!--++    Character(len=*), optional,   intent(in)   :: CFrame
    !!--++
    !!--++ (Private)
    !!--++ Read and Set Crystal Information in a Shelx File
    !!--++
    !!--++ Update: April - 2005
    !!
    Subroutine Readn_Set_XTal_SHX(file_dat,nlines,Cell,SpG,A,CFrame)
       !---- Arguments ----!
       character(len=*),dimension(:),intent(in)   :: file_dat
       integer,                      intent(in)   :: nlines
       Type (Crystal_Cell_Type),     intent(out)  :: Cell
       Type (Space_Group_Type),      intent(out)  :: SpG
       Type (Atom_list_type),        intent(out)  :: A
       Character(len=*), optional,   intent(in)   :: CFrame

       !---- Local Variables ----!
       character(len=60), dimension(192) :: symm_car
       character(len=2),  dimension(15)  :: elem_atm
       integer                           :: i,n_ini, n_end, nl, noper
       integer                           :: n_elem_atm, n_fvar
       real(kind=cp), dimension(6)       :: vet,vet2
       real(kind=cp), dimension(10)      :: fvar

       n_ini=1
       n_end=nlines

       !---- CELL / ZERR ----!
       call Read_Shx_Cell(file_dat,n_ini,n_end,vet,vet2)
       if(present(CFrame)) then
         call Set_Crystal_Cell(vet(1:3),vet(4:6),Cell,CFrame,vet2(1:3),vet2(4:6))
       else
         call Set_Crystal_Cell(vet(1:3),vet(4:6),Cell,"A",vet2(1:3),vet2(4:6))
       end if

       !---- OBTAIN SPACE GROUP (LATT / SYMM) ----!
       call Read_Shx_Latt(file_dat,n_ini,n_end,nl)
       call Read_Shx_Symm(file_dat,n_ini,n_end,noper,symm_car)
       if (nl > 0) then
          noper=noper+1
          symm_car(noper)="-X,-Y,-Z"
       end if
       select case (abs(nl))
          case (2) ! I
             noper=noper+1
             symm_car(noper)="X+1/2,Y+1/2,Z+1/2"
          case (3) ! Rom, Hex
             noper=noper+1
             symm_car(noper)="X+2/3,Y+1/3,Z+1/3"
             noper=noper+1
             symm_car(noper)="X+1/3,Y+2/3,Z+2/3"
          case (4) ! F
             noper=noper+1
             symm_car(noper)="X,Y+1/2,Z+1/2"
          case (5) ! A
             noper=noper+1
             symm_car(noper)="X,Y+1/2,Z+1/2"
             noper=noper+1
             symm_car(noper)="X+1/2,Y,Z+1/2"
             noper=noper+1
             symm_car(noper)="X+1/2,Y+1/2,Z"
          case (6) ! B
             noper=noper+1
             symm_car(noper)="X+1/2,Y,Z+1/2"
          case (7) ! C
             noper=noper+1
             symm_car(noper)="X+1/2,Y+1/2,Z"
       end select ! nl
       call set_spacegroup(" ",SPG,symm_car,noper,"gen")

       !---- ATOMS ----!
       call Read_Shx_Cont(file_dat,n_ini,n_end,n_elem_atm,elem_atm)
       call Read_Shx_Fvar(file_dat,n_ini,n_end,n_fvar,fvar)
       call Read_Shx_Atom(file_dat,n_ini,n_end,n_fvar,fvar,elem_atm,cell,A)
       if (err_form) return

       !---- Convert Us to Betas and Uiso to Biso
       do i=1,A%natoms
          vet(1:3)=A%atom(i)%x
          A%atom(i)%Mult=Get_Multip_Pos(vet(1:3),SpG)

          select case (A%atom(i)%thtype)
             case ("isotr")
                A%atom(i)%biso= A%atom(i)%ueq*78.95683521

             case ("aniso")
                A%atom(i)%ueq=U_Equiv(cell,a%atom(i)%u(1:6))  ! Uequi
                A%atom(i)%biso= A%atom(i)%ueq*78.95683521
                select case (A%atom(i)%Utype)
                   case ("u_ij")
                      A%atom(i)%u(1:6) =  Convert_U_Betas(A%atom(i)%u(1:6),Cell)
                   case ("b_ij")
                      A%atom(i)%u(1:6) = Convert_B_Betas(A%atom(i)%u(1:6),Cell)
                end select
                A%atom(i)%Utype="beta"

             case default
                A%atom(i)%ueq=0.05
                A%atom(i)%biso = A%atom(i)%ueq*78.95683521
                A%atom(i)%thtype = "isotr"
          end select
       end do

       return
    End Subroutine Readn_Set_XTal_SHX

    !!--++
    !!--++ Subroutine Readn_Set_Xtal_Structure_Molcr(filenam,Molcrys,Mode,Iphase, Job_Info, file_list,CFrame)
    !!--++    character(len=*),              intent( in)     :: filenam  ! In -> Name of the file
    !!--++    Type (Molecular_Crystal_Type), intent(out)     :: Molcrys  ! Molecular crytal
    !!--++    Character(len=*),    optional, intent( in)     :: Mode     ! In -> if Mode="CIF" filenam
    !!--++                                                                       is of CIF type format
    !!--++    Integer,             optional, intent( in)     :: Iphase   ! Number of the phase.
    !!--++    Type(Job_Info_type), optional, intent(out)     :: Job_Info ! Diffaction conditions
    !!--++    Type(file_list_type),optional, intent(in out)  :: file_list! Complete file to be used by
    !!--++                                                              the calling program or other procedures
    !!--++    Character(len=*),    optional, intent(in)      :: CFrame
    !!--++    Overloaded
    !!--++    Subroutine to read and input file and construct the crystal structure
    !!--++    in terms of the ofjects Cell, SpG and A. The optional argument Iphase is an integer
    !!--++    telling to the program to read the phase number Iphase in the case of the presence
    !!--++    of more than one phase. If absent only the first phase is read.
    !!--++
    !!--++ Update: April - 2005
    !!
    Subroutine Readn_Set_Xtal_Structure_Molcr(filenam,Molcrys,Mode,Iphase,Job_Info,file_list,CFrame)
       !---- Arguments ----!
       character(len=*),              intent( in)     :: filenam
       Type (Molecular_Crystal_Type), intent(out)     :: Molcrys
       Character(len=*),     optional,intent( in)     :: Mode
       Integer,              optional,intent( in)     :: Iphase
       Type(Job_Info_type),  optional,intent(out)     :: Job_Info
       Type(file_list_type), optional,intent(in out)  :: file_list
       Character(len=*),     optional,intent(in)      :: CFrame
       !---- Local variables -----!
       Type (Atom_list_type)                         :: A
       character(len=132), allocatable, dimension(:) :: file_dat
       character(len=3)                              :: modec
       integer                                       :: i,nlines


       call init_err_form()

       nlines=0
       if (present(file_list)) nlines=file_list%nlines

       !---- Number of Lines in the input file ----!
       if(nlines == 0) then
           call Number_Lines(trim(filenam), nlines)
           if (nlines==0) then
              err_form=.true.
              ERR_Form_Mess="The file "//trim(filenam)//" contains nothing"
              return
           else
              if (allocated(file_dat)) deallocate( file_dat)
              allocate( file_dat(nlines))
              call reading_Lines(trim(filenam),nlines,file_dat)
           end if
           if (present(file_list)) then
              file_list%nlines=nlines
              if (allocated(file_list%line)) deallocate(file_list%line)
              allocate(file_list%line(nlines))
              file_list%line=file_dat
           end if
       else
           if (allocated(file_dat)) deallocate( file_dat)
           allocate( file_dat(nlines))
           file_dat=file_list%line
       end if


       !---- Define the type of file: CIF, CFL, RES,... ----!
       modec=" "
       if (present(mode)) modec=l_case(mode(1:3))

       select case(modec)
           case("cif")
              if (present(iphase)) then
                 if(present(CFrame)) then
                   call readn_set_xtal_cif(file_dat,nlines,molcrys%Cell,molcrys%Spg, A,CFrame,NPhase=IPhase)
                 else
                   call readn_set_xtal_cif(file_dat,nlines,molcrys%Cell,molcrys%Spg, A,NPhase=IPhase)
                 end if
              else
                 if(present(CFrame)) then
                   call readn_set_xtal_cif(file_dat,nlines,molcrys%Cell,molcrys%Spg,A,CFrame)
                 else
                   call readn_set_xtal_cif(file_dat,nlines,molcrys%Cell,molcrys%Spg,A)
                 end if
              end if

           case("pcr")
              if (present(iphase)) then
                 if(present(CFrame)) then
                   call readn_set_xtal_pcr(file_dat,nlines,molcrys%Cell,molcrys%Spg, A,CFrame,NPhase=IPhase)
                 else
                   call readn_set_xtal_pcr(file_dat,nlines,molcrys%Cell,molcrys%Spg, A,NPhase=IPhase)
                 end if
              else
                 if(present(CFrame)) then
                   call readn_set_xtal_pcr(file_dat,nlines,molcrys%Cell,molcrys%Spg,A,CFrame)
                 else
                   call readn_set_xtal_pcr(file_dat,nlines,molcrys%Cell,molcrys%Spg,A)
                 end if
              end if

           case("shx")
              if(present(CFrame)) then
                call readn_set_xtal_shx(file_dat,nlines,molcrys%Cell,molcrys%Spg,A,CFrame)
              else
                call readn_set_xtal_shx(file_dat,nlines,molcrys%Cell,molcrys%Spg,A)
              end if
           case default
              !---- CFL Format ----!
              if (present(Job_Info)) then
                 if (present(iphase)) then
                    if(present(CFrame)) then
                      call readn_set_xtal_cfl(file_dat,nlines,molcrys%Cell,molcrys%Spg,A,CFrame,NPhase=IPhase,Job_Info=Job_Info)
                    else
                      call readn_set_xtal_cfl(file_dat,nlines,molcrys%Cell,molcrys%Spg,A,NPhase=IPhase,Job_Info=Job_Info)
                    end if
                 else
                    if(present(CFrame)) then
                      call readn_set_xtal_cfl(file_dat,nlines,molcrys%Cell,molcrys%Spg,A,CFrame,Job_Info=Job_Info)
                    else
                      call readn_set_xtal_cfl(file_dat,nlines,molcrys%Cell,molcrys%Spg,A,Job_Info=Job_Info)
                    end if
                 end if
              else
                 if (present(iphase)) then
                    if(present(CFrame)) then
                      call readn_set_xtal_cfl(file_dat,nlines,molcrys%Cell,molcrys%Spg,A,CFrame,NPhase=IPhase)
                    else
                      call readn_set_xtal_cfl(file_dat,nlines,molcrys%Cell,molcrys%Spg,A,NPhase=IPhase)
                    end if
                 else
                    if(present(CFrame)) then
                      call readn_set_xtal_cfl(file_dat,nlines,molcrys%Cell,molcrys%Spg,A,CFrame)
                    else
                      call readn_set_xtal_cfl(file_dat,nlines,molcrys%Cell,molcrys%Spg,A)
                    end if
                 end if
              end if
              !---- Reading molecules ----!
              if (present(iphase)) then
                call readn_set_xtal_cfl_molec(file_dat,nlines,molcrys,NPhase=IPhase)
              else
                call readn_set_xtal_cfl_molec(file_dat,nlines,molcrys)
              end if

       end select
       if (err_form) return

       !---- Passing from Atom_List_Type -> Molcrys ----!
       molcrys%n_free=A%natoms
       if (A%natoms > 0) then
          if (allocated(molcrys%Atm)) deallocate(molcrys%Atm)
          allocate(molcrys%Atm(A%natoms))
          molcrys%Atm=A%Atom
       end if

       call deallocate_atom_list(A)

       !---- Testing if Xtal was defined ----!
       if (all(molcrys%cell%cell > 0.0)) then
          do i=1,molcrys%n_mol
             if (.not. molcrys%mol(i)%in_xtal) then
                 molcrys%mol(i)%in_xtal=.true.
             end if
          end do
       end if

       return
    End Subroutine Readn_Set_Xtal_Structure_Molcr

    !!--++
    !!--++ Subroutine Readn_Set_Xtal_Structure_Split(filenam,Cell,SpG,A,Mode,Iphase,Job_Type,File_List,CFrame)
    !!--++    character(len=*),              intent( in)     :: filenam  ! In -> Name of the file
    !!--++    Type (Crystal_Cell_Type),      intent(out)     :: Cell     ! Out -> Cell object
    !!--++    Type (Space_Group_Type),       intent(out)     :: SpG      ! Out -> Space Group object
    !!--++    Type (atom_list_type),         intent(out)     :: A        ! Out -> Atom_List object
    !!--++    Character(len=*),    optional, intent( in)     :: Mode     ! In -> if Mode="CIF" filenam
    !!--++                                                                       is of CIF type format
    !!--++    Integer,             optional, intent( in)     :: Iphase   ! Number of the phase.
    !!--++    Type(Job_Info_type), optional, intent(out)     :: Job_Info ! Diffaction conditions
    !!--++    Type(file_list_type),optional, intent(in out)  :: file_list! Complete file to be used by
    !!--++                                                                 the calling program or other procedures
    !!--++    Character(len=*),    optional, intent( in)     :: CFrame   !Cartesian Frame
    !!--++
    !!--++    Overloaded
    !!--++    Subroutine to read and input file and construct the crystal structure
    !!--++    in terms of the ofjects Cell, SpG and A. The optional argument Iphase is an integer
    !!--++    telling to the program to read the phase number Iphase in the case of the presence
    !!--++    of more than one phase. If absent only the first phase is read.
    !!--++
    !!--++ Update: April - 2005
    !!
    Subroutine Readn_Set_Xtal_Structure_Split(filenam,Cell,SpG,A,Mode,Iphase,Job_Info,file_list,CFrame)
       !---- Arguments ----!
       character(len=*),             intent( in)     :: filenam
       Type (Crystal_Cell_Type),     intent(out)     :: Cell
       Type (Space_Group_Type),      intent(out)     :: SpG
       Type (atom_list_type),        intent(out)     :: A
       Character(len=*),    optional,intent( in)     :: Mode
       Integer,             optional,intent( in)     :: Iphase
       Type(Job_Info_type), optional,intent(out)     :: Job_Info
       Type(file_list_type),optional,intent(in out)  :: file_list
       Character(len=*),    optional,intent( in)     :: CFrame

       !---- Local variables -----!
       character(len=132), allocatable, dimension(:) :: file_dat
       character(len=3)                              :: modec
       integer                                       :: nlines

       call init_err_form()

       nlines=0
       if (present(file_list)) nlines=file_list%nlines

       !---- Number of Lines in the input file ----!
       if(nlines == 0) then
           call Number_Lines(trim(filenam), nlines)
           if (nlines==0) then
              err_form=.true.
              ERR_Form_Mess="The file "//trim(filenam)//" contains nothing"
              return
           else
              if (allocated(file_dat)) deallocate( file_dat)
              allocate( file_dat(nlines))
              call reading_Lines(trim(filenam),nlines,file_dat)
           end if
           if (present(file_list)) then
              file_list%nlines=nlines
              if (allocated(file_list%line)) deallocate(file_list%line)
              allocate(file_list%line(nlines))
              file_list%line=file_dat
           end if
       else
           if (allocated(file_dat)) deallocate( file_dat)
           allocate( file_dat(nlines))
           file_dat=file_list%line
       end if

       !---- Define the type of file: CIF, CFL, RES,... ----!
       modec=" "
       if (present(mode)) modec=l_case(mode(1:3))

       select case(modec)
           case("cif")
              if (present(iphase)) then
                 if(present(CFrame)) then
                   call readn_set_xtal_cif(file_dat,nlines,Cell,Spg, A,CFrame,NPhase=IPhase)
                 else
                   call readn_set_xtal_cif(file_dat,nlines,Cell,Spg, A,NPhase=IPhase)
                 end if
              else
                 if(present(CFrame)) then
                   call readn_set_xtal_cif(file_dat,nlines,Cell,Spg,A,CFrame)
                 else
                   call readn_set_xtal_cif(file_dat,nlines,Cell,Spg,A)
                 end if
              end if

           case("pcr")
              if (present(iphase)) then
                 if(present(CFrame)) then
                   call readn_set_xtal_pcr(file_dat,nlines,Cell,Spg, A,CFrame,NPhase=IPhase)
                 else
                   call readn_set_xtal_pcr(file_dat,nlines,Cell,Spg, A,NPhase=IPhase)
                 end if
              else
                 if(present(CFrame)) then
                   call readn_set_xtal_pcr(file_dat,nlines,Cell,Spg,A,CFrame)
                 else
                   call readn_set_xtal_pcr(file_dat,nlines,Cell,Spg,A)
                 end if
              end if

           case("shx")
              if(present(CFrame)) then
                call readn_set_xtal_shx(file_dat,nlines,Cell,Spg,A,CFrame)
              else
                call readn_set_xtal_shx(file_dat,nlines,Cell,Spg,A)
              end if
           case default
              !---- CFL Format ----!
              if (present(Job_Info)) then
                 if (present(iphase)) then
                    if(present(CFrame)) then
                      call readn_set_xtal_cfl(file_dat,nlines,Cell,Spg,A,CFrame,NPhase=IPhase,Job_Info=Job_Info)
                    else
                      call readn_set_xtal_cfl(file_dat,nlines,Cell,Spg,A,NPhase=IPhase,Job_Info=Job_Info)
                    end if
                 else
                    if(present(CFrame)) then
                      call readn_set_xtal_cfl(file_dat,nlines,Cell,Spg,A,CFrame,Job_Info=Job_Info)
                    else
                      call readn_set_xtal_cfl(file_dat,nlines,Cell,Spg,A,Job_Info=Job_Info)
                    end if
                 end if
              else
                 if (present(iphase)) then
                    if(present(CFrame)) then
                      call readn_set_xtal_cfl(file_dat,nlines,Cell,Spg,A,CFrame,NPhase=IPhase)
                    else
                      call readn_set_xtal_cfl(file_dat,nlines,Cell,Spg,A,NPhase=IPhase)
                    end if
                 else
                    if(present(CFrame)) then
                      call readn_set_xtal_cfl(file_dat,nlines,Cell,Spg,A,CFrame)
                    else
                      call readn_set_xtal_cfl(file_dat,nlines,Cell,Spg,A)
                    end if
                 end if
              end if

       end select

       return
    End Subroutine Readn_Set_Xtal_Structure_Split

    !!----
    !!---- Subroutine Write_Cif_Powder_Profile(Filename,Code)
    !!----    character(len=*), intent(in) :: filename     !  In -> Name of File
    !!----    integer,     intent(in)      :: code         !  In -> 0 Shelxs-Patterson
    !!----                                                          1 Shelxs-Direct Methods
    !!----                                                          2 Shelxl-Refinement
    !!----
    !!----    Write a Cif Powder Profile file
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Write_Cif_Powder_Profile(filename,code)
       !---- Arguments ----!
       character(len=*), intent(in) :: filename
       integer,          intent(in) :: code

       !---- Local Variables ----!
       logical :: info

       integer :: iunit !,nlong

       !---- Inicializacion de variables ----!
       info=.false.
       iunit=0

       !---- Esta abierto este Fichero? ----!
       inquire(file=filename,opened=info)
       if (info) then
          inquire(file=filename,number=iunit)
          close(unit=iunit)
       end if

       !---- Escritura ----!
       if (iunit==0) iunit=61
       open(unit=iunit,file=filename,status="unknown",action="write")
       rewind(unit=iunit)

       !---- Head ----!
       write(unit=iunit,fmt="(a)") "data_profile"

       write(unit=iunit,fmt="(a)") " "
       if (code == 0) then
          write(unit=iunit,fmt="(a)")     "_pd_block_id      ?"
       else
          write(unit=iunit,fmt="(a,i3)")  "_pd_block_id       ",code
       end if

       !---- Profile ----!
       write(unit=iunit,fmt="(a)") " "

       write(unit=iunit,fmt="(a)") "loop_"
       write(unit=iunit,fmt="(a)") "_pd_proc_point_id"
       write(unit=iunit,fmt="(a)") "_pd_proc_2theta_corrected             # one of "
       write(unit=iunit,fmt="(a)") "_pd_proc_energy_incident              # these "
       write(unit=iunit,fmt="(a)") "_pd_proc_d_spacing                    # three"
       write(unit=iunit,fmt="(a)") "_pd_proc_intensity_net"
       write(unit=iunit,fmt="(a)") "_pd_calc_intensity_net "
       write(unit=iunit,fmt="(a)") "_pd_proc_ls_weight      "
       write(unit=iunit,fmt="(a)") "?     ?     ?     ?     ?     ?     ?"

       write(unit=iunit,fmt="(a)") " "
       write(unit=iunit,fmt="(a)") "# The following lines are used to test the character set of files sent by     "
       write(unit=iunit,fmt="(a)") "# network email or other means. They are not part of the CIF data set.        "
       write(unit=iunit,fmt="(a)") "# abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789              "
       write(unit=iunit,fmt="(a)") "# !@#$%^&*()_+{}:"//""""//"~<>?|\-=[];'`,./ "

       close (unit=iunit)

       return
    End Subroutine Write_Cif_Powder_Profile

    !!----
    !!---- Subroutine Write_Cif_Template(filename,type_data,code,cell,SpG,A)
    !!----    character(len=*),        intent(in) :: filename   !  In -> Filename
    !!----    integer,                 intent(in) :: type_data  !  In -> 0: Single Crystal, 1: Powder Data, 2:Only structural data
    !!----    character(len=*),        intent(in) :: code       !  In -> Code name for the data set
    !!----    Type (Crystal_Cell_Type),intent(in) :: Cell       ! Cell type to be output
    !!----    Type (Space_Group_Type), intent(in) :: SpG        ! Space group type to be output
    !!----    Type (Atom_List_Type),   intent(in) :: A          ! Atom list type to be output
    !!----
    !!----    Write a Cif File
    !!----
    !!---- Updated: February - 2005, January 2015
    !!
    Subroutine Write_Cif_Template(filename,type_data,code,cell,SpG,A)
       !---- Arguments ----!
       character(len=*),        intent(in) :: filename
       integer,                 intent(in) :: type_data
       character(len=*),        intent(in) :: code
       Type (Crystal_Cell_Type),intent(in) :: Cell
       Type (Space_Group_Type), intent(in) :: SpG
       Type (Atom_List_Type),   intent(in) :: A

       !---- Local Variables ----!
       logical                           :: info,aniso
       character(len=132)                :: line
       character(len=1), parameter       :: qmark='?'
       character(len=30)                 :: comm,adptyp
       character(len=30),dimension(6)    :: text
       real(kind=cp)                     :: u,su, ocf
       real(kind=cp), dimension(6)       :: Ua,sua,aux
       real(kind=cp), dimension(A%natoms):: occup,soccup
       integer                           :: iunit,i, j

       !---- Initialization of variables ----!
       info=.false.
       iunit=0

       !---- Is this file opened? ----!
       inquire(file=filename,opened=info)
       if (info) then
          inquire(file=filename,number=iunit)
          close(unit=iunit)
       end if

       !---- Writing ----!
       if (iunit==0) iunit=61
       open(unit=iunit,file=filename,status="unknown",action="write")
       rewind(unit=iunit)

       !---- Head Information ----!
       if(type_data == 0) then
           write(unit=iunit,fmt="(a)") "##############################################################################"
           write(unit=iunit,fmt="(a)") "###    CIF submission form for molecular structure report (Acta Cryst. C)  ###"
           write(unit=iunit,fmt="(a)") "##############################################################################"
           write(unit=iunit,fmt="(a)") " "
           write(unit=iunit,fmt="(a)") "#============================================================================="
           write(unit=iunit,fmt="(a)") "data_global"
           write(unit=iunit,fmt="(a)") "#============================================================================="
           write(unit=iunit,fmt="(a)") " "
          else if(type_data > 1) then
           write(unit=iunit,fmt="(a)") "##################################################################"
           write(unit=iunit,fmt="(a)") "###    CIF file from CrysFML, contains only structural data    ###"
           write(unit=iunit,fmt="(a)") "##################################################################"

       end if

       !---- Processing Summary ----!
       if(type_data < 2) then
         write(unit=iunit,fmt="(a)") "# PROCESSING SUMMARY (IUCr Office Use Only)"

         write(unit=iunit,fmt="(a)") " "
         write(unit=iunit,fmt="(a)") "_journal_data_validation_number      ?"

         write(unit=iunit,fmt="(a)") " "
         write(unit=iunit,fmt="(a)") "_journal_date_recd_electronic        ?"
         write(unit=iunit,fmt="(a)") "_journal_date_to_coeditor            ?"
         write(unit=iunit,fmt="(a)") "_journal_date_from_coeditor          ?"
         write(unit=iunit,fmt="(a)") "_journal_date_accepted               ?"
         write(unit=iunit,fmt="(a)") "_journal_date_printers_first         ?"
         write(unit=iunit,fmt="(a)") "_journal_date_printers_final         ?"
         write(unit=iunit,fmt="(a)") "_journal_date_proofs_out             ?"
         write(unit=iunit,fmt="(a)") "_journal_date_proofs_in              ?"
         write(unit=iunit,fmt="(a)") "_journal_coeditor_name               ?"
         write(unit=iunit,fmt="(a)") "_journal_coeditor_code               ?"
         write(unit=iunit,fmt="(a)") "_journal_coeditor_notes"
         write(unit=iunit,fmt="(a)") "; ?"
         write(unit=iunit,fmt="(a)") ";"
         write(unit=iunit,fmt="(a)") "_journal_techeditor_code             ?"
         write(unit=iunit,fmt="(a)") "_journal_techeditor_notes"
         write(unit=iunit,fmt="(a)") "; ?"
         write(unit=iunit,fmt="(a)") ";"
         write(unit=iunit,fmt="(a)") "_journal_coden_ASTM                  ?"
         write(unit=iunit,fmt="(a)") "_journal_name_full                   ?"
         write(unit=iunit,fmt="(a)") "_journal_year                        ?"
         write(unit=iunit,fmt="(a)") "_journal_volume                      ?"
         write(unit=iunit,fmt="(a)") "_journal_issue                       ?"
         write(unit=iunit,fmt="(a)") "_journal_page_first                  ?"
         write(unit=iunit,fmt="(a)") "_journal_page_last                   ?"
         write(unit=iunit,fmt="(a)") "_journal_paper_category              ?"
         write(unit=iunit,fmt="(a)") "_journal_suppl_publ_number           ?"
         write(unit=iunit,fmt="(a)") "_journal_suppl_publ_pages            ?"

         write(unit=iunit,fmt="(a)") " "
         write(unit=iunit,fmt="(a)") "#============================================================================="
         write(unit=iunit,fmt="(a)") " "

         !---- Submission details ----!
         write(unit=iunit,fmt="(a)") "# 1. SUBMISSION DETAILS"
         write(unit=iunit,fmt="(a)") " "

         write(unit=iunit,fmt="(a)") "_publ_contact_author_name            ?   # Name of author for correspondence"
         write(unit=iunit,fmt="(a)") "_publ_contact_author_address             # Address of author for correspondence"
         write(unit=iunit,fmt="(a)") "; ?"
         write(unit=iunit,fmt="(a)") ";"
         write(unit=iunit,fmt="(a)") "_publ_contact_author_email           ?"
         write(unit=iunit,fmt="(a)") "_publ_contact_author_fax             ?"
         write(unit=iunit,fmt="(a)") "_publ_contact_author_phone           ?"

         write(unit=iunit,fmt="(a)") " "
         write(unit=iunit,fmt="(a)") "_publ_contact_letter"
         write(unit=iunit,fmt="(a)") "; ?"
         write(unit=iunit,fmt="(a)") ";"

         write(unit=iunit,fmt="(a)") " "
         write(unit=iunit,fmt="(a)") "_publ_requested_journal              ?"
         write(unit=iunit,fmt="(a)") "_publ_requested_coeditor_name        ?"
         write(unit=iunit,fmt="(a)") "_publ_requested_category             ?   # Acta C: one of CI/CM/CO/FI/FM/FO"

         write(unit=iunit,fmt="(a)") "#=============================================================================="
         write(unit=iunit,fmt="(a)") " "

         !---- Title  and Author List ----!
         write(unit=iunit,fmt="(a)") "# 3. TITLE AND AUTHOR LIST"

         write(unit=iunit,fmt="(a)") " "
         write(unit=iunit,fmt="(a)") "_publ_section_title"
         write(unit=iunit,fmt="(a)") "; ?"
         write(unit=iunit,fmt="(a)") ";"
         write(unit=iunit,fmt="(a)") "_publ_section_title_footnote"
         write(unit=iunit,fmt="(a)") ";"
         write(unit=iunit,fmt="(a)") ";"

         write(unit=iunit,fmt="(a)") " "
         write(unit=iunit,fmt="(a)") "# The loop structure below should contain the names and addresses of all "
         write(unit=iunit,fmt="(a)") "# authors, in the required order of publication. Repeat as necessary."

         write(unit=iunit,fmt="(a)") " "
         write(unit=iunit,fmt="(a)") "loop_"
         write(unit=iunit,fmt="(a)") "    _publ_author_name"
         write(unit=iunit,fmt="(a)") "    _publ_author_footnote"
         write(unit=iunit,fmt="(a)") "    _publ_author_address"
         write(unit=iunit,fmt="(a)") "?                                   #<--'Last name, first name' "
         write(unit=iunit,fmt="(a)") "; ?"
         write(unit=iunit,fmt="(a)") ";"
         write(unit=iunit,fmt="(a)") "; ?"
         write(unit=iunit,fmt="(a)") ";"

         write(unit=iunit,fmt="(a)") " "
         write(unit=iunit,fmt="(a)") "#============================================================================="
         write(unit=iunit,fmt="(a)") " "

         !---- Text ----!
         write(unit=iunit,fmt="(a)") "# 4. TEXT"

         write(unit=iunit,fmt="(a)") " "
         write(unit=iunit,fmt="(a)") "_publ_section_synopsis"
         write(unit=iunit,fmt="(a)") ";  ?"
         write(unit=iunit,fmt="(a)") ";"
         write(unit=iunit,fmt="(a)") "_publ_section_abstract"
         write(unit=iunit,fmt="(a)") "; ?"
         write(unit=iunit,fmt="(a)") ";          "
         write(unit=iunit,fmt="(a)") "_publ_section_comment"
         write(unit=iunit,fmt="(a)") "; ?"
         write(unit=iunit,fmt="(a)") ";"
         write(unit=iunit,fmt="(a)") "_publ_section_exptl_prep      # Details of the preparation of the sample(s)"
         write(unit=iunit,fmt="(a)") "                              # should be given here. "
         write(unit=iunit,fmt="(a)") "; ?"
         write(unit=iunit,fmt="(a)") ";"
         write(unit=iunit,fmt="(a)") "_publ_section_exptl_refinement"
         write(unit=iunit,fmt="(a)") "; ?"
         write(unit=iunit,fmt="(a)") ";"
         write(unit=iunit,fmt="(a)") "_publ_section_references"
         write(unit=iunit,fmt="(a)") "; ?"
         write(unit=iunit,fmt="(a)") ";"
         write(unit=iunit,fmt="(a)") "_publ_section_figure_captions"
         write(unit=iunit,fmt="(a)") "; ?"
         write(unit=iunit,fmt="(a)") ";"
         write(unit=iunit,fmt="(a)") "_publ_section_acknowledgements"
         write(unit=iunit,fmt="(a)") "; ?"
         write(unit=iunit,fmt="(a)") ";"

         write(unit=iunit,fmt="(a)") " "
         write(unit=iunit,fmt="(a)") "#============================================================================="
         write(unit=iunit,fmt="(a)") " "

         !---- Identifier ----!
         write(unit=iunit,fmt="(a)") "#============================================================================="
         write(unit=iunit,fmt="(a)") "# If more than one structure is reported, the remaining sections should be "
         write(unit=iunit,fmt="(a)") "# completed per structure. For each data set, replace the '?' in the"
         write(unit=iunit,fmt="(a)") "# data_? line below by a unique identifier."
       end if !type_data < 2

       write(unit=iunit,fmt="(a)") " "
       if (len_trim(code) == 0) then
          write(unit=iunit,fmt="(a)") "data_?"
       else
          write(unit=iunit,fmt="(a)") "data_"//code(1:len_trim(code))
       end if
       write(unit=iunit,fmt="(a)") " "
       if(type_data < 2) then
         write(unit=iunit,fmt="(a)") " "
         write(unit=iunit,fmt="(a)") "#============================================================================="
         write(unit=iunit,fmt="(a)") " "

         !---- Chemical Data ----!
         write(unit=iunit,fmt="(a)") "# 5. CHEMICAL DATA"

         write(unit=iunit,fmt="(a)") " "
         write(unit=iunit,fmt="(a)") "_chemical_name_systematic"
         write(unit=iunit,fmt="(a)") "; ?"
         write(unit=iunit,fmt="(a)") ";"
         write(unit=iunit,fmt="(a)") "_chemical_name_common             ?"
         write(unit=iunit,fmt="(a)") "_chemical_formula_moiety          ?"
         write(unit=iunit,fmt="(a)") "_chemical_formula_structural      ?"
         write(unit=iunit,fmt="(a)") "_chemical_formula_analytical      ?"
         write(unit=iunit,fmt="(a)") "_chemical_formula_iupac           ?"
         write(unit=iunit,fmt="(a)") "_chemical_formula_sum             ?"
         write(unit=iunit,fmt="(a)") "_chemical_formula_weight          ?"
         write(unit=iunit,fmt="(a)") "_chemical_melting_point           ?"
         write(unit=iunit,fmt="(a)") "_chemical_compound_source         ?       # for minerals and "
         write(unit=iunit,fmt="(a)") "                                          # natural products"

         write(unit=iunit,fmt="(a)") " "
         write(unit=iunit,fmt="(a)") "loop_"
         write(unit=iunit,fmt="(a)") "    _atom_type_symbol               "
         write(unit=iunit,fmt="(a)") "    _atom_type_description          "
         write(unit=iunit,fmt="(a)") "    _atom_type_scat_dispersion_real "
         write(unit=iunit,fmt="(a)") "    _atom_type_scat_dispersion_imag "
         write(unit=iunit,fmt="(a)") "    _atom_type_scat_source          "
         write(unit=iunit,fmt="(a)") "    _atom_type_scat_length_neutron       # include if applicable"
         write(unit=iunit,fmt="(a)") "    ?    ?    ?    ?    ?      ?    "

       end if !type_data < 2
       write(unit=iunit,fmt="(a)") " "
       write(unit=iunit,fmt="(a)") "#============================================================================="
       write(unit=iunit,fmt="(a)") " "
       !---- Crystal Data ----!
       select case (type_data)
          case (0,2) ! Single Crystal or structural data only
             write(unit=iunit,fmt="(a)") "# 6. CRYSTAL DATA"
          case (1) ! Powder Data + Crystal Data
             write(unit=iunit,fmt="(a)") "# 6. POWDER SPECIMEN AND CRYSTAL DATA"
       end select

       write(unit=iunit,fmt="(a)") " "
       write(unit=iunit,fmt="(a)") "_symmetry_cell_setting               ?"
       line=SpG%SPG_Symb
       write(unit=iunit,fmt="(a)") "_symmetry_space_group_name_H-M       '"//trim(line)//"'"
       line=SpG%Hall
       write(unit=iunit,fmt="(a)") "_symmetry_space_group_name_Hall      '"//trim(line)//"'"

       write(unit=iunit,fmt="(a)") " "
       write(unit=iunit,fmt="(a)") "loop_"
       write(unit=iunit,fmt="(a)") "    _symmetry_equiv_pos_as_xyz   #<--must include 'x,y,z'"
       do i=1,SpG%multip
          line="'"//trim(SpG%SymopSymb(i))//"'"
          write(iunit,'(a)') trim(line)
       end do

       write(unit=iunit,fmt="(a)") " "
       do i=1,3
          call setnum_std(Cell%cell(i),Cell%cell_std(i),text(i))
       end do
       do i=1,3
          call setnum_std(Cell%ang(i),Cell%ang_std(i),text(i+3))
       end do
       write(iunit,'(a)') "_cell_length_a                       "//trim(adjustl(text(1)))
       write(iunit,'(a)') "_cell_length_b                       "//trim(adjustl(text(2)))
       write(iunit,'(a)') "_cell_length_c                       "//trim(adjustl(text(3)))
       write(iunit,'(a)') "_cell_angle_alpha                    "//trim(adjustl(text(4)))
       write(iunit,'(a)') "_cell_angle_beta                     "//trim(adjustl(text(5)))
       write(iunit,'(a)') "_cell_angle_gamma                    "//trim(adjustl(text(6)))

       write(unit=iunit,fmt="(a,f14.4)") "_cell_volume                   ",Cell%CellVol
       if(type_data < 2) then
         write(unit=iunit,fmt="(a)") "_cell_formula_units_Z                ?"
         write(unit=iunit,fmt="(a)") "_cell_measurement_temperature        ?"
         write(unit=iunit,fmt="(a)") "_cell_special_details"
         write(unit=iunit,fmt="(a)") "; ?"
         write(unit=iunit,fmt="(a)") ";"
       end if

       select case (type_data)
          case (0) ! Single Crystal
             write(unit=iunit,fmt="(a)") "_cell_measurement_reflns_used        ?"
             write(unit=iunit,fmt="(a)") "_cell_measurement_theta_min          ?"
             write(unit=iunit,fmt="(a)") "_cell_measurement_theta_max          ?"

             write(unit=iunit,fmt="(a)") " "
             write(unit=iunit,fmt="(a)") "_exptl_crystal_description           ?"
             write(unit=iunit,fmt="(a)") "_exptl_crystal_colour                ?"
             write(unit=iunit,fmt="(a)") "_exptl_crystal_size_max              ?"
             write(unit=iunit,fmt="(a)") "_exptl_crystal_size_mid              ?"
             write(unit=iunit,fmt="(a)") "_exptl_crystal_size_min              ?"
             write(unit=iunit,fmt="(a)") "_exptl_crystal_size_rad              ?"
             write(unit=iunit,fmt="(a)") "_exptl_crystal_density_diffrn        ?"
             write(unit=iunit,fmt="(a)") "_exptl_crystal_density_meas          ?"
             write(unit=iunit,fmt="(a)") "_exptl_crystal_density_method        ?"
             write(unit=iunit,fmt="(a)") "_exptl_crystal_F_000                 ?"

          case (1) ! Powder Data
             write(unit=iunit,fmt="(a)") "# The next three fields give the specimen dimensions in mm.  The equatorial"
             write(unit=iunit,fmt="(a)") "# plane contains the incident and diffracted beam."

             write(unit=iunit,fmt="(a)") " "
             write(unit=iunit,fmt="(a)") "_pd_spec_size_axial               ?       # perpendicular to "
             write(unit=iunit,fmt="(a)") "                                          # equatorial plane"

             write(unit=iunit,fmt="(a)") "_pd_spec_size_equat               ?       # parallel to "
             write(unit=iunit,fmt="(a)") "                                          # scattering vector"
             write(unit=iunit,fmt="(a)") "                                          # in transmission"
             write(unit=iunit,fmt="(a)") "_pd_spec_size_thick               ?       # parallel to "
             write(unit=iunit,fmt="(a)") "                                          # scattering vector"
             write(unit=iunit,fmt="(a)") "                                          # in reflection"

             write(unit=iunit,fmt="(a)") " "
             write(unit=iunit,fmt="(a)") "# The next five fields are character fields that describe the specimen."

             write(unit=iunit,fmt="(a)") " "
             write(unit=iunit,fmt="(a)") "_pd_spec_mounting                         # This field should be"
             write(unit=iunit,fmt="(a)") "                                          # used to give details of the "
             write(unit=iunit,fmt="(a)") "                                          # container."
             write(unit=iunit,fmt="(a)") "; ?"
             write(unit=iunit,fmt="(a)") ";"
             write(unit=iunit,fmt="(a)") "_pd_spec_mount_mode               ?       # options are 'reflection'"
             write(unit=iunit,fmt="(a)") "                                          # or 'transmission'"
             write(unit=iunit,fmt="(a)") "_pd_spec_shape                    ?       # options are 'cylinder' "
             write(unit=iunit,fmt="(a)") "                                          # 'flat_sheet' or 'irregular'"
             write(unit=iunit,fmt="(a)") "_pd_char_particle_morphology      ?"
             write(unit=iunit,fmt="(a)") "_pd_char_colour                   ?       # use ICDD colour descriptions"

             write(unit=iunit,fmt="(a)") " "
             write(unit=iunit,fmt="(a)") "# The following three fields describe the preparation of the specimen."
             write(unit=iunit,fmt="(a)") "# The cooling rate is in K/min.  The pressure at which the sample was "
             write(unit=iunit,fmt="(a)") "# prepared is in kPa.  The temperature of preparation is in K.        "

             write(unit=iunit,fmt="(a)") " "
             write(unit=iunit,fmt="(a)") "_pd_prep_cool_rate                ?"
             write(unit=iunit,fmt="(a)") "_pd_prep_pressure                 ?"
             write(unit=iunit,fmt="(a)") "_pd_prep_temperature              ?"
       end select
       if(type_data < 2) then
         write(unit=iunit,fmt="(a)") " "
         write(unit=iunit,fmt="(a)") "# The next four fields are normally only needed for transmission experiments."
         write(unit=iunit,fmt="(a)") " "
         write(unit=iunit,fmt="(a)") "_exptl_absorpt_coefficient_mu        ?"
         write(unit=iunit,fmt="(a)") "_exptl_absorpt_correction_type       ?"
         write(unit=iunit,fmt="(a)") "_exptl_absorpt_process_details       ?"
         write(unit=iunit,fmt="(a)") "_exptl_absorpt_correction_T_min      ?"
         write(unit=iunit,fmt="(a)") "_exptl_absorpt_correction_T_max      ?"

         write(unit=iunit,fmt="(a)") " "
         write(unit=iunit,fmt="(a)") "#============================================================================="
         write(unit=iunit,fmt="(a)") " "

         !---- Experimental Data ----!
         write(unit=iunit,fmt="(a)") "# 7. EXPERIMENTAL DATA"

         write(unit=iunit,fmt="(a)") " "
         write(unit=iunit,fmt="(a)") "_exptl_special_details"
         write(unit=iunit,fmt="(a)") "; ?"
         write(unit=iunit,fmt="(a)") ";"

         if (type_data == 1) then
            write(unit=iunit,fmt="(a)") " "
            write(unit=iunit,fmt="(a)") "# The following item is used to identify the equipment used to record "
            write(unit=iunit,fmt="(a)") "# the powder pattern when the diffractogram was measured at a laboratory "
            write(unit=iunit,fmt="(a)") "# other than the authors' home institution, e.g. when neutron or synchrotron"
            write(unit=iunit,fmt="(a)") "# radiation is used."

            write(unit=iunit,fmt="(a)") " "
            write(unit=iunit,fmt="(a)") "_pd_instr_location"
            write(unit=iunit,fmt="(a)") "; ?"
            write(unit=iunit,fmt="(a)") ";"
            write(unit=iunit,fmt="(a)") "_pd_calibration_special_details           # description of the method used"
            write(unit=iunit,fmt="(a)") "                                          # to calibrate the instrument"
            write(unit=iunit,fmt="(a)") "; ?"
            write(unit=iunit,fmt="(a)") ";"
         end if

         write(unit=iunit,fmt="(a)") " "
         write(unit=iunit,fmt="(a)") "_diffrn_ambient_temperature          ?"
         write(unit=iunit,fmt="(a)") "_diffrn_radiation_type               ?"
         write(unit=iunit,fmt="(a)") "_diffrn_radiation_wavelength         ?"
         write(unit=iunit,fmt="(a)") "_diffrn_radiation_source             ?"
         write(unit=iunit,fmt="(a)") "_diffrn_source                       ?"
         write(unit=iunit,fmt="(a)") "_diffrn_source_target                ?"
         write(unit=iunit,fmt="(a)") "_diffrn_source_type                  ?"

         write(unit=iunit,fmt="(a)") " "
         write(unit=iunit,fmt="(a)") "_diffrn_radiation_monochromator      ?"
         write(unit=iunit,fmt="(a)") "_diffrn_measurement_device_type      ?"
         write(unit=iunit,fmt="(a)") "_diffrn_measurement_method           ?"
         write(unit=iunit,fmt="(a)") "_diffrn_detector_area_resol_mean     ?   # Not in version 2.0.1"
         write(unit=iunit,fmt="(a)") "_diffrn_detector                     ?"
         write(unit=iunit,fmt="(a)") "_diffrn_detector_type                ?   # make or model of detector"
         if (type_data == 1) then
            write(unit=iunit,fmt="(a)") "_pd_meas_scan_method                 ?   # options are 'step', 'cont',"
            write(unit=iunit,fmt="(a)") "                                         # 'tof', 'fixed' or"
            write(unit=iunit,fmt="(a)") "                                         # 'disp' (= dispersive)"
            write(unit=iunit,fmt="(a)") "_pd_meas_special_details"
            write(unit=iunit,fmt="(a)") ";  ?"
            write(unit=iunit,fmt="(a)") ";"
         end if

         select case (type_data)
            case (0)
               write(unit=iunit,fmt="(a)") " "
               write(unit=iunit,fmt="(a)") "_diffrn_reflns_number                ?"
               write(unit=iunit,fmt="(a)") "_diffrn_reflns_av_R_equivalents      ?"
               write(unit=iunit,fmt="(a)") "_diffrn_reflns_av_sigmaI/netI        ?"
               write(unit=iunit,fmt="(a)") "_diffrn_reflns_theta_min             ?"
               write(unit=iunit,fmt="(a)") "_diffrn_reflns_theta_max             ?"
               write(unit=iunit,fmt="(a)") "_diffrn_reflns_theta_full            ?   # Not in version 2.0.1"
               write(unit=iunit,fmt="(a)") "_diffrn_measured_fraction_theta_max  ?   # Not in version 2.0.1"
               write(unit=iunit,fmt="(a)") "_diffrn_measured_fraction_theta_full ?   # Not in version 2.0.1"
               write(unit=iunit,fmt="(a)") "_diffrn_reflns_limit_h_min           ?"
               write(unit=iunit,fmt="(a)") "_diffrn_reflns_limit_h_max           ?"
               write(unit=iunit,fmt="(a)") "_diffrn_reflns_limit_k_min           ?"
               write(unit=iunit,fmt="(a)") "_diffrn_reflns_limit_k_max           ?"
               write(unit=iunit,fmt="(a)") "_diffrn_reflns_limit_l_min           ?"
               write(unit=iunit,fmt="(a)") "_diffrn_reflns_limit_l_max           ?"
               write(unit=iunit,fmt="(a)") "_diffrn_reflns_reduction_process     ?"

               write(unit=iunit,fmt="(a)") " "
               write(unit=iunit,fmt="(a)") "_diffrn_standards_number             ?"
               write(unit=iunit,fmt="(a)") "_diffrn_standards_interval_count     ?"
               write(unit=iunit,fmt="(a)") "_diffrn_standards_interval_time      ?"
               write(unit=iunit,fmt="(a)") "_diffrn_standards_decay_%            ?"
               write(unit=iunit,fmt="(a)") "loop_"
               write(unit=iunit,fmt="(a)") "    _diffrn_standard_refln_index_h"
               write(unit=iunit,fmt="(a)") "    _diffrn_standard_refln_index_k"
               write(unit=iunit,fmt="(a)") "    _diffrn_standard_refln_index_l"
               write(unit=iunit,fmt="(a)") "?   ?   ?"

            case (1)
               write(unit=iunit,fmt="(a)") " "
               write(unit=iunit,fmt="(a)") "#  The following four items give details of the measured (not processed)"
               write(unit=iunit,fmt="(a)") "#  powder pattern.  Angles are in degrees."

               write(unit=iunit,fmt="(a)") " "
               write(unit=iunit,fmt="(a)") "_pd_meas_number_of_points         ?"
               write(unit=iunit,fmt="(a)") "_pd_meas_2theta_range_min         ?"
               write(unit=iunit,fmt="(a)") "_pd_meas_2theta_range_max         ?"
               write(unit=iunit,fmt="(a)") "_pd_meas_2theta_range_inc         ?"

               write(unit=iunit,fmt="(a)") " "
               write(unit=iunit,fmt="(a)") "# The following three items are used for time-of-flight measurements only."

               write(unit=iunit,fmt="(a)") " "
               write(unit=iunit,fmt="(a)") "_pd_instr_dist_src/spec           ?"
               write(unit=iunit,fmt="(a)") "_pd_instr_dist_spec/detc          ?"
               write(unit=iunit,fmt="(a)") "_pd_meas_2theta_fixed             ?"

         end select

         write(unit=iunit,fmt="(a)") " "
         write(unit=iunit,fmt="(a)") "#============================================================================="
         write(unit=iunit,fmt="(a)") " "

         !---- Refinement Data ----!
         write(unit=iunit,fmt="(a)") "# 8. REFINEMENT DATA"

         write(unit=iunit,fmt="(a)") " "

         write(unit=iunit,fmt="(a)") "_refine_special_details"
         write(unit=iunit,fmt="(a)") "; ?"
         write(unit=iunit,fmt="(a)") ";"

         if (type_data == 1) then
            write(unit=iunit,fmt="(a)") " "
            write(unit=iunit,fmt="(a)") "# Use the next field to give any special details about the fitting of the"
            write(unit=iunit,fmt="(a)") "# powder pattern."

            write(unit=iunit,fmt="(a)") " "
            write(unit=iunit,fmt="(a)") "_pd_proc_ls_special_details"
            write(unit=iunit,fmt="(a)") "; ?"
            write(unit=iunit,fmt="(a)") ";"

            write(unit=iunit,fmt="(a)") " "
            write(unit=iunit,fmt="(a)") "# The next three items are given as text."
            write(unit=iunit,fmt="(a)") " "

            write(unit=iunit,fmt="(a)") "_pd_proc_ls_profile_function      ?"
            write(unit=iunit,fmt="(a)") "_pd_proc_ls_background_function   ?"
            write(unit=iunit,fmt="(a)") "_pd_proc_ls_pref_orient_corr"
            write(unit=iunit,fmt="(a)") "; ?"
            write(unit=iunit,fmt="(a)") ";"
         end if

         select case (type_data)
            case (0)
               write(unit=iunit,fmt="(a)") " "
               write(unit=iunit,fmt="(a)") "_reflns_number_total                 ?"
               write(unit=iunit,fmt="(a)") "_reflns_number_gt                    ?  # Not in version 2.0.1"
               write(unit=iunit,fmt="(a)") "_reflns_threshold_expression         ?  # Not in version 2.0.1"

            case (1)
               write(unit=iunit,fmt="(a)") " "
               write(unit=iunit,fmt="(a)") "_pd_proc_ls_prof_R_factor         ?"
               write(unit=iunit,fmt="(a)") "_pd_proc_ls_prof_wR_factor        ?"
               write(unit=iunit,fmt="(a)") "_pd_proc_ls_prof_wR_expected      ?"

              write(unit=iunit,fmt="(a)") " "
              write(unit=iunit,fmt="(a)") "# The following four items apply to angular dispersive measurements."
              write(unit=iunit,fmt="(a)") "# 2theta minimum, maximum and increment (in degrees) are for the "
              write(unit=iunit,fmt="(a)") "# intensities used in the refinement."

              write(unit=iunit,fmt="(a)") " "
              write(unit=iunit,fmt="(a)") "_pd_proc_2theta_range_min         ?"
              write(unit=iunit,fmt="(a)") "_pd_proc_2theta_range_max         ?"
              write(unit=iunit,fmt="(a)") "_pd_proc_2theta_range_inc         ?"
              write(unit=iunit,fmt="(a)") "_pd_proc_wavelength               ?"

              write(unit=iunit,fmt="(a)") " "
              write(unit=iunit,fmt="(a)") "_pd_block_diffractogram_id        ?  # The id used for the block containing"
              write(unit=iunit,fmt="(a)") "                                     # the powder pattern profile (section 11)."

              write(unit=iunit,fmt="(a)") " "
              write(unit=iunit,fmt="(a)") "# Give appropriate details in the next two text fields."
              write(unit=iunit,fmt="(a)") " "
              write(unit=iunit,fmt="(a)") "_pd_proc_info_excluded_regions    ?"
              write(unit=iunit,fmt="(a)") "_pd_proc_info_data_reduction      ?"

         end select

         write(unit=iunit,fmt="(a)") " "
         write(unit=iunit,fmt="(a)") "_refine_ls_structure_factor_coef     ?"
         write(unit=iunit,fmt="(a)") "_refine_ls_matrix_type               ?"
         write(unit=iunit,fmt="(a)") "_refine_ls_R_I_factor                ?"
         write(unit=iunit,fmt="(a)") "_refine_ls_R_Fsqd_factor             ?"
         write(unit=iunit,fmt="(a)") "_refine_ls_R_factor_all              ?"
         write(unit=iunit,fmt="(a)") "_refine_ls_R_factor_gt               ?   # Not in version 2.0.1"
         write(unit=iunit,fmt="(a)") "_refine_ls_wR_factor_all             ?"
         write(unit=iunit,fmt="(a)") "_refine_ls_wR_factor_ref             ?   # Not in version 2.0.1"
         write(unit=iunit,fmt="(a)") "_refine_ls_goodness_of_fit_all       ?"
         write(unit=iunit,fmt="(a)") "_refine_ls_goodness_of_fit_ref       ?   # Not in version 2.0.1"
         write(unit=iunit,fmt="(a)") "_refine_ls_restrained_S_all          ?"
         write(unit=iunit,fmt="(a)") "_refine_ls_restrained_S_obs          ?"
         write(unit=iunit,fmt="(a)") "_refine_ls_number_reflns             ?"
         write(unit=iunit,fmt="(a)") "_refine_ls_number_parameters         ?"
         write(unit=iunit,fmt="(a)") "_refine_ls_number_restraints         ?"
         write(unit=iunit,fmt="(a)") "_refine_ls_number_constraints        ?"
         write(unit=iunit,fmt="(a)") "_refine_ls_hydrogen_treatment        ?"
         write(unit=iunit,fmt="(a)") "_refine_ls_weighting_scheme          ?"
         write(unit=iunit,fmt="(a)") "_refine_ls_weighting_details         ?"
         write(unit=iunit,fmt="(a)") "_refine_ls_shift/su_max              ?   # Not in version 2.0.1"
         write(unit=iunit,fmt="(a)") "_refine_ls_shift/su_mean             ?   # Not in version 2.0.1"
         write(unit=iunit,fmt="(a)") "_refine_diff_density_max             ?"
         write(unit=iunit,fmt="(a)") "_refine_diff_density_min             ?"
         write(unit=iunit,fmt="(a)") "_refine_ls_extinction_method         ?"
         write(unit=iunit,fmt="(a)") "_refine_ls_extinction_coef           ?"
         write(unit=iunit,fmt="(a)") "_refine_ls_abs_structure_details     ?"
         write(unit=iunit,fmt="(a)") "_refine_ls_abs_structure_Flack       ?"
         write(unit=iunit,fmt="(a)") "_refine_ls_abs_structure_Rogers      ?"

         write(unit=iunit,fmt="(a)") " "
         write(unit=iunit,fmt="(a)") "# The following items are used to identify the programs used."
         write(unit=iunit,fmt="(a)") " "

         write(unit=iunit,fmt="(a)") "_computing_data_collection           ?"
         write(unit=iunit,fmt="(a)") "_computing_cell_refinement           ?"
         write(unit=iunit,fmt="(a)") "_computing_data_reduction            ?"
         write(unit=iunit,fmt="(a)") "_computing_structure_solution        ?"
         write(unit=iunit,fmt="(a)") "_computing_structure_refinement      ?"
         write(unit=iunit,fmt="(a)") "_computing_molecular_graphics        ?"
         write(unit=iunit,fmt="(a)") "_computing_publication_material      ?"

       End if  !(type_data < 2) then
       write(unit=iunit,fmt="(a)") " "
       write(unit=iunit,fmt="(a)") "#============================================================================="
       write(unit=iunit,fmt="(a)") " "
       !---- Atomic Coordinates and Displacement Parameters ----!
       write(unit=iunit,fmt="(a)") "# 9. ATOMIC COORDINATES AND DISPLACEMENT PARAMETERS"

       write(unit=iunit,fmt="(a)") " "

       write(unit=iunit,fmt="(a)") "loop_"
       write(unit=iunit,fmt='(a)') "    _atom_site_label"
       write(unit=iunit,fmt='(a)') "    _atom_site_fract_x"
       write(unit=iunit,fmt='(a)') "    _atom_site_fract_y"
       write(unit=iunit,fmt='(a)') "    _atom_site_fract_z"
       write(unit=iunit,fmt='(a)') "    _atom_site_U_iso_or_equiv"
       write(unit=iunit,fmt='(a)') "    _atom_site_occupancy"
       write(unit=iunit,fmt='(a)') "    _atom_site_adp_type              # Not in version 2.0.1"
       write(unit=iunit,fmt='(a)') "    _atom_site_type_symbol"

       !Calculation of the factor corresponding to the occupation factor provided in A
       do i=1,A%natoms
         occup(i)=A%Atom(i)%occ/(real(A%Atom(i)%mult)/real(SpG%multip))
         soccup(i)=A%Atom(i)%occ_std/(real(A%Atom(i)%mult)/real(SpG%multip))
       end do
       ocf=sum(abs(A%atom(1)%x-A%atom(2)%x))
       if( ocf < 0.001) then
         ocf=occup(1)+occup(2)
       else
         ocf=occup(1)
       end if
       occup=occup/ocf; soccup=soccup/ocf
       aniso=.false.
       do i=1,A%natoms
          line(1:132)=" "
          line(2:)= A%Atom(i)%Lab
           ! _atom_site_fract_x, _atom_site_fract_y, _atom_site_fract_z
          do j=1,3
            comm=" "
            call setnum_std(A%Atom(i)%x(j),A%Atom(i)%x_std(j),comm)
            line=trim(line)//" "//trim(comm)
          end do
          ! _atom_site_U_iso_or_equiv
            comm=" "
          if(A%Atom(i)%thtype == "isotr") then
            adptyp='Uiso'
            u=A%Atom(i)%Biso/(8.0*pi*pi)
            su=A%Atom(i)%Biso_std/(8.0*pi*pi)
            call setnum_std(u,su,comm)

          else if(A%Atom(i)%thtype == "aniso") then
            aniso=.true.
            adptyp='Uani'
            if(A%atom(i)%Utype == "beta") then
               aux=A%atom(i)%u
               ua=convert_betas_u(aux,cell)
               aux=A%atom(i)%u_std
               sua=convert_betas_u(aux,cell)
            else if(A%atom(i)%Utype == "u_ij") then
               ua=A%atom(i)%u
               sua=A%atom(i)%u_std
            end if
            u=(ua(1)+ua(2)+ua(3))/3.0
            su=(ua(1)+ua(2)+ua(3))/3.0
            call setnum_std(u,su,comm)
          else
            adptyp='.'
          end if
            line=trim(line)//" "//trim(comm)

           !_atom_site_occupancy
            comm=" "
            call setnum_std(occup(i),soccup(i),comm)
            line=trim(line)//" "//trim(comm)

          WRITE(iunit,"(a)") trim(line)//" "//trim(adptyp)//" "//A%atom(i)%SfacSymb
       end do
       if(aniso) then
          write(unit=iunit,fmt="(a)") " "
          write(unit=iunit,fmt="(a)") "loop_"
          write(unit=iunit,fmt="(a)") "    _atom_site_aniso_label "
          write(unit=iunit,fmt="(a)") "    _atom_site_aniso_U_11  "
          write(unit=iunit,fmt="(a)") "    _atom_site_aniso_U_22  "
          write(unit=iunit,fmt="(a)") "    _atom_site_aniso_U_33  "
          write(unit=iunit,fmt="(a)") "    _atom_site_aniso_U_12  "
          write(unit=iunit,fmt="(a)") "    _atom_site_aniso_U_13  "
          write(unit=iunit,fmt="(a)") "    _atom_site_aniso_U_23  "
          write(unit=iunit,fmt="(a)") "    _atom_site_aniso_type_symbol"
          do i=1,A%natoms
             if(A%Atom(i)%thtype /= "aniso") cycle
             line(1:132)=" "
             line(2:)= A%Atom(i)%Lab
             if(A%atom(i)%Utype == "beta") then
                aux=A%atom(i)%u
                ua=convert_betas_u(aux,cell)
                aux=A%atom(i)%u_std
                sua=convert_betas_u(aux,cell)
             else if(A%atom(i)%Utype == "u_ij") then
                ua=A%atom(i)%u
                sua=A%atom(i)%u_std
             end if
             do j=1,6
               comm=" "
               call setnum_std(ua(j),sua(j),comm)
               line=trim(line)//" "//trim(comm)
             end do
              WRITE(iunit,"(a)") trim(line)//"  "//A%atom(i)%SfacSymb
          end do
       end if

       if(type_data < 2) then
          write(unit=iunit,fmt="(a)") " "
          write(unit=iunit,fmt="(a)") "# Note: if the displacement parameters were refined anisotropically"
          write(unit=iunit,fmt="(a)") "# the U matrices should be given as for single-crystal studies."

          write(unit=iunit,fmt="(a)") " "
          write(unit=iunit,fmt="(a)") "#============================================================================="
          write(unit=iunit,fmt="(a)") " "

          !---- Molecular Geometry ----!
          write(unit=iunit,fmt="(a)") "# 10. MOLECULAR GEOMETRY"

          write(unit=iunit,fmt="(a)") " "


          write(unit=iunit,fmt="(a)") "_geom_special_details                ?"

          write(unit=iunit,fmt="(a)") " "
          write(unit=iunit,fmt="(a)") "loop_"
          write(unit=iunit,fmt="(a)") "    _geom_bond_atom_site_label_1  "
          write(unit=iunit,fmt="(a)") "    _geom_bond_atom_site_label_2  "
          write(unit=iunit,fmt="(a)") "    _geom_bond_site_symmetry_1    "
          write(unit=iunit,fmt="(a)") "    _geom_bond_site_symmetry_2    "
          write(unit=iunit,fmt="(a)") "    _geom_bond_distance           "
          write(unit=iunit,fmt="(a)") "    _geom_bond_publ_flag          "
          write(unit=iunit,fmt="(a)") "    ?   ?   ?   ?   ?   ?"

          write(unit=iunit,fmt="(a)") " "
          write(unit=iunit,fmt="(a)") "loop_"
          write(unit=iunit,fmt="(a)") "    _geom_contact_atom_site_label_1 "
          write(unit=iunit,fmt="(a)") "    _geom_contact_atom_site_label_2 "
          write(unit=iunit,fmt="(a)") "    _geom_contact_distance          "
          write(unit=iunit,fmt="(a)") "    _geom_contact_site_symmetry_1   "
          write(unit=iunit,fmt="(a)") "    _geom_contact_site_symmetry_2   "
          write(unit=iunit,fmt="(a)") "    _geom_contact_publ_flag         "
          write(unit=iunit,fmt="(a)") "    ?   ?   ?   ?   ?   ?"

          write(unit=iunit,fmt="(a)") " "
          write(unit=iunit,fmt="(a)") "loop_"
          write(unit=iunit,fmt="(a)") "_geom_angle_atom_site_label_1 "
          write(unit=iunit,fmt="(a)") "_geom_angle_atom_site_label_2 "
          write(unit=iunit,fmt="(a)") "_geom_angle_atom_site_label_3 "
          write(unit=iunit,fmt="(a)") "_geom_angle_site_symmetry_1   "
          write(unit=iunit,fmt="(a)") "_geom_angle_site_symmetry_2   "
          write(unit=iunit,fmt="(a)") "_geom_angle_site_symmetry_3   "
          write(unit=iunit,fmt="(a)") "_geom_angle                   "
          write(unit=iunit,fmt="(a)") "_geom_angle_publ_flag         "
          write(unit=iunit,fmt="(a)") "?   ?   ?   ?   ?   ?   ?   ?"

          write(unit=iunit,fmt="(a)") " "
          write(unit=iunit,fmt="(a)") "loop_"
          write(unit=iunit,fmt="(a)") "_geom_torsion_atom_site_label_1 "
          write(unit=iunit,fmt="(a)") "_geom_torsion_atom_site_label_2 "
          write(unit=iunit,fmt="(a)") "_geom_torsion_atom_site_label_3 "
          write(unit=iunit,fmt="(a)") "_geom_torsion_atom_site_label_4 "
          write(unit=iunit,fmt="(a)") "_geom_torsion_site_symmetry_1   "
          write(unit=iunit,fmt="(a)") "_geom_torsion_site_symmetry_2   "
          write(unit=iunit,fmt="(a)") "_geom_torsion_site_symmetry_3   "
          write(unit=iunit,fmt="(a)") "_geom_torsion_site_symmetry_4   "
          write(unit=iunit,fmt="(a)") "_geom_torsion                   "
          write(unit=iunit,fmt="(a)") "_geom_torsion_publ_flag         "
          write(unit=iunit,fmt="(a)") "?   ?   ?   ?   ?   ?   ?   ?   ?   ?"

          write(unit=iunit,fmt="(a)") " "
          write(unit=iunit,fmt="(a)") "loop_"
          write(unit=iunit,fmt="(a)") "_geom_hbond_atom_site_label_D "
          write(unit=iunit,fmt="(a)") "_geom_hbond_atom_site_label_H "
          write(unit=iunit,fmt="(a)") "_geom_hbond_atom_site_label_A "
          write(unit=iunit,fmt="(a)") "_geom_hbond_site_symmetry_D   "
          write(unit=iunit,fmt="(a)") "_geom_hbond_site_symmetry_H   "
          write(unit=iunit,fmt="(a)") "_geom_hbond_site_symmetry_A   "
          write(unit=iunit,fmt="(a)") "_geom_hbond_distance_DH       "
          write(unit=iunit,fmt="(a)") "_geom_hbond_distance_HA       "
          write(unit=iunit,fmt="(a)") "_geom_hbond_distance_DA       "
          write(unit=iunit,fmt="(a)") "_geom_hbond_angle_DHA         "
          write(unit=iunit,fmt="(a)") "_geom_hbond_publ_flag         "
          write(unit=iunit,fmt="(a)") "?   ?   ?   ?   ?   ?   ?   ?   ?   ?   ?"

          write(unit=iunit,fmt="(a)") " "
          write(unit=iunit,fmt="(a)") "#============================================================================="
          write(unit=iunit,fmt="(a)") " "


          !---- Final Informations ----!
          write(unit=iunit,fmt="(a)") "#============================================================================="
          write(unit=iunit,fmt="(a)") "# Additional structures (last six sections and associated data_? identifiers) "
          write(unit=iunit,fmt="(a)") "# may be added at this point.                                                 "
          write(unit=iunit,fmt="(a)") "#============================================================================="

          write(unit=iunit,fmt="(a)") " "
          write(unit=iunit,fmt="(a)") "# The following lines are used to test the character set of files sent by     "
          write(unit=iunit,fmt="(a)") "# network email or other means. They are not part of the CIF data set.        "
          write(unit=iunit,fmt="(a)") "# abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789              "
          write(unit=iunit,fmt="(a)") "# !@#$%^&*()_+{}:"//""""//"~<>?|\-=[];'`,./ "
       end if

       close(unit=iunit)

       return
    End Subroutine Write_Cif_Template

    !!----
    !!---- Subroutine Write_Shx_Template(Filename,Code,Title,Lambda,Z,Celda,Space,Atomos)
    !!----    character(len=*),        intent(in) :: filename  !  In -> Filename
    !!----    integer,                 intent(in) :: code      !  In -> 0 Shelxs-Patterson
    !!----                                                              1 Shelxs-Direct Methods
    !!----                                                              2 Shelxl-Refinement
    !!----    character(len=*),        intent(in) :: title     !  In -> Title
    !!----    real(kind=cp),           intent(in) :: lambda    !  In -> Lambda
    !!----    integer,                 intent(in) :: z         !  In -> Z
    !!----    type(Crystal_cell_Type), intent(in) :: celda     !  In -> Cell variable
    !!----    type(Space_Group_Type),  intent(in) :: Space     !  In -> SpaceGroup variable
    !!----    type(atom_list_type),    intent(in) :: atomos    !  In -> Atom List
    !!----
    !!----    Write a Shelx File
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Write_Shx_Template(filename,code,title,lambda,z,celda,space,atomos)
       !---- Arguments ----!
       character(len=*),        intent(in) :: filename
       integer,                 intent(in) :: code
       character(len=*),        intent(in) :: title
       real(kind=cp),           intent(in) :: lambda
       integer,                 intent(in) :: z
       type(Crystal_cell_Type), intent(in) :: celda
       type(Space_Group_Type),  intent(in) :: Space
       type(atom_list_type),    intent(in) :: atomos

       !---- Local Variables ----!
       logical                :: info

       integer                :: i,j,k,nc,iunit !,nlong
       integer                :: nlat
       integer, dimension(15) :: z_cont

       !---- Inicializacion de variables ----!
       info=.false.
       iunit=0
       z_cont=0
       nc=0  !this depends on scattering factor?

       !---- Esta abierto este Fichero? ----!
       inquire(file=filename,opened=info)
       if (info) then
          inquire(file=filename,number=iunit)
          close(unit=iunit)
       end if

       !---- Escritura ----!
       if (iunit == 0) iunit=61
       open(unit=iunit,file=filename,status="unknown",action="write")
       rewind(unit=iunit)

       !---- Title ----!
       write(unit=iunit,fmt="(a)") "TITL "//title(1:len_trim(title))

       !---- Lambda, Cell ----!
       write(unit=iunit,fmt="(a,f8.5,3f9.4,3f7.3)") "CELL ",lambda,celda%cell,celda%ang

       !---- Z, Std ----!
       write(unit=iunit,fmt="(a,i3,a,3f8.4,3f7.3)") "ZERR ",z,"     ",celda%cell_std,celda%ang_std

       !---- Latt ----!
       nlat=1
       select case (space%centred)
          case (0) ! Centric

          case (1) ! Acentric
             nlat=-1

          case (2) ! Not used in Shelx
             write(unit=iunit,fmt="(a)") " ERROR: Origin not at -1 "
             close(unit=iunit)
             return

       end select
       select case (space%spg_lat)
          case ("P")

          case ("I")
             nlat=2*nlat

          case ("R")
             nlat=3*nlat

          case ("F")
             nlat=4*nlat

          case ("A")
             nlat=5*nlat

          case ("B")
             nlat=6*nlat

          case ("C")
             nlat=7*nlat

       end select
       write(unit=iunit,fmt="(a,i2)") "LATT ",nlat

       !---- Symm ----!
       do i=2,space%numops
          write(unit=iunit,fmt="(a)") "SYMM "//u_case(space%symopsymb(i))
       end do

       !---- Sfac ----!
       j=0
       do i=1,atomos%natoms
          if (j == 0) then
             j=1
             z_cont(j)=atomos%atom(i)%z
          else
             do k=1,j
                if (z_cont(k) == atomos%atom(i)%z) exit
             end do
             if (z_cont(k) /= atomos%atom(i)%z) then
                j=j+1
                z_cont(j)=atomos%atom(i)%z
             end if
          end if
       end do


       write(unit=iunit,fmt="(a)") "SFAC "

       !---- Unit ----!
       write(unit=iunit,fmt="(a)") "UNIT "

       select case (code)
          case (0) ! Shelxs - Patterson
             write(unit=iunit,fmt="(a)") "PATT "

          case (1) ! Shelxs - Direct Methods
             write(unit=iunit,fmt="(a)") "TREF "

          case (2) ! Shelxl - Refinement
             !---- L.S. ----!
             write(unit=iunit,fmt="(a)") "L.S. 10"

             !---- Fvar ----!
             write(unit=iunit,fmt="(a)") "FVAR 1.0"

             !---- Weight ----!
             write(unit=iunit,fmt="(a)") "WGHT 0.2"

             !---- Fmap ----!
             write(unit=iunit,fmt="(a)") "FMAP 2"

             !---- Atoms ----!
             do i=1,atomos%natoms
                write(unit=iunit,fmt="(a4,i3,4f11.5)") &
                     atomos%atom(i)%lab, nc, atomos%atom(i)%x, atomos%atom(i)%occ+10.0
             end do
       end select

       !---- Format ----!
       write(unit=iunit,fmt="(a)") "HKLF 4"

       !---- End ----!
       write(unit=iunit,fmt="(a)") "END "

       return
    End Subroutine Write_Shx_Template

    !!----
    !!---- Subroutine Get_Phases_File(filecode, Nphas, PhasesName,ILines)
    !!----    character(len=*),                intent(in)   :: filecode
    !!----    Integer,                         intent(out)  :: Nphas
    !!----    Character(len=80), dimension(:), intent(out)  :: PhasesName
    !!----    Integer,dimension(2,:),          intent(out)  :: ILines
    !!----
    !!---- Determine how many phases there are in a CIF or PCR file and
    !!---- give the lines to locate
    !!----
    !!---- Update: 01/05/2013
    !!
    Subroutine Get_Phases_File(filecode, NPhas, PhasesName,ILines)
       !---- Arguments ----!
       character(len=*),             intent(in)   :: filecode
       integer,                      intent(out)  :: Nphas
       character(len=*),dimension(:),intent(out)  :: PhasesName
       integer,dimension(:,:),       intent(out)  :: ILines

       !---- Local Variables ----!
       character(len=3) :: ext
       integer          :: npos

       !> Error
       call init_err_form()

       !> Init
       Nphas=0
       PhasesName=' '
       Ilines=0

       !> PCR or CIF file
       npos=index(filecode,'.',back=.true.)
       if (npos <=0) then
          err_form=.true.
          err_form_mess='No extension was found in the name of the file!'
          return
       end if

       ext=filecode(npos+1:)
       ext=u_case(ext)
       select case (ext)
          case ('CIF')
             call get_nphases_ciffile(filecode, NPhas, PhasesName,ILines)
          case ('PCR')
             call get_nphases_pcrfile(filecode, NPhas, PhasesName,ILines)
          case default
             err_form=.true.
             err_form_mess='Extension for this file not valid!'
       end select

       return
    End Subroutine Get_Phases_File

    !!--++
    !!--++ Subroutine Get_NPhases_CIFFile(Filecode,NPhas,PhasesName,ILines)
    !!--++    character(len=*),                 intent(in)  :: Filecode    ! Filename
    !!--++    integer,                          intent(out) :: NPhas       ! Number of Phases in the file
    !!--++    character(len=*), dimension(:),   intent(out) :: PhasesName     ! Name of Phases in the file
    !!--++    integer,          dimension(:,:), intent(out) :: ILines        ! Index for lines for each Phase
    !!--++
    !!--++ Determine the number of phases are included into the file
    !!--++
    !!--++ Date: 01/05/2013
    !!
    Subroutine Get_NPhases_CIFFile(Filecode,NPhas,PhasesName,ILines)
       !---- Arguments ----!
       character(len=*),                 intent(in)  :: Filecode    ! Filename
       integer,                          intent(out) :: NPhas       ! Number of Phases in the file
       character(len=*), dimension(:),   intent(out) :: PhasesName     ! Name of Phases in the file
       integer,          dimension(:,:), intent(out) :: ILines        ! Index for lines for each Phase

       !---- Local Variables ----!
       character(len=150), dimension(:), allocatable :: filen
       character(len=150)                            :: line
       integer                                       :: i,j,nl

       !> Error
       call init_err_form()

       !> Initialize
       NPhas=0
       PhasesName=' '
       ILines=0

       !> Reading file
       nl=0
       call number_lines(trim(filecode),nl)
       if (nl <=0) then
          err_form=.true.
          err_form_mess='No lines were readen for '//trim(filecode)//' !!'
          return
       end if
       allocate(filen(nl))
       call reading_lines(trim(filecode),nl,filen)

       !> Number of Phases
       do i=1,nl
          line=adjustl(filen(i))

          !> empty line
          if (len_trim(line) <= 0) cycle

          !> comment line
          if (line(1:1) =='#') cycle

          !> No data_global
          j=index(line,'data_global')
          if (j > 0) cycle

          !> Just only lines beginning with data...
          j=index(line,'data_')
          if (j /= 1) cycle

          nphas=nphas+1
          ILines(1,Nphas)=i
          PhasesName(nphas)=trim(line(j+5:))
          if (nphas > 1) ILines(2,nphas-1)=i-1
       end do
       if (nphas > 0 .and. ILines(2,nphas)==0) ILines(2,nphas)=nl

       if (allocated(filen)) deallocate(filen)

       return
    End Subroutine  Get_NPhases_CIFFile

    !!--++
    !!--++ Subroutine Get_NPhases_PCRFile(filecode, Nphas,PhasesName,ILines)
    !!--++    character(len=*),                intent(in)   :: filecode
    !!--++    Integer,                         intent(out)  :: Nphas
    !!--++    Character(len=80), dimension(:), intent(out)  :: PhasesName
    !!--++    Integer,dimension(2,:),          intent(out)  :: ILines
    !!--++
    !!--++ Determine how many phases and where there in a PCR file
    !!--++
    !!--++ Update: 01/05/2013
    !!
    Subroutine Get_NPhases_PCRFile(filecode, NPhas, PhasesName,ILines)
       !---- Arguments ----!
       character(len=*),             intent(in)   :: filecode
       integer,                      intent(out)  :: Nphas
       character(len=*),dimension(:),intent(out)  :: PhasesName
       integer,dimension(:,:),       intent(out)  :: ILines

       !---- Local Variables ----!
       logical                                      :: multi, ask_phase
       character(len=80), dimension(:), allocatable :: file_dat
       character(len=80)                            :: line
       integer                                      :: i,k,iv,nlines
       integer, dimension(30)                       :: ivet
       real(kind=cp), dimension(30)                 :: vet

       !> Err
       call init_err_form()

       !> Init
       NPhas=0
       PhasesName=' '
       ILines=0

       !> Reading file
       nlines=0
       call number_lines(trim(filecode),nlines)
       if (nlines <=0) then
          err_form=.true.
          err_form_mess='No lines were readen for '//trim(filecode)//' !!'
          return
       end if
       allocate(file_dat(nlines))
       call reading_lines(trim(filecode),nlines,file_dat)

       ILines(1,:)=1
       ILines(2,:)=nlines

       !> Simple / Multi format
       multi=.false.
       do i=1,nlines
          line=adjustl(file_dat(i))
          if (line(1:1) =='!' .or. line(1:1)==' ') cycle
          if (index(line,'NPATT ') <=0) cycle
          multi=.true.
       end do

       !> Number of Phases
       if (.not. multi) then
          do i=2,nlines
             line=adjustl(file_dat(i))
             if (line(1:1) =='!' .or. line(1:1)==' ') cycle
             call getnum(line,vet,ivet,iv)
             if (iv > 3) then
                NPhas=ivet(3)
                exit
             end if
          end do

       else
          do i=1,nlines
             line=adjustl(file_dat(i))
             if (line(1:4) /='!Nph') cycle

             line=adjustl(file_dat(i+1))
             call getnum(line,vet,ivet,iv)
             if (iv > 1) then
                NPhas=ivet(1)
                exit
             end if
          end do
       end if

       if (NPhas == 0) then
          err_form=.true.
          err_form_mess=" No Phase information was found in this PCR file. Please, check it! "
          return
       end if

       !> Locate where begin each Phase
       k=0
       ask_phase=.true.

       do i=1,nlines
          line=adjustl(file_dat(i))
          if (ask_phase) then
             if (index(line,'Data for PHASE') <= 0) cycle
          else
             if (line(1:1) /='!') then
                k=k+1
                ILines(1,k)=i
                PhasesName(k)=trim(adjustl(line))
                if (k == NPhas) exit

                ask_phase=.true.
             end if
             cycle
          end if
          ask_phase=.false.
       end do

       if (NPhas /= k) then
          err_form=.true.
          err_form_mess=" Locating Phases failed in this PCR. Please, check it!"
          return
       end if

       do i=1,Nphas
          if (nphas > 1) then
             ilines(2,i)=ilines(1,i+1)-1
          end if
       end do

       return
    End Subroutine Get_NPhases_PCRFile
    !!----
    !!---- Subroutine Write_CFL(lun,Cel,SpG,Atm,comment)
    !!----    integer,                  intent(in)    :: lun
    !!----    type (Space_Group_Type),  intent(in)    :: SpG
    !!----    type (Crystal_Cell_Type), intent(in)    :: Cel
    !!----    type (atom_list_type),    intent(in)    :: Atm
    !!----    character(len=*),optional,intent(in)    :: comment
    !!----
    !!----    (OVERLOADED)
    !!----
    !!----    Write a CFL-file with atom_list_type
    !!----
    !!---- Update: July - 2014
    !!
    Subroutine Write_CFL_Atom_List_Type(lun,Cel,SpG,Atm,comment)
       !---- Arguments ----!
       integer,                  intent(in)    :: lun
       type (Space_Group_Type),  intent(in)    :: SpG
       type (Crystal_Cell_Type), intent(in)    :: Cel
       type (atom_list_type),    intent(in)    :: Atm
       character(len=*),optional,intent(in)    :: comment

       !----- Local variables -----!
       integer                         :: j !,loc
       real(kind=cp), dimension(6)     :: a,sa
       character(len=30), dimension(6) :: text

       if(present(comment)) write(unit=lun,fmt="(a)") "TITLE "//trim(comment)
       write(unit=lun,fmt="(a)") "!  Automatically generated CFL file (Write_CFL)"

       a(1:3)=Cel%Cell
       a(4:6)=Cel%ang
       sa(1:3)=Cel%Cell_std
       sa(4:6)=Cel%ang_std
       do j=1,6
          call SetNum_Std(a(j), sa(j), text(j))
       end do
       write(unit=lun,fmt="(a)") "!         a               b               c            alpha           beta            gamma"
       write(unit=lun,fmt="(a,6a16)") "Cell ",text
       write(unit=lun,fmt="(a,i3)")"!     Space Group # ",SpG%NumSpg
       write(unit=lun,fmt="(a,a)") "Spgr  ",SpG%SPG_Symb
       call Write_Atoms_CFL(Atm,Lun,cel)

       return
    End Subroutine Write_CFL_Atom_List_Type
    !!----
    !!---- Subroutine Write_CFL(lun,Molx,comment)
    !!----    integer,                       intent(in) :: lun
    !!----    type (Molecular_Crystal_Type), intent(in) :: Molx
    !!----    character(len=*),optional,     intent(in) :: comment
    !!----
    !!----    (OVERLOADED)
    !!----
    !!----    Write a CFL-file with molecular_crystal_type
    !!----
    !!---- Update: July - 2014
    !!
    Subroutine Write_CFL_Molcrys(lun,Molx,comment)
       !---- Arguments ----!
       integer,                       intent(in) :: lun
       type (Molecular_Crystal_Type), intent(in) :: Molx
       character(len=*),optional,     intent(in) :: comment

       !----- Local variables -----!
       integer                         :: j !,loc
       real(kind=cp), dimension(6)     :: a,sa
       character(len=30), dimension(6) :: text

       if(present(comment)) write(unit=lun,fmt="(a)") "TITLE "//trim(comment)
       write(unit=lun,fmt="(a)") "!  Automatically generated CFL file (Write_CFL)"

       a(1:3)=molx%cell%Cell
       a(4:6)=molx%cell%ang
       sa(1:3)=molx%cell%Cell_std
       sa(4:6)=molx%cell%ang_std
       do j=1,6
          call SetNum_Std(a(j), sa(j), text(j))
       end do
       write(unit=lun,fmt="(a)") "!         a               b               c            alpha           beta            gamma"
       write(unit=lun,fmt="(a,6a16)") "Cell ",text
       write(unit=lun,fmt="(a,i3)")"!     Space Group # ",molx%spg%NumSpg
       write(unit=lun,fmt="(a,a)") "Spgr  ",molx%spg%SPG_Symb
       call Write_Atoms_CFL(Molx,Lun)

       return
    End Subroutine Write_CFL_Molcrys
    !!----
    !!---- Subroutine Write_Atoms_CFL(Ats,Lun,Cell)
    !!----    Type (atom_list_type),dimension(:),  intent(in) :: Ats     !  In -> Atom List
    !!----    integer, optional,                   intent(in) :: lun     !  In -> Unit to write
    !!----    Type(Crystal_Cell_Type), optional,   intent(in) :: Cell    !  In -> Transform to thermal parameters
    !!----
    !!----    Write the atoms in the asymmetric unit for a CFL file
    !!----
    !!---- Update: February - 2003
    !!
    Subroutine Write_Atoms_CFL_ATM(Ats,Lun,cell)
       !---- Arguments ----!
       type (atom_list_type),            intent(in) :: Ats
       integer, optional,                intent(in) :: Lun
       Type(Crystal_Cell_Type), optional,intent(in) :: Cell

       !---- Local Variables ----!
       character(len=30),dimension(6) :: text
       character(len=36)              :: forma,fom
       integer                        :: i, j, iunit, leng, maxl,ish
       real(kind=cp), dimension(6)    :: u,bet,sb

       iunit=6
       if (present(lun)) iunit=lun

       if(ats%natoms == 0) then
         write (unit=iunit,fmt="(a)") "!  No atoms ..."
         return
       end if
       !Determine the maximum length of the atom labels
       maxl=0
       do i=1,ats%natoms
         leng=len_trim(ats%atom(i)%lab)
         if(leng > maxl) maxl=leng
       end do
       maxl=max(maxl,4)+1
       ish=maxl-4
       fom   ="(a,tr  ,a)"
       Select Case(ish)
          Case(:9)
            write(unit=fom(6:6),fmt="(i1)") ish
          Case(10:)
            write(unit=fom(6:7),fmt="(i2)") ish
       End Select
       forma="(a,a  ,tr2,a,tr3,5a14,2f8.2,tr3,a)"
       Select Case(maxl)
         Case(:9)
             write(unit=forma(5:5),fmt="(i1)") maxl
         Case(10:)
             write(unit=forma(5:6),fmt="(i2)") maxl
       End Select
       write (unit=iunit,fmt=fom) "!     ", &
             "Atom  Type     x/a           y/b           z/c           Biso          Occ           Spin    Charge    Info"
       do i=1,ats%natoms

          do j=1,3
             call SetNum_Std(ats%atom(i)%x(j), ats%atom(i)%x_std(j), text(j))
          end do
          call SetNum_Std(ats%atom(i)%Biso, ats%atom(i)%Biso_std, text(4))
          call SetNum_Std(ats%atom(i)%Occ, ats%atom(i)%Occ_std, text(5))

          write (unit=iunit,fmt=forma) &
                "Atom   ",trim(ats%atom(i)%lab),ats%atom(i)%chemsymb, (text(j),j=1,5), &
                 ats%atom(i)%moment,ats%atom(i)%charge,"# "//ats%atom(i)%AtmInfo

          if (ats%atom(i)%thtype == "aniso") then

             if (ats%atom(i)%utype == "beta") then
                bet=ats%atom(i)%u(1:6)
                sb=ats%atom(i)%u_std(1:6)
                do j=1,6
                   call SetNum_Std(bet(j), sb(j), text(j))
                end do
                write (unit=iunit,fmt="(a,tr1,6a14)") "Beta  ", text
                if (present(Cell)) then
                   u=convert_betas_u(bet,cell)
                   sb=convert_betas_u(ats%atom(i)%u_std,cell)
                   do j=1,6
                      call SetNum_Std(u(j), sb(j), text(j))
                   end do
                   write(unit=iunit,fmt="(a,6a14)") "!U_ij  ", text
                end if

             else if(ats%atom(i)%thtype == "u_ij") then
                u=ats%atom(i)%u(1:6)
                sb=ats%atom(i)%u_std(1:6)
                do j=1,6
                   call SetNum_Std(u(j), sb(j), text(j))
                end do
                write(unit=iunit,fmt="(a,6a14)") "U_ij  ", text
                if (present(Cell)) then
                   bet=convert_u_betas(u,cell)
                   sb=convert_u_betas(ats%atom(i)%u_std,cell)
                   do j=1,6
                      call SetNum_Std(bet(j), sb(j), text(j))
                   end do
                   write(unit=iunit,fmt="(a,6a14)") "!Beta  ", text
                end if
             end if

          end if
       end do

       return
    End Subroutine Write_Atoms_CFL_ATM

    !!----
    !!---- Subroutine Write_Atoms_CFL(Ats,Lun,Cell)
    !!----    Type (atom_list_type),dimension(:),  intent(in) :: Ats     !  In -> Atom List
    !!----    integer, optional,                   intent(in) :: lun     !  In -> Unit to write
    !!----    Type(Crystal_Cell_Type), optional,   intent(in) :: Cell    !  In -> Transform to thermal parameters
    !!----
    !!----    Write the atoms in the asymmetric unit for a CFL file
    !!----
    !!---- Update: February - 2003
    !!
    Subroutine Write_Atoms_CFL_MOLX(Molx,Lun)
        !---- Arguments ----!
        type (Molecular_Crystal_Type), intent(in) :: Molx
        integer, optional,             intent(in) :: Lun

        !---- Local Variables ----!
        character(len=30),dimension(6) :: text
        character(len=36)              :: forma,fom
        integer                        :: i, j, iunit, leng, maxl,ish
        real(kind=cp), dimension(6)    :: u,bet,sb

        iunit=6
        if (present(lun)) iunit=lun

        if(molx%n_free > 0) then
            !Determine the maximum length of the atom labels
            maxl=0
            do i=1,molx%n_free
                leng=len_trim(molx%atm(i)%lab)
                if(leng > maxl) maxl=leng
            end do
            maxl=max(maxl,4)+1
            ish=maxl-4
            fom   ="(a,tr  ,a)"
            Select Case(ish)
                Case(:9)
                    write(unit=fom(6:6),fmt="(i1)") ish
                Case(10:)
                    write(unit=fom(6:7),fmt="(i2)") ish
            End Select
            forma="(a,a  ,tr2,a,tr3,5a14,2f8.2,tr3,a)"
            Select Case(maxl)
                Case(:9)
                    write(unit=forma(5:5),fmt="(i1)") maxl
                Case(10:)
                    write(unit=forma(5:6),fmt="(i2)") maxl
            End Select
            write (unit=iunit,fmt=fom) "!     ", &
                  "Atom  Type     x/a           y/b           z/c           Biso          Occ           Spin    Charge    Info"
            do i=1,molx%n_free

                do j=1,3
                   call SetNum_Std(molx%atm(i)%x(j), molx%atm(i)%x_std(j), text(j))
                end do
                call SetNum_Std(molx%atm(i)%Biso, molx%atm(i)%Biso_std, text(4))
                call SetNum_Std(molx%atm(i)%Occ, molx%atm(i)%Occ_std, text(5))

                write (unit=iunit,fmt=forma) &
                      "Atom   ",trim(molx%atm(i)%lab),molx%atm(i)%chemsymb, (text(j),j=1,5), &
                       molx%atm(i)%moment,molx%atm(i)%charge,"# "//molx%atm(i)%AtmInfo

                if (molx%atm(i)%thtype == "aniso") then

                    if (molx%atm(i)%utype == "beta") then
                        bet=molx%atm(i)%u(1:6)
                        sb=molx%atm(i)%u_std(1:6)
                        do j=1,6
                            call SetNum_Std(bet(j), sb(j), text(j))
                        end do
                        write (unit=iunit,fmt="(a,tr1,6a14)") "Beta  ", text
                        u=convert_betas_u(bet,molx%cell)
                        sb=convert_betas_u(molx%atm(i)%u_std,molx%cell)
                        do j=1,6
                            call SetNum_Std(u(j), sb(j), text(j))
                        end do
                        write(unit=iunit,fmt="(a,6a14)") "!U_ij  ", text
                    else if(molx%atm(i)%thtype == "u_ij") then
                        u=molx%atm(i)%u(1:6)
                        sb=molx%atm(i)%u_std(1:6)
                        do j=1,6
                            call SetNum_Std(u(j), sb(j), text(j))
                        end do
                        write(unit=iunit,fmt="(a,6a14)") "U_ij  ", text
                        bet=convert_u_betas(u,molx%cell)
                        sb=convert_u_betas(molx%atm(i)%u_std,molx%cell)
                        do j=1,6
                            call SetNum_Std(bet(j), sb(j), text(j))
                        end do
                        write(unit=iunit,fmt="(a,6a14)") "!Beta  ", text
                    end if
                end if
            end do ! i=1,molx%n_free
        end if ! molx%n_free > 0

        if (molx%n_mol > 0) then
            do i=1,molx%n_mol
                write(unit=iunit,fmt="(/,a,tr2,i3,tr2,a,tr2,a)") &
                     "MOLEX",molx%mol(i)%natoms,trim(molx%mol(i)%Name_mol),molx%mol(i)%coor_type
                write(unit=iunit,fmt="(a)") &
                     "!    Xc         Yc          Zc        Phi        Theta      Chi     TypeAngles TypeThermal"
                write(unit=iunit,fmt="(6f11.5,tr6,a,tr10,a)") &
                     molx%mol(i)%xcentre,molx%mol(i)%orient,molx%mol(i)%rot_type,molx%mol(i)%therm_type
                write(unit=iunit,fmt="(t1,6i10,tr2,a)") &
                     molx%mol(i)%lxcentre,molx%mol(i)%lorient," ! Refinemencodes"

                select case (molx%mol(i)%coor_type)
                    case ("C","c")
                        write(unit=iunit,fmt="(a)") &
                        "!Atom   Type        XC          YC          ZC    N1  N2  N3      Biso        Occ "
                    case ("F","f")
                        write(unit=iunit,fmt="(a)") &
                        "!Atom   Type        X           Y           Z     N1  N2  N3      Biso        Occ "
                    case ("S","s")
                        write(unit=iunit,fmt="(a)") &
                        "!Atom   Type    distance      Theta       Phi     N1  N2  N3      Biso        Occ "
                    case ("Z","z")
                        write(unit=iunit,fmt="(a)") &
                        "!Atom   Type    distance  Bond-Angle Torsion-Ang  N1  N2  N3      Biso        Occ "
                    case default
                        write(unit=iunit,fmt="(a)") &
                        "!Atom   Type      Coor1       Coor2       Coor3   N1  N2  N3      Biso        Occ "
                end select ! molx%mol(i)%coor_type

                do j=1,molx%mol(i)%natoms
                    write(unit=iunit,fmt="(a,tr2,a,3f12.5,3i4,2f12.5)")  &
                          molx%mol(i)%AtName(j), molx%mol(i)%AtSymb(j),molx%mol(i)%I_Coor(:,j),  &
                          molx%mol(i)%Conn(:,j), molx%mol(i)%Biso(j),  molx%mol(i)%Occ(j)
                end do ! j = molx%mol(i)%natoms
            end do ! i = 1,molx%n_mol
        end if ! molx%n_mol > 0
        return
    End Subroutine Write_Atoms_CFL_MOLX
    !!----
    !!---- Subroutine Write_Atoms_CFL(Ats,Lun,Cell)
    !!----    Type (atom_list_type),dimension(:),  intent(in) :: Ats     !  In -> Atom List
    !!----    integer, optional,                   intent(in) :: lun     !  In -> Unit to write
    !!----    Type(Crystal_Cell_Type), optional,   intent(in) :: Cell    !  In -> Transform to thermal parameters
    !!----
    !!----    Write the atoms in the asymmetric unit for a CFL file
    !!----
    !!---- Update: February - 2003
    !!
    Subroutine Write_Atoms_CFL_MOLX_orig(Molx,Lun)
       !---- Arguments ----!
       type (Molecular_Crystal_Type), intent(in) :: Molx
       integer, optional,             intent(in) :: Lun

       !---- Local Variables ----!
       character(len=30),dimension(6) :: text
       character(len=36)              :: forma,fom
       integer                        :: i, j, iunit, leng, maxl,ish
       real(kind=cp), dimension(6)    :: u,bet,sb

       iunit=6
       if (present(lun)) iunit=lun

       if(molx%n_free == 0) then
         write (unit=iunit,fmt="(a)") "!  No atoms ..."
         return
       end if
       !Determine the maximum length of the atom labels
       maxl=0
       do i=1,molx%n_free
         leng=len_trim(molx%atm(i)%lab)
         if(leng > maxl) maxl=leng
       end do
       maxl=max(maxl,4)+1
       ish=maxl-4
       fom   ="(a,tr  ,a)"
       Select Case(ish)
          Case(:9)
            write(unit=fom(6:6),fmt="(i1)") ish
          Case(10:)
            write(unit=fom(6:7),fmt="(i2)") ish
       End Select
       forma="(a,a  ,tr2,a,tr3,5a14,2f8.2,tr3,a)"
       Select Case(maxl)
         Case(:9)
             write(unit=forma(5:5),fmt="(i1)") maxl
         Case(10:)
             write(unit=forma(5:6),fmt="(i2)") maxl
       End Select
       write (unit=iunit,fmt=fom) "!     ", &
             "Atom  Type     x/a           y/b           z/c           Biso          Occ           Spin    Charge    Info"
       do i=1,molx%n_free

          do j=1,3
             call SetNum_Std(molx%atm(i)%x(j), molx%atm(i)%x_std(j), text(j))
          end do
          call SetNum_Std(molx%atm(i)%Biso, molx%atm(i)%Biso_std, text(4))
          call SetNum_Std(molx%atm(i)%Occ, molx%atm(i)%Occ_std, text(5))

          write (unit=iunit,fmt=forma) &
                "Atom   ",trim(molx%atm(i)%lab),molx%atm(i)%chemsymb, (text(j),j=1,5), &
                 molx%atm(i)%moment,molx%atm(i)%charge,"# "//molx%atm(i)%AtmInfo

          if (molx%atm(i)%thtype == "aniso") then

             if (molx%atm(i)%utype == "beta") then
                bet=molx%atm(i)%u(1:6)
                sb=molx%atm(i)%u_std(1:6)
                do j=1,6
                   call SetNum_Std(bet(j), sb(j), text(j))
                end do
                write (unit=iunit,fmt="(a,tr1,6a14)") "Beta  ", text
                u=convert_betas_u(bet,molx%cell)
                sb=convert_betas_u(molx%atm(i)%u_std,molx%cell)
                do j=1,6
                    call SetNum_Std(u(j), sb(j), text(j))
                end do
                write(unit=iunit,fmt="(a,6a14)") "!U_ij  ", text
             else if(molx%atm(i)%thtype == "u_ij") then
                u=molx%atm(i)%u(1:6)
                sb=molx%atm(i)%u_std(1:6)
                do j=1,6
                   call SetNum_Std(u(j), sb(j), text(j))
                end do
                write(unit=iunit,fmt="(a,6a14)") "U_ij  ", text
                bet=convert_u_betas(u,molx%cell)
                sb=convert_u_betas(molx%atm(i)%u_std,molx%cell)
                do j=1,6
                    call SetNum_Std(bet(j), sb(j), text(j))
                end do
                write(unit=iunit,fmt="(a,6a14)") "!Beta  ", text
             end if
          end if
       end do

       return
    End Subroutine Write_Atoms_CFL_MOLX_orig

 End Module CFML_IO_Formats

!!-------------------------------------------------------
!!---- Crystallographic Fortran Modules Library (CrysFML)
!!-------------------------------------------------------
!!---- The CrysFML project is distributed under LGPL. In agreement with the
!!---- Intergovernmental Convention of the ILL, this software cannot be used
!!---- in military applications.
!!----
!!---- Copyright (C) 1999-2012  Institut Laue-Langevin (ILL), Grenoble, FRANCE
!!----                          Universidad de La Laguna (ULL), Tenerife, SPAIN
!!----                          Laboratoire Leon Brillouin(LLB), Saclay, FRANCE
!!----
!!---- Authors: Juan Rodriguez-Carvajal (ILL)
!!----          Javier Gonzalez-Platas  (ULL)
!!----
!!---- Contributors: Laurent Chapon     (ILL)
!!----               Marc Janoschek     (Los Alamos National Laboratory, USA)
!!----               Oksana Zaharko     (Paul Scherrer Institute, Switzerland)
!!----               Tierry Roisnel     (CDIFX,Rennes France)
!!----               Eric Pellegrini    (ILL)
!!----
!!---- This library is free software; you can redistribute it and/or
!!---- modify it under the terms of the GNU Lesser General Public
!!---- License as published by the Free Software Foundation; either
!!---- version 3.0 of the License, or (at your option) any later version.
!!----
!!---- This library is distributed in the hope that it will be useful,
!!---- but WITHOUT ANY WARRANTY; without even the implied warranty of
!!---- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
!!---- Lesser General Public License for more details.
!!----
!!---- You should have received a copy of the GNU Lesser General Public
!!---- License along with this library; if not, see <http://www.gnu.org/licenses/>.
!!----
!!----
!!---- MODULE: CFML_Structure_Factors
!!----   INFO: Main module for Structure Factors Calculations
!!----
!!---- HISTORY
!!----    Update: 06/03/2011
!!----
!!----
!!---- DEPENDENCIES
!!----
!!--++     Use CFML_Scattering_Chemical_Tables
!!--++     Use CFML_Crystallographic_Symmetry,   only: Space_Group_Type
!!--++     Use CFML_Reflections_Utilities,       only: Reflection_List_Type, HKL_R
!!--++     Use CFML_Atom_TypeDef,                only: atom_list_type
!!--++     Use CFML_GlobalDeps,                  only: sp, tpi
!!--++     Use CFML_Math_General,                only: atan2d
!!--++     Use CFML_String_Utilities,            only: L_Case,U_Case
!!----
!!---- VARIABLES
!!--++    AF0                             [Private]
!!--++    AFP                             [Private]
!!--++    AFPP                            [Private]
!!--++    AJH                             [Private]
!!--++    BJH                             [Private]
!!----    ERR_SFAC
!!----    ERR_SFAC_MESS
!!--++    HR_TYPE                         [Private]
!!--++    HR                              [Private]
!!--++    HT                              [Private]
!!--++    SF_INITIALIZED                  [Private]
!!--++    TH                              [Private]
!!----
!!---- PUBLIC PROCEDURES
!!----    Functions:
!!--++       FJ                           [Private]
!!----
!!----    Subroutines:
!!--++       CALC_TABLE_AB                [Private]
!!--++       CALC_TABLE_TH                [Private]
!!----       CALC_HKL_STRFACTOR
!!----       CALC_STRFACTOR
!!--++       CREATE_TABLE_AF0_ELECTRONS   [Private]
!!--++       CREATE_TABLE_AF0_XRAY        [Private]
!!--++       CREATE_TABLE_AFP_NEUTNUC     [Private]
!!--++       CREATE_TABLE_FABC_XRAY       [Private]
!!--++       CREATE_TABLE_HR_HT           [Private]
!!----       INIT_HKL_STRUCTURE_FACTORS
!!----       INIT_STRUCTURE_FACTORS
!!----       MODIFY_SF
!!--++       SET_FIXED_TABLES             [Private]
!!----       STRUCTURE_FACTORS
!!--++       SUM_AB                       [Private]
!!--++       SUM_AB_NEUTNUC               [Private]
!!----       WRITE_STRUCTURE_FACTORS
!!----
!!
 Module CFML_Structure_Factors

    !---- Use Modules ----!
    Use CFML_GlobalDeps,                  only: cp, tpi
    Use CFML_Math_General,                only: atan2d
    Use CFML_String_Utilities,            only: L_Case,U_Case
    Use CFML_Scattering_Chemical_Tables
    Use CFML_Crystallographic_Symmetry,   only: Space_Group_Type
    Use CFML_Reflections_Utilities,       only: Reflection_List_Type, HKL_R
    Use CFML_Atom_TypeDef,                only: atom_list_type

    !---- Variables ----!
    implicit none

    private

    !---- List of public functions ----!

    !---- List of public subroutines ----!
    public :: Init_Structure_Factors,Init_Calc_hkl_StrFactors, Structure_Factors,  &
              Modify_SF, Write_Structure_Factors,Calc_StrFactor, Calc_hkl_StrFactor, &
              Init_Calc_StrFactors

    !---- List of private functions ----!
    private :: Fj

    !---- List of private subroutines ----!
    private :: Calc_Table_AB, Create_Table_AF0_Xray, Create_Table_AFP_NeutNuc, &
               Create_Table_HR_HT, Set_Fixed_Tables, Calc_Table_TH, Sum_AB,    &
               Sum_AB_NeutNuc, Create_Table_Fabc_Xray, Create_Table_AF0_Electrons

    !---- Definitions ----!

    !!--++
    !!--++ AF0
    !!--++     real(kind=cp), dimension(:,:), allocatable, private :: AF0
    !!--++
    !!--++     Array for Atomic Factor. The dimensions are
    !!--++           AF0(Natoms,NRef)
    !!--++
    !!--++ Update: December - 2003
    !!
    real(kind=cp), dimension(:,:), allocatable, private :: AF0

    !!--++
    !!--++ AFP
    !!--++     real(kind=cp), dimension(:), allocatable, private :: AFP
    !!--++
    !!--++     Array for real part of anomalous scattering form factor.
    !!--++     The dimension is: AFP(Natoms)
    !!--++
    !!--++ Update: December - 2003
    !!
    real(kind=cp), dimension(:), allocatable, private :: AFP

    !!--++
    !!--++ AFPP
    !!--++     real(kind=cp), dimension(:), allocatable, private :: AFPP
    !!--++
    !!--++     Array for imaginary part of anomalous scattering form factor.
    !!--++     The dimension is: AFPP(Natoms)
    !!--++
    !!--++ Update: December - 2003
    !!
    real(kind=cp), dimension(:), allocatable, private :: AFPP

    !!--++
    !!--++ AJH
    !!--++     real(kind=cp), dimension(:,:), allocatable, private :: Ajh
    !!--++
    !!--++     Array for Aj(h). The dimensions are
    !!--++           Ajh(Natoms,Nref)
    !!--++     where
    !!--++           F(h)=Sum_j[Fj(h){Aj(h)+i Bj(h)}]
    !!--++
    !!--++ Update: December - 2003
    !!
    real(kind=cp), dimension(:,:), allocatable, private :: AJH

    !!--++
    !!--++ BJH
    !!--++     real(kind=cp), dimension(:,:), allocatable, private :: Bjh
    !!--++
    !!--++     Array for Bj(h). The dimensions are
    !!--++           Bjh(Natoms,Nref)
    !!--++     where
    !!--++           F(h)=Sum_j[Fj(h){Aj(h)+i Bj(h)}]
    !!--++
    !!--++ Update: December - 2003
    !!
    real(kind=cp), dimension(:,:), allocatable, private :: BJH

    !!----
    !!---- ERR_SFAC
    !!----    logical, public ::
    !!----
    !!----    Logical Variable in
    !!----
    !!---- Update: February - 200
    !!
    logical, public :: ERR_SFac

    !!----
    !!---- ERR_SFac_Mess
    !!----    character(len=150), public :: ERR_SFac_Mess
    !!----
    !!----    String containing information about the last error
    !!----
    !!---- Update: February - 2005
    !!
    character(len=150), public :: ERR_SFac_Mess


    !!--++
    !!--++ FF_A, FF_B, FF_C, FF_Z
    !!--++     real(kind=cp), dimension(:,:), allocatable, private :: FF_a,FF_b
    !!--++     real(kind=cp), dimension(  :), allocatable, private :: FF_c
    !!--++
    !!--++     Arrays for coefficients of X-rays scattering form factors.
    !!--++     The dimensions are: AFP(Nspecies)
    !!--++      FF_A(4,Nspecies), FF_B(4,Nspecies), FF_C(Nspecies), FF_Z(Nspecies)
    !!--++     Constructed in Create_Table_fabc_Xray(Atm,lambda,lun)
    !!--++     FF_Z contains atomic number Z (useful for electron diffraction)
    !!--++
    !!--++ Update: April - 2009
    !!
    real(kind=cp), dimension(:,:), allocatable, private :: FF_a, FF_b
    real(kind=cp), dimension(  :), allocatable, private :: FF_c
    real(kind=cp), dimension(  :), allocatable, private :: FF_Z

    !!--++
    !!--++    Type :: HR_Type
    !!--++       integer,dimension(3) :: H
    !!--++    End Type HR_Type
    !!--++
    !!--++    (Private)
    !!--++    Define a H vector
    !!--++
    !!--++ Update: February - 2005
    !!
    Type, Private :: HR_Type
       integer, dimension(3) :: H
    End Type HR_Type

    !!--++
    !!--++ HR
    !!--++     type(HR_Type), dimension(:,:), allocatable, private :: Hr
    !!--++
    !!--++     Array for HR Calculations. The dimension are
    !!--++           HR(Natoms,NRef)
    !!--++
    !!--++ Update: February - 2005
    !!
    type(HR_Type), dimension(:,:), allocatable, private :: HR

    !!--++
    !!--++ HT
    !!--++    real(kind=cp), dimension(:,:), allocatable, private :: Ht
    !!--++
    !!--++    Array for HT Calculations. The dimension are
    !!--++          HT(Natoms,Nref)
    !!--++
    !!--++ Update: February - 2005
    !!
    real(kind=cp), dimension(:,:), allocatable, private :: HT

    !!--++
    !!--++ Nspecies
    !!--++     integer, private :: Nspecies
    !!--++
    !!--++     Number of chemical species for X-rays scattering form factors.
    !!--++  Constructed in Create_Table_fabc_Xray(Atm,lambda,lun)
    !!--++
    !!--++ Update: April - 2009
    !!
    integer, private :: Nspecies

    !!--++
    !!--++ P_A
    !!--++     integer, dimension(:), allocatable, private :: P_A
    !!--++
    !!--++     Integer pointer from atoms to species: P_A(Natoms), contains the species
    !!--++     of atom Natoms. Constructed in Create_Table_fabc_Xray(Atm,lambda,lun)
    !!--++
    !!--++ Update: April - 2009
    !!
    integer, dimension(:), allocatable, private :: P_A

    !!----
    !!---- SF_Initialized
    !!----    logical, private :: SF_Initialized
    !!----
    !!----  Logical Variable indicating if the module has been initialized.
    !!----
    !!---- Update: February - 2005
    !!
    logical, private :: SF_Initialized=.false.

    !!--++
    !!--++ TH
    !!--++    real(kind=cp), dimension(:,:), allocatable, private :: Th
    !!--++
    !!--++    Array for TH Calculations. The dimension are
    !!--++          TH(Natoms,Nref)
    !!--++
    !!--++ Update: February - 2005
    !!
    real(kind=cp), dimension(:,:), allocatable, private :: TH

 Contains

    !---- Functions ----!

    !!--++
    !!--++ Pure Function Fj(s,a,b,c)
    !!--++    real(kind=cp),             intent(in) :: s
    !!--++    real(kind=cp),dimension(4),intent(in) :: a
    !!--++    real(kind=cp),dimension(4),intent(in) :: b
    !!--++    real(kind=cp),             intent(in) :: c
    !!--++
    !!--++    (Private)
    !!--++    Atomic scattering factor calculation according to:
    !!--++       Fj(s)=Sum_i[Ai*exp(-Bi*s*s)] + C (i=1..4)
    !!--++
    !!--++ Update: February - 2005
    !!
    Pure Function Fj(s,a,b,c) Result(res)
       !---- Arguments ----!
       real(kind=cp),             intent(in) :: s
       real(kind=cp),dimension(4),intent(in) :: a
       real(kind=cp),dimension(4),intent(in) :: b
       real(kind=cp),             intent(in) :: c
       real(kind=cp)                         :: res

       !---- Local variables ----!
       integer :: i

       res=0.0
       do i=1,4
          res=res + a(i)*exp(-b(i)*s*s)
       end do
       res=res+c

       return
    End Function Fj

    !---- Subroutines ----!

    !!--++
    !!--++ Subroutine Calc_Table_AB(Nref,Atm,Grp)
    !!--++    integer,                            intent(in) :: Nref
    !!--++    type(atom_list_type),              intent(in) :: Atm
    !!--++    type(space_group_type),             intent(in) :: Grp
    !!--++
    !!--++    (Private)
    !!--++    Calculate Table with Aj(h) and Bj(h) values
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Calc_Table_AB(Nref,Atm,Grp)
       !---- Arguments ----!
       integer,                            intent(in) :: Nref
       type(atom_list_type),               intent(in) :: Atm
       type(space_group_type),             intent(in) :: Grp

       !---- Local Variables ----!
       integer                       :: i,j,k
       real(kind=cp)                 :: arg,anis
       real(kind=cp),dimension(3)    :: h
       real(kind=cp),dimension(6)    :: beta

       Ajh=0.0
       Bjh=0.0
       if(Grp%Centred == 2) then
         do j=1,Nref
            do i=1,Atm%natoms
               arg=0.0
               do k=1,grp%NumOps
                  h=hr(k,j)%h
                  arg=tpi*(dot_product(h,Atm%atom(i)%x)+ht(k,j))
                  anis=1.0
                  if(Atm%atom(i)%thtype == "aniso") then
                    beta=Atm%atom(i)%u(1:6)
                    anis=     h(1)*h(1)*beta(1)+     h(2)*h(2)*beta(2)+    h(3)*h(3)*beta(3) &
                         +2.0*h(1)*h(2)*beta(4)+ 2.0*h(1)*h(3)*beta(5)+2.0*h(2)*h(3)*beta(6)
                    anis=exp(-anis)
                  end if
                  Ajh(i,j)=Ajh(i,j)+cos(arg)*anis
               end do ! symmetry
            end do ! Atoms
         end do ! Reflections
       else
         do j=1,Nref
            do i=1,Atm%natoms
               arg=0.0
               do k=1,grp%NumOps
                  h=hr(k,j)%h
                  arg=tpi*(dot_product(h,Atm%atom(i)%x)+ht(k,j))
                  anis=1.0
                  if(Atm%atom(i)%thtype == "aniso") then
                    beta=Atm%atom(i)%u(1:6)
                    anis=     h(1)*h(1)*beta(1)+     h(2)*h(2)*beta(2)+    h(3)*h(3)*beta(3) &
                         +2.0*h(1)*h(2)*beta(4)+ 2.0*h(1)*h(3)*beta(5)+2.0*h(2)*h(3)*beta(6)
                    anis=exp(-anis)
                  end if
                  Ajh(i,j)=Ajh(i,j)+cos(arg)*anis
                  Bjh(i,j)=Bjh(i,j)+sin(arg)*anis
               end do ! symmetry
            end do ! Atoms
         end do ! Reflections
       end if

       return
    End Subroutine Calc_Table_AB

    !!----
    !!---- Subroutine Calc_StrFactor(mode,rad,nn,sn,Atm,Grp,sf2,deriv,fc)
    !!----    character(len=*),                   intent(in) :: mode !S-XTAL (S) or Powder (P)
    !!----    character(len=*),                   intent(in) :: rad  !Radiation: X-rays, Neutrons
    !!----    integer,                            intent(in) :: nn
    !!----    real(kind=cp)                       intent(in) :: sn !(sinTheta/Lambda)**2
    !!----    type(atom_list_type),               intent(in) :: Atm
    !!----    type(space_group_type),             intent(in) :: Grp
    !!----    real(kind=cp)                       intent(out):: sf2
    !!----    real(kind=cp),dimension(:),optional,intent(out):: deriv
    !!----    complex, optional,                  intent(out):: fc
    !!----
    !!----    Calculate Structure Factor for reflection "nn" in the list
    !!----    and derivatives with respect to refined parameters
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Calc_StrFactor(mode,rad,nn,sn,Atm,Grp,sf2,deriv,fc)
       !---- Arguments ----!
       character(len=*),                   intent(in) :: mode
       character(len=*),                   intent(in) :: rad
       integer,                            intent(in) :: nn
       real(kind=cp),                      intent(in) :: sn !(sinTheta/Lambda)**2
       type(atom_list_type),               intent(in) :: Atm
       type(space_group_type),             intent(in) :: Grp
       real(kind=cp),                      intent(out):: sf2
       real(kind=cp),dimension(:),optional,intent(out):: deriv
       complex, optional,                  intent(out):: fc

       !---- Local Variables ----!
       character(len=1)                      :: modi
       integer                               :: i,j,k,m
       real(kind=cp)                         :: arg,anis,cosr,sinr,scosr,ssinr,fr,der !,fi
       real(kind=cp)                         :: a1,a2,a3,a4,b1,b2,b3,b4,av,bv,f
       real(kind=cp),dimension(3)            :: h
       real(kind=cp),dimension(6)            :: beta
       real(kind=cp),dimension(Atm%natoms)   :: frc,frs,otr,oti,afpxn
       real(kind=cp),dimension(9,Atm%natoms) :: drs,drc

       !--- Initialising local variables
       a1=0.0
       a2=0.0
       a3=0.0
       a4=0.0
       b1=0.0
       b2=0.0
       b3=0.0
       b4=0.0
       av=0.0
       bv=0.0
       fr=1.0
       !fi=0.0
       frc=0.0
       frs=0.0
       otr=0.0
       oti=0.0
       modi=u_case(mode(1:1))
       if(rad(1:1) == "N") then
         afpxn(:)=afp(:)
       else
         afpxn(:)=af0(:,nn)
       end if

       if(Grp%Centred == 2) then
            do i=1,Atm%natoms
               arg=0.0
               scosr=0.0
               ssinr=0.0
               drs(:,i)=0.0
               drc(:,i)=0.0
               do k=1,grp%NumOps
                  h=hr(k,nn)%h
                  arg=tpi*(dot_product(h,Atm%atom(i)%x)+ht(k,nn))
                  anis=1.0
                  if(Atm%atom(i)%thtype == "aniso") then
                    beta=Atm%atom(i)%u(1:6)
                    anis=     h(1)*h(1)*beta(1)+     h(2)*h(2)*beta(2)+    h(3)*h(3)*beta(3) &
                         +2.0*h(1)*h(2)*beta(4)+ 2.0*h(1)*h(3)*beta(5)+2.0*h(2)*h(3)*beta(6)
                    anis=exp(-anis)
                  end if
                  cosr=COS(arg)*anis*fr     !fr*cos{2pi(hT Rs rj+ts)}*exp(-{hTRsBetaj RsTh})
                  scosr=scosr+cosr          !FRC= SIG fr(j,s)cos{2pi(hT Rs rj+ts)}*Ta(s)

                  if(present(deriv)) then
                     sinr=SIN(arg)*anis*fr   !fr*sin{2pi(hT Rs rj+ts)}*exp(-{hTRsBetaj RsTh})
                     drc(1:3,i)=drc(1:3,i)+h(1:3)*sinr      ! -
                     drc(4,i)=drc(4,i)+h(1)*h(1)*cosr
                     drc(5,i)=drc(5,i)+h(2)*h(2)*cosr
                     drc(6,i)=drc(6,i)+h(3)*h(3)*cosr
                     drc(7,i)=drc(7,i)+h(1)*h(2)*cosr
                     drc(8,i)=drc(8,i)+h(1)*h(3)*cosr
                     drc(9,i)=drc(9,i)+h(2)*h(3)*cosr
                  end if

               end do ! symmetry

               frc(i) = scosr
               otr(i) = afpxn(i)*th(i,nn)
               oti(i) =  afpp(i)*th(i,nn)
               a1= a1 + otr(i)*frc(i)
               b1= b1 + oti(i)*frc(i)

            end do ! Atoms

            av = a1-a2-a3-a4    !real part of the structure factor
            bv = b1-b2+b3+b4    !imaginary part of the structure factor

       else

            do i=1,Atm%natoms
               arg=0.0
               scosr=0.0
               ssinr=0.0
               drs(:,i)=0.0
               drc(:,i)=0.0
               do k=1,grp%NumOps
                  h=hr(k,nn)%h
                  arg=tpi*(dot_product(h,Atm%atom(i)%x)+ht(k,nn))
                  anis=1.0
                  if(Atm%atom(i)%thtype == "aniso") then
                    beta=Atm%atom(i)%u(1:6)
                    anis=     h(1)*h(1)*beta(1)+     h(2)*h(2)*beta(2)+    h(3)*h(3)*beta(3) &
                         +2.0*h(1)*h(2)*beta(4)+ 2.0*h(1)*h(3)*beta(5)+2.0*h(2)*h(3)*beta(6)
                    anis=exp(-anis)
                  end if
                  cosr=COS(arg)*anis*fr     !fr*cos{2pi(hT Rs rj+ts)}*exp(-{hTRsBetaj RsTh})
                  sinr=SIN(arg)*anis*fr     !fr*sin{2pi(hT Rs rj+ts)}*exp(-{hTRsBetaj RsTh})
                  scosr=scosr+cosr          !FRC= SIG fr(j,s)cos{2pi(hT Rs rj+ts)}*Ta(s)
                  ssinr=ssinr+sinr          !FRS= SIG fr(j,s)sin{2pi(hT Rs rj+ts)}*Ta(s)

                  if(present(deriv)) then
                     drc(1:3,i)=drc(1:3,i)+h(1:3)*sinr      ! -
                     drs(1:3,i)=drs(1:3,i)+h(1:3)*cosr      ! +

                     drc(4,i)=drc(4,i)+h(1)*h(1)*cosr
                     drc(5,i)=drc(5,i)+h(2)*h(2)*cosr
                     drc(6,i)=drc(6,i)+h(3)*h(3)*cosr
                     drc(7,i)=drc(7,i)+h(1)*h(2)*cosr
                     drc(8,i)=drc(8,i)+h(1)*h(3)*cosr
                     drc(9,i)=drc(9,i)+h(2)*h(3)*cosr

                     drs(4,i)=drs(4,i)+h(1)*h(1)*sinr
                     drs(5,i)=drs(5,i)+h(2)*h(2)*sinr
                     drs(6,i)=drs(6,i)+h(3)*h(3)*sinr
                     drs(7,i)=drs(7,i)+h(1)*h(2)*sinr
                     drs(8,i)=drs(8,i)+h(1)*h(3)*sinr
                     drs(9,i)=drs(9,i)+h(2)*h(3)*sinr
                  end if

               end do ! symmetry

               frc(i) = scosr
               frs(i) = ssinr
               otr(i) = afpxn(i)*th(i,nn)
               oti(i) =  afpp(i)*th(i,nn)
               a1= a1 + otr(i)*frc(i)
               b1= b1 + oti(i)*frc(i)
               a3 = a3 + oti(i)*frs(i)
               b3 = b3 + otr(i)*frs(i)

            end do ! Atoms

            av = a1-a2-a3-a4    !real part of the structure factor
            bv = b1-b2+b3+b4    !imaginary part of the structure factor

       end if

       If(modi == "P") then
          sf2 = a1*a1 + a2*a2 + a3*a3 + a4*a4 + b1*b1 + b2*b2 + b3*b3 + b4*b4
          sf2 = sf2 + 2.0*(b1*b4 -  a1*a4 + a2*a3 - b2*b3)
       else
          sf2= av*av+bv*bv
       End if

       if(present(fc)) then
         fc=cmplx(av,bv)
       end if

       if(present(deriv)) then

         if(modi == "P") then

             do i=1,Atm%natoms
                !derivatives with respect to coordinates  POWDER
                do m=1,3
                   k= Atm%atom(i)%lx(m)
                   if(k /= 0) then
                     f=atm%atom(i)%mx(m)
                     der= otr(i)*(-a1*drc(m,i)+b3*drs(m,i))+oti(i)*(-b1*drc(m,i)+a3*drs(m,i))
                     der=2.0*der*tpi
                     deriv(k) = sign(1.0_cp,f)*der+deriv(k)
                   end if
                 end do

                 k=Atm%atom(i)%lbiso  !Derivatives w.r.t. Biso  POWDER
                 if(k /= 0) then
                   f=Atm%atom(i)%mbiso
                   der= otr(i)*(a1*frc(i) +b3*frs(i))+oti(i)*(b1*frc(i) +a3*frs(i))
                   der=-2.0*der*sn
                   deriv(k) = sign(1.0_cp,f)*der+deriv(k)
                 end if

                 k=Atm%atom(i)%locc    !Derivatives w.r.t. occupation factor   POWDER
                 if(k /= 0) then
                   f=Atm%atom(i)%mocc
                   der= otr(i)*(a1*frc(i)+b3*frs(i))+oti(i)*(b1*frc(i)+a3*frs(i))
                   der=2.0*der/atm%atom(i)%occ
                   deriv(k) = sign(1.0_cp,f)*der+deriv(k)
                 end if

                 do m=4,9      !Derivatives w.r.t. anisotropic temperature factors   POWDER
                    j=m-3
                    k=Atm%atom(i)%lu(j)
                    if(k /= 0) then
                      f=Atm%atom(i)%mu(j)
                      der=  otr(i)*(a1*drc(i,j)+b3*drs(m,i))+oti(i)*(b1*drc(m,i)+a3*drs(m,i))
                      der=-2.0*der
                      if(j > 3) der=2.0*der
                      deriv(k) = sign(1.0_cp,f)*der+deriv(k)
                    end if
                 end do

             end do

         else

             do i=1,Atm%natoms
                !derivatives with respect to coordinates  S-XTAL
                do m=1,3
                   k= Atm%atom(i)%lx(m)
                   if(k /= 0) then
                     f=atm%atom(i)%mx(m)
                     der=   -av*(otr(i)*drc(m,i) + oti(i)*drs(m,i))
                     der=der-bv*(oti(i)*drc(m,i) - otr(i)*drs(m,i))
                     der=2.0*der*tpi
                     deriv(k) = sign(1.0_cp,f)*der+deriv(k)
                   end if
                 end do

                 k=Atm%atom(i)%lbiso  !Derivatives w.r.t. Biso  S-XTAL
                 if(k /= 0) then
                   f=Atm%atom(i)%mbiso
                   der=   -av*( otr(i)*frc(i) - oti(i)*frs(i) )
                   der=der-bv*( oti(i)*frc(i) + otr(i)*frs(i) )
                   der=2.0*der*sn
                   deriv(k) = sign(1.0_cp,f)*der+deriv(k)
                 end if

                 k=Atm%atom(i)%locc    !Derivatives w.r.t. occupation factor  S-XTAL
                 if(k /= 0) then
                   f=Atm%atom(i)%mocc
                   der=    av*( otr(i)*frc(i) - oti(i)*frs(i) )
                   der=der+bv*( oti(i)*frc(i) + otr(i)*frs(i) )
                   der=2.0*der/atm%atom(i)%occ
                   deriv(k) = sign(1.0_cp,f)*der+deriv(k)
                 end if

                 do m=4,9        !Derivatives w.r.t. anisotropic temperature factors S-XTAL
                    j=m-3
                    k=Atm%atom(i)%lu(j)
                    if(k /= 0) then
                      f=Atm%atom(i)%mu(j)
                      der=   -av*(otr(i)*drc(m,i) - oti(i)*drs(m,i))
                      der=der-bv*(oti(i)*drc(m,i) + otr(i)*drs(m,i))
                      der=2.0*der
                      if(j > 3) der=2.0*der
                      deriv(k) = sign(1.0_cp,f)*der+deriv(k)
                    end if
                 end do

             end do
         end if !modi
       end if  !derivatives

       return
    End Subroutine Calc_StrFactor

    !!--++
    !!----
    !!---- Subroutine Calc_hkl_StrFactor(mode,rad,hn,sn,Atm,Grp,sf2,deriv,fc)
    !!----    character(len=*),                   intent(in) :: mode !S-XTAL (S) or Powder (P)
    !!----    character(len=*),                   intent(in) :: rad  !Radiation: X-rays, Neutrons
    !!----    integer, dimension(3)               intent(in) :: hn
    !!----    real(kind=cp)                       intent(in) :: sn !(sinTheta/Lambda)**2
    !!----    type(atom_list_type),               intent(in) :: Atm
    !!----    type(space_group_type),             intent(in) :: Grp
    !!----    real(kind=cp)                       intent(out):: sf2
    !!----    real(kind=cp),dimension(:),optional,intent(out):: deriv
    !!----    complex, optional,                  intent(out):: fc
    !!----
    !!----    Calculate Structure Factor for reflection "h=(hkl)" not related with
    !!----    previous lists and derivatives with respect to refined parameters.
    !!----    This subroutine calculates the form-factors internally without using
    !!----    global tables. The purpose of this procedure is to avoid the use of
    !!----    too much memory in tables.
    !!----
    !!---- Update: April - 2009
    !!
    Subroutine Calc_hkl_StrFactor(mode,rad,hn,sn,Atm,Grp,sf2,deriv,fc)
       !---- Arguments ----!
       character(len=*),                   intent(in) :: mode
       character(len=*),                   intent(in) :: rad
       integer,dimension(3),               intent(in) :: hn
       real(kind=cp),                      intent(in) :: sn !(sinTheta/Lambda)**2
       type(atom_list_type),               intent(in) :: Atm
       type(space_group_type),             intent(in) :: Grp
       real(kind=cp),                      intent(out):: sf2
       real(kind=cp),dimension(:),optional,intent(out):: deriv
       complex, optional,                  intent(out):: fc

       !---- Local Variables ----!
       character(len=1)                      :: modi
       integer                               :: i,j,k,m
       real(kind=cp)                         :: arg,anis,cosr,sinr,scosr,ssinr,fr,fi,der, hnt
       real(kind=cp)                         :: a1,a2,a3,a4,b1,b2,b3,b4,av,bv,f,occ,b, Tob
       real(kind=cp),dimension(3)            :: h
       real(kind=cp),dimension(6)            :: beta
       real(kind=cp),dimension(Atm%natoms)   :: frc,frs,otr,oti,afpxn,ff
       real(kind=cp),dimension(9,Atm%natoms) :: drs,drc


       !--- Initialising local variables
       a1=0.0
       a2=0.0
       a3=0.0
       a4=0.0
       b1=0.0
       b2=0.0
       b3=0.0
       b4=0.0
       av=0.0
       bv=0.0
       frc=0.0
       frs=0.0
       otr=0.0
       oti=0.0
       modi=u_case(mode(1:1))
       !Setting up the scattering form factors and multiply by group specific
       !coefficients for calculating structure factors per conventional cell
       !---- Modify the scattering factors to include the
       !---- multipliers factors concerning centre of symmetry and
       !---- centred translations
       fr=1.0; fi=1.0
       if (Grp%Centred == 2) fr=2.0
       if (Grp%NumLat  > 1)  fi=Grp%NumLat
       Select Case (rad(1:1))
          Case("N")
              afpxn(:)=fr*fi*afp(:)
          Case("X","E")
              do i=1,Nspecies
                ff(i)=FF_c(i)
                do j=1,4
                 ff(i)=ff(i)+FF_a(j,i)*exp(-sn*FF_b(j,i))
                end do
                 if (rad(1:1) == "E") ff(i)=0.023934*(FF_Z(i)-ff(i))/sn !Mott-Bethe formula fe=me^2/(8pi Eps0 h^2) (Z-fx(s))/s^2
              end do
              do i=1,Atm%natoms
                j=P_a(i)   !pointer has been set up in Initialization subroutine
                afpxn(i)= fr*fi*ff(j)
              end do
       End Select

       fr=1.0
       fi=0.0
       if(Grp%Centred == 2) then
            do i=1,Atm%natoms
               arg=0.0
               scosr=0.0
               ssinr=0.0
               drs(:,i)=0.0
               drc(:,i)=0.0
               do k=1,grp%NumOps
                  h=Hkl_R(hn,grp%symop(k))                   !Calculations in-lining
                  hnt=dot_product(real(hn),Grp%SymOp(k)%Tr)  !Calculations in-lining
                  arg=tpi*(dot_product(h,Atm%atom(i)%x)+hnt)
                  anis=1.0
                  if(Atm%atom(i)%thtype == "aniso") then
                    beta=Atm%atom(i)%u(1:6)
                    anis=     h(1)*h(1)*beta(1)+     h(2)*h(2)*beta(2)+    h(3)*h(3)*beta(3) &
                         +2.0*h(1)*h(2)*beta(4)+ 2.0*h(1)*h(3)*beta(5)+2.0*h(2)*h(3)*beta(6)
                    anis=exp(-anis)
                  end if
                  cosr=COS(arg)*anis*fr     !fr*cos{2pi(hT Rs rj+ts)}*exp(-{hTRsBetaj RsTh})
                  scosr=scosr+cosr          !FRC= SIG fr(j,s)cos{2pi(hT Rs rj+ts)}*Ta(s)

                  if(present(deriv)) then
                     sinr=SIN(arg)*anis*fr   !fr*sin{2pi(hT Rs rj+ts)}*exp(-{hTRsBetaj RsTh})
                     drc(1:3,i)=drc(1:3,i)+h(1:3)*sinr      ! -
                     drc(4,i)=drc(4,i)+h(1)*h(1)*cosr
                     drc(5,i)=drc(5,i)+h(2)*h(2)*cosr
                     drc(6,i)=drc(6,i)+h(3)*h(3)*cosr
                     drc(7,i)=drc(7,i)+h(1)*h(2)*cosr
                     drc(8,i)=drc(8,i)+h(1)*h(3)*cosr
                     drc(9,i)=drc(9,i)+h(2)*h(3)*cosr
                  end if

               end do ! symmetry
               occ= atm%atom(i)%occ
               b=atm%atom(i)%biso
               Tob= occ * exp(-b*sn)
               frc(i) = scosr
               otr(i) = afpxn(i)* Tob
               oti(i) =  afpp(i)* Tob
               a1= a1 + otr(i)*frc(i)
               b1= b1 + oti(i)*frc(i)

            end do ! Atoms

            av = a1-a2-a3-a4    !real part of the structure factor
            bv = b1-b2+b3+b4    !imaginary part of the structure factor

       else

            do i=1,Atm%natoms
               arg=0.0
               scosr=0.0
               ssinr=0.0
               drs(:,i)=0.0
               drc(:,i)=0.0
               do k=1,grp%NumOps
                  h=Hkl_R(hn,grp%symop(k))
                  hnt=dot_product(real(hn),Grp%SymOp(k)%Tr)
                  arg=tpi*(dot_product(h,Atm%atom(i)%x)+hnt)
                  anis=1.0
                  if(Atm%atom(i)%thtype == "aniso") then
                    beta=Atm%atom(i)%u(1:6)
                    anis=     h(1)*h(1)*beta(1)+     h(2)*h(2)*beta(2)+    h(3)*h(3)*beta(3) &
                         +2.0*h(1)*h(2)*beta(4)+ 2.0*h(1)*h(3)*beta(5)+2.0*h(2)*h(3)*beta(6)
                    anis=exp(-anis)
                  end if
                  cosr=COS(arg)*anis*fr     !fr*cos{2pi(hT Rs rj+ts)}*exp(-{hTRsBetaj RsTh})
                  sinr=SIN(arg)*anis*fr     !fr*sin{2pi(hT Rs rj+ts)}*exp(-{hTRsBetaj RsTh})
                  scosr=scosr+cosr          !FRC= SIG fr(j,s)cos{2pi(hT Rs rj+ts)}*Ta(s)
                  ssinr=ssinr+sinr          !FRS= SIG fr(j,s)sin{2pi(hT Rs rj+ts)}*Ta(s)

                  if(present(deriv)) then
                     drc(1:3,i)=drc(1:3,i)+h(1:3)*sinr      ! -
                     drs(1:3,i)=drs(1:3,i)+h(1:3)*cosr      ! +

                     drc(4,i)=drc(4,i)+h(1)*h(1)*cosr
                     drc(5,i)=drc(5,i)+h(2)*h(2)*cosr
                     drc(6,i)=drc(6,i)+h(3)*h(3)*cosr
                     drc(7,i)=drc(7,i)+h(1)*h(2)*cosr
                     drc(8,i)=drc(8,i)+h(1)*h(3)*cosr
                     drc(9,i)=drc(9,i)+h(2)*h(3)*cosr

                     drs(4,i)=drs(4,i)+h(1)*h(1)*sinr
                     drs(5,i)=drs(5,i)+h(2)*h(2)*sinr
                     drs(6,i)=drs(6,i)+h(3)*h(3)*sinr
                     drs(7,i)=drs(7,i)+h(1)*h(2)*sinr
                     drs(8,i)=drs(8,i)+h(1)*h(3)*sinr
                     drs(9,i)=drs(9,i)+h(2)*h(3)*sinr
                  end if

               end do ! symmetry
               occ= atm%atom(i)%occ
               b=atm%atom(i)%biso
               Tob= occ * exp(-b*sn)
               frc(i) = scosr
               frs(i) = ssinr
               otr(i) = afpxn(i)* Tob
               oti(i) =  afpp(i)* Tob
               a1= a1 + otr(i)*frc(i)
               b1= b1 + oti(i)*frc(i)
               a3 = a3 + oti(i)*frs(i)
               b3 = b3 + otr(i)*frs(i)

            end do ! Atoms

            av = a1-a2-a3-a4    !real part of the structure factor
            bv = b1-b2+b3+b4    !imaginary part of the structure factor

       end if

       If(modi == "P") then
          sf2 = a1*a1 + a2*a2 + a3*a3 + a4*a4 + b1*b1 + b2*b2 + b3*b3 + b4*b4
          sf2 = sf2 + 2.0*(b1*b4 -  a1*a4 + a2*a3 - b2*b3)
       else
          sf2= av*av+bv*bv
       End if

       if(present(fc)) then
         fc=cmplx(av,bv)
       end if

       if(present(deriv)) then

         if(modi == "P") then

             do i=1,Atm%natoms
                !derivatives with respect to coordinates  POWDER
                do m=1,3
                   k= Atm%atom(i)%lx(m)
                   if(k /= 0) then
                     f=atm%atom(i)%mx(m)
                     der= otr(i)*(-a1*drc(m,i)+b3*drs(m,i))+oti(i)*(-b1*drc(m,i)+a3*drs(m,i))
                     der=2.0*der*tpi
                     deriv(k) = sign(1.0_cp,f)*der+deriv(k)
                   end if
                 end do

                 k=Atm%atom(i)%lbiso  !Derivatives w.r.t. Biso  POWDER
                 if(k /= 0) then
                   f=Atm%atom(i)%mbiso
                   der= otr(i)*(a1*frc(i) +b3*frs(i))+oti(i)*(b1*frc(i) +a3*frs(i))
                   der=-2.0*der*sn
                   deriv(k) = sign(1.0_cp,f)*der+deriv(k)
                 end if

                 k=Atm%atom(i)%locc    !Derivatives w.r.t. occupation factor   POWDER
                 if(k /= 0) then
                   f=Atm%atom(i)%mocc
                   der= otr(i)*(a1*frc(i)+b3*frs(i))+oti(i)*(b1*frc(i)+a3*frs(i))
                   der=2.0*der/atm%atom(i)%occ
                   deriv(k) = sign(1.0_cp,f)*der+deriv(k)
                 end if

                 do m=4,9      !Derivatives w.r.t. anisotropic temperature factors   POWDER
                    j=m-3
                    k=Atm%atom(i)%lu(j)
                    if(k /= 0) then
                      f=Atm%atom(i)%mu(j)
                      der=  otr(i)*(a1*drc(i,j)+b3*drs(m,i))+oti(i)*(b1*drc(m,i)+a3*drs(m,i))
                      der=-2.0*der
                      if(j > 3) der=2.0*der
                      deriv(k) = sign(1.0_cp,f)*der+deriv(k)
                    end if
                 end do

             end do

         else

             do i=1,Atm%natoms
                !derivatives with respect to coordinates  S-XTAL
                do m=1,3
                   k= Atm%atom(i)%lx(m)
                   if(k /= 0) then
                     f=atm%atom(i)%mx(m)
                     der=   -av*(otr(i)*drc(m,i) + oti(i)*drs(m,i))
                     der=der-bv*(oti(i)*drc(m,i) - otr(i)*drs(m,i))
                     der=2.0*der*tpi
                     deriv(k) = sign(1.0_cp,f)*der+deriv(k)
                   end if
                 end do

                 k=Atm%atom(i)%lbiso  !Derivatives w.r.t. Biso  S-XTAL
                 if(k /= 0) then
                   f=Atm%atom(i)%mbiso
                   der=   -av*( otr(i)*frc(i) - oti(i)*frs(i) )
                   der=der-bv*( oti(i)*frc(i) + otr(i)*frs(i) )
                   der=2.0*der*sn
                   deriv(k) = sign(1.0_cp,f)*der+deriv(k)
                 end if

                 k=Atm%atom(i)%locc    !Derivatives w.r.t. occupation factor  S-XTAL
                 if(k /= 0) then
                   f=Atm%atom(i)%mocc
                   der=    av*( otr(i)*frc(i) - oti(i)*frs(i) )
                   der=der+bv*( oti(i)*frc(i) + otr(i)*frs(i) )
                   der=2.0*der/atm%atom(i)%occ
                   deriv(k) = sign(1.0_cp,f)*der+deriv(k)
                 end if

                 do m=4,9        !Derivatives w.r.t. anisotropic temperature factors S-XTAL
                    j=m-3
                    k=Atm%atom(i)%lu(j)
                    if(k /= 0) then
                      f=Atm%atom(i)%mu(j)
                      der=   -av*(otr(i)*drc(m,i) - oti(i)*drs(m,i))
                      der=der-bv*(oti(i)*drc(m,i) + otr(i)*drs(m,i))
                      der=2.0*der
                      if(j > 3) der=2.0*der
                      deriv(k) = sign(1.0_cp,f)*der+deriv(k)
                    end if
                 end do

             end do
         end if !modi
       end if  !derivatives

       return
    End Subroutine Calc_hkl_StrFactor

    !!--++ Subroutine Calc_Table_TH(Reflex,Atm)
    !!--++    type(reflection_List_type),   intent(in) :: Reflex
    !!--++    type(atom_list_type),        intent(in) :: Atm
    !!--++
    !!--++    (Private)
    !!--++    Calculate a Table of Isotropinc Thermal contribution and occupation
    !!--..         TH(Natoms,Nref)
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Calc_Table_TH(Reflex,Atm)
       !---- Argument ----!
       type(reflection_list_type), intent(in) :: Reflex
       type(atom_list_type),      intent(in) :: Atm

       !---- Local variables ----!
       integer          :: i,j
       real(kind=cp)    :: b,s

       !---- Isotropic model ----!
       do j=1,reflex%nref
          s=reflex%ref(j)%s
          do i=1,atm%natoms
             b=atm%atom(i)%biso
             th(i,j)= atm%atom(i)%occ * exp(-b*s*s)
          end do
       end do

       return
    End Subroutine Calc_Table_TH

    !!--++
    !!--++ Subroutine Create_Table_fabc_Xray(Atm,lambda,lun)
    !!--++    type(atom_list_type),      intent(in) :: Atm
    !!--++    real(kind=cp), optiona      intent(in) :: lambda
    !!--++    integer, optional,          intent(in) :: lun
    !!--++
    !!--++    (Private)
    !!--++    Calculate a Table of Coefficients for Atomic Form Factors for X-Ray
    !!--++    ff_A(4,species),ff_B(4,Nspecies),ff_C(Nspecies), AFP(Nspecies), AFPP(Nspecies)
    !!--++    ff_z(Nspecies) contains the atomic number of the chemical species (useful for Electron diffraction)
    !!--++    p_a(Natoms) => pointer to the species of each atom
    !!--++
    !!--++ Update: April - 2009
    !!
    Subroutine Create_Table_fabc_Xray(Atm,lambda,elect,lun)
       !---- Arguments ----!
       type(atom_list_type),       intent(in) :: Atm
       real(kind=cp), optional,    intent(in) :: lambda
       integer, optional,          intent(in) :: elect
       integer, optional,          intent(in) :: lun

       !---- Local Variables ----!
       character(len=4)               :: symbcar
       integer                        :: i,j, k,n,L
       integer, dimension(atm%natoms) :: ix,jx,ia
       real(kind=cp)                  :: dmin,d

       !---- Init ----!
       err_sfac=.false.

       !---- Load form factor values for XRay ----!
       call Set_Xray_Form()

       !---- Found Species on Xray_Form ----!
       ix=0
       jx=0
       n=0
       if(allocated(P_a)) deallocate(P_a)
       allocate(P_a(atm%natoms))

       do i=1,atm%natoms
          symbcar=l_case(atm%atom(i)%SfacSymb)
          do j=1,Num_Xray_Form
             if (symbcar /= Xray_form(j)%Symb) cycle
             ix(i)=j
             if(any(jx == j) ) exit
             n=n+1
             jx(n)=j
             ia(n)=i
             exit
          end do
       end do

       if (any(ix==0)) then
          err_sfac=.true.
          ERR_SFac_Mess="The Species "//symbcar//" was not found"
          return
       end if

       do i=1,atm%natoms
         j=ix(i)
         do k=1,n
           if(jx(k) == j) then
             P_a(i)=k              !The atom i is of species k
             exit
           end if
         end do
       end do
       Nspecies=n !Global private variable (Total number of chemical species)
       if(allocated(FF_a)) deallocate (FF_a)
       if(allocated(FF_b)) deallocate (FF_b)
       if(allocated(FF_c)) deallocate (FF_c)
       if(allocated(FF_z)) deallocate (FF_z)
       allocate(FF_a(4,n),FF_b(4,n),FF_c(n),FF_z(n))
       do k=1,n
          j = jx(k)
          i = ia(k)
          FF_a(:,k)= xray_form(j)%a(:)
          FF_b(:,k)= xray_form(j)%b(:)
          FF_c(  k)= xray_form(j)%c
          FF_z(  k)= xray_form(j)%Z
       end do

       if (present(lun)) then
          if(present(elect)) then
            write(unit=lun,fmt="(/,a)") "  INFORMATION FROM TABULATED X-RAY SCATTERING FACTORS (For Electron Diffraction)"
            write(unit=lun,fmt="(a,/)") "  =============================================================================="
          else
            write(unit=lun,fmt="(/,a)") "  INFORMATION FROM TABULATED X-RAY SCATTERING FACTORS"
            write(unit=lun,fmt="(a,/)") "  ==================================================="
          end if
       End if
       if(.not. present(elect)) then
        if (present(lambda)) then
          !---- Load anomalous scattering form factor values for XRays ----!
          call Set_Delta_Fp_Fpp()

          !---- Select wavelength (by default is CuKalpha1: k=5 in the list) ----!
          dmin=1000.0
          do i=1,5
             d=abs(lambda-Xray_Wavelengths(i)%Kalfa(1))
             if (d < dmin) then
                dmin=d
                k=i        !Selection of the index for fp and fpp lists
             end if
          end do

          !---- Found Species on Anomalous_ScFac ----!
          do i=1,atm%natoms
             symbcar=l_case(atm%atom(i)%chemsymb)
             do j=1,Num_Delta_Fp
                if (symbcar /= Anomalous_ScFac(j)%Symb) cycle
                afp(i)=Anomalous_ScFac(j)%fp(k)
                afpp(i)=Anomalous_ScFac(j)%fpp(k)
                exit
             end do
          end do
          call Remove_Delta_Fp_Fpp()
        else
           if (present(lun)) then
             write(unit=lun,fmt="(a)")    "  Missed lambda, anomalous dipersion corrections not applied   "
             write(unit=lun,fmt="(a)")    "  The default wavelength is that of Cu-Kalpha1 spectral line  "
           end if
        end if
       end if !present(elect)


       !---- Printing Information ----!
       if (present(lun)) then
         if(present(elect)) then
          write(unit=lun,fmt="(/,a,/)")    "   ATOMIC SCATTERING FACTOR COEFFICIENTS: {A(i),B(i),I=1,4},C  and Atomic Number "
          write(unit=lun,fmt="(a,i3)")     "   Number of chemically different species: ",n
         write(unit=lun,fmt="(/,a)") &
               "   Atom     a1       b1       a2       b2       a3       b3       a4       b4        c       Z"
          do k=1,n
             j = jx(k)
             i = ia(k)
             write(unit=lun,fmt="(a,9F9.5,i7)")    &
                           "     "//atm%atom(i)%chemsymb, &
                           (xray_form(j)%a(L),xray_form(j)%b(L), L=1,4), xray_form(j)%c, &
                           xray_form(j)%z
          end do
        else
          write(unit=lun,fmt="(/,a,/)")    "   ATOMIC SCATTERING FACTOR COEFFICIENTS: {A(i),B(i),I=1,4},C  Dfp  Dfpp "
          write(unit=lun,fmt="(a,i3)")     "   Number of chemically different species: ",n
          write(unit=lun,fmt="(/,a)") &
               "   Atom     a1       b1       a2       b2       a3       b3       a4       b4        c      Dfp     Dfpp"
          do k=1,n
             j = jx(k)
             i = ia(k)
             write(unit=lun,fmt="(a,11F9.5)")    &
                           "     "//atm%atom(i)%chemsymb, &
                           (xray_form(j)%a(L),xray_form(j)%b(L), L=1,4), xray_form(j)%c, &
                           afp(i), afpp(i)
          end do
         end if
          write(unit=lun,fmt="(/,/)")
       end if

       call Remove_Xray_Form()

       return
    End Subroutine Create_Table_fabc_Xray

    !!--++
    !!--++ Subroutine Create_Table_AF0_Electrons(Reflex,Atm,lun)
    !!--++    type(reflection_List_type), intent(in) :: Reflex
    !!--++    type(atom_list_type),       intent(in) :: Atm
    !!--++    integer, optional,          intent(in) :: lun
    !!--++
    !!--++    (Private)
    !!--++    Calculate a Table of Atomic Factors for Electrons
    !!--++    applying the Mott-Bethe formula:
    !!--++    fe=me^2/(8pi Eps0 h^2) (Z-fx(s))/s^2
    !!--++
    !!--++ Update: April - 2009
    !!
    Subroutine Create_Table_AF0_Electrons(Reflex,Atm,lun)
       !---- Arguments ----!
       type(reflection_list_type), intent(in) :: Reflex
       type(atom_list_type),       intent(in) :: Atm
       integer, optional,          intent(in) :: lun

       !---- Local Variables ----!
       character(len=4)               :: symbcar
       integer                        :: i,j, k,n,L
       integer, dimension(atm%natoms) :: ix,jx,ia
       real(kind=cp)                  :: fx

       !---- Init ----!
       err_sfac=.false.

       !---- Load form factor values for XRay ----!
       call Set_Xray_Form()

       !---- Found Species on Xray_Form ----!
       ix=0
       jx=0
       n=0
       do i=1,atm%natoms
          symbcar=l_case(atm%atom(i)%SfacSymb)
          do j=1,Num_Xray_Form
             if (symbcar /= Xray_form(j)%Symb) cycle
             ix(i)=j
             if(any(jx == j) ) exit
             n=n+1
             jx(n)=j
             ia(n)=i
             exit
          end do
       end do

       if (present(lun)) then
         write(unit=lun,fmt="(/,a)") "  INFORMATION FROM TABULATED X-RAY SCATTERING FACTORS (For Electron Diffraction)"
          write(unit=lun,fmt="(a,/)") "  =============================================================================="
       End if

       if (any(ix==0)) then
          err_sfac=.true.
          ERR_SFac_Mess="The Species "//symbcar//" was not found"
       else
          !---- Fill AF Table ----!
          do j=1,reflex%nref
             do i=1,atm%natoms
                fx=fj(reflex%ref(j)%s,xray_form(ix(i))%a,xray_form(ix(i))%b,xray_form(ix(i))%c)+afp(i)
                !Mott-Bethe formula fe=me^2/(8pi Eps0 h^2) (Z-fx(s))/s^2
                af0(i,j)=0.023934*(xray_form(ix(i))%Z-fx)/(reflex%ref(j)%s*reflex%ref(j)%s)
             end do
          end do
       end if

       !---- Printing Information ----!
       if (present(lun)) then
          write(unit=lun,fmt="(/,a,/)")    "   ATOMIC SCATTERING FACTOR COEFFICIENTS: {A(i),B(i),I=1,4},C  and Atomic Number "
          write(unit=lun,fmt="(a,i3)")     "   Number of chemically different species: ",n
          write(unit=lun,fmt="(/,a)") &
               "   Atom     a1       b1       a2       b2       a3       b3       a4       b4        c       Z"
          do k=1,n
             j = jx(k)
             i = ia(k)
             write(unit=lun,fmt="(a,9F9.5,i7)")    &
                           "     "//atm%atom(i)%chemsymb, &
                           (xray_form(j)%a(L),xray_form(j)%b(L), L=1,4), xray_form(j)%c, &
                            xray_form(j)%Z
          end do
          write(unit=lun,fmt="(/,/)")
       end if

       call Remove_Xray_Form()

       return
    End Subroutine Create_Table_AF0_Electrons

    !!--++
    !!--++ Subroutine Create_Table_AF0_Xray(Reflex,Atm,lambda,lun)
    !!--++    type(reflection_List_type), intent(in) :: Reflex
    !!--++    type(atom_list_type),      intent(in) :: Atm
    !!--++    real(kind=cp), optiona      intent(in) :: lambda
    !!--++    integer, optional,          intent(in) :: lun
    !!--++
    !!--++    (Private)
    !!--++    Calculate a Table of Atomic Factors for X-Ray
    !!--..      AF0(Natoms,Nref), AFP(Natoms), AFPP(Natoms)
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Create_Table_AF0_Xray(Reflex,Atm,lambda,lun)
       !---- Arguments ----!
       type(reflection_list_type), intent(in) :: Reflex
       type(atom_list_type),      intent(in) :: Atm
       real(kind=cp), optional,    intent(in) :: lambda
       integer, optional,          intent(in) :: lun

       !---- Local Variables ----!
       character(len=4)               :: symbcar
       integer                        :: i,j, k,n,L
       integer, dimension(atm%natoms) :: ix,jx,ia
       real(kind=cp)                  :: dmin,d

       !---- Init ----!
       err_sfac=.false.

       !---- Load form factor values for XRay ----!
       call Set_Xray_Form()

       !---- Found Species on Xray_Form ----!
       ix=0
       jx=0
       n=0
       do i=1,atm%natoms
          symbcar=l_case(atm%atom(i)%SfacSymb)
          do j=1,Num_Xray_Form
             if (symbcar /= Xray_form(j)%Symb) cycle
             ix(i)=j
             if(any(jx == j) ) exit
             n=n+1
             jx(n)=j
             ia(n)=i
             exit
          end do
       end do

       if (present(lun)) then
          write(unit=lun,fmt="(/,a)") "  INFORMATION FROM TABULATED X-RAY SCATTERING FACTORS"
          write(unit=lun,fmt="(a,/)") "  ==================================================="
       End if
       if (present(lambda)) then
          !---- Load anomalous scattering form factor values for XRays ----!
          call Set_Delta_Fp_Fpp()

          !---- Select wavelength (by default is CuKalpha1: k=5 in the list) ----!
          dmin=1000.0
          do i=1,5
             d=abs(lambda-Xray_Wavelengths(i)%Kalfa(1))
             if (d < dmin) then
                dmin=d
                k=i        !Selection of the index for fp and fpp lists
             end if
          end do

          !---- Found Species on Anomalous_ScFac ----!
          do i=1,atm%natoms
             symbcar=l_case(atm%atom(i)%chemsymb)
             do j=1,Num_Delta_Fp
                if (symbcar /= Anomalous_ScFac(j)%Symb) cycle
                afp(i)=Anomalous_ScFac(j)%fp(k)
                afpp(i)=Anomalous_ScFac(j)%fpp(k)
                exit
             end do
          end do
          call Remove_Delta_Fp_Fpp()
       else
           if (present(lun)) then
             write(unit=lun,fmt="(a)")    "  Missed lambda, anomalous dipersion corrections not applied   "
             write(unit=lun,fmt="(a)")    "  The default wavelength is that of Cu-Kalpha1 spectral line  "
           end if
       end if

       if (any(ix==0)) then
          err_sfac=.true.
          ERR_SFac_Mess="The Species "//symbcar//" was not found"
       else
          !---- Fill AF Table ----!
          do j=1,reflex%nref
             do i=1,atm%natoms
                af0(i,j)=fj(reflex%ref(j)%s,xray_form(ix(i))%a,xray_form(ix(i))%b,xray_form(ix(i))%c)+afp(i)
             end do
          end do
       end if

       !---- Printing Information ----!
       if (present(lun)) then
          write(unit=lun,fmt="(/,a,/)")    "   ATOMIC SCATTERING FACTOR COEFFICIENTS: {A(i),B(i),I=1,4},C  Dfp  Dfpp "
          write(unit=lun,fmt="(a,i3)")     "   Number of chemically different species: ",n
          write(unit=lun,fmt="(/,a)") &
               "   Atom     a1       b1       a2       b2       a3       b3       a4       b4        c      Dfp     Dfpp"
          do k=1,n
             j = jx(k)
             i = ia(k)
             write(unit=lun,fmt="(a,11F9.5)")    &
                           "     "//atm%atom(i)%chemsymb, &
                           (xray_form(j)%a(L),xray_form(j)%b(L), L=1,4), xray_form(j)%c, &
                           afp(i), afpp(i)
          end do
          write(unit=lun,fmt="(/,/)")
       end if

       call Remove_Xray_Form()

       return
    End Subroutine Create_Table_AF0_Xray

    !!--++
    !!--++ Subroutine Create_Table_AFP_NeutNuc(Atm,lun)
    !!--++    type(atom_list_type),              intent(in) :: Atm
    !!--++    integer, optional,                  intent(in) :: lun
    !!--++
    !!--++    (Private)
    !!--++    Setting a Table of Fermi Lengths for Neutron Nuclear Scattering
    !!--..      AFP(Natoms)
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Create_Table_AFP_NeutNuc(Atm,lun)
       !---- Arguments ----!
       type(atom_list_type),    intent(in) :: Atm
       integer, optional,       intent(in) :: lun

       !---- Local Variables ----!
       character(len=4)                        :: symbcar
       integer                                 :: i,k,n
       character(len=4), dimension(atm%natoms) :: symb
       real(kind=cp),    dimension(atm%natoms) :: bs
       real(kind=cp)                           :: b

       !---- Init ----!
       err_sfac=.false.

       !---- Load chemical information ----!
       call set_chem_info()

       !---- Getting Fermi Lengths of atoms ----!
       symb="    "
       bs=0.0
       n=0
       do i=1,atm%natoms
          symbcar=u_case(atm%atom(i)%chemsymb)
          call Get_Fermi_Length(symbcar,b)
          if (abs(b) < 0.0001) then
             err_sfac=.true.
             ERR_SFac_Mess="The Fermi Length of Species "//symbcar//" was not found"
             return
          else
             afp(i) = b
             if(any(symb == symbcar)) cycle
             n=n+1
             symb(n)=symbcar
             bs(n) = b
          end if
       end do

       !---- Printing Information ----!
       if (present(lun)) then
          write(unit=lun,fmt="(/,a)")  "  INFORMATION FROM TABULATED NEUTRON SCATTERING FACTORS"
          write(unit=lun,fmt="(a,/)")  "  ==================================================="
          write(unit=lun,fmt="(a)")    "  FERMI LENGTHS "
          write(unit=lun,fmt="(a,i3)") "   Number of chemically different species: ",n
          write(unit=lun,fmt="(/,a)")  "   Atom     Fermi Length [10^(-12) cm]"
          do k=1,n
             write(unit=lun,fmt="(a,F15.6)")  "     "//symb(k), bs(k)
          end do
          write(unit=lun,fmt="(/,/)")
       end if

       call Remove_chem_info()

       return
    End Subroutine Create_Table_AFP_NeutNuc

    !!--++
    !!--++ Subroutine Create_Table_HR_HT(Reflex,Grp)
    !!--++    type(reflection_list_type), intent(in) :: Hkl
    !!--++    type(space_group_type),     intent(in) :: Grp
    !!--++
    !!--++    (Private)
    !!--++    Calculate a Table with HR and HT values
    !!--..       Hr(Grp%Numops,Reflex%Nref)
    !!--..       HT(Grp%Numops,Reflex%Nref)
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Create_Table_HR_HT(Reflex,Grp)
       !---- Arguments ----!
       type(reflection_list_type), intent(in) :: Reflex
       type(space_group_type),     intent(in) :: Grp

       !---- Local Variables ----!
       integer :: i,j

       do j=1,reflex%nref
          do i=1,grp%NumOps
             hr(i,j)%h=Hkl_R(reflex%ref(j)%h,grp%symop(i))
             ht(i,j)=dot_product(real(reflex%ref(j)%h),Grp%SymOp(i)%Tr)
          end do
       end do

       return
    End Subroutine Create_Table_HR_HT

    !!----
    !!---- Subroutine Init_Calc_hkl_StrFactors(Atm,Mode,lambda,lun)
    !!----    type(atom_list_type),                intent(in) :: Atm
    !!----    character(len=*),          optional, intent(in) :: Mode
    !!----    real(kind=cp),             optional, intent(in) :: lambda
    !!----    integer,                   optional, intent(in) :: lun  !Logical unit for writing scatt-factors
    !!----
    !!----    Allocates and initializes arrays for hkl - Structure Factors calculations.
    !!----    No calculation of fixed tables is performed. Should be called before using
    !!----    the subroutine Calc_hkl_StrFactor
    !!----
    !!---- Update: April - 2009
    !!
    Subroutine Init_Calc_hkl_StrFactors(Atm,Mode,lambda,lun)
       !---Arguments ---!
       type(atom_list_type),                intent(in) :: Atm
       character(len=*),          optional, intent(in) :: Mode
       real(kind=cp),             optional, intent(in) :: lambda
       integer,                   optional, intent(in) :: lun

       !--- Local variables ---!

       integer :: Natm
       integer :: ierr
       character(len=3) :: tipo

       tipo="XRA"
       if (present(mode)) tipo=adjustl(mode)
       tipo=U_Case(tipo)
       err_sfac=.false.
       Natm = Atm%natoms


       !---- Anomalous Scattering factor tables ----!
       if (allocated(AFP)) deallocate(AFP)
       allocate(AFP(Natm),stat=ierr)
       if (ierr /=0) then
          err_sfac=.true.
          ERR_SFac_Mess="Error on memory for AFP"
          return
       end if
       AFP=0.0

       if (allocated(AFPP)) deallocate(AFPP)
       allocate(AFPP(Natm),stat=ierr)
       if (ierr /=0) then
          err_sfac=.true.
          ERR_SFac_Mess="Error on memory for AFPP"
          return
       end if
       AFPP=0.0


       !---- Table Fabc ----!
       select case (tipo)

          case ("XRA")
             if (present(lambda)) then
                if (present(lun)) then
                   call Create_Table_Fabc_Xray(Atm,lambda,lun)
                else
                   call Create_Table_Fabc_Xray(Atm,lambda)
                end if
             else
                if (present(lun)) then
                   call Create_Table_Fabc_Xray(Atm,lun=lun)
                else
                   call Create_Table_Fabc_Xray(Atm)
                end if
             end if

          case ("ELE")

             if (present(lun)) then
                call Create_Table_Fabc_Xray(Atm,lun=lun)
             else
                call Create_Table_Fabc_Xray(Atm)
             end if


          case ("NUC")
             if (present(lun)) then
                call Create_Table_AFP_NeutNuc(Atm,lun=lun)
             else
                call Create_Table_AFP_NeutNuc(Atm)
             end if

       end select

       if (.not. err_sfac) SF_Initialized=.true.

       return
    End Subroutine Init_Calc_hkl_StrFactors

    !!----
    !!---- Subroutine Init_Calc_StrFactors(Reflex,Atm,Grp,Mode,lambda,lun)
    !!----    type(reflection_list_type),          intent(in) :: Reflex
    !!----    type(atom_list_type),                intent(in) :: Atm
    !!----    type(space_group_type),              intent(in) :: Grp
    !!----    character(len=*),          optional, intent(in) :: Mode
    !!----    real(kind=cp),             optional, intent(in) :: lambda
    !!----    integer,                   optional, intent(in) :: lun  !Logical unit for writing scatt-factors
    !!----
    !!----    Allocates and initializes arrays for Calc_StrFactors calculations.
    !!----    Calculations of fixed tables are performed. Should be called before using
    !!----    the subroutine Calc_StrFactor
    !!----
    !!---- Update: April - 2009
    !!
    Subroutine Init_Calc_StrFactors(Reflex,Atm,Grp,Mode,lambda,lun)
       !---Arguments ---!
       type(reflection_list_type),          intent(in) :: Reflex
       type(atom_list_type),                intent(in) :: Atm
       type(space_group_type),              intent(in) :: Grp
       character(len=*),          optional, intent(in) :: Mode
       real(kind=cp),             optional, intent(in) :: lambda
       integer,                   optional, intent(in) :: lun

       !--- Local variables ---!

       Call Init_Structure_Factors(Reflex,Atm,Grp,Mode,lambda,lun)
       !---- Table TH ----!
       Call Calc_Table_TH(Reflex,Atm)

       return
    End Subroutine Init_Calc_StrFactors

    !!----
    !!---- Subroutine Init_Structure_Factors(Reflex,Atm,Grp,Mode,lambda,lun)
    !!----    type(reflection_list_type),          intent(in) :: Reflex
    !!----    type(atom_list_type),                intent(in) :: Atm
    !!----    type(space_group_type),              intent(in) :: Grp
    !!----    character(len=*),          optional, intent(in) :: Mode
    !!----    real(kind=cp),             optional, intent(in) :: lambda
    !!----    integer,                   optional, intent(in) :: lun  !Logical unit for writing scatt-factors
    !!----
    !!----    Allocates and initializes arrays for Structure Factors calculations.
    !!----    A calculation of fixed tables is also performed.
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Init_Structure_Factors(Reflex,Atm,Grp,Mode,lambda,lun)
       !---Arguments ---!
       type(reflection_list_type),          intent(in) :: Reflex
       type(atom_list_type),                intent(in) :: Atm
       type(space_group_type),              intent(in) :: Grp
       character(len=*),          optional, intent(in) :: Mode
       real(kind=cp),             optional, intent(in) :: lambda
       integer,                   optional, intent(in) :: lun

       !--- Local variables ---!

       integer :: Natm, Multr
       integer :: ierr

       err_sfac=.false.
       Natm = Atm%natoms
       Multr= Grp%Numops

       !---- Scattering factor tables ----!
       if (allocated(AF0)) deallocate(AF0)
       allocate(AF0(Natm,Reflex%Nref),stat=ierr)
       if (ierr /=0) then
          err_sfac=.true.
          ERR_SFac_Mess="Error on memory for AF0"
          return
       end if
       AF0=0.0

       !---- Anomalous Scattering factor tables ----!
       if (allocated(AFP)) deallocate(AFP)
       allocate(AFP(Natm),stat=ierr)
       if (ierr /=0) then
          err_sfac=.true.
          ERR_SFac_Mess="Error on memory for AFP"
          return
       end if
       AFP=0.0

       if (allocated(AFPP)) deallocate(AFPP)
       allocate(AFPP(Natm),stat=ierr)
       if (ierr /=0) then
          err_sfac=.true.
          ERR_SFac_Mess="Error on memory for AFPP"
          return
       end if
       AFPP=0.0

       !---- HR Table ----!
       if (allocated(HR)) deallocate(HR)
       allocate(HR(Multr,Reflex%Nref),stat=ierr)
       if (ierr /=0) then
          err_sfac=.true.
          ERR_SFac_Mess="Error on memory for HR"
          return
       end if
       HR=HR_Type(0)

       !---- HT Table ----!
       if (allocated(HT)) deallocate(HT)
       allocate(HT(Multr,Reflex%Nref),stat=ierr)
       if (ierr /=0) then
          err_sfac=.true.
          ERR_SFac_Mess="Error on memory for HTR"
          return
       end if
       HT=0.0

       if (allocated(TH)) deallocate(TH)
       allocate(TH(Natm,Reflex%Nref),stat=ierr)
       if (ierr /=0) then
          err_sfac=.true.
          ERR_SFac_Mess="Error on memory for HTR"
          return
       end if
       TH=0.0

       if (allocated(Ajh)) deallocate(Ajh)
       allocate(Ajh(Natm,Reflex%Nref), stat=ierr)
       if (ierr /=0) then
          err_sfac=.true.
          ERR_SFac_Mess="Error in Memory for Aj(h)"
          return
       end if
       Ajh=0.0

       if (allocated(Bjh)) deallocate(Bjh)
       allocate(Bjh(Natm,Reflex%Nref), stat=ierr)
       if (ierr /=0) then
          err_sfac=.true.
          ERR_SFac_Mess="Error in Memory for Bj(h)"
          return
       end if
       Bjh=0.0

       if (present(mode)) then
          if (present(lambda)) then
             if (present(lun)) then
                call Set_Fixed_Tables(Reflex,Atm,Grp,Mode,lambda,lun)
             else
                call Set_Fixed_Tables(Reflex,Atm,Grp,Mode,lambda)
             end if
          else
             if (present(lun)) then
                call Set_Fixed_Tables(Reflex,Atm,Grp,Mode,lun=lun)
             else
                call Set_Fixed_Tables(Reflex,Atm,Grp,Mode)
             end if
          end if
       else
          if (present(lambda)) then
             if (present(lun)) then
                call Set_Fixed_Tables(Reflex,Atm,Grp,lambda=lambda,lun=lun)
             else
                call Set_Fixed_Tables(Reflex,Atm,Grp,lambda=lambda)
             end if
          else
             if (present(lun)) then
                call Set_Fixed_Tables(Reflex,Atm,Grp,lun=lun)
             else
                call Set_Fixed_Tables(Reflex,Atm,Grp)
             end if
          end if
       end if

       if (.not. err_sfac) SF_Initialized=.true.

       return
    End Subroutine Init_Structure_Factors

    !!----
    !!---- Subroutine Modify_SF(Reflex,Atm,Grp,List,Nlist,Mode)
    !!----    type(reflection_list_type),         intent(in out) :: Reflex
    !!----    type(atom_list_type),              intent(in)     :: Atm
    !!----    type(space_group_type),             intent(in)     :: Grp
    !!----    integer,dimension(:),               intent(in)     :: List
    !!----    integer,                            intent(in)     :: Nlist
    !!----    character(len=*),optional,          intent(in)     :: Mode
    !!----
    !!----    Recalculation of Structure Factors because a list of Atoms
    !!----    parameters were modified. List variable
    !!----    contains the number of atoms to be changed.
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Modify_SF(Reflex,Atm,Grp,List,Nlist,partyp,Mode)
       !---- Arguments ----!
       type(reflection_list_type),   intent(in out) :: Reflex
       type(atom_list_type),         intent(in)     :: Atm
       type(space_group_type),       intent(in)     :: Grp
       integer,dimension(:),         intent(in)     :: List
       integer,                      intent(in)     :: NList
       character(len=*),optional,    intent(in)     :: partyp
       character(len=*),optional,    intent(in)     :: Mode

       !---- Local variables ----!
       character(len=2) :: typ
       integer          :: i,j,k,ii
       real(kind=cp)    :: arg,b,s

       typ="CO"
       if (present(partyp)) typ=adjustl(partyp)
       typ=U_Case(typ)

       select case (typ)

          case ("CO") ! by coordinates

            if(Grp%Centred == 2) then

               do j=1,Reflex%Nref
                  do ii=1,Nlist
                     i=list(ii)
                     Ajh(i,j)=0.0
                     arg=0.0
                     do k=1,grp%NumOps
                        arg=tpi*(dot_product(hr(k,j)%h,Atm%atom(i)%x)+ht(k,j))
                        Ajh(i,j)=Ajh(i,j)+cos(arg)
                     end do ! symmetry
                  end do ! NList
               end do ! Reflections

            else

               do j=1,Reflex%Nref
                  do ii=1,Nlist
                     i=list(ii)
                     arg=0.0
                     Ajh(i,j)=0.0
                     Bjh(i,j)=0.0
                     do k=1,grp%NumOps
                        arg=tpi*(dot_product(hr(k,j)%h,Atm%atom(i)%x)+ht(k,j))
                        Ajh(i,j)=Ajh(i,j)+cos(arg)
                        Bjh(i,j)=Bjh(i,j)+sin(arg)
                     end do ! symmetry
                  end do ! NList
               end do ! Reflections

            end if

          case ("TH") ! by thermal parameter or occupation number

             do j=1,Reflex%Nref
                s=reflex%ref(j)%s
                do ii=1,Nlist
                   i=list(ii)
                   b=atm%atom(i)%biso
                   th(i,j)=atm%atom(i)%occ*exp(-b*s*s)
                end do ! NList
             end do ! Reflections

       end select

       !---- Recalculation of SF ----!
       if(present(mode)) then
         if(mode == "XRA" .or. mode == "ELE") then
            call Sum_AB(Reflex,Atm%Natoms,Grp%Centred)
         else if(mode == "NUC") then
            call Sum_AB_NeutNuc(Reflex,Atm%Natoms,Grp%Centred)
         end if
       else
         call Sum_AB(Reflex,Atm%Natoms,Grp%Centred)
       end if


       return
    End Subroutine Modify_SF

    !!--++
    !!--++ Subroutine Set_Fixed_Tables(Reflex,Atm,Grp,mode,lambda,lun)
    !!--++    type(reflection_list_type),         intent(in) :: Reflex
    !!--++    type(atom_list_type),              intent(in) :: Atm
    !!--++    type(space_group_type),             intent(in) :: Grp
    !!--++    character(len=*), optional,         intent(in) :: Mode
    !!--++    real(kind=cp), optional,            intent(in) :: lambda
    !!--++    integer, optional,                  intent(in) :: lun
    !!--++
    !!--++    (Private)
    !!--++    Calculates arrays that are fixed during all further
    !!--++    calculations
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Set_Fixed_Tables(Reflex,Atm,Grp,Mode,lambda,lun)
       !---- Arguments ----!
       type(reflection_list_type),         intent(in) :: Reflex
       type(atom_list_type),               intent(in) :: Atm
       type(space_group_type),             intent(in) :: Grp
       character(len=*), optional,         intent(in) :: Mode
       real(kind=cp), optional,            intent(in) :: lambda
       integer, optional,                  intent(in) :: lun

       !---- Local variables ----!
       character(len=3) :: tipo

       tipo="XRA"
       if (present(mode)) tipo=adjustl(mode)
       tipo=U_Case(tipo)

       !---- Table HR - HT ----!
       call Create_Table_HR_HT(Reflex,Grp)

       !---- Table AF0 ----!
       select case (tipo)

          case ("XRA")
             if (present(lambda)) then
                if (present(lun)) then
                   call Create_Table_AF0_Xray(Reflex,Atm,lambda,lun)
                else
                   call Create_Table_AF0_Xray(Reflex,Atm,lambda)
                end if
             else
                if (present(lun)) then
                   call Create_Table_AF0_Xray(Reflex,Atm,lun=lun)
                else
                   call Create_Table_AF0_Xray(Reflex,Atm)
                end if
             end if

             !---- Modify the scattering factor tables to include the
             !---- multipliers factors concerning centre of symmetry and
             !---- centred translations
             if (Grp%Centred == 2) then
                af0=2.0*af0
                afpp=2.0*afpp
             end if

             if (Grp%NumLat  > 1) then
                af0=Grp%NumLat*af0
                afpp=Grp%NumLat*afpp
             end if

          case ("ELE")

             if (present(lun)) then
                call Create_Table_AF0_Electrons(Reflex,Atm,lun=lun)
             else
                call Create_Table_AF0_Electrons(Reflex,Atm)
             end if

             !---- Modify the scattering factor tables to include the
             !---- multipliers factors concerning centre of symmetry and
             !---- centred translations
             if (Grp%Centred == 2) then
                af0=2.0*af0
                afpp=0.0
             end if

             if (Grp%NumLat  > 1) then
                af0=Grp%NumLat*af0
                afpp=0.0
             end if

          case ("NUC","NEU")
             if (present(lun)) then
                call Create_Table_AFP_NeutNuc(Atm,lun=lun)
             else
                call Create_Table_AFP_NeutNuc(Atm)
             end if
             if (Grp%Centred == 2) afp=2.0*afp
             if (Grp%NumLat  > 1) afp=Grp%NumLat*afp

       end select

       return
    End Subroutine Set_Fixed_Tables

    !!----
    !!---- Subroutine Structure_Factors(Atm,Grp,Reflex,Mode,lambda)
    !!----    type(atom_list_type),               intent(in)     :: Atm
    !!----    type(space_group_type),             intent(in)     :: Grp
    !!----    type(reflection_list_type),         intent(in out) :: Reflex
    !!----    character(len=*), optional,         intent(in)     :: Mode
    !!----    real(kind=cp), optional,            intent(in)     :: lambda
    !!----
    !!----    Calculate the Structure Factors from a list of Atoms
    !!----    and a set of reflections. A call to Init_Structure_Factors
    !!----    is a pre-requisite for using this subroutine. In any case
    !!----    the subroutine calls Init_Structure_Factors if SF_initialized=.false.
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Structure_Factors(Atm,Grp,Reflex,Mode,lambda)
       !---- Arguments ----!
       type(atom_list_type),               intent(in)     :: Atm
       type(space_group_type),             intent(in)     :: Grp
       type(reflection_list_type),         intent(in out) :: Reflex
       character(len=*), optional,         intent(in)     :: Mode
       real(kind=cp), optional,            intent(in)     :: lambda

       !Provisional items
       ! integer::i,j
       !---------------
       if(present(Mode)) then
          if(present(lambda)) then
            if(.not. SF_Initialized) call Init_Structure_Factors(Reflex,Atm,Grp,Mode,lambda)
          else
            if(.not. SF_Initialized) call Init_Structure_Factors(Reflex,Atm,Grp,Mode)
          end if
       else
          if(present(lambda)) then
            if(.not. SF_Initialized) call Init_Structure_Factors(Reflex,Atm,Grp,Lambda=lambda)
          else
            if(.not. SF_Initialized) call Init_Structure_Factors(Reflex,Atm,Grp)
          end if
       end if

       !---- Table TH ----!
       Call Calc_Table_TH(Reflex,Atm)

       !---- Table AB ----!
       call Calc_Table_AB(Reflex%Nref,Atm,Grp)

       !Provisional items
       !open(unit=111,file="stfac.inf",status="replace",action="write")
       !do j=1,Nref
       !  write(111,"(a,3i4)") " Reflection:  ",hkl(j)%h
       !
       !  write(111,"(a)") " Atom              F0         occ*W         Ajh         Bjh"
       !  do i=1,Atm%natoms
       !       write(111,"(a,4f12.4)") "  "//atm%atom(i)%lab, af0(i,j),th(i,j),Ajh(i,j),Bjh(i,j)
       !  end do ! Atoms
       !end do ! Reflections
       !close(unit=111)
       !End Provisional items

       !---- Final Calculation ----!
       if(present(mode)) then
         if(mode == "XRA" .or. mode == "ELE" ) then
            call Sum_AB(Reflex,Atm%Natoms,Grp%Centred)
         else if(mode == "NUC") then
            call Sum_AB_NeutNuc(Reflex,Atm%Natoms,Grp%Centred)
         else if(mode == "MAG") then
         end if
       else
         call Sum_AB(Reflex,Atm%Natoms,Grp%Centred)
       end if
       return
    End Subroutine Structure_Factors

    !!--++
    !!--++ Subroutine Sum_AB(Reflex,Natm,icent)
    !!--++    type(reflection_list_type), intent(in out) :: Reflex
    !!--++    integer,                    intent(in)     :: Natm
    !!--++    integer,                    intent(in)     :: icent
    !!--++
    !!--++    (Private)
    !!--++    Calculate the Final Sum for Structure Factors calculations
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Sum_AB(Reflex,Natm,icent)
       !---- Arguments ----!
       type(reflection_list_type), intent(in out)  :: Reflex
       integer,                    intent(in)      :: Natm
       integer,                    intent(in)      :: icent

       !---- Local Variables ----!
       integer                                     :: i,j
       real(kind=cp)                               :: a,b, ph
       real(kind=cp), dimension(natm,reflex%nref)  :: aa,bb,cc,dd


       ! A(h)=SIG(i){(f0+Deltaf')*OCC*Tiso*Ag}    asfa=a-d
       ! C(h)=SIG(i){    Deltaf" *OCC*Tiso*Ag}    bsfa=b+c

       ! B(h)=SIG(i){(f0+Deltaf')*OCC*Tiso*Bg}
       ! D(h)=SIG(i){    Deltaf" *OCC*Tiso*Bg}

       !---- Fj(h)*Aj(h) ----!

       aa=af0*th*ajh

       if (icent == 2) then    !Calculation for centrosymmetric structures
          do j=1,reflex%nref
             cc(:,j)= afpp(:)*th(:,j)*ajh(:,j)
          end do

          !---- Final Sum ----!
          do i=1,reflex%Nref
             a=sum(aa(:,i))
             b=sum(cc(:,i))
             reflex%ref(i)%Fc=sqrt(a*a+b*b)
             ph = atan2d(b,a)
             if (ph < 0.0) ph=ph+360.0
             reflex%ref(i)%Phase = ph
             reflex%ref(i)%A=a
             reflex%ref(i)%B=b
          end do

       else       !Calculation for non-centrosymmetric structures
          !---- Fj(h)*Bj(h) ----!
          bb=af0*th*bjh

          do j=1,reflex%nref
             cc(:,j)= afpp(:)*th(:,j)*ajh(:,j)
             dd(:,j)= afpp(:)*th(:,j)*bjh(:,j)
          end do

          !---- Final Sum ----!
          do i=1,reflex%Nref
             a=sum(aa(:,i)-dd(:,i))
             b=sum(bb(:,i)+cc(:,i))
             reflex%ref(i)%Fc=sqrt(a*a+b*b)
             ph = atan2d(b,a)
             if (ph < 0.0) ph=ph+360.0
             reflex%ref(i)%Phase = ph
             reflex%ref(i)%A=a
             reflex%ref(i)%B=b
          end do
       end if

       return
    End Subroutine Sum_AB

    !!--++
    !!--++ Subroutine Sum_AB_NeutNuc(Reflex,Natm,icent)
    !!--++    type(reflection_list_type),         intent(in out) :: Reflex
    !!--++    integer,                            intent(in)     :: Natm
    !!--++    integer,                            intent(in)     :: icent
    !!--++
    !!--++    (Private)
    !!--++    Calculate the Final Sum for Structure Factors calculations
    !!--++    Adapted for Neutron Nuclear Scattering (real scattering lengths)
    !!--++
    !!--++ Update: February - 2005
    !!
    Subroutine Sum_AB_NeutNuc(Reflex,Natm,icent)
       !---- Arguments ----!
       type(reflection_list_type),   intent(in out) :: Reflex
       integer,                      intent(in)     :: Natm
       integer,                      intent(in)     :: icent

       !---- Local Variables ----!
       integer                                     :: i,j
       real(kind=cp)                               :: a,b, ph
       real(kind=cp), dimension(natm,reflex%nref)  :: aa,bb

       if (icent == 2) then    !Calculation for centrosymmetric structures

          !---- Fj(h)*Aj(h) ----!
          do j=1,reflex%nref
             aa(:,j)= afp(:)*th(:,j)*ajh(:,j)
          end do

          !---- Final Sum ----!
          do i=1,reflex%Nref
             a=sum(aa(:,i))
             reflex%ref(i)%Fc=abs(a)
             reflex%ref(i)%Phase = 90.0_cp - 90.0_cp * sign(1.0_cp,a)
             reflex%ref(i)%A=a
             reflex%ref(i)%B=0.0
          end do

       else       !Calculation for non-centrosymmetric structures
          !---- Fj(h)*Bj(h) ----!
          !---- Fj(h)*Aj(h) ----!
          do j=1,reflex%nref
             aa(:,j)= afp(:)*th(:,j)*ajh(:,j)
             bb(:,j)= afp(:)*th(:,j)*bjh(:,j)
          end do

          !---- Final Sum ----!
          do i=1,reflex%Nref
             a=sum(aa(:,i))
             b=sum(bb(:,i))
             reflex%ref(i)%Fc=sqrt(a*a+b*b)
             ph = atan2d(b,a)
             if (ph < 0.0) ph=ph+360.0
             reflex%ref(i)%Phase = ph
             reflex%ref(i)%A=a
             reflex%ref(i)%B=b
          end do
       end if

       return
    End Subroutine Sum_AB_NeutNuc

    !!----
    !!---- Subroutine Write_Structure_Factors(lun,Reflex,Mode)
    !!----    integer,                            intent(in) :: lun
    !!----    type(reflection_list_type),         intent(in) :: Reflex
    !!----    Character(len=*), optional,         intent(in) :: Mode
    !!----
    !!----    Writes in logical unit=lun the list of structure factors
    !!----    contained in the array hkl
    !!----
    !!---- Update: February - 2005
    !!
    Subroutine Write_Structure_Factors(lun,Reflex,Mode)
       !---- Argument ----!
       integer,                            intent(in) :: lun
       type(reflection_list_type),         intent(in) :: Reflex
       Character(len=*), optional,         intent(in) :: Mode
       !---- Local Variables ----!
       integer :: i

       If(present(mode)) then
         Select Case (mode(1:3))
           Case("NUC","nuc")
             write(unit=lun,fmt="(/,/,a)") "    LIST OF REFLECTIONS AND STRUCTURE FACTORS(NEUTRONS)"
             write(unit=lun,fmt="(a)")     "    ==================================================="
           Case("ELE","ele")
             write(unit=lun,fmt="(/,/,a)") "    LIST OF REFLECTIONS AND STRUCTURE FACTORS(ELECTRONS)"
             write(unit=lun,fmt="(a)")     "    ===================================================="
           Case default
             write(unit=lun,fmt="(/,/,a)") "    LIST OF REFLECTIONS AND STRUCTURE FACTORS(X-RAYS)"
             write(unit=lun,fmt="(a)")     "    ================================================="
         End Select
       else
         write(unit=lun,fmt="(a)")   "    LIST OF REFLECTIONS AND STRUCTURE FACTORS(X-RAYS)"
         write(unit=lun,fmt="(a)")   "    ================================================="
       end if

       write(unit=lun,fmt="(/,a,/)") &
 "   H   K   L   Mult    SinTh/Lda       dspc          |Fc|         Phase          F-Real        F-Imag       |Fc|^2      Num"
       do i=1,reflex%Nref
             write(unit=lun,fmt="(3i4,i5,6f14.5,f14.3,i8)") reflex%ref(i)%h, reflex%ref(i)%mult, &
                                 reflex%ref(i)%S,0.5/reflex%ref(i)%S, reflex%ref(i)%Fc, reflex%ref(i)%Phase,   &
                                 reflex%ref(i)%a, reflex%ref(i)%b, reflex%ref(i)%Fc*reflex%ref(i)%Fc,i
       end do
       return
    End Subroutine Write_Structure_Factors

 End Module CFML_Structure_Factors
!
!   cif2hkl: convert a CIF or CFL crystal structure file into a PowderN reflection list.
!
!   cif2hkl 1.1 (18 Dec 2012) by Farhi E. [farhi@ill.fr] using crysFML <http://forge.ill.fr/projects/crysfml>
!   Copyright (C) 2009 Institut Laue Langevin, EUPL license.
!   This is free software; see the source for copying conditions.
!   There is NO warranty; not even for MERCHANTABILITY or FITNESS
!   FOR A PARTICULAR PURPOSE.
!
! Usage: ./cif2hkl [options][-o outfile] file1 file2 ...
! Action: Read a CIF/CFL/SHX/PCR crystallographic description
!         and generates a HKL F^2 reflection list.
! Input:
!   file1...          Input file in CIF, PCR, CFL, SHX, INS, RES format.
!                       The file format is determined from its extension
!                         .CIF           Crystallographic Information File
!                         .PCR/.CFL      FullProf file
!                         .SHX/.INS/.RES ShelX file
! Output:
!   a file with readable header, and reflection list with columns
!     [ H K L Multiplicity Sin(Theta/Lambda) d_spacing |F|^2 ]
! Options:
! --help     or -h    Show this help
! --version  or -v    Display program version
! --out FILE          Specify the name of the next output file.
!    -o FILE            Default is to add .hkl to the initial file name.
! --lambda LAMBDA     Set the incoming probe wavelength [Angs].
!    -l    LAMBDA       Default is 0.5
! --powder   or -p    Generate a list of unique HKL reflections (for powders). Default.
! --xtal     or -x    Generate a list of all HKL reflections (for single crystals).
! --verbose           Display processing details.
! --no-outout-files   Just read the CIF/CFL/ShelX file (for checking).
! Example: ./cif2hkl -o CaF2.laz CaF2.cfl

! Compile with:
!   gfortran -O2 CFML_GlobalDeps_Linux.f90 CFML_Math_Gen.f90 CFML_String_Util_gf.f90 CFML_Math_3D.f90 CFML_Sym_Table.f90 CFML_Chem_Scatt.f90 CFML_Symmetry.f90 CFML_Cryst_Types.f90 CFML_Reflct_Util.f90 CFML_Atom_Mod.f90 CFML_Geom_Calc.f90 CFML_Molecules.f90 CFML_Form_CIF.f90 CFML_Sfac.f90 -o cif2hkl cif2hkl.F90 -lm
!   rm *.mod
!   ./cif2hkl ../CIF/CaF2.cfl
!
! Create Matlab Mex with:
!     mex -c -O cif2hkl.F90
!     mex -O cif2hkl_mex.c cif2hkl.o -o cif2hkl -lgfortran

! ==============================================================================

! cif2hkl is available under the EUPL license (see below). It uses CrysFML which
! is a LGPL library. In agreement with the Intergovernmental Convention of the
! ILL, this software cannot be used in military applications.

! ==============================================================================

!		   European Union Public Licence
!		            V. 1.1
!		EUPL (c) the European Community 2007

!This European Union Public Licence (the “EUPL”) applies to the Work or Software
!(as defined below) which is provided under the terms of this Licence. Any use of the
!Work, other than as authorised under this Licence is prohibited (to the extent such use
!is covered by a right of the copyright holder of the Work).

!The Original Work is provided under the terms of this Licence when the Licensor (as
!defined below) has placed the following notice immediately following the copyright
!notice for the Original Work:

!                          Licensed under the EUPL V.1.1

!or has expressed by any other mean his willingness to license under the EUPL.

!1. Definitions

!In this Licence, the following terms have the following meaning:

!- The Licence: this Licence.

!- The Original Work or the Software: the software distributed and/or communicated
!by the Licensor under this Licence, available as Source Code and also as Executable
!Code as the case may be.

!- Derivative Works: the works or software that could be created by the Licensee,
!based upon the Original Work or modifications thereof. This Licence does not define
!the extent of modification or dependence on the Original Work required in order to
!classify a work as a Derivative Work; this extent is determined by copyright law
!applicable in the country mentioned in Article 15.

!- The Work: the Original Work and/or its Derivative Works.

!- The Source Code: the human-readable form of the Work which is the most
!convenient for people to study and modify.

!- The Executable Code: any code which has generally been compiled and which is
!meant to be interpreted by a computer as a program.

!- The Licensor: the natural or legal person that distributes and/or communicates the
!Work under the Licence.

!- Contributor(s): any natural or legal person who modifies the Work under the
!Licence, or otherwise contributes to the creation of a Derivative Work.

!- The Licensee or “You”: any natural or legal person who makes any usage of the
!Software under the terms of the Licence.

!- Distribution and/or Communication: any act of selling, giving, lending, renting,
!distributing, communicating, transmitting, or otherwise making available, on-line or
!off-line, copies of the Work or providing access to its essential functionalities at the
!disposal of any other natural or legal person.

!2. Scope of the rights granted by the Licence

!The Licensor hereby grants You a world-wide, royalty-free, non-exclusive, sublicensable
!licence to do the following, for the duration of copyright vested in the
!Original Work:

!- use the Work in any circumstance and for all usage,
!- reproduce the Work,
!- modify the Original Work, and make Derivative Works based upon the Work,
!- communicate to the public, including the right to make available or display the
!Work or copies thereof to the public and perform publicly, as the case may be,
!the Work,
!- distribute the Work or copies thereof,
!- lend and rent the Work or copies thereof,
!- sub-license rights in the Work or copies thereof.

!Those rights can be exercised on any media, supports and formats, whether now
!known or later invented, as far as the applicable law permits so.

!In the countries where moral rights apply, the Licensor waives his right to exercise his
!moral right to the extent allowed by law in order to make effective the licence of the
!economic rights here above listed.

!The Licensor grants to the Licensee royalty-free, non exclusive usage rights to any
!patents held by the Licensor, to the extent necessary to make use of the rights granted
!on the Work under this Licence.

!3. Communication of the Source Code

!The Licensor may provide the Work either in its Source Code form, or as Executable
!Code. If the Work is provided as Executable Code, the Licensor provides in addition a
!machine-readable copy of the Source Code of the Work along with each copy of the
!Work that the Licensor distributes or indicates, in a notice following the copyright
!notice attached to the Work, a repository where the Source Code is easily and freely
!accessible for as long as the Licensor continues to distribute and/or communicate the
!Work.

!4. Limitations on copyright

!Nothing in this Licence is intended to deprive the Licensee of the benefits from any
!exception or limitation to the exclusive rights of the rights owners in the Original
!Work or Software, of the exhaustion of those rights or of other applicable limitations
!thereto.

!5. Obligations of the Licensee

!The grant of the rights mentioned above is subject to some restrictions and obligations
!imposed on the Licensee. Those obligations are the following:
!Attribution right: the Licensee shall keep intact all copyright, patent or trademarks
!notices and all notices that refer to the Licence and to the disclaimer of warranties.

!The Licensee must include a copy of such notices and a copy of the Licence with
!every copy of the Work he/she distributes and/or communicates. The Licensee must
!cause any Derivative Work to carry prominent notices stating that the Work has been
!modified and the date of modification.

!Copyleft clause: If the Licensee distributes and/or communicates copies of the
!Original Works or Derivative Works based upon the Original Work, this Distribution
!and/or Communication will be done under the terms of this Licence or of a later
!version of this Licence unless the Original Work is expressly distributed only under
!this version of the Licence. The Licensee (becoming Licensor) cannot offer or impose
!any additional terms or conditions on the Work or Derivative Work that alter or
!restrict the terms of the Licence.

!Compatibility clause: If the Licensee Distributes and/or Communicates Derivative
!Works or copies thereof based upon both the Original Work and another work
!licensed under a Compatible Licence, this Distribution and/or Communication can be
!done under the terms of this Compatible Licence. For the sake of this clause,
!“Compatible Licence” refers to the licences listed in the appendix attached to this
!Licence. Should the Licensee’s obligations under the Compatible Licence conflict
!with his/her obligations under this Licence, the obligations of the Compatible Licence
!shall prevail.

!Provision of Source Code: When distributing and/or communicating copies of the
!Work, the Licensee will provide a machine-readable copy of the Source Code or
!indicate a repository where this Source will be easily and freely available for as long
!as the Licensee continues to distribute and/or communicate the Work.

!Legal Protection: This Licence does not grant permission to use the trade names,
!trademarks, service marks, or names of the Licensor, except as required for
!reasonable and customary use in describing the origin of the Work and reproducing
!the content of the copyright notice.

!6. Chain of Authorship

!The original Licensor warrants that the copyright in the Original Work granted
!hereunder is owned by him/her or licensed to him/her and that he/she has the power
!and authority to grant the Licence.

!Each Contributor warrants that the copyright in the modifications he/she brings to the
!Work are owned by him/her or licensed to him/her and that he/she has the power and
!authority to grant the Licence.

!Each time You accept the Licence, the original Licensor and subsequent Contributors
!grant You a licence to their contributions to the Work, under the terms of this
!Licence.

!7. Disclaimer of Warranty

!The Work is a work in progress, which is continuously improved by numerous
!contributors. It is not a finished work and may therefore contain defects or “bugs”
!inherent to this type of software development.

!For the above reason, the Work is provided under the Licence on an “as is” basis and
!without warranties of any kind concerning the Work, including without limitation
!merchantability, fitness for a particular purpose, absence of defects or errors,
!accuracy, non-infringement of intellectual property rights other than copyright as
!stated in Article 6 of this Licence.

!This disclaimer of warranty is an essential part of the Licence and a condition for the
!grant of any rights to the Work.

!8. Disclaimer of Liability

!Except in the cases of wilful misconduct or damages directly caused to natural
!persons, the Licensor will in no event be liable for any direct or indirect, material or
!moral, damages of any kind, arising out of the Licence or of the use of the Work,
!including without limitation, damages for loss of goodwill, work stoppage, computer
!failure or malfunction, loss of data or any commercial damage, even if the Licensor
!has been advised of the possibility of such damage. However, the Licensor will be
!liable under statutory product liability laws as far such laws apply to the Work.

!9. Additional agreements

!While distributing the Original Work or Derivative Works, You may choose to
!conclude an additional agreement to offer, and charge a fee for, acceptance of support,
!warranty, indemnity, or other liability obligations and/or services consistent with this
!Licence. However, in accepting such obligations, You may act only on your own
!behalf and on your sole responsibility, not on behalf of the original Licensor or any
!other Contributor, and only if You agree to indemnify, defend, and hold each
!Contributor harmless for any liability incurred by, or claims asserted against such
!Contributor by the fact You have accepted any such warranty or additional liability.

!10. Acceptance of the Licence

!The provisions of this Licence can be accepted by clicking on an icon “I agree”
!placed under the bottom of a window displaying the text of this Licence or by
!affirming consent in any other similar way, in accordance with the rules of applicable
!law. Clicking on that icon indicates your clear and irrevocable acceptance of this
!Licence and all of its terms and conditions.

!Similarly, you irrevocably accept this Licence and all of its terms and conditions by
!exercising any rights granted to You by Article 2 of this Licence, such as the use of
!the Work, the creation by You of a Derivative Work or the Distribution and/or
!Communication by You of the Work or copies thereof.

!11. Information to the public

!In case of any Distribution and/or Communication of the Work by means of electronic
!communication by You (for example, by offering to download the Work from a
!remote location) the distribution channel or media (for example, a website) must at
!least provide to the public the information requested by the applicable law regarding
!the Licensor, the Licence and the way it may be accessible, concluded, stored and
!reproduced by the Licensee.

!12. Termination of the Licence

!The Licence and the rights granted hereunder will terminate automatically upon any
!breach by the Licensee of the terms of the Licence.
!Such a termination will not terminate the licences of any person who has received the
!Work from the Licensee under the Licence, provided such persons remain in full
!compliance with the Licence.

!13. Miscellaneous

!Without prejudice of Article 9 above, the Licence represents the complete agreement
!between the Parties as to the Work licensed hereunder.

!If any provision of the Licence is invalid or unenforceable under applicable law, this
!will not affect the validity or enforceability of the Licence as a whole. Such provision
!will be construed and/or reformed so as necessary to make it valid and enforceable.
!The European Commission may publish other linguistic versions and/or new versions
!of this Licence, so far this is required and reasonable, without reducing the scope of
!the rights granted by the Licence. New versions of the Licence will be published with
!a unique version number.

!All linguistic versions of this Licence, approved by the European Commission, have
!identical value. Parties can take advantage of the linguistic version of their choice.

!14. Jurisdiction

!Any litigation resulting from the interpretation of this License, arising between the
!European Commission, as a Licensor, and any Licensee, will be subject to the
!jurisdiction of the Court of Justice of the European Communities, as laid down in
!article 238 of the Treaty establishing the European Community.
!Any litigation arising between Parties, other than the European Commission, and
!resulting from the interpretation of this License, will be subject to the exclusive
!jurisdiction of the competent court where the Licensor resides or conducts its primary
!business.

!15. Applicable Law

!This Licence shall be governed by the law of the European Union country where the
!Licensor resides or has his registered office.

!This licence shall be governed by the Belgian law if:

!- a litigation arises between the European Commission, as a Licensor, and any
!Licensee;
!- the Licensor, other than the European Commission, has no residence or
!registered office inside a European Union country.

!===

!Appendix

!“Compatible Licences” according to article 5 EUPL are:

!- GNU General Public License (GNU GPL) v. 2
!- Open Software License (OSL) v. 2.1, v. 3.0
!- Common Public License v. 1.0
!- Eclipse Public License v. 1.0
!- Cecill v. 2.0

! ==============================================================================



! ==============================================================================
! Modules needed to compile this program:
! Module CFML_GlobalDeps                     CFML_GlobalDeps_Linux.f90
! Module CFML_Math_General                   CFML_Math_Gen.f90
! Module CFML_String_Utilities               CFML_String_Util_gf.f90
! Module CFML_Math_3D                        CFML_Math_3D.f90
! Module CFML_Symmetry_Tables                CFML_Sym_Table.f90
! Module CFML_Scattering_Chemical_Tables     CFML_Chem_Scatt.f90
! Module CFML_Crystallographic_Symmetry      CFML_Symmetry.f90
! Module CFML_Crystal_Metrics                CFML_Cryst_Types.f90
! Module CFML_Reflections_Utilities          CFML_Reflct_Util.f90
! Module CFML_Atom_TypeDef                   CFML_Atom_Mod.f90
! Module CFML_Structure_Factors              CFML_Sfac.f90
! Module CFML_Geometry_Calc                  CFML_Geom_Calc.f90
! Module CFML_Molecular_Crystals             CFML_Molecules.f90
! Module CFML_IO_Formats                     CFML_Form_CIF.f90
!
! CFML_GlobalDeps_Linux.f90 CFML_Math_Gen.f90 CFML_String_Util_gf.f90 CFML_Math_3D.f90 CFML_Sym_Table.f90 CFML_Chem_Scatt.f90 CFML_Symmetry.f90 CFML_Cryst_Types.f90 CFML_Reflct_Util.f90 CFML_Atom_Mod.f90 CFML_Geom_Calc.f90 CFML_Molecules.f90 CFML_Form_CIF.f90 CFML_Sfac.f90


! ==============================================================================
! routine to sort HKL reflections with decreasing d-spacing
subroutine sort_d(hkl)
  use CFML_Reflections_Utilities,      only: Reflection_List_Type, Reflection_Type
  use CFML_Math_General,               only: sort
  use CFML_GlobalDeps,                 only: cp

  type (Reflection_List_Type), INTENT(in out) :: hkl

  real(kind=cp),  dimension(hkl%Nref) :: S
  integer,        dimension(hkl%Nref) :: ind
  type (Reflection_Type),  dimension(hkl%Nref) :: ref

  integer :: i
  type (Reflection_Type) :: temp

  do i=1,hkl%Nref
    S(i)   = hkl%ref(i)%S
    ref(i) = hkl%ref(i)
  end do
  call sort(S, hkl%Nref, ind)
  ! now swap reflections: hkl%ref(ind(i))%S is in ascending order
  do i=1,hkl%Nref
    hkl%ref(i) = ref(ind(i))
  end do

end subroutine sort_d


! ==============================================================================
! CFML_cif2hkl: convert 'file_in' (CIF/CFL) into a reflection list 'file_out' for PowderN
! INPUT:
!   file_in:   the CIF/CFL file name (string)
!   lambda:    neutron wavelength, which limits the number of reflections ;
!              use e.g. 1.0 (float*8)
!   mode:      "p" or "x" for powder and Xtal handling resp.
!   verbose:   0 or 1 for silent and verbose display resp.
! OUPUT:
!   file_out: the reflection list file name (string)
!   message:  a message to display (string)
subroutine CFML_cif2hkl(file_in, file_out, lambda, powxtal, verbose, message, mode)

  use CFML_Crystallographic_Symmetry,  only: Space_Group_Type
  use CFML_Crystal_Metrics,            only: Crystal_Cell_Type
  use CFML_Atom_TypeDef,               only: Atom_List_Type
  use CFML_IO_Formats,                 only: Readn_Set_Xtal_Structure, File_List_Type
  use CFML_Reflections_Utilities,      only: Reflection_List_Type, Hkl_Uni, Hkl_Gen_SXtal,Get_MaxNumRef,WRITE_REFLIST_INFO
  use CFML_Structure_Factors,          only: Structure_Factors,Init_Structure_Factors,Calc_StrFactor
  use CFML_String_Utilities,           only: L_case
  use CFML_GlobalDeps,                 only: pi, dp

  implicit none

  ! subroutine I/O
  character(len=1024)         :: file_in, file_out     ! Name of the input/output file
  real*8                      :: lambda                ! probe wavelength
  character(len=1024)         :: powxtal               ! 'p' or 'x' or '-'
  integer                     :: verbose               ! 0 or 1 for verbose mode
  character*4096              :: message
  character(len=1024)         :: mode                  ! NUC,XRA,MAG,ELE

  ! local variables
  type (File_List_Type)       :: fich_cfl
  type (Space_Group_Type)     :: SpG
  type (Crystal_Cell_Type)    :: Cell
  type (Atom_List_Type)       :: A
  type (Reflection_List_Type) :: hkl
  real                        :: stlmax
  integer                     :: lun=1, MaxNumRef, I, Y
  character(len=1024)         :: ext                   ! file name extension

  integer, parameter                             :: n_elements=423
  character (Len = 8), dimension(n_elements)     :: element
  real ( KIND = dp ), dimension(n_elements)      :: Bcoh, Binc, weight, Sabs
  real                                           :: sigma_coh, sigma_inc, sigma_abs, mass, F

  character(len=1024)                            :: formula
  character(len=4096)                            :: s1,s2,s3  ! temporary string for concatenation
  integer*4, dimension(3)                        :: today, now
  character*2   eol

  integer dot_pos
  integer sep_pos
  integer end_pos

  !values to test CFML_cif2hkl(program)
  !file_in  = 'Na2Ca3Al2F14.cfl'
  !file_out = 'Na2Ca3Al2F14_out'
  !lambda   = 2.4105
  if (lambda > 0) then
    stlmax = 1/lambda
  else
    stlmax= 1.0
  end if

  eol=char(13)//char(10)
  message = ''

  ! set the element name, cross sections and weight
  ! list of isotopes
  element   = (/'H    ','D    ','2H   ','3H   ','He   ','3He  ','4He  ','Li   ','6Li  ','7Li  ','Be   ',&
  '9Be  ','B    ','10B  ','11B  ','C    ','12C  ','13C  ','14C  ','N    ','14N  ','15N  ','O    ','16O  ',&
  '17O  ','18O  ','F    ','19F  ','Ne   ','20Ne ','21Ne ','22Ne ','Na   ','23Na ','Mg   ','24Mg ','25Mg ',&
  '26Mg ','Al   ','27Al ','Si   ','28Si ','29Si ','30Si ','P    ','31P  ','S    ','32S  ','33S  ','34S  ',&
  '36S  ','Cl   ','35Cl ','37Cl ','Ar   ','36Ar ','38Ar ','40Ar ','K    ','39K  ','40K  ','41K  ','Ca   ',&
  '40Ca ','42Ca ','43Ca ','44Ca ','46Ca ','48Ca ','Sc   ','45Sc ','Ti   ','46Ti ','47Ti ','48Ti ','49Ti ',&
  '50Ti ','V    ','50V  ','51V  ','Cr   ','50Cr ','52Cr ','53Cr ','54Cr ','Mn   ','55Mn ','Fe   ','54Fe ',&
  '56Fe ','57Fe ','58Fe ','Co   ','59Co ','Ni   ','58Ni ','60Ni ','61Ni ','62Ni ','64Ni ','Cu   ','63Cu ',&
  '65Cu ','Zn   ','64Zn ','66Zn ','67Zn ','68Zn ','70Zn ','Ga   ','69Ga ','71Ga ','Ge   ','70Ge ','72Ge ',&
  '73Ge ','74Ge ','76Ge ','As   ','75As ','Se   ','74Se ','76Se ','77Se ','78Se ','80Se ','82Se ','Br   ',&
  '79Br ','81Br ','Kr   ','78Kr ','80Kr ','82Kr ','83Kr ','84Kr ','86Kr ','Rb   ','85Rb ','87Rb ','Sr   ',&
  '84Sr ','86Sr ','87Sr ','88Sr ','Y    ','89Y  ','Zr   ','90Zr ','91Zr ','92Zr ','94Zr ','96Zr ','Nb   ',&
  '93Nb ','Mo   ','92Mo ','94Mo ','95Mo ','96Mo ','97Mo ','98Mo ','100Mo','Tc   ','99Tc ','Ru   ','96Ru ',&
  '98Ru ','99Ru ','100Ru','101Ru','102Ru','104Ru','Rh   ','103Rh','Pd   ','102Pd','104Pd','105Pd','106Pd',&
  '108Pd','110Pd','Ag   ','107Ag','109Ag','Cd   ','106Cd','108Cd','110Cd','111Cd','112Cd','113Cd','114Cd',&
  '116Cd','In   ','113In','115In','Sn   ','112Sn','114Sn','115Sn','116Sn','117Sn','118Sn','119Sn','120Sn',&
  '122Sn','124Sn','Sb   ','121Sb','123Sb','Te   ','120Te','122Te','123Te','124Te','125Te','126Te','128Te',&
  '130Te','I    ','127I ','Xe   ','124Xe','126Xe','128Xe','129Xe','130Xe','131Xe','132Xe','134Xe','136Xe',&
  'Cs   ','133Cs','Ba   ','130Ba','132Ba','134Ba','135Ba','136Ba','137Ba','138Ba','La   ','138La','139La',&
  'Ce   ','136Ce','138Ce','140Ce','142Ce','Pr   ','141Pr','Nd   ','142Nd','143Nd','144Nd','145Nd','146Nd',&
  '148Nd','150Nd','Pm   ','147Pm','Sm   ','144Sm','147Sm','148Sm','149Sm','150Sm','152Sm','154Sm','Eu   ',&
  '151Eu','153Eu','Gd   ','152Gd','154Gd','155Gd','156Gd','157Gd','158Gd','160Gd','Tb   ','159Tb','Dy   ',&
  '156Dy','158Dy','160Dy','161Dy','162Dy','163Dy','164Dy','Ho   ','165Ho','Er   ','162Er','164Er','166Er',&
  '167Er','168Er','170Er','Tm   ','169Tm','Yb   ','168Yb','170Yb','171Yb','172Yb','173Yb','174Yb','176Yb',&
  'Lu   ','175Lu','176Lu','Hf   ','174Hf','176Hf','177Hf','178Hf','179Hf','180Hf','Ta   ','180Ta','181Ta',&
  'W    ','180W ','182W ','183W ','184W ','186W ','Re   ','185Re','187Re','Os   ','184Os','186Os','187Os',&
  '188Os','189Os','190Os','192Os','Ir   ','191Ir','193Ir','Pt   ','190Pt','192Pt','194Pt','195Pt','196Pt',&
  '198Pt','Au   ','196Au','Hg   ','196Hg','198Hg','199Hg','200Hg','201Hg','202Hg','204Hg','Tl   ','203Tl',&
  '205Tl','Pb   ','204Pb','206Pb','207Pb','208Pb','Bi   ','209Bi','Po   ','210Po','At   ','Rn   ','222Rn',&
  'Fr   ','Ra   ','226Ra','Ac   ','Th   ','232Th','Pa   ','231Pa','U    ','233U ','234U ','235U ','238U ',&
  'Np   ','237Np','Pu   ','238Pu','239Pu','240Pu','242Pu','Am   ','243Am','Cm   ','244Cm','246Cm','248Cm',&
  'Bk   ','Cf   ','Es   ','Fm   ','Md   ','No   ','Lr   ','Rf   ','Db   ','Sg   ','Bh   ','Hs   ','Mt   ',&
  'Ds   ','Rg   ','Cn   ','Uut  ','Uuq  ','Uup  ','Uuh  ','Uus  ','Uuo  '/)
  ! list of coherent lengths
  Bcoh      = (/-0.00003739, -0.00003741, 0.00006671, 0.00004792, &
   0.00003260, 0.00000000, 0.00003260, -0.00001900, 0.00000000, -0.00002220,&
    0.00007790, 0.00007790, 0.00000000	, 0.00000000, 0.00006650,&
    0.00006646	, 0.00006651, 0.00006190, 0.00000000, 0.00009360	,&
    0.00009370, 0.00006440, 0.00005803	, 0.00005803, 0.00005780,&
    0.00005840, 0.00005654	, 0.00005654, 0.00004566, 0.00004631,&
    0.00006660, 0.00003870, 0.00003630, 0.00003630, 0.00005375, 0.00005660,&
    0.00003620, 0.00004890, 0.00003449, 0.00003449, 0.00004149, 0.00004107,&
    0.00004700, 0.00004580, 0.00005130	, 0.00005130, 0.00002847	,&
    0.00002804, 0.00004740, 0.00003480, 0.00003000, 0.00009577, 0.00011650,&
    0.00003080, 0.00001909, 0.00024900, 0.00003500, 0.00001830, 0.00003670	, 0.00003740, 0.00003000,&
    0.00002690, 0.00004700, 0.00004800, 0.00003360, -0.00001560, 0.00001420, 0.00003600, 0.00000390,&
    0.00012290, 0.00012290, -0.00003438, 0.00004930, 0.00003630, -0.00006080, 0.00001040, 0.00006180,&
    -0.00000382, 0.00007600, -0.00000402, 0.00003635, -0.00004500, 0.00004920, -0.00004200, 0.00004550,&
    -0.00003730, -0.00003730, 0.00009450, 0.00004200, 0.00009940, 0.00002300, 0.00015000, 0.00002490,&
    0.00002490, 0.00010300, 0.00014400, 0.00002800, 0.00007600, -0.00008700, -0.00000370, 0.00007718,&
    0.00006430, 0.00010610, 0.00005680, 0.00005220, 0.00005970, 0.00007560, 0.00006030, 0.00006000, 0.00007288,&
    0.00007880, 0.00006400, 0.00008185, 0.00010000, 0.00008510, 0.00005020, 0.00007580, 0.00008200, 0.00006580,&
    0.00006580, 0.00007970, 0.00000800, 0.00012200, 0.00008250, 0.00008240, 0.00007480, 0.00006340, 0.00006795,&
    0.00006800, 0.00006790, 0.00007810, 0.00000000, 0.00000000, 0.00000000, 0.00000000, 0.00000000, 0.00008100,&
    0.00007090, 0.00007030, 0.00007230, 0.00007020, 0.00007000, 0.00005670, 0.00007400, 0.00007150,&
    0.00007750	, 0.00007750, 0.00007160, 0.00006400, 0.00008700, 0.00007400, 0.00008200, 0.00005500,&
    0.00007054, 0.00007054, 0.00006715, 0.00006910, 0.00006800, 0.00006910, 0.00006200, 0.00007240, 0.00006580,&
    0.00006730, 0.00006800, 0.00006800, 0.00007030, 0.00000000, 0.00000000, 0.00000000, 0.00000000, 0.00000000,&
    0.00000000, 0.00000000, 0.00005880, 0.00005880, 0.00005910, 0.00007700, 0.00007700, 0.00005500, 0.00006400,&
    0.00004100, 0.00007700, 0.00005922, 0.00007555, 0.00004165, 0.00000000, 0.00005000, 0.00005400, 0.00005900,&
    0.00006500, 0.00006400, 0.00000000, 0.00007500, 0.00006300, 0.00000000, 0.00005390, 0.00000000, 0.00006225,&
    0.00006000, 0.00006200, 0.00006000, 0.00005930, 0.00006480, 0.00006070, 0.00006120, 0.00006490, 0.00005740,&
    0.00005970, 0.00005570, 0.00005710, 0.00005380, 0.00005800, 0.00005300, 0.00003800, 0.00000000, 0.00007960,&
    0.00005020, 0.00005560, 0.00005890, 0.00006020, 0.00005280	, 0.00005280, 0.00004920, 0.00000000,&
    0.00000000, 0.00000000, 0.00000000, 0.00000000, 0.00000000, 0.00000000, 0.00000000, 0.00000000, 0.00005420,&
    0.00005420, 0.00005070, -0.00003600, 0.00007800, 0.00005700, 0.00004670, 0.00004910, 0.00006830,&
    0.00004840, 0.00008240, 0.00008000, 0.00008240, 0.00004840, 0.00005800, 0.00006700, 0.00004840, 0.00004750,&
    0.00004580, 0.00004580, 0.00007690, 0.00007700, 0.00014000, 0.00002800, 0.00014000, 0.00008700, 0.00005700,&
    0.00005300, 0.00012600, 0.00012600, 0.00000000, -0.00003000, 0.00014000, -0.00003000, 0.00000000,&
    0.00014000, -0.00005000, 0.00009300, 0.00000000, 0.00000000, 0.00008220, 0.00000000, 0.00010000,&
    0.00010000, 0.00000000, 0.00006300, 0.00000000, 0.00009000, 0.00009150, 0.00007380, 0.00007380, 0.00000000,&
    0.00006100, 0.00006000, 0.00006700, 0.00010300, -0.00001400, 0.00005000, 0.00000000, 0.00008010,&
    0.00008010, 0.00007790, 0.00008800, 0.00008200, 0.00010600, 0.00003000, 0.00007400, 0.00009600, 0.00007070,&
    0.00007070, 0.00012430, 0.00000000, 0.00006770, 0.00009660, 0.00009430, 0.00009560, 0.00019300, 0.00008720,&
    0.00007210, 0.00007240, 0.00000000, 0.00007700, 0.00010900, 0.00006610, 0.00000800, 0.00005900, 0.00007460,&
    0.00013200, 0.00006910, 0.00007000, 0.00006910, 0.00004860	, 0.00005000, 0.00006970, 0.00006530,&
    0.00007480, -0.00000720, 0.00009200, 0.00009000, 0.00009300, 0.00010700, 0.00010000, 0.00011600,&
    0.00010000, 0.00007600, 0.00010700, 0.00011000, 0.00011500, 0.00010600, 0.00000000, 0.00000000, 0.00009600,&
    0.00009000, 0.00009900, 0.00010550, 0.00008830, 0.00009890, 0.00007800, 0.00007630, 0.00007630, 0.00012692,&
    0.00030300, 0.00000000, 0.00016900, 0.00000000, 0.00000000, 0.00000000, 0.00000000, 0.00008776, 0.00006990,&
    0.00009520, 0.00009405, 0.00009900, 0.00009220, 0.00009280, 0.00009500, 0.00008532, 0.00008532, 0.00000000,&
    0.00000000, 0.00000000, 0.00000000, 0.00000000, 0.00000000, 0.00010000, 0.00010000, 0.00000000, 0.00010310,&
    0.00010310, 0.00009100, 0.00009100, 0.00008417	, 0.00010100, 0.00012400, 0.00010470, 0.00008402,&
    0.00010550, 0.00010550, 0.00000000, 0.00014100, 0.00007700, 0.00003500, 0.00008100, 0.00008300, 0.00008300,&
    0.00000000, 0.00009500, 0.00009300, 0.00007700, 0.00000000, 0.00000000, 0.00000000, 0.00000000, 0.00000000,&
    0.00000000, 0.00000000, 0.00000000, 0.00000000, 0.00000000, 0.00000000, 0.00000000, 0.00000000, 0.00000000,&
    0.00000000, 0.00000000, 0.00000000, 0.00000000, 0.00000000, 0.00000000, 0.00000000, 0.00000000 /)
  ! list of incoherent lengths
  Binc      = (/0.00025272	, 0.00025274, 0.00004040	, -0.00001040, 0.00000000	, 0.00000000, 0.00000000,&
    2.70576E-05, 0.00000000, -0.00002490, 0.00000120	, 0.00000120, 3.67807E-05, 0.00000000, -0.00001300,&
    8.92062E-07, 0.00000000, -0.00000520, 0.00000000, 1.99471E-05, 0.00002000, -0.00000020, 7.97885E-07,&
    0.00000000, 0.00000180, 0.00000000, -0.00000082	, -0.00000082, 2.52313E-06, 0.00000000, 0.00000600,&
    0.00000000, 0.00003590	, 0.00003590, 7.97885E-06, 0.00000000, 0.00001480, 0.00000000, 0.00000256	,&
    0.00000256, 1.78412E-06, 0.00000000, 0.00000090, 0.00000000, 0.00000200	, 0.00000200, 2.36017E-06,&
    0.00000000, 0.00001500, 0.00000000, 0.00000000, 6.49431E-05, 0.00006100, 0.00000100, 1.33809E-05,&
    0.00000000, 0.00000000, 0.00000000, 1.46581E-05, 0.00001400, 1.99471E-05, 0.00001500, 6.30783E-06,&
    0.00000000, 0.00000000, 1.99471E-05, 0.00000000, 0.00000000, 0.00000000, -0.00006000, -0.00006000,&
    4.77899E-05, 0.00000000, -0.00003500, 0.00000000, 0.00005100, 0.00000000, 6.35809E-05, 1.99471E-05,&
    0.00006350, 3.81611E-05, 0.00000000, 0.00000000, 0.00006870, 0.00000000, 0.00001790, 0.00001790,&
    1.78412E-05, 0.00000000, 0.00000000, 1.5451E-05, 0.00000000, -0.00006200, -0.00006200, 6.43275E-05,&
    0.00000000, 0.00000000, 0.00003900, 0.00000000, 0.00000000, 2.09207E-05, 0.00000220, 0.00001790,&
    7.82781E-06, 0.00000000, 0.00000000, -0.00001500, 0.00000000, 0.00000000, 1.12838E-05, -0.00000850,&
    -0.00000820, 1.19683E-05, 0.00000000, 0.00000000, 0.00003400, 0.00000000, 0.00000000, -0.00000690,&
    -0.00000690, 1.59577E-05, 0.00000000, 0.00000000, 0.00000600, 0.00000000, 0.00000000, 0.00000000,&
    8.92062E-06, -0.00001100, 0.00000600, 2.82095E-06, 0.00000000, 0.00000000, 0.00000000, 0.00000000,&
    0.00000000, 0.00000000, 1.99471E-05, 1.99471E-05, 1.99471E-05, 6.90988E-06, 0.00000000, 0.00000000,&
    1.99471E-05, 0.00000000, 0.00001100	, 0.00001100, 3.98942E-06, 0.00000000, -0.00001080, 0.00000000,&
    0.00000000, 0.00000000, -0.00000139, -0.00000139, 5.6419E-06, 0.00000000, 0.00000000, 1.99471E-05,&
    0.00000000, 1.99471E-05, 0.00000000, 0.00000000, 1.99471E-05, 1.99471E-05, 1.78412E-05, 0.00000000,&
    0.00000000, 0.00000000, 0.00000000, 0.00000000, 0.00000000, 0.00000000, 1.5451E-05, 1.5451E-05,&
    8.60273E-06, 0.00000000, 0.00000000, -0.00002600, 0.00000000, 0.00000000, 0.00000000, 2.14837E-05,&
    0.00001000, -0.00001600, 5.24727E-05, 0.00000000, 0.00000000, 0.00000000, 1.5451E-05, 0.00000000,&
    1.5451E-05, 0.00000000, 0.00000000, 2.07296E-05, 0.00000017, -0.00002100, 4.18414E-06, 0.00000000,&
    0.00000000, 1.5451E-05, 0.00000000, 1.5451E-05, 0.00000000, 1.5451E-05, 0.00000000, 0.00000000, 0.00000000,&
    2.36017E-06, -0.00000050, -0.00000100, 8.46284E-06, 0.00000000, 0.00000000, -0.00002040, 0.00000000,&
    -0.00000260, 0.00000000, 0.00000000, 0.00000000, 0.00001580	, 0.00001580, 0.00003040	, 0.00000000,&
    0.00000000, 0.00000000, 0.00000000, 0.00000000, 0.00000000, 0.00000000, 0.00000000, 0.00000000,&
    0.00001290	, 0.00001290, 1.09255E-05, 0.00000000, 0.00000000, 0.00000000, 1.99471E-05, 0.00000000,&
    1.99471E-05, 0.00000000, 2.99871E-05, 1.99471E-05, 0.00003000, 8.92062E-07, 0.00000000, 0.00000000,&
    0.00000000, 0.00000000, -0.00000350, -0.00000350, 8.55636E-05, 0.00000000, 0.00021000, 0.00000000,&
    6.30783E-05, 0.00000000, 0.00000000, 0.00000000, 0.00003200	, 0.00003200, 0.00017617	, 0.00000000,&
    0.00011000, 0.00000000, 0.00000000, 0.00000000, 0.00000000, 0.00000000, 4.46031E-05, 0.00000000,&
    0.00003200, 0.00034664	, 0.00000000, 0.00000000, 0.00000000, 0.00000000, 0.00000000, 0.00000000,&
    0.00000000, -0.00000170, -0.00000170, 0.00020806	, 0.00000000, 0.00000000, 0.00000000, 0.00004900,&
    0.00000000, 0.00001300, 0.00000000, -0.00001700, -0.00001700, 2.95864E-05, 0.00000000, 0.00000000,&
    0.00000000, 0.00001000, 0.00000000, 0.00000000, 0.00000900	, 0.00000900, 5.6419E-05, 0.00000000,&
    0.00000000, -0.00005590, 0.00000000, -0.00005300, 0.00000000, 0.00000000, 2.36017E-05, 0.00002200,&
    0.00000000, 4.54864E-05, 0.00000000, 0.00000000, 0.00000900, 0.00000000, 0.00001060, 0.00000000,&
    2.82095E-06, 1.99471E-05, -0.00000290, 3.60155E-05, 0.00000000, 0.00000000, 1.5451E-05, 0.00000000,&
    0.00000000, 2.67619E-05, 0.00002000, 0.00002800, 1.5451E-05, 0.00000000, 0.00000000, 1.5451E-05,&
    0.00000000, 1.99471E-05, 0.00000000, 0.00000000, 0.00000000	, 0.00000000, 0.00000000, 1.01711E-05,&
    0.00000000, 0.00000000, 0.00000000, -0.00001000, 0.00000000, 0.00000000, -0.00001840, -0.00001840,&
    7.24715E-05, 0.00000000, 0.00000000, 0.00015500, 0.00000000, 0.00000000, 0.00000000, 0.00000000,&
    1.29272E-05, 0.00001060, -0.00000242, 1.5451E-06, 0.00000000, 0.00000000, 0.00000140, 0.00000000,&
    2.58544E-06, 2.58544E-06, 0.00000259	, 0.00000259, 0.00000000	, 0.00000000	, 0.00000000, 0.00000000	,&
    0.00000000	, 0.00000000, 0.00000000	, 0.00000000	, 0.00000000, 8.92062E-06, 8.92062E-06, 1.99471E-06,&
    0.00001000, 0.00000000, 0.00001300, 0.00000000, 1.99471E-05, 1.99471E-05, 0.00000000	, 0.00000000,&
    0.00001300, 0.00000000, 0.00000000, 0.00002000	, 0.00002000, 0.00000000	, 0.00000000, 0.00000000,&
    0.00000000, 0.00000000	, 0.00000000	, 0.00000000	, 0.00000000	, 0.00000000	, 0.00000000	,&
    0.00000000	, 0.00000000	, 0.00000000	, 0.00000000	, 0.00000000	, 0.00000000	, 0.00000000	,&
    0.00000000	, 0.00000000	, 0.00000000	, 0.00000000, 0.00000000, 0.00000000, 0.00000000, 0.00000000,&
    0.00000000/)
  ! list of absorption cross sections
  Sabs = (/0.33260000	, 0.33260000	, 0.00051900	, 0.00000000	, 0.00747000	, 5333.00000000,&
    0.00000000	, 70.50000000, 940.00000000, 0.04540000, 0.00760000	, 0.00760000	, 767.00000000,&
    3835.00000000, 0.00550000, 0.00350000	, 0.00353000	, 0.00137000, 0.00000000	, 1.90000000	, 1.91000000	,&
    0.00002400, 0.00019000	, 0.00010000	, 0.23600000	, 0.00016000	, 0.00960000	, 0.00960000, 0.03900000,&
    0.03600000, 0.67000000, 0.04600000, 0.53000000	, 0.53000000, 0.06300000, 0.05000000, 0.19000000,&
    0.03820000, 0.23100000	, 0.23100000, 0.17100000, 0.17700000, 0.10100000, 0.10700000, 0.17200000	,&
    0.17200000	, 0.53000000	, 0.54000000	, 0.54000000	, 0.22700000	, 0.15000000	, 33.50000000,&
    44.10000000, 0.43300000, 0.67500000, 5.20000000, 0.80000000, 0.66000000, 2.10000000	, 2.10000000	,&
    35.00000000, 1.46000000	, 0.43000000, 0.41000000, 0.68000000, 6.20000000, 0.88000000, 0.74000000,&
    1.09000000, 27.50000000, 27.50000000, 6.09000000, 0.59000000, 1.70000000, 7.84000000, 2.20000000,&
    0.17900000, 5.08000000, 60.00000000, 4.90000000, 3.05000000, 15.80000000, 0.76000000, 18.10000000,&
    0.36000000, 13.30000000, 13.30000000, 2.56000000, 2.25000000, 2.59000000, 2.48000000, 1.28000000,&
    37.18000000, 37.18000000, 4.49000000, 4.60000000, 2.90000000, 2.50000000, 14.50000000, 1.52000000,&
    3.78000000, 4.50000000, 2.17000000, 1.11000000, 0.93000000, 0.62000000, 6.80000000, 1.10000000, 0.09200000,&
    2.75000000, 2.18000000, 3.61000000, 2.20000000, 3.00000000, 0.80000000, 15.10000000, 0.40000000,&
    0.16000000, 4.50000000	, 4.50000000, 11.70000000, 51.80000000, 85.00000000, 42.00000000, 0.43000000,&
    0.61000000, 0.04400000, 6.90000000, 11.00000000, 2.70000000, 25.00000000, 6.40000000, 11.80000000,&
    29.00000000, 185.00000000, 0.11300000, 0.00300000, 0.38000000, 0.48000000, 0.12000000, 1.28000000,&
    0.87000000, 1.04000000, 16.00000000, 0.05800000, 1.28000000	, 1.28000000	, 0.18500000, 0.01100000,&
    1.17000000, 0.22000000, 0.04990000, 0.02290000, 1.15000000	, 1.15000000, 2.48000000	, 0.01900000,&
    0.01500000, 13.10000000, 0.50000000, 2.50000000, 0.12700000, 0.40000000, 20.00000000, 20.00000000,&
    2.56000000, 0.28000000, 8.00000000, 6.90000000, 4.80000000, 3.30000000, 1.17000000, 0.31000000,&
    144.80000000, 144.80000000, 6.90000000, 3.40000000, 0.60000000, 20.00000000, 0.30400000, 8.55000000,&
    0.22600000, 63.30000000, 37.60000000, 91.00000000, 2520.00000000, 1.00000000, 1.10000000, 11.00000000,&
    24.00000000, 2.20000000, 20600.00000000, 0.34000000, 0.07500000, 193.80000000, 12.00000000, 202.00000000,&
    0.62600000, 1.00000000, 0.11400000, 30.00000000, 0.14000000, 2.30000000, 0.22000000, 2.20000000,&
    0.14000000, 0.18000000, 0.13300000, 4.91000000, 5.75000000, 3.80000000, 4.70000000, 2.30000000, 3.40000000,&
    418.00000000, 6.80000000, 1.55000000, 1.04000000, 0.21500000, 0.29000000, 6.15000000	, 6.15000000,&
    23.90000000	, 165.00000000, 3.50000000, 8.00000000, 21.00000000, 26.00000000, 85.00000000, 0.45000000,&
    0.26500000, 0.26000000, 29.00000000	, 29.00000000, 1.10000000, 30.00000000, 7.00000000, 2.00000000,&
    5.80000000, 0.68000000, 3.60000000, 0.27000000, 8.97000000, 57.00000000, 8.93000000, 0.63000000,&
    7.30000000, 1.10000000, 0.57000000, 0.95000000, 11.50000000, 11.50000000, 50.50000000, 18.70000000,&
    337.00000000, 3.60000000, 42.00000000, 1.40000000, 2.50000000, 1.20000000, 168.40000000, 168.40000000,&
    5922.00000000, 0.70000000, 57.00000000, 2.40000000, 42080.00000000, 104.00000000, 206.00000000, 8.40000000,&
    4530.00000000, 9100.00000000, 312.00000000, 49700.00000000, 735.00000000, 85.00000000, 61100.00000000,&
    1.50000000, 259000.00000000, 2.20000000, 0.77000000, 23.40000000, 23.40000000, 994.00000000, 33.00000000,&
    43.00000000, 56.00000000, 600.00000000, 194.00000000, 124.00000000, 2840.00000000, 64.70000000,&
    64.70000000, 159.00000000, 19.00000000, 13.00000000, 19.60000000, 659.00000000, 2.74000000, 5.80000000,&
    100.00000000, 100.00000000, 34.80000000, 2230.00000000, 11.40000000, 48.60000000, 0.80000000, 17.10000000,&
    69.40000000, 2.85000000, 74.00000000, 21.00000000, 2065.00000000, 104.10000000, 561.00000000, 23.50000000,&
    373.00000000, 84.00000000, 41.00000000, 13.04000000, 20.60000000, 563.00000000, 20.50000000, 18.30000000,&
    30.00000000, 20.70000000, 10.10000000, 1.70000000, 37.90000000, 89.70000000, 112.00000000, 76.40000000,&
    16.00000000, 3000.00000000, 80.00000000, 320.00000000, 4.70000000, 25.00000000, 13.10000000, 2.00000000,&
    425.00000000, 954.00000000, 111.00000000, 10.30000000, 152.00000000, 10.00000000, 1.44000000, 27.50000000,&
    0.72000000, 3.66000000, 98.65000000, 98.65000000, 372.30000000, 3080.00000000, 2.00000000, 2150.00000000,&
    60.00000000, 7.80000000, 4.89000000, 0.43000000, 3.43000000, 11.40000000, 0.10400000, 0.17100000	,&
    0.65000000, 0.03000000, 0.69900000, 0.00048000, 0.03380000, 0.03380000, 0.00000000	, 0.00000000,&
    0.00000000	, 0.00000000	, 0.00000000, 0.00000000	, 12.80000000	, 12.80000000, 0.00000000	, 7.37000000	,&
    7.37000000, 200.60000000, 200.60000000, 7.57000000	, 574.70000000, 100.10000000, 680.90000000, 2.68000000,&
    175.90000000, 175.90000000, 0.00000000	, 558.00000000, 1017.30000000, 289.60000000, 18.50000000,&
    75.30000000	, 75.30000000, 0.00000000	, 16.20000000, 1.36000000, 3.00000000, 0.00000000	, 0.00000000	,&
    0.00000000	, 0.00000000	, 0.00000000	, 0.00000000	, 0.00000000	, 0.00000000	, 0.00000000	,&
    0.00000000	, 0.00000000	, 0.00000000	, 0.00000000	, 0.00000000	, 0.00000000	, 0.00000000	,&
    0.00000000	, 0.00000000	, 0.00000000	, 0.00000000	, 0.00000000	, 0.00000000	/)
  ! list of isotopes weights
  weight = (/1.0079000, 1.0078250, 2.0141018, 3.0160493, 4.0026000, 3.0160293, 4.0026033, 6.9410000, 6.0151223,&
    7.0160040, 9.0121821, 9.0121821, 10.8110000, 10.0129370, 11.0093055, 12.0107000, 12.0000000, 13.0033548,&
    14.0032420, 14.0067000, 14.0030740, 15.0001089, 15.9994000, 15.9949146, 16.9991315, 17.9991604, 18.9984032,&
    18.9984032, 20.1797000, 19.9924402, 20.9938467, 21.9913855, 22.9897697, 22.9897697, 24.3050000, 23.9850419,&
    24.9858370, 25.9825930, 26.9815384, 26.9815384, 28.0855000, 27.9769265, 28.9764947, 29.9737702, 30.9737615,&
    30.9737615, 32.0650000, 31.9720707, 32.9714585, 33.9678668, 35.9670809, 35.4530000, 34.9688527, 36.9659026,&
    39.9480000, 35.9675463, 37.9627322, 39.9623831, 39.0983000, 38.9637069, 39.9639987, 40.96182597,&
    40.0780000, 39.9625912, 41.9586183, 42.9587668, 43.9554811, 45.9536928, 47.9525340, 44.9559102, 44.9559102,&
    47.8670000, 45.9526295, 46.9517638, 47.9479471, 48.9478708, 49.9447921, 50.9415000, 49.9471628, 50.9439637,&
    51.9961000, 49.9460496, 51.9405119, 52.9406538, 53.9388849, 54.9380496, 54.9380496, 55.8450000, 53.9396148,&
    55.9349421, 56.9353987, 57.9332805, 58.9332002, 58.9332002, 58.6934000, 57.9353479, 59.9307906, 60.9310604,&
    61.9283488, 63.9279696, 63.5460000, 62.9296011, 64.9277937, 65.3900000, 63.9291466, 65.9260368, 66.9271309,&
    67.9248476, 69.9253250, 69.7230000, 68.9255810, 70.9247050, 72.6400000, 69.9242504, 71.9220762, 72.9234594,&
    73.9211782, 75.9214027, 74.9215964, 74.9215964, 78.9600000, 73.9224766, 75.9192141, 76.9199146, 77.9173095,&
    79.9165218, 81.9167000, 79.9040000, 78.9183376, 80.9162910, 83.8000000, 77.9203860, 79.9163780, 81.9134846,&
    82.9141360, 83.9115070, 85.9106103, 85.4678000, 84.9117893, 86.9091835, 87.6200000, 83.9134250, 85.9092624,&
    86.9088793, 87.9056143, 88.9058479, 88.9058479, 91.2240000, 89.9047037, 90.9056450, 91.9050401, 93.9063158,&
    95.9082760, 92.9063775, 92.9063775, 95.9400000, 91.9068100, 93.9050876, 94.9058415, 95.9046789, 96.9060210,&
    97.9054078, 99.9074770, 98.0000000, 98.0000000, 101.0700000, 95.9075980, 97.9052870, 98.9059393, 99.9042197,&
    100.9055822, 101.9043495, 103.9054300, 102.9055040, 102.9055040, 106.4200000, 101.9056080, 103.9040350,&
    104.9050840, 105.9034830, 107.9038940, 109.9051520, 107.8682000, 106.9050930, 108.9047560, 112.4110000,&
    105.9064580, 107.9041830, 109.9030060, 110.9041820, 111.9027572, 112.9044009, 113.9033581, 115.9047550,&
    114.8180000, 112.9040610, 114.9038780, 118.7100000, 111.9048210, 113.9027820, 114.9033460, 115.9017440,&
    116.9029540, 117.9016060, 118.9033090, 119.9021966, 121.9034401, 123.9052746, 121.7600000, 120.9038180,&
    122.9042157, 127.6000000, 119.9040200, 121.9030471, 122.9042730, 123.9028195, 124.9044247, 125.9033055,&
    127.9044614, 129.9062228, 126.9044680, 126.9044680, 131.2930000, 123.9058958, 125.9042690, 127.9035304,&
    128.9047795, 129.9035079, 130.9050819, 131.9041545, 133.9053945, 135.9072200, 132.9054470, 132.9054470,&
    137.3270000, 129.9063100, 131.9050560, 133.9045030, 134.9056830, 135.9045700, 136.9058210, 137.9052410,&
    138.9055000, 137.9071070, 138.9063480, 140.1160000, 135.9071400, 137.9059860, 139.9054340, 141.9092400,&
    140.9076480, 140.9076480, 144.2400000, 141.9077190, 142.9098100, 143.9100830, 144.9125690, 145.9131120,&
    147.9168890, 149.9208870, 145.0000000, 145.0000000, 150.3600000, 143.9119950, 146.9148930, 147.9148180,&
    148.9171800, 149.9172710, 151.9197280, 153.9222050, 151.9640000, 150.9198460, 152.9212260, 157.2500000,&
    151.9197880, 153.9208620, 154.9226190, 155.9221200, 156.9239570, 157.9241010, 159.9270510, 158.9253430,&
    158.9253430, 162.5000000, 155.9242780, 157.9244050, 159.9251940, 160.9269300, 161.9267950, 162.9287280,&
    163.9291710, 164.9303190, 164.9303190, 167.2590000, 161.9287750, 163.9291970, 165.9302900, 166.9320450,&
    167.9323680, 169.9354600, 168.9342110, 168.9342110, 173.0400000, 167.9338940, 169.9347590, 170.9363220,&
    171.9363777, 172.9382068, 173.9388581, 175.9425680, 174.9670000, 174.9407679, 175.9426824, 178.4900000,&
    173.9400400, 175.9414018, 176.9432200, 177.9436977, 178.9458151, 179.9465488, 180.9479000, 179.9474660,&
    180.9479960, 183.8400000, 179.9467060, 181.9482060, 182.9502245, 183.9509326, 185.9543620, 186.2070000,&
    184.9529557, 186.9557508, 190.2300000, 183.9524910, 185.9538380, 186.9557479, 187.9558360, 188.9581449,&
    189.9584450, 191.9614790, 192.2170000, 190.9605910, 192.9629240, 195.0780000, 189.9599300, 191.9610350,&
    193.9626640, 194.9647740, 195.9649350, 197.9678760, 196.9665520, 196.9665520, 200.5900000, 195.9658150,&
    197.9667520, 198.9682620, 199.9683090, 200.9702850, 201.9706260, 203.9734760, 204.3833000, 202.9723290,&
    204.9744120, 207.2000000, 203.9730290, 205.9744490, 206.9758810, 207.9766360, 208.9803830, 208.9803830,&
    209.0000000, 209.0000000, 210.0000000, 222.0000000, 222.0000000, 223.0000000, 226.0000000, 226.0000000,&
    227.0000000, 232.0381000, 232.0381000, 231.0359000, 231.0359000, 238.0289000, 233.0396280, 234.0409456,&
    235.0439231, 238.0507826, 237.0000000, 237.0000000, 244.0000000, 238.0495534, 239.0521565, 240.0538075,&
    242.0587368, 243.0000000, 243.0000000, 247.0000000, 244.0627463, 246.0672176, 248.0723420, 247.0000000,&
    251.0000000, 252.0829700, 257.0950990, 258.0000000, 259.1010200, 262.1096900, 261.1087500, 262.1141500,&
    266.1219300, 264.1247300, 277.0000000, 268.1388200, 281.0000000, 272.1534800, 285.0000000, 284.0000000,&
    289.0000000, 288.0000000, 293.0000000, 291.0000000, 294.0000000/)

  ! get_filename_ext: get file name extension ================================
  dot_pos = index(file_in, '.', back=.true.)  ! position of last dot
  sep_pos = scan(file_in, '/\\', back=.true.) ! position of last separator
  end_pos = len(file_in)
  if (sep_pos > dot_pos) then
    dot_pos = 0
  end if
  if (dot_pos == 0 .or. dot_pos == end_pos) then
    ext = ""
  else
    dot_pos = dot_pos+1 ! skip '.' char
    ext = l_case(file_in(dot_pos:end_pos))
  end if
  if (ext == "ins" .or. ext == "res") then
    ext = "shx"
  end if

  ! Compute reflections: mode could be an option (CFL, CIF, SHX, PCR)
  call ReadN_set_Xtal_Structure(file_in, Cell, SpG, A , Mode=ext, file_list=fich_cfl)
  if (A%Natoms .eq. 0) then
    message = "ERROR: cif2hkl: Could not extract a crystallographic structure from file "//&
      trim(file_in)//eol//&
      "       Check file existence/permissions and type (should be a CFL,CIF,ShelX)."//eol
    return
  end if
  if (verbose .ne. 0) then
    message = "file='"//trim(file_in)//"';"//eol
    s1 = trim(ADJUSTL(message))//eol//&
      "% cell         [    a         b         c        alpha     beta      gamma ]"//eol
    write(s2,fmt="(a,6f10.5,a)") "cell=[ ", &
         Cell%cell(1), Cell%cell(2), Cell%cell(3), &
         Cell%ang(1), Cell%ang(2), Cell%ang(3), "];"//eol
    write(s3,fmt="(a,i4,a)") "Spgr='"//trim(SpG%SPG_Symb)//"'; % space group [Number ",&
         SpG%NumSpg, "]"//eol
    message = trim(s1)//trim(s2)//trim(s3)//&
      "%             [    x/a       y/b       z/c      Biso      Occ       Spin      Charge ]"//eol
  end if

  !Compute cross section
  sigma_coh=0
  sigma_inc=0
  sigma_abs=0
  mass     =0
  formula  =""

  do I=1, A%Natoms
    do Y = 1,n_elements
      if (trim(L_case(A%atom(i)%ChemSymb)) == trim(L_case(element(Y)))) THEN
        ! an atom from the fomula (i) matches one in the isotopes list (y)
        ! compute total cross sections and weight
        sigma_coh = sigma_coh + 4*pi*bcoh(Y)*bcoh(Y)*A%atom(i)%Mult*1E8
        sigma_inc = sigma_inc + 4*pi*binc(Y)*binc(Y)*A%atom(i)%Mult*1E8
        sigma_abs = sigma_abs + Sabs(Y)*A%atom(i)%Mult
        mass      = mass+weight(Y)*A%atom(i)%Mult
        s1 = adjustl(formula)
        write(unit=s2, fmt='(I3)') A%atom(i)%Mult
        formula   = trim(s1)//" "//trim(element(Y))//trim(adjustl(s2))
        ! display verbose information
        ! Label,x/a, y/b, z/c, B, occ, Spin, Charge
        if (verbose .ne. 0) then
          write(s2,fmt="(a,a,a,7f10.5,a)") trim(message),trim(A%atom(i)%lab),"=[",A%atom(i)%X, &
            A%atom(i)%Biso,A%atom(i)%Occ,A%atom(i)%moment,A%atom(i)%Charge,"];"//eol
          message = s2
        end if
        exit
      end if
    end do
  end do
  if (verbose .ne. 0) then
    s1 = trim(message)//"title='"//trim(formula)//" ["//trim(SpG%SPG_Symb)//&
      ", "//trim(SpG%CrystalSys)//", "//trim(SpG%Centre)//"]';"//eol
!    write(*,*) "% sigma_coh  ",  sigma_coh, " coherent   scattering cross section in [barn]"
!    write(*,*) "% sigma_inc  " , sigma_inc, " incoherent scattering cross section in [barn]"
!    write(*,*) "% sigma_abs  " , sigma_abs, " absorption scattering cross section in [barn]"
!    write(*,*) "% density    ",  mass/cell%cellVol, " in [g/cm^3]"
!    write(*,*) "% weight     ",  mass,         " in [g/mol]"
!    write(*,*) "% Vc         ",  cell%cellVol, " volume of unit cell in [A^3]"
    message = s1
  end if

  ! suppress Sfac computation and output when has --no-output-files option
  if (powxtal(1:1) .ne. '-') then
    MaxNumRef = Get_MaxNumRef(stlmax,Cell%CellVol,mult=SpG%NumOps)
    if (powxtal(1:1) == "p") then
      ! powder mode:
      !    Hkl_Uni(Crystalcell, Spacegroup,Friedel,Value1,Value2,Code,Num_Ref,Reflex, no_order)
      call Hkl_Uni(Cell,Spg,.true.,0.0,stlmax,"s",MaxNumRef,hkl)
    else
      ! SX mode:
      call Hkl_Gen_SXtal(Cell,Spg,0.0,stlmax,MaxNumRef,hkl)
      ! sort SX Bragg peaks
      call sort_d(hkl)
    end if
    ! exit when no reflection can be computed
    if (hkl%Nref == 0) then
      message = "ERROR: cif2hkl: No reflection list can be set from file "//&
        trim(file_in)//eol//&
        "       Check file existence/permissions and type (should be a CFL,CIF,ShelX)."//eol
      return
    end if
    ! mode="nuc" (neutron), "ele" (electrons), "xra" x-rays
    call Structure_Factors(A,SpG,hkl,mode=mode)

    ! get current date/time
    call idate(today)   ! today(1)=day, (2)=month, (3)=year
    call itime(now)     ! now(1)=hour, (2)=minute, (3)=second

    !Write reflection file
    open( unit=lun,file=file_out,status="replace",action="write")
    write(unit=lun,fmt="(a,a,a)")    "# TITLE  ",     trim(formula), " ["//trim(SpG%CrystalSys)//", "//trim(SpG%Centre)//"]"
    write(unit=lun,fmt="(a)") "#        a         b         c       alpha     beta      gamma"
    write(unit=lun,fmt="(a,6f10.5)") "# CELL ", Cell%cell(1), Cell%cell(2), Cell%cell(3), Cell%ang(1), Cell%ang(2), Cell%ang(3)
    write(unit=lun,fmt="(a,a,a,i4,a)") "# SPCGRP  ",    trim(SpG%SPG_Symb)," [Number ",SpG%NumSpg, "]"
    write(unit=lun,fmt="(a)") "#                    X         Y         Z         B         Occ       Spin      Charge"
    do I=1, A%Natoms
      write(unit=lun,fmt="(a,a,7f10.5)") "# Atom  ",A%atom(i)%lab,&
            A%atom(i)%X, &
            A%atom(i)%Biso,A%atom(i)%Occ,A%atom(i)%moment,A%atom(i)%Charge
    end do
    write(unit=lun,fmt="(a)")        "# COMMAND cif2hkl "//trim(file_in)//" --output "//trim(file_out)
    write(unit=lun,fmt="(a)")        "# CIF2HKL (c) ILL 2012 E. Farhi <farhi@ill.eu> based on CrysFML"
    write(unit=lun,fmt=1000) today, now
  1000 format ( '# DATE    ', i2.2, '/', i2.2, '/', i4.4, ' at ', i2.2, ':', i2.2, ':', i2.2)
    write(unit=lun,fmt="(a)") "#"
    write(unit=lun,fmt="(a,f14.5,a)") "# Physical parameters:"
    write(unit=lun,fmt="(a,f14.5,a)") "# sigma_coh  ",  sigma_coh, " coherent   scattering cross section in [barn]"
    write(unit=lun,fmt="(a,f14.5,a)") "# sigma_inc  " , sigma_inc, " incoherent scattering cross section in [barn]"
    write(unit=lun,fmt="(a,f14.5,a)") "# sigma_abs  " , sigma_abs, " absorption scattering cross section in [barn]"
    write(unit=lun,fmt="(a,f14.5,a)") "# density    ",  mass/cell%cellVol, " in [g/cm^3]"
    write(unit=lun,fmt="(a,f14.5,a)") "# weight     ",  mass,         " in [g/mol]"
    write(unit=lun,fmt="(a,f14.5,a)") "# Vc         ",  cell%cellVol, " volume of unit cell in [A^3]"
    write(unit=lun,fmt="(a,f14.5,a)") "# lattice_a  ", Cell%cell(1),  " lattice parameter a in [Angs]"
    write(unit=lun,fmt="(a,f14.5,a)") "# lattice_b  ", Cell%cell(2),  " lattice parameter b in [Angs]"
    write(unit=lun,fmt="(a,f14.5,a)") "# lattice_c  ", Cell%cell(3),  " lattice parameter c in [Angs]"
    write(unit=lun,fmt="(a,f14.5,a)") "# lattice_aa ", Cell%ang(1),   " lattice angle alpha in [deg]"
    write(unit=lun,fmt="(a,f14.5,a)") "# lattice_bb ", Cell%ang(2),   " lattice angle beta in [deg]"
    write(unit=lun,fmt="(a,f14.5,a)") "# lattice_cc ", Cell%ang(3),   " lattice angle gamma in [deg]"
    Select Case (l_case(mode(1:3)))
      Case("nuc")
        write(unit=lun,fmt="(a)") "# STRUCTURE FACTORS(NEUTRONS)"
      Case("xra")
        write(unit=lun,fmt="(a)") "# STRUCTURE FACTORS(X-RAYS)"
      Case("ele")
        write(unit=lun,fmt="(a)") "# STRUCTURE FACTORS(ELECTRONS)"
      Case default
        message = "ERROR: cif2hkl: unknown option: --mode "//trim(mode)//eol
        return
    End Select
    write(unit=lun,fmt="(a)") "#"
    write(unit=lun,fmt="(a)") "# Format parameters: Crystallographica format"
    write(unit=lun,fmt="(a)") "# column_h  1"
    write(unit=lun,fmt="(a)") "# column_k  2"
    write(unit=lun,fmt="(a)") "# column_l  3"
    write(unit=lun,fmt="(a)") "# column_j  4   multiplicity 'j'"
    write(unit=lun,fmt="(a)") "# column_d  5   d-spacing 'd' in [Angs]"
    write(unit=lun,fmt="(a)") "# column_F2 6   norm of scattering factor |F|^2 in [barn]"
    write(unit=lun,fmt="(a)") "#"
    write(unit=lun,fmt="(a,i5,a,f10.4,a)") "# List ",hkl%Nref, " reflections for lambda > ", &
            lambda, " [Angs], decreasing d-spacing."
    write(unit=lun,fmt="(a)") &
            "# H   K   L     Mult    dspc                   |Fc|^2"
    do i=1,hkl%Nref
      F    = hkl%ref(i)%Fc
      if ((F+1.0) .ne. F) then ! except for NaN's
        write(unit=lun,fmt="(3(i4,1x),i5,1x,2(f13.5,1x),f25.5)") &
        hkl%ref(i)%h, hkl%ref(i)%mult, &
        0.5/hkl%ref(i)%S, hkl%ref(i)%Fc*hkl%ref(i)%Fc
      end if
    end do

    ! write with Write_RefList_Info(Rfl, Iunit, Mode)
    ! call Write_RefList_Info(hkl, lun, mode)

    close (unit=lun)
  end if

End subroutine CFML_cif2hkl


subroutine print_version(pgmname,message)
  ! Show program version. pgmname = argv[0] ================================
  character*1024 pgmname
  character*1024, intent(out) :: message

  character*80 AUTHOR, DATE, VERSION
  character*2   eol

  eol=char(13)//char(10)

  AUTHOR ="Farhi E. [farhi@ill.fr] using crysFML <http://forge.ill.fr/projects/crysfml>"
  DATE   ="11 Mar 2016"
  VERSION="1.2"


  message = trim(pgmname)//" "//trim(VERSION)//" ("//trim(DATE)//") by "//trim(AUTHOR)//eol//&
   "  Copyright (C) 2009 Institut Laue Langevin, EUPL license."//eol//&
   "  This is free software; see the source for copying conditions."//eol//&
   "  There is NO warranty; not even for MERCHANTABILITY or FITNESS"//eol//&
   "  FOR A PARTICULAR PURPOSE."//eol
end subroutine print_version

subroutine print_usage(pgmname,message)
  ! Show program help. pgmname = argv[0] ===================================
  character*1024 pgmname
  character*4096,intent(out) :: message

  character*2   eol

  eol=char(13)//char(10)

  message = "Usage: "//trim(pgmname)//" [options][-o outfile] file1 file2 ..."//eol//&
    "Action: Read a CIF/CFL/SHX/PCR crystallographic description"//eol//&
    "        and generates a HKL F^2 reflection list."//eol//&
    "Input:"//eol//&
    "  file1...          Input file in CIF, PCR, CFL, SHX, INS, RES format."//eol//&
    "                      The file format is determined from its extension"//eol//&
    "                        .CIF           Crystallographic Information File"//eol//&
    "                        .PCR/.CFL      FullProf file"//eol//&
    "                        .SHX/.INS/.RES ShelX file"//eol//&
    "Output:"//eol//&
    "  a file with readable header, and reflection list with columns"//eol//&
    "    [ H K L Multiplicity Sin(Theta/Lambda) d_spacing |F|^2 ]"//eol//&
    "Options:"//eol//&
    "--help     or -h    Show this help"//eol//&
    "--version  or -v    Display program version"//eol//&
    "--out FILE          Specify the name of the next output file."//eol//&
    "   -o FILE            Default is to add .hkl to the initial file name."//eol//&
    "--lambda LAMBDA     Set the incoming probe wavelength [Angs]."//eol//&
    "   -l    LAMBDA       Default is 0.5"//eol//&
    "--powder   or -p    Generate a list of unique HKL reflections (for powders). Default."//eol//&
    "--xtal     or -x    Generate a list of all HKL reflections (for single crystals)."//eol//&
    "--mode MODE         Generate structure factors for given probe, where MODE is"//eol//&
    "   -m  MODE           NUC=neutron(default) XRA=xrays ELE=electrons"//eol//&
    "--verbose           Display processing details."//eol//&
    "--no-outout-files   Just read the CIF/CFL/ShelX file (for checking)."//eol//&
    "Example: "//trim(pgmname)//" --powder --mode NUC -o CaF2.laz CaF2.cfl"//eol

end subroutine print_usage

!*****************************************************************************
! main: Entry point
!****************************************************************************/
program cif2hkl

  character(len=1024) :: pgmname
  integer             :: i=0
  integer             :: argc=0
  character(len=1024) :: argv
  character(len=1024) :: outfile
  character(len=1024) :: ext            ! input file name extension
  real*8              :: lambda= 0.5    ! wavelength (determines minimum d)
  character(len=1024) :: powxtal="p"    ! 'p'=powder, 's'=SX output file, '-'=no output
  integer             :: verbose=0      ! verbose mode to display additional information
  character(len=1024) :: mode="NUC"     ! 'NUC','XRA','ELE'

  character*4096      :: message

  argc    = iargc()       ! number of arguments
  call getarg(0, pgmname) ! program name
  outfile = ""
  message = ""

  if (argc == 0) then
    call print_usage(pgmname, message)
    write(*,*) trim(message)
  else
    do while (i < argc)
      i = i + 1
      call getarg(i, argv)
      if (argv(1:2) == "-h" .or. argv(1:6) == "--help") then
        call print_usage(pgmname, message)
        write(*,*) trim(message)
        stop
      end if
      if (argv(1:2) == "-v" .or. argv(1:9) == "--version") then
        call print_version(pgmname, message)
        write(*,*) trim(message)
        stop
      end if
      if ( (argv(1:8) == "--lambda" .or. argv(1:2) == "-l") .and. i<argc) then
        i=i+1
        call getarg(i, argv)
        read(argv, *) lambda
        cycle
      end if
      if ( (argv(1:5) == "--out".or. argv(1:2) == "-o") .and. i < argc) then
        i=i+1
        call getarg(i, outfile)
        cycle
      end if
      if ( (argv(1:6) == "--mode".or. argv(1:2) == "-m") .and. i < argc) then
        i=i+1
        call getarg(i, mode)
        cycle
      end if
      if (argv(1:2) == "-p" .or. argv(1:3) == "--p") then
        powxtal = "p"
        cycle
      end if
      if (argv(1:2) == "-x" .or. argv(1:3) == "--x") then
        powxtal = "x"
        cycle
      end if
      if (argv(1:8) == "-verbose" .or. argv(1:9) == "--verbose") then
        verbose = 1
        cycle
      end if
      if (argv(1:4) == "--no") then
        powxtal = "-"
        cycle
      end if
      if (argv(1:1) .ne. '-') then
        ! convert argv[i]: process conversion

        ! check outfile
        if (len_trim(outfile) == 0) then
          outfile = trim(argv)//".hkl"  ! append .hkl extension
        end if
        call cfml_cif2hkl(argv, outfile, lambda, powxtal, verbose, message, mode)
        write(*,*) trim(message)

        ! revert outfile to default
        outfile = ""
        cycle
      end if
    end do
  end if

end program cif2hkl