C-----------------------------------------------------------------------
C  Read in all Basic Data from the terminal commands
C-----------------------------------------------------------------------
      SUBROUTINE BASINP
      INCLUDE 'COMDIF'
      CHARACTER KISAVE*2
C-----------------------------------------------------------------------
C  Select data to be read from keys with the value in KI 
C   If KI = 'BD' then all basic data must be typed in.
C   The following keys are allowed :--
C     AD BD  CZ  DH  FR  LA  M2  M3  MM  OM  PS  RO  RR  SD  SE  TM  TP  
C
C  If M2, M3 or MM reset the indices corresponding to 2thetamax
C
C  BD -- All Basic Data
C-----------------------------------------------------------------------
      IF (KI .EQ. 'BD') THEN
        WRITE (COUT,10000)
        CALL YESNO ('Y',ANS)
        IF (ANS .EQ. 'N') THEN
          KI = ' '
          RETURN
        ENDIF
      ENDIF
C-----------------------------------------------------------------------
C  AD -- Attenuator Data
C-----------------------------------------------------------------------
      IF (KI .EQ. 'AD' .OR. KI .EQ. 'BD') THEN
        IF (NATTEN .EQ. 0) THEN
          WRITE (COUT,12000)
        ELSE
          WRITE (COUT,12100) (ATTEN(I),I=1,NATTEN+1)
        ENDIF
        CALL GWRITE (ITP,' ')
        WRITE (COUT,12200)
        CALL YESNO ('Y',ANS)
        IF (ANS .EQ. 'Y') THEN
          WRITE (COUT,12300)
          CALL FREEFM (ITR)
          NATTEN = 0
          ATTEN(1) = 1.0
          DO 100, I = 1,6
            IF (RFREE(I) .GT. 1.0) THEN
              NATTEN = NATTEN + 1
              ATTEN(NATTEN+1) = RFREE(I)
            ENDIF
  100     CONTINUE
        ENDIF
        IF (KI .EQ. 'AD') THEN
          KI = ' '
          RETURN
        ENDIF
      ENDIF
C-----------------------------------------------------------------------
C  LA -- Wavelength.  When a new wavelength is to be used, the R matrix,
C                     SINABS and IH,K,LMAX must all be changed
C-----------------------------------------------------------------------
      IF (KI .EQ. 'LA' .OR. KI .EQ. 'BD') THEN
        WRITE (COUT,11000) WAVE
        CALL FREEFM (ITR)
        OWAVE = WAVE
        IF (RFREE(1) .NE. 0.0) WAVE = RFREE(1)
        WAVFAC = WAVE/OWAVE
        IF (KI .EQ. 'LA') THEN
          DO 110 I = 1,3
            SINABS(I)   = WAVFAC*WAVFAC*SINABS(I)
            SINABS(I+3) = WAVFAC*WAVFAC*SINABS(I+3)
            DO 110 J = 1,3
              R(I,J) = WAVFAC*R(I,J)
  110     CONTINUE
          S = 2.0*SIN((THEMAX*0.5)/DEG)
          IHMAX = 1.0+S/(APS(1)*SANGS(2)*SANG(3)*WAVE)
          IKMAX = 1.0+S/(APS(2)*SANGS(3)*SANG(1)*WAVE)
          ILMAX = 1.0+S/(APS(3)*SANGS(1)*SANG(2)*WAVE)
          KI = ' '
          CALL WRBAS
          RETURN
        ENDIF
      ENDIF
C-----------------------------------------------------------------------
C  OM -- Orientation Matrix
C-----------------------------------------------------------------------
      IF (KI .EQ. 'OM' .OR. KI .EQ. 'BD') THEN
        IF (KI .EQ. 'OM') THEN
          WRITE (COUT,11000) WAVE
          CALL FREEFM (ITR)
          IF (RFREE(1) .NE. 0.0) WAVE = RFREE(1)
        ENDIF
        WRITE (COUT,13000)
        CALL GWRITE (ITP,' ')
        DO 120 I = 1,3
          WRITE (COUT,13100)
          CALL FREEFM (ITR)
          R(I,1) = RFREE(1)
          R(I,2) = RFREE(2)
          R(I,3) = RFREE(3)
  120   CONTINUE
        DO 130 I = 1,3
          DO 130 J = 1,3
            R(I,J) = R(I,J)*WAVE
  130   CONTINUE
        KISAVE = KI
        KI = 'OM'
        CALL ORMAT3
        KI = KISAVE
        CALL WRBAS
      ENDIF
