src/res_cfg.f

Fortran project RESTRAX, source module src/res_cfg.f.

Source module last modified on Mon, 8 May 2006, 23:39;
HTML image of Fortran source automatically generated by for2html on Mon, 29 May 2006, 15:06.


#//////////////////////////////////////////////////////////////////////
#////
#////  R E S T R A X   4.7
#////
#////  TAS configuration: read and convert parameters
#////   
#////  
#//////////////////////////////////////////////////////////////////////

#----------------------------------------------------
      SUBROUTINE TAS_READCFG(sarg)
# Read *.cfg file
# 1) try CFGNAME
# 2) try 'default.cfg'
# 3) create default 'default.cfg' and read it   
#----------------------------------------------------      
      implicit none

      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      INCLUDE 'res_cfg.inc'
     
      character*(*) sarg
      integer*4 u,iretry,i,ierr,il,n1,n2,ii,ll,ird
      parameter (u=22)
      character*128 line,name
      integer*4 READ_MIRROR
      
100   format(a60) 
101   format(a) 
102   format( 'A new file default.cfg is created in current directory',
     &      ' with default values.')
103   format( 'Cannot find configuration file ',a,//,
     &      'trying default.cfg... ')

201   format(
      'title (max.60 characters) :'/
      'default setup '/
      'source (shape,diameter,width,height):'
      '0   10.   8.     8.  '/
      'n-guide (present, distance,length,hor1,hor2,ver1,ver2,',
      'ro[m-1], gh, gv [Ni nat.], refh, refv):'
      '0  10.  6300.   2.5   2.5   15.   15.  2.4E-4  1  1  1  1'/
      'monochromator (chi,aniz.,poiss.,thick.,height,length,',
      'segments hor. & vert.):'/
      '0.0   1   0.3   0.3   12.0  10.0    1   3 '/
      'analyzer (chi,aniz.,poiss.,thick.,height,length,',
      'segments hor. & vert.):'/
      '0.0   1   0.3   0.3   12.0  10.0    1   3 '/
      'detector (shape,diameter,width,height):'/
      '1    4.0    3.0   5.0'/
      'distances (l1,l2,l3,l4):'/
      '900.  210.  150.  70.'/
      '1st collimator (distance,length,hor1,hor2,ver1,ver2,',
      'ro[m-1], gh, gv [Ni nat.], refh, refv):'
      '236.   534.   8.05    5.   9.05   11.  0.  0.  0.  1   1'/
      '2nd collimator (distance,length,hor1,hor2,ver1,ver2,',
      'ro[m-1], gh, gv [Ni nat.], refh, refv):'
      '87.    35.   4.   4.   7.   7.   0.  0.  0.  1   1'/
      '3nd collimator (distance,length,hor1,hor2,ver1,ver2,',
      'ro[m-1], gh, gv [Ni nat.], refh, refv):'
      '60.    35.   4.   4.   7.    7.  0.  0.  0.  1   1'/
      '4th collimator (distance,length,hor1,hor2,ver1,ver2,',
      'ro[m-1], gh, gv [Ni nat.], refh, refv):'
      '35.    20.   4.   4.  12.   12.  0.  0.  0.  1   1')         
      
      iretry=0
      
      call BOUNDS(sarg,ii,ll) 
      if (ll.gt.0) name=sarg(ii:ii+ll-1)
      select case (ll)
      case(0)  ! empty argument: offer the current file and ask user
        name=cfgname
        ird=1
      case default  ! try argument as the filename
        name=sarg(ii:ii+ll-1)
        ird=0  
      end select
      
1     call OPENRESFILE(name, 'cfg',u,ird,0,name,ierr) 
2     if(ierr.ne.0) then      
         if (name.ne. ' ') then  ! try dialog      
           name= ' '
           goto 1
         else if(name(1:11).ne. 'default.cfg') then  ! try default.cfg
           write(sout,103)
           name= 'default.cfg'
           goto 1
         else if (iretry.eq.0) then  ! create new default.cfg
           write(sout,102)
           iretry=1
           goto 10
         else
           goto 999
         endif  
      endif            
        
      il=0
      read(u,*,err=19)
      il=il+1
      read(u,100,err=19) cfgtitle
      il=il+1
      read(u,*,err=19)
      il=il+1
      tsrc=300.d0
      read(u,101) line
      read(line,*,err=701) nsrc,dsrc,wsrc,hsrc,tsrc
      goto 702
