C-----------------------------------------------------------------------
C           This is the Command interpreting subroutine
C 
C    Each 2-letter command in KI is associated with a unique call or 
C  set of calls.  Having made the call the particular 2-letter sequence
C  will not make any further calls and will be cleared at the end of 
C  the call.
C    When routines change the value of KI, which some do, the new value 
C  is always unique and will always cause action further down in SETOP.
C
C-----------------------------------------------------------------------
      SUBROUTINE SETOP
      INCLUDE 'COMDIF'
      CHARACTER STRING*80
  100 WRITE (COUT,10000)
      CALL ALFNUM (STRING)
      KI = STRING(1:2)
      IF (KI .EQ. 'Q') THEN
         CALL WNEND
         STOP
      ENDIF 
C-----------------------------------------------------------------------
C  The program runs in two modes, full screen and windowed.
C  The following routines require the use of the windowed mode
C-----------------------------------------------------------------------
      IF (KI .EQ. 'GO' .OR. KI .EQ. 'IP' .OR.
     $    KI .EQ. 'IR' .OR. KI .EQ. 'IE' .OR. KI .EQ. 'IM') THEN
         IF (IWNCUR .EQ. 3) CALL WNSET (2)
      ENDIF
C-----------------------------------------------------------------------
C  These routines require full screen mode, any others should work
C  in either mode so we are not flipping screens all the time
C-----------------------------------------------------------------------
      IF (KI .EQ. 'AL' .OR. KI .EQ. 'A8' .OR. KI .EQ. 'RO' .OR.
     $    KI .EQ. 'OC' .OR. KI .EQ. 'SD' .OR. KI .EQ. 'AR' .OR.
     $    KI .EQ. 'PK' .OR. KI .EQ. 'RC' .OR. KI .EQ. 'PD' .OR.
     $    KI .EQ. 'RP' .OR. KI .EQ. 'BD' .OR. KI .EQ. 'CH' .OR.
     $    KI .EQ. 'GS' .OR. KI .EQ. 'CR' .OR. KI .EQ. 'LC' .OR.
     $    KI .EQ. 'LP' .OR. KI .EQ. 'M2' .OR. KI .EQ. 'M3' .OR.
     $    KI .EQ. 'MM' .OR. KI .EQ. 'RS' .OR. KI .EQ. 'BC' .OR.
     $    KI .EQ. 'NR' .OR. KI .EQ. 'TO' .OR.
     $    KI .EQ. 'MR' .OR. KI .EQ. 'MS' .OR. KI .EQ. 'FI') THEN
         IF (IWNCUR .NE. 3) CALL WNSET (3)
      ENDIF