C-----------------------------------------------------------------------
C  CZ -- Circle Zero Corrections
C-----------------------------------------------------------------------
      IF (KI .EQ. 'CZ' .OR. KI .EQ. 'BD') THEN
        WRITE (COUT,14000) DTHETA,DOMEGA,DCHI,DPHI
        CALL FREEFM (ITR)
        DTHETA = RFREE(1)
        DOMEGA = RFREE(2)
        DCHI   = RFREE(3)
        DPHI   = RFREE(4)
        IF (KI .NE. 'BD') THEN
          KI = ' '
          CALL WRBAS
          RETURN
        ENDIF
      ENDIF
C-----------------------------------------------------------------------
C  RO -- Re-Orientation reflections for use during GO
C-----------------------------------------------------------------------
      IF (KI .EQ. 'RO' .OR. KI .EQ. 'BD') THEN
        WRITE (COUT,15000)
        CALL YESNO ('N',ANS)
        NINTOR = 0
        REOTOL = 10.0
        IF (ANS .EQ. 'N') THEN
          CALL WRBAS
        ELSE
          WRITE (COUT,15100)
          CALL FREEFM (ITR)
          NINTOR = IFREE(1)
          IF (NINTOR .EQ. 0) NINTOR = 500
          WRITE (COUT,15200)
          CALL FREEFM (ITR)
          REOTOL = RFREE(1)
          IF (REOTOL .EQ. 0.0) REOTOL = 0.1
          CALL WRBAS
          CALL ALIGN
        ENDIF
        KI = ' '
      ENDIF
C-----------------------------------------------------------------------
C  RR -- Reference Reflections
C-----------------------------------------------------------------------
      IF (KI .EQ. 'RR' .OR. KI .EQ. 'BD') THEN
        WRITE (COUT,16000)
        CALL YESNO ('Y',ANS)
        IF (ANS. EQ. 'Y') THEN
          WRITE (COUT,16100)
          CALL FREEFM (ITR)
          NSTAN  = 0
          NINTRR = IFREE(1)
          IF (NINTRR .EQ. 0) NINTRR = 100
          WRITE (COUT,19000)
          CALL GWRITE (ITP,' ')
  140     WRITE (COUT,19100)
          CALL FREEFM (ITR)
          IF (IFREE(1) .NE. 0 .OR. IFREE(2) .NE. 0 .OR.
     $        IFREE(3) .NE. 0) THEN
            NSTAN = NSTAN + 1
            IHSTAN(NSTAN) = IFREE(1)
            IKSTAN(NSTAN) = IFREE(2)
            ILSTAN(NSTAN) = IFREE(3)
            GO TO 140
          ENDIF
        ELSE
          NSTAN = 0
          NINTRR = 0
        ENDIF
        IF (KI .NE. 'BD') THEN
          KI = ' '
          CALL WRBAS
          RETURN
        ENDIF
      ENDIF
C-----------------------------------------------------------------------
C  TM -- 2Theta min and max
C-----------------------------------------------------------------------
      IF (KI .EQ. 'TM' .OR. KI .EQ. 'OM' .OR. KI .EQ. 'BD' .OR.
     $    KI .EQ. 'M2' .OR. KI .EQ. 'M3' .OR. KI .EQ. 'MM' .OR.
     $    KI .EQ. 'TO') THEN
        IF (KI .EQ. 'TM' .OR. KI .EQ. 'OM' .OR. KI .EQ. 'BD' .OR.
     $      THEMAX .LT. 1.0) THEN
          WRITE (COUT,21000) THEMIN,THEMAX
          CALL FREEFM (ITR)
          IF (RFREE(1) .NE. 0.0) THEMIN = RFREE(1)
          IF (RFREE(2) .NE. 0.0) THEMAX = RFREE(2)
          IF (ITYPE .GE. 0 .AND. ITYPE .LE. 3) THEN
            NPTS = (AS + BS*TAN(0.5*THEMAX/DEG) + CS)*STEPDG + 0.5
            IF (NPTS .GT. 499) THEN 
               WRITE (COUT,22000)
               CALL GWRITE (ITP,' ')
            ENDIF 
          ENDIF
        ENDIF