701   read(line,*,err=19) nsrc,dsrc,wsrc,hsrc
      tsrc=0
702   il=il+1
      read(u,*,err=19)
      il=il+1
      read(u,*,err=19) (tas_col(i,1),i=1,12)
      il=il+1
      read(u,*,err=19)
      il=il+1
      read(u,*,err=19) (tas_cry(i,1),i=1,8)
      il=il+1
      read(u,*,err=19)
      il=il+1
      read(u,*,err=19) (tas_cry(i,2),i=1,8)
      il=il+1
      read(u,*,err=19)
      il=il+1
      read(u,*,err=19) ndet,ddet,wdet,hdet
      il=il+1
      read(u,*,err=19)
      il=il+1
      read(u,*,err=19) (tas_dis(i),i=1,4)
      il=il+1
      read(u,*,err=19)
      il=il+1
      read(u,*,err=19) (tas_col(i,2),i=2,12)
      il=il+1
      read(u,*,err=19)
      il=il+1
      read(u,*,err=19) (tas_col(i,3),i=2,12)
      il=il+1
      read(u,*,err=19)
      il=il+1
      read(u,*,err=19) (tas_col(i,4),i=2,12)
      il=il+1
      read(u,*,err=19)
      il=il+1
      read(u,*,err=19) (tas_col(i,5),i=2,12)
      close(u)
      call BOUNDS(name,ii,ll)
      cfgname=name(ii:ii+ll-1)
      goto 50
      
# retry with default.cfg   
19    write(sout,*)  'Error in the configuration file, line ',il+1 
      ierr=1
      goto 2            

# create new default.cfg
10    open(u,file= 'default.cfg',status= 'NEW',err=999)
      write(u,201)
      close(u)
      go to 1
      
# file read, do some converisons      
50    continue
      call BOUNDS(cfgname,i,il)
      write(sout,*)  'Configuration updated: ',cfgname(i:i+il-1)
#     GAMA is in mrad/A
#     RO is in mm^-1
      il=0
      do i=1,5
        tas_col(c_gamah,i)=tas_col(c_gamah,i)*gammani
        tas_col(c_gamav,i)=tas_col(c_gamav,i)*gammani
        tas_col(c_roh,i)=tas_col(c_roh,i)/1000.
        n1=READ_MIRROR(tas_col(c_gamah,i))  ! try to read mirror lookup table
        n2=READ_MIRROR(tas_col(c_gamav,i))
        if(n1.lt.0.or.n2.lt.0) il=-1        
      enddo
# if the mirror lookup table is full, clear the table and read CFG again
      if(il.lt.0) then
        n1=READ_MIRROR(-1.d0)
        goto 1
      endif  

      return

999   write(smes,998)    
998   format( 'Fatal error: cannot create configuration file',/,
      'Check privileges or disk space !')
      stop 
      end
      
#--------------------------------------------------------------------------
      SUBROUTINE TAS_TO_NESS      
#     Conversion of parameters from CFG and RESCAL fields to NESS 
# TAS is defined with inverted primary spectrometer - tracing starts at the sample!
#--------------------------------------------------------------------------
      implicit none

      INCLUDE 'const.inc'      
      INCLUDE 'inout.inc'      
      INCLUDE 'rescal.inc'      
      INCLUDE 'res_cfg.inc'
#      INCLUDE 'ness_common.inc'
      INCLUDE 'restrax.inc'      
      
      logical*4 useguide
      logical*4 emod
      common /mode/ emod
      real*8 ld,dum,ei0,ef0
      integer*4 i
      
#///  general setting: scattering triangle, etc...
      if (tsrc.gt.0) stemp=tsrc
      stp.nfx=res_dat(i_fx)
      stp.sm=res_dat(i_sm)
      stp.ss=res_dat(i_ss)
      stp.sa=res_dat(i_sa)
      stp.kfix=res_dat(i_kfix)
      stp.e=res_dat(i_en)
      call QNORM(res_dat(i_qh),dum,stp.q)           