C-----------------------------------------------------------------------
C  This routine reads commands from the terminal and sets a flag to 
C  indicate whether the command may inhibit an automatic restart of
C  data collection, if appropriate.
C  All control of the program flow is via the variable KI.
C-----------------------------------------------------------------------
      IF (KI .NE. ' ') THEN
        IMENU = 0
      ELSE
        IF (IMENU .EQ. 0) THEN
          WRITE (COUT,11000)
          CALL YESNO ('N',ANS)
        ELSE
          IMENU = 0
          ANS = 'Y'
        ENDIF
        IF (ANS .EQ. 'Y') THEN
          IWNOLD = IWNCUR
          IF (IWNCUR .NE. 3) CALL WNSET (3)
          WRITE (COUT,12000)
          CALL GWRITE (ITP,' ')
          IF (DFMODL .EQ. 'CAD4') THEN
            WRITE (COUT,12100)
            CALL GWRITE (ITP,' ')
          ENDIF
          WRITE (COUT,12200)
          CALL FREEFM (ITR)
          I = IFREE(1)
          CALL GWRITE (ITP,' ')
          IF (I .EQ. 0 .OR. I .EQ. 1) THEN
            WRITE (COUT,13000)
            CALL GWRITE (ITP,' ')
            IF (I .EQ. 0) THEN
              WRITE (COUT,14000)
              CALL ALFNUM (STRING)
              ANS = STRING(1:1)
            ENDIF
          ENDIF
          IF (I .EQ. 0 .OR. I .EQ. 2) THEN
            WRITE (COUT,15000)
            CALL GWRITE (ITP,' ')
            IF (I .EQ. 0) THEN
              WRITE (COUT,14000)
              CALL ALFNUM (STRING)
              ANS = STRING(1:1)
            ENDIF
          ENDIF
          IF (I .EQ. 0 .OR. I .EQ. 3) THEN
            WRITE (COUT,16000)
            CALL GWRITE (ITP,' ')
            IF (I .EQ. 0) THEN
              WRITE (COUT,14000)
              CALL ALFNUM (STRING)
              ANS = STRING(1:1)
            ENDIF
          ENDIF
          IF (I .EQ. 0 .OR. I .EQ. 4) THEN
            WRITE (COUT,17000)
            CALL GWRITE (ITP,' ')
            IF (I .EQ. 0) THEN
              WRITE (COUT,14000)
              CALL ALFNUM (STRING)
              ANS = STRING(1:1)
            ENDIF
          ENDIF
          IF (I .EQ. 0 .OR. I .EQ. 5) THEN
            WRITE (COUT,18000)
            CALL GWRITE (ITP,' ')
            IF (I .EQ. 0) THEN
              WRITE (COUT,14000)
              CALL ALFNUM (STRING)
              ANS = STRING(1:1)
            ENDIF
          ENDIF
          IF (I .EQ. 0 .OR. I .EQ. 6) THEN
            WRITE (COUT,19000)
            CALL GWRITE (ITP,' ')
            WRITE (COUT,20000)
            CALL GWRITE (ITP,' ')
            IF (I .EQ. 0) THEN
              WRITE (COUT,14000)
              CALL ALFNUM (STRING)
              ANS = STRING(1:1)
            ENDIF
          ENDIF
          IF (DFMODL .EQ. 'CAD4' .AND. (I .EQ. 0 .OR. I .EQ. 7)) THEN
            WRITE (COUT,20100)
            CALL GWRITE (ITP,' ')
            IF (I .EQ. 0) THEN
              WRITE (COUT,14000)
              CALL ALFNUM (STRING)
              ANS = STRING(1:1)
            ENDIF
          ENDIF
        ENDIF
        GO TO 100
      ENDIF
      IF (KI .EQ. 'RI') KI = 'RB'
      JAUTO = 0
      IF (KI .EQ. 'AD') CALL BASINP
      IF (KI .EQ. 'AL' .OR. KI .EQ. 'AR') CALL ALIGN
      IF (KI .EQ. 'AP') CALL PROFAS
      IF (KI .EQ. 'A8') CALL CENT8
      IF (KI .EQ. 'BI') CALL PRNINT
      IF (KI .EQ. 'CR') CALL ALIGN
      IF (KI .EQ. 'CZ') CALL BASINP
      IF (KI .EQ. 'DE') CALL DEMO1E
      IF (KI .EQ. 'EX') THEN
        WRITE (COUT,21000)
        CALL YESNO ('Y',ANS)
        IF (ANS .EQ. 'Y') THEN
          CALL WRBAS
          CALL WNEND 
          STOP
        ENDIF
      ENDIF
      IF (KI .EQ. 'GO') THEN
        ISEG = 0
        IAUTO = 0
        CALL BEGIN
      ENDIF
      IF (KI .EQ. 'GS') CALL GRID
      IF (KI .EQ. 'AI') CALL IDTOAS
      IF (KI .EQ. 'IE') CALL INDMES
      IF (KI .EQ. 'IM') CALL INDMES
      IF (KI .EQ. 'IN') CALL ANGINI
      IF (KI .EQ. 'IR') CALL INDMES
      IF (KI .EQ. 'IP') CALL INDMES
      IF (KI .EQ. 'AH') KI = 'IX'
      IF (KI .EQ. 'IX') CALL RCPCOR
      IF (KI .EQ. 'LP') CALL LINPRF
      IF (KI .EQ. 'MM') THEN
        CALL LSORMT
        IF (KI .NE. ' ') CALL BASINP
      ENDIF
      IF (KI .EQ. 'M2') THEN
        CALL ORCEL2
        IF (KI .NE. ' ') CALL BASINP
      ENDIF
      IF (KI .EQ. 'M3') THEN
        CALL ORMAT3
        IF (KI .NE. ' ') CALL BASINP
      ENDIF
      IF (KI .EQ. 'TO') THEN
        CALL TRANSF
        IF (KI .NE. ' ') CALL BASINP
      ENDIF
      IF (KI .EQ. 'LC') CALL CELLLS
      IF (KI .EQ. 'OM') CALL BASINP
      IF (KI .EQ. 'PO') KI = 'OS'
      IF (KI .EQ. 'OS') CALL OSCIL
      IF (KI .EQ. 'PA') CALL PRTANG
      IF (KI .EQ. 'PD') CALL PRNBAS
      IF (KI .EQ. 'PL') CALL SETROW
      IF (KI .EQ. 'PR') CALL SETROW
      IF (KI .EQ. 'HA') KI = 'RA'
      IF (KI .EQ. 'P9') CALL PHI90 
      IF (KI .EQ. 'RA') CALL ORMAT3
      IF (KI .EQ. 'RB') CALL WRBAS
      IF (KI .EQ. 'RP') CALL PSCAN (JUNK,JUNK)
      IF (KI .EQ. 'SA') CALL INDMES
      IF (KI .EQ. 'SC') CALL INDMES
      IF (KI .EQ. 'SH') THEN
        CALL SHUTTR (0)
        KI = ' '
      ENDIF
      IF (KI .EQ. 'SW') CALL SWITCH
      IF (KI .EQ. 'SO') CALL INDMES
      IF (KI .EQ. 'SP') CALL INDMES
      IF (KI .EQ. 'SR') CALL INDMES
      IF (DFMODL .EQ. 'CAD4') THEN
        IF (KI .EQ. 'EK' .OR. KI .EQ. 'KE') CALL EKKE
        IF (KI .EQ. 'MS') CALL INDMES
        IF (KI .EQ. 'MR') CALL RCPCOR
        IF (KI .EQ. 'FI') CALL FACEIN
      ENDIF
      IF (KI .EQ. 'ST') CALL INDMES
      IF (KI .EQ. 'TC') CALL PCOUNT
      IF (KI .EQ. 'UM') CALL CNTREF
      IF (KI .EQ. 'VM') CALL VUMICR
      IF (KI .EQ. 'WB') CALL WRBAS
      IF (KI .EQ. 'HO' .OR. KI .EQ. 'ZE') THEN
        CALL ZERODF
        KI = ' '
      ENDIF
      IF (KI .EQ. 'NR') CALL SETNRC
