linse/sics
0
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Initial revision

Browse Source
This commit is contained in:
cvs
2000-02-07 10:38:55 +00:00
commit fdc6b051c9
846 changed files with 230218 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

217
difrac/tcentr.f Normal file
View File

@@ -0,0 +1,217 @@
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