#                     write(*,*) 'TAS_TO_NESS  1'
      if (res_dat(i_fx).eq.1.) then
         ei0=hsqov2m*res_dat(i_kfix)**2
         ef0=ei0-stp.e
      else
         ef0=hsqov2m*res_dat(i_kfix)**2
         ei0=ef0+stp.e
      end if                 
      if (ei0.le.0.or.ef0.le.0) goto 999
      stp.ki=sqrt(ei0/hsqov2m)
      stp.kf=sqrt(ef0/hsqov2m)      
      
#///  sample:
      smos=res_dat(i_etas)*minute/sqrt8ln2
#                      write(*,*) 'TAS_TO_NESS  2'
      sam.name= 'sample'      
      sam.shape=1
      sam.dist=0.
      sam.axi=0.
      do i=1,3
        sou.sta(i)=0.
        sou.gon(i)=0.
      enddo
      sam.size(1)=res_dat(i_sdi)*10.
      sam.size(3)=res_dat(i_sdi)*10.
      sam.size(2)=res_dat(i_shi)*10.
      
#///  Soller collimators
      guide.frame.name= 'guide' 
      sol1.frame.name= 'col1'
      sol2.frame.name= 'col2'   
      sol3.frame.name= 'col3'
      sol4.frame.name= 'col4'   
#xxxxxxxxxCxxxxxxxxxCxxxxxxxxxCxxxxxxxxxCxxxxxxxxxCxxxxxxxxxCxxxxxxxxxCx            
      
      
      ld=tas_col(c_dist,2)+tas_col(c_len,2)
      call CREATE_COL(sol1,2,tas_dis(1)-ld,-1,0)
      useguide=(tas_col(c_use,1).gt.0.and.tas_col(c_len,1).gt.0)
      if (useguide) then
         call CREATE_COL(guide,1,ld,-1,0)
      else
         call CREATE_COL(guide,1,1.d0,-1,0)
      endif    
#                      write(*,*) 'TAS_TO_NESS  3'
      ld=tas_dis(2)-tas_col(c_dist,3)-tas_col(c_len,3)
      call CREATE_COL(sol2,3,ld,-1,0)
#                      write(*,*) 'TAS_TO_NESS  4'
      call CREATE_COL(sol3,4,tas_col(c_dist,4),1,0)
#                      write(*,*) 'TAS_TO_NESS  5'
      call CREATE_COL(sol4,5,tas_col(c_dist,5),1,0)
#                      write(*,*) 'TAS_TO_NESS  6'
      

#///  monochromator:
      mon.frame.name= 'monochromator' 
      call CREATE_CRY(mon,1,tas_dis(2)-sol2.frame.dist/10.,-1)  
#                      write(*,*) 'TAS_TO_NESS  7'
      if (stp.sm.lt.0) then 
        mon.frame.gon(1)=mon.thb-mon.chi+pi/2
        sol1.frame.axi=mon.thb*2.
      else if (stp.sm.gt.0) then 
        mon.frame.gon(1)=-mon.thb-mon.chi-pi/2
        sol1.frame.axi=-mon.thb*2.
      else 
        mon.frame.gon(1)=0.    ! if SM=0, then a filter is considered instead of the analyzer
        mon.thb=0.             ! CRYST_GO recognizes this case if THB=0
        sol1.frame.axi=0.      ! dhkl determines the edge position, kc=pi/dhkl
        mon.chi=pi/2.  
        mon.rh=0. 
        mon.rv=0.
        mon.hmos=0.
        mon.vmos=0.
      endif                                 
# set index where crystal takes random numbers from /RAND/ X array      
      mon.dnrnd=7

#///  source:
      sou.name= 'source'   
      if(nsrc.eq.0) then
        sou.shape=2
        sou.size(1)=dsrc*10.
        sou.size(2)=dsrc*10.
        sou.size(3)=0.1
      else
        sou.shape=3
        sou.size(1)=wsrc*10.
        sou.size(2)=hsrc*10.
        sou.size(3)=0.1
      endif
      sou.axi=0.
      if (useguide) then
        sou.dist=(tas_col(c_dist,1)+tas_col(c_len,1))*10.
      else 
# SOU.DIST is measured between SOURCE and GUIDE exit  
# TAS_DIS(1) is measured between GUIDE exit and SOL1 entry
        sou.dist=(tas_col(c_dist,2)+tas_col(c_len,2))*10.
        sou.dist=sou.dist-guide.frame.dist     
      endif
      do i=1,3
        sou.sta(i)=0.
        sou.gon(i)=0.
      enddo

      