C-----------------------------------------------------------------------
C  If the command has not yet been executed, no auto restart is
C  possible
C-----------------------------------------------------------------------
      IF (KI .NE. ' ') JAUTO = 1
      IF (KI .EQ. 'BD') CALL BASINP
      IF (KI .EQ. 'CH') CALL REINDX
      IF (KI .EQ. 'DH') THEN
        IKO(5) = 0
        CALL BASINP
      ENDIF
      IF (KI .EQ. 'FR') CALL BASINP
      IF (KI .EQ. 'LA') CALL BASINP
      IF (KI .EQ. 'LT') CALL LOTEM
      IF (KI .EQ. 'OC') CALL BLIND
      IF (KI .EQ. 'PK') CALL PEAKSR
      IF (KI .EQ. 'PS') CALL BASINP
      IF (KI .EQ. 'RC') CALL CREDUC (KI)
      IF (KI .EQ. 'RO') CALL BASINP
      IF (KI .EQ. 'BC') CALL BIGCHI
      IF (KI .EQ. 'RR') CALL BASINP
      IF (KI .EQ. 'RS') CALL REINDX
      IF (KI .EQ. 'SD') CALL BASINP
      IF (KI .EQ. 'SE') CALL BASINP
      IF (KI .EQ. 'SG') THEN
        IOUT = ITP 
        CALL SPACEG (IOUT,1)
      ENDIF
      IF (KI .EQ. 'TM') CALL BASINP
      IF (KI .EQ. 'TP') CALL BASINP
C-----------------------------------------------------------------------
C  If the KI code is in the first 60 codes, then no automatic restart.
C-----------------------------------------------------------------------
      IF (JAUTO .NE. 0) THEN
        NSAVE = NBLOCK
        ZERO = 0
        WRITE (IID,REC=9) ZERO
        NBLOCK = NSAVE
      ENDIF
      IF (KI .NE. ' ') THEN
        WRITE (COUT,22000) KI
        CALL GWRITE (ITP,' ')
        KI = ' '
        IMENU = 1
        GO TO 100
      ENDIF
      RETURN
10000 FORMAT (' Command ',$)
11000 FORMAT (' Unacceptable command. Do you want the menus (N) ? ',$)
12000 FORMAT (/' The following help menus are available :--'/
     $         '  1.  Terminal Data Input Commands;'/
     $         '  2.  Crystal Alignment Commands;'/
     $         '  3.  Intensity Data Collection;'/
     $         '  4.  Angle Setting and Intensity Measurement;'/
     $         '  5.  Photograph Setup Commands;'/
     $         '  6.  General System Commands.')