C-----------------------------------------------------------------------
C  Optionally retain old matrix for M2, M3 or MM
C-----------------------------------------------------------------------
        IF (KI .EQ. 'M2' .OR. KI .EQ. 'M3' .OR. KI .EQ. 'MM' .OR.
     $      KI .EQ. 'TO') THEN
          WRITE (COUT,24000)
          CALL YESNO ('Y',ANS)
          IF (ANS .EQ. 'N') THEN
            DO 145 I = 1,3
              DO 145 J = 1,3
                R(I,J) = ROLD(I,J)
  145       CONTINUE
          ELSE
            DO 148 I = 1,3
              DO 148 J = 1,3
                R(I,J) = R(I,J)/WAVE
  148       CONTINUE
          ENDIF
          CALL GETPAR
          DO 146 I = 1,3
            SANG(I)  = SIN(CANG(I)/DEG)
            CANG(I)  = COS(CANG(I)/DEG)
            SANGS(I) = SIN(CANGS(I)/DEG)
            CANGS(I) = COS(CANGS(I)/DEG)
  146     CONTINUE
          DO 147 I = 1,3
            DO 147 J = 1,3
              R(I,J) = R(I,J)*WAVE
  147     CONTINUE
        ENDIF
C-----------------------------------------------------------------------
C  Set new h,k,l max values
C-----------------------------------------------------------------------
        S = 2.0*SIN((THEMAX*0.5)/DEG)
        IHMAX = 1.0 + S/(APS(1)*SANGS(2)*SANG(3)*WAVE)
        IKMAX = 1.0 + S/(APS(2)*SANGS(3)*SANG(1)*WAVE)
        ILMAX = 1.0 + S/(APS(3)*SANGS(1)*SANG(2)*WAVE)
        IF (KI .EQ. 'OM') ANS = 'Y'
        IF (KI .NE. 'TM' .AND. KI .NE. 'BD' .AND. ANS .EQ. 'Y') 
     $      CALL SYSPNT
        IF (KI .NE. 'BD') THEN
          KI = ' '
          CALL WRBAS
          RETURN
        ENDIF
      ENDIF
C-----------------------------------------------------------------------
C  SE -- Systematic Extinction Conditions
C-----------------------------------------------------------------------
      IF (KI .EQ. 'SE' .OR. KI .EQ. 'BD') THEN
        WRITE (COUT,25000)
        CALL FREEFM (ITR)
        NCOND = IFREE(1)
        IF (NCOND .NE. 0) THEN
          WRITE (COUT,28000)
          CALL GWRITE (ITP,' ')
          DO 150 J = 1,NCOND
            WRITE (COUT,13100)
            CALL FREEFM (ITR)
            ICOND(J) = IFREE(1)
            IHS(J) = IFREE(2)
            IKS(J) = IFREE(3)
            ILS(J) = IFREE(4)
            IR(J) = IFREE(5)
            IS(J) = IFREE(6)
  150     CONTINUE
        ENDIF
        IF (KI .NE. 'BD') THEN
          KI = ' '
          CALL WRBAS
          RETURN
        ENDIF
      ENDIF