#///  analyzer:
      ana.frame.name= 'analyzer'   
#      write(*,*) 'TAS_TO_NESS ',(TAS_CRY(I,2),I=1,8)
      call CREATE_CRY(ana,2,tas_dis(3)-sol3.frame.dist/10.,1)        
#                      write(*,*) 'TAS_TO_NESS  8'
      if(stp.sa.eq.0) then
          ana.frame.gon(1)=0.    ! if SA=0, then a filter is considered instead of the analyzer
          ana.thb=0.             ! CRYST_GO recognizes this case if THB=0
          sol4.frame.axi=0.      ! dhkl determines the edge position, kc=2*pi/dhkl
          ana.chi=pi/2.  
          ana.rh=0. 
          ana.rv=0. 
          ana.hmos=0
          ana.vmos=0
      else if(cfgmode.eq.1) then     ! Option with scondary spectrometer turned up   
        if (stp.sa.gt.0) then 
          ana.frame.gon(1)=pi/2
          ana.frame.gon(2)=-pi/2
          ana.frame.gon(3)=ana.thb-ana.chi
          sol4.frame.axi=0
          sol4.frame.axv=-ana.thb*2.
        else if (stp.sa.lt.0) then 
          ana.frame.gon(1)=-pi/2
          ana.frame.gon(2)=+pi/2
          ana.frame.gon(3)=-ana.thb+ana.chi
          sol4.frame.axi=0
          sol4.frame.axv=ana.thb*2.
        endif       
      else
        ana.frame.gon(2)=0
        ana.frame.gon(3)=0
        if (stp.sa.gt.0) then 
          ana.frame.gon(1)=ana.thb-ana.chi+pi/2.
          sol4.frame.axi=ana.thb*2.
          sol4.frame.axv=0
        else if (stp.sa.lt.0) then 
          ana.frame.gon(1)=-ana.thb-ana.chi-pi/2.
          sol4.frame.axi=-ana.thb*2.
          sol4.frame.axv=0
        endif  
      endif
# set index where crystal takes random numbers from /RAND/ X array      
      ana.dnrnd=8
            
#///  dector:
      det.name= 'detector'   
      if(ndet.eq.0) then
        det.shape=2
        det.size(1)=ddet*10.
        det.size(2)=ddet*10.
        det.size(3)=0.1
      else
        det.shape=3
        det.size(1)=wdet*10.
        det.size(2)=hdet*10.
        det.size(3)=0.1
      endif
      det.axi=0.
      det.dist=tas_dis(4)*10.-sol4.frame.dist
      do 30 i=1,3
        det.sta(i)=0.
        det.gon(i)=0.
30    continue
                                      
      if((stp.sm.eq.0).or.(stp.sa.eq.0)) then
         stp.e=hsqov2m*(stp.ki**2-stp.kf**2)             
      endif 
      sol2.bint=stp.tauf*hovm**2*stp.ki**3/2.d0/gammal*1.d7
      sol3.bint=stp.tauf*hovm**2*stp.kf**3/2.d0/gammal*1.d7
      mon.typ=0
      if(emod) then
        ana.typ=1      
      else
        ana.typ=0
      endif
#                      write(*,*) 'TAS_TO_NESS  9'
      call SPEC_INITALL     !   Initialize all TAS components  
#        write(*,*) 'TAS_TO_NESS'
#        CALL WRITE_SETUP(20)      
#                      write(*,*) 'TAS_TO_NESS  OK'
      return
      
999   write(smes,*)  'CHECK SCATTERING TRIANGLE !!!'
      end

#---------------------------------------------------------        
      SUBROUTINE CREATE_CRY(cr,ic,cdist,dir)
# CR ... structure of CRYSTAL type
# IC  ... index of the component (1=mono, 2=anal)
# CDIST ... distance in [cm] !!
# DIR ... direction downstream >0 or up-stream <0
#---------------------------------------------------------        
      implicit none

      INCLUDE 'const.inc'      
      INCLUDE 'inout.inc'      
      INCLUDE 'rescal.inc'
      INCLUDE 'restrax.inc'
      INCLUDE 'res_cfg.inc'

      integer*4 ic,dir
      real*8 cdist
      
      record /CRYSTAL/ cr
      
