src/ness/ness_3ax.f

Fortran project SIMRES, source module src/ness/ness_3ax.f.

Source module last modified on Sat, 21 May 2005, 19:42;
HTML image of Fortran source automatically generated by for2html on Mon, 23 May 2005, 21:29.


#//////////////////////////////////////////////////////////////////////
#////                                                              ////
#////  NEutron Scattering Simulation - v.1.2, (c) J.Saroun, 1997   ////
#////   update May 1998 (J.S.)                                     ////
#//////////////////////////////////////////////////////////////////////
#////
#////  Subroutines specific to 3-axis spectrometers and conversion
#////  from the RESTRAX-parameter set.
#////
#////  * SUBROUTINE SET_3AX(ICOM)
#////  * LOGICAL*4 FUNCTION SPEC_GO(ICOM)
#////  * SUBROUTINE SPEC_INI(ICLR,IRES)
#////  * SUBROUTINE NESS_CONV
#////  * SUBROUTINE CREATE_SOL(SOL1,ALPHA,NFM,VLSM,VLCANM,HDM1,HDM2,
#////                          VDM1,VDM2)
#////  * SUBROUTINE WRITE_SETUP(IC)
#////
#////  May 1998:         SOLLERs replaced by BENDERs in all subroutines and commons
#////                  SET_3AX(2) sets values of critical angles for BENDERs
#////              SET_3AX(3) sets values of BENDERs radii
#////              SET_3AX(4) switch on/off spin flippers
#////              SET_3AX(5) switch on/off magnetization of crystals
#//////////////////////////////////////////////////////////////////////
#***  bug fixed:  GUIDE=2*GAMACR   replaced by GUIDE=GAMACR*MON.LAMBDA
#***  (25/5/98 by J.S.)


#----------------------------------------------------------------
      SUBROUTINE SET_3AX(icom)
#     changes sample position (with a possibility to add
#     other parameters not included in RESTRAX3 parameter set.
#     Can be called by the RESTRAX main program as well as by
#     the NESS interactive command interpreter (NESS_LOOP)
#----------------------------------------------------------------
      implicit none
      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      INCLUDE 'structures.inc'
      INCLUDE 'ness_common.inc'
      INCLUDE 'collimators.inc'
      INCLUDE 'source.inc'
      INCLUDE 'rescal.inc'
#      INCLUDE 'trax.inc'

      integer*4 icom,npar,ndpar
      parameter(ndpar=16)
      real*4   param(ndpar)
      integer*4 i,i1,i2
      character*4 s1,s2
 


#      WRITE(*,*) 'SET_3AX: ',ICOM,NOS
      if(nos.gt.0.and.nos.le.ndpar) then
          do i=1,nos
             param(i)=ret(i)
          end do
      endif
      npar=nos
#      WRITE(*,*) 'SET_3AX: ',ICOM,NPAR,(PARAM(I),I=1,NPAR)


      if(icom.eq.1) then
1       format( ' sample position [mm]:             ',3(2x,f7.2))
        if(npar.ge.2) sam.sta(1)=param(2)
        if(npar.ge.3) sam.sta(2)=param(3)
        if(npar.ge.1) sam.sta(3)=param(1)
        param(2)=sam.sta(1)
        param(3)=sam.sta(2)
        param(1)=sam.sta(3)
        write(sout,1) (param(i),i=1,3)
      endif

      if(icom.eq.3) then
3       format( ' crystal rocking angles [min]:     ',2(2x,f10.4))
#        WRITE(SOUT,*) 'Command not available'
#       RETURN
        if(npar.ge.1) dthax(1)=param(1)
        if(npar.ge.2)  dthax(5)=param(2)
        param(1)= dthax(1)
        param(2)= dthax(5)
        write(sout,3) (param(i),i=1,2)
      endif

      if(icom.eq.4) then
4       format( ' Spin flippers :  ',2(3x,a4))
        if(npar.ge.1) flipm=nint(param(1))
        if(npar.ge.2) flipa=nint(param(2))
        param(1)=flipm
        param(2)=flipa
        s1= 'off '
        s2= 'off '
        if (flipm.gt.0) s1= 'on  '
        if (flipa.gt.0) s2= 'on  '
        write(sout,4) s1,s2
      endif

      if(icom.eq.5) then
5       format( ' Magnetization :  ',2(3x,a4))
        if(npar.ge.1) mon.mag=param(1)
        if(npar.ge.2) ana.mag=param(2)
        param(1)=mon.mag
        param(2)=ana.mag
        s1= 'off '
        s2= 'off '
        if (mon.mag.gt.0) s1= 'on  '
        if (ana.mag.gt.0) s2= 'on  '
        write(sout,5) s1,s2
      endif

      if(icom.eq.6) then
6       format( ' Spin transfer :  ',a4, ' -> ',a4)
61      format( ' Spin transfer :   all')
        i1=mod(nint(spint),2)
        i2=int(spint/2)
        if(npar.ge.1) i1=nint(param(1))
        if(npar.ge.2) i2=nint(param(2))
        if((i1.eq.0.or.i1.eq.1).and.(i2.eq.0.or.i2.eq.1)) then
           s1= 'up  '
           s2= 'up  '
           if (i1.eq.0) s1= 'down'
           if (i2.eq.0) s2= 'down'
           write(sout,6) s1,s2
           spint=i1+2*i2
         else
           spint=-1
           write(sout,61)
        endif
      endif
      if(icom.eq.7) then
7       format( ' POLARIZING BENDERS:   ',4(2x,i1))
        if(npar.ge.1) polar(3)=param(1)
        if(npar.ge.2) polar(5)=param(2)
        if(npar.ge.3) polar(6)=param(3)
        if(npar.ge.4) polar(7)=param(4)
        do i=1,4
           param(i)=0
        enddo
        if (polar(3).ne.0) param(1)=1
        if (polar(5).ne.0) param(2)=1
        if (polar(6).ne.0) param(3)=1
        if (polar(7).ne.0) param(4)=1
        write(sout,7) (nint(param(i)),i=1,4)
      endif

      if(icom.eq.8) then

81       format( ' Crystal name: ',$)
82       format(a8)
        if (npar.gt.0.and.(param(1).eq.1).or.(param(1).eq.2)) then
          if (param(1).eq.1) then        
              write(sout,81)
            read(sinp,82)  mon.frame.name
          else if  (param(1).eq.2) then
              write(sout,81)
            read(sinp,82)  ana.frame.name
          endif
        endif
        call SET_CRYST(mon.frame.name(1:8),ana.frame.name(1:8))
      endif        

      if(icom.eq.9) then
9       format( ' Oscilating colimators:   ',4(2x,i1))
        if(npar.ge.1) osc(3)=(param(1).ne.0)
        if(npar.ge.2) osc(5)=(param(2).ne.0)
        if(npar.ge.3) osc(6)=(param(3).ne.0)
        if(npar.ge.4) osc(7)=(param(4).ne.0)
        do i=1,4
           param(i)=0
        enddo
        if (osc(3)) param(1)=1
        if (osc(5)) param(2)=1
        if (osc(6)) param(3)=1
        if (osc(7)) param(4)=1
        write(sout,9) (nint(param(i)),i=1,4)
      endif

      if(icom.eq.2) then
2       format( 'monochromator: '/,
     *          ' d-gradient  [0.001/cm]: ',g13.5,/,
     *          ' grad. angle  [deg]    : ',g13.5,/,
     *          ' lamella thickness [um]: ',g13.5)
        if(npar.ge.1) mon.dgr=param(1)
        if(npar.ge.2) mon.dga=param(2)*pi/180
        if(npar.ge.3) mon.dlam=param(3)
        write(sout,2) mon.dgr,mon.dga/pi*180,mon.dlam
      endif
      if(icom.eq.21) then
21       format( 'analyzer: '/,
     *           ' d-gradient  [0.001/cm]: ',g13.5,/,
     *           ' grad. angle  [deg]    : ',g13.5,/,
     *           ' lamella thickness [um]: ',g13.5)
        if(npar.ge.1) ana.dgr=param(1)
        if(npar.ge.2) ana.dga=param(2)*pi/180
        if(npar.ge.3) ana.dlam=param(3)
        write(sout,21) ana.dgr,ana.dga/pi*180,ana.dlam
      endif

      if(icom.eq.10) then
10      format( ' dI/dx   [%/cm] : ',g13.5,/,
     *          ' d2I/dx2 [%/cm2]: ',g13.5,/,
     *          ' centre  [cm]   : ',g13.5)
        if(npar.ge.1) flxa=param(1)/1000
        if(npar.ge.2) flxb=param(2)/10000
        if(npar.ge.3) flx0=param(3)*10
        write(sout,10) flxa*1000,flxb*10000,flx0/10
      endif
      if(icom.eq.11) then
11      format( ' dI/dy   [%/cm] : ',g13.5,/,
     *          ' d2I/dy2 [%/cm2]: ',g13.5,/,
     *          ' centre  [cm]   : ',g13.5)
        if(npar.ge.1) flya=param(1)/1000
        if(npar.ge.2) flyb=param(2)/10000
        if(npar.ge.3) fly0=param(3)*10
        write(sout,10) flya*1000,flyb*10000,fly0/10
      endif

      if(icom.eq.12) then
120       format( ' Analyzer part is in normal position')
121      format( ' Analyzer part is turned up')
122      format( ' Analyzer part is turned down')
123      format( ' Analyzer part is turned up/down')
        if(npar.ge.1) then
           if (param(1).eq.1) then
               cfgmode=1
           else
               cfgmode=0
           endif
        endif
        if (cfgmode.eq.0) write(sout, 120)
        if (cfgmode.eq.1.and.res_dat(i_sa).gt.0) write(sout,121) 
        if (cfgmode.eq.1.and.res_dat(i_sa).lt.0) write(sout,122)
        if (cfgmode.eq.1.and.res_dat(i_sa).eq.0) write(sout,123)         
      endif
      
      if(icom.eq.13) then
130      format( ' Normal mode')
131       format( ' Simulation in E=const. plane')
        if (emode.ne.0) emode=1
        if(npar.ge.1) then
           if (param(1).eq.1) then
               emode=1
           else
               emode=0
           endif
        endif
        if (emode.eq.0) write(sout, 130)
        if (emode.eq.1) write(sout,131) 
      endif
      
      do i=1,nos
         ret(i)=param(i)
      end do
      nos=0


      return
      end
#---------------------------------------------------------------
      SUBROUTINE SET_CRYST(namem,namea)
#---------------------------------------------------------------
      implicit none
      INCLUDE 'inout.inc'
      INCLUDE 'structures.inc'
      INCLUDE 'ness_common.inc'
      INCLUDE 'rescal.inc'
      
      character*8 namem,namea

83    format( ' Monochromator: ',a8, '   Analyzer: ',a8)

      if(namem(1:1).ne. ' ') mon.frame.name=namem        
      if(namea(1:1).ne. ' ') ana.frame.name=namea
      if(namem(1:1).ne. ' '.or.namea(1:1).ne. ' ') then
        write(sout,83) mon.frame.name(1:8), ana.frame.name(1:8)
      endif        
        call READCRYST(mon,mon.frame.name(1:8))
        call READCRYST(ana,ana.frame.name(1:8))
        if(mon.vol.ne.0) res_dat(i_dm)=mon.dhkl
        if(ana.vol.ne.0) res_dat(i_da)=ana.dhkl
      end

#----------------------------------------
      logical*4 FUNCTION CHECKPARAM()
#-----------------------------------------
      implicit none
      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      INCLUDE 'rescal.inc'

      real*8 l1,l2,kfix,fx,en
      logical*4 log
      
      kfix=res_dat(i_kfix)
      fx=res_dat(i_fx)
      en=res_dat(i_en)
      
      log=.true.
      if (fx.eq.1.) then
         l1=2.*pi/kfix
         if(kfix**2-en/hsqov2m.gt.0.d0) then
           l2=2.*pi/sqrt(kfix**2-en/hsqov2m)
         else
           log=.false.
           write(smes,*)  'Energy transfer too large'
           write(smes,*)  'KI=',kfix, ' E/hsqov2m=',en/hsqov2m
           goto 100         
         endif
      else
         l2=2.*pi/kfix
         if(kfix**2+en/hsqov2m.gt.0.d0) then
           l1=2.*pi/sqrt(kfix**2+en/hsqov2m)
         else
           log=.false.
           write(smes,*)  'Energy transfer too large'
           write(smes,*)  'KF=',kfix, ' E/hsqov2m=',en/hsqov2m
           goto 100         
         endif
      endif

      if (l1.ge.2.*res_dat(i_dm)) then 
         write(smes,*)  'monochromator dhkl too large!'
         write(smes,*)  'lambda=',l1, ' 2d=',2.*res_dat(i_dm)
         log=.false.
         goto 100
      endif
      if (l2.ge.2.*res_dat(i_da)) then 
         write(smes,*)  'analyzer dhkl too large!'
         write(smes,*)  'lambda=',l2, ' 2d=',2.*res_dat(i_da)
         log=.false.
         goto 100
      endif

      
100   CHECKPARAM=log      
      end 
      


#---------------------------------------------------------------
      SUBROUTINE LOG_EVENT(neu)
#---------------------------------------------------------------
      implicit none
      INCLUDE 'structures.inc'
      record /NEUTRON/ neu
      end

#--------------------------------------------------------
      SUBROUTINE SPEC_INI(iclr,itask)
#     Clears all necessary variables and, if ICLR<>1,
#     initializes objects and limits of random variables
#    
#  ITASK=1 ... inelastic scattering, TAS resolution
#  ITASK=2 ... sample -> source
#  ITASK=3 ... source -> sample
#  ITASK=4 ... sample -> source + sample(powder) -> detector (no analyser)
#  ITASK=5 ... source -> sample + sample(powder) -> detector (no analyser)
#  ITASK=6 ... sample -> source + sample (Vanad) -> monitor(IMONIT)
#  ITASK=7 ... source -> monitor(IMONIT)
#  ITASK=8 ... inelastic scattering, TAS resolution, splitted TAS1 and TAS2 
#  ITASK=9 ... elastic (powder) resolution function
#  ITASK=10 ... powder (ITASK=4), splitted TAS1 and TAS2  
#  ITASK=11 ... source -> detector, Bragg scattering (or double-crystal for Q=0)
#--------------------------------------------------------
      implicit none

      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      INCLUDE 'structures.inc'
      INCLUDE 'ness_common.inc'
      INCLUDE 'rescal.inc'
      INCLUDE 'randvars.inc'

      integer*4 i,j,iclr,itask
      real*8 a1,a2,a3,ahmin,avmin,ctm,ah2,av2,c2ts
      real*8 lms,lsa,cta,z,z1,sgnm,sgna,stmch,stach
      real*8 b89
      real*8 wmax,hmax,band
#      REAL*8 AUX(CRND,CRND),DETERM
      record /STATI/ cov_qe
 
      integer*4 ierr,nev

      common /errors/ ierr
      common /result/ cov_qe
      logical*4 verbose
      common /mcsetting/ verbose,nev
      real*8 GETEFFMOS,thm

 
#      write(*,*) 'SPEC_INI(ICLR,ITASK)',ICLR,ITASK

      call STAT_CLR(4,cov_qe)

      sou.count=0
      gdea.frame.count=0
      guide.frame.count=0
      sol1.frame.count=0
      mon.frame.count=0
      sol2.frame.count=0
      sol2a.frame.count=0
      sam.count=0
      sol3.frame.count=0
      ana.frame.count=0
      sol4.frame.count=0
      det.frame.count=0

      if (iclr.eq.1) then
         return
      endif

#// Reconfigure setup in special cases:
#// Powder diffractometer -> skip analyzer and SOL4 
      if (itask.eq.4.or.itask.eq.5.or.itask.eq.9) 
     *    det.frame.dist=ana.frame.dist+sol4.frame.dist+det.frame.dist