C-----------------------------------------------------------------------
C  SD -- Scan Control Data
C
C   Values of ITYPE on input & during running and IBSECT & ISCAN
C
C                                ITYPE
C       Type of Operation     Input Running IBSECT3  ISCAN
C
C  Theta/2Theta b/P/b scan      0       0      0       0
C  Omega b/P/b scan             1       2      0       0
C  Compton or T.D.S.            2       0      0       1
C  Theta/2Theta Precision scan  3       1      0       3
C  Omega        Precision scan  4       3      0       4
C  Peak Top Theta backgrounds   5       5      0       0
C  Peak Top Omega backgrounds   6       6      0       0
C  Economized Peak Top Theta    7       7      0       0
C  Economized Peak Top Omega    8       8      0       0
C
C-----------------------------------------------------------------------
      IF (KI .EQ. 'SD' .OR. KI .EQ. 'BD') THEN
        WRITE (COUT,30000)
        CALL FREEFM (ITR)
        ITYPE = IFREE(1)
        WRITE (COUT,30100) AS,BS,CS
        CALL FREEFM (ITR)
        IF (RFREE(1) .NE. 0.0) AS = RFREE(1)
        IF (RFREE(2) .NE. 0.0) BS = RFREE(2)
        IF (RFREE(3) .NE. 0.0) CS = RFREE(3)
        IPRFLG = 1
        IF (ITYPE .LT. 4) THEN
          WRITE (COUT,31000)
          CALL FREEFM (ITR)
          IPRFLG = IFREE(1)
        ENDIF
        ISCAN = 0
        IBSECT = 0
        ITEMP = ITYPE
        IF (ITYPE .EQ. 1) ITEMP = 2
C        IF (ITYPE .EQ. 2) THEN
C          ITEMP  = 0
C          ISCAN = 1
C        ENDIF
        IF (ITYPE .EQ. 2) THEN
          ITEMP  = 1
          ISCAN = 3
        ENDIF
        IF (ITYPE .EQ. 3) THEN
          ITEMP  = 3
          ISCAN = 4
        ENDIF
        IF (ITYPE .GE. 4) ITEMP = ITYPE + 1
        ITYPE = ITEMP
        IBSECT = 0
C       WRITE (COUT,32000)
C       CALL FREEFM (ITR)
C       IBSECT = IFREE(1)
        IF (ITYPE .LT. 4) THEN
C          WRITE (COUT,33000)
C          CALL FREEFM (ITR)
C          SPEED = RFREE(1)
C          IF (SPEED .EQ. 0.0) SPEED = 4.0
        ENDIF
C---------------------------------------------------------------------
C Step and Preset for TRICS
C-------------------------------------------------------------------
        OLDDSTEP = STEP
        OLDPRE = PRESET
        WRITE(COUT,33500)STEP,PRESET
        CALL FREEFM(ITR)
        STEP = RFREE(1)
        PRESET = RFREE(2)
        IF(STEP .LE. 0.)STEP = OLDSTEP
        IF(PRESET .LE. 0)PRESET = OLDPRE
        IF(STEP .LE. 0.)STEP = 0.02
        IF(PRESET .LE. 0)PRESET = 10000
C-----------------------------------------------------------------------
C  Horizontal aperture width for CAD-4 data collection
C-----------------------------------------------------------------------
        IF (DFMODL .EQ. 'CAD4') THEN
          CADSL = ICADSL/10.0
          WRITE (COUT,33100) CADSL
          CALL FREEFM (ITR)
          IF (RFREE(1) .EQ. 0.0) RFREE(1) = CADSL
          ICADSL = 10*RFREE(1) + 0.5
          WRITE (COUT,33200)
          CALL YESNO ('Y',ANS)
          ICADSW = 1
          IF (ANS .EQ. 'N') ICADSW = 0
        ENDIF
        STEPOF = 0.5
        IF (IPRFLG .EQ. 0) THEN
          WRITE (COUT,34000)
          CALL FREEFM (ITR)
          STEPOF = RFREE(1)
          IF (STEPOF .EQ. 0) STEPOF = 0.5
        ENDIF
        IF (ITYPE .GE. 0 .AND. ITYPE .LE. 3) THEN
          NPTS = (AS + BS*TAN(0.5*THEMAX/DEG) + CS)*STEPDG + 0.5
          IF (NPTS .GT. 499) THEN
             WRITE (COUT,22000)
             CALL GWRITE (ITP,' ')
          ENDIF 
        ENDIF
        IF (KI .NE. 'BD') THEN
          KI = ' '
          CALL WRBAS
          RETURN
        ENDIF
      ENDIF
