linse/sics
0
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
ef5a0354f3edfc92ac90fc462f77df3478bad641
sics/difrac/tcentr.f
cvs 714b8ae84d - Fixed a bug which caused the SICServer to die when a socket was broken. 
- Fixed many things in DIFRAC subsystem:
  * Recoded tcentr.f etc so that the course centering will work and will not
    go into an endless loop.
  * fixed boundary overwrites which occurred when yesno or alfnum where
    uset to get a single character and several were given.
  * Addeded documentation for DIFRAC
- Added tcl-files which  support the WWW status system
2000-03-31 13:16:50 +00:00

191 lines
7.1 KiB
Fortran
Raw Blame History

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 View Git Blame Copy Permalink