#// set number of random values            
      if(itask.eq.1.or.itask.eq.8) then
         rndlist.dim=9
         if (emode.eq.1) rndlist.dim=8
      endif   
      if(itask.eq.2.or.itask.eq.3.or.itask.eq.11) rndlist.dim=6
      if(itask.eq.4.or.itask.eq.5) rndlist.dim=7
      if(itask.eq.6.or.itask.eq.7.or.itask.eq.9) rndlist.dim=8
      if(itask.eq.7.and.imonit.le.7) rndlist.dim=6
      
      do 30 i=1,rndlist.dim
          rndlist.mean(i)=0.d0
          rndlist.pool(i)=1.1d0
          rndlist.active(i)=1
30    continue

#// set time variable inactive
      rndlist.active(6)=0
      rndlist.limits(6)=1.d0
      rndlist.pool(6)=1d0

#// initialize transformation matrix
      do 80 i=1,crnd
      do 80 j=1,crnd
         if (i.ne.j) then
            tmat(i,j)=0.d0
         else
            tmat(i,j)=1.d0
         endif
80    continue
      do i=1,rndlist.dim
            tmean(i)=0.d0
      enddo
      
#// Set mean ki value
      sgnm=-sign(1,stp.sm)  ! "minus" because of the up-stream tracing
      thm=abs(mon.frame.gon(1)-sgnm*pi/2.+mon.chi)
      tmean(3)=pi/mon.dhkl/sin(thm)
        
# ******************************************************
#                                                      *
#                  PRIMARY SPECTROMETER                *
#                                                      *
# ******************************************************

#// Call another initialization procedure for the simulation started 
#// from the source
      if(itask.eq.3.or.itask.eq.5.or.itask.eq.7.or.ftas.gt.0) then
         call FORW_INI(itask)         
      else
      
#// Initialize components 
      call SLIT_INIT(sou)
      call BENDER_INIT(gdea)
      call BENDER_INIT(guide)
      call BENDER_INIT(sol1)
      call CRYST_INIT2(mon)
      call BENDER_INIT(sol2)
      call BENDER_INIT(sol2a)
      call SLIT_INIT(sam)
      
#// calculate maximum angular deviations for the secondary spectrometer
#      CALL APERTURE1(ITASK,ahmin,avmin)
      call APERTURE1(itask,ahmin,avmin,wmax,hmax,band)

1     format(a,5(2x,g12.6))      
#      write(*,*) 'APERTURE1 ',ahmin,avmin,wmax,hmax,band

      lms=sol2.frame.dist+sol2a.frame.dist+mon.frame.dist
      ctm=sgnm/tan(thm)
      stmch=sin(thm-sgnm*mon.chi) 
      

#// common constraints for simulation started at the sample
      if(mon.nh.gt.1.or.mon.hmos.le.sec) then 
        z=1.d0 
      else
        z=0.d0
      endif  
      rndlist.limits(1)=ahmin*rndlist.pool(1)
      rndlist.limits(2)=avmin*rndlist.pool(2)
# get contributions to Bragg angle spread 
#          a1=4*mon.hmos ! mosaicity
#          a2=GETEFFMOS(MON) 
#          a3=0.5*tan(mon.thb)*(avmin/2)**2 ! vertical divergence
#      RNDLIST.LIMITS(3)=SQRT(a1**2+a2**2+a3**2)*stp.ki*abs(ctm)*
#     *                  RNDLIST.POOL(3) 
#      RNDLIST.LIMITS(4)=sam.size(1)*RNDLIST.POOL(4)
#      RNDLIST.LIMITS(5)=sam.size(2)*RNDLIST.POOL(5)        
      rndlist.limits(3)=band*stp.ki*abs(ctm)* rndlist.pool(3) 
      rndlist.limits(4)=wmax*rndlist.pool(4)
      rndlist.limits(5)=hmax*rndlist.pool(5)        
      tmat(5,2)=-1./lms
# Except fully asymmetric case      
      if(mon.frame.size(1)*abs(stmch).gt.mon.frame.size(3)) then
        tmat(1,3)=(1.d0-lms*z*mon.rh/stmch)*ctm*stp.ki
        tmat(4,3)=-z*mon.rh*stp.ki/stmch*ctm
      endif
#// no constraints in debug mode
      if (idbg.ge.1) then
          rndlist.limits(1)=ahmin
          rndlist.limits(2)=avmin
          rndlist.limits(3)=0.05*stp.ki
          rndlist.limits(4)=sam.size(1)
          rndlist.limits(5)=sam.size(2)
      endif

      endif

# ******************************************************
#                                                      *
#                  SECONDARY SPECTROMETER              *
#                                                      *
# ******************************************************

#// Initialize components 
      call BENDER_INIT(sol3)
      call CRYST_INIT2(ana)
      call BENDER_INIT(sol4)
      call SLIT_INIT(det.frame)

#// calculate maximum angular deviations for the secondary spectrometer
      call APERTURE2(itask,ah2,av2)
#      write(*,*) 'APERTURE2 ',ah2,av2

      if (rndlist.dim.ge.7) then
         rndlist.active(7)=1
         rndlist.limits(7)=av2
      endif
      
      if (rndlist.dim.ge.8) then
         rndlist.active(8)=1
         rndlist.limits(8)=ah2
      endif
 
      if(ana.nh.gt.1.or.ana.hmos.le.sec) then 
        z=1.d0 
      else
        z=0.d0
      endif  
#/// for monitor after Vanad sample and analyzer
      if(itask.eq.6.and.imonit.ge.9) then
        sgna=sign(1,stp.sa) 
        cta=sgna/tan(ana.thb)
        stach=sin(ana.thb-sgna*ana.chi) 
        lsa=sol3.frame.dist+ana.frame.dist
        z1=1.d0-z*ana.rh*lsa/stach        
#     get contributions to Bragg angle spread 
        a1=4*ana.hmos  ! mosaicity
        a2=GETEFFMOS(ana) 
        if (abs(z1).gt.0.05) then
          if(cfgmode.eq.1) then
            tmat(3,7)=1.d0/cta/z1/stp.kf
          else  
            tmat(3,8)=1.d0/cta/z1/stp.kf
          endif  
#          TMAT(4,8)=COMEGA*Z*ana.rh/stach/Z1
          rndlist.limits(8)=sqrt((sam.size(1)/lsa)**2+a1**2+a2**2)
        endif
      endif  
      
#/// for powder diffractometer, initial optimization of vertical scatt. angle 
      if(itask.eq.4) then
         c2ts=comega/somega
         if(abs(c2ts).lt.5) tmat(2,7)=c2ts/stp.ki
      endif
      if(itask.eq.5) then
         c2ts=comega/somega
         if(abs(c2ts).lt.5) tmat(2,7)=-c2ts/stp.ki
      endif

#/// for inelastic scattering (TAS resolution)
      if(itask.eq.1.or.itask.eq.8) then
          rndlist.active(9)=1
          sgna=sign(1,stp.sa) 
          cta=sgna/tan(ana.thb)
          stach=sin(ana.thb-sgna*ana.chi) 
          lsa=sol3.frame.dist+ana.frame.dist
# get contributions to Bragg angle spread 
          a1=4*ana.hmos  ! mosaicity
          a2=GETEFFMOS(ana) 
          a3=0.5*tan(ana.thb)*(av2/2)**2  ! vertical divergence
          rndlist.limits(9)=sqrt(a1**2+a2**2+a3**2)*stp.kf*abs(cta)      
          b89=(1.d0-lsa*z*ana.rh/stach)*cta*stp.kf
          if(cfgmode.eq.1) then
            tmat(7,9)=b89
#            TMAT(7,9)=-B89/HSQOV2M/STP.KF
            tmat(5,9)=comega*z*ana.rh/stach*cta*stp.kf
          else
            tmat(8,9)=(1.d0-lsa*z*ana.rh/stach)*cta*stp.kf
            tmat(4,9)=comega*z*ana.rh/stach*cta*stp.kf
          endif  
      endif


#/// for tracing through the secondary spectrometer only
      if(itask.eq.8.or.itask.eq.9) then
          do i=1,6
            rndlist.active(i)=0
            rndlist.limits(i)=1
          enddo
          tmat(4,9)=0.d0
      endif
            
      
#// no constraints in debug mode
      if (idbg.ge.1) then
          rndlist.limits(7)=av2
          rndlist.limits(8)=ah2
          rndlist.limits(9)=0.05*stp.kf
          do  i=1,rndlist.dim
          do  j=1,rndlist.dim
            if (i.ne.j) then
              tmat(i,j)=0.d0
            else
              tmat(i,j)=1.d0
            endif
          end do
          end do
          write(sout,*)  'No initial correlations'        
      endif

      if (verbose) then
          write(sout,*)  'Monte-Carlo variables initialized.'
          call WRITE_SETUP(20,itask)
      endif  
      
#      WRITE(SOUT,*) 'SPEC_INI done.'
#          CALL WRITE_SETUP(20,ITASK)

#100   FORMAT('TMAT: ',16(1X,G10.4))      
#101   FORMAT('TLIM: ',16(1X,G10.4))      
#      write(*,*)
#      DO I=1,RNDLIST.DIM
#        write(*,100) (TMAT(I,J),J=1,RNDLIST.DIM)
#      ENDDO
#      write(*,101) (RNDLIST.LIMITS(J),J=1,RNDLIST.DIM)
#      write(*,*)
#      write(*,*) 'DET(TMAT)= ',DETERM(TMAT,CRND,AUX)

      return
999   ierr=2
      return
      end

#---------------------------------------------------------------------
      logical FUNCTION SPEC_GO(itask)
#     traces neutron trajectories starting at the sample 
#  ITASK=1 ... inelastic scattering, TAS resolution
#  ITASK=2 ... sample -> source
#  ITASK=3 ... source -> sample
#  ITASK=4 ... sample -> source + sample(powder) -> detector (no analyser)
#  ITASK=5 ... source -> sample + sample(powder) -> detector (no analyser)
#  ITASK=6 ... sample -> source + sample (Vanad) -> monitor(IMONIT)
#  ITASK=7 ... source -> monitor(IMONIT)

# The neutron coordinates are stored in the following order
# NEUI1(source) -> NEUI(incident) -> NEUF(scattered) -> NEUF1(detector)
#----------------------------------------------------------------------
      implicit none
        
      integer*4 itask     
      logical DIFF_GO,MONIT_GO,INELAST_GO,FLUX_GODIFF_GO2,
     *        MONIT_GO2,FLUX_GO2,TAS2_GODIFF2_GODIFF3_GO,DCRYST_GO  
      
      if(itask.eq.1) then
          SPEC_GO=INELAST_GO()
          return
      else if(itask.eq.2) then
          SPEC_GO=FLUX_GO()
          return
      else if(itask.eq.3) then
          SPEC_GO=FLUX_GO2()
          return
      else if(itask.eq.4) then
          SPEC_GO=DIFF_GO()
          return
      else if(itask.eq.5) then
          SPEC_GO=DIFF_GO2()
          return
      else if(itask.eq.6) then
          SPEC_GO=MONIT_GO()
          return
      else if(itask.eq.7) then
          SPEC_GO=MONIT_GO2()
          return
      else if(itask.eq.8) then
          SPEC_GO=TAS2_GO()
          return
      else if(itask.eq.9) then
          SPEC_GO=DIFF2_GO()
          return
      else if(itask.eq.10) then
          SPEC_GO=DIFF3_GO()
          return
      else if(itask.eq.11) then
          SPEC_GO=DCRYST_GO()
          return
      else
          SPEC_GO=.false.
      endif    
      end

#---------------------------------------------------------------
      logical FUNCTION FLUX_GO()
#     simulate incident flux, start at the sample
#---------------------------------------------------------------
      implicit none

      INCLUDE 'structures.inc'
      INCLUDE 'ness_common.inc'
        
      record /NEUTRON/ neui,neuf,neui1,neuf1,neu
      logical TAS1_GO,SLIT_GO
      logical*4 log
      common /neuif/ neui,neuf,neui1,neuf1

#      LOG=SLIT_GO(SAM,NEUI,NEU)
#      NEUI=NEU      
#      IF (LOG) LOG=TAS1_GO()
      log=TAS1_GO()
      neu=neui
      if (log) log=(log.and.SLIT_GO(sam,neu,neui))
      FLUX_GO=log
      end
      
      
#---------------------------------------------------------------
      logical FUNCTION TAS1_GO()
#     trace primary TAS spectrometer from the sample
#---------------------------------------------------------------
      implicit none

      INCLUDE 'structures.inc'
      INCLUDE 'ness_common.inc'
        
      record /NEUTRON/ neui,neuf,neui1,neuf1,neu,neu1
      logical BENDER_GO,CRYST_GO2,SOURCE_GO
      logical log,SAM_BOARDER
      common /neuif/ neui,neuf,neui1,neuf1
      real*8 t1,t2

#      LOG=.TRUE.
      
      log=SAM_BOARDER(sam,neui.r,neui.k,t1,t2)
      log=(log.and.neui.p.gt.0)
      neu1=neui
      if(flipm.eq.1) neu1.s=-neu1.s
      if(log) log=(log.and.BENDER_GO(sol2,neu1,neu))
      if(log) log=(log.and.BENDER_GO(sol2a,neu,neu1))
      if(log) log=(log.and.CRYST_GO2(mon,neu1,neu))
      if(log) log=(log.and.BENDER_GO(sol1,neu,neu1))
      if(log) log=(log.and.BENDER_GO(guide,neu1,neu))
      if(log) log=(log.and.BENDER_GO(gdea,neu,neu1))
      if(log) then
          log=(log.and.SOURCE_GO(sou,neu1,neui1))
          neui.p=neui1.p
          neui1=neui
          neui1.r(1)=-neui1.r(1)
           neui1.k(2)=-neui1.k(2)
          neui.r(1)=-neui.r(1)
           neui.k(2)=-neui.k(2)
      endif
      TAS1_GO=log
      end


#---------------------------------------------------------------
      logical FUNCTION DIFF_GO()
#     trace from the source to the detector with pwd. sample
#---------------------------------------------------------------
      implicit none

      INCLUDE 'structures.inc'
      INCLUDE 'ness_common.inc'
        
      record /NEUTRON/ neui,neuf,neui1,neuf1,neu,neu1
      logical BENDER_GO,PWD_GO,TAS1_GO,DETECT_GO
      logical*4 log
      common /neuif/ neui,neuf,neui1,neuf1
      
      log=TAS1_GO()
      if(log) log=(log.and.PWD_GO(sam,neui,neuf,stp.q*stp.ss))
      neu=neuf
      if(flipa.eq.1) neu.s=-neu.s
      if(log) log=(log.and.BENDER_GO(sol3,neu,neu1))
      if(log) log=(log.and.DETECT_GO(det,neu1,neuf1))
      DIFF_GO=log
      return
      end

#---------------------------------------------------------------
      logical FUNCTION MONIT_GO()
#     trace from the source to the monitor at position IMONIT
#---------------------------------------------------------------
      implicit none

      INCLUDE 'structures.inc'
      INCLUDE 'ness_common.inc'
      INCLUDE 'randvars.inc'
        
      record /NEUTRON/ neui,neuf,neui1,neuf1,neu,neu1
      logical BENDER_GO,SLIT_GO,CRYST_GO2,TAS1_GO,DETECT_GO
      logical VAN_GO,VAN_TRANS,log
      integer*4 m
      common /neuif/ neui,neuf,neui1,neuf1
      real*8 ll
      integer*4 i
      
      m=imonit
      
      log=TAS1_GO()
      if(.not.log) goto 999
      if (m.eq.7) then
        if(log) log=(log.and.VAN_TRANS(sam,neui,neuf))
        ll=(sol3.frame.dist-neuf.r(3))
        do i=1,2
          neuf.r(i)=neuf.r(i)+ll*neuf.k(i)/neuf.k(3)        
        enddo
        neuf1=neuf
        goto 100
      endif
      if (m.eq.6) then
        if(log) log=(log.and.SLIT_GO(sam,neui,neuf))
        neuf1=neuf
        goto 100
      endif
