Source module last modified on Tue, 2 May 2006, 0:54;
HTML image of Fortran source automatically generated by
for2html on Mon, 29 May 2006, 15:06.
#////////////////////////////////////////////////////////////////////////////////
#////
#//// R E S T R A X 4.8.1 EXCI
#////
#//// Subroutine called by RESTRAX to get values of excitation energy (OMEXC)
#//// and scattering cross-section (SQOM) for given QHKL,E values stored in Q(i)
#//// Permits to define up to 6 different branches of S(Q,E)
#////
#//// You can use this file as a template
#//// Refer to DON'T CHANGE .. END blocks for the code to be preserved
#////
#//// J. Saroun (saroun@ujf.cas.cz) , March 2005
#//// Read attached documentation or visit RESTRAX home page for help:
#//// http://omega.ujf.cas.cz/restrax
#////////////////////////////////////////////////////////////////////////////////
#
# *** ARGUMENTS ***
# input:
# Q(1:4) ... (H,K,L,E) values
# ICOM<-10 ... initialization (called only once when loaded at runtime )
# ICOM=0 ... initialization (run usually before each [M]FIT or INIT commands)
# ICOM=-1 ... only excitation energies are used (e.g. for plotting disp. branches)
# ICOM=-2 ... only S(Q,E) values are used (e.g. for plotting S(Q,E) maps)
# ICOM>0 ... should return both excitation energies and S(Q,E). ICOM=index of supplied event
#
# output:
# OMEXC(1:6) ... excitation energies for 1..nbr branches for Qhkl = Q(1:3)
# SQOM(1:6) ... S(Q,E) values for 1..nbr branches
#
# *** SHARED DATA ***
#
# Following fileds are available via common variables declared in the *.inc files:
#
# Monte Carlo ray-tracing results:
#-----------------------------------
# REAL*4 QOM(1:4,j),PQOM(j) .... value of (Q,E) and weight for j-th event
# IQOM(j) .... the index of data set corresponding to given j-th event.
# NQOM(k) .... partitioning of the QOM, PQOM ... arrays, i.e. the number
# of events stored for the k-th data set is NQOM(k)-NQOM(k-1).
# NDATQOM .... index of actual data set, for which the scan profile is accumulated
# Use this index to define specific free parameters for different data sets
#
# Instrument setting:
#-----------------------------------
# REAL*4 QOM0(1:4,k) .... Spectrometer position (Q,E) for k-th data set
#
# Unit vectors in rec. lat. units:
#-----------------------------------
# REAL*8 PARAM(1:MPAR) ... free model parameters
# INETEGR*4 FIXPARAM(1:MPAR) ... fixed parameters. Set FIXPARAM(i)=0 to make
# the i-th parameter fixed)
# NTERM ... number of free model parameters (<=64)
# NBR ... number of branches defined by EXCI (<=6)
# REAL*8 WEN(1:6) ... widths of the disp. branches.
# CHARACTER*10 PARNAME(1:MPAR) ... names of free parameters
#
# Outside EXCI, WEN is used only as a flag to check, whether scattering
# is difuse (WEN>0) or not (WEN=0). The convolution method is selected according
# to this flag.
#
# *** SHARED SUBROUTINES ***
# (see source files for details)
# in this module:
# SUBROUTINE READEXCIPAR ... Read initial values of model variables
# in exci_io.f:
# SUBROUTINE SETEXCIDEFAULT ... Set default values to common EXCI variables
# in reclat.f:
# SUBROUTINE POLVECT(Q,TAU,SIG1,SIG2,SIG3,ICOM) ... Get polarization unit vectors with
# respect to q=TAU-Q
# REAL*8 FUNCTION QxQ(A,B) ... Scalar product of vectors A,B in non-carthesian rec. lattice coordinates
# SUBROUTINE QNORM(X,QRLU,QANG) ... Norm of a vector X in non-carthesian rec. lattice coordinates
#///////////////////////////////////////////////////////////////////////////////////
#------------------------------------------------------------------------------
SUBROUTINE EXCI(icom,q,omexc,sqom)
# Incommensurate satellites in horizontal plane, infinite in energy
# and vertical direction
# free parameters:
# (1) Intensity (2) background (3) position (4) width
#------------------------------------------------------------------------------
implicit none
#----------------------- *** DON'T CHANGE *** ------------------------------
INCLUDE 'const.inc'
# INCLUDE 'inout.inc'
INCLUDE 'exci.inc'
integer*4 icom ,excinit
real*8 q(4),omexc(6),sqom(6)
#-------------------------- *** END *** ------------------------------------
# **** Local user declarations ****
integer*4 i,j,k
real*8 qsat(3),v(3),dirsq,qsq
#// TAU(3) ... B.Z. center
#// POS(3,6)... satellite positions are POS*dist
#// DIR(3) ... direction of "rods"
#// fqsq(6) ... scattering cross-sections of satellites
#// wq(6) ... satellite widths
#// dist ... width of satellites in r.l.u.
real*8 tau(3),dir(3),pos(3,6),fqsq(6),wq(6),dist
common /excipar/ tau,dir,pos,fqsq,wq,dist
#------------------ *** DATA section *** ----------------------
# **** DEFAULT values of internal model variables ****
data fqsq/6*1./
data tau/1.,0.,0./
data dir/0.,0.,1./
data pos/1.,1.,0.,1.,-1.,0,-1.,1.,0.,-1.,-1.,0,6*0./
data wq/6*0.01/
data dist/0.3/
data excinit/0/
data dirsq/1.d0/
#***********************************************************************************
# MODEL INITIALIZATION (ICOM<-10)
#***********************************************************************************
#-- called only once when loaded at runtime
#-- set some values shared with RESTRAX if different from default
if (icom.lt.-10) then
call SETEXCIDEFAULT ! DONīT CHANGE
# Set model identification string:
phontitle= 'Incommensurate satellites'
#// Define fixed parameters (=0), default: all free (=1)
# FIXPARAM(1)=0 ! let Intensity fixed !!
#// Number of branches ****
nbr=4
#// Initial widths in energy, default=1meV
#// Set wen(i)=0 for zero-width branches
# WEN(1)=0.D0
# WEN(2)=2.D0
#**** How to read file with parameters (default=1):
#**** (0) never (1) at program start or on INIT command (2) each time MFIT is called
# EXCREAD=0
# Set name of file with model parameters (if different from default exc.par)
phonname= 'sat.par'
# Define names of free parameters for i>2:
parname(3)= 'Position'
parname(4)= 'Width'
#// Number of free model parameters
nterm=4
return
endif
#----------------------- *** DON'T CHANGE *** ------------------------------
if ((icom.ne.0).and.(excinit.ne.0)) goto 1
#---------------------------- *** END *** ----------------------------------
#***********************************************************************************
# MODEL INITIALIZATION (ICOM=0)
#***********************************************************************************
#-- called before each [M]FIT or INIT command
#
# calculate |DIR|^2
dirsq=dir(1)**2+dir(2)**2+dir(3)**2
#/// Assign initial values of free parameters to param(i) array
param(3)=dist
param(4)=wq(1)
#----------------------- *** DON'T CHANGE *** -------------------------
excinit=1
return
1 continue
#---------------------------- *** END *** ----------------------------------
#********************************************************************************
#
# EXECUTION PART (ICOM<>0)
#
# This part is called many times during the fitting procedure
# => should be as fast as possible
#
#// Do whatever you want in the following code.
#// EXCI MUST RETURN:
#// OMEXC(i) ... excitation energies for first NBR branches (i=1..6)
#// SQOM(i) ... dS/dOmega/dE
# (ICOM=-1 => only OMEXC(i) values are used by RESTRAX to plot the branches.
# Otherwise, ICOM refers to the event number in the QOM array
# => ICOM can be used e.g. as an index to internal lookup tables of EXCI etc...
#********************************************************************************
#------------------!! OBLIGATORY !!-------------------------
#// Assign values in the PARAM array to the local model variables
#// if you don't work with the PARAM() array directly
#// REMEMBER: PARAM(1,2) are reserved for Scale and Background
do i=1,nbr
wq(i)=param(4)
enddo
dist=param(3)
#----------------------!! END !! -------------------------
# Orthogonal lattice is supposed !
# get squares of distances from DIR axis for all satellites, calculate SQOM:
do j=1,nbr
do k=1,3
qsat(k) = q(k)-tau(k)-dist*pos(k,j)
enddo
v(1)=qsat(2)*dir(3)-qsat(3)*dir(2)
v(2)=qsat(3)*dir(1)-qsat(1)*dir(3)
v(3)=qsat(1)*dir(2)-qsat(2)*dir(1)
qsq=(v(1)**2+v(2)**2+v(3)**2)/dirsq
sqom(j)=fqsq(j)/wq(j)*exp(-qsq/wq(j)**2) ! gaussian profile
omexc(j) = q(4) ! any energy is allowed
enddo
#20 format(a,6(2x,G10.4))
# write(*,20) 'EXCI, tau: ',(tau(j),j=1,3)
# write(*,20) 'EXCI, dir: ',(dir(j),j=1,3)
# write(*,20) 'EXCI, pos: ',(pos(j,1),j=1,3)
# write(*,20) 'EXCI, qsat: ',(qsat(j),j=1,3)
# write(*,20) 'EXCI, wq: ',(wq(j),j=1,nbr)
# write(*,20) 'EXCI, fqsq: ',(fqsq(j),j=1,nbr),QSQ
# write(*,20) 'EXCI, sqom: ',(sqom(j),j=1,nbr)
# pause
end
#------------------------------------------------------------------------------
SUBROUTINE REPEXCIPAR
# REPORT model ID and input parameters as needed
#------------------------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
# INCLUDE 'inout.inc'
INCLUDE 'exci.inc'
integer*4 i
real*8 tau(3),dir(3),pos(3,6),fqsq(6),wq(6),dist
common /excipar/ tau,dir,pos,fqsq,wq,dist
write(*,*) 'EXCI: '//phontitle
#// Report some model values:
10 format( 'Number of satellites: ',i2)
write(*,10) nbr
11 format( 'Tau: ',3(1x,i3))
write(*,11) (nint(tau(i)),i=1,3)
13 format( 'Direction: ',3(1x,i3))
write(*,13) (nint(dir(i)),i=1,3)
end
#------------------------------------------------------------------------------
SUBROUTINE READEXCIPAR
# Read values of model variables used by EXCI
# Call by RESTRAX when requiared
# File is opened and closed by RESTRAX, don't call OPEN/CLOSE here !!!
#------------------------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
# INCLUDE 'inout.inc'
INCLUDE 'exci.inc'
integer*4 i,k
real*8 width
real*8 tau(3),dir(3),pos(3,6),fqsq(6),wq(6),dist
common /excipar/ tau,dir,pos,fqsq,wq,dist
rewind(excunit) ! call rewind for compatibility with g77
# read model parameters from file
read (excunit,fmt=*,err=998) nbr ! number of satellites (1..6)
if (nbr.gt.6) nbr=6
if (nbr.le.0) nbr=1
read (excunit,*,err=998) width ! width (in r.l.u.)
read (excunit,*,err=998) dist ! distance from DIR axis (direction vectors are listed below)
read (excunit,*,err=998) dir ! direction of "rods" axes (=DIR)
read (excunit,*,err=998) tau ! B.Z. center (=TAU)
do i=1,3
tau(i)=1.d0*nint(tau(i))
enddo
# read fqsq & direction -| to DIR axis for each satellite
do i=1,nbr
read (excunit,*,err=998) fqsq(i),(pos(k,i),k=1,3)
wq(i)=width
enddo
write(*,*) 'Parameters updated from '//phonname
return
998 write(*,*) 'Format error?! Cannot read excitation parameters.'
return
end