12100 FORMAT ( '  7.  Kappa Geometry (CAD-4) Commands.')
12200 FORMAT (' Which do you want (All) ? ',$)
13000 FORMAT (/10X,'*** Terminal Data Input Commands ***'/
     $'   AD Attenuator Data: number and values.'/
     $'   BD all Basic Data (CZ DH FR LA OM OR PS RR SD SE TM TP)'/
     $'   CZ Correct angle Zero values.'/
     $'   FR First Reflection to be measured.'/
     $'   LA LAmbda for the wavelength in use, usually alpha1.'/
     $'   LT Liquid Nitrogen option - specific to cryosystem.'/
     $'   OM Orientation Matrix.'/
     $'   PS PSi rotation data.'/
     $'   RO re-Orientation Reflections: frequency and h,k,ls.'/
     $'   RR Reference Reflections: frequency and h,k,ls.'/
     $'   SD Scan Data: type, width, speed, profile control.'/
     $'   SE Systematic Extinctions.'/
     $'   SG Space-Group symbol.'/
     $'   TM 2Theta Min and max values.'/
     $'   TP Time and Precision parameters for intensity measurement.'/)
14000 FORMAT (' Type <CR> when ready to proceed.')
15000 FORMAT (/10X,'*** Crystal Alignment Commands ***'/
     $'   AL ALign reflections and their symmetry equivalents for MM.'/
     $'   AR Align Resumption after interruption.'/
     $'   A8 Align the 8 alternate settings of one reflection.'/
     $'   CH CHoose reflections from the PK list for use with M2/M3.'/
     $'   CR Centre the Reflection which is already in the detector.'/
     $'   LC 2theta Least-squares Cell with symmetry constrained cell.'/
     $'   MM Matrix from Many reflections by least-squares on AL data.'/
     $'   M2 Matrix from 2 indexed reflections and a unit cell.'/
     $'   M3 Matrix from 3 indexed reflections.'/
     $'   OC Orient a Crystal, i.e. index the peaks from PK.'/
     $'   PK PeaK search in 2Theta, Chi, Phi for use with OC.'/
     $'   RC Reduce a unit Cell.'/
     $'   RP Rotate Phi 360degs, centre and save any peaks found.'/
     $'   RS ReSet the cell and matrix with the results from RC.'/
     $'   TO Transform the Orientation matrix.'/)
16000 FORMAT (/10X,'*** Intensity Data Collection ***'/
     $'   GO Start of intensity data collection.'/
     $'   K  Kill operation at the end of the current reflection.'/
     $'   Q  Quit after the next set of reference reflections.'/)
17000 FORMAT (/5X,'*** Angle Setting and Intensity Measurement ***'/
     $'   GS Grid Search measurement in 2theta, omega or chi.'/
     $'   IE Intensity measurement for Equivalent reflections.'/
     $'   IM Intensity Measurement of the reflection in the detector.'/
     $'   IP Intensity measurement in Psi for empirical absorption.'/
     $'   IR Intensity measurement for specified Reflections.'/
     $'   LP Line Profile plot on the printer.'/
     $'   SA Set All angles to specified values.'/
     $'   SC Set    Chi to the specified value.'/
     $'   SH SHutter open or close as a flip/flop.'/
     $'   SO Set  Omega to the specified value.'/
     $'   SP Set    Phi to the specified value.'/
     $'   SR Set Reflection: h,k,l,psi.'/
     $'   ST Set 2Theta to the specified value.'/
     $'   TC Timed Counts.'/
     $'   ZE ZEro the instrument Angles.'/)
18000 FORMAT (/10X,'*** Photograph Setup Commands ***'/
     $'   PL Photograph in the Laue mode.'/
     $'   PO Photograph in the Oscillation mode (same as OS).'/
     $'   PR Photograph in the Rotation mode.'/)
19000 FORMAT (/10X,'*** General System Commands ***'/
     $'   AH Angles to H,k,l (same as IX).'/
     $'   AI Ascii Intensity data file conversion.'/
     $'   AP Ascii Profile data file conversion.'/
     $'   BC Big Chi search for psi rotation.'/
     $'   BI Big Intensity search in the IDATA.DA file.'/
     $'   EX EXit the program saving the basic data on IDATA.DA.'/
     $'   HA H,k,l to Angles (same as RA).')