C-----------------------------------------------------------------------
C  TP -- Time and Precision control data
C-----------------------------------------------------------------------
      IF (KI .EQ. 'TP' .OR. KI .EQ. 'BD') THEN
        WRITE (COUT,35000)
        CALL GWRITE (ITP,' ')
        I = ITYPE
        IF (ISCAN .EQ. 1) THEN
          WRITE (COUT,37000)
          CALL FREEFM (ITR)
          FRAC = RFREE(1)
          TMAX = RFREE(2)
          PA = RFREE(3)
          PM = RFREE(4)
        ELSE
          IF (I .EQ. 0 .OR. I .EQ. 2 .OR. I .EQ. 5 .OR. I .EQ. 6) THEN
            WRITE (COUT,36000)
            CALL FREEFM (ITR)
            FRAC = RFREE(1)
            IF (FRAC .EQ. 0.0) FRAC = 0.1
            IF (I .EQ. 5 .OR. I .EQ. 6) THEN
              WRITE (COUT,35900)
              CALL FREEFM (ITR)
              PRESET = RFREE(1)
              IF (PRESET .EQ. 0.0) PRESET = 1000.0
            ENDIF
          ELSE IF (I .EQ. 1 .OR. I .EQ. 3) THEN
            WRITE (COUT,36000)
            CALL FREEFM (ITR)
            FRAC = RFREE(1)
            IF (FRAC .EQ. 0.0) FRAC = 0.1
            WRITE (COUT,37100)
            CALL FREEFM (ITR)
            TMAX = RFREE(1)
            IF (TMAX .EQ. 0.0) TMAX = 240.0
            WRITE (COUT,37200)
            CALL FREEFM (ITR)
            PA = RFREE(1)
            IF (PA .EQ. 0.0) PA = 0.02
            WRITE (COUT,37300)
            CALL FREEFM (ITR)
            PM = RFREE(1)
            IF (PM .EQ. 0.0) PM = 0.10
          ELSE IF (I .EQ. 7 .OR. I .EQ. 8) THEN
            WRITE (COUT,38000)
            CALL FREEFM (ITR)
            FRAC = RFREE(1)
            TMAX = RFREE(2)
            PA = RFREE(3)
          ENDIF
        ENDIF
        IF (KI .NE. 'BD') THEN
          KI = ' '
          CALL WRBAS
          RETURN
        ENDIF
      ENDIF
C-----------------------------------------------------------------------
C  DH -- DH Matrix Data
C-----------------------------------------------------------------------
      IF (KI .EQ. 'DH' .OR. KI .EQ. 'BD') THEN
        WRITE (COUT,40000)
        CALL FREEFM (ITR)
        NSEG = IFREE(1)
        NMSEG = 1
        WRITE (COUT,42000)
        CALL GWRITE (ITP,' ')
        DO 160 J = 1,NSEG
          WRITE (COUT,13100)
          CALL FREEFM (ITR)
          IHO(J) = IFREE(1)
          IKO(J) = IFREE(2)
          ILO(J) = IFREE(3)
          IDH(J,1,1) = IFREE(4)
          IDH(J,2,1) = IFREE(5)
          IDH(J,3,1) = IFREE(6)
          IDH(J,1,2) = IFREE(7)
          IDH(J,2,2) = IFREE(8)
          IDH(J,3,2) = IFREE(9)
          IDH(J,1,3) = IFREE(10)
          IDH(J,2,3) = IFREE(11)
          IDH(J,3,3) = IFREE(12)
  160   CONTINUE
C-----------------------------------------------------------------------
C  Read the B.Z. limits for COMPTON or TDS
C-----------------------------------------------------------------------
        IF (ISCAN .EQ. 1) THEN
          WRITE (COUT,44000)
          CALL GWRITE (ITP,' ')
           DO 170 J = 1,NSEG
            WRITE (COUT,13100)
            CALL FREEFM (ITR)
            JA(J) = IFREE(1)
            JB(J) = IFREE(2)
            JC(J) = IFREE(3)
            JMIN(J) = IFREE(4)
            JMAX(J) = IFREE(5)
  170     CONTINUE
        ENDIF
        IF (KI .EQ. 'DH') CALL SYSPNT
        IF (KI .NE. 'BD') THEN
          KI = ' '
          RETURN
        ENDIF
      ENDIF