#      call WrtNeu(NEUI)
      if(log) log=(log.and.VAN_GO(sam,neui,neuf,stp.q*stp.ss))
#      call WrtNeu(NEUF)
      neu1=neuf
      if(flipa.eq.1) neu1.s=-neu1.s
      if(log) log=(log.and.BENDER_GO(sol3,neu1,neu))
#      call WrtNeu(NEU)
#      pause
      if (m.eq.8) goto 100
      if(log) log=(log.and.CRYST_GO2(ana,neu,neu1))
      if (m.eq.9) goto 101
      if (log) log=(log.and.BENDER_GO(sol4,neu1,neu))
      if (m.eq.10) goto 100
      if(log) log=(log.and.DETECT_GO(det,neu,neuf1))
      MONIT_GO=log
      return

100   neuf1=neu
      MONIT_GO=log
      return

101   neuf1=neu1
      MONIT_GO=log
      return

999   MONIT_GO=.false.
      return
      end

#---------------------------------------------------------------
      logical FUNCTION INELAST_GO()
#     trace 3-axis setup to get resolution function R(Q,E)
#---------------------------------------------------------------
      implicit none

      INCLUDE 'structures.inc'
      INCLUDE 'ness_common.inc'
        
      record /NEUTRON/ neui,neuf,neui1,neuf1,neu,neu1
      logical SAM_GO,BENDER_GO,CRYST_GO2,TAS1_GO,DETECT_GO,TAS1_GO2
      logical log
      real*8 ki
      common /neuif/ neui,neuf,neui1,neuf1
      
      if(ftas.eq.0) then
        log=TAS1_GO()
      else
        log=TAS1_GO2()
      endif
      if(.not.log) goto 10
      if(log) log=(log.and.SAM_GO(sam,neui,neuf))
      if (normmon.ne.0) then   ! weight by monitor efficiency ~ 1/ki
          ki=sqrt(neui.k(1)**2+neui.k(2)**2+neui.k(3)**2)
          neuf.p=neuf.p*ki
      endif      
      neuf.p=neuf.p/neui.p
      neu1=neuf
      if(flipa.eq.1) neu1.s=-neu1.s
      if(log) log=(log.and.BENDER_GO(sol3,neu1,neu))
      if(log) log=(log.and.CRYST_GO2(ana,neu,neu1))
      if(log) log=(log.and.BENDER_GO(sol4,neu1,neu))
      if(log) log=(log.and.DETECT_GO(det,neu,neuf1))
      neuf.p=neuf1.p
10    INELAST_GO=log

      end
      
#-----------------------------------------------------------------------------
      logical FUNCTION DCRYST_GO()
#     trace 3-axis setup without sample (incl. just nominal scatterinc angle)
# for Q=0, equivalent to the double-crystal setting
#-----------------------------------------------------------------------------
      implicit none

      INCLUDE 'structures.inc'
      INCLUDE 'ness_common.inc'
        
      record /NEUTRON/ neui,neuf,neui1,neuf1,neu,neu1
      logical BRAGG_GO,BENDER_GO,CRYST_GO2,TAS1_GO,DETECT_GO,TAS1_GO2
      logical log
      common /neuif/ neui,neuf,neui1,neuf1
      
      if(ftas.eq.0) then
        log=TAS1_GO()
      else
        log=TAS1_GO2()
      endif
      if(.not.log) goto 10
      if(log) log=(log.and.BRAGG_GO(sam,neui,neuf))
#      NEUF.P=1
      neu1=neuf
      if(flipa.eq.1) neu1.s=-neu1.s
      if(log) log=(log.and.BENDER_GO(sol3,neu1,neu))
      if(log) log=(log.and.CRYST_GO2(ana,neu,neu1))
      if(log) log=(log.and.BENDER_GO(sol4,neu1,neu))
      if(log) log=(log.and.DETECT_GO(det,neu,neuf1))
#      NEUF.P=NEUF1.P
10    DCRYST_GO=log

      end

#---------------------------------------------------------------
      logical FUNCTION TAS2_GO()
#     trace 3-axis setup, secondary part only
# as INELAST_GO, but without primary spectrometer
#---------------------------------------------------------------
      implicit none

      INCLUDE 'structures.inc'
      INCLUDE 'ness_common.inc'
        
      record /NEUTRON/ neui,neuf,neui1,neuf1,neu,neu1
      logical SAM_GO,BENDER_GO,CRYST_GO2,DETECT_GO
      logical log
      real*8 ki
      common /neuif/ neui,neuf,neui1,neuf1      
#      real*8 s(10)
#      integer*4 i
#      save s
#1     format('TRACE PROBABILITIES: ',a,I,6(2x,G10.4))
#      if(sam.count.eq.0) s(1)=0.
#      if(ana.frame.count.eq.0) s(3)=0.
      
      log=(neui.p.gt.0)
      if(.not.log) goto 10
      if(log) log=(log.and.SAM_GO(sam,neui,neuf))
      if (normmon.ne.0) then   ! weight by monitor efficiency ~ 1/ki
          ki=sqrt(neui.k(1)**2+neui.k(2)**2+neui.k(3)**2)
          neuf.p=neuf.p*ki
      endif      
      neuf.p=neuf.p/neui.p
      
#      if(log) s(1)=s(1)+NEUF.P
#      if (sam.count.gt.0) then
#      if (s(1).gt.sam.count*sam.size(3)*1.57*1.2) then
#        write(*,1) 'WARNING!!! : ',sam.count,NEUI.R(1),NEUF.P              
#        write(*,1) 'sample: ',det.count,s(1)/sam.count  
#        pause      
#      endif
#      endif
      
      neu1=neuf
      if(flipa.eq.1) neu1.s=-neu1.s
      if(log) log=(log.and.BENDER_GO(sol3,neu1,neu))
      if(log) log=(log.and.CRYST_GO2(ana,neu,neu1))            
#      if(log) s(3)=s(3)+NEU1.P/NEU.P
      if(log) log=(log.and.BENDER_GO(sol4,neu1,neu))
      if(log) log=(log.and.DETECT_GO(det,neu,neuf1))
#      if (sam.count.gt.1000) then
#        write(*,1) 'sample: ',sam.count,s(1)/sam.count        
#        write(*,1) 'sample x,P: ',10000,NEUI.R(1),NEUF.P        
#      endif
#      if (ana.frame.count.gt.1000) then
#        write(*,1) 'analyzer: ',ana.frame.count,s(3)/ana.frame.count        
#      endif
             
      neuf.p=neuf1.p
10    TAS2_GO=log

      end
        
#---------------------------------------------------------------
      SUBROUTINE TestQE(ki,kf)
#---------------------------------------------------------------
      implicit none
      INCLUDE 'const.inc'
      INCLUDE 'structures.inc'
      INCLUDE 'ness_common.inc'
      INCLUDE 'rescal.inc'
      
      real*8  vq(3),wq(3),kf0,ki0,vki(3),vkf(3),ki(3),kf(3)
      integer*4 i,j
        
      do i=1,3
        vki(i)=ki(i) 
        vkf(i)=kf(i)
      enddo 
      kf0=vkf(1)**2+vkf(2)**2+vkf(3)**2
      ki0=vki(1)**2+vki(2)**2+vki(3)**2
      vkf(1)=vkf(1)-stp.kf*somega
      vkf(3)=vkf(3)-stp.kf*comega
      vki(3)=vki(3)-stp.ki
      do i=1,3
        vq(i)=vkf(i)-vki(i)
      enddo
#*  transform to C&N coord.
      do i=1,3
         wq(i)=0
         do j=1,3
            wq(i)=wq(i)+mlc(j,i)*vq(j)
         enddo
      enddo
      if(wq(1).gt.0.06) then
80      format(a10,4(1x,g12.6))
        write (*,80)  'VKI: ',(vki(i),i=1,3) 
        write (*,80)  'VKF: ',(vkf(i),i=1,3) 
        write (*,80)  'VQ: ',(vq(i),i=1,3) 
        write (*,80)  'WQ: ',(wq(i),i=1,3),hsqov2m*(ki0-kf0)-stp.e 
        vkf(1)=kf(1)*comega-kf(3)*somega
        vkf(3)=kf(1)*somega+kf(3)*comega
        write (*,80)  'KF: ',(vkf(i),i=1,3) 
        write (*,80)  'ang: ',ki(1)/ki(3),vkf(1)/vkf(3) 
        pause
      endif
      end

#---------------------------------------------------------------
      logical FUNCTION DIFF2_GO()
# trace from a sample (diffuse elastic) to the detector
# without primary spectrometer
#---------------------------------------------------------------
      implicit none

      INCLUDE 'structures.inc'
      INCLUDE 'ness_common.inc'
        
      record /NEUTRON/ neui,neuf,neui1,neuf1,neu,neu1
      logical BENDER_GO,ESAM_GO,DETECT_GO
      logical*4 log
      common /neuif/ neui,neuf,neui1,neuf1
      
      log=(neui.p.gt.0)
      if(.not.log) goto 10
      if(log) log=(log.and.ESAM_GO(sam,neui,neuf))
      neuf.p=neuf.p/neui.p
      neu=neuf
      if(flipa.eq.1) neu.s=-neu.s
      if(log) log=(log.and.BENDER_GO(sol3,neu,neu1))
      if(log) log=(log.and.DETECT_GO(det,neu1,neuf1))
      neuf.p=neuf1.p
10    DIFF2_GO=log
      return
      end

#---------------------------------------------------------------
      logical FUNCTION DIFF3_GO()
# trace from a powder sample to the detector
# as DIFF_GO, but without primary spectrometer
#---------------------------------------------------------------
      implicit none

      INCLUDE 'structures.inc'
      INCLUDE 'ness_common.inc'
        
      record /NEUTRON/ neui,neuf,neui1,neuf1,neu,neu1
      logical BENDER_GO,PWD_GO,DETECT_GO
      logical*4 log
      common /neuif/ neui,neuf,neui1,neuf1
      
      log=(neui.p.gt.0)
      if(.not.log) goto 10
      if(log) log=(log.and.PWD_GO(sam,neui,neuf,stp.q*stp.ss))
#      NEUF.P=NEUF.P/NEUI.P
      neu=neuf
      if(flipa.eq.1) neu.s=-neu.s
      if(log) log=(log.and.BENDER_GO(sol3,neu,neu1))
      if(log) log=(log.and.DETECT_GO(det,neu1,neuf1))
10    DIFF3_GO=log

#         E(1)=NEU.R(1)               
#         E(2)=NEU.R(2)
#         E(3)=HSQOV2M*(KKI-STP.KI**2)
#         E(4)=NEU.T/1000   ! in [ms]             
#         DEI=DEI+NEU.P*E(3)**2
#         DEI0=DEI0+E(3)*NEU.P
#         CALL EVARRAY(1,1,NCNT,E,NEU.P) 
#         DO I=1,3
#               E(I)=NEU.K(I)
#         ENDDO
#         E(3)=E(3)-STP.KI
#         E(4)=NEU.S
#         CALL EVARRAY(1,0,NCNT,E,NEU.P)


      return
      end

#---------------------------------------------------------------
      logical*4 FUNCTION BENCH_CR(icom,neu)
#     traces neutron trajectories from the sample to the source
#     (ICOM=1) or from the sample to the detector (ICOM=2)
#---------------------------------------------------------------
      implicit none

      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      INCLUDE 'structures.inc'
      INCLUDE 'ness_common.inc'
        
      record /NEUTRON/ neu,neu1
      logical BENDER_GO,SLIT_GO,CRYST_GO2,log
      integer*4 icom
101    format(1x,7(g13.6,2x),a1)
      log=.true.
      log=(neu.p.gt.0)
#      IF(LOG) write(*,101) (NEU.R(i),i=1,3),(NEU.K(i),i=1,3),NEU.p
      if(log) log=(log.and.SLIT_GO(sam,neu,neu1))
#      IF(LOG) write(*,101) (NEU1.R(i),i=1,3),(NEU1.K(i),i=1,3),NEU1.p
      if(flipm.eq.1) neu1.s=-neu1.s
      if(log) log=(log.and.BENDER_GO(sol2,neu1,neu))
#      IF(LOG) write(*,101) (NEU.R(i),i=1,3),(NEU.K(i),i=1,3),NEU.p
      if(log) log=(log.and.BENDER_GO(sol2a,neu,neu1))
#      IF(LOG) write(*,101) (NEU1.R(i),i=1,3),(NEU1.K(i),i=1,3),NEU1.p
      BENCH_CR=log
      if(log.and.(icom.eq.1)) log=(log.and.CRYST_GO2(mon,neu1,neu))
      return
      end

#---------------------------------------------------------------
      logical*4 FUNCTION BENCH_SOL2(icom,neu)
#     traces neutron trajectories from the sample to the source
#     (ICOM=1) or from the sample to the detector (ICOM=2)
#---------------------------------------------------------------
      implicit none

      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      INCLUDE 'structures.inc'
      INCLUDE 'ness_common.inc'
        
      record /NEUTRON/ neu,neu1
      logical BENDER_GO,SLIT_GO,log
      integer*4 icom
      log=.true.
      log=(neu.p.gt.0)
      if(log) log=(log.and.SLIT_GO(sam,neu,neu1))
      if(flipm.eq.1) neu1.s=-neu1.s
      BENCH_SOL2=log
      if(log.and.(icom.eq.1)) log=(log.and.BENDER_GO(sol2,neu1,neu))
      return
      end

#---------------------------------------------------------------
      logical*4 FUNCTION BENCH_PWD(icom,neu)
#     traces neutron trajectories from the sample to the source
#     (ICOM=1) or from the sample to the detector (ICOM=2)
#---------------------------------------------------------------
      implicit none

      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      INCLUDE 'structures.inc'
      INCLUDE 'ness_common.inc'
        
      record /NEUTRON/ neu,neu1,neui
      logical BENDER_GO,SLIT_GO,CRYST_GO2,log,SOURCE_GO,PWD_GO
      integer*4 icom
      log=.true.
      log=(neu.p.gt.0)
      neui=neu
      if(log) log=(log.and.SLIT_GO(sam,neu,neu1))
      if(flipm.eq.1) neu1.s=-neu1.s
      if(log) log=(log.and.BENDER_GO(sol2,neu1,neu))
      if(log) log=(log.and.BENDER_GO(sol2a,neu,neu1))
      if(log) log=(log.and.CRYST_GO2(mon,neu1,neu))
      if(log) log=(log.and.BENDER_GO(sol1,neu,neu1))
      if(log) log=(log.and.BENDER_GO(guide,neu1,neu))
      if(log) log=(log.and.BENDER_GO(gdea,neu,neu1))
      if(log) then
          log=(log.and.SOURCE_GO(sou,neu1,neu))
          neu1=neui
          neu1.p=neu.p
          neu1.r(1)=-neu1.r(1)
           neu1.k(2)=-neu1.k(2)
      endif
      BENCH_PWD=log
      if(log.and.(icom.eq.1))
     *      log=(log.and.PWD_GO(sam,neu1,neu,stp.q*stp.ss))
      return
      end

#---------------------------------------------------
      SUBROUTINE NESS_CONV(READCFG)
#     Conversion of parameters from TRAX & RESCAL to NESS
#---------------------------------------------------
      implicit none

      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      INCLUDE 'structures.inc'
      INCLUDE 'ness_common.inc'
      INCLUDE 'collimators.inc'
      INCLUDE 'rescal.inc'
      INCLUDE 'trax.inc'

      integer*4 READCFG
      integer*4 ierr
      common /errors/ ierr
      integer*4 i      
      
      if (READCFG.gt.0) call SETCFG(cfgname)
      