20000 FORMAT (
     $'   IN INitialize integer parts of present angles (NRC only).'/
     $'   NR set the NRC program flag.'/
     $'   P9 Rotate Phi by 90 degrees for crystal centering.'/
     $'   PA Print Angle settings.'/
     $'   PD Print Data of all forms.'/
     $'   Q  Quit the program directly.'/
     $'   RB Read the Basic data from the IDATA.DA file.'/
     $'   SW SWitch register flags setting.'/
     $'   UM (UMpty) Count unique reflections within theta limits.'/
     $'   VM View crystal with Microscope.'/ 
     $'   WB Write the Basic data to the IDATA.DA file.'/)
20100 FORMAT (/10X,'*** For Kappa geometry (CAD-4) ***'/
     $'   EK Euler to Kappa angle conversion.'/
     $'   KE Kappa to Euler angle conversion.'/
     $'   MR emulate CAD-4 MICROR command.'/
     $'   MS emulate CAD-4 MICROS command.')
21000 FORMAT (' EX was typed. Are you sure you wish to exit (Y) ? ',$)
22000 FORMAT (' The command ',A,' is invalid. Type <CR> for the menus.')
      END
C-----------------------------------------------------------------------
C  Subroutine to open and close the X-ray shutter
C  This routine is called via 'SH' or direct from other routines.
C  The argument IDO has the following values :--
C    -1  Close the shutter
C     0  Reverse the sense of the shutter.  The sense is held in SENSE
C     1  Open the shutter
C     2  ??
C    99  Called from GOLOOP at the start of data-collection; 
C        Opens the shutter and sets DOIT = 'NO'
C        to prevent shutter operation during data-collection.
C   -99  Called from GOLOOP at the end of data-collection; 
C        Closes the shutter and sets DOIT = 'YES'
C        to allow normal shutter operation.
C
C  This version is for Rigaku diffractometers,but should work (surely?)
C  for all instruments with trivial modification.
C-----------------------------------------------------------------------
      SUBROUTINE SHUTTR (IDO)
      CHARACTER SENSE*4,COUT(20)*132,DOIT*4
      COMMON /IOUASC/ COUT
      DATA SENSE/'CLOS'/,ICLOSE,IOPEN/0,1/,DOIT/'YES '/
      INF = 0
      IF (DOIT .EQ. 'YES ') THEN
        IF (IDO .EQ.-1 .OR. IDO .EQ. -99) THEN
          IF (SENSE .EQ. 'OPEN') THEN
            CALL SHUTR (ICLOSE,INF)
            IF (INF .NE. 0) GO TO 100
            SENSE = 'CLOS' 
          ENDIF
        ELSE IF (IDO .EQ. 0) THEN
          IF (SENSE .EQ. 'OPEN') THEN
            CALL SHUTR (ICLOSE,INF)
            IF (INF .NE. 0) GO TO 100
            SENSE = 'CLOS'
          ELSE
            CALL SHUTR (IOPEN,INF)
            IF (INF .NE. 0) GO TO 100
            SENSE = 'OPEN'
          ENDIF
        ELSE IF (IDO .EQ. 1 .OR. IDO .EQ. 99) THEN
          IF (SENSE .EQ. 'CLOS') THEN
            CALL SHUTR (IOPEN,INF)
            IF (INF .NE. 0) GO TO 100
            SENSE = 'OPEN'
          ENDIF
        ELSE IF (IDO .EQ. 2) THEN
          IF (SENSE .EQ. 'OPEN') CALL SHUTR (IOPEN,INF)
          IF (SENSE .EQ. 'CLOS') CALL SHUTR (ICLOSE,INF)
        ENDIF
      ELSE
        IF (IDO .EQ. -99) THEN
          CALL SHUTR (ICLOSE,INF)
          IF (INF .NE. 0) GO TO 100
          SENSE = 'CLOS'
        ENDIF
      ENDIF
      IF (IDO .EQ.  99) DOIT = 'NO  '
      IF (IDO .EQ. -99) DOIT = 'YES '
      RETURN
  100 WRITE (COUT,10000)
      CALL GWRITE (ITP,' ')
      RETURN
10000 FORMAT (' Shutter Error.')
      END
C-----------------------------------------------------------------------
C  Subroutine to initialize the integer values of the angles
C-----------------------------------------------------------------------
      SUBROUTINE ANGINI
      INCLUDE 'COMDIF'
      WRITE (COUT,10000)
      CALL YESNO ('Y',ANS)
      IF (ANS .EQ. 'Y') THEN
        WRITE (COUT,11000)
        CALL FREEFM (ITR)
        RTHETA = RFREE(1)
        ROMEGA = RFREE(2)
        RCHI   = RFREE(3)
        RPHI   = RFREE(4)
        CALL INITL (RTHETA,ROMEGA,RCHI,RPHI)
        KI = ' '
      ENDIF
      RETURN