C-----------------------------------------------------------------------
C  Psi Scan Data
C-----------------------------------------------------------------------
      IF (KI .EQ.'PS' .OR. KI .EQ. 'BD') THEN
        WRITE (COUT,47000)
        CALL FREEFM (ITR)
        DPSI = RFREE(1)
        PSIMIN = RFREE(2)
        PSIMAX = RFREE(3)
        IF (KI .NE. 'BD') THEN
          KI = ' '
          RETURN
        ENDIF
      ENDIF
C-----------------------------------------------------------------------
C  FR -- First Reflection Data
C-----------------------------------------------------------------------
      IF (KI .EQ. 'FR' .OR. KI .EQ. 'BD') THEN
        WRITE (COUT,49000)
        CALL FREEFM (ITR)
        IND(1) = IFREE(1)
        IND(2) = IFREE(2)
        IND(3) = IFREE(3)
        WRITE (COUT,52000)
        CALL FREEFM (ITR)
        NREF = IFREE(1)
        NMSEG = IFREE(2)
        WRITE (COUT,53000)
        CALL FREEFM (ITR)
        NBLOCK = IFREE(1)
        KI = ' '
      ENDIF
      RETURN
10000 FORMAT (' Basic Data Input (Y) ',$)
11000 FORMAT (' Type the wavelength (',F7.5,') ',$)
12000 FORMAT (' There are no attenuators at present.')
12100 FORMAT (' The current attenuator coefficients are'/6F8.3)
12200 FORMAT (' Do you wish to change this (Y) ? ',$)
12300 FORMAT (' Type the new values ',$)
13000 FORMAT (' Type the Orientation Matrix on 3 lines.'/)
13100 FORMAT (' > ',$)
14000 FORMAT (' The current 2Theta, Omega, Chi and PHI zeroes are :--',
     $        /4F7.3/,
     $        ' Type the new values ',$)
15000 FORMAT (' Perform re-orientation during data collection (N) ? ',$)
15100 FORMAT (' Type the re-orientation frequency (500) ',$)
15200 FORMAT (' Type the re-orientation angular tolerance (0.1) ',$)
16000 FORMAT (' Measure reference reflections during data collection',
     $        ' (Y) ? ',$)
16100 FORMAT (' Type the measurement frequency (100) ',$)
19000 FORMAT (' Type up to 6 sets of h,k,l values.')
19100 FORMAT (' h,k,l > ',$)
21000 FORMAT (' Type 2Thetamin and 2Thetamax (',F4.1,F6.1,') ',$)
22000 FORMAT (' **WARNING** More than 500 profile points possible.'/
     $        ' Reduce either 2theta(max), or the scan parameters',
     $        ' AS and/or CS.')
24000 FORMAT (' You can keep the new matrix or retain the old one.'/
     $        ' Do you wish to keep the new matrix (Y) ? ',$)
25000 FORMAT (' Systematic Extinction Conditions'/
     $        ' Type the number of conditions ',$)
28000 FORMAT (' For each condition type the following :--'/
     $        ' A reflection class number 1 to 7,'/
     $        ' 1=00l  2=0k0  3=h00  4=0kl  5=h0l  6=hk0  7=hkl'/
     $        ' followed by the coefficients A to E of an equation'/
     $        '           Ah + Bk + Cl  =  Dn + E'/
     $        ' which is the condition for h,k,l to be present.')
30000 FORMAT (' Scan data : Scan type, As,Bs,Cs, Profile flag.'//
     $  ' Scan type: 0 2Theta,             1 Omega,'/
     $  '            2 2Theta precision,   3 Omega precision,'/
     $  '            4 2Theta peak top,    5 Omega peak top,'/
     $  '            6 2Theta econ. pktop, 7 Omega econ. pk top;'/
     $  ' Type the scan type (0) ',$)
30100 FORMAT (' Reflection width in degs is  As + Bs*tan(theta) + Cs'/
     $        ' Type the new As, Bs, Cs (',3F6.3,') ',$)
31000 FORMAT (' Profile flag   0/1  for DO/DONT-DO profile analysis.'/
     $        ' Type the flag (0) ',$)
