exci/res_exci_incom.f

Fortran project RESTRAX, source module exci/res_exci_incom.f.

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