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