#      write(*,*) 'Convert input data to NESS structures'

      sol1.dlh=dlamh(3)
      sol1.dlv=dlamv(3)
      sol1.nlh=nlam(3)
      sol1.nlv=vlam(3)
      sol2.dlh=dlamh(5)
      sol2.dlv=dlamv(5)
      sol2.nlh=nlam(5)
      sol2.nlv=vlam(5)
      sol3.dlh=dlamh(6)
      sol3.dlv=dlamv(6)
      sol3.nlh=nlam(6)
      sol3.nlv=vlam(6)
      sol4.dlh=dlamh(7)
      sol4.dlv=dlamv(7)
      sol4.nlh=nlam(7)
      sol4.nlv=vlam(7)
      sol2a.dlh=dlamh(4)
      sol2a.dlv=dlamv(4)
      sol2a.nlh=nlam(4)
      sol2a.nlv=vlam(4)
      guide.dlh=dlamh(2)
      guide.dlv=dlamv(2)
      guide.nlh=nlam(2)
      guide.nlv=vlam(2)
      gdea.dlh=dlamh(1)
      gdea.dlv=dlamv(1)
      gdea.nlh=nlam(1)
      gdea.nlv=vlam(1)

#///  sample:
      smos=res_dat(i_etas)*minute/r8ln2
      sam.name= 'sample'
      sam.shape=1
      sam.dist=0.
      sam.axi=0.
      do 10 i=1,3
        sou.sta(i)=0.
        sou.gon(i)=0.
10    continue
      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
      sol1.frame.name= 'col1'
      sol2.frame.name= 'col2'
      sol2a.frame.name= 'col2a'
      guide.frame.name= 'guide'
      gdea.frame.name= 'guide_a'
#xxxxxxxxxcxxxxxxxxxcxxxxxxxxxcxxxxxxxxxcxxxxxxxxxcxxxxxxxxxcxxxxxxxxxcx

      call CREATE_COL(sol1,nfm,alpha(1),beta(1),vlsm,vl0-vlcanm-vlsm,
     1     hdm1,hdm2,vdm1,vdm2,3,-1)
      
      if (nfg.gt.0) then
         call CREATE_COL(guide,nfg,0.d0,0.d0,lguide,
     1        vl0-sol1.frame.dist/10., hg1,hg2,vg1,vg2,2,-1)
         call CREATE_COL(gdea,nfg,0.d0,0.d0,lga,
     1        dga+guide.frame.size(3)/10,hga1,hga2,vga1,vga2,1,-1)
      else
         call CREATE_COL(guide,nfg,0.d0,0.d0,0.d0,
     1       vl0-sol1.frame.dist/10., hg1, hg2,vg1,vg2,2,-1)
         dguide=0.  ! important to set correctly source distance
         call CREATE_COL(gdea,nfg,0.d0,0.d0,0.d0,
     1       0.d0,hga2,hga1,vga2,vga1,1,-1)
         dga=0.  ! important to set correctly source distance
      endif

      call CREATE_COL(sol2,nfs,alpha(2),beta(2),vlms,vl1-vlcans-vlms,
     1    hds1,hds2,vds1,vds2,5,-1)
     
      if(alpha(2).gt.0) then
        call CREATE_COL(sol2a,nfs,500.d0,500.d0,len2a,vlms+dist2a,
     1    h2a1,h2a2,v2a1,v2a2,4,-1)
      else
        call CREATE_COL(sol2a,nfs,0.d0,0.d0,len2a,vlms+dist2a,
     1    h2a1,h2a2,v2a1,v2a2,4,-1)
      endif


#///  monochromator:
      mon.frame.shape=3
      mon.frame.size(1)=wmon*10.
      mon.frame.size(2)=hmon*10.
      mon.frame.size(3)=thmon*10.
      mon.frame.dist=vl1*10.-sol2a.frame.dist-sol2.frame.dist
      mon.frame.axi=0.
      mon.chi=himon*deg
      mon.dhkl=res_dat(i_dm)
      mon.thb=asin(pi/mon.dhkl/stp.ki)
      mon.rh=res_dat(i_romh)/1000.
      mon.rv=res_dat(i_romv)/1000.
      mon.hmos=res_dat(i_etam)*minute/r8ln2
      mon.vmos=mon.hmos*anrm
      if (stp.sm.lt.0) then
        mon.frame.gon(1)=mon.thb-mon.chi+pi/2.+
     &       (dthax(1)-dthax(2))*pi/180/60
        sol1.frame.axi=mon.thb*2.-dthax(2)*pi/180/60
      else if (stp.sm.gt.0) then
        mon.frame.gon(1)=-mon.thb-mon.chi-pi/2.-
     &       (dthax(1)-dthax(2))*pi/180/60
        sol1.frame.axi=-mon.thb*2.+dthax(2)*pi/180/60
      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.
        stp.ki=2*pi/mon.dhkl
      endif
      mon.poi=poissm
      mon.nh=nhm
      mon.nv=nvm
      mon.nb=nbm
      mon.dh=0.1d0
      mon.dv=0.1d0
      mon.db=0.1d0
      mon.frame.axv=0


#///  source:
      sou.name= 'source'
      sou.size(1)=wsou*10.
      sou.size(2)=hsou*10.
      sou.size(3)=0.1
      if(nsou.eq.0) then
        sou.shape=2
        sou.size(1)=diasou*10.
        sou.size(2)=diasou*10.
      else if (nsou.eq.2) then
        sou.shape=2
      else if (nsou.eq.3) then
        sou.shape=1
      else
        sou.shape=3
      endif

      sou.axi=0.
      sou.dist=dguide*10.-dga*10.
      do 20 i=1,3
        sou.sta(i)=0.
        sou.gon(i)=0.
20    continue

#///  Soller collimators:
      sol3.frame.name= 'col3'
      sol4.frame.name= 'col4'
      call CREATE_COL(sol3,nfa,alpha(3),beta(3),vlsa,vlcana,
     1     hda1,hda2,vda1,vda2,6,1)

      sol3.frame.axi=omega+sign(1,stp.ss)*dthax(4)*minute
      sol3.frame.gon(1)=sign(1,stp.ss)*dthax(3)*minute

      call CREATE_COL(sol4,nfd,alpha(4),beta(4),vlad,vlcand,
     1     hdd1,hdd2,vdd1,vdd2,7,1)

#///  analyzer:
#      ANA.FRAME.NAME='analyzer'
      ana.frame.shape=3
      ana.frame.size(1)=wana*10.
      ana.frame.size(2)=hana*10.
      ana.frame.size(3)=thana*10.
      ana.frame.dist=vl2*10.-sol3.frame.dist
      ana.frame.axi=0.
      ana.chi=-hiana*deg
      ana.dhkl=res_dat(i_da)
      ana.thb=asin(pi/ana.dhkl/stp.kf)
      ana.rh=res_dat(i_roah)/1000.
      ana.rv=res_dat(i_roav)/1000.
      ana.hmos=res_dat(i_etaa)*minute/r8ln2
      ana.vmos=ana.hmos*anra


      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
          if (stp.sm.eq.0) stp.kf=2*pi/mon.dhkl             
      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+pi/2.+dthax(5)*pi/180/60
          sol4.frame.axi=0
          sol4.frame.axv=-ana.thb*2.-dthax(6)*pi/180/60
        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+pi/2.-dthax(5)*pi/180/60
          sol4.frame.axi=0
          sol4.frame.axv=ana.thb*2.+dthax(6)*pi/180/60
        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.+dthax(5)*pi/180/60
          sol4.frame.axi=ana.thb*2.+dthax(6)*pi/180/60
          sol4.frame.axv=0
        else if (stp.sa.lt.0) then 
          ana.frame.gon(1)=-ana.thb-ana.chi-pi/2.-dthax(5)*pi/180/60
          sol4.frame.axi=-ana.thb*2.-dthax(6)*pi/180/60
          sol4.frame.axv=0
        endif  
      endif

      ana.poi=poissa
      ana.nh=nha
      ana.nv=nva
      ana.nb=nba
      ana.dh=0.1d0
      ana.dv=0.1d0
      ana.db=0.1d0


#///  dector:
      det.frame.name= 'detector'
      if(ndet.eq.0) then
        det.frame.shape=2
        det.frame.size(1)=diadet*10.
        det.frame.size(2)=diadet*10.
        det.frame.size(3)=hdet*10.
      else
        det.frame.shape=3
        det.frame.size(1)=wdet*10.
        det.frame.size(2)=hdet*10.
        det.frame.size(3)=wdet*10.
      endif
      det.frame.axi=0.
      det.frame.axv=0.
      det.frame.dist=vl3*10.-sol4.frame.dist
      do i=1,3
        det.frame.sta(i)=0.
        det.frame.gon(i)=0.
      enddo
      if(adet.gt.0.) then      
        det.alpha=adet/10.d0
        det.nd=nsegdet
        det.space=spacedet
        det.frame.gon(2)=phidet*pi/180.      
        if(det.frame.shape.eq.2) then
          det.frame.size(1)=diadet*10.
          det.frame.size(3)=diadet*10.
          det.frame.size(2)=hdet*10.
        else
          det.frame.size(1)=wdet*10.
          det.frame.size(2)=hdet*10.
          det.frame.size(3)=diadet*10.
        endif  
      endif
      

      if((stp.sm.eq.0).and.(stp.sa.eq.0)) then
         stp.e=hsqov2m*(stp.ki**2-stp.kf**2)
      endif
      
#      write(*,*) 'GUIDE.NLH, NLAM2: ',GUIDE.NLH, NLAM2

#     call WRITE_SETUP(20)
#      write(*,*) 'Conversion done.'
#     pause

      return
999   ierr=2
      return
      end

#--------------------------------------------------------------
      SUBROUTINE CREATE_COL(obj,nfm,alpha,beta,lcol,dcol,
     &       hw1,hw2,vw1,vw2,ic,idir)
# Fill OBJ structure with parameters of a collimator segment
# NFM   .. indicates presence
# ALPHA .. Soller divergence, horizontal
# BETA  .. Soller divergence, vertical
# LENG  .. collimator length
# DIST  .. distance of entry from the preceding component
# H1,H2 .. entry and exit widths
# V1,V2 .. entry and exit heights
# IC    .. index to other parameters in the common "collimators"
# IDIR  .. direction downstream (1) or upstream (-1) 
# if IDIR=-1, exchanges entry and exit and sets oposite sign of
# horiz. curvature for curved guides)
# Converts input sizes from [cm] to [mm]
#--------------------------------------------------------------
      implicit none
      include 'const.inc'
      include 'inout.inc'
      INCLUDE 'structures.inc'
      INCLUDE 'collimators.inc'
      
      record /BENDER/ obj
      integer*4 nfm,ic,idir,i
      real*8 alpha,beta,lcol,dcol,hw1,hw2,vw1,vw2
      
      integer*4 READ_MIRROR,is
      real*8 h1,h2,v1,v2,leng,dist
1     format(a,3(2x,g12.6))
#      write(*,1) 'Create collimator '//OBJ.FRAME.NAME(1:10),NFM,
#     &  ALPHA,LCOL
      

      obj.typ=ctyp(ic)      
      is=sign(1,idir)
# unit conversion [cm]-> [mm] 
# if IDIR<0, exchange entry and exit
      if (is.gt.0) then
        h1=hw1*10.
        h2=hw2*10.
        v1=vw1*10.
        v2=vw2*10.
      else
        h2=hw1*10.
        h1=hw2*10.
        v2=vw1*10.
        v1=vw2*10.
      endif        
      leng=lcol*10.
      dist=dcol*10.
      
      obj.ch=roh(ic)*is
      obj.cv=rov(ic)
      
      obj.ghlu=gamh(ic)
      obj.ghru=gamh(ic)
      if (polar(ic).eq.0) then
         obj.ghld=gamh(ic)
         obj.ghrd=gamh(ic)
      else
         obj.ghld=0
         obj.ghrd=0
      endif
      obj.oscilate=osc(ic)
      obj.gvt=gamv(ic)
      obj.gvb=gamv(ic)
      obj.rhlu=refh(ic)
      obj.rhld=refh(ic)
      obj.rhru=refh(ic)
      obj.rhrd=refh(ic)
      obj.rvt=refv(ic)
      obj.rvb=refv(ic)
      obj.nhlu=READ_MIRROR(obj.ghlu)
      obj.nhld=READ_MIRROR(obj.ghld)
      obj.nhru=READ_MIRROR(obj.ghru)
      obj.nhrd=READ_MIRROR(obj.ghrd)
      obj.nvt=READ_MIRROR(obj.gvt)
      obj.nvb=READ_MIRROR(obj.gvb)
      obj.frame.axi=0.

      do 10 i=1,3
        obj.frame.sta(i)=0.
        obj.frame.gon(i)=0.
10    continue
      obj.frame.shape=3
      obj.frame.dist=dist
      obj.frame.size(1)=h1
      obj.frame.size(2)=v1
      obj.frame.size(3)=leng
      obj.w2=h2
      obj.h2=v2
      if (obj.dlh.eq.0) obj.dlh=0.08 
      if (obj.dlv.eq.0) obj.dlv=0.08
      
      if((alpha.gt.0).or.(nfm.ge.0)) then
          if(alpha.gt.0.and.alpha.lt.500.and.obj.typ.lt.2) then  ! set NLH automatically
            if (obj.nlh.le.0) obj.nlh=
     *         nint((h1+h2)/(2*leng*(alpha*minute+obj.dlh/leng/10.)))
          else
            if (obj.nlh.le.0) obj.nlh=1
          endif  
          if (beta.gt.0.and.beta.lt.500.and.obj.typ.lt.2) then  ! set NLV automatically
            if (obj.nlv.le.0) obj.nlv=
     *         nint((v1+v2)/(2*leng*(beta*minute+obj.dlv/leng/10.))) 
          else
            if (obj.nlv.le.0) obj.nlv=1
          endif
      else
          obj.frame.size(1)=1000.
          obj.frame.size(2)=1000.
          obj.frame.size(3)=0.
          obj.w2=obj.frame.size(1)
          obj.h2=obj.frame.size(2)
          obj.nlh=1
          obj.nlv=1
          obj.typ=-1
      endif
      if(obj.nlh.le.1) obj.oscilate=0
100   format( 'WARNING! oscilating colimator ',a, ' has only ',
     &  i2, ' slits')
      if (obj.oscilate.gt.0.and.obj.nlh.le.6) then
          write(sout,100)  obj.frame.name,obj.nlh
      endif
      end
      

#---------------------------------------------------------------        
      integer*4 FUNCTION READ_MIRROR(qc)
# read reflectivity data for supemirror (used in BENDER by NESS)
# 1 line header + 3 columns: m, r(up), r(down)
# returns:
# if found ... the index to lookup table
# if QC=-1 ... 0, clears tables
# if QC not in (0.1,10) ... 0, no reflections
# if error ... 0, show adequate message
#---------------------------------------------------------------
      implicit none
      include 'const.inc'
      include 'inout.inc'
      
      integer*4 iu
      parameter(iu=22)      
      integer*4 m_n(5),ires,indx,i,j        
      real*8 mni,z,qc
      character*3 suffix,m_name(5)
      character*9 fname
      real*8 m_alpha(128,5), m_ref1(128,5), m_ref2(128,5)
      common /mirror/ m_alpha,m_ref1,m_ref2,m_n,m_name
      logical*4 verbose
      integer*4 nev
      common /mcsetting/ verbose,nev

1     format(f3.1)
3     format( 'reflectivity (',i1, ') ',a9, ' , read ',i5, ' lines.')      
4     format( 'Error ',i5, ' while reading mirror table, line ',i5, ' .')
5     format( 'found mirror table (',i1, ') m=',a3, ', ',i5, ' lines.')      
6     format( 'no more space in mirror tables - clearing records')      


      mni=qc/gammani
      READ_MIRROR=0
      if(mni.lt.0) goto 200    ! clear all
      if(mni.eq.0) goto 100
      z=log10(mni)
      if (z.lt.-1.or.z.ge.1) goto 100   ! must be 0.1 <= mNi < 10

