PSI sics-cvs-psi_pre-ansto
This commit is contained in:
Douglas Clowes
190
difrac/tcentr.f
Normal file
190
difrac/tcentr.f
Normal file
@@ -0,0 +1,190 @@
|
||||
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))
|
||||
REAL CURCTS,MAXCTS
|
||||
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-----------------------------------------------------------------------
|
||||
C CAD-4 and Sietronics deleted for clarity: Mark Koennecke
|
||||
CALL SHUTTR (99)
|
||||
C-----------------------------------------------------------------------
|
||||
C All other machines for the moment
|
||||
C Modified: Mark Koennecke for TRICS
|
||||
C Do initial search. But use the results of the searches
|
||||
C only if they improved the countrate.
|
||||
C-----------------------------------------------------------------------
|
||||
CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICOL)
|
||||
CALL CCTIME (PRESET,CURCTS)
|
||||
C----- first two theta
|
||||
RTIM = PRESET
|
||||
CALL TFIND(RTIM,MAXCTS)
|
||||
IF(MAXCTS .LT. CURCTS) THEN
|
||||
THETA = RTHETA
|
||||
OMEGA = ROMEGA
|
||||
ELSE
|
||||
CURCTS = MAXCTS
|
||||
ENDIF
|
||||
CALL KORQ (IFLAG1)
|
||||
IF (IFLAG1 .NE. 1) THEN
|
||||
KI = 'O4'
|
||||
RETURN
|
||||
ENDIF
|
||||
C----- now phi
|
||||
RTIM = PRESET
|
||||
CALL PFIND(RTIM,MAXCTS)
|
||||
IF(MAXCTS .LT. CURCTS) THEN
|
||||
PHI = RPHI
|
||||
ELSE
|
||||
CURCTS = MAXCTS
|
||||
ENDIF
|
||||
CALL KORQ (IFLAG1)
|
||||
IF (IFLAG1 .NE. 1) THEN
|
||||
KI = 'O4'
|
||||
RETURN
|
||||
ENDIF
|
||||
C------ finally phi
|
||||
RTIM = PRESET
|
||||
CALL CFIND(RTIM,MAXCTS)
|
||||
IF(MAXCTS .LT. CURCTS) THEN
|
||||
CHI = RCHI
|
||||
ELSE
|
||||
CURCTS = MAXCTS
|
||||
ENDIF
|
||||
CALL KORQ (IFLAG1)
|
||||
IF (IFLAG1 .NE. 1) THEN
|
||||
KI = 'O4'
|
||||
RETURN
|
||||
ENDIF
|
||||
C------- end of pre centering
|
||||
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 CCTIME (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
|
||||
Reference in New Issue
Block a user