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