# get filename suffix
      suffix= '1.0'
      write(suffix,1,err=10) mni
10    fname= 'mirror'//suffix

# search for an existing table
      i=1
      do while(i.le.5.and.m_name(i).ne.suffix.and.m_n(i).gt.0)
         i=i+1
      enddo
      
# no table found, no more free space      
      if (i.gt.5) then
        if (verbose) write(sout,6)
        do j=1,5
          m_n(j)=0
          m_name(j)= ' '
        enddo
        i=1
      endif
      
# there is already corresponding table      
      if  (m_name(i).eq.suffix) then
         if (dbgref) write(sout,5) i,m_name(i),m_n(i)
         READ_MIRROR=i
         return
      endif
      
# load the lookup table to the first free position      
      indx=i
      call OPENRESFILE(fname,iu,ires,1) 
      if(ires.le.0) goto 100  ! error while opening
      ires=0
      i=0
      read(iu,*,iostat=ires,end=40,err=100)  ! assume 1-line header
      do while(ires.eq.0.and.(i.lt.128))
          read(iu,*,iostat=ires,end=30,err=40)
     *      m_alpha(i+1,indx), m_ref1(i+1,indx),m_ref2(i+1,indx)
          i=i+1
      enddo
      
      
# read OK      
30    close(iu)
      m_n(indx)=i
      m_name(indx)=suffix
      if (verbose) write(sout,3) indx,fname,i
      READ_MIRROR=indx
      return
      
# error while reading           
40    close(iu)
      write(sout,4) ires,i
      READ_MIRROR=0
      return
      
# no reflections       
100   READ_MIRROR=0
      return

# clear tables:     
200   do j=1,5
        do i=1,128
            m_alpha(i,j)=i
            m_ref1(i,j)=0
            m_ref2(i,j)=0
        enddo
        m_n(j)=0
        m_name(j)= ' '
      enddo
      READ_MIRROR=0
      return
      end


#---------------------------------------------------------------        
      SUBROUTINE READ_FLUX(fname)
# read flux distribution
# 1 line header + 2 columns: Lambda, dPhi/dLambda
# units are [Ang], [1e12/s/cm^2/Ang]      
#---------------------------------------------------------------
      implicit none
      include 'const.inc'
      include 'inout.inc'
      INCLUDE 'source.inc'
      integer*4 iu
      parameter(iu=22)
      integer*4 ires,ilin,i,j,ic,TRUELEN       
      character*30 fname,s
      character*1024 line
1     format(a)              
2     format(4(2x,g10.4))              

      ires=0
      ilin=0
      flxn=0
      flxhnx=0
      flxvnx=0
      flxhna=0
      flxvna=0

# empty string => clear table and exit      
      if (fname(1:1).eq. ' '.or.fname(1:1).eq.char(0)) return
      
      s=fname
      j=TRUELEN(s)
      call OPENRESFILE(s(1:j),iu,ires,1) 
      if(ires.le.0) goto 100
      read(iu,1,iostat=ires,end=30,err=40) line  ! assume 1-line header
      j=TRUELEN(line)
      flxlog=index(line(1:j), 'LOGSCALE')
#         if (FLXLOG.GT.0) write(*,*) 'LOGSCALE'
      ilin=ilin+1
      do while(ires.eq.0.and.(flxn.lt.256))
          read(iu,1,iostat=ires,end=30,err=40) line
          ilin=ilin+1
          j=TRUELEN(line)
          read(line(1:j),*,iostat=ires,err=20) 
     &                   flxlam(flxn+1), flxdist(flxn+1)
#       write(*,2) flxn+1,flxlam(flxn+1), flxdist(flxn+1)
          flxn=flxn+1
      enddo
      
      read(iu,1,iostat=ires,end=30,err=40) line
      j=TRUELEN(line)
      ilin=ilin+1
#      write(*,*) '>'//LINE(1:10)//'<'
      
20    if (line(1:10).eq. 'HORIZONTAL') then
#       write(*,*) ' read HORIZONTAL'
         ic=0
         read(line(11:j),*,iostat=ires,err=40) flxhnx,flxhna,flxhx,flxha
         flxhx=flxhx*10.d0
         if (flxhnx.gt.64.or.flxhna.gt.64)  goto 40   
         do i=1,flxhnx
            read(iu,1,iostat=ires,end=30,err=40) line
            ilin=ilin+1
            j=TRUELEN(line)
            read(line(1:j),*,iostat=ires,err=25) (flxhp(i,j),j=1,flxhna)
            ic=ic+1
         enddo
      else
         goto 30
      endif      
      read(iu,1,iostat=ires,end=30,err=40) line
      j=TRUELEN(line)
      ilin=ilin+1
#      write(*,*) '>'//LINE(1:80)

25    if (ic.ne.flxhnx) goto 40
      if (line(1:8).eq. 'VERTICAL') then
#       write(*,*) ' read VERTICAL'
         ic=0
         read(line(9:j),*,iostat=ires,err=40) flxvnx,flxvna,flxvx,flxva
         flxvx=flxvx*10.d0
         if (flxvnx.gt.64.or.flxvna.gt.64)  goto 40   
         do i=1,flxvnx
            read(iu,1,iostat=ires,end=30,err=40) line
            ilin=ilin+1
            j=TRUELEN(line)
            read(line(1:j),*,iostat=ires,err=30) (flxvp(i,j),j=1,flxvna)
            ic=ic+1
        enddo
      endif      
      if (ic.ne.flxvnx) goto 40

       
30    close(iu)
3     format( 'Flux table: ',i3, ' lines.')
31    format( 'Flux table with 2D distributions: ',i3, ' lines, dim=',
     &      4(1x,i3))
      if (flxhnx.gt.0) then
        write(sout,31) flxn,flxhnx,flxhna,flxvnx,flxvna
      else
        write(sout,3) flxn
      endif
      
      if (flxlog.gt.0) then
         flxdlam=log(flxlam(flxn)/flxlam(1))/(flxn-1)
      else
         flxdlam=(flxlam(flxn)-flxlam(1))/(flxn-1)
      endif
      
      return

40    close(iu)
      flxn=0
      flxhnx=0
      flxvnx=0
      flxhna=0
      flxvna=0
4     format( 'Error ',i5, ' while reading flux table, line ',i5, ' .')
      write(sout,4) ires,ilin
      return
      
100   flxn=0
      write (sout,*)  'Cannot open flux table: <'//s(1:j)// '>'
      return
      end



#----------------------------------------
      SUBROUTINE GETSTATE(itask,nevent)
#----------------------------------------
      implicit none

      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      INCLUDE 'structures.inc'
      INCLUDE 'ness_common.inc'
      
      integer*4 itask,nevent
            
5     format(1x,a8,$)
6     format(1x,i8,$)
7     format(1x,f8.6,$)
            
#// Write header      
      if (itask.le.2.or.itask.eq.4.or.itask.eq.6.or.itask.eq.11) then        
        write(*,5) sol2.frame.name
        write(*,5) sol2a.frame.name
        write(*,5) mon.frame.name
        write(*,5) sol1.frame.name
        write(*,5) guide.frame.name
        write(*,5) gdea.frame.name
        write(*,5) sou.name
        write(*,5) sam.name
      else if (itask.eq.3.or.itask.eq.5.or.itask.eq.7) then 
        write(*,5) sou.name
        write(*,5) gdea.frame.name
        write(*,5) guide.frame.name
        write(*,5) sol1.frame.name
        write(*,5) mon.frame.name
        write(*,5) sol2a.frame.name
        write(*,5) sol2.frame.name
        write(*,5) sam.name
      endif
      if (itask.eq.4.or.itask.eq.5.or.itask.eq.9) then        
        write(*,5) sol3.frame.name
        write(*,5) det.frame.name
      else if (itask.eq.1.or.itask.eq.6.or.itask.eq.7.or.
     &         itask.eq.11) then 
        write(*,5) sol3.frame.name
        write(*,5) ana.frame.name
        write(*,5) sol4.frame.name
        write(*,5) det.frame.name
      else if (itask.eq.8) then 
        write(*,5) sam.name
        write(*,5) sol3.frame.name
        write(*,5) ana.frame.name
        write(*,5) sol4.frame.name
        write(*,5) det.frame.name
      endif  
      write(*,*)
#// Write counts     
      if (itask.le.2.or.itask.eq.4.or.itask.eq.6.or.itask.eq.11) then        
        write(*,6) sol2.frame.count
        write(*,6) sol2a.frame.count
        write(*,6) mon.frame.count
        write(*,6) sol1.frame.count
        write(*,6) guide.frame.count
        write(*,6) gdea.frame.count
        write(*,6) sou.count
        write(*,6) sam.count
      else if (itask.eq.3.or.itask.eq.5.or.itask.eq.7) then 
        write(*,6) sou.count
        write(*,6) gdea.frame.count
        write(*,6) guide.frame.count
        write(*,6) sol1.frame.count
        write(*,6) mon.frame.count
        write(*,6) sol2a.frame.count
        write(*,6) sol2.frame.count
        write(*,6) sam.count
      endif
      if (itask.eq.4.or.itask.eq.5.or.itask.eq.9) then        
        write(*,6) sol3.frame.count
        write(*,6) det.frame.count
      else if (itask.eq.1.or.itask.eq.6.or.itask.eq.7.or.
     &         itask.eq.11) then 
        write(*,6) sol3.frame.count
        write(*,6) ana.frame.count
        write(*,6) sol4.frame.count
        write(*,6) det.frame.count
      else if (itask.eq.8) then 
        write(*,6) sam.count
        write(*,6) sol3.frame.count
        write(*,6) ana.frame.count
        write(*,6) sol4.frame.count
        write(*,6) det.frame.count
      endif  
      write(*,*)
#// Write transmissions     
      if (itask.le.2.or.itask.eq.4.or.itask.eq.6.or.itask.eq.11) then        
        if (nevent.gt.0) write(*,7) 1.*sol2.frame.count/nevent
        if (sol2.frame.count.gt.0) 
     *      write(*,7) 1.*sol2a.frame.count/sol2.frame.count
        if (sol2a.frame.count.gt.0) 
     *      write(*,7) 1.*mon.frame.count/sol2a.frame.count
        if (mon.frame.count.gt.0) 
     *      write(*,7) 1.*sol1.frame.count/mon.frame.count
        if (sol1.frame.count.gt.0) 
     *      write(*,7) 1.*guide.frame.count/sol1.frame.count
        if (guide.frame.count.gt.0) 
     *      write(*,7) 1.*gdea.frame.count/guide.frame.count
        if (gdea.frame.count.gt.0) 
     *      write(*,7) 1.*sou.count/gdea.frame.count
        if (sou.count.gt.0) write(*,7) 1.*sam.count/sou.count
      else if (itask.eq.3.or.itask.eq.5.or.itask.eq.7) then
        if (nevent.gt.0) write(*,7) 1.*sou.count/nevent
        if (sou.count.gt.0) write(*,7) 1.*gdea.frame.count/sou.count
        if (gdea.frame.count.gt.0) 
     *      write(*,7) 1.*guide.frame.count/gdea.frame.count
        if (guide.frame.count.gt.0) 
     *      write(*,7) 1.*sol1.frame.count/guide.frame.count
        if (sol1.frame.count.gt.0) 
     *      write(*,7) 1.*mon.frame.count/sol1.frame.count
        if (mon.frame.count.gt.0) 
     *      write(*,7) 1.*sol2a.frame.count/mon.frame.count
        if (sol2a.frame.count.gt.0) 
     *      write(*,7) sol2.frame.count/sol2a.frame.count
        if (sol2.frame.count.gt.0) 
     *      write(*,7) 1.*sam.count/sol2.frame.count
      endif
      if (itask.eq.4.or.itask.eq.5) then        
        if (sam.count.gt.0) 
     *      write(*,7) 1.*sol3.frame.count/sam.count
        if (sol3.frame.count.gt.0) 
     *      write(*,7) 1.*det.frame.count/sol3.frame.count
      else if (itask.eq.1.or.itask.eq.6.or.itask.eq.7.or.
     &        itask.eq.11) then 
        if (sam.count.gt.0) 
     *      write(*,7) 1.*sol3.frame.count/sam.count
        if (sol3.frame.count.gt.0) 
     *      write(*,7) 1.*ana.frame.count/sol3.frame.count
        if (ana.frame.count.gt.0) 
     *      write(*,7) 1.*sol4.frame.count/ana.frame.count
        if (sol4.frame.count.gt.0) 
     *      write(*,7) 1.*det.frame.count/sol4.frame.count
      else if (itask.eq.8) then 
        if (nevent.gt.0) 
     *      write(*,7) 1.*sam.count/nevent
        if (sam.count.gt.0) 
     *      write(*,7) 1.*sol3.frame.count/sam.count
        if (sol3.frame.count.gt.0) 
     *      write(*,7) 1.*ana.frame.count/sol3.frame.count
        if (ana.frame.count.gt.0) 
     *      write(*,7) 1.*sol4.frame.count/ana.frame.count
        if (sol4.frame.count.gt.0) 
     *      write(*,7) 1.*det.frame.count/sol4.frame.count
      else if (itask.eq.9) then 
        if (nevent.gt.0) 
     *      write(*,7) 1.*sol3.frame.count/nevent
        if (sol3.frame.count.gt.0) 
     *      write(*,7) 1.*det.frame.count/sol3.frame.count
      endif  
      write(*,*)
        
      end



#---------------------------------------------------
        SUBROUTINE SLIT_WRITE(iu,object)
#     Writes parameters of OBJECT to unit U
#--------------------------------------------------
      implicit none

      INCLUDE 'const.inc'
      INCLUDE 'structures.inc'
      integer*4 iu,i
      record /SLIT/ object

1     format(a30)
2     format( ' size : ',3(2x,f9.3))
3     format( ' pos  : ',3(2x,f9.1))
5     format( ' gon  : ',3(2x,f9.1))
4     format( ' distance, omega,phi,shape: ',3(2x,f9.1),5x,i1)

      write(iu,*)  '************************************'
      write(iu,1) object.name
      write(iu,*)  '************************************'
      write(iu,2) (object.size(i),i=1,3)
      write(iu,3) (object.pos(i),i=1,3)
      write(iu,5) (object.gon(i)*180/pi,i=1,3)
      write(iu,4) object.dist,object.axi*180/pi,object.axv*180/pi,
     *  object.shape

      return
      end

#---------------------------------------------------
        SUBROUTINE CRYST_WRITE(iu,object)
#     Writes parameters of OBJECT to unit U
#--------------------------------------------------
      implicit none

      INCLUDE 'const.inc'
      INCLUDE 'structures.inc'
      integer*4 iu,i
      real*8 GETEFFMOSGETDTH

      record /CRYSTAL/ object
1     format( ' nh,nv,nb: ',3(2x,i3))
12    format( ' spaces: ',3(2x,g10.4))
2     format( ' G0 : ',3(2x,f8.3))
3     format( ' dG : ',3(2x,e12.3))
7     format( ' lambda,dhkl,thb,chi: ',4(2x,f8.3))
8     format( ' curvatures (h,v,z): ',3(2x,g10.4))
9     format( ' hmos,vmos,etamax,effmos,dthb: ',5(2x,f7.2))
10    format( ' Qhkl,DW,mi,ref: ',4(2x,g12.4))
11    format( ' dExt,dLam,Ext1: ',3(2x,g12.4))


      call SLIT_WRITE(iu,object.frame)
      write(iu,*)
      write(iu,1) object.nh,object.nv,object.nb
      write(iu,12) object.dh,object.dv,object.db
      write(iu,7) object.lambda,object.dhkl,object.thb*180/pi,
     1            object.chi*180/pi
      write(iu,8) object.rh*1000,object.rv*1000,object.rb*1000
      write(iu,9) object.hmos*180*60/pi,object.vmos*180*60/pi,
     1              object.deta*180*60/pi,GETEFFMOS(object)*180*60/pi,
     &              GETDTH(object)*180*60/pi
      write(iu,10) object.qhkl,object.dw,object.mi,object.ref
      write(iu,11) object.dext,object.dlam,object.ext1
      write(iu,2) (object.g(i),i=1,3)
      write(iu,3) (object.dg_dr(1,i),i=1,3)
      write(iu,3) (object.dg_dr(2,i),i=1,3)
      write(iu,3) (object.dg_dr(3,i),i=1,3)

      return
      end

