218 lines
8.3 KiB
Fortran
218 lines
8.3 KiB
Fortran
C-----------------------------------------------------------------------
|
|
C This subroutine controls the automatic alignment of reflections
|
|
C-----------------------------------------------------------------------
|
|
SUBROUTINE TCENTR (NSTORE)
|
|
INCLUDE 'COMDIF'
|
|
DIMENSION THETAS(NSIZE), OMEGS(NSIZE), CHIS(NSIZE),PHIS(NSIZE),
|
|
$ ITIMS(NSIZE),THETAP(NSIZE),OMEGP(NSIZE),CHIP(NSIZE),
|
|
$ PHIP(NSIZE)
|
|
CHARACTER WHICH*6
|
|
EQUIVALENCE (ACOUNT( 1),THETAS(1)),
|
|
$ (ACOUNT( NSIZE+1),OMEGS(1)),
|
|
$ (ACOUNT(2*NSIZE+1),CHIS(1)),
|
|
$ (ACOUNT(3*NSIZE+1),PHIS(1)),
|
|
$ (ACOUNT(4*NSIZE+1),ITIMS(1)),
|
|
$ (ACOUNT(5*NSIZE+1),THETAP(1)),
|
|
$ (ACOUNT(6*NSIZE+1),OMEGP(1)),
|
|
$ (ACOUNT(7*NSIZE+1),CHIP(1)),
|
|
$ (ACOUNT(8*NSIZE+1),PHIP(1))
|
|
WIDTH = 1.25
|
|
C-----------------------------------------------------------------------
|
|
C Read the peaks from disk
|
|
C-----------------------------------------------------------------------
|
|
CALL ANGRW (0,4,NMAX,160,0)
|
|
C-----------------------------------------------------------------------
|
|
C Save the current angles for later
|
|
C-----------------------------------------------------------------------
|
|
DO 100 J = 1,NMAX
|
|
THETAP(J) = THETAS(J)
|
|
OMEGP(J) = OMEGS(J)
|
|
PHIP(J) = PHIS(J)
|
|
CHIP(J) = CHIS(J)
|
|
100 CONTINUE
|
|
C-----------------------------------------------------------------------
|
|
C Centre the NSTORE to NMAX positions
|
|
C-----------------------------------------------------------------------
|
|
NGOOD = NSTORE - 1
|
|
DO 210 J = NSTORE,NMAX
|
|
C-----------------------------------------------------------------------
|
|
C Check if a K or a Q was typed on the terminal
|
|
C-----------------------------------------------------------------------
|
|
CALL KORQ (IFLAG1)
|
|
IF (IFLAG1 .NE. 1) THEN
|
|
KI = 'O4'
|
|
RETURN
|
|
ENDIF
|
|
RTHETA = THETAS(J)
|
|
ROMEGA = OMEGS(J)
|
|
RCHI = CHIS(J)
|
|
RPHI = PHIS(J)
|
|
WRITE (COUT,10000) J,RTHETA,ROMEGA,RCHI,RPHI
|
|
CALL GWRITE (ITP,' ')
|
|
WRITE (LPT,10000) J,RTHETA,ROMEGA,RCHI,RPHI
|
|
CALL ANGSET (RTHETA,ROMEGA,RCHI,RPHI,NATT,ICOL)
|
|
THETA = RTHETA
|
|
OMEGA = ROMEGA
|
|
CHI = RCHI
|
|
PHI = RPHI
|
|
C-----------------------------------------------------------------------
|
|
C Set the angles at the approximate position of the peak and adjust
|
|
C Phi, Chi and 2Theta to get maximum intensity in the detector.
|
|
C Sietronics interface works via MAXPOINT; CAD4 via CADCEN
|
|
C-----------------------------------------------------------------------
|
|
CALL SHUTTR (99)
|
|
ITIMS(J) = 0
|
|
IF (DFMODL .EQ. 'CAD4') THEN
|
|
KI = 'SP'
|
|
CALL CADCEN (0)
|
|
IF (KI .EQ. 'FF') THEN
|
|
WHICH = 'Phi'
|
|
WRITE (COUT,13000) WHICH
|
|
CALL GWRITE (ITP,' ')
|
|
WRITE (LPT,13000) WHICH
|
|
GO TO 200
|
|
ENDIF
|
|
110 CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICOL)
|
|
KI = 'ST'
|
|
IGOOD = 0
|
|
CALL CADCEN (IGOOD)
|
|
C write (lpt,99993) ki,igood
|
|
C99993 format (' KI,igood ',a,i4)
|
|
IF (KI .EQ. 'FF' .OR. KI .EQ. 'TO' .OR. KI .EQ. 'BO') THEN
|
|
CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,IERR)
|
|
KI = 'SC'
|
|
RTIM = PRESET
|
|
CALL CFIND (RTIM)
|
|
CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICOL)
|
|
IF (RTIM .GT. 3.0) THEN
|
|
WHICH = 'Chi'
|
|
WRITE (COUT,13000) WHICH
|
|
CALL GWRITE (ITP,' ')
|
|
WRITE (LPT,13000) WHICH
|
|
GO TO 200
|
|
ENDIF
|
|
KI = 'SO'
|
|
IGOOD = 0
|
|
CALL CADCEN (IGOOD)
|
|
IF (KI .EQ. 'FF') THEN
|
|
WHICH = 'Omega'
|
|
WRITE (COUT,13000) WHICH
|
|
CALL GWRITE (ITP,' ')
|
|
WRITE (LPT,13000) WHICH
|
|
GO TO 200
|
|
ENDIF
|
|
GO TO 110
|
|
ENDIF
|
|
IF (IGOOD .NE. 0) GO TO 110
|
|
C-----------------------------------------------------------------------
|
|
C Sietronics 145D centring
|
|
C-----------------------------------------------------------------------
|
|
ELSE IF (DFMODL .EQ. '145D') THEN
|
|
PWIDTH = 2*WIDTH
|
|
CALL MAXPOINT (3,PWIDTH,0.1,RMAXPT)
|
|
PHI = RMAXPT
|
|
CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICOL)
|
|
CWIDTH = 4*WIDTH
|
|
CALL MAXPOINT (2,CWIDTH,0.1,RMAXPT)
|
|
CHI = RMAXPT
|
|
OMEGA = OMEGA - 0.5*TWIDTH
|
|
CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICOL)
|
|
TWIDTH = WIDTH
|
|
CALL MAXPOINT (4,TWIDTH,0.1,RMAXPT)
|
|
THETA = RMAXPT
|
|
C-----------------------------------------------------------------------
|
|
C All other machines for the moment
|
|
C-----------------------------------------------------------------------
|
|
ELSE
|
|
RTIM = 1000.
|
|
CALL PFIND (RTIM)
|
|
THETA = RTHETA
|
|
OMEGA = ROMEGA
|
|
IF (RTIM .GT. 10000.0) GO TO 200
|
|
C IF (RTIM .GT. 1.0) RTIM = 1.0
|
|
CHI = RCHI + 1.25
|
|
CALL CFIND (RTIM)
|
|
THETA = RTHETA + 1.25
|
|
OMEGA = OMEGA - 0.625
|
|
IF (RTIM .GT. 10000.0) GO TO 200
|
|
C IF (RTIM .GT. 1.0) RTIM = 1.0
|
|
CALL TFIND (RTIM)
|
|
IF (RTIM .GT. 10000.0) GO TO 200
|
|
ENDIF
|
|
WRITE (COUT,11000) THETA,OMEGA,CHI,PHI
|
|
CALL GWRITE (ITP,' ')
|
|
WRITE (LPT,11000) THETA,OMEGA,CHI,PHI
|
|
CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICOL)
|
|
C-----------------------------------------------------------------------
|
|
C Save the tweaked positions to make life a little easier later
|
|
C-----------------------------------------------------------------------
|
|
THETAP(J) = THETA
|
|
OMEGP(J) = OMEGA
|
|
CHIP(J) = CHI
|
|
PHIP(J) = PHI
|
|
CALL ANGRW (1,4,NMAX,160,1)
|
|
C-----------------------------------------------------------------------
|
|
C Now proceed with the conventional alignment with defaults appropriate
|
|
C to fully open windows
|
|
C The steps are adapted to the 2-Theta angle.
|
|
C-----------------------------------------------------------------------
|
|
AFRAC = 0.5
|
|
CON = IFRDEF
|
|
CON = 10.0/(IFRDEF*THETA)
|
|
DT = 10.0*CON
|
|
DO = 5.0*CON
|
|
DC = 50.0*CON
|
|
IF(PRESET .LT. 1000) PRESET = 1000.0
|
|
C IF (TIME .LT. 0.10) TIME = 0.10
|
|
C IF (TIME .GT. 3.0) GO TO 200
|
|
NATT = 0
|
|
IF (CHI .LT. 0.0) CHI = CHI + 360.0
|
|
IF (CHI .GT. 360.0) CHI = CHI - 360.0
|
|
IF (PHI .LT. 0.0) PHI = PHI + 360.0
|
|
IF (PHI .GT. 360.0) PHI = PHI - 360.0
|
|
CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICOL)
|
|
ISLIT = 0
|
|
IF (DFMODL .EQ. 'CAD4') ISLIT = 40
|
|
CALL WXW2T (DT,DO,DC,ISLIT)
|
|
COUNT = 0
|
|
ITIMS(J) = 0
|
|
IF (KI .EQ. 'FF') GO TO 200
|
|
C-----------------------------------------------------------------------
|
|
C Position on the peak and count for standard preset
|
|
C-----------------------------------------------------------------------
|
|
CALL ANGSET (RTHETA,ROMEGA,RCHI,RPHI,NATT,ICOL)
|
|
CALL SHUTTR (99)
|
|
CALL CTIME (PRESET,COUNT)
|
|
ICOUNT = COUNT
|
|
C-----------------------------------------------------------------------
|
|
C Do not save a weak count
|
|
C-----------------------------------------------------------------------
|
|
IF (ICOUNT .LT. 100) GO TO 200
|
|
WRITE (COUT,12000) RTHETA,ROMEGA,RCHI,RPHI,ICOUNT
|
|
CALL GWRITE (ITP,' ')
|
|
WRITE (LPT,12000) RTHETA,ROMEGA,RCHI,RPHI,ICOUNT
|
|
C-----------------------------------------------------------------------
|
|
C If the alignment was successful, remember it
|
|
C-----------------------------------------------------------------------
|
|
THETAP(J) = RTHETA
|
|
OMEGP(J) = ROMEGA
|
|
CHIP(J) = RCHI
|
|
PHIP(J) = RPHI
|
|
CALL ANGRW (1,4,NMAX,160,1)
|
|
NGOOD = NGOOD + 1
|
|
THETAS(NGOOD) = RTHETA
|
|
OMEGS(NGOOD) = ROMEGA
|
|
CHIS(NGOOD) = RCHI
|
|
PHIS(NGOOD) = RPHI
|
|
ITIMS(NGOOD) = COUNT
|
|
CALL ANGRW (1,5,NGOOD,140,0)
|
|
200 CALL SHUTTR (-99)
|
|
210 CONTINUE
|
|
KI = 'O4'
|
|
RETURN
|
|
10000 FORMAT (/' Peak',I4,' Coarse Setting ',4F10.3)
|
|
11000 FORMAT ( ' Approximate ',4F10.3)
|
|
12000 FORMAT ( ' Final Values ',4F10.3,I10)
|
|
13000 FORMAT (' Coarse centering failure in ',A)
|
|
END
|