Commit 3c9d22ab authored by juan rodriguez-carvajal's avatar juan rodriguez-carvajal
Browse files

Merge branch 'testing-fpm' into 'master'

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

See merge request !28
parents e0a9fe99 6a050fb4
Pipeline #13537 passed with stages
in 6 minutes and 22 seconds
This diff is collapsed.
......@@ -419,7 +419,7 @@
! Now calculate structure factors
write(*,*) " => Calculating structure factors ..."
call cpu_time(tini)
call Magnetic_Structure_Factors(Cell,A,SpG,stlmax,hkl,Stf,lun)
call Magnetic_Structure_Factors("Powder",Cell,A,SpG,stlmax,hkl,Stf,lun)
if (ERR_SFac) then
write(*,*) " => Error in calculations of Structure Factors"
write(*,*) " => "//trim(ERR_SFac_Mess)
......
......@@ -32,9 +32,9 @@ rem ****---- Lahey Compiler ----****
rem
rem ****---- Intel Compiler ----****
:IFORT
ifort /c Calc_Powder.f90 /Ox /nologo /I. /I..\..\ifort\LibC
ifort /c Calc_Powder.f90 /Ox /nologo /I. /I..\..\ifort64\LibC
rem ifort /exe:Calc_Powder *.obj ..\..\ifort\LibC\CrysFML.lib /link /stack:102400000
link /subsystem:console /stack:102400000 /out:Calc_Powder.exe *.obj ..\..\ifort\LibC\CrysFML.lib
link /subsystem:console /stack:102400000 /out:Calc_Powder.exe *.obj ..\..\ifort64\LibC\CrysFML.lib
goto END
rem
rem **---- G95 Compiler ----**
......
......@@ -27,9 +27,9 @@ rem ****---- Lahey Compiler ----****
rem
rem ****---- Intel Compiler ----****
:IFORT
ifort /c Corr_Cells.f90 /Ox /nologo /I. /I..\..\ifort\LibC
ifort /c Corr_Cells.f90 /Ox /nologo /I. /I..\..\ifort64\LibC
rem ifort /exe:Corr_Cells *.obj ..\..\ifort\LibC\CrysFML.lib /link /stack:102400000
link /subsystem:console /stack:102400000 /out:Corr_Cells.exe *.obj ..\..\ifort\LibC\CrysFML.lib
link /subsystem:console /stack:102400000 /out:Corr_Cells.exe *.obj ..\..\ifort64\LibC\CrysFML.lib
goto END
rem
rem **---- G95 Compiler ----**
......
......@@ -27,9 +27,9 @@ rem ****---- Lahey Compiler ----****
rem
rem ****---- Intel Compiler ----****
:IFORT
ifort /c Laue_Powder.f90 /Ox /nologo /I. /I..\..\ifort\LibC
ifort /c Laue_Powder.f90 /Ox /nologo /I. /I..\..\ifort64\LibC
rem ifort /exe:Simple_Calc_Powder *.obj ..\..\ifort\LibC\CrysFML.lib /link /stack:102400000
link /subsystem:console /stack:102400000 /out:Laue_Powder.exe *.obj ..\..\ifort\LibC\CrysFML.lib
link /subsystem:console /stack:102400000 /out:Laue_Powder.exe *.obj ..\..\ifort64\LibC\CrysFML.lib
goto END
rem
rem **---- G95 Compiler ----**
......
......@@ -27,9 +27,9 @@ rem ****---- Lahey Compiler ----****
rem
rem ****---- Intel Compiler ----****
:IFORT
ifort /c Simple_Calc_Powder.f90 /Ox /nologo /I. /I..\..\ifort\LibC
ifort /c Simple_Calc_Powder.f90 /Ox /nologo /I. /I..\..\ifort64\LibC
rem ifort /exe:Simple_Calc_Powder *.obj ..\..\ifort\LibC\CrysFML.lib /link /stack:102400000
link /subsystem:console /stack:102400000 /out:Simple_Calc_Powder.exe *.obj ..\..\ifort\LibC\CrysFML.lib
link /subsystem:console /stack:102400000 /out:Simple_Calc_Powder.exe *.obj ..\..\ifort64\LibC\CrysFML.lib
goto END
rem
rem **---- G95 Compiler ----**
......
......@@ -13,8 +13,8 @@ Program Calc_Structure_Factors
use CFML_Crystal_Metrics, only: Crystal_Cell_Type, Write_Crystal_Cell
use CFML_Reflections_Utilities, only: Reflection_List_Type, Hkl_Uni, get_maxnumref
use CFML_IO_Formats, only: Readn_set_Xtal_Structure,err_form_mess,err_form,file_list_type
use CFML_Structure_Factors, only: Structure_Factors, Write_Structure_Factors, &
Init_Structure_Factors,Calc_StrFactor
use CFML_Structure_Factors, only: Structure_Factors, Write_Structure_Factors,Init_Calc_hkl_StrFactors, &
Init_Structure_Factors,Calc_StrFactor, Calc_hkl_StrFactor
use CFML_String_Utilities, only: u_case
!---- Variables ----!
......@@ -24,13 +24,13 @@ Program Calc_Structure_Factors
type (space_group_type) :: SpG
type (Atom_list_Type) :: A
type (Crystal_Cell_Type) :: Cell
type (Reflection_List_Type) :: hkl
type (Reflection_List_Type) :: hkl,hkl_sing
character(len=256) :: filcod !Name of the input file
character(len=132) :: line
character(len=15) :: sinthlamb !String with stlmax (2nd cmdline argument)
real :: stlmax !Maximum Sin(Theta)/Lambda
real :: sn,sf2, Lambda
real :: sn,sf2, Lambda, delta
integer :: MaxNumRef, lun=1, ier,i
complex :: fc
......@@ -116,13 +116,39 @@ Program Calc_Structure_Factors
!> Calculation for neutron scattering
call Init_Structure_Factors(hkl,A,Spg,mode="NUC",lun=lun)
call Structure_Factors(A,SpG,hkl,mode="NUC")
hkl_sing=hkl
call Write_Structure_Factors(lun,hkl,mode="NUC")
!> Test of another structure factor subroutine
write(unit=lun,fmt="(/,a,/)") " => Calculation with subroutine Calc_StrFactor"
write(unit=*,fmt="(/,a,/)") " => Calculation with subroutine Calc_StrFactor"
write(unit=lun,fmt="(/,a,/)") " H K L Mult SinTh/Lda |Fc| Phase F-Real F-Imag Num"
do i=1, hkl%nref
sn=hkl%ref(i)%s * hkl%ref(i)%s
call Calc_StrFactor("P","N",i,sn,A,Spg,sf2,fc=fc)
delta=abs(hkl%ref(i)%Fc-sqrt(sf2))
if(delta > 0.01) write(*,"(3i4,3f14.4)") hkl%ref(i)%h,hkl%ref(i)%Fc,sqrt(sf2),delta
delta=abs(hkl%ref(i)%A-real(fc))
if(delta > 0.01) write(*,"(3i4,3f14.4)") hkl%ref(i)%h,hkl%ref(i)%A,real(fc),delta
delta=abs(hkl%ref(i)%B-aimag(fc))
if(delta > 0.01) write(*,"(3i4,3f14.4)") hkl%ref(i)%h,hkl%ref(i)%B,aimag(fc),delta
write(unit=lun,fmt="(3i4,i5,5f12.5,i8,f12.5)") hkl%ref(i)%h, hkl%ref(i)%mult, &
hkl%ref(i)%S, hkl%ref(i)%Fc, hkl%ref(i)%Phase, real(fc), aimag(fc), i, sqrt(sf2)
end do
write(unit=lun,fmt="(/,a,/)") " => Calculation with subroutine Calc_hkl_StrFactor"
write(unit=*,fmt="(/,a,/)") " => Calculation with subroutine Calc_hkl_StrFactor"
write(unit=lun,fmt="(/,a,/)") " H K L Mult SinTh/Lda |Fc| Phase F-Real F-Imag Num"
call Init_Calc_hkl_StrFactors(A,"NUC")
do i=1, hkl%nref
sn=hkl%ref(i)%s * hkl%ref(i)%s
call Calc_hkl_StrFactor("P","N",hkl%ref(i)%h,sn,A,SpG,sf2,fc=fc)
delta=abs(hkl%ref(i)%Fc-sqrt(sf2))
if(delta > 0.01) write(*,"(3i4,3f14.4)") hkl%ref(i)%h,hkl%ref(i)%Fc,sqrt(sf2),delta
delta=abs(hkl%ref(i)%A-real(fc))
if(delta > 0.01) write(*,"(3i4,3f14.4)") hkl%ref(i)%h,hkl%ref(i)%A,real(fc),delta
delta=abs(hkl%ref(i)%B-aimag(fc))
if(delta > 0.01) write(*,"(3i4,3f14.4)") hkl%ref(i)%h,hkl%ref(i)%B,aimag(fc),delta
write(unit=lun,fmt="(3i4,i5,5f12.5,i8,f12.5)") hkl%ref(i)%h, hkl%ref(i)%mult, &
hkl%ref(i)%S, hkl%ref(i)%Fc, hkl%ref(i)%Phase, real(fc), aimag(fc), i, sqrt(sf2)
end do
......
......@@ -32,6 +32,7 @@ Program Calc_Magnetic_Structure_Factors
character(len=256) :: filcod !Name of the input file
character(len=132) :: line
character(len=15) :: sinthlamb !String with stlmax (2nd cmdline argument)
character(len=6) :: Mode !"Powder", "SXtal"
real :: stlmax !Maximum Sin(Theta)/Lambda
real :: Lambda
integer :: lun=1, ier,i,codini=0
......@@ -106,20 +107,28 @@ Program Calc_Magnetic_Structure_Factors
call Get_moment_ctr(A%Atom(i)%X,A%Atom(i)%M_xyz,Spg,codini,codes,Ipr=lun)
end do
call Write_Atom_List(A,level=2,lun=lun)
!Look for wavelength in CFL file
!Look for wavelength and Mode in CFL file
lambda=0.70926 !Mo kalpha (used only for x-rays)
do i=1,fich_cfl%nlines
Mode="Powder"
do i=1,fich_cfl%nlines
line=adjustl(fich_cfl%line(i))
if(U_Case(line(1:6)) == "LAMBDA") then
read(unit=line(7:),fmt=*,iostat=ier) lambda
if(ier /= 0) lambda=0.70926
end if
end do
call Magnetic_Structure_Factors(Cell,A,SpG,stlmax,hkl,Stf,lun)
if(U_Case(line(1:4)) == "MODE") then
read(unit=line(5:),fmt=*,iostat=ier) Mode
if(ier /= 0) then
Mode="Powder"
else
Mode=adjustl(Mode)
end if
end if
end do
call Magnetic_Structure_Factors(Mode,Cell,A,SpG,stlmax,hkl,Stf,lun)
call Write_Structure_Factors(lun,hkl,stf,full)
write(unit=*,fmt="(a)") " Normal End of: PROGRAM Magnetic STRUCTURE FACTORS "
write(unit=*,fmt="(a)") " Results in File: "//trim(filcod)//".sfa"
end if
......
......@@ -8544,7 +8544,6 @@
read(unit=spgm(j+1:j+2),fmt=*,iostat=ier) ic
if (ier /=0) ic=0
call getnum(spgm(:j-1),vet,ivet,iv)
spgm=spgm(:j-1)
else
call getnum(spgm,vet,ivet,iv)
end if
......@@ -8999,7 +8998,12 @@
end do
exit
end do
SpaceGroup%Spg_Symb(2:)=l_case(SpaceGroup%Spg_Symb(2:)) !Make lowercase the HM generators of the group
j=index(SpaceGroup%Spg_Symb,":")
if(j /= 0) then
SpaceGroup%Spg_Symb(2:j)=l_case(SpaceGroup%Spg_Symb(2:j)) !Make lowercase the HM generators of the group
else
SpaceGroup%Spg_Symb(2:)=l_case(SpaceGroup%Spg_Symb(2:)) !Make lowercase the HM generators of the group
end if
end if
!write(*,"(a)") " => Wyckoff done"
......@@ -9656,7 +9660,7 @@
end do
MSpGn%NumOps=MSpG%NumOps
MSpGn%Centre="Non-Centrosymmetric" ! Alphanumeric information about the center of symmetry
if(MSpGn%Centred == 1) then
if(MSpGn%Centred == 0) then
MSpGn%Centre="Centrosymmetric, -1 not @the origin "
MSpGn%Centre_coord=0.5*MSpGn%SymOp(m)%tr
else if(MSpGn%Centred == 2) then
......
!!-------------------------------------------------------
!!---- 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)
!!---- Nebil Ayape Katcho (ILL)
!!----
!!---- 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 (Windows 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= 1 ! Windows
!!----
!!---- 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="Windows"
!!----
!!---- 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
integer, parameter :: IL = selected_int_kind(16) ! Long Integer
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
......@@ -741,7 +741,7 @@
Job_Info%W = 0.0
Job_Info%X = 0.0
Job_Info%Y = 0.0
Job_Info%theta_step = 0.0
Job_Info%bkg = 0.0
......@@ -749,10 +749,10 @@
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
......@@ -775,7 +775,7 @@
end if
end if
if (line(1:4) == "STEP") then
if (line(1:4) == "STEP") then
read(unit=line(5:),fmt=*,iostat=ier) Job_info%theta_step
if (ier /= 0) then
Job_info%theta_Step = 0.05
......@@ -787,7 +787,7 @@
read(unit=line(7:),fmt=*,iostat=ier) Job_info%bkg
if(ier /= 0) Job_info%bkg=20.0
end if
end do
if (nphas == 0) then
......@@ -859,8 +859,8 @@
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))
......@@ -2044,26 +2044,28 @@
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))
!write(*,"(a)") " From Read_Key_Str _symmetry_space_group_name_H-M: "//spgr_hm
!if (len_trim(spgr_hm) == 0 ) spgr_hm=adjustl(filevar(nline_ini+1))
!nline_ini=np1
! TR feb. 2015 .(re-reading the same item with another name)
if(len_trim(spgr_hm) == 0) then
nline_ini=np1
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))
if (len_trim(spgr_hm) == 0 ) spgr_hm=adjustl(filevar(nline_ini+1))
!write(*,"(a)") " From Read_Key_Str _space_group_name_H-M_alt: "//spgr_hm
end if
if (spgr_hm =="?" .or. spgr_hm=="#") then
if (spgr_hm == "?" .or. spgr_hm == "#") then
spgr_hm=" "
else
np1=index(spgr_hm,"'")
np2=index(spgr_hm,"'",back=.true.)
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.)
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
......@@ -2071,6 +2073,7 @@
end if
end if
en