354 lines
13 KiB
Fortran
354 lines
13 KiB
Fortran
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
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|