10000 FORMAT (' Initialize the integer parts of the angle (Y) ? ',$)
11000 FORMAT (' Type the integers for 2theta,omega,chi,phi ',$)
      END
C-----------------------------------------------------------------------
C  Subroutine to call the space group symbol interpreting routines
C  If IOUT   .LT. -1 the symbol is not asked for
C  If IOUT   .LT. 0  there is no printed output from SGROUP
C  If IDHFLG .EQ. 1  the DH matrices are generated
C-----------------------------------------------------------------------
      SUBROUTINE SPACEG (IOUT,IDHFLG)
      INCLUDE 'COMDIF'
      DIMENSION CEN(3,4),GARB(500),ISET(25)
      EQUIVALENCE (ACOUNT(1),GARB(1))
      CHARACTER STRING*10
      IF (IOUT .EQ. -2) THEN
        IOUT = -1
        GO TO 130
      ENDIF
  100 IF (SGSYMB(1) .EQ. 0.0 .AND. SGSYMB(2) .EQ. 0.0) THEN
        WRITE (COUT,10000)
      ELSE
        WRITE (STRING,11000) SGSYMB
        DO 110 I = 10,1,-1
          IF (STRING(I:I) .NE. ' ') GO TO 120
  110   CONTINUE
  120   WRITE (COUT,12000) STRING(1:I)
      ENDIF
      CALL ALFNUM (STRING)
      IF (STRING .NE. ' ') READ (STRING,11000) SGSYMB
  130 IERR = ITP 
      CALL SGROUP (SGSYMB,LAUENO,NAXIS,ICENT,LATCEN,NSYM,NPOL,JRT,
     $             CEN,NCV,IOUT,IERR,GARB)
      IF (NAXIS .GE. 4) GO TO 100
      IF (IDHFLG .EQ. 1) THEN
        SAVE = NBLOCK
        CALL DHGEN
        NBLOCK = SAVE
C-----------------------------------------------------------------------
C  Read the DH segment data from the IDATA file
C-----------------------------------------------------------------------
        READ (IID,REC=4) LATCEN,NSEG,(IHO(I),IKO(I),ILO(I),((IDH(I,J,M),
     $                   J = 1,3),M = 1,3),I = 1,4),
     $                   NSYM,NSET,ISET,LAUENO,NAXIS,ICENT
      ENDIF
      IF (KI .EQ. 'SG') KI = ' '
      RETURN
10000 FORMAT (' Type the space-group symbol ')
11000 FORMAT (10A1)
12000 FORMAT (' Type the space-group symbol (',A,') ')
      END
C-----------------------------------------------------------------------
C  Subroutine to set switches
C-----------------------------------------------------------------------
      SUBROUTINE SWITCH
      INCLUDE 'COMDIF'
      CHARACTER STRING*20
      WRITE (COUT,10000) (ISREG(I),I=1,10)
      CALL ALFNUM (STRING)
      IF (STRING .NE. ' ') THEN
        DO 100 I = 1,LEN(STRING)
          IASCII = ICHAR (STRING(I:I))
          IF (IASCII .GE. 48 .AND. IASCII .LE. 57) THEN
            ISWTCH = IASCII - 48 + 1
            IF (ISREG(ISWTCH) .EQ. 0) THEN
              ISREG(ISWTCH) = 1
            ELSE
              ISREG(ISWTCH) = 0
            ENDIF
          ENDIF
  100   CONTINUE
      ENDIF
      WRITE (COUT,11000) (ISREG(I),I=1,10)
      CALL GWRITE (ITP,' ')
      KI = ' '
      RETURN
10000 FORMAT (' The current settings are: 0 1 2 3 4 5 6 7 8 9'/
     $        '                          ',10I2/
     $        ' Input switches to change (none): ')
11000 FORMAT (' The  new settings are:    0 1 2 3 4 5 6 7 8 9'/
     $        '                          ',10I2)
      END
