Initial revision
This commit is contained in:
cvs
353
difrac/trics.f
Normal file
353
difrac/trics.f
Normal file
@@ -0,0 +1,353 @@
|
||||
C-----------------------------------------------------------------------
|
||||
C RALF Routines for TRICS running SICS
|
||||
C interface.
|
||||
C
|
||||
C Mark Koennecke, November 1999
|
||||
C
|
||||
C-----------------------------------------------------------------------
|
||||
SUBROUTINE HKLN (I1, I2, I3, I4)
|
||||
J1 = I1
|
||||
J2 = I2
|
||||
J3 = I3
|
||||
J4 = I4
|
||||
RETURN
|
||||
END
|
||||
C-----------------------------------------------------------------------
|
||||
C INTON This routine must be called before any others and may be
|
||||
C used to initialise the diffractometer
|
||||
C-----------------------------------------------------------------------
|
||||
SUBROUTINE INTON
|
||||
RETURN
|
||||
END
|
||||
C-----------------------------------------------------------------------
|
||||
C INTOFF -- clean up the interface
|
||||
C-----------------------------------------------------------------------
|
||||
SUBROUTINE INTOFF
|
||||
return
|
||||
end
|
||||
C-----------------------------------------------------------------------
|
||||
C ZERODF In case of an error this routine returns the diffractometer
|
||||
C to a known state
|
||||
C-----------------------------------------------------------------------
|
||||
SUBROUTINE ZERODF
|
||||
RETURN
|
||||
END
|
||||
C-----------------------------------------------------------------------
|
||||
C CTIME Count for a fixed time
|
||||
C-----------------------------------------------------------------------
|
||||
SUBROUTINE CTIME (XTIME, XCOUNT)
|
||||
REAL XTIME, XCOUNT
|
||||
INCLUDE 'COMDIF'
|
||||
call setslt (icadsl,icol)
|
||||
CALL SICSCOUNT(XTIME,XCOUNT)
|
||||
RETURN
|
||||
END
|
||||
C-----------------------------------------------------------------------
|
||||
C ANGET Read the angles
|
||||
C-----------------------------------------------------------------------
|
||||
SUBROUTINE ANGET (WTWOTH, WOMEGA, WCHI, WPHI)
|
||||
include 'COMDIF'
|
||||
CALL SICSANGET(WTWOTH,WOMEGA,WCHI,WPHI)
|
||||
wtwoth = wtwoth - dtheta
|
||||
womega = womega - wtwoth/2. - domega
|
||||
wchi = wchi - dchi
|
||||
wphi = wphi - dphi
|
||||
if (wtwoth .lt. 0.0) wtwoth = wtwoth + 360.00
|
||||
if (womega .lt. 0.0) womega = womega + 360.00
|
||||
if (wchi .lt. 0.0) wchi = wchi + 360.00
|
||||
if (wphi .lt. 0.0) wphi = wphi + 360.00
|
||||
RETURN
|
||||
END
|
||||
C----------------------------------------------------------------------
|
||||
C ANGCHECK check the angles against hardware or software limits
|
||||
C-----------------------------------------------------------------------
|
||||
SUBROUTINE ANGCHECK (WTHETA, WOMEGA, WCHI, WPHI, INVALID)
|
||||
include 'COMDIF'
|
||||
atheta = wtheta + dtheta
|
||||
aomega = womega + domega + wtheta/2.0
|
||||
achi = wchi + dchi
|
||||
aphi = wphi + dphi
|
||||
if (atheta .gt. 180.00) atheta = atheta - 360.00
|
||||
if (aomega .gt. 180.00) aomega = aomega - 360.00
|
||||
IF(ACHI .LT. 0)ACHI = ACHI + 360.
|
||||
IF(APHI .GT. 360.)APHI = APHI - 360.
|
||||
IF(APHI .LT. 0) APHI = APHI + 360.
|
||||
CALL SICSANGCHECK(ATHETA,AOMEGA,ACHI,APHI,INVALID)
|
||||
RETURN
|
||||
END
|
||||
C-----------------------------------------------------------------------
|
||||
C ANGSET Set the angles
|
||||
C-----------------------------------------------------------------------
|
||||
SUBROUTINE ANGSET (WTHETA, WOMEGA, WCHI, WPHI, NATTW, ICOL)
|
||||
include 'COMDIF'
|
||||
ishutf = 0
|
||||
if (nattw .gt. 0) then
|
||||
iattf = 1
|
||||
else
|
||||
iattf = 0
|
||||
endif
|
||||
atheta = wtheta + dtheta
|
||||
aomega = womega + wtheta/2. + domega
|
||||
achi = wchi + dchi
|
||||
aphi = wphi + dphi
|
||||
if (atheta .gt. 180.00) atheta = atheta - 360.00
|
||||
if (aomega .gt. 180.00) aomega = aomega - 360.00
|
||||
IF(ACHI .LT. 0)ACHI = ACHI + 360.
|
||||
IF(APHI .GT. 360.)APHI = APHI - 360.
|
||||
IF(APHI .LT. 0) APHI = APHI + 360.
|
||||
CALL SICSANGSET(ATHETA,AOMEGA,ACHI,APHI,ICOL)
|
||||
RETURN
|
||||
END
|
||||
C-----------------------------------------------------------------------
|
||||
C SHUTR Open or close the shutter
|
||||
C IOC = 1 open, 2 close
|
||||
C INF = 0 OK
|
||||
C-----------------------------------------------------------------------
|
||||
SUBROUTINE SHUTR (IOC, INF)
|
||||
INF = 0
|
||||
IF (IOC .EQ. 1) THEN
|
||||
ISHUTF = 1
|
||||
ELSE
|
||||
ISHUTF = 0
|
||||
ENDIF
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE ONEBEP(R1,R2)
|
||||
CHARACTER CTRLG*1
|
||||
RETURN
|
||||
END
|
||||
|
||||
C-----------------------------------------------------------------------
|
||||
C KORQ -- Read the keyboard buffer
|
||||
C If it contains K|k|Q|q return: 0 = K
|
||||
C 1 = nothing found
|
||||
C 2 = Q
|
||||
C
|
||||
C KORQ will toggle the switch registers 1-9,0 if the numeric
|
||||
C keys are found in the buffer.
|
||||
C-----------------------------------------------------------------------
|
||||
SUBROUTINE KORQ (I1)
|
||||
INCLUDE 'COMDIF'
|
||||
CHARACTER STRING*80
|
||||
LOGICAL SWFND,SAVED,SWCALL
|
||||
DATA SAVED/.FALSE./
|
||||
SWFND = .FALSE.
|
||||
C-----------------------------------------------------------------------
|
||||
C First check if we are making a regular call after a K or Q has been
|
||||
C found from a call from RSW.
|
||||
C-----------------------------------------------------------------------
|
||||
CALL CHECKINT(I1)
|
||||
RETURN
|
||||
END
|
||||
C-----------------------------------------------------------------------
|
||||
C RSW Read the switch register
|
||||
C-----------------------------------------------------------------------
|
||||
SUBROUTINE RSW (N,IVALUE)
|
||||
INCLUDE 'COMDIF'
|
||||
RETURN
|
||||
END
|
||||
C-----------------------------------------------------------------------
|
||||
C Initialise the Program
|
||||
C-----------------------------------------------------------------------
|
||||
SUBROUTINE INITL(R1,R2,R3,R4)
|
||||
A1 = R1
|
||||
A2 = R2
|
||||
A3 = R3
|
||||
A4 = R4
|
||||
RETURN
|
||||
END
|
||||
C--------------------------------------------------------------------
|
||||
C Routine to perform scans.
|
||||
C ITYPE Scan type -- 0 or 2 Omega/2-theta
|
||||
C 1 or 3 Omega
|
||||
C SCNANG Angle to scan in degrees. This should be the
|
||||
C 2theta range for an omega-2theta scan and the
|
||||
C omega range for an omega scan.
|
||||
C ACOUNT Returns total intensity in ACOUNT(1) and profile
|
||||
C in ACOUNT(2)-ACOUNT(NPPTS+1)
|
||||
C TIME Total scan time in secs
|
||||
C SPEED Scan speed in degs/min.
|
||||
C NPPTS Number of points in the profile on output
|
||||
C IERR Error code 0 -- O.K.
|
||||
C 1 -- Collision
|
||||
C 2 or more really bad!
|
||||
C--------------------------------------------------------------------
|
||||
SUBROUTINE TSCAN (ITYPE,SCNANG,ACOUNT,PRESET,STEP,NPPTS,IERR)
|
||||
COMMON /DFMACH/ ISCDEF,ICDDEF,IDTDEF,IDODEF,IDCDEF,IFRDEF,NRC,
|
||||
$ NATTEN,STEPDG,ICADSL,ICADSW
|
||||
DIMENSION ACOUNT(*)
|
||||
REAL THSTART, OMSTART, CHI, PHI, TH, OM
|
||||
INTEGER ICOL, IT
|
||||
C--------------------------------------------------------------------
|
||||
C Version 0.50 Supports itype = 0 or 1 omega-2theta and
|
||||
C 2 or 3 omega
|
||||
C in both cases IANGLE is omega at the end of the scan
|
||||
C
|
||||
C Version 0.6 Modified to be a generic routine using ANGSET and
|
||||
C CTIME for doing the scans. This ammounts to a simple
|
||||
C step scan. This is the only useful thing for TRICS
|
||||
C at SINQ.
|
||||
C PRESET is the preset for counting.
|
||||
C STEP is the scan step width.
|
||||
C--------------------------------------------------------------------
|
||||
IERR = 0
|
||||
C--------------------------------------------------------------------
|
||||
C The diffractometer should have been positioned at the beginning
|
||||
C position for the scan.
|
||||
C--------------------------------------------------------------------
|
||||
CALL SETSLT (ICADSL,ICOL)
|
||||
isense = 1
|
||||
if (scnang .lt. 0.0) then
|
||||
isense = -1
|
||||
scnang = - scnang
|
||||
endif
|
||||
NPPTS = INT(SCNANG/STEP)
|
||||
CALL ANGET(THSTART,OMSTART,CHI,PHI)
|
||||
IF (ITYPE .EQ. 0 .OR. ITYPE .EQ. 1) THEN
|
||||
MODE = 0
|
||||
C--------------------------------------------------------------------
|
||||
C Omega scan
|
||||
C--------------------------------------------------------------------
|
||||
ELSE IF (ITYPE .EQ. 2 .OR. ITYPE .EQ. 3) THEN
|
||||
MODE = 2
|
||||
ELSE
|
||||
IERR = 2
|
||||
RETURN
|
||||
ENDIF
|
||||
C--------------------------------------------------------------------
|
||||
C Setup complete -- do the scan
|
||||
C--------------------------------------------------------------------
|
||||
ACOUNT(1) = 0.
|
||||
DO 200, I = 1, NPPTS
|
||||
C----- position
|
||||
IF(MODE .EQ. 0) THEN
|
||||
TH = THSTART + ISENSE*I*STEP
|
||||
OM = 0
|
||||
ELSE IF(MODE .EQ. 2)THEN
|
||||
TH = THSTART
|
||||
OM = OMSTART + ISENSE*I*STEP
|
||||
ENDIF
|
||||
CALL ANGSET(TH,OM,CHI,PHI,1,ICOL)
|
||||
IF(ICOL .GT. 0)THEN
|
||||
IERR = 2
|
||||
RETURN
|
||||
ENDIF
|
||||
C----- count
|
||||
CALL CTIME(PRESET,COUNT)
|
||||
CALL KORQ(IT)
|
||||
IF(IT .NE. 1)THEN
|
||||
IERR = 2
|
||||
RETURN
|
||||
ENDIF
|
||||
ACOUNT(I+1) = COUNT
|
||||
ACOUNT(1) = ACOUNT(1) + COUNT
|
||||
200 CONTINUE
|
||||
return
|
||||
end
|
||||
C--------------------------------------------------------------------
|
||||
C Routine to display a peak profile in the current graphics window.
|
||||
C The arguments are:
|
||||
C
|
||||
C NHIST The number of points to be plotted
|
||||
C HIST An array of points
|
||||
C IHTAGS(4) The calculated peak position, the experimental position,
|
||||
C low background limit and high background limit.
|
||||
C--------------------------------------------------------------------
|
||||
SUBROUTINE PTPREP (NHIST,HIST,IHTAGS)
|
||||
INTEGER IHTAGS(4)
|
||||
REAL HIST(*)
|
||||
INTEGER IX,IY,IZ
|
||||
CHARACTER STRING*80
|
||||
RETURN
|
||||
END
|
||||
C-------------------------------------------------------------------
|
||||
C RPSCAN Ralf support for PSCAN routine
|
||||
C PHI scan from -90 to 90 with a step of 2.
|
||||
C-------------------------------------------------------------------
|
||||
SUBROUTINE RPSCAN (NPTS,ICOL,SPRESET)
|
||||
INCLUDE 'COMDIF'
|
||||
INTEGER IDIR,I,IT
|
||||
REAL WTH,WOM,WCHI,WPHI, STEP, PHI,SPRESET
|
||||
STEP = 2.
|
||||
C-------------------------------------------------------------------
|
||||
C Get the current angles and decide which direction to scan
|
||||
C-------------------------------------------------------------------
|
||||
CALL ANGET (WTH,WOM,WCHI,WPHI)
|
||||
C------------------------------------------------------------------
|
||||
C have the scan go always from 270 - 90 region as TRICS may have
|
||||
C restrictions around 0.
|
||||
C------------------------------------------------------------------
|
||||
WPHI = 270.00
|
||||
TARGET = 90.00
|
||||
IDIR = -1
|
||||
NPTS = 90
|
||||
C-------------------------------------------------------------------
|
||||
C Now do the scan
|
||||
C-------------------------------------------------------------------
|
||||
ACOUNT(1) = 0.
|
||||
DO 200, I = 1, NPTS
|
||||
C----- position
|
||||
PHI = WPHI + I*IDIR*STEP
|
||||
CALL ANGSET(WTH,WOM,WCHI,PHI,1,ICOL)
|
||||
IF(ICOL .GT. 0)THEN
|
||||
IERR = 2
|
||||
RETURN
|
||||
ENDIF
|
||||
C----- count
|
||||
CALL CTIME(SPRESET,COUNT)
|
||||
CALL KORQ(IT)
|
||||
IF(IT .NE. 1)THEN
|
||||
IERR = 2
|
||||
RETURN
|
||||
ENDIF
|
||||
ACOUNT(I) = COUNT
|
||||
ACOUNT(5*NSIZE+I) = PHI
|
||||
200 CONTINUE
|
||||
RETURN
|
||||
END
|
||||
C-------------------------------------------------------------------
|
||||
C special to some strange diffractometer, just keep the linker happy
|
||||
C-------------------------------------------------------------------
|
||||
SUBROUTINE MAXPOINT (IAXIS,WIDTH,STEPS,ANGLE)
|
||||
RETURN
|
||||
END
|
||||
C-----------------------------------------------------------------------
|
||||
C GENSCN Routine to perform a scan of a given motor
|
||||
C ICIRCL 1 -- 2-theta ISLIT 0 -- Nothing
|
||||
C 2 -- omega 1 -- Vertical
|
||||
C 3 -- kappa 2 -- Horizontal
|
||||
C 4 -- phi 3 -- +45 deg
|
||||
C 4 -- -45 deg
|
||||
C 5 -- Upper 1/2 circle
|
||||
C 6 -- Lower 1/2 circle
|
||||
C 10 to 59 -- horiz. aperture in mms
|
||||
C SPEED Speed in degrees per minute
|
||||
C STEP Step width in degrees, NPTS number of steps
|
||||
C ICOL 0 -- OK
|
||||
C GENSCN is also only valid for CAD4
|
||||
C-----------------------------------------------------------------------
|
||||
SUBROUTINE GENSCN (ICIRCL, WSPEED, WSTEP, NPTS, ISLIT, ICOL)
|
||||
return
|
||||
end
|
||||
C-----------------------------------------------------------------------
|
||||
C SETSLT -- Set the slits
|
||||
C cannot set slits at TRICS: NOT motorized
|
||||
C-----------------------------------------------------------------------
|
||||
subroutine setslt (islt,icol)
|
||||
return
|
||||
end
|
||||
C-----------------------------------------------------------------------
|
||||
C Set the microscope viewing position (CAD-4 version)
|
||||
C-----------------------------------------------------------------------
|
||||
SUBROUTINE VUPOS (VTH,VOM,VCH,VPH)
|
||||
CALL ANGSET(VTH,VOM,VCH,VPH)
|
||||
RETURN
|
||||
END
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
Reference in New Issue
Block a user