C32000 FORMAT (' Bisecting (0) or Parallel (1) mode ',$)
33000 FORMAT (' Scan speed in deg/min 2theta or omega (4) ',$)
33500 FORMAT (' Scan step in deg (',F8.3,
     &   ') and Scan Preset (',F12.3,') ',
     &   $)
33100 FORMAT (' Horizontal aperture width in mms (',F4.1,') ',$)
33200 FORMAT (' Try -,-,- refln if high-angle scan problems (Y) ? ',$)
34000 FORMAT (' Fraction of A & C to step off for profile analysis',
     $        ' (0.5) ',$)
35000 FORMAT (' Time and Precision Parameters')
35900 FORMAT (' Type the peak-top measuring preset (1000.0) ',$)
36000 FORMAT (' Type the Background fraction (0.1) ',$)
37000 FORMAT (' Type Bkfrac,Qtime,PresetMax,Pa,Pm ',$)
37100 FORMAT (' Type the maximum preset/reflection (240) ',$)
37200 FORMAT (' Type the precision desired (0.02) ',$)
37300 FORMAT (' Type the minimum precision acceptable (0.10) ',$)
38000 FORMAT (' Max Counts, Sample & Max Time (secs) ',$)
40000 FORMAT (' Segment Data (DH Matrices)'/
     $        ' Type the number of segments ',$)
42000 FORMAT (' For each segment type the 12 integer values'/
     $        '  HOO KOO LOO D11 D21 D31 D12 D22 D32 D13 D23 D33')
44000 FORMAT (' B.Z. Limits for each segment'/
     $        ' JA,JB,JC,Jmin,Jmax ',$)
47000 FORMAT (' Psi Data: Dpsi,Psimin,Psimax')
49000 FORMAT (' First Reflection Data'/
     $        ' Type h,k,l for the reflection ',$)
52000 FORMAT (' Type the Reflection and Segment numbers ',$)
53000 FORMAT (' Type the Data record number ',$)
      END
C-----------------------------------------------------------------------
C Get the crystal system pointer for an absolute matrix
C-----------------------------------------------------------------------
      SUBROUTINE SYSPNT
      INCLUDE 'COMDIF'
      WRITE (COUT,10000)
      CALL GWRITE (ITP,' ')
      IF (LAUENO .NE. 0) THEN
        ISYS = LAUENO
        IF (LAUENO .GE.  4 .AND. LAUENO .LE.  5) ISYS = 4
        IF (LAUENO .GE.  6 .AND. LAUENO .LE.  7) ISYS = 6
        IF (LAUENO .GE.  8 .AND. LAUENO .LE. 12) ISYS = 5
        IF (LAUENO .GE. 13 .AND. LAUENO .LE. 14) ISYS = 7
      ELSE
        CALL SYSANG (AP,SANG,CANG,ISYS,KI)
      ENDIF
      ISYSAN = ISYS
      IF (ISYS .GT. 7) ISYS = 2
      WRITE (COUT,11000) ISYS
      CALL FREEFM (ITR)
      IF (IFREE(1) .NE. 0) ISYS = IFREE(1)
      IF (ISYS .EQ. 2) THEN
        IF (LAUENO .NE. 0) THEN
          ISYS = NAXIS + 7
        ELSE
          ISYS = ISYSAN
        ENDIF
      ENDIF
      CALL SINMAT
      RETURN
10000 FORMAT (' Select a number for the cell geometry to be used'/
     $        ' Triclinic    1     Monoclinic    2'/
     $        ' Orthorhombic 3     Tetragonal    4'/
     $        ' Hexagonal    5     Rhombohedral  6     Cubic  7')
11000 FORMAT (' Type your selection (',I1,') ',$)
      END
C-----------------------------------------------------------------------
C
C  Decide on the crystal system based on the cell-edges and angles
C  The routine looks for differences between cell-edges which are less
C  than a tolerance based on the cell-edge/500.0; and differnces
C  between 90.0 and the cell angles which are less than TOLANG
C  ICTE is the count of cell edges  which are equal within TOLIJ;
C  ICTA is the count of cell angles which are equal to 90 within TOLANG
C-----------------------------------------------------------------------
      SUBROUTINE SYSANG (ABC,SANG,CANG,ISYS,KI)
      DIMENSION ABC(3),SANG(3),CANG(3),ANG(3),
     $          DEIJ(3),DAI(3),TOLEI(3),TOLEIJ(3)
      CHARACTER KI*2
      RMULT = 1.0
      IF (KI .EQ. 'OP') RMULT = 3.0
      TOLANG = 0.1*RMULT