#///  monochromator:
      cr.frame.shape=3
      cr.frame.size(1)=tas_cry(c_x,ic)*10.
      cr.frame.size(2)=tas_cry(c_y,ic)*10.
      cr.frame.size(3)=tas_cry(c_z,ic)*10.
      cr.frame.dist=cdist*10.
      cr.frame.axi=0.
      cr.chi=-dir*tas_cry(c_chi,ic)*deg
      cr.dhkl=res_dat(i_dm+ic-1)
#      write(*,*) 'CREATE ',CR.FRAME.NAME(1:6),CR.DHKL,STP.KI,STP.KF
      
      if (ic.eq.1) then          
        cr.thb=asin(pi/cr.dhkl/stp.ki)
        cr.lambda=2*pi/stp.ki
      else
        cr.thb=asin(pi/cr.dhkl/stp.kf)
        cr.lambda=2*pi/stp.kf
      endif
          
      cr.rh=res_dat(i_romh+(ic-1)*2)/1000.
      cr.rv=res_dat(i_romv+(ic-1)*2)/1000.
      cr.hmos=res_dat(i_etam+ic-1)*minute/sqrt8ln2
      cr.vmos=cr.hmos*tas_cry(c_ani,ic)
      cr.poi=tas_cry(c_poi,ic)
      cr.vol=1.6016
      cr.fhkl=2.3527
      cr.mi=0.d0    ! absorption is neglected      
      cr.nh=nint(tas_cry(c_nh,ic))
      cr.nv=nint(tas_cry(c_nv,ic))  
      
      end

#---------------------------------------------------------        
      SUBROUTINE CREATE_COL(sol,ic,cdist,dir,pol)
# SOL ... structure of BENDER type
# IC  ... index of the component (1=guide .. 5=SOL4)
# CDIST ... distance in [cm] !!
# DIR ... direction downstream >0 or up-stream <0
# POL ... polarization (0 means no polarization)    
#---------------------------------------------------------        
      implicit none

      INCLUDE 'const.inc'      
      INCLUDE 'inout.inc'      
      INCLUDE 'rescal.inc'
      INCLUDE 'restrax.inc'
      INCLUDE 'res_cfg.inc'
      
      integer*4 i,ic,dir,pol,READ_MIRROR,n1,n2
      record /BENDER/ sol
      real*8 z,cdist,lng,a,b
      
      
      sol.curv=tas_col(c_roh,ic)
      sol.ghlu=tas_col(c_gamah,ic)
      sol.ghru=tas_col(c_gamah,ic)
      if (pol.eq.0) then 
         sol.ghld=tas_col(c_gamah,ic)
         sol.ghrd=tas_col(c_gamah,ic)
      else
         sol.ghld=0
         sol.ghrd=0
      endif     
      sol.gvt=tas_col(c_gamav,ic)
      sol.gvb=tas_col(c_gamav,ic)
      sol.rhlu=tas_col(c_refh,ic)
      sol.rhld=tas_col(c_refh,ic)
      sol.rhru=tas_col(c_refh,ic)
      sol.rhrd=tas_col(c_refh,ic)
      sol.rvt=tas_col(c_refv,ic)
      sol.rvb=tas_col(c_refv,ic)
      n1=READ_MIRROR(tas_col(c_gamah,ic))
      n2=READ_MIRROR(tas_col(c_gamav,ic))
      sol.nhlu=n1
      sol.nhld=n1
      sol.nhru=n1
      sol.nhrd=n1
      sol.nvt=n2
      sol.nvb=n2 
      sol.frame.axi=0.
      sol.frame.axv=0.
      do 10 i=1,3
        sol.frame.sta(i)=0.
        sol.frame.gon(i)=0.