#---------------------------------------------------
        SUBROUTINE BENDER_WRITE(iu,object)
#     Writes parameters of OBJECT to unit U
#--------------------------------------------------
      implicit none

      INCLUDE 'const.inc'
      INCLUDE 'structures.inc'
      integer*4 iu

      record /BENDER/ object

2     format( ' nlh,nlv : ',2(2x,i4),a11)
3     format( ' w2,h2 : ',2(2x,f8.1))
4     format( ' crit. angles : ',6(2x,e12.3))
5     format( ' 1/RH, 1/RV  : ',2(e12.3,2x))
51    format( ' focal distances (H,V)  : ',2(g10.4,2x))
6     format( ' dlh,dlv : ',2(2x,f8.3))
7     format( ' reflectivities : ',6(2x,f8.3))
8     format( ' ref. indexes : ',6(2x,i2))

      call SLIT_WRITE(iu,object.frame)
      if (object.typ.lt.0) then 
        write(iu,*)  'ignored'
      else if (object.typ.eq.0) then 
        write(iu,*)  'collimator'
      else if (object.typ.eq.1) then 
        write(iu,*)  'guide'
      else if (object.typ.eq.2) then 
        write(iu,*)  'parabolic guide'
      else if (object.typ.eq.3) then 
        write(iu,*)  'parabolic guide with optimized slit lengths'
      else if (object.typ.eq.4) then 
        write(iu,*)  'elliptic guide'
      endif
      
      write(iu,*)
      write(iu,3) object.w2, object.h2
      if (object.oscilate.gt.0) then
          write(iu,2) object.nlh,object.nlv, ' oscilating'
      else
          write(iu,2) object.nlh,object.nlv
      endif
      write(iu,6) object.dlh,object.dlv
      write(iu,4) object.ghlu,object.ghld,object.ghru,object.ghrd,
     1            object.gvt,object.gvb
      write(iu,7) object.rhlu,object.rhld,object.rhru,object.rhrd,
     1            object.rvt,object.rvb
      write(iu,8) object.nhlu,object.nhld,object.nhru,object.nhrd,
     1            object.nvt,object.nvb
      if (object.typ.gt.1) then 
         write(iu,51) object.ch,object.cv
      else
         write(iu,5)  object.ch,object.cv
      endif
      end

#---------------------------------------------------
        SUBROUTINE DETECT_WRITE(iu,object)
#     Writes parameters of OBJECT to unit U
#--------------------------------------------------
      implicit none

      INCLUDE 'const.inc'
      INCLUDE 'structures.inc'
      integer*4 iu

      record /DETECTOR/ object

2     format( ' alpha [1/A/cm]: ',g12.4)
3     format( ' No. of segments : ',i3)
4     format( ' gap [mm] : ',g12.4)
5     format( ' tilt [deg] : ',g12.4)

      call SLIT_WRITE(iu,object.frame)
      write(iu,*)
      write(iu,2) object.alpha*10.
      write(iu,3) object.nd
      write(iu,4) object.space
      write(iu,5) object.frame.gon(2)*180/pi
      return
      end




#---------------------------------------------------
      SUBROUTINE WRITE_SETUP(ic,itask)
#     Writes actual parameters of the setup
#---------------------------------------------------
      implicit none

      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      INCLUDE 'structures.inc'
      INCLUDE 'ness_common.inc'

      integer*4 ic,itask

#      REAL*8 Z1,Z2,Z3,fwhm1,fwhm2

5     format( ' w2,h2: ',2(2x,f7.1))
6     format( ' nl: ',i4)
10    format( ' a',i1, ': ',f8.3)
11    format( ' KI,KF,Q: ',4(2x,f8.3))

      if(ic.ne.6) open(unit=ic,file= 'res_setup.txt',err=999,
     1            status= 'Unknown')

      write(ic,*)  'Configuration ',cfgname
      call SLIT_WRITE(ic,sou)
       write(ic,*)
      call BENDER_WRITE(ic,gdea)
       write(ic,*)
      call BENDER_WRITE(ic,guide)
       write(ic,*)
      call BENDER_WRITE(ic,sol1)
       write(ic,*)
      call CRYST_WRITE(ic,mon)
       write(ic,*)
      call BENDER_WRITE(ic,sol2a)
       write(ic,*)
      call BENDER_WRITE(ic,sol2)
       write(ic,*)
      call SLIT_WRITE(ic,sam)
       write(ic,*)
      call BENDER_WRITE(ic,sol3)
       write(ic,*)
      if (itask.ne.4.and.itask.ne.5.and.itask.ne.9) then
        call CRYST_WRITE(ic,ana)
           write(ic,*)
        call BENDER_WRITE(ic,sol4)
           write(ic,*)
      endif  
      call DETECT_WRITE(ic,det)
        write(ic,*)
#12    FORMAT(' range etam: +-',E12.4,'   r: ',3(2x,E12.3))
#13    FORMAT(' range etaa: +-',E12.4,'   r: ',3(2x,E12.3))
#      WRITE(IC,13) ABS(X_CR(1,2)),Y_CR(1,2),Y_CR(N_CR/2,2),Y_CR(N_CR,2)
#      CALL GETREFPAR(MON,MON.lambda,MON.QHKL,MON.MI,Z1,Z2,Z3,fwhm1)
#      CALL GETREFPAR(ANA,ANA.lambda,ANA.QHKL,ANA.MI,Z1,Z2,Z3,fwhm2)
#14    FORMAT(' fwhm [min] mon: = ',G12.5,'  anal: ',G12.5)
#      WRITE(IC,14) fwhm1*60*180/PI,fwhm2*60*180/PI
      write(ic,*)
      write(ic,*)  'AXES:'
      write(ic,10) 1,mon.frame.gon(1)*180/pi
      if (sol1.frame.axi.ne.0) then
         write(ic,10) 2,sol1.frame.axi*180/pi
      else
         write(ic,10) 2,sol2.frame.axi*180/pi
      endif
      write(ic,10) 4,sol3.frame.axi*180/pi
#      WRITE(IC,10) 5,ANA.FRAME.GON(1)*180/PI
#      WRITE(IC,10) 6,SOL4.FRAME.AXI*180/PI
      write(ic,*)
      write(ic,11) stp.ki,stp.kf,stp.q  ! ,STP.E
      if(ic.ne.6) close(ic)
#      WRITE(*,*) 'Setup written'
      return
999   write(*,*)  'Cannot open file for output!'
      return
      end


#------------------------------------------------------------------------
      SUBROUTINE APERTURE2(itask,ahmax,avmax)
#  Calculate maximum angular deviations transmitted through the instrument
#  for the SECONDARY spectrometer (sample-detector) 
#--------------------------------------------------------
      implicit none

      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      INCLUDE 'structures.inc'
      INCLUDE 'ness_common.inc'

      real*8  ahmax,avmax
      integer*4 itask,i
      real*8 a(20),l1,d1,l2,d2,b1,b2,ksi,stmch,stpch,z

# Horizontal, sample-detector      
#--------------------------------      
      
      do i=1,20
        a(i)=1e30
      enddo  
      
# Colim. 3
      l1=sol3.frame.dist
      d1=sam.size(1)+sol3.frame.size(1)
      if (l1.gt.1e-10) a(1)=d1/l1
      
      l1=sol3.frame.dist+sol3.frame.size(3)
      d1=sam.size(1)+sol3.w2
      if (l1.gt.1e-10) a(2)=d1/l1
      
      if (sol3.frame.size(3).gt.1d-10) then
        b1=(sol3.w2+sol3.frame.size(1))/sol3.frame.size(3)/sol3.nlh
      else
        b1=1.d30
      endif    
      b2=sol3.ghlu*4*pi/stp.kf
      if (l1.gt.1e-10) a(3)=max(b1,b2)
      
      if (imonit.eq.8) goto 10
            
      if (itask.eq.4.or.itask.eq.5) then
# 2-axis diffractometer: only Colim.3 and detector
         l1=sol3.frame.dist+det.frame.dist
         d1=sam.size(1)+det.frame.size(1)  
         if (l1.gt.1e-10) a(4)=d1/l1
         goto 10      
      else      
# Analyzer
         l1=sol3.frame.dist+ana.frame.dist
         d1=sam.size(1)+abs(ana.frame.size(1)*sin(ana.thb-ana.chi))+
     *      abs(ana.frame.size(3)*cos(ana.thb-ana.chi))  
         if (l1.gt.1e-10) a(4)=d1/l1      
      endif       
      
      if (ana.nh.gt.1.or.ana.hmos.le.sec) then
         z=1.d0
      else
         z=0.d0
      endif       

      l1=sol3.frame.dist+ana.frame.dist
      d1=sam.size(1)+ abs(ana.frame.size(3)*cos(ana.thb-ana.chi))
      if(ana.nh.gt.1) then
        d1=d1+abs(ana.frame.size(1)*sin(ana.thb-ana.chi))/ana.nh
      endif  
      stmch=sin(ana.thb-ana.chi)      
      stpch=sin(ana.thb+ana.chi)
      if (stmch.lt.1d-10) stmch=1d-10
            
# Colim. 4
      l2=sol4.frame.dist
      d2=sol4.frame.size(1)
      ksi=stmch/stpch-2*z*ana.rh*l2/stmch
      if (abs(l2+l1*ksi).gt.1.d-10) then
        a(5)=(d2+abs(d1*ksi))/(l2+l1*ksi)
      endif

      if (imonit.eq.9) goto 10
      
      l2=sol4.frame.dist+sol4.frame.size(3)
      d2=sol4.w2
      ksi=stmch/stpch-2*z*ana.rh*l2/stmch
      if (abs(l2+l1*ksi).gt.1.d-10) then
        a(6)=(d2+abs(d1*ksi))/(l2+l1*ksi)
      endif
      
      if (sol4.frame.size(3).gt.1d-10) then
        b1=(sol4.w2+sol4.frame.size(1))/sol4.frame.size(3)/sol4.nlh
      else
        b1=1.d30
      endif    
      b2=sol4.ghlu*4*pi/stp.kf
      a(7)=max(b1,b2)
            
      if (imonit.eq.10) goto 10
      
# Detector
      l2=sol4.frame.dist+det.frame.dist
      d2=det.frame.size(1)
      ksi=stmch/stpch-2*z*ana.rh*l2/stmch
      if (abs(l2+l1*ksi).gt.1.d-10) then
        a(8)=(d2+abs(d1*ksi))/(l2+l1*ksi)
      endif
      
10    ahmax=1d30
      do i=1,20
        ahmax=min(ahmax,abs(a(i)))
      enddo
      
# Vertical, sample-detector      
#--------------------------------      
      
      do i=1,20
        a(i)=1e30
      enddo  
      
# Colim. 3
      l1=sol3.frame.dist
      d1=sam.size(2)+sol3.frame.size(2)
      if (l1.gt.1e-10) a(1)=d1/l1
      
      l1=sol3.frame.dist+sol3.frame.size(3)
      d1=sam.size(2)+sol3.h2
      if (l1.gt.1e-10) a(2)=d1/l1
      
      if (sol3.frame.size(3).gt.1d-10) then
        b1=(sol3.h2+sol3.frame.size(2))/sol3.frame.size(3)/sol3.nlv
      else
        b1=1.d30
      endif    
      b2=sol3.gvt*4*pi/stp.kf
      a(3)=max(b1,b2)
      
      if (imonit.eq.8) goto 20
            
      if (itask.eq.4.or.itask.eq.5.or.itask.eq.9) then
# 2-axis diffractometer: only Colim.3 and detector
         l1=sol3.frame.dist+det.frame.dist
         d1=sam.size(2)+det.frame.size(2)  
         if (l1.gt.1e-10) a(4)=d1/l1
         goto 20      
      else
# Analyzer
         l1=sol3.frame.dist+ana.frame.dist
         d1=sam.size(2)+ana.frame.size(2) 
         if (l1.gt.1e-10)  a(4)=d1/l1
      endif       
      
      l1=sol3.frame.dist+ana.frame.dist
      d1=sam.size(2)
      if(ana.nv.gt.1) then
        d1=d1+ana.frame.size(2)/ana.nv
      endif  

      if (ana.nv.gt.1) then
         z=1.d0
      else
         z=0.d0
      endif       
            
# Colim. 4
      l2=sol4.frame.dist
      d2=sol4.frame.size(2)
      ksi=1-2*sin(ana.thb)*cos(ana.chi)*z*ana.rv*l2
      if (abs(l2+l1*ksi).gt.1.d-10) then
        a(5)=(d2+abs(d1*ksi))/(l2+l1*ksi)
      endif
      
      if (imonit.eq.9) goto 20

      l2=sol4.frame.dist+sol4.frame.size(3)
      d2=sol4.h2
      ksi=1-2*sin(ana.thb)*cos(ana.chi)*z*ana.rv*l2
      if (abs(l2+l1*ksi).gt.1.d-10) then
        a(6)=(d2+abs(d1*ksi))/(l2+l1*ksi)
      endif
      
      if (sol4.frame.size(3).gt.1d-10) then
        b1=(sol4.h2+sol4.frame.size(2))/sol4.frame.size(3)/sol4.nlv
      else
        b1=1.d30
      endif    
      b2=sol4.gvt*4*pi/stp.kf
      a(7)=max(b1,b2)
            
      if (imonit.eq.10) goto 20
      
# Detector
      l2=sol4.frame.dist+det.frame.dist
      d2=det.frame.size(2)
      ksi=1-2*sin(ana.thb)*cos(ana.chi)*z*ana.rv*l2
      if (abs(l2+l1*ksi).gt.1.d-10) then
        a(8)=(d2+abs(d1*ksi))/(l2+l1*ksi)
      endif
      
20    avmax=1d30
      do i=1,20
        avmax=min(avmax,abs(a(i)))
      enddo
      
#      IF(ANA.NV.GT.1) THEN
#         D1=ANA.FRAME.SIZE(2)/ANA.NV
#         L1=SOL3.FRAME.DIST+ANA.FRAME.DIST
#         AVMAX=AVMAX+ABS(D1/L1)
#      ENDIF   
      
      end



#------------------------------------------------------------------------
      SUBROUTINE APERTURE1(itask,ahmax,avmax,wmax,hmax,band)
#  Calculate maximum angular deviations transmitted through the instrument
#  for the PRIMARY spectrometer (sample-source) 
#--------------------------------------------------------
      implicit none

      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      INCLUDE 'structures.inc'
      INCLUDE 'ness_common.inc'

      real*8  ahmax,avmax,wmax,hmax,band
      integer*4 itask,i
      real*8 a(20),b(30),c(30)
      real*8 l1,d1,l2,d2,ksi,stmch,stpch,ctmch,ctpch,sgnm,z
      real*8 a1,a2,a3,w2,h2,f1,eta
      real*8 ah1,ah2,ah3,av1,av2,av3
      real*8 g1,g2,g3,g4,g5
      real*8 GETEFFMOS

#      write(*,*) 'APERTURE1 entry'

# Horizontal, sample->source      
#--------------------------------      
      
      do i=1,20
        a(i)=1e30
      enddo        
      do i=1,30
        b(i)=1e30
      enddo        
      do i=1,20
        c(i)=1e30
      enddo        

# Colim. 2
      g1=sol2.ghlu*4*pi/stp.ki
      w2=sol2.frame.size(1)

      l1=sol2.frame.dist
      d1=sam.size(1)+w2
      if (l1.gt.1e-10) a(1)=d1/l1