C----------------------------------------------------------------------
C  Set the NRC flag +1 if Chi(0) is at the bottom of the chi circle,
C                   -1 if Chi(0) is at the top.
C  Assuming the instrument itself is defined in a right-handed way.
C----------------------------------------------------------------------
      SUBROUTINE SETNRC
      INCLUDE 'COMDIF'
      WRITE (COUT,10000) NRC
      CALL FREEFM (ITR)
      IF (IFREE(1) .NE. 0) NRC = IFREE(1)
      RETURN
10000 FORMAT (' The current value of the NRC flag is',I3/
     $        ' Type the new value (Current) ',$)
      END
C-----------------------------------------------------------------------
C  Convert Euler angles to Kappa (KI = 'EK') or vice-versa (KI = 'KE')
C-----------------------------------------------------------------------
      SUBROUTINE EKKE
      INCLUDE 'COMDIF'
      COMMON /CADCON/ ALPHA,APMIN,APMAX,MAXVAR,MINVAR,
     $                IHOLE,IVSLIT,IHSLIT,INEG45,IPOS45,IUPHAF,ILOHAF,
     $                VUTHT,VUOME,VUCHI,VUPHI,IPORT,IBAUD
      PARAMETER (RA = 57.2958)
      SALPHA = SIN(ALPHA/RA)
      CALPHA = COS(ALPHA/RA)
      ISTATUS = 0
C-----------------------------------------------------------------------
C  KI = 'EK'  Euler to Kappa
C-----------------------------------------------------------------------
      IF (KI .EQ. 'EK') THEN
        WRITE (COUT,10000) THETA,OMEGA,CHI,PHI
        CALL FREEFM (ITR)
        IF (RFREE(1) .EQ. 0.0 .AND. RFREE(2) .EQ. 0.0 .AND.
     $      RFREE(3) .EQ. 0.0) THEN
          THE = THETA
          OME = OMEGA
          CHE = CHI
          PHE = PHI
        ELSE
          THE = RFREE(1)
          OME = RFREE(2)
          CHE = RFREE(3)
          PHE = RFREE(4)
        ENDIF
        THE = THE/2.0
        SCO2 = SIN(ONE80(CHE)/(2.0*RA))
        BOT  = SALPHA*SALPHA - SCO2*SCO2
        IF (BOT .LT. 0.0) THEN
          ISTATUS = 1
          KI = ' '
          RETURN
        ENDIF
        RKAO2 = ATAN(SCO2/SQRT(BOT))
        RKA   = ONE80(2.0*RA*RKAO2)
        DELTA = RA*ATAN(CALPHA*SIN(RKAO2)/COS(RKAO2))
        OMK   = ONE80(OME - DELTA) + THE
        PHK   = ONE80(PHE - DELTA)
        WRITE (COUT,11000) THE,OMK,RKA,PHK
C-----------------------------------------------------------------------
C  KI = 'KE'  Kappa to Euler 
C-----------------------------------------------------------------------
      ELSE
        WRITE (COUT,12000)
        CALL FREEFM (ITR)
        THE = RFREE(1)
        OMK = RFREE(2)
        RKA = RFREE(3)
        PHK = RFREE(4)
        OMK = OMK - THE
        THE = THE + THE
        RKAO2 = RKA/(2.0*RA)
        CHE   = ONE80(2.0*RA*ASIN(SALPHA*SIN(RKAO2)))
        DELTA = RA*ATAN(CALPHA*SIN(RKAO2)/COS(RKAO2))
        OME   = ONE80(OMK + DELTA)
        PHE   = ONE80(PHK + DELTA)
        WRITE (COUT,13000) THE,OME,CHE,PHE
      ENDIF
      CALL GWRITE (ITP,' ')
      KI = ' '
      RETURN
10000 FORMAT (' The present Euler angles are 2T,O,C,P',4F8.3,/
     $        ' Type the angles to convert (Present) ',$)
11000 FORMAT (' The 4 Kappa angles T,O,K,P are  ',4F8.3)
12000 FORMAT (' Type the 4 Kappa angles T,O,K,P ',$)
13000 FORMAT (' The 4 Euler angles 2T,O,C,P are ',4F8.3)
      END
C-----------------------------------------------------------------------
C  Set the diffractometer to a convenient microscope viewing position
C-----------------------------------------------------------------------
      SUBROUTINE VUMICR
      INCLUDE 'COMDIF'
      NATT = 0
      CALL VUPOS (THETA,OMEGA,CHI,PHI)
      CALL SHUTTR (-99)
      CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,IERR)
      IF (IERR .NE. 0) THEN
        WRITE (COUT,10000)
        CALL GWRITE (ITP,' ')
      ENDIF
      KI = ' '
      RETURN