10    continue          
      sol.frame.shape=3
      sol.frame.dist=cdist*10.
      if (dir.gt.0) then
        sol.frame.size(1)=tas_col(c_hor1,ic)*10.
        sol.frame.size(2)=tas_col(c_ver1,ic)*10.
        sol.w2=tas_col(c_hor2,ic)*10.
        sol.h2=tas_col(c_ver2,ic)*10.      
      else
        sol.frame.size(1)=tas_col(c_hor2,ic)*10.
        sol.frame.size(2)=tas_col(c_ver2,ic)*10.
        sol.w2=tas_col(c_hor1,ic)*10.
        sol.h2=tas_col(c_ver1,ic)*10.      
      endif
        
      sol.frame.size(3)=tas_col(c_len,ic)*10.
      sol.nlv=1
      sol.dlh=0.08
      sol.dlv=0.08
      
      
      lng=sol.frame.size(3)    
      if (ic.eq.1) then 
        if (tas_col(c_use,ic).le.0) then
           a=0
           b=0
        else
           a=1000.
           b=1000.
        endif    
      else
         a=res_dat(i_alf1+ic-2)   
         b=res_dat(i_bet1+ic-2)   
      endif   
      if((a.gt.0).and.(lng.gt.0)) then      
         if(a.lt.500.) then
             z=lng*2.0*(a*minute+sol.dlh/lng)
             sol.nlh=nint((sol.frame.size(1)+sol.w2)/z)
         else
             sol.nlh=1
         endif        
         if(sol.nlh.le.0) sol.nlh=1
         if (b.gt.0.and.b.lt.500) then
             z=lng*2.0*(b*minute+sol.dlv/lng)
             sol.nlv=nint((sol.frame.size(2)+sol.h2)/z) 
         endif
      else
          sol.frame.size(1)=1000.
          sol.frame.size(2)=1000.
          sol.frame.size(3)=0.
          sol.w2=sol.frame.size(1)
          sol.h2=sol.frame.size(2)
          sol.nlh=1
          sol.nlv=1          
      endif  
      
      return
      end              

        
#----------------------------------------------------
      SUBROUTINE TAS_TO_TRAX
# Convert RESTRAX data to TRAX arrays
#----------------------------------------------------      
      implicit none

      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      INCLUDE 'rescal.inc'
      INCLUDE 'restrax.inc'
      INCLUDE 'trax.inc'
      real*8 dum
      integer*4 i
      logical*4 useguide
 
# scattering triangle
      homega=res_dat(i_en)
      if (res_dat(i_fx).eq.1.) then
         nefix=1
         ei0=res_dat(i_kfix)**2*hsqovm/2.
         ef0=ei0-homega
      else
         nefix=2
         ef0=res_dat(i_kfix)**2*hsqovm/2.
         ei0=ef0+homega
      end if                 
      if (ei0.le.0.or.ef0.le.0) goto 999
      vki=sqrt(ei0*2./hsqovm)
      vkf=sqrt(ef0*2./hsqovm)

      call QNORM(res_dat(i_qh),dum,vq0)           
         
#
      ets=res_dat(i_etas)
      if (ets.eq.0.) ets=0.00833333    
      hisam=0.
      his=hisam*tdr
      isc=res_dat(i_ss)
      nsam=0
      diasam=res_dat(i_sdi)
      wsam=res_dat(i_sdi) 
      thsam=res_dat(i_sdi) 
      hsam=res_dat(i_shi)
      if (diasam.eq.0) diasam=0.01
      if (hsam.eq.0) hsam=0.01
       
#
      etm=res_dat(i_etam)
      if (etm.eq.0.) etm=0.00833333
      himon=mon.chi/tdr
      if (mon.hmos.gt.0) then
        anrm=mon.vmos/mon.hmos
      else
        anrm=1
      endif 
      wmon=mon.frame.size(1)/10.
      hmon=mon.frame.size(2)/10.
      thmon=mon.frame.size(3)/10.         
      rohm=res_dat(i_romh)/100.
      rovm=res_dat(i_romv)/100.
      cryd(1)=res_dat(i_dm)
      poiss(1)=mon.poi
      im=nint(res_dat(i_sm))

#  analyzer
      eta=res_dat(i_etaa)
      if (eta.eq.0.) eta=0.00833333     
      hiana=-ana.chi/tdr
      if (ana.hmos.gt.0) then
        anra=ana.vmos/ana.hmos
      else
        anra=1
      endif    
      wana=ana.frame.size(1)/10.
      hana=ana.frame.size(2)/10.
      thana=ana.frame.size(3)/10.         
      roha=res_dat(i_roah)/100.
      rova=res_dat(i_roav)/100.    
      cryd(2)=res_dat(i_da)
      poiss(2)=ana.poi
      ia=res_dat(i_sa)

