linse/sics
0
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
fdc6b051c9e38d3b472a1dc574c3035709d292b1
sics/difrac/ralf.f
cvs fdc6b051c9 Initial revision
2000-02-07 10:38:55 +00:00

1122 lines
40 KiB
Fortran
Raw Blame History

C-----------------------------------------------------------------------
C RALF Routines for the CAD4L with standard Enraf Nonius LSI/11
C interface.
C
C Peter S. White February 1994
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
COMMON /CADCON/ ALPHA,APMIN,APMAX,MAXVAR,MINVAR,
$ IHOLE,IVSLIT,IHSLIT,INEG45,IPOS45,IUPHAF,ILOHAF,
$ VUTHT,VUOME,VUCHI,VUPHI,IPORT,IBAUD
PARAMETER (STDGR =(128.0 * 4096.0)/360.0)
LOGICAL FIRST
INCLUDE 'COMDIF'
INCLUDE 'CAD4COMM'
DATA FIRST/.TRUE./
IF (FIRST) THEN
STEPDG = 91.0222
IFRDEF = 100
IDTDEF = 4
IDODEF = 2
NATTEN = 1
NRC = 1
DFTYPE = 'NONI'
CALL DIFGON
C-----------------------------------------------------------------------
C Set the CAD4 common block to starting values
C-----------------------------------------------------------------------
iroutf = 0
incr1 = 0
incr2 = 0
npi1 = 0
npi2 = 0
iscanw = 0
motw = 0
ishutf = 0
ibalf = 0
iattf = 0
iresf = 0
ierrf = 0
intfl = 0
xrayt = 0.0
do 100 i = 1,4
want(i) = 0.0
cmeas(i) = 0.0
100 continue
thpos = 78.0
thneg = -49.0
tthp = aint(-2.0 * THPOS * STDGR)
tthn = aint( 2.0 * (THPOS - THNEG) * STDGR)
aptw = 0.0
aptm = 0.0
call cad4_get_instrument
call cad4_ini_terminal
io_cobnr = 0
freq = 400
ENDIF
C CALL ZERODF
RETURN
END
C-----------------------------------------------------------------------
C INTOFF -- clean up the interface
C-----------------------------------------------------------------------
SUBROUTINE INTOFF
irc = io_done()
return
end
C-----------------------------------------------------------------------
C ZERODF In case of an error this routine returns the diffractometer
C to a known state
C-----------------------------------------------------------------------
SUBROUTINE ZERODF
INCLUDE 'CAD4COMM'
ishutf = 0
iattf = 0
do 100 i = 1,4
100 want(i) = 0.0
iroutf = 5
call lsi (1)
RETURN
END
C-----------------------------------------------------------------------
C CTIME Count for a fixed time
C-----------------------------------------------------------------------
SUBROUTINE CTIME (XTIME, XCOUNT)
INCLUDE 'COMDIF'
include 'cad4comm'
call setslt (icadsl,icol)
iroutf = 6
ibalf = 0
ishutf = 1
incr1 = 0
incr2 = 2
npi1 = int(xtime * freq)
npi2 = 0
motw = 0
iscanw = 1
call lsi (1)
xcount = 0
do 100 i = 1,ndumps
xcount = xcount + dump(i)
100 continue
RETURN
END
C-----------------------------------------------------------------------
C ANGET Read the angles
C-----------------------------------------------------------------------
SUBROUTINE ANGET (WTWOTH, WOMEGA, WCHI, WPHI)
include 'COMDIF'
include 'cad4comm'
iroutf = 1
call lsi (1)
call mtokap (cmeas(for_th),wtwoth)
call mtokap (cmeas(for_om),wkom)
call mtokap (cmeas(for_ka),wkappa)
call mtokap (cmeas(for_ph),wkphi)
call eulkap (1,womega,wchi,wphi,wkom,wkappa,wkphi,istatus)
womega = womega - wtwoth
wtwoth = 2 * wtwoth
wtwoth = wtwoth - dtheta
womega = womega - domega
wchi = wchi - dchi
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 ANGSET Set the angles
C-----------------------------------------------------------------------
SUBROUTINE ANGSET (WTHETA, WOMEGA, WCHI, WPHI, NATTW, ICOL)
include 'COMDIF'
include 'cad4comm'
ishutf = 0
if (nattw .gt. 0) then
iattf = 1
else
iattf = 0
endif
atheta = wtheta + dtheta
aomega = womega + domega
achi = wchi + dchi
if (atheta .gt. 180.00) atheta = atheta - 360.00
if (aomega .gt. 180.00) aomega = aomega - 360.00
atheta = atheta/2.0
aomega = aomega + atheta
call eulkap (0,aomega,achi,wphi,wkom,wkappa,wkphi,istatus)
if (istatus .ne. 0) then
icol = istatus
return
endif
call kaptom (atheta, want(for_th))
call kaptom (wkom, want(for_om))
call kaptom (wkappa, want(for_ka))
call kaptom (wkphi, want(for_ph))
iroutf = 5
call lsi (1)
icol = 0
call displa (wtheta,womega,wchi,wphi)
RETURN
END
C-----------------------------------------------------------------------
C Convert encoders to degrees
C-----------------------------------------------------------------------
SUBROUTINE MTOKAP (ENCODR, ANGLE)
PARAMETER (DGRST = 360.0/(128.0 * 4096.0))
ANGLE = DGRST * ENCODR
if (angle .gt. 180.0) angle = angle - 360.0
RETURN
END
C-----------------------------------------------------------------------
C Convert degrees to encoder steps--check the range
C-----------------------------------------------------------------------
SUBROUTINE KAPTOM (ANGLE,ENCODR)
PARAMETER (STDGR = (128.0 * 4096.0)/360.0)
TANGLE = ANGLE
IF (TANGLE .GT. 180.0) TANGLE = TANGLE - 360.0
ENCODR = AINT (TANGLE * STDGR)
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)
INCLUDE 'CAD4COMM'
INF = 0
IF (IOC .EQ. 1) THEN
ISHUTF = 1
ELSE
ISHUTF = 0
ENDIF
IROUTF = 0
CALL LSI (1)
IF (IERRF .NE. 0) INF = 1
RETURN
END
SUBROUTINE ONEBEP(R1,R2)
CHARACTER CTRLG*1
A1 = R1
A2 = R2
CTRLG = CHAR(7)
C WRITE (6,10000) CTRLG
10000 FORMAT (1H+,A,$)
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-----------------------------------------------------------------------
IF (SAVED .AND. I1 .NE. -9999) THEN
SAVED = .FALSE.
I1 = ISAVED
RETURN
ENDIF
SWCALL = .FALSE.
IF (I1 .EQ. -9999) SWCALL = .TRUE.
ANS = ' '
C-----------------------------------------------------------------------
C For now dummy out the call to keysin and return 0 characters
C-----------------------------------------------------------------------
NCHARS = 0
NCHARS = KEYSIN (STRING)
I1 = 1
DO 10 I = 1,NCHARS
IASCII = ICHAR (STRING(I:I))
IF (IASCII .EQ. 3) STOP
IF (IASCII .EQ. 75 .OR. IASCII .EQ. 107) ANS = 'K'
IF (IASCII .EQ. 81 .OR. IASCII .EQ. 113) ANS = 'Q'
IF (ANS .EQ. 'K' .OR. ANS .EQ. 'k') I1 = 0
IF (ANS .EQ. 'Q' .OR. ANS .EQ. 'q') I1 = 2
IF (IASCII .GE. 48 .AND. IASCII .LE. 57) THEN
SWFND = .TRUE.
ISWTCH = IASCII - 48 + 1
IF (ISREG(ISWTCH) .EQ. 0) THEN
ISREG(ISWTCH) = 1
ELSE
ISREG(ISWTCH) = 0
ENDIF
ENDIF
10 CONTINUE
IF (SWCALL .AND. I1 .NE. 1) THEN
ISAVED = I1
SAVED = .TRUE.
ENDIF
C IF (SWFND) THEN
C WRITE (WIN1BF(13),10000) (ISREG(I),I=1,10)
C ENDIF
10000 FORMAT (10X,10I2)
RETURN
END
C-----------------------------------------------------------------------
C RSW Read the switch register
C-----------------------------------------------------------------------
SUBROUTINE RSW (N,IVALUE)
INCLUDE 'COMDIF'
C-----------------------------------------------------------------------
C Update the switches just in case. II = -9999 is a flag to tell
C KORQ to protect any K or Q characters.
C-----------------------------------------------------------------------
II = -9999
CALL KORQ (II)
C-----------------------------------------------------------------------
C And get the current value.
C-----------------------------------------------------------------------
IF (N .LT. 0 .OR. N .GT. 9) RETURN
IVALUE = ISREG(N+1)
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,TIME,SPEED,NPPTS,IERR)
COMMON /DFMACH/ ISCDEF,ICDDEF,IDTDEF,IDODEF,IDCDEF,IFRDEF,NRC,
$ NATTEN,STEPDG,ICADSL,ICADSW
DIMENSION ACOUNT(*)
include 'cad4comm'
C--------------------------------------------------------------------
C Version 0.50 Supports itype = 0 or 2 omega-2theta and
C 1 or 3 omega
C in both cases IANGLE is omega at the end of the scan
C
C--------------------------------------------------------------------
IERR = 0
C--------------------------------------------------------------------
C The diffractometer should have been positioned at the beginning
C position for the scan.
C
C Omega/2-Theta scan
C Speed is passed in terms of 2-theta but E-N needs omega speed
C 1 encoder step = 360/(128 * 4096) = 0.00068664 deg
C 16 steps = 0.01098 deg (equals 8 omega steps)
C--------------------------------------------------------------------
CALL SETSLT (ICADSL,ICOL)
isense = 1
if (scnang .lt. 0.0) then
isense = -1
scnang = - scnang
endif
IF (ITYPE .EQ. 0 .OR. ITYPE .EQ. 1) THEN
MODE = 0
if (speed .le. 16.48) then
npi = nint(0.5 + 16.48*2/speed)
incr1 = isense
else
npi = 1
incr1 = isense*nint(0.5 + speed/(2*16.48))
endif
npi2 = 6
scang = scnang/2.0
iscanw = 8
C--------------------------------------------------------------------
C Omega scan
C--------------------------------------------------------------------
ELSE IF (ITYPE .EQ. 2 .OR. ITYPE .EQ. 3) THEN
MODE = 2
if (speed .le. 16.48) then
npi = nint(0.5 + 16.48/speed)
incr1 = isense
else
npi = 1
incr1 = isense*nint(0.5 + speed/(16.48))
endif
npi2 = 0
scang = scnang
iscanw = 16
ELSE
IERR = 2
RETURN
ENDIF
C--------------------------------------------------------------------
C Setup complete -- do the scan
C--------------------------------------------------------------------
call mtokap (float(iscanw), stpsiz)
nppts = int (scang/stpsiz)
call kaptom (float(ndumps * iscanw), scang)
incr2 = incr1
npi1 = npi
iresf = 0
C--------------------------------------------------------------------
C Set MOTW = 3 + 5*64 Omega master, theta slave
C--------------------------------------------------------------------
IBALF = 0
MOTW = 323
time = xrayt
iroutf = 6
call lsi (nppts)
acount(1) = 0.0
do 200 i = 1,nppts
acount(i+1) = dump(i)
acount(1) = acount(1) + dump(i)
200 continue
time = (xrayt - time) / freq
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)
INCLUDE 'COMDIF'
INTEGER IHTAGS(4)
REAL HIST(*)
INTEGER IX,IY,IZ
CHARACTER STRING*80
DATA IX,IY,IZ/0,0,0/
CALL PCDRAW (XCLEAR,IX,IY,IZ,STRING)
MAX = 1
MIN = 999999
IF (NHIST .LE. 1) THEN
WRITE (LPT,10000) NHIST
10000 FORMAT (1X,' Invalid value for NHIST: ',I10)
RETURN
ENDIF
DO 10 I = 1,NHIST
IF (HIST(I) .GT. MAX) MAX = HIST(I)
IF (HIST(I) .LT. MIN) MIN = HIST(I)
10 CONTINUE
XSCALE = 4096.0/NHIST
DO 20 I = 1,NHIST
IY = HIST(I)
IY = IY*3072.0/MAX
IX = I * XSCALE
IF (IY .LT. 0 .OR. IY .GT. 3072 .OR.
$ IX .LT. 1 .OR. IX .GT. 4096) THEN
WRITE (LPT,10100) IX,IY
10100 FORMAT (1X,'Error plotting point ',I10,',',I10)
RETURN
ENDIF
CALL PCDRAW (XMOVE, IX,IY,IZ,STRING)
CALL PCDRAW (XDRAW, IX,IY,IZ,STRING)
20 CONTINUE
C-------------------------------------------------------------------
C Now put in the indicators.
C-------------------------------------------------------------------
DO 30 I = 1,4
IHTAGS(I) = IHTAGS(I) * XSCALE
30 CONTINUE
IF (IHTAGS(1) .GT. 0) THEN
CALL PCDRAW (XMOVE, IHTAGS(1),100,IZ,STRING)
CALL PCDRAW (XDRAW, IHTAGS(1),300,IZ,STRING)
ENDIF
IF (IHTAGS(2) .GT. 0) THEN
CALL PCDRAW (XMOVE, IHTAGS(2),400,IZ,STRING)
CALL PCDRAW (XDRAW, IHTAGS(2),600,IZ,STRING)
ENDIF
IF (IHTAGS(3) .GT. 0) THEN
CALL PCDRAW (XMOVE, IHTAGS(3),100,IZ,STRING)
CALL PCDRAW (XDRAW, IHTAGS(3),300,IZ,STRING)
ENDIF
IF (IHTAGS(4) .GT. 0) THEN
CALL PCDRAW (XMOVE, IHTAGS(4),100,IZ,STRING)
CALL PCDRAW (XDRAW, IHTAGS(4),300,IZ,STRING)
ENDIF
RETURN
END
C-------------------------------------------------------------------
C RPSCAN Ralf support for PSCAN routine
C-------------------------------------------------------------------
SUBROUTINE RPSCAN (NPTS,ICOL)
INCLUDE 'COMDIF'
INCLUDE 'CAD4COMM'
ICOL = 0
NATTN = 0
CALL SETSLT (0,ICOL)
C-------------------------------------------------------------------
C Get the current angles and decide which direction to scan
C-------------------------------------------------------------------
CALL ANGET (WTH,WOM,WCHI,WPHI)
IF (WPHI .GT. 180.0) WPHI = WPHI - 360.00
IF (WPHI .LE. 0) THEN
WPHI = -90.00
TARGET = 90.00
IDIR = 1
ELSE
WPHI = 90.00
TARGET = -90.00
IDIR = -1
ENDIF
C-------------------------------------------------------------------
C Move PHI to the correct starting position
C-------------------------------------------------------------------
CALL ANGSET (WTH,WOM,WCHI,WPHI,NATTN,ICOL)
C-------------------------------------------------------------------
C Now do the scan
C-------------------------------------------------------------------
INCR1 = 10 * IDIR
INCR2 = 0
IRESF = 0
NPI1 = 1
MOTW = 2
STEPW = 2.0
CALL KAPTOM (STEPW,ENCST)
ISCANW = INT(ENCST + 0.5)/IABS(INCR1)
NPTS = 90
IROUTF = 6
CALL LSI (NPTS)
PHIST = WPHI - STEPW/2.0
IF (IDIR .LT. 1) PHIST = -WPHI - STEPW/2.0
C-----------------------------------------------------------------------
C Nonius (in their wisdom) always return the profile in ascending
C phi.
C-----------------------------------------------------------------------
DO 100 I = 1,NPTS
ACOUNT(I) = DUMP(I)
ACOUNT(5*NSIZE + I) = PHIST + I*STEPW
100 CONTINUE
RETURN
END
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-----------------------------------------------------------------------
SUBROUTINE GENSCN (ICIRCL, WSPEED, WSTEP, NPTS, ISLIT, ICOL)
include 'COMDIF'
include 'cad4comm'
icol = 0
call setslt (islit,icol)
C-----------------------------------------------------------------------
C Get current positions
C-----------------------------------------------------------------------
ishutf = 0
iroutf = 1
call lsi (1)
call mtokap (cmeas(for_th),wtwoth)
call mtokap (cmeas(for_om),wkom)
call mtokap (cmeas(for_ka),wkappa)
call mtokap (cmeas(for_ph),wkphi)
C-----------------------------------------------------------------------
C Offset required angle
C-----------------------------------------------------------------------
imult = 1
tstep = wstep
if (icircl .eq. 1) then
tstep = wstep/2.0
wtwoth = wtwoth - tstep*npts/2 - tstep/2
else if (icircl .eq. 2) then
wkom = wkom - tstep*npts/2 - tstep/2
else if (icircl .eq. 3) then
wkappa = wkappa - tstep*npts/2 - tstep/2
else if (icircl .eq. 4) then
wkphi = wkphi - tstep*npts/2 - tstep/2
else if (icircl .eq. 5) then
tstep = wstep/2.0
wtwoth = wtwoth - tstep*npts/2 - tstep/2
wkom = wkom - tstep*npts/2 - tstep/2
imult = 2
endif
call kaptom (wtwoth, want(for_th))
call kaptom (wkom, want(for_om))
call kaptom (wkappa, want(for_ka))
call kaptom (wkphi, want(for_ph))
ishutf = 0
iroutf = 5
call lsi (1)
C-----------------------------------------------------------------------
C Now we are at the begining of the scan
C-----------------------------------------------------------------------
isense = 1
if (tstep .lt. 0.0) isense = -1
nattn = 0
incr2 = 0
iresf = 0
npi2 = 0
if (wspeed .le. 16.48) then
incr1 = isense
npi1 = int((imult*16.48)/wspeed + 0.5)
else
npi1 = 1
incr1 = isense*int(wspeed/(imult*16.48) + 0.5)
endif
stepw = abs(tstep)
if (icircl .eq. 1) then
motw = 5
else if (icircl .eq. 2) then
motw = 3
else if (icircl .eq. 3) then
motw = 4
else if (icircl .eq. 4) then
motw = 2
else if (icircl .eq. 5) then
motw = 323
incr2 = incr1
npi2 = 6
else
icol = -1
return
endif
call kaptom (stepw,encst)
iscanw = int(encst + 0.5)/iabs(incr1)
npoints = npts
ishutf = 1
iroutf = 6
call lsi (npoints)
i1 = 9*NSIZE + 1
i2 = 9*NSIZE + npoints
j = 0
do 100 i = i1,i2
j = j + 1
acount(i) = dump(j)
100 continue
return
end
C-----------------------------------------------------------------------
C SETSLT -- Set the slits
C-----------------------------------------------------------------------
subroutine setslt (islt,icol)
COMMON /CADCON/ ALPHA,APMIN,APMAX,MAXVAR,MINVAR,
$ IHOLE,IVSLIT,IHSLIT,INEG45,IPOS45,IUPHAF,ILOHAF,
$ VUTHT,VUOME,VUCHI,VUPHI,IPORT,IBAUD
include 'cad4comm'
icol = 0
ishutf = 0
if (islit .lt. 0) then
icol = -1
return
endif
aptwsv = aptw
if (islt .eq. 0) aptw = IHOLE
if (islt .eq. 1) aptw = IVSLIT
if (islt .eq. 2) aptw = IHSLIT
if (islt .eq. 3) aptw = INEG45
if (islt .eq. 4) aptw = IPOS45
if (islt .eq. 5) aptw = IUPHAF
if (islt .eq. 6) aptw = ILOHAF
if (islt .ge. 10) then
slsize = float(islt)/10.0
if (slsize .lt. APMIN) slsize = APMIN
if (slsize .gt. APMAX) slsize = APMAX
aptw = (MAXVAR - MINVAR) * (slsize - APMIN)/(APMAX - APMIN)
aptw = aptw + MINVAR
endif
if (abs(aptm - aptw) .lt.1.5) return
if (aptw .ne. aptwsv) then
iroutf = 13
call lsi (0)
endif
return
end
C-----------------------------------------------------------------------
C LSI Cad specific routine to initiate transfer to the interface
C If doing multple transfers use xrayt from the first one to
C improve accuracy of the scan time estimate.
C-----------------------------------------------------------------------
subroutine lsi (length)
include 'cad4comm'
nreturn = length
if (nreturn .lt. 1) nreturn = 1
call disap (4,nreturn)
if (nreturn .gt. 96) then
xrayts = xrayt
lcount = 0
ltemp = nreturn
100 ltemp = ltemp - 96
lcount = lcount + 1
iroutf = 4096 + lcount*4*96
call disap (4,ltemp)
if (ltemp .gt. 96) go to 100
xrayt = xrayts
endif
return
end
C-----------------------------------------------------------------------
C For now we only need support the old DISAP type 4
C-----------------------------------------------------------------------
subroutine disap (mode, length)
external cad4_transm_gonio, cad4_recv_gonio, cad4_type_error,
$ cad4_start_load
include 'CAD4COMM'
if (mode .eq. 4) then
ndumps = length
call cad4_io (f_tr_gon, cad4_transm_gonio, cad4_recv_gonio,
$ cad4_type_error, cad4_type_error, cad4_type_error,
$ cad4_type_error, cad4_type_error, cad4_start_load,
$ cad4_type_error)
endif
return
end
C-----------------------------------------------------------------------
C Cad4_start_load: The interface needs to be reloaded so quit!
C-----------------------------------------------------------------------
subroutine cad4_start_load (result)
include 'CAD4COMM'
call cad4_reset_terminal
stop
end
C-----------------------------------------------------------------------
C Cad4_set_swreg: Copy switch register to buffer
C-----------------------------------------------------------------------
subroutine cad4_set_swreg
include 'CAD4COMM'
output_data_w(1) = io_coswr
output_length = 2
return
end
C-----------------------------------------------------------------------
C Cad4_get_swreg: Copy pocket terminal switch register to host
C-----------------------------------------------------------------------
subroutine cad4_get_swreg
include 'CAD4COMM'
nswreg = input_data_w(1)
return
end
C-----------------------------------------------------------------------
C Cad4_recv_gonio: Copy results returned from the LSI
C-----------------------------------------------------------------------
subroutine cad4_recv_gonio (result)
integer*2 i, nrd
include 'CAD4COMM'
C-----------------------------------------------------------------------
C Get the interface switch register
C-----------------------------------------------------------------------
nswreg = input_data_w(c4h_swreg)
C-----------------------------------------------------------------------
C Convert input error bits to an error number
C-----------------------------------------------------------------------
call bitcon (c4h_errfl, errtbl, ierrf)
C-----------------------------------------------------------------------
C Convert accumulated exposure time to a real
C-----------------------------------------------------------------------
call input_double (c4h_xrtim, xrayt)
C-----------------------------------------------------------------------
C Convert encoder readings
C-----------------------------------------------------------------------
call input_double (c4h_thmh, cmeas(for_th))
call input_double (c4h_phmh, cmeas(for_ph))
call input_double (c4h_ommh, cmeas(for_om))
call input_double (c4h_kamh, cmeas(for_ka))
call input_double (c4h_apmh, aptm)
C-----------------------------------------------------------------------
C And finally any profile points
C-----------------------------------------------------------------------
nd = 1
nend = ndumps
if (iroutf .gt. 4096) then
nd = (iroutf - 4096)/4 + 1
endif
if (nend .gt. 96) nend = 96
do 100 i = 1,nend
nrd = (i - 1)*2 + c4h_dump0
call input_double (nrd, dump(nd))
nd = nd + 1
100 continue
return
end
C-----------------------------------------------------------------------
C Input_double: convert LSI double integers to floating point
C-----------------------------------------------------------------------
subroutine input_double (c4h_label, f_value)
integer*2 c4h_label
real f_value
C-----------------------------------------------------------------------
C Equivalence integer with pairs of short integers
C-----------------------------------------------------------------------
integer*4 long
integer*2 short(2)
equivalence (long, short(1))
include 'CAD4COMM'
short(2) = input_data_w(c4h_label)
short(1) = input_data_w(c4h_label + 1)
f_value = float (long)
return
end
C-----------------------------------------------------------------------
C Bitcon: Convert most significant bit set to a number
C-----------------------------------------------------------------------
subroutine bitcon (c4h_label, tabel, iresult)
integer*2 c4h_label, tabel(15), iresult
integer*2 itcnt, itval, inval
include 'CAD4COMM'
iresult = 0
inval = input_data_w(c4h_label)
if (inval .gt. 0) then
itcnt = 15
itval = #4000
100 continue
if (tabel(itcnt) .ne. 0) then
if (iand(inval, itval) .ne. 0) iresult = tabel(itcnt)
endif
itval = itval/2
itcnt = itcnt - 1
if (itval .ne. 0 .and. iresult .ne. 0) go to 100
endif
return
end
C-----------------------------------------------------------------------
C Cad4_transm_gonio: Setup buffer for transmission to LSI
C-----------------------------------------------------------------------
subroutine cad4_transm_gonio
integer*2 nsa, nba, nmast, nslav, mselw
include 'CAD4COMM'
C-----------------------------------------------------------------------
C Outtput switch register
C-----------------------------------------------------------------------
output_data_w(c4h_swreg) = io_coswr
C-----------------------------------------------------------------------
C Route flag
C-----------------------------------------------------------------------
if (iroutf .lt. 4096) then
output_data_w(c4h_routfl) = routbl (iand(iroutf, #0f) + 1)
else
output_data_w(c4h_routfl) = iroutf
endif
C-----------------------------------------------------------------------
C Two theta limit values
C-----------------------------------------------------------------------
call output_double ((tthp*16.0), c4h_tthmxh)
call output_double ((tthn*16.0), c4h_tthmnh)
C-----------------------------------------------------------------------
C Shutter and attenuator go in one word
C-----------------------------------------------------------------------
nsa = ishutf * 2
nsa = ior(nsa, iattf)
nsa = iand (nsa, #03)
nsa = satbl (nsa + 1)
C-----------------------------------------------------------------------
C Set function comes from IBALF
C-----------------------------------------------------------------------
nba = iand (ibalf, #03)
if (nba .eq. 3) then
nba = (ibalf - nba)/4
nba = iand (nba, (not (satbl(3))))
nsa = nsa + nba
endif
output_data_w(c4h_sasysc) = nsa
C-----------------------------------------------------------------------
C Output cumulative exposure time
C-----------------------------------------------------------------------
call output_double (xrayt, c4h_xrtim)
C-----------------------------------------------------------------------
C Motor selection word
C-----------------------------------------------------------------------
nmast = iand (motw, #07) + 1
nslav = iand (motw, #01C0)/#0040 + 1
output_data_w(c4h_mselw) = mottbl(nmast) + mottbl(nslav)*#0008
C-----------------------------------------------------------------------
C Number of dumps required
C-----------------------------------------------------------------------
if (incr1 .lt. 0) then
output_data_w(c4h_nrd) = -ndumps
else
output_data_w(c4h_nrd) = ndumps
endif
C-----------------------------------------------------------------------
C Calculate master and slave increment words
C-----------------------------------------------------------------------
mselw = nmast - 1
call setinc (mselw)
mselw = 1 - nslav
call setinc (mselw)
C-----------------------------------------------------------------------
C Wanted goniometer and aperature settings
C-----------------------------------------------------------------------
call output_double (want(for_th), c4h_thwh)
call output_double (want(for_ph), c4h_phwh)
call output_double (want(for_om), c4h_omwh)
call output_double (want(for_ka), c4h_kawh)
call output_double (aptw, c4h_apwh)
C-----------------------------------------------------------------------
C Set output buffer length
C-----------------------------------------------------------------------
output_length = c4h_apwl * 2
return
end
C-----------------------------------------------------------------------
C Output_double: convert real to double integer
C-----------------------------------------------------------------------
subroutine output_double (f_value, c4h_label)
real f_value
integer*2 c4h_label
integer*4 long
integer*2 short(2)
equivalence (long, short(1))
include 'CAD4COMM'
long = int(f_value)
output_data_w(c4h_label) = short(2)
output_data_w(c4h_label + 1) = short(1)
return
end
C-----------------------------------------------------------------------
C Setinc: routine to output increment values for master axis if the
C selection word is positive ot the slave axis if negative
C-----------------------------------------------------------------------
subroutine setinc (aselw)
integer*2 aselw, iabaw, aoffs, nid, inci, dincr, nrinc
include 'CAD4COMM'
C-----------------------------------------------------------------------
C calculate increment values
C-----------------------------------------------------------------------
call increm (aselw, nid, inci, dincr, nrinc)
C-----------------------------------------------------------------------
C and copy them to the output buffer
C-----------------------------------------------------------------------
output_data_w (c4h_nid) = nid
iabaw = iabs (aselw) + 1
aoffs = mottbl(iabaw)*3 + c4h_incr
if (mottbl(iabaw) .ne. 0) then
output_data_w (c4h_inci + aoffs) = inci
output_data_w (c4h_dincr + aoffs) = dincr
output_data_w (c4h_nrinc + aoffs) = nrinc
endif
return
end
C-----------------------------------------------------------------------
C Increm: calculate increment values
C-----------------------------------------------------------------------
subroutine increm (aselw, nid, inci, dincr, nrinc)
integer*2 aselw, nid, inci, dincr, nrinc
real fincr
include 'CAD4COMM'
ifact = 4
if (iroutf .ge. 9 .and. iroutf .le. 11) ifact = 2
nid = iscanw * npi1
if (aselw .ne. 0) then
if (npi1 .ne. 0) then
if (aselw .le. 0) then
fincr = float(incr1 * npi2 * ifact)/float(npi1 * 6)
else
fincr = float(incr1 * ifact)/float(npi1)
endif
else
fincr = 0.0
endif
if (abs(fincr) .gt. (1.0/32768.0)) then
nrinc = int(1.0/abs(fincr))
if (nrinc .lt. 1) nrinc = 1
else
nrinc = 32767
endif
inci = int(fincr * float(nrinc))
if ((fincr * float(nrinc) - float(inci)) .lt. 0.0)
$ inci = inci - 1
dincr = int((fincr * float(nrinc) - float(inci)) * 32768.0)
endif
return
end
C-----------------------------------------------------------------------
C Set the microscope viewing position (CAD-4 version)
C-----------------------------------------------------------------------
SUBROUTINE VUPOS (VTH,VOM,VCH,VPH)
COMMON /CADCON/ ALPHA,APMIN,APMAX,MAXVAR,MINVAR,
$ IHOLE,IVSLIT,IHSLIT,INEG45,IPOS45,IUPHAF,ILOHAF,
$ VUTHT,VUOME,VUCHI,VUPHI,IPORT,IBAUD
VTH = VUTHT
VOM = VUOME
VCH = VUCHI
VPH = VUPHI
RETURN
END
C-----------------------------------------------------------------------
C Read the CAD-4 Goniometer constants file (goniom.ini) for the
C constants needed by DIFRAC in /CADCON/
C-----------------------------------------------------------------------
SUBROUTINE DIFGON
COMMON /CADCON/ ALPHA,APMIN,APMAX,MAXVAR,MINVAR,
$ IHOLE,IVSLIT,IHSLIT,INEG45,IPOS45,IUPHAF,ILOHAF,
$ VUTHT,VUOME,VUCHI,VUPHI,IPORT,IBAUD
CHARACTER DFTYPE*4,DFMODL*4
COMMON /DFMACC/ DFTYPE,DFMODL
COMMON /INFREE/ IFREE(20),RFREE(20),ICFLAG
CHARACTER COUT(20)*132,OCHAR*100,CKEY*6
COMMON /IOUASC/ COUT
COMMON /FREECH/ OCHAR
C-----------------------------------------------------------------------
C Set the values to sensible defaults. Values from IHSLIT to IUPHAP
C are decimal numbers with the same digits as the octal numbers which
C are the true values.
C-----------------------------------------------------------------------
DFMODL = 'CAD4'
ALPHA = 49.99
APMIN = 1.3
APMAX = 5.9
IHSLIT = 77
MINVAR = 277
MAXVAR = 2443
IHOLE = 2570
INEG45 = 3001
IPOS45 = 3135
IVSLIT = 3315
ILOHAF = 3477
IUPHAF = 3731
C-----------------------------------------------------------------------
C Attach goniom.ini to unit 9
C-----------------------------------------------------------------------
OPEN (UNIT=9, ACCESS='SEQUENTIAL', FILE='goniom.ini',
$ STATUS='OLD', ERR=110)
C-----------------------------------------------------------------------
C Read values from goniom.ini. Ignore lines starting with /
C-----------------------------------------------------------------------
100 READ (9,11000,END=200) OCHAR
11000 FORMAT (A)
IF (OCHAR(1:1) .EQ. '/') GO TO 100
CKEY = OCHAR(1:6)
IDONE = 0
IF (CKEY .EQ. 'Dfmodl') THEN
IF (OCHAR(9:9) .NE. ' ') I = 9
IF (OCHAR(8:8) .NE. ' ') I = 8
IF (OCHAR(7:7) .NE. ' ') I = 7
DFMODL = OCHAR(I:I+3)
GO TO 100
ENDIF
OCHAR(1:6) = ' '
CALL FREEFM (1000)
IVAL = IFREE(1)
C-----------------------------------------------------------------------
C Get COMMON /CADCON/ values for DIFRAC
C-----------------------------------------------------------------------
IF (CKEY .EQ. 'Port ') THEN
IPORT = IVAL
IDONE = 1
ELSE IF (CKEY .EQ. 'Baud ') THEN
IBAUD = IVAL
IDONE = 1
ELSE IF (CKEY .EQ. 'Alpha ') THEN
ALPHA = RFREE(1)
IDONE = 1
ELSE IF (CKEY .EQ. 'Apmax ') THEN
APMAX = RFREE(1)
IDONE = 1
ELSE IF (CKEY .EQ. 'Apmin ') THEN
APMIN = RFREE(1)
IDONE = 1
ELSE IF (CKEY .EQ. 'Vutht ') THEN
VUTHT = RFREE(1)
IDONE = 1
ELSE IF (CKEY .EQ. 'Vuome ') THEN
VUOME = RFREE(1)
IDONE = 1
ELSE IF (CKEY .EQ. 'Vuchi ') THEN
VUCHI = RFREE(1)
IDONE = 1
ELSE IF (CKEY .EQ. 'Vuphi ') THEN
VUPHI = RFREE(1)
IDONE = 1
ENDIF
IF (IDONE .EQ. 0) THEN
IVAL = IFREE(1)
CALL OCTDEC (IVAL)
IF (CKEY .EQ. 'Maxvar') THEN
MAXVAR = IVAL
ELSE IF (CKEY .EQ. 'Minvar') THEN
MINVAR = IVAL
ELSE IF (CKEY .EQ. 'Upperh') THEN
IUPHAF = IVAL
ELSE IF (CKEY .EQ. 'Lowerh') THEN
ILOHAF = IVAL
ELSE IF (CKEY .EQ. 'Negsl ') THEN
INEG45 = IVAL
ELSE IF (CKEY .EQ. 'Possl ') THEN
IPOS45 = IVAL
ELSE IF (CKEY .EQ. 'Vslit ') THEN
IVSLIT = IVAL
ELSE IF (CKEY .EQ. 'Hslit ') THEN
IHSLIT = IVAL
ELSE IF (CKEY .EQ. 'Hole ') THEN
IHOLE = IVAL
ENDIF
ENDIF
GO TO 100
C-----------------------------------------------------------------------
C There was an error opening goniom.ini. Do something about it.
C-----------------------------------------------------------------------
110 WRITE (COUT,10000)
CALL GWRITE (ITP,' ')
10000 FORMAT (' Error opening CAD-4 goniometer constants file',
$ ' goniom.ini.'/
$ ' Exit from DIFRAC, check the file and try again.')
RETURN
200 CLOSE (UNIT = 9)
RETURN
END
C-----------------------------------------------------------------------
C Convert a decimal number to the decimal equivalent of the octal
C number with the same digits.
C e.g. 123(10) --> 123(8) --> 83(10)
C-----------------------------------------------------------------------
SUBROUTINE OCTDEC (IVAL)
IWORK = IVAL
IMULT = 1
IVAL = 0
100 ITEMP = IWORK/10
IDIGIT = IWORK - 10*ITEMP
IVAL= IVAL + IDIGIT*IMULT
IMULT = IMULT*8
IWORK = ITEMP
IF (IWORK .NE. 0) GO TO 100
RETURN
END
Reference in New Issue View Git Blame Copy Permalink