10000 FORMAT (' Setting collision during VM')
      END
C-----------------------------------------------------------------------
C  Rotate the crystal 90 degrees in phi for centering operations
C-----------------------------------------------------------------------
      SUBROUTINE PHI90
      INCLUDE 'COMDIF'
      CALL ANGET (THETA,OMEGA,CHI,PHI)
      PHI = PHI + 90.0
      CALL MOD360 (PHI)
      CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,IERR)
      KI = ' '
      RETURN
      END
C-----------------------------------------------------------------------
C  Transform the orientation matrix
C-----------------------------------------------------------------------
      SUBROUTINE TRANSF
      INCLUDE 'COMDIF'
      DIMENSION HOLD(3,3),HNEW(3,3),HNEWI(3,3),RNEW(3,3)
      WRITE (COUT,10000)
      CALL GWRITE (ITP,' ')
      DO 100 I = 1,3
   90   WRITE (COUT,11000) I
        CALL FREEFM (ITR)
        HOLD(1,I) = IFREE(1)
        HOLD(2,I) = IFREE(2)
        HOLD(3,I) = IFREE(3)
        HNEW(1,I) = IFREE(4)
        HNEW(2,I) = IFREE(5)
        HNEW(3,I) = IFREE(6)
        IF ((HOLD(1,I) .EQ. 0.0 .AND. HOLD(2,I) .EQ. 0.0 .AND.
     $       HOLD(3,I) .EQ. 0.0) .OR.
     $      (HNEW(1,I) .EQ. 0.0 .AND. HNEW(2,I) .EQ. 0.0 .AND.
     $       HNEW(3,I) .EQ. 0.0)) THEN
          WRITE (COUT,11100) 
          CALL GWRITE (ITP,' ')
          GO TO 90
        ENDIF
  100 CONTINUE
C-----------------------------------------------------------------------
C  Invert the IHNEW matrix and form  RNEW = R.IHOLD.(IHNEW)-1
C-----------------------------------------------------------------------
      CALL MATRIX (HNEW,HNEWI,HNEWI,HNEWI,'INVERT')
      CALL MATRIX (R,HOLD,RNEW,RJUNK,'MATMUL')
      CALL MATRIX (RNEW,HNEWI,RNEW,RJUNK,'MATMUL')
C-----------------------------------------------------------------------
C  Print the new matrix and parameters
C-----------------------------------------------------------------------
      DO 110 I = 1,3
        DO 110 J = 1,3
          ROLD(I,J) = R(I,J)/WAVE
          R(I,J) = RNEW(I,J)
          RNEW(I,J) = RNEW(I,J)/WAVE
  110 CONTINUE
C-----------------------------------------------------------------------
C  Evaluate the determinant to decide if right or left handed
C-----------------------------------------------------------------------
        DET = R(1,1)*(R(2,2)*R(3,3) - R(2,3)*R(3,2)) -
     $        R(1,2)*(R(2,1)*R(3,3) - R(2,3)*R(3,1)) +
     $        R(1,3)*(R(2,1)*R(3,2) - R(2,2)*R(3,1))
        IF (NRC*DET .EQ. 0) THEN
          WRITE (COUT,12000)
          KI = ' '
        ELSE IF (NRC*DET .GT. 0) THEN
          WRITE (COUT,13000) KI,((RNEW(I,J),J = 1,3),I = 1,3)
        ELSE
          WRITE (COUT,14000) KI,((RNEW(I,J),J = 1,3),I = 1,3)
        ENDIF
        CALL GWRITE (ITP,' ')
        CALL GETPAR
        DO 120 I = 1,3
          AP(I) = AP(I)*WAVE
  120   CONTINUE
        WRITE (COUT,15000) AP,CANG
        CALL GWRITE (ITP,' ')
      RETURN
10000 FORMAT (10X,' Transform the Orientation Matrix'/
     $        ' Type in old and new h,k,l values for 3 reflections')
11000 FORMAT (' Type old and new h,k,l for reflection',I2,'  ',$)
11100 FORMAT (' 0,0,0 indices not allowed.  Try again.')
12000 FORMAT (' The determinant of the matrix is 0.')
13000 FORMAT (' New RIGHT-handed Orientation Matrix from ',A2/(3F12.8))
14000 FORMAT (' New LEFT-handed Orientation Matrix from ',A2/(3F12.8))
15000 FORMAT (' New Unit Cell ',3F9.4,3F9.3)
      END