#  source
      if(sou.shape.eq.2) then
        nsou=0
        diasou=sou.size(1)/10.
      else
        nsou=1
        diasou=sou.size(1)/10.
        wsou=sou.size(1)/10.
        hsou=sou.size(2)/10.
      endif  
      srctemp=stemp
#  detector
      if(det.shape.eq.2) then
        ndet=0
        diadet=det.size(1)/10.
      else
        ndet=1
        diadet=det.size(1)/10.
        wdet=det.size(1)/10.
        hdet=det.size(2)/10.
      endif  
      
# neutron guide:
      useguide=(guide.ghlu.gt.0.and.guide.frame.size(3).gt.0)
      if (useguide) then 
         gamacr=guide.ghlu
         nguide=1
      else
         nguide=0
         gamacr=0
      endif
      
#  Soller collimators
      do i=1,4
        alpha(i)=res_dat(i+i_alf1-1)
        beta(i)=res_dat(i+i_bet1-1)
      enddo  
           
# ////   if ALPHA(I)<500  then the coarse collimator is ignored
# ////   if ALPHA(I)>=500 then the Soller collimator is ignored 
# ////   if ALPHA(I)=0 then no collimation is considered

      nfm=-1
      nfs=-1
      nfa=-1
      nfd=-1
      if (alpha(1).ge.500.) then
        alpha(1)=0.
        nfm=1
      end if
      if (alpha(2).ge.500.) then
        alpha(2)=0.
        nfs=1
      end if
      if (alpha(3).ge.500.) then
        alpha(3)=0.
        nfa=1
      end if
      if (alpha(4).ge.500.) then
        alpha(4)=0.
        nfd=1
      end if

# distances
      if (guide.frame.size(3).gt.0) then
         vl0=(sol1.frame.dist+guide.frame.dist)/10.
      else
         vl0=(sol1.frame.dist+guide.frame.dist+sou.dist)/10.            
      endif
      vl1=(sol2.frame.dist+mon.frame.dist)/10.
      vl2=(sol3.frame.dist+ana.frame.dist)/10.
      vl3=(sol4.frame.dist+det.dist)/10.
# collimator 1
      if (sol1.frame.size(3).le.0) then
         nfm=-1
      else
         nfm=1
         vlsm=sol1.frame.size(3)/10.
         hdm1=sol1.w2/10.
         hdm2=sol1.frame.size(1)/10.
         vdm1=sol1.h2/10.
         vdm2=sol1.frame.size(2)/10.
         vlcanm=vl0-(sol1.frame.size(3)+sol1.frame.dist)/10.
      endif   

# collimator 2
      if (sol2.frame.size(3).le.0) then
         nfs=-1
      else
         nfs=1
         vlms=sol2.frame.size(3)/10.
         hds1=sol2.w2/10.
         hds2=sol2.frame.size(1)/10.
         vds1=sol2.h2/10.
         vds2=sol2.frame.size(2)/10.
         vlcans=(mon.frame.dist-sol2.frame.size(3))/10.
      endif   
      
# collimator 3
      if (sol3.frame.size(3).le.0) then
         nfa=-1
      else
         nfa=1
         vlsa=sol3.frame.size(3)/10.
         hda1=sol3.frame.size(1)/10.
         hda2=sol3.w2/10.
         vda1=sol3.frame.size(2)/10
         vda2=sol3.h2/10.
         vlcana=sol3.frame.dist/10.
      endif   
# collimator 4
      if (sol4.frame.size(3).le.0) then
         nfd=-1
      else
         nfd=1
         vlad=sol4.frame.size(3)/10.
         hdd1=sol4.frame.size(1)/10.
         hdd2=sol4.w2/10.
         vdd1=sol4.frame.size(2)/10
         vdd2=sol4.h2/10.
         vlcand=sol4.frame.dist/10.
      endif   
      
      if (vlsm.le.0) nfm=-1
      if (vlms.le.0) nfs=-1
      if (vlsa.le.0) nfa=-1
      if (vlad.le.0) nfd=-1
      
      return
      
999   write(smes,*)  'CHECK SCATTERING TRIANGLE !!!'
     
      end