src/ness/ness_3ax.f

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

Source module last modified on Sat, 16 Jul 2005, 18:46;
HTML image of Fortran source automatically generated by for2html on Mon, 29 May 2006, 15:06.


#//////////////////////////////////////////////////////////////////////
#////  $Id: ness_3ax.f,v 1.2 2005/07/16 16:46:06 saroun Exp $
#////                                                              //// 
#////  NEutron Scattering Simulation - v.1.2, (c) J.Saroun, 1997   ////
#//////////////////////////////////////////////////////////////////////
#////
#////  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) 
#////  
#
#
#////              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 'restrax.inc'
      INCLUDE 'restrax_cmd.inc'

      integer*4 ndcom,ndpar
      parameter(ndcom=16,ndpar=16)
      integer*4 icom,ncom,npar,i1,i2,i
      real*4   param(ndpar)          
      character*5 commands(ndcom)
      

      character*4 s1,s2
      common /commands/ ncom,commands,npar,param      
      
      if(nos.gt.0) then
          do i=1,nos
             param(i)=ret(i)
          end do
      else
          do i=1,nos
             param(i)=0.
          end do      
      endif       
      npar=nos            
      
      if(icom.eq.1) then
1       format( ' SPOS = ',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.4) then
4       format( ' FLIP = ',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( ' MAG  = ',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 = ',a4, ' -> ',a4)
61      format( ' SPIN =    all')
        if(nint(spint).lt.0) i1=-1
        if(nint(spint).gt.0) i1=1
        if(nint(spint).eq.0) i1=0
        i2=nint(spint)-2*i1
        if(npar.ge.1) i1=nint(param(1))            
        if(npar.ge.2) i2=nint(param(2)) 
        spint=2*i1+i2 
        if(i1.eq.0.or.i2.eq.0) spint=0
        if(spint.ne.0) then
           if (i1.eq.1) s1= 'up'
           if (i2.eq.1) s2= 'up'
           if (i1.eq.-1) s1= 'down'
           if (i2.eq.-1) s2= 'down'
           write(sout,6) s1,s2   
        else   
           write(sout,61)
        endif   
      endif
            
      if(icom.eq.8) then
8       format( ' TAUF = ',g12.4, ' [ns]')
81      format( ' phi(i)=',g12.4, ' [T*m]',/, ' phi(f)=',g12.4, ' [T*m]')
        if(npar.ge.1) then
           stp.tauf=param(1)
           sol2.bint=stp.tauf*hovm**2*stp.ki**3/2.d0/gammal*1.d7
           sol3.bint=stp.tauf*hovm**2*stp.kf**3/2.d0/gammal*1.d7
           write(sout,81) sol2.bint,sol3.bint      
        endif   
        param(1)=stp.tauf
        write(sout,8) stp.tauf        
      endif
            
            
      return
      end


#---------------------------------------------------------------        
      logical*4 FUNCTION SPEC_GO(icom)
#     traces neutron trajectories from the sample to the source
#     (ICOM=1) or from the sample to the detector (ICOM=2)
#---------------------------------------------------------------
 
      implicit none     
      INCLUDE 'ness_common.inc'
      
      integer*4 ierr,icom
      real*8 dkki,dkkf     
      record /NEUTRON/ neui,neuf,neui1,neuf1,neu,neu1 
      logical*4 BENDER_GO,SLIT_GO,CRYST_GO,log           
      common /errors/ ierr
      common /neuif/ neui,neuf,neui1,neuf1,dkki,dkkf
10    format( 'NEU: ',7(2x,e10.3))                          
      log=.true.
      if(icom.eq.1) then
        if(flipm.gt.0) neui.s=-neui.s 
#        IF(LOG) write(*,*) 'I1', NEUI.PHI
        if(log) log=(log.and.BENDER_GO(sol2,neui,neu))
#        IF(LOG) write(*,*) 'I2', NEU.PHI
        if(log) log=(log.and.CRYST_GO(mon,neu,neu1,dkki))
#        IF(LOG) write(*,*) 'I3', NEU1.PHI
        if(log) log=(log.and.BENDER_GO(sol1,neu1,neu))
#        IF(LOG) write(*,*) 'I4', NEU.PHI
        if(log) log=(log.and.BENDER_GO(guide,neu,neu1))
#        IF(LOG) write(*,*) 'I5', NEU1.PHI
        if(log) log=(log.and.SLIT_GO(sou,neu1,neui1))
#        IF(LOG) write(*,*) 'I6', NEUI1.PHI
      else if(icom.eq.2) then
        if(flipa.gt.0) neuf.s=-neuf.s 
#        IF(LOG) write(*,*) 'F1', NEUF.PHI
        if(log) log=(log.and.BENDER_GO(sol3,neuf,neu))        
#        IF(LOG) write(*,*) 'F2', NEU.PHI
        if(log) log=(log.and.CRYST_GO(ana,neu,neu1,dkkf))
#        IF(LOG) write(*,*) 'F3', NEU1.PHI
        if(log) log=(log.and.BENDER_GO(sol4,neu1,neu))
#        IF(LOG) write(*,*) 'F4', NEU.PHI
        if(log) log=(log.and.SLIT_GO(det,neu,neuf1))      
#        IF(LOG) write(*,*) 'F5', NEUF1.PHI
      endif
      SPEC_GO=log
100   continue      
      return      
      end

#---------------------------------------------------------------------  
      SUBROUTINE SPEC_CLEAR
#---------------------------------------------------------------------  
      implicit none
      INCLUDE 'ness_common.inc'
      sou.count=0
      guide.frame.count=0
      sol1.frame.count=0
      mon.frame.count=0
      sol2.frame.count=0
      sam.count=0
      sol3.frame.count=0
      ana.frame.count=0
      sol4.frame.count=0
      det.count=0             
      end

#---------------------------------------------------------------------  
      SUBROUTINE SPEC_INITALL
#---------------------------------------------------------------------  
      implicit none
      INCLUDE 'ness_common.inc'
      call SLIT_INIT(sou)
      call BENDER_INIT(guide)
      call BENDER_INIT(sol1)
      call CRYST_INIT(mon)
      call BENDER_INIT(sol2)
      call SLIT_INIT(sam)
      call BENDER_INIT(sol3)
      call CRYST_INIT(ana)
      call BENDER_INIT(sol4)
      call SLIT_INIT(det)
      end

#---------------------------------------------------------------------      
      SUBROUTINE SPEC_SETUP
#//  SPEC_MODIFIED(LOG) Check if the configuration was changed       
#//  SPEC_UPDATE Update values in XDEV,XSET   
#//  SPEC_SET(DEV,SET) fill instrument parameters from DEV,SET arrays
#//  SPEC_GET(DEV,SET) get instrument parameters to DEV,SET arrays  
#//
#// FDEV/FSET is equivalent to the current instrument setting
#// XDEV/XSET stores the setting after ray-tracing 
#---------------------------------------------------------------------      
      implicit none
      INCLUDE 'ness_common.inc'
      
      byte fdev(ldev),fset(lset),xdev(ldev),xset(lset)
      byte dev(ldev),set(lset) 
      logical*4 log      
      integer*4 i,ilast,chksum,xchecksum
      
      save xdev,xset,xchecksum
      
      equivalence (fdev(1),flipm)
      equivalence (fset(1),smos)

#----------------------------------------------------------          
      ENTRY SPEC_UNCHANGED(log)
# compare XDEV/XSET fields with the stored ones (FDEV/FSET)
# return .TRUE. if they are identical      
#----------------------------------------------------------                         
      call SPEC_INITALL 
      log=.true.            
      do i=1,ldev
         if(log) then
            log=(log.and.(xdev(i).eq.fdev(i)))
         else
            goto 101            
         endif   
      end do
101   ilast=ldev     
      do i=1,lset
         if(log) then
            log=(log.and.(xset(i).eq.fset(i)))
         else            
            goto 201
         endif
      end do
201   return
      
#------------------------------------------------------------          
      ENTRY SPEC_COMPARE(dev,set,log)
# compare DEV/SET fields with the stored ones (FDEV/FSET)
# return .TRUE. if they are identical      
#------------------------------------------------------------                            
      call SPEC_INITALL 
      log=.true.
      ilast=0           
      do i=1,ldev
#        IF (DEV(I).NE.FDEV(I)) write(*,*) 'DEV ',I+ILAST
         if(log) then
            log=(log.and.(dev(i).eq.fdev(i)))
         else
#            GOTO 200
         endif   
      end do
      ilast=ldev     
      do i=1,lset
#        IF (SET(I).NE.FSET(I)) write(*,*) 'SET ',I
         if(log) then
            log=(log.and.(set(i).eq.fset(i)))
         else            
#            GOTO 200
         endif
      end do
#200   IF(.NOT.LOG) THEN
#      write(*,*) 'BYTE ',I+ILAST
#      ENDIF
      return
               
#-----------------------------------------------------------------------------          
      ENTRY SPEC_UPDATE      
# ensure that the setup is considered as updated, i.e. MC is already done, etc.
# Set XDEV/XSET = FDEV/FSET
#-----------------------------------------------------------------------------          
      call SPEC_CLEAR                
      checksum=0         
      do i=1,ldev
         xdev(i)=fdev(i)
         checksum=checksum+fdev(i)
      end do
      do i=1,lset
         xset(i)=fset(i)
         checksum=checksum+fset(i)
      end do
      ischanged=.false.
      xchecksum=checksum
          
      return


#-------------------------------------------------------------------          
      ENTRY SPEC_ERASE
# Cleares XDEV/XSET fields. Causes the setting to be always
# considered as MODIFIED => new ray-tracing is required
#-------------------------------------------------------------------          
               
      do i=1,ldev
         xdev(i)=0.
      end do
      do i=1,lset
         xset(i)=0.
      end do    
      ischanged=.true.
      checksum=0     
      return

#-----------------------------------------------          
      ENTRY SPEC_GETCHK(chksum)
# calculate check sum of the FDEV/FSET fields      
#-----------------------------------------------          
      chksum=0         
      do i=1,ldev
         chksum=chksum+fdev(i)
      end do
      do i=1,lset
         chksum=chksum+fset(i)
      end do    
      return
     
#--------------------------------------------          
      ENTRY SPEC_GET(dev,set)
# Read instrument setting into DEV/SET fields      
#--------------------------------------------          
               
      do i=1,ldev
         dev(i)=fdev(i)
      end do
      do i=1,lset
         set(i)=fset(i)
      end do    
      return
      
#----------------------------------------------------          
      ENTRY SPEC_SET(dev,set)
# Set instrument setting according to DEV/SET fields      
#----------------------------------------------------          
      do i=1,ldev
         fdev(i)=dev(i)
      end do
      do i=1,lset
         fset(i)=set(i)
      end do    
      return
       
      end


   
#--------------------------------------------------------      
      SUBROUTINE SPEC_INI(iclr)
#     Clears all necessary variables and, if ICLR<>1, 
#     initializes limits of random variables
#--------------------------------------------------------
      implicit none
      
      INCLUDE 'const.inc'      
      INCLUDE 'inout.inc'
#      INCLUDE 'ness_common.inc'
      INCLUDE 'restrax.inc'
      
      real*8 wm,hm,wa,ha,sim,com,psm
      real*8 z,z1,z2,z3,zld,zlm,zls,zla,sim1,sia1,sia,coa
      real*8 dki1,dki2,dkf1,dkf2,tanpsm,tanpsa
      integer*4 iclr,ierr,i 
      real*4 secnds
      
      record /STATI/ cov_qe    
      common /errors/ ierr
      common /result/ cov_qe
      call STAT_CLR(4,cov_qe)
       
#      CALL RESNORM1(0)      
#      CALL RESNORM2(0)      
      call RESINT(0)
      if (iclr.eq.1) then
        call SPEC_CLEAR          
        return                    
      endif
      
#      CALL SPEC_MODIFIED(LOGIN)  ! SPEC_CLEAR and SPEC_INITALL are called inside
#      IF(.NOT.LOGIN) THEN
#         RETURN
#      ENDIF 
      
#      write(*,*) 'SPEC_INI'       
      call MAXV_UPD(0)

      t0=(sou.dist+sol1.frame.dist+mon.frame.dist+sol2.frame.dist)/
     1    hovm/stp.ki
      t0=t0+(sol3.frame.dist+ana.frame.dist+sol4.frame.dist+det.dist)/
     2    hovm/stp.kf  
     
#///  calculates size and orientation of the volumes <dKi>,<dKf>:
     
      sim=mon.stmch
      com=mon.ctmch
      zlm=mon.frame.dist+sol2.frame.dist
      wm=abs(mon.frame.size(1)*sim)+abs(mon.frame.size(3)*com)
      hm=abs(mon.frame.size(2))
      if (abs(sim-mon.rh*zlm).gt.0.0001*tan(mon.thb)*sim) then         
         if(stp.sm.lt.0) then
            tanpsm=tan(mon.thb)*sim/(sim-mon.rh*zlm)
         else
            tanpsm=-tan(mon.thb)*sim/(sim-mon.rh*zlm)
         endif            
      else
         tanpsm=10000.
      endif
      psm=atan(tanpsm)


#/// just a filter:
      if (stp.sm.eq.0) then
        z=sol1.frame.dist+sou.dist+mon.frame.dist+sol2.frame.dist
        dki1=stp.ki*(sam.size(1)+sou.size(1))/z
        dki2=stp.ki*(sam.size(2)+sou.size(2))/z        
      else
      
#//// Z1,Z2,Z3 are maximum divergences allowed by the monochromator, 
#//// Soller collimator 2 and source (including focusing), respectively
      
      sim1=sin(mon.thb+mon.chi)
      zls=sol1.frame.dist+sou.dist                 
      z1=abs(wm/zlm) 
      if ( sol2.frame.size(3).gt.0) then  
      z2=abs((sol2.w2+sol2.frame.size(1))/sol2.frame.size(3)/sol2.nlh)
     1 +sol3.ghlu*mon.lambda
      else
       z2=1.d+10
      endif
      z=abs((sol2.w2+sam.size(1))/(sol2.frame.dist+sol2.frame.size(3)))
      z2=min(z,z2)
      if(stp.sm.ne.0) then
        z3=abs(zlm*sim1+zls*sim-2.*mon.rh*zlm)
        if(z3.lt.1.d-10) z3=1.d-10
        z3=(sou.size(1)*sim+sam.size(1)*(sim1-2.*mon.rh)
     *      +4.*mon.deta*zls)/z3
      else
         z3=1.d+10
      endif   
      dki1=stp.ki*min(z1,z2,z3)
      

      z1=abs(hm/zlm)
      z2=abs((sol2.h2+sam.size(2))/(sol2.frame.dist+sol2.frame.size(3)))
      z3=abs(zlm+zls-2.*mon.rv*zlm*zls*cos(mon.chi)*sin(mon.thb))
      if(z3.lt.1.d-10) z3=1.d-10
      z3=(sou.size(2)+sam.size(2)+4.*zls*mon.deta*sin(mon.thb))/z3
      dki2=stp.ki*min(z1,z2,z3)      
      
      
      z1=abs(wm/zlm) 
      if (sol2.frame.size(3).gt.0) then          
      z2=abs((sol2.w2+sol2.frame.size(1))/sol2.frame.size(3))
      else
        z2=1.d+10
      endif
      dki1=stp.ki*min(z1,z2)

      z1=abs(hm/zlm)
      z2=abs((sol2.h2+sam.size(2))/(sol2.frame.dist+sol2.frame.size(3)))
      dki2=stp.ki*min(z1,z2)

      endif


#/// analyzer is just a filter
      if (stp.sa.eq.0) then
        z=sol3.frame.dist+det.dist+ana.frame.dist+sol4.frame.dist
        dkf1=stp.kf*(sam.size(1)+det.size(1))/z
        dkf2=stp.kf*(sam.size(2)+det.size(2))/z        
      else
                  
#/// normal analyzer
      sia=ana.stmch
      coa=ana.ctmch
      zla=ana.frame.dist+sol3.frame.dist
      wa=abs(ana.frame.size(1)*sia)+abs(ana.frame.size(3)*coa)
      ha=abs(ana.frame.size(2))
      if (abs(sia-ana.rh*zla).gt.0.0001*tan(ana.thb)*sia) then         
         if(stp.sa.gt.0) then
            tanpsa=tan(ana.thb)*sia/(sia-ana.rh*zla)
         else
            tanpsa=-tan(ana.thb)*sia/(sia-ana.rh*zla)
         endif            
      else
         tanpsa=10000.
      endif

#//// Z1,Z2,Z3 are maximum divergences allowed by the analyzer, Soller 
#//// collimator 3 and detector (including focusing), respectively      

#// normal analyzer mode
      if(cfgmode.ne.1) then

      sia1=sin(ana.thb+ana.chi)
      zld=sol4.frame.dist+det.dist                 
      z1=abs(wa/zla) 
      if ( sol3.frame.size(3).gt.0) then         
      z2=abs((sol3.w2+sol3.frame.size(1))/sol3.frame.size(3)/sol3.nlh)
     1 +sol3.ghlu*ana.lambda
      else
        z2=1.d+10
      endif  
      z=abs((sol3.w2+sam.size(1))/(sol3.frame.dist+sol3.frame.size(3)))
      z2=min(z,z2)
      if (stp.sa.ne.0) then
         z3=abs(zla*sia1+zld*sia-2.*ana.rh*zla)
         if(z3.lt.1.d-10) z3=1.d-10
         z3=(det.size(1)*sia+sam.size(1)*(sia1-2.*ana.rh)+
     *   4.*ana.deta*zld)/z3  
      else
         z3=1.d+10
      endif   
      dkf1=stp.kf*min(z1,z2,z3)

      z1=abs(ha/zla)
      z2=abs((sol3.h2+sam.size(2))/(sol3.frame.dist+sol3.frame.size(3)))
      z3=abs(zla+zld-2.*ana.rv*zla*zld*cos(ana.chi)*sin(ana.thb))
      if(z3.lt.1.d-10) z3=1.d-10
      z3=(det.size(2)+sam.size(2)+4.*zld*ana.deta*sin(ana.thb))/z3
      dkf2=stp.kf*min(z1,z2,z3)


#//// Z1,Z2,Z3 are maximum divergences allowed by the analyzer, Soller 
#//// collimator 3 and detector (including focusing), respectively      

#// flat_cone mode
      else

      sia1=sin(ana.thb+ana.chi)
      zld=sol4.frame.dist+det.dist                 
      z1=abs(ha/zla) 
      if ( sol3.frame.size(3).gt.0) then         
      z2=abs((sol3.w2+sol3.frame.size(1))/sol3.frame.size(3)/sol3.nlh)
     1 +sol3.ghlu*ana.lambda
      else
        z2=1.d+10
      endif  
      z=abs((sol3.w2+sam.size(1))/(sol3.frame.dist+sol3.frame.size(3)))
      z2=min(z,z2)
      z3=abs(zla+zld-2.*ana.rv*zla*zld*cos(ana.chi)*sin(ana.thb))
      if(z3.lt.1.d-10) z3=1.d-10
      z3=(det.size(2)+sam.size(1)+4.*zld*ana.deta*sin(ana.thb))/z3
      
      dkf1=stp.kf*min(z1,z2,z3)
      z1=abs(wa/zla)
      z2=abs((sol3.h2+sam.size(2))/(sol3.frame.dist+sol3.frame.size(3)))
      if (stp.sa.ne.0) then
         z3=abs(zla*sia1+zld*sia-2.*ana.rh*zla)
         if(z3.lt.1.d-10) z3=1.d-10
         z3=(det.size(1)*sia+sam.size(2)*(sia1-2.*ana.rh)+
     *   4.*ana.deta*zld)/z3  
      else
         z3=1.d+10
      endif   
      dkf2=stp.kf*min(z1,z2,z3)
      
      endif

      
      endif
      
#///  record RNDLIST is filled:   **************************************
#///  ensure, that LIMITS>=0 !!!
      
      rndlist.dim=9
      
      nseed=-2*abs(int(10*secnds(0.0)))+1
#     NSEED=-1001001
      do 30 i=1,rndlist.dim
        rndlist.mean(i)=0.
        rndlist.pool(i)=1.1
        rndlist.active(i)=1
30    continue

      rndlist.limits(1)=sam.size(1)
      rndlist.limits(2)=sam.size(2)
      rndlist.limits(3)=2*pi      
      
      rndlist.limits(4)=dki1*rndlist.pool(4)
      rndlist.limits(5)=dki2*rndlist.pool(5)

      rndlist.limits(6)=dkf1*rndlist.pool(6)
      rndlist.limits(7)=dkf2*rndlist.pool(7)
      
      rndlist.limits(8)=1.
      rndlist.limits(9)=1.

      rndlist.active(1)=0
      rndlist.active(2)=0
      rndlist.active(3)=0  
      rndlist.active(8)=0
      rndlist.active(9)=0  

#      IF (STP.SM.EQ.0) RNDLIST.ACTIVE(8)=0  
#      IF (STP.SA.EQ.0) RNDLIST.ACTIVE(9)=0  
            
      
101   format( 'Monte-Carlo variables initialized for data set ',i3)
      if (silent.lt.1) write(sout,101) mf_cur            

      call WRITE_SETUP(20) 

      return
999   ierr=2
2     format( 'Warning for ki,kf,Q: ',3(g12.5,1x))
      write(sout,2) stp.ki,stp.kf,stp.q
      return
      end


#-----------------------------
      SUBROUTINE GETSTATE
#-----------------------------
      implicit none
      
      INCLUDE 'ness_common.inc'
      
      write(*,*)  'mon:',sam.count,sol2.frame.count,mon.frame.count,
     1  sol1.frame.count,sou.count
      write(*,*)  'ana:',sol3.frame.count,ana.frame.count,
     1  sol4.frame.count,det.count
      write(*,*)
      
      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

      record /CRYSTAL/ object
1     format( ' nh,nv: ',2(2x,i3))
2     format( ' G0 : ',3(2x,f8.3))
3     format( ' dG : ',3(2x,e12.3))
4     format( ' POS : ',3(2x,e12.3))
7     format( ' dhkl, thb, chi: ',3(2x,f8.3))
8     format( ' roh,rov: ',2(2x,f8.4))
9     format( ' hmos,vmos,etamax: ',3(2x,f7.2))
10    format( ' lam,Qhkl,ref: ',3(2x,e12.3))
11    format( ' typ: normal')
12    format( ' typ: simple')

      call SLIT_WRITE(object.frame,iu)
      write(iu,4) (object.frame.pos(i),i=1,3)
      write(iu,1) object.nh,object.nv
      write(iu,7) object.dhkl,object.thb*180/pi,object.chi*180/pi
      write(iu,8) object.rh*1000,object.rv*1000
      write(iu,9) object.hmos*180*60/pi,object.vmos*180*60/pi,
     1              object.deta*180*60/pi
      write(iu,10) object.lambda,object.qhkl,object.ref
      if (object.typ.eq.0) then 
        write(iu,11)
      else
        write(iu,12)      
      endif  
      write(iu,*)
      write(iu,2) (object.g(i),i=1,3)
      write(iu,*)
      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 WRITE_SETUP(ic) 
#     Writes actual parameters of the setup
#---------------------------------------------------
      implicit none

      INCLUDE 'const.inc'      
      INCLUDE 'inout.inc'      
      INCLUDE 'ness_common.inc'      
      INCLUDE 'rescal.inc'      
      integer*4 ic

#      DATA THZMEV/0.24181/

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

      if(ic.ne.6) open(unit=ic,file= 'res_setup.txt',err=999,
     1            status= 'Unknown')
    
      write(ic,*)  '*************************************************'
      call SLIT_WRITE(sou,ic) 
      write(ic,12) stemp
      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,sol2) 
       write(ic,*) '*************************************************' 
      call SLIT_WRITE(sam,ic) 
       write(ic,*) '*************************************************' 
      call BENDER_WRITE(ic,sol3) 
       write(ic,*) '*************************************************' 
      call CRYST_WRITE(ic,ana) 
       write(ic,*) '*************************************************' 
      call BENDER_WRITE(ic,sol4) 
       write(ic,*) '*************************************************' 
      call SLIT_WRITE(det,ic) 
       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,atan(somega/comega)*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
      
#      write(IC,*) SOU.SIMPLE
#      write(IC,*) SOL1.FRAME.SIMPLE
#      write(IC,*) MON.FRAME.SIMPLE
#      write(IC,*) SOL2.FRAME.SIMPLE
#      write(IC,*) SOL3.FRAME.SIMPLE
#      write(IC,*) ANA.FRAME.SIMPLE
#      write(IC,*) SOL4.FRAME.SIMPLE
#      write(IC,*) DET.SIMPLE
      
      
      if(ic.ne.6) close(ic)  
#      WRITE(*,*) 'Setup written'    
      return
999   write(*,*)  'Cannot open file for output!'
      return
      end