C-----------------------------------------------------------------------
C  Make the angles from their sines and cosines; the 90 differences DA,
C  and the cell-edge tolerances.
C-----------------------------------------------------------------------
      DO 100 I = 1,3
        ANG(I) = 57.2958*ATAN2(SANG(I),CANG(I))
        DAI(I) = ABS(90.0 - ANG(I))
        TOLEI(I) = ABC(I)/500.0
  100 CONTINUE
C-----------------------------------------------------------------------
C  Make the cell-edge differences and their tolerances
C-----------------------------------------------------------------------
      K = 0
      DO 110 I = 1,2
        DO 110 J = I+1,3
          K = K + 1
          DEIJ(K) = ABS(ABC(I) - ABC(J))
          TOLEIJ(K) = RMULT*SQRT(TOLEI(I)*TOLEI(I) + TOLEI(J)*TOLEI(J))
  110 CONTINUE
C-----------------------------------------------------------------------
C  Count the agreements etween cell-edges and angles
C-----------------------------------------------------------------------
      ICTE = 0
      ICTA = 0
      DO 120 I = 1,3
        IF (DEIJ(I) .LT. TOLEIJ(I)) ICTE = ICTE + 1
        IF (DAI(I)  .LT. TOLANG)    ICTA = ICTA + 1
  120 CONTINUE
C-----------------------------------------------------------------------
C  Set ISYS according to ICTE and ICTA
C-----------------------------------------------------------------------
      ISYS = 0
C-----------------------------------------------------------------------
C  ICTE = 0 and ICTA = 0 -- Triclinic
C-----------------------------------------------------------------------
      IF (ICTE .EQ. 0 .AND. ICTA .EQ. 0) ISYS = 1
C-----------------------------------------------------------------------
C  ICTE = 0 and ICTA = 2 -- Monoclinic
C-----------------------------------------------------------------------
  130 IF (ICTE .EQ. 0 .AND. ICTA .EQ. 2) THEN
        IF (DAI(1) .GT. TOLANG) ISYS =  8
        IF (DAI(2) .GT. TOLANG) ISYS =  9
        IF (DAI(3) .GT. TOLANG) ISYS = 10
      ENDIF
C-----------------------------------------------------------------------
C  ICTE = 0 and ICTA = 3 -- Orthorhombic
C-----------------------------------------------------------------------
      IF (ICTE .EQ. 0 .AND. ICTA .EQ. 3) ISYS = 3
C-----------------------------------------------------------------------
C  ICTE = 1 and ICTA = 3 -- Tetragonal
C-----------------------------------------------------------------------
      IF (ICTE .EQ. 1 .AND. ICTA .EQ. 3) ISYS = 4
C-----------------------------------------------------------------------
C  ICTE = 1 and ICTA = 2 -- Hexagonal (maybe monoclinic)
C-----------------------------------------------------------------------
      IF (ICTE .EQ. 1 .AND. ICTA .EQ. 2) THEN
        IF (ABS(120.0 - ANG(3)) .LT. TOLANG) THEN
          ISYS = 5
        ELSE
          ICTE = 0
          GO TO 130
        ENDIF
      ENDIF
C-----------------------------------------------------------------------
C  ICTE = 3 and ICTA = 0 -- Rhombohedral
C-----------------------------------------------------------------------
      IF (ICTE .EQ. 3 .AND. ICTA .EQ. 0) ISYS = 6
C-----------------------------------------------------------------------
C  ICTE = 3 and ICTA = 3 -- Cubic
C-----------------------------------------------------------------------
      IF (ICTE .EQ. 3 .AND. ICTA .EQ. 3) ISYS = 7
C-----------------------------------------------------------------------
C  Safety - just in case !
C-----------------------------------------------------------------------
      IF (ISYS .EQ. 0) ISYS = 1
      RETURN
      END
