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