#----            
      w2=sol2.w2
      l1=sol2.frame.dist+sol2.frame.size(3)
      d1=sam.size(1)+w2
      if (l1.gt.1e-10) a(2)=max(d1/l1,g1)
      
      l1=sol2.frame.size(3)
      d1=(w2+sol2.frame.size(1))/sol2.nlh
      if (l1.gt.1e-10) a(3)=max(d1/l1,g1)
            
# Colim. 2A
      g2=sol2a.ghlu*4*pi/stp.ki
      w2=sol2a.frame.size(1)
      
      l1=sol2a.frame.dist+sol2.frame.dist
      d1=sam.size(1)+w2  
      if (l1.gt.1e-10) a(4)=max(d1/l1,g1)
      
      l1=l1-sol2.frame.dist
      d1=sol2.frame.size(1)+w2  
      if (l1.gt.1e-10) a(5)=max(d1/l1,g1)
      
      l1=l1-sol2.frame.size(3)
      d1=sol2.w2+w2  
      if (l1.gt.1e-10) a(6)=max(d1/l1,g1)
#----      
      w2=sol2a.w2
      
      l1=sol2.frame.dist+sol2a.frame.dist+sol2a.frame.size(3)
      d1=sam.size(1)+w2
      if (l1.gt.1e-10) a(7)=max(d1/l1,g1,g2)

      l1=l1-sol2.frame.dist
      d1=sol2.frame.size(1)+w2
      if (l1.gt.1e-10) a(8)=max(d1/l1,g1,g2)

      l1=l1-sol2.frame.size(3)
      d1=sol2.w2+w2
      if (l1.gt.1e-10) a(9)=max(d1/l1,g1,g2)

      l1=sol2a.frame.size(3)
      d1=(w2+sol2a.frame.size(1))/sol2a.nlh
      if (l1.gt.1e-10) a(10)=max(d1/l1,g2)

# Monochromator
      sgnm=-sign(1,stp.sm)  ! "minus" because of the up-stream tracing
      stmch=sin(mon.thb-sgnm*mon.chi) 
      stpch=sin(mon.thb+sgnm*mon.chi) 
      ctmch=cos(mon.thb-sgnm*mon.chi) 
      ctpch=cos(mon.thb+sgnm*mon.chi) 
      if (abs(stmch).lt.1d-10) stmch=1d-10
      if (abs(stpch).lt.1d-10) stpch=1d-10
      w2=abs(mon.frame.size(1)*stmch)+abs(mon.frame.size(3)*ctmch)
      
      l1=sol2.frame.dist+sol2a.frame.dist+mon.frame.dist
      d1=sam.size(1)+w2  
      if (l1.gt.1e-10) a(11)=max(d1/l1,g1,g2)

      l1=l1-sol2.frame.dist
      d1=sol2.frame.size(1)+w2  
      if (l1.gt.1e-10) a(12)=max(d1/l1,g1,g2)

      l1=l1-sol2.frame.size(3)
      d1=sol2.w2+w2
      if (l1.gt.1e-10) a(13)=max(d1/l1,g1,g2)

      l1=mon.frame.dist
      d1=sol2a.frame.size(1)+w2
      if (l1.gt.1e-10) a(14)=max(d1/l1,g1,g2)

      l1=l1-sol2a.frame.size(3)
      d1=sol2a.w2+w2
      if (l1.gt.1e-10) a(15)=max(d1/l1,g1,g2)
      
      ah1=1.d30
      do i=1,20
        ah1=min(ah1,abs(a(i)))
      enddo

#      do i=1,20
#        if(ah1.eq.abs(a(i))) write(*,*) 'a: ', i,a(i) 
#      enddo

#// End of primary part (before monochromator)

# Colim. 1
      w2=sol1.frame.size(1)
      g3=sol1.ghlu*4*pi/stp.ki

      l1=sol1.frame.dist
      d1=abs(mon.frame.size(1)*stpch)+abs(mon.frame.size(3)*ctpch)+w2  
      if (l1.gt.1e-10) b(1)=d1/l1
#---------
      w2=sol1.w2

      l1=sol1.frame.dist+sol1.frame.size(3)
      d1=abs(mon.frame.size(1)*stpch)+abs(mon.frame.size(3)*ctpch)+w2  
      if (l1.gt.1e-10) b(2)=max(d1/l1,g3)

      l1=sol1.frame.size(3)
      d1=(w2+sol1.frame.size(1))/sol1.nlh
      if (l1.gt.1e-10) b(3)=max(d1/l1,g3)

# Guide B
      w2=guide.frame.size(1)
      g4=guide.ghlu*4*pi/stp.ki

      l1=sol1.frame.dist+guide.frame.dist
      d1=abs(mon.frame.size(1)*stpch)+abs(mon.frame.size(3)*ctpch)+w2  
      if (l1.gt.1e-10) b(4)=max(d1/l1,g3)

      l1=guide.frame.dist
      d1=sol1.frame.size(1)+w2  
      if (l1.gt.1e-10) b(5)=max(d1/l1,g3)

      l1=guide.frame.dist-sol1.frame.size(3)
      d1=sol1.w2+w2  
      if (l1.gt.1e-10) b(6)=max(d1/l1,g3)
#---------
      w2=guide.w2

      l1=sol1.frame.dist+guide.frame.dist+guide.frame.size(3)
      d1=abs(mon.frame.size(1)*stpch)+abs(mon.frame.size(3)*ctpch)+w2  
      if (l1.gt.1e-10) b(7)=max(d1/l1,g3,g4)

      l1=guide.frame.dist+guide.frame.size(3)
      d1=sol1.frame.size(1)+w2  
      if (l1.gt.1e-10) b(8)=max(d1/l1,g3,g4)

      l1=guide.frame.dist+guide.frame.size(3)-sol1.frame.size(3)
      d1=sol1.w2+w2  
      if (l1.gt.1e-10) b(9)=max(d1/l1,g3,g4)

      l1=guide.frame.size(3)
      d1=(guide.frame.size(1)+w2)/guide.nlh
      if (l1.gt.1e-10) b(10)=max(d1/l1,g4)

# Guide A
      w2=gdea.frame.size(1)
      g5=gdea.ghlu*4*pi/stp.ki

      l1=sol1.frame.dist+guide.frame.dist+gdea.frame.dist
      d1=abs(mon.frame.size(1)*stpch)+abs(mon.frame.size(3)*ctpch)+w2  
      if (l1.gt.1e-10) b(11)=max(d1/l1,g3,g4)

      l1=guide.frame.dist+gdea.frame.dist
      d1=sol1.frame.size(1)+w2  
      if (l1.gt.1e-10) b(12)=max(d1/l1,g3,g4)

      l1=guide.frame.dist+gdea.frame.dist-sol1.frame.size(3)
      d1=sol1.w2+w2  
      if (l1.gt.1e-10) b(13)=max(d1/l1,g3,g4)

      l1=gdea.frame.dist
      d1=guide.frame.size(1)+w2  
      if (l1.gt.1e-10) b(14)=max(d1/l1,g3,g4)

      l1=gdea.frame.dist-guide.frame.size(3)
      d1=guide.w2+w2  
      if (l1.gt.1e-10) b(15)=max(d1/l1,g3,g4)
#---------
      w2=gdea.w2


      l1=sol1.frame.dist+guide.frame.dist+gdea.frame.dist+
     *   gdea.frame.size(3)
      d1=abs(mon.frame.size(1)*stpch)+abs(mon.frame.size(3)*ctpch)+w2  
      if (l1.gt.1e-10) b(16)=max(d1/l1,g3,g4,g5)

      l1=guide.frame.dist+gdea.frame.dist+gdea.frame.size(3)
      d1=sol1.frame.size(1)+w2  
      if (l1.gt.1e-10) b(17)=max(d1/l1,g3,g4,g5)

      l1=guide.frame.dist+gdea.frame.dist+gdea.frame.size(3)-
     *   sol1.frame.size(3)
      d1=sol1.w2+w2  
      if (l1.gt.1e-10) b(18)=max(d1/l1,g3,g4,g5)

      l1=gdea.frame.dist+gdea.frame.size(3)
      d1=guide.frame.size(1)+w2  
      if (l1.gt.1e-10) b(19)=max(d1/l1,g3,g4,g5)

      l1=gdea.frame.dist+gdea.frame.size(3)-guide.frame.size(3)
      d1=guide.w2+w2  
      if (l1.gt.1e-10) b(20)=max(d1/l1,g3,g4,g5)

      l1=gdea.frame.size(3)
      d1=(gdea.frame.size(1)+w2)/gdea.nlh
      if (l1.gt.1e-10) b(21)=max(d1/l1,g5)

# Source

      l1=sol1.frame.dist+guide.frame.dist+gdea.frame.dist+sou.dist
      d1=abs(mon.frame.size(1)*stpch)+abs(mon.frame.size(3)*ctpch)+w2  
      if (l1.gt.1e-10) b(22)=max(d1/l1,g3,g4,g5)

      l1=guide.frame.dist+gdea.frame.dist+sou.dist
      d1=sol1.frame.size(1)+w2  
      if (l1.gt.1e-10) b(23)=max(d1/l1,g3,g4,g5)

      l1=guide.frame.dist+gdea.frame.dist+sou.dist-sol1.frame.size(3)
      d1=sol1.w2+w2  
      if (l1.gt.1e-10) b(24)=max(d1/l1,g3,g4,g5)

      l1=gdea.frame.dist+sou.dist
      d1=guide.frame.size(1)+w2  
      if (l1.gt.1e-10) b(25)=max(d1/l1,g3,g4,g5)

      l1=gdea.frame.dist+sou.dist-guide.frame.size(3)
      d1=guide.w2+w2  
      if (l1.gt.1e-10) b(26)=max(d1/l1,g3,g4,g5)

      l1=sou.dist
      d1=gdea.frame.size(1)+w2  
      if (l1.gt.1e-10) b(27)=max(d1/l1,g3,g4,g5)

      l1=sou.dist-gdea.frame.size(3)
      d1=gdea.w2+w2  
      if (l1.gt.1e-10) b(28)=max(d1/l1,g3,g4,g5)

      ah2=1.d30
      do i=1,30
        ah2=min(ah2,abs(b(i)))
      enddo

#      do i=1,30
#        if(ah2.eq.abs(b(i))) write(*,*) 'b: ', i,b(i) 
#      enddo

#// End of secondary part (after monochromator)

#// find max. divergence
#      write(*,*) 'MON.RH,MON.NH  ',MON.RH,MON.NH,stmch

      z=0.d0
      if (mon.rh.ne.0.d0.and.
     *    (mon.nh.gt.1.or.mon.hmos.le.sec)) then
#        write(*,*) '????'
        z=1.d0
        f1=0.5*stmch/mon.rh
      else
        f1=1.d30
      endif     
      l1=sol2.frame.dist+sol2a.frame.dist+mon.frame.dist
      d1=sam.size(1)+abs(mon.frame.size(3)*ctmch)
      if(mon.nh.gt.1) then
        d1=d1+abs(mon.frame.size(1)*stmch)/mon.nh       
      endif  
#       write(*,*) 'stmch,F1 ',stmch,F1
      eta=abs(GETEFFMOS(mon))+2.*mon.hmos
      
#      write(*,*) 'eta ',eta


# Colim. 1
      l2=sol1.frame.dist
      d2=sol1.frame.size(1)
      ksi=stpch/stmch-l2/f1
      if (abs(l2+l1*ksi).gt.1.d-10) then
        c(1)=(d2+abs(d1*ksi)+2*eta*l2)/(l2+l1*ksi)
      endif
      
      l2=sol1.frame.dist+sol1.frame.size(3)
      d2=sol1.w2
      ksi=stpch/stmch-l2/f1
      if (abs(l2+l1*ksi).gt.1.d-10.and.g3.eq.0) then
        c(2)=(d2+abs(d1*ksi)+2*eta*l2)/(l2+l1*ksi)
      endif
      
#      write(*,*) 'col1 ',C(1),C(2)
      
# Guide B
      l2=sol1.frame.dist+guide.frame.dist
      d2=guide.frame.size(1)
      ksi=stpch/stmch-l2/f1
      if (abs(l2+l1*ksi).gt.1.d-10.and.g3.eq.0) then
        c(3)=(d2+abs(d1*ksi)+2*eta*l2)/(l2+l1*ksi)
      endif
      
      l2=sol1.frame.dist+guide.frame.dist+guide.frame.size(3)
      d2=guide.w2
      ksi=stpch/stmch-l2/f1
      if (abs(l2+l1*ksi).gt.1.d-10.and.g3.eq.0.and.g4.eq.0) then
        c(4)=(d2+abs(d1*ksi)+2*eta*l2)/(l2+l1*ksi)
      endif
      
#      write(*,*) 'GDB ',C(3),C(4)
      
# Guide A
      l2=sol1.frame.dist+guide.frame.dist+gdea.frame.dist
      d2=gdea.frame.size(1)
      ksi=stpch/stmch-l2/f1
      if (abs(l2+l1*ksi).gt.1.d-10.and.g3.eq.0.and.g4.eq.0) then
        c(5)=(d2+abs(d1*ksi)+2*eta*l2)/(l2+l1*ksi)
      endif
      
      l2=sol1.frame.dist+guide.frame.dist+gdea.frame.dist+
     *   gdea.frame.size(3)
      d2=gdea.w2
      ksi=stpch/stmch-l2/f1
      if (abs(l2+l1*ksi).gt.1.d-10.and.g3.eq.0.and.g4.eq.0.
     *    and.g5.eq.0) then
        c(6)=(d2+abs(d1*ksi)+2*eta*l2)/(l2+l1*ksi)
      endif
      
#      write(*,*) 'GDA ',C(5),C(6)
                       
# Source
      l2=sol1.frame.dist+guide.frame.dist+gdea.frame.dist+sou.dist
      d2=sou.size(1)
      ksi=stpch/stmch-l2/f1
      if (abs(l2+l1*ksi).gt.1.d-10.and.g3.eq.0.and.g4.eq.0.
     *    and.g5.eq.0) then
        c(7)=(d2+abs(d1*ksi)+2*eta*l2)/(l2+l1*ksi)
      endif
      
#      write(*,*) 'SRC ',C(7)
                       
     
      ah3=1.d30
      do i=1,20
        ah3=min(ah3,abs(c(i)))
      enddo

#      do i=1,20
#        if(ah3.eq.abs(c(i))) write(*,*) 'c: ', i,c(i) 
#      enddo

      ahmax=min(ah1,ah3)
#// get max. beam width at the sample
      wmax=sam.size(1)
      
      l1=sol2.frame.dist
      d1=sol2.frame.size(1)  
      wmax=min(wmax,d1+l1*ahmax)

      l1=sol2.frame.dist+sol2.frame.size(3)
      d1=sol2.w2 
      wmax=min(wmax,d1+l1*ahmax)

      l1=sol2.frame.dist+sol2a.frame.dist
      d1=sol2a.frame.size(1)   
      wmax=min(wmax,d1+l1*ahmax)

      l1=sol2.frame.dist+sol2a.frame.dist+sol2a.frame.size(3)
      d1=sol2a.w2   
      wmax=min(wmax,d1+l1*ahmax)

      l1=sol2.frame.dist+sol2a.frame.dist+mon.frame.dist
      d1=abs(mon.frame.size(1)*stmch)+abs(mon.frame.size(3)*ctmch) 
      wmax=min(wmax,d1+l1*ahmax)

      if(mon.nh.eq.1.and.abs(f1-l1).gt.1.d-10) then
        ahmax=min(ahmax,(abs(ah2*f1)+wmax+2.d0*eta*abs(f1))/abs(f1-l1)) 
      endif 
#      WRITE(*,*) 'GAMMA ',(ABS(AH2*F1)+WMAX+2.D0*ETA*ABS(F1))/ABS(F1-L1)
      
#--------------------------------      
# Vertical, sample->source      
#--------------------------------      

      do i=1,20
        a(i)=1e30
      enddo        
      do i=1,30
        b(i)=1e30
      enddo        
      do i=1,20
        c(i)=1e30
      enddo        

# Colim. 2
      g1=sol2.gvt*4*pi/stp.ki

      l1=sol2.frame.dist
      d1=sam.size(2)+sol2.frame.size(2)
      if (l1.gt.1e-10) a(1)=d1/l1
#----            
      l1=sol2.frame.dist+sol2.frame.size(3)
      d1=sam.size(2)+sol2.h2
      if (l1.gt.1e-10) a(2)=max(d1/l1,g1)
      
      l1=sol2.frame.size(3)
      d1=(sol2.h2+sol2.frame.size(2))/sol2.nlv
      if (l1.gt.1e-10) a(3)=max(d1/l1,g1)
            
# Colim. 2A
      g2=sol2a.gvt*4*pi/stp.ki
      h2=sol2a.frame.size(2)
      
      l1=sol2a.frame.dist+sol2.frame.dist
      d1=sam.size(2)+h2  
      if (l1.gt.1e-10) a(4)=max(d1/l1,g1)
      
      l1=l1-sol2.frame.dist
      d1=sol2.frame.size(2)+h2  
      if (l1.gt.1e-10) a(5)=max(d1/l1,g1)
      
      l1=l1-sol2.frame.size(3)
      d1=sol2.h2+h2  
      if (l1.gt.1e-10) a(6)=max(d1/l1,g1)
#----      
      h2=sol2a.h2
      
      l1=sol2.frame.dist+sol2a.frame.dist+sol2a.frame.size(3)
      d1=sam.size(2)+h2
      if (l1.gt.1e-10) a(7)=max(d1/l1,g1,g2)

      l1=l1-sol2.frame.dist
      d1=sol2.frame.size(2)+h2
      if (l1.gt.1e-10) a(8)=max(d1/l1,g1,g2)

      l1=l1-sol2.frame.size(3)
      d1=sol2.h2+h2
      if (l1.gt.1e-10) a(9)=max(d1/l1,g1,g2)

      l1=sol2a.frame.size(3)
      d1=(sol2a.h2+sol2a.frame.size(2))/sol2a.nlv
      if (l1.gt.1e-10) a(10)=max(d1/l1,g2)

# Monochromator
      h2=mon.frame.size(2)
      
      l1=sol2.frame.dist+sol2a.frame.dist+mon.frame.dist
      d1=sam.size(2)+h2  
      if (l1.gt.1e-10) a(11)=max(d1/l1,g1,g2)

      l1=l1-sol2.frame.dist
      d1=sol2.frame.size(2)+h2  
      if (l1.gt.1e-10) a(12)=max(d1/l1,g1,g2)

      l1=l1-sol2.frame.size(3)
      d1=sol2.h2+h2
      if (l1.gt.1e-10) a(13)=max(d1/l1,g1,g2)

      l1=mon.frame.dist
      d1=sol2a.frame.size(2)+h2
      if (l1.gt.1e-10) a(14)=max(d1/l1,g1,g2)

      l1=l1-sol2a.frame.size(3)
      d1=sol2a.h2+h2
      if (l1.gt.1e-10) a(15)=max(d1/l1,g1,g2)
      
      av1=1.d30
      do i=1,20
        av1=min(av1,abs(a(i)))
      enddo

#      do i=1,20
#        if(av1.eq.abs(a(i))) write(*,*) 'a: ', i,a(i) 
#      enddo

#// End of primary part (before monochromator)

# Colim. 1
      h2=sol1.frame.size(2)
      g3=sol1.gvt*4*pi/stp.ki

      l1=sol1.frame.dist
      d1=mon.frame.size(2)+h2  
      if (l1.gt.1e-10) b(1)=d1/l1
#---------
      h2=sol1.h2

      l1=sol1.frame.dist+sol1.frame.size(3)
      d1=mon.frame.size(2)+h2  
      if (l1.gt.1e-10) b(2)=max(d1/l1,g3)

      l1=sol1.frame.size(3)
      d1=(h2+sol1.frame.size(2))/sol1.nlv
      if (l1.gt.1e-10) b(3)=max(d1/l1,g3)

# Guide B
      h2=guide.frame.size(2)
      g4=guide.gvt*4*pi/stp.ki

      l1=sol1.frame.dist+guide.frame.dist
      d1=mon.frame.size(2)+h2  
      if (l1.gt.1e-10) b(4)=max(d1/l1,g3)

      l1=guide.frame.dist
      d1=sol1.frame.size(2)+h2  
      if (l1.gt.1e-10) b(5)=max(d1/l1,g3)

      l1=guide.frame.dist-sol1.frame.size(3)
      d1=sol1.h2+h2  
      if (l1.gt.1e-10) b(6)=max(d1/l1,g3)
#---------
      h2=guide.h2

      l1=sol1.frame.dist+guide.frame.dist+guide.frame.size(3)
      d1=mon.frame.size(2)+h2  
      if (l1.gt.1e-10) b(7)=max(d1/l1,g3,g4)

      l1=guide.frame.dist+guide.frame.size(3)
      d1=sol1.frame.size(2)+h2  
      if (l1.gt.1e-10) b(8)=max(d1/l1,g3,g4)

      l1=guide.frame.dist+guide.frame.size(3)-sol1.frame.size(3)
      d1=sol1.h2+h2  
      if (l1.gt.1e-10) b(9)=max(d1/l1,g3,g4)

      l1=guide.frame.size(3)
      d1=(guide.frame.size(2)+h2)/guide.nlv
      if (l1.gt.1e-10) b(10)=max(d1/l1,g4)

# Guide A
      h2=gdea.frame.size(2)
      g5=gdea.gvt*4*pi/stp.ki

      l1=sol1.frame.dist+guide.frame.dist+gdea.frame.dist
      d1=mon.frame.size(2)+h2  
      if (l1.gt.1e-10) b(11)=max(d1/l1,g3,g4)

      l1=guide.frame.dist+gdea.frame.dist
      d1=sol1.frame.size(2)+h2  
      if (l1.gt.1e-10) b(12)=max(d1/l1,g3,g4)

      l1=guide.frame.dist+gdea.frame.dist-sol1.frame.size(3)
      d1=sol1.h2+h2  
      if (l1.gt.1e-10) b(13)=max(d1/l1,g3,g4)

      l1=gdea.frame.dist
      d1=guide.frame.size(2)+h2  
      if (l1.gt.1e-10) b(14)=max(d1/l1,g3,g4)

      l1=gdea.frame.dist-guide.frame.size(3)
      d1=guide.h2+h2  
      if (l1.gt.1e-10) b(15)=max(d1/l1,g3,g4)
#---------
      h2=gdea.h2


      l1=sol1.frame.dist+guide.frame.dist+gdea.frame.dist+
     *   gdea.frame.size(3)
      d1=mon.frame.size(2)+h2  
      if (l1.gt.1e-10) b(16)=max(d1/l1,g3,g4,g5)

      l1=guide.frame.dist+gdea.frame.dist+gdea.frame.size(3)
      d1=sol1.frame.size(2)+h2  
      if (l1.gt.1e-10) b(17)=max(d1/l1,g3,g4,g5)

      l1=guide.frame.dist+gdea.frame.dist+gdea.frame.size(3)-
     *   sol1.frame.size(3)
      d1=sol1.h2+h2  
      if (l1.gt.1e-10) b(18)=max(d1/l1,g3,g4,g5)

      l1=gdea.frame.dist+gdea.frame.size(3)
      d1=guide.frame.size(2)+h2  
      if (l1.gt.1e-10) b(19)=max(d1/l1,g3,g4,g5)

      l1=gdea.frame.dist+gdea.frame.size(3)-guide.frame.size(3)
      d1=guide.h2+h2  
      if (l1.gt.1e-10) b(20)=max(d1/l1,g3,g4,g5)

      l1=gdea.frame.size(3)
      d1=(gdea.frame.size(2)+h2)/gdea.nlv
      if (l1.gt.1e-10) b(21)=max(d1/l1,g5)

# Source

      l1=sol1.frame.dist+guide.frame.dist+gdea.frame.dist+sou.dist
      d1=mon.frame.size(2)+h2  
      if (l1.gt.1e-10) b(22)=max(d1/l1,g3,g4,g5)

      l1=guide.frame.dist+gdea.frame.dist+sou.dist
      d1=sol1.frame.size(2)+h2  
      if (l1.gt.1e-10) b(23)=max(d1/l1,g3,g4,g5)

      l1=guide.frame.dist+gdea.frame.dist+sou.dist-sol1.frame.size(3)
      d1=sol1.h2+h2  
      if (l1.gt.1e-10) b(24)=max(d1/l1,g3,g4,g5)

      l1=gdea.frame.dist+sou.dist
      d1=guide.frame.size(2)+h2  
      if (l1.gt.1e-10) b(25)=max(d1/l1,g3,g4,g5)

      l1=gdea.frame.dist+sou.dist-guide.frame.size(3)
      d1=guide.h2+h2  
      if (l1.gt.1e-10) b(26)=max(d1/l1,g3,g4,g5)

      l1=sou.dist
      d1=gdea.frame.size(2)+h2  
      if (l1.gt.1e-10) b(27)=max(d1/l1,g3,g4,g5)

      l1=sou.dist-gdea.frame.size(3)
      d1=gdea.h2+h2  
      if (l1.gt.1e-10) b(28)=max(d1/l1,g3,g4,g5)

      av2=1.d30
      do i=1,30
        av2=min(av2,abs(b(i)))
      enddo
      
#      do i=1,30
#        if(av2.eq.abs(b(i))) write(*,*) 'b: ', i,b(i) 
#      enddo

#// End of secondary part (after monochromator)


#// find max. divergence

      z=0.d0
      if (mon.rv.ne.0.d0.and.mon.nv.gt.1.and.
     *    abs(cos(mon.chi)).gt.1.d-3) then
        z=1.d0
        f1=0.5/cos(mon.chi)/sin(mon.thb)/mon.rv
      else
        f1=1.d30
      endif     
      l1=sol2.frame.dist+sol2a.frame.dist+mon.frame.dist
      d1=sam.size(2)
      if(mon.nv.gt.1) then
        d1=d1+mon.frame.size(2)/mon.nv
      endif  
      eta=4.*mon.vmos*cos(mon.chi)*sin(mon.thb)

# Colim. 1
      l2=sol1.frame.dist
      d2=sol1.frame.size(2)
      ksi=1.d0-l2/f1
      if (abs(l2+l1*ksi).gt.1.d-10) then
        c(1)=(d2+abs(d1*ksi)+2*eta*l2)/(l2+l1*ksi)
      endif
      
      l2=sol1.frame.dist+sol1.frame.size(3)
      d2=sol1.h2
      ksi=1.d0-l2/f1
      if (abs(l2+l1*ksi).gt.1.d-10.and.g3.eq.0) then
        c(2)=(d2+abs(d1*ksi)+2*eta*l2)/(l2+l1*ksi)
      endif
      
# Guide B
      l2=sol1.frame.dist+guide.frame.dist
      d2=guide.frame.size(2)
      ksi=1.d0-l2/f1
      if (abs(l2+l1*ksi).gt.1.d-10.and.g3.eq.0) then
        c(3)=(d2+abs(d1*ksi)+2*eta*l2)/(l2+l1*ksi)
      endif
      
      l2=sol1.frame.dist+guide.frame.dist+guide.frame.size(3)
      d2=guide.h2
      ksi=1.d0-l2/f1
      if (abs(l2+l1*ksi).gt.1.d-10.and.g3.eq.0.and.g4.eq.0) then
        c(4)=(d2+abs(d1*ksi)+2*eta*l2)/(l2+l1*ksi)
      endif
      
# Guide A
      l2=sol1.frame.dist+guide.frame.dist+gdea.frame.dist
      d2=gdea.frame.size(2)
      ksi=1.d0-l2/f1
      if (abs(l2+l1*ksi).gt.1.d-10.and.g3.eq.0.and.g4.eq.0) then
        c(5)=(d2+abs(d1*ksi)+2*eta*l2)/(l2+l1*ksi)
      endif
      
      l2=sol1.frame.dist+guide.frame.dist+gdea.frame.dist+
     *   gdea.frame.size(3)
      d2=gdea.h2
      ksi=1.d0-l2/f1
      if (abs(l2+l1*ksi).gt.1.d-10.and.g3.eq.0.and.g4.eq.0.
     *    and.g5.eq.0) then
        c(6)=(d2+abs(d1*ksi)+2*eta*l2)/(l2+l1*ksi)
      endif
                        
# Source
      l2=sol1.frame.dist+guide.frame.dist+gdea.frame.dist+sou.dist
      d2=sou.size(2)
      ksi=1.d0-l2/f1
      if (abs(l2+l1*ksi).gt.1.d-10.and.g3.eq.0.and.g4.eq.0.
     *    and.g5.eq.0) then
        c(7)=(d2+abs(d1*ksi)+2*eta*l2)/(l2+l1*ksi)
      endif
#      write(*,*) 'ksi: ',ksi,D1*ksi,L2+L1*ksi
      
      
      av3=1.d30
      do i=1,20
        av3=min(av3,abs(c(i)))
      enddo
     
#      do i=1,30
#        if(av3.eq.abs(c(i))) write(*,*) 'c: ', i,c(i) 
#      enddo
     

      avmax=min(av1,av3)
#// get max. beam height at the sample
      hmax=sam.size(2)
      
      l1=sol2.frame.dist
      d1=sol2.frame.size(2)  
      hmax=min(hmax,d1+l1*av1)

      l1=sol2.frame.dist+sol2.frame.size(3)
      d1=sol2.h2 
      hmax=min(hmax,d1+l1*av1)

      l1=sol2.frame.dist+sol2a.frame.dist
      d1=sol2a.frame.size(2)   
      hmax=min(hmax,d1+l1*av1)

      l1=sol2.frame.dist+sol2a.frame.dist+sol2a.frame.size(3)
      d1=sol2a.h2   
      hmax=min(hmax,d1+l1*av1)

      l1=sol2.frame.dist+sol2a.frame.dist+mon.frame.dist
      d1=mon.frame.size(2) 
      hmax=min(hmax,d1+l1*av1)

      if(mon.nv.eq.1.and.abs(f1-l1).gt.1.d-10) then
        avmax=min(avmax,abs((abs(av2*f1)+hmax+abs(eta*f1))/(f1-l1))) 
      endif 
                  
#      IF(MON.NV.GT.1) THEN
#         D1=MON.FRAME.SIZE(2)/MON.NV
#         L1=SOL2.FRAME.DIST+SOL2a.FRAME.DIST+MON.FRAME.DIST
#         AVMAX=AVMAX+ABS(D1/L1)
#      ENDIF   
      
#      write(*,*) 'AV: ',ABS((ABS(AV2*F1)+HMAX+ABS(ETA*F1))/(F1-L1))

#      DO I=1,20
#        IF (avmax.eq.ABS(A(I))) write(*,*) 'Hor. limit: ', I,A(I)
#      ENDDO

      
      a1=4*mon.hmos  ! mosaicity
      a2=GETEFFMOS(mon) 
      a3=0.5*tan(mon.thb)*(avmax/2)**2  ! vertical divergence
      band=sqrt(a1**2+a2**2+a3**2)+ah2

      
#10    format('AHMAX, WMAX, AH1, AH2, AH3, BAND',6(1x,G10.4))
#20    format('AVMAX, HMAX, AV1, AV2, AV3',5(1x,G12.6))
#      write(*,*) 'APERTURE 1'      
#      write(*,10) AHMAX, WMAX, AH1, AH2, AH3, BAND
#      write(*,20) AVMAX, HMAX, AV1, AV2 , AV3
#      pause
      
      end