406 lines
13 KiB
Fortran
406 lines
13 KiB
Fortran
C-----------------------------------------------------------------------
|
|
C 8-Reflection Centring Routine July.80
|
|
C The treatment follows INT TAB V.4. pp. 282
|
|
C For the CAD-4 the treatment is the same as described in the CAD-4
|
|
C Manual as corrected in the note by Y. Le Page
|
|
C-----------------------------------------------------------------------
|
|
SUBROUTINE CENT8
|
|
INCLUDE 'COMDIF'
|
|
DIMENSION T8(8),D8(8),A8(8),P8(8)
|
|
DATA RA/57.2958/
|
|
INTEGER INTERRUPT
|
|
REAL MPRESET
|
|
100 WRITE (COUT,10000)
|
|
CALL YESNO ('Y',ANS)
|
|
IF (ANS .EQ. 'N') THEN
|
|
KI = ' '
|
|
RETURN
|
|
ENDIF
|
|
IF (DFMODL .EQ. 'CAD4') THEN
|
|
WRITE (COUT,14900)
|
|
DT = RFREE(1)
|
|
ISLIT = 10.0*DT + 0.5
|
|
IF (ISLIT .EQ. 0) ISLIT = 40
|
|
IF (ISLIT .LT. 10) ISLIT = 10
|
|
IF (ISLIT .GT. 60) ISLIT = 60
|
|
ELSE
|
|
ISLIT = 0
|
|
WRITE (COUT,15000) IFRDEF,IDTDEF,IDODEF,IDCDEF
|
|
CALL FREEFM (ITR)
|
|
DT = RFREE(1)
|
|
DO = RFREE(2)
|
|
DC = RFREE(3)
|
|
IF (DT .EQ. 0) DT = IDTDEF
|
|
IF (DO .EQ. 0) DO = IDODEF
|
|
IF (DC .EQ. 0) DC = IDCDEF
|
|
110 DT = DT/IFRDEF
|
|
DO = DO/IFRDEF
|
|
DC = DC/IFRDEF
|
|
WRITE (COUT,16000)
|
|
CALL FREEFM (ITR)
|
|
MPRESET = RFREE(1)
|
|
IF (MPRESET .EQ. 0) MPRESET = 1000.0
|
|
WRITE (COUT,18000)
|
|
CALL FREEFM (ITR)
|
|
AFRAC = RFREE(1)
|
|
IF (AFRAC .EQ. 0) AFRAC = 0.5
|
|
ENDIF
|
|
DO 115 I = 1,10
|
|
IHK(I) = 0
|
|
NREFB(I) = 0
|
|
ILA(I) = 0
|
|
115 CONTINUE
|
|
C-----------------------------------------------------------------------
|
|
C Get the reflections to be used
|
|
C-----------------------------------------------------------------------
|
|
WRITE (COUT,19000)
|
|
CALL GWRITE (ITP,' ')
|
|
I = 0
|
|
IREFS = 0
|
|
120 WRITE (COUT,34000)
|
|
CALL FREEFM (ITR)
|
|
IH = IFREE(1)
|
|
IK = IFREE(2)
|
|
IL = IFREE(3)
|
|
IF (IH .NE. 0 .OR. IK .NE. 0 .OR. IL .NE. 0) THEN
|
|
ISTAN = 0
|
|
DPSI = 0
|
|
MREF = 0
|
|
IPRVAL = 1
|
|
CALL ANGCAL
|
|
IF (IVALID .EQ. 0) THEN
|
|
I = I + 1
|
|
IHK(I) = IH
|
|
NREFB(I) = IK
|
|
ILA(I) = IL
|
|
IREFS = I
|
|
ENDIF
|
|
GO TO 120
|
|
ENDIF
|
|
IF (I .EQ. 0) THEN
|
|
KI = ' '
|
|
RETURN
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C Set the first reflection as a check. (Probably unnecessary now)
|
|
C-----------------------------------------------------------------------
|
|
IH = IHK(1)
|
|
IK = NREFB(1)
|
|
IL = ILA(1)
|
|
IPRVAL = 0
|
|
CALL ANGCAL
|
|
CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICC)
|
|
CALL SHUTTR (1)
|
|
C WRITE (COUT,22000)
|
|
C CALL YESNO ('Y',ANS)
|
|
C IF (ANS .EQ. 'N') GO TO 100
|
|
C-----------------------------------------------------------------------
|
|
C Make and store the 8 angular combinations in T8,D8,A8,P8
|
|
C-----------------------------------------------------------------------
|
|
DO 200 J = 1,IREFS
|
|
IH = IHK(J)
|
|
IK = NREFB(J)
|
|
IL = ILA(J)
|
|
IPRVAL = 0
|
|
IF (DFMODL .NE. 'CAD4') THEN
|
|
CALL ANGCAL
|
|
TNEG = -THETA
|
|
CALL MOD360 (TNEG)
|
|
CNEG = -CHI
|
|
CALL MOD360 (CNEG)
|
|
PNEG = 180.0 + PHI
|
|
CALL MOD360 (PNEG)
|
|
T8(1) = THETA
|
|
T8(2) = THETA
|
|
T8(3) = TNEG
|
|
T8(4) = TNEG
|
|
T8(5) = THETA
|
|
T8(6) = THETA
|
|
T8(7) = TNEG
|
|
T8(8) = TNEG
|
|
DO 130 I = 1,8
|
|
D8(I) = OMEGA
|
|
130 CONTINUE
|
|
OMNEG = -OMEGA
|
|
CALL MOD360(OMNEG)
|
|
DO 140 I = 3,6
|
|
D8(I) = OMNEG
|
|
140 CONTINUE
|
|
A8(1) = CHI
|
|
A8(2) = CNEG
|
|
A8(7) = CNEG
|
|
A8(8) = CHI
|
|
CNEG = 180.0 + CNEG
|
|
CALL MOD360 (CNEG)
|
|
A8(4) = CNEG
|
|
A8(5) = CNEG
|
|
CNEG = 180 + CHI
|
|
CALL MOD360 (CNEG)
|
|
A8(3) = CNEG
|
|
A8(6) = CNEG
|
|
P8(1) = PHI
|
|
P8(2) = PNEG
|
|
P8(3) = PHI
|
|
P8(4) = PNEG
|
|
P8(5) = PNEG
|
|
P8(6) = PHI
|
|
P8(7) = PNEG
|
|
P8(8) = PHI
|
|
C-----------------------------------------------------------------------
|
|
C For CAD-4 :--
|
|
C Work out the 8 settings, as in CAD-4 manual, with the arcs of the
|
|
C goniometer head are horizontal and vertical - heaven knows why!!
|
|
C-----------------------------------------------------------------------
|
|
ELSE
|
|
DPSI = 0
|
|
ISTAN = 0
|
|
CALL ANGCAL
|
|
PSI = 360.0 - PHI
|
|
C-----------------------------------------------------------------------
|
|
C Rotate psi by -phi to get required position. This is approximate
|
|
C but good enough for alignment to start
|
|
C-----------------------------------------------------------------------
|
|
DPSI = 10.0
|
|
CALL ANGCAL
|
|
C-----------------------------------------------------------------------
|
|
C Generate positions 1, 2, 3 and 4 from this
|
|
C-----------------------------------------------------------------------
|
|
TNEG = -THETA
|
|
CALL MOD360 (TNEG)
|
|
T8(1) = THETA
|
|
T8(2) = TNEG
|
|
T8(3) = THETA
|
|
T8(4) = TNEG
|
|
D8(1) = OMEGA
|
|
D8(2) = OMEGA
|
|
OMEGA = -OMEGA
|
|
CALL MOD360 (OMEGA)
|
|
D8(3) = OMEGA
|
|
D8(4) = OMEGA
|
|
A8(1) = CHI
|
|
A8(2) = CHI
|
|
A8(3) = 180.0 - CHI
|
|
CALL MOD360 (A8(3))
|
|
A8(4) = A8(3)
|
|
P8(1) = PHI
|
|
P8(2) = PHI
|
|
PHI = 180.0 + PHI
|
|
CALL MOD360(PHI)
|
|
P8(3) = PHI
|
|
P8(4) = PHI
|
|
C-----------------------------------------------------------------------
|
|
C Calculate the position at Phi = 90 and take the settings at
|
|
C 180 + Phi and -Chi from there to generate settings 5, 6, 7 and 8
|
|
C-----------------------------------------------------------------------
|
|
PSI = PSI - 90.0
|
|
CALL MOD360 (PSI)
|
|
CALL ANGCAL
|
|
T8(5) = THETA
|
|
T8(6) = TNEG
|
|
T8(7) = THETA
|
|
T8(8) = TNEG
|
|
D8(5) = OMEGA
|
|
D8(6) = OMEGA
|
|
OMEGA = -OMEGA
|
|
CALL MOD360 (OMEGA)
|
|
D8(7) = OMEGA
|
|
D8(8) = OMEGA
|
|
CHI = -CHI
|
|
CALL MOD360 (CHI)
|
|
A8(5) = CHI
|
|
A8(6) = CHI
|
|
CHI = 180.0 - CHI
|
|
CALL MOD360 (CHI)
|
|
A8(7) = CHI
|
|
A8(8) = CHI
|
|
PHI = 180.0 + PHI
|
|
CALl MOD360 (PHI)
|
|
P8(5) = PHI
|
|
P8(6) = PHI
|
|
PHI = - PHI
|
|
CALl MOD360 (PHI)
|
|
P8(7) = PHI
|
|
P8(8) = PHI
|
|
C write (cout,99999) (i,t8(i),d8(i),a8(i),p8(i), i=1,8)
|
|
C99999 format (i3,4f10.3)
|
|
C call gwrite (itp,' ')
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C Set the 8 different settings, align them and store the results
|
|
C in T8,D8,A8 AND P8.
|
|
C-----------------------------------------------------------------------
|
|
TT0 = 0
|
|
OM0 = 0
|
|
CH0 = 0
|
|
MREF = 0
|
|
CALL SHUTTR (1)
|
|
DO 150 I = 1,8
|
|
145 ITRY = 1
|
|
THETA = T8(I)
|
|
OMEGA = D8(I)
|
|
CHI = A8(I)
|
|
PHI = P8(I)
|
|
MREF = MREF + 1
|
|
CALL HKLN (IH,IK,IL,MREF)
|
|
CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICC)
|
|
IF (ICC .NE. 0) THEN
|
|
WRITE (COUT,23000) MREF,IH,IK,IL
|
|
CALL GWRITE (ITP,' ')
|
|
GO TO 200
|
|
ENDIF
|
|
WRITE (COUT,24000) IH,IK,IL,THETA,OMEGA,CHI,PHI
|
|
CALL GWRITE (ITP,' ')
|
|
WRITE (LPT,24000) IH,IK,IL,THETA,OMEGA,CHI,PHI
|
|
CALL WXW2T (DT,DO,DC,ISLIT)
|
|
CALL SHUTTR (1)
|
|
CALL CCTIME (MPRESET,COUNT)
|
|
CALL KORQ(INTERRUPT)
|
|
IF(INTERRUPT .NE. 1) THEN
|
|
WRITE(COUT,37000)
|
|
RETURN
|
|
ENDIF
|
|
CALL SHUTTR (-1)
|
|
IF (KI .EQ. 'FF') THEN
|
|
IF (ITRY .EQ. 1) THEN
|
|
WRITE (LPT,25000) MREF,IH,IK,IL
|
|
WRITE (COUT,25000) MREF,IH,IK,IL
|
|
CALL GWRITE (ITP,' ')
|
|
ITRY = 2
|
|
GO TO 145
|
|
ELSE IF (ITRY .EQ. 2) THEN
|
|
WRITE (LPT,25100) MREF,IH,IK,IL
|
|
WRITE (COUT,25100) MREF,IH,IK,IL
|
|
CALL GWRITE (ITP,' ')
|
|
GO TO 200
|
|
ENDIF
|
|
ENDIF
|
|
WRITE (COUT,26000) RTHETA,ROMEGA,RCHI,RPHI,COUNT
|
|
CALL GWRITE (ITP,' ')
|
|
WRITE (LPT,26000) RTHETA,ROMEGA,RCHI,RPHI,COUNT
|
|
T8(I) = RTHETA
|
|
D8(I) = ROMEGA
|
|
A8(I) = RCHI
|
|
P8(I) = RPHI
|
|
150 CONTINUE
|
|
CALL SHUTTR (-1)
|
|
C-----------------------------------------------------------------------
|
|
C Analyse the results for CAD4 or all others
|
|
C-----------------------------------------------------------------------
|
|
DO 160 I = 1,8
|
|
IF (T8(I) .GE. 180.0) T8(I) = T8(I) - 360.0
|
|
TT0 = TT0 + T8(I)
|
|
IF (D8(I) .GE. 180.0) D8(I) = D8(I) - 360.0
|
|
OM0 = OM0 + D8(I)
|
|
CH0 = CH0 + A8(I)
|
|
160 CONTINUE
|
|
EXPCT = 0.
|
|
CALL ANG360(TT0,EXPCT)
|
|
TT0 = TT0/8.0
|
|
CALL ANG360(OM0,EXPCT)
|
|
OM0 = OM0/8.0
|
|
CALL ANG360(CH0,EXPCT)
|
|
CH0 = CH0/8.0
|
|
WRITE (COUT,28000) TT0,OM0,CH0
|
|
CALL GWRITE (ITP,' ')
|
|
WRITE (LPT,28000) TT0,OM0,CH0
|
|
C-----------------------------------------------------------------------
|
|
C Get the true values of the angles
|
|
C-----------------------------------------------------------------------
|
|
IF (DFMODL .NE. 'CAD4') THEN
|
|
TT0 = T8(1)+T8(2)+T8(5)+T8(6)-T8(3)-T8(4)-T8(7)-T8(8)
|
|
EXPCT = 8*T8(1)
|
|
CALL ANG360(TT0,EXPCT)
|
|
OM0 = D8(1)+D8(2)+D8(7)+D8(8)-D8(3)-D8(4)-D8(5)-D8(6)
|
|
EXPCT = 8*D8(1)
|
|
CALL ANG360(OM0,EXPCT)
|
|
CH0 = A8(1)+A8(3)+A8(6)+A8(8)-A8(2)-A8(4)-A8(5)-A8(7)
|
|
EXPCT = 8*A8(1)
|
|
CALL ANG360(CH0,EXPCT)
|
|
TT0 = TT0/8.0
|
|
OM0 = OM0/8.0
|
|
CALL MOD360 (OM0)
|
|
CH0 = CH0/8.0
|
|
C BCOUNT(J-1) = TT0
|
|
C BBGR1(J-1) = OM0
|
|
C BBGR2(J-1) = CH0
|
|
C BTIME(J-1) = PHI
|
|
WRITE (COUT,29000) TT0,OM0,CH0,PHI
|
|
CALL GWRITE (ITP,' ')
|
|
WRITE (LPT,29000) TT0,OM0,CH0,PHI
|
|
CHXL = A8(1)+A8(2)+A8(3)+A8(4)-A8(5)-A8(6)-A8(7)-A8(8)
|
|
EXPCT = 0.
|
|
CALL ANG360(CHXL,EXPCT)
|
|
CHC = A8(1)+A8(2)+A8(5)+A8(6)-A8(3)-A8(4)-A8(7)-A8(8)
|
|
CALL ANG360(CHC,EXPCT)
|
|
CHXL = CHXL/8.0
|
|
CHC = CHC/8.0
|
|
WRITE (COUT,30000) CHXL,CHC
|
|
CALL GWRITE (ITP,' ')
|
|
WRITE (LPT,30000) CHXL,CHC
|
|
ELSE
|
|
OM0 = (D8(1)-D8(2)+D8(3)-D8(4)+D8(5)-D8(6)+D8(7)-D8(8))/8.0
|
|
CH0 = (A8(1)-A8(2)+A8(3)-A8(4)+A8(5)-A8(6)+A8(7)-A8(8))/8.0
|
|
DMON = 5.4*CH0*SIN(0.5*T8(1)/RA)
|
|
VER = 216.5*TAN(DMON/RA)
|
|
HOR = 3.78*OM0
|
|
DETEC = 3.02*(TT0 - OM0)
|
|
WRITE (COUT,35000) DETEC,HOR,VER,DMON
|
|
CALL GWRITE (ITP,' ')
|
|
WRITE (LPT,35000) DETEC,HOR,VER,DMON
|
|
TT0 = (T8(1)-T8(2)+T8(3)-T8(4)+T8(5)-T8(6)+T8(7)-T8(8))/8.0
|
|
OMET = (D8(1)+D8(2)-D8(3)-D8(4)-A8(5)-A8(6)+A8(7)+A8(8))/8.0
|
|
CHIT = (A8(1)+A8(2)-A8(3)-A8(4)-D8(5)-D8(6)+D8(7)+D8(8))/8.0
|
|
CHSIGN = 1.0
|
|
IF (A8(1) .GT. 180.0) CHSIGN = -1.0
|
|
CHIT = CHSIGN*(90.0 + CHIT)
|
|
CALL MOD360 (CHIT)
|
|
PHIT = 0.0
|
|
WRITE (COUT,36000) TT0,OMET,CHIT,PHIT
|
|
CALL GWRITE (ITP,'%')
|
|
WRITE (LPT,36000) TT0,OMET,CHIT,PHIT
|
|
ENDIF
|
|
200 CONTINUE
|
|
KI = ' '
|
|
RETURN
|
|
10000 FORMAT (' 8 Reflection Centring (Y) ? ',$)
|
|
C12000 FORMAT (' *** WARNING --- Remove the low temp. arm *** ',/,
|
|
C $ ' Type the Source-to-Crystal distance (',I3,'mm) ',$)
|
|
C14000 FORMAT (' Type the Crystal-to-Detector distance (',I3,'mm) ',$)
|
|
14900 FORMAT (' Type the horizontal slit width in mms (4.0) ',$)
|
|
15000 FORMAT (' Type the 2T,Om,Ch step size in 1/',I3,'th',
|
|
$ ' (',I2,',',I2,',',I2,') ',$)
|
|
16000 FORMAT (' Type the count preset per step (1000.0) ',$)
|
|
18000 FORMAT (' Type the max count cutoff fraction (0.5) ',$)
|
|
19000 FORMAT (' Type h,k,l for reflections to be used (End) ')
|
|
C22000 FORMAT (' The 1st reflection is set. Is everything OK (Y) ? ',$)
|
|
23000 FORMAT (' Setting',I2,', Collision. Cannot complete',3I4)
|
|
24000 FORMAT (' Starting values ',3I4,4F10.3)
|
|
25000 FORMAT (' Setting',I2,' of',3I4,' failed on first attempt.')
|
|
25100 FORMAT (' Setting',I2,' of',3I4,' failed. Cannot complete')
|
|
26000 FORMAT (' Final values ',12X,4F10.3,F8.0)
|
|
28000 FORMAT (' Zero Values of TT,OM,CH ',3F8.3)
|
|
29000 FORMAT (' True values of TT,OM,CH ',3F8.3,' (at Phi',F8.3,')')
|
|
30000 FORMAT (' Delta-chi Crystal ',F8.3,5X,'Delta-chi Counter ',
|
|
$ F8.3//)
|
|
C31000 FORMAT (' SXT ',F10.3,' SXO',F10.3,' CXT',F10.3)
|
|
C32000 FORMAT (' SYT ',F10.3,' SYO',F10.3,' CYT',F10.3//)
|
|
34000 FORMAT (' Next h,k,l (End) ',$)
|
|
35000 FORMAT (' Offsets: Det',F7.3,'mm, Hor',F7.3,'mm, ',
|
|
$ 'Ver',F7.3,'mm, Mon',F7.3,'deg.')
|
|
36000 FORMAT (' True 2Theta Omega Chi Phi'/2X,4F10.3/)
|
|
37000 FORMAT (' Operation interrupted by user')
|
|
END
|
|
C-----------------------------------------------------------------------
|
|
C Routine to make the difference between ANG and EXPCT small
|
|
C-----------------------------------------------------------------------
|
|
SUBROUTINE ANG360 (ANG,EXPCT)
|
|
100 D = EXPCT - ANG
|
|
ISIGN = 1
|
|
IF (D .LT. 0.) ISIGN = -1
|
|
IF (ABS(D) .GE. 180.0) THEN
|
|
ANG = ANG + ISIGN*360.0
|
|
GO TO 100
|
|
ENDIF
|
|
RETURN
|
|
END
|