C-----------------------------------------------------------------------
C  Subroutine for the following functions
C    1.  To set and measure a given hkl reflection  IR
C    2.  To set only a given hkl reflection         SR
C    3.  To measure only a given hkl reflection     IM
C    4.  To move the circles to given angles        SA (& ST,SO,SC,SP)
C    5.  Perform Psi scans                          IP
C-----------------------------------------------------------------------
      SUBROUTINE INDMES
      INCLUDE 'COMDIF'
      CHARACTER ITF*1,IT(NSIZE)*1,PSNAME*40
      REAL RW(3,3)
      NJREF = NREF
      NATT = 0
      PSI = 0.0
C-----------------------------------------------------------------------
C  Set up for the DE function
C-----------------------------------------------------------------------
      IF (KI .EQ. 'DE') THEN
        CALL HKLN (IH,IK,IL,NJREF)
        CALL ANGET (THETA,OMEGA,CHI,PHI)
        CALL MESRIT
        CALL ANGSET (THETA,OMEGA,CHI,PHI,0,ICOL)
        RETURN
      ENDIF
C-----------------------------------------------------------------------
C  Default values for IH,IK,IL and write the appropriate header
C-----------------------------------------------------------------------
      IH = 0
      IK = 0
      IL = 0
      NIREF = 0
      IF (KI .EQ. 'IR') THEN
         WRITE (COUT,10000)
         CALL GWRITE (ITP,' ')
      ENDIF
      IF (KI .EQ. 'IE') THEN
         WRITE (COUT,11000)
         CALL YESNO ('Y',ANS)
         IF (ANS .EQ. 'N') THEN
           KI = ' '
           RETURN
         ENDIF
      ENDIF
      IF (KI .EQ. 'SR') THEN
         WRITE (COUT,14000)
         CALL GWRITE (ITP,' ')
      ENDIF
      IF (KI .EQ. 'MS') THEN
         WRITE (COUT,14100)
         CALL GWRITE (ITP,' ')
      ENDIF
      IF (KI .EQ. 'IM') THEN
         WRITE (COUT,15000)
         CALL GWRITE (ITP,' ')
      ENDIF
      IF (KI .EQ. 'SA') THEN
         WRITE (COUT,24000)
         CALL GWRITE (ITP,'$')
      ENDIF
      IF (KI .EQ. 'ST') THEN
         WRITE (COUT,28000)
         CALL GWRITE (ITP,'$')
      ENDIF
      IF (KI .EQ. 'SO') THEN
         WRITE (COUT,29000)
         CALL GWRITE (ITP,'$')
      ENDIF
      IF (KI .EQ. 'SC') THEN
         WRITE (COUT,30000)
         CALL GWRITE (ITP,'$')
      ENDIF
      IF (KI .EQ. 'SP') THEN
         WRITE (COUT,31000)
         CALL GWRITE (ITP,'$')
      ENDIF
C-----------------------------------------------------------------------
C  The SA function angle input
C-----------------------------------------------------------------------
      IF (KI .EQ. 'SA') THEN
        CALL ANGET (THETA,OMEGA,CHI,PHI)
        CALL FREEFM (ITR)
        THETA = RFREE(1)
        OMEGA = RFREE(2)
        CHI   = RFREE(3)
        PHI   = RFREE(4)
        NJREF = -NJREF
        CALL SETIT (NJREF)
        RETURN
      ENDIF
C-----------------------------------------------------------------------
C  The ST, SO, SC, SP functions angle input
C-----------------------------------------------------------------------
      IF (KI .EQ. 'ST' .OR. KI .EQ. 'SO' .OR.
     $    KI .EQ. 'SC' .OR. KI .EQ. 'SP') THEN
        CALL ANGET (THETA,OMEGA,CHI,PHI)
        CALL FREEFM (ITR)
        IF (KI .EQ. 'ST' )THETA = RFREE(1)
        IF (KI .EQ. 'SO') OMEGA = RFREE(1)
        IF (KI .EQ. 'SC') CHI   = RFREE(1)
        IF (KI .EQ. 'SP') PHI   = RFREE(1)
        NJREF = -NJREF
        CALL SETIT (NJREF)
        RETURN
      ENDIF
C-----------------------------------------------------------------------
C  Only the IM, IR, IE and SR functions are left at this point.  Do IM.
C-----------------------------------------------------------------------
      IF (KI .EQ. 'IM' ) THEN
        WRITE (COUT,13000)
        CALL FREEFM (ITR)
        IH = IFREE(1)
        IK = IFREE(2)
        IL = IFREE(3)
        CALL HKLN (IH,IK,IL, NJREF)
        CALL ANGET (THETA,OMEGA,CHI,PHI)
        CALL MESRIT
        CALL ANGSET (THETA,OMEGA,CHI,PHI,0,ICC)
        KI = ' '
        RETURN
      ENDIF
C-----------------------------------------------------------------------
C  Input instruction for the IE function
C-----------------------------------------------------------------------
      IOUT = -1
      IF (KI .EQ. 'IE') THEN
        CALL SPACEG (IOUT,0)
        WRITE (COUT,17000)
      ENDIF
C-----------------------------------------------------------------------
C  Input instruction for the SR AND IR functions
C-----------------------------------------------------------------------
      IF (KI .EQ. 'SR' .OR. KI .EQ. 'MS') THEN
        WRITE (COUT,18000)
      ENDIF
      IF (KI .EQ. 'IR') THEN
        IF (SGSYMB(1) .EQ. 0.0 .AND. SGSYMB(2) .EQ. 0.0)
     $      CALL SPACEG (IOUT,0)
        WRITE (COUT,16000)
      ENDIF
C-----------------------------------------------------------------------
C  Set up the IP instruction and CURVES.DAT
C-----------------------------------------------------------------------
      IF (KI .EQ. 'IP') THEN
        WRITE (COUT,33000)
        IIP = LPT
        CALL YESNO ('Y',ANS)
        IF (ANS .EQ. 'Y') THEN
           IIP = IOUNIT(8)
           PSNAME = 'CURVES.DAT'
           CALL IBMFIL (PSNAME,IIP,80,'US',IERR)
           WRITE (IIP,34000) WAVE
           DO 100 I = 1,3
              DO 110 J = 1,3
                 RW(I,J) = R(I,J)/WAVE
  110         CONTINUE
              WRITE (IIP,35000) (RW(I,J),J=1,3)
  100      CONTINUE
        ENDIF
        DPSI = 10
        PSIMIN = 0.0
        PSIMAX = 360.0
        WRITE (COUT,17000)
      ENDIF
      CALL GWRITE (ITP,' ')
C-----------------------------------------------------------------------
C  Interpret the free-form input for SR, IR and IE
C-----------------------------------------------------------------------
  150 WRITE (COUT,32000)
      CALL ALFNUM (OCHAR)
      DO 160 J = 1,100
        I = 101 - J
        ANS = OCHAR(I:I)
        IF (ANS .NE. ' ') THEN
          ITF = '+'
          IF (ANS .EQ. '-') ITF = '-'
          IF (ANS .EQ. '-' .OR. ANS .EQ. '+') OCHAR(I:I) = ' '
          GO TO 170
        ENDIF
  160 CONTINUE
  170 CALL FREEFM (1000)
      IH = IFREE(1)
      IK = IFREE(2)
      IL = IFREE(3)
C-----------------------------------------------------------------------
C  SR Function - Set the display and then the reflection
C  MS Function for the CAD4 only
C-----------------------------------------------------------------------
      IF (KI .EQ. 'SR' .OR. KI .EQ. 'MS') THEN
        CALL HKLN (IH,IK,IL,NJREF)
        ISTAN = 0
        DPSISV = DPSI
        DPSI = 180.
        IPRVAL = 1
        CALL ANGCAL
        DPSI = DPSISV
        IF (IVALID .EQ. 32) THEN
          KI = ' '
          RETURN
        ENDIF
        IF (IVALID .NE. 0) THEN
          WRITE (COUT,19000)
          CALL YESNO ('N',ANS)
          IF (ANS .EQ. 'N') THEN
            KI = ' '
            RETURN
          ENDIF
        ENDIF
        IF (KI .EQ. 'MS') OMEGA = OMEGA + 90.0 - 0.5*THETA
        IF (ITF .EQ. '-') THETA = 360.0 - THETA
        CALL SETIT (NJREF)
        RETURN
      ENDIF
C-----------------------------------------------------------------------
C  Store the h,k,l values for the IR and IE functions
C-----------------------------------------------------------------------
      IF (IH .NE. 0 .OR. IK .NE. 0 .OR. IL .NE. 0) THEN
        ILIST = 0
        IF (KI .EQ. 'IE') ILIST = 1
        IPRVAL = 1
        CALL ANGCAL
        IF (IVALID .EQ. 32) GO TO 150
        IF (IVALID .NE. 0) THEN
          WRITE (COUT,19100)
          CALL YESNO ('N',ANS)
          IF (ANS .EQ. 'N') GO TO 150
        ENDIF
        CALL DEQHKL (NHKL,ILIST)
        NIREF = NIREF + 1
        IOH(NIREF) = IH
        IOK(NIREF) = IK
        IOL(NIREF) = IL
        IT(NIREF) = ITF
        IF (NIREF .EQ. NSIZE) THEN
          WRITE (COUT,18500)
          CALL GWRITE (ITP,' ')
          GO TO 180
        ENDIF
        GO TO 150
      ENDIF
C-----------------------------------------------------------------------
C  IR and IE Functions
C-----------------------------------------------------------------------
  180 DO 220 I = 1,NIREF
        IH = IOH(I)
        IK = IOK(I)
        IL = IOL(I)
        ITF = IT(I)
        JHKL(1,1) = IH
        JHKL(2,1) = IK
        JHKL(3,1) = IL
        NHKL = 1
        ILIST = 0
        IPRVAL = 0
        IF (KI .EQ. 'IE') CALL DEQHKL (NHKL,ILIST)
        DO 210 J = 1,NHKL
          IH = JHKL(1,J)
          IK = JHKL(2,J)
          IL = JHKL(3,J)
          PSI = 0.0
C-----------------------------------------------------------------------
C  Set the display
C-----------------------------------------------------------------------
          CALL HKLN (IH,IK,IL,NJREF)
          ISTAN = 0
C-----------------------------------------------------------------------
C  Test if psi rotation is required
C-----------------------------------------------------------------------
          IF (ABS(DPSI) .GT. 0.0001) THEN
            TPSI = PSIMIN
            IF (TPSI .GE. 180.0) TPSI = TPSI - 360.0
            PSI  = PSIMIN
          ENDIF
C-----------------------------------------------------------------------
C  Calculate angles for given h,k,l and psi.  Why is Psi reversed ???
C       Psi has to be reversed for the absorp calculation to work
C       could have something to do with the handedness of the NRC
C       Picker.
C-----------------------------------------------------------------------
  200     PSISAV = PSI
          PSI = 360.0 - PSI
          IPRVAL = 0
          CALL ANGCAL
          IF (ITF .EQ. '-') THETA = 360.0 - THETA
          PSI = PSISAV
C-----------------------------------------------------------------------
C  If ANGCAL found rotation is possible set the circles and measure
C-----------------------------------------------------------------------
          IF (IROT .EQ. 0) THEN
            CALL MESRIT
          ELSE
            WRITE (COUT,25000) IH,IK,IL,PSI
            CALL GWRITE (ITP,' ')
          ENDIF
          CALL KORQ (KQFLAG)
          IF (KQFLAG .EQ. 1) THEN
C-----------------------------------------------------------------------
C  Increment the psi value for rotation
C-----------------------------------------------------------------------
            IF (ABS(DPSI) .GT. 0.0001) THEN
              TPSI = TPSI + DPSI
              PSI  =  PSI + DPSI
              IF (PSI .GE. 360.0) PSI = PSI - 360.0
              IF (TPSI .LE. PSIMAX) GO TO 200
            ENDIF
          ENDIF
C-----------------------------------------------------------------------
C  Return circles to omega=0 and peak centre before exit
C-----------------------------------------------------------------------
          ICC = 0
          PSI = 0.0
          SDPSI = DPSI
          DPSI = 0.0
          IPRVAL = 0
          CALL ANGCAL
          IF (ITF .EQ. '-') THETA = 360.0 - THETA
          DPSI = SDPSI
          CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICC)
          IF (ICC .NE. 0)   THEN
            WRITE (COUT,26000)
            CALL GWRITE (ITP,' ')
            KI = ' '
            RETURN
          ENDIF
C          CALL KORQ (KQFLAG)
          IF (KQFLAG .NE. 1) THEN
            KI = ' '
            RETURN
          ENDIF
  210   CONTINUE
  220 CONTINUE
      IF (KI .EQ. 'IP') THEN
        IF (IIP .NE. LPT)
     $      CALL IBMFIL (PSNAME,-IIP,80,'US',IERR)
      ENDIF
      KI = ' '
      RETURN
10000 FORMAT (' Intensity Measurements for Individual Reflections')
11000 FORMAT (' Intensity Measurements for Equivalent Reflections',
     $        ' (Y) ? ',$)
13000 FORMAT (' Type h,k,l for label ',$)
14000 FORMAT (' Set One Reflection')
14100 FORMAT (' Set a Crystal Face for absorption measurements')
15000 FORMAT (' Measure the Reflection which is now in the Detector')
16000 FORMAT (' Type h,k,l and +/- 2Theta sense (+) for up to 50',
     $        ' reflections. CR = End.')
17000 FORMAT (' Type h,k,l for up to 50 reflections. CR = End.')
18000 FORMAT (' Type h,k,l and +/- 2theta sense (+) ',$)
18500 FORMAT (' No more reflections allowed.')
19000 FORMAT (' Do you want to set it anyway (N) ? ',$)
19100 FORMAT (' Do you want to measure it anyway (N) ? ',$)
20000 FORMAT (3I4,5F8.3)
24000 FORMAT (' Type 2Theta,Omega,Chi,Phi (0) ',$)
25000 FORMAT (3I4,' Rotation to Psi',F7.2,' is NOT possible.')
26000 FORMAT (' Setting Collision')
28000 FORMAT (' Type 2-Theta ',$)
29000 FORMAT (' Type Omega ',$)
30000 FORMAT (' Type Chi ',$)
31000 FORMAT (' Type Phi ',$)
32000 FORMAT (' Next h,k,l (End) > ',$)
33000 FORMAT (' Collect Psi scan data'/
     $        ' Do you want to write data to CURVES.DAT (Y) ? ')
34000 FORMAT (1X,F8.5)
35000 FORMAT (1X,3F10.6)
      END
C-----------------------------------------------------------------------
C  Measure the reflection
C-----------------------------------------------------------------------
      SUBROUTINE MESRIT
      INCLUDE 'COMDIF'
      ITIME = 1
      IF (ISCAN .EQ. 3 .OR.  ISCAN .EQ. 4) THEN
        CALL SAMMES (ITIME,ICC)
      ELSE
        CALL MESINT (IROFL,ICC)
      ENDIF
      IF (ICC .EQ. 2) THEN
        WRITE (COUT,10000)
        CALL GWRITE (ITP,' ')
        RETURN
      ENDIF
      CALL PROFIL
      IBGRD1 = BGRD1
      IBGRD2 = BGRD2
      ISUM   = SUM
      ICOUNT = COUNT
      ATT = ATTEN(NATT+1)
      IF (IPRFLG .EQ. 0) THEN
        if(FRAC1 .GT. 0.01) THEN
           PEAK = ATT*(SUM - 0.5*(BGRD1 + BGRD2)/FRAC1)
        ELSE
           PEAK = 0.
        END IF
        IPEAK  = PEAK
        IF (KI .EQ. 'DE') THEN
           WRITE (COUT,11000)
           CALL GWRITE (ITP,' ')
        ENDIF
        IF (LPT .NE. ITP)
     $  WRITE (LPT,12000) IH,IK,IL,THETA,FRAC1,NATT,
     $                    IBGRD1,ISUM,IBGRD2,PSI,IPEAK,ITIME
        WRITE (COUT,12000) IH,IK,IL,THETA,FRAC1,NATT,
     $                    IBGRD1,ISUM,IBGRD2,PSI,IPEAK,ITIME
        CALL GWRITE (ITP,' ')
      ELSE
        FFRAC = FRAC
        IF (ITYPE .EQ. 7 .OR. ITYPE .EQ. 8) THEN
          IP = PRESET
          BB = 1000*(PRESET - IP)
          FFRAC = BB/IP
        ENDIF
        PEAK = ATT*(COUNT - 0.5*(BGRD1 + BGRD2)/FFRAC)
        IPEAK  = PEAK
        IF (LPT .NE. ITP)
     $  WRITE (LPT,12000) IH,IK,IL,THETA,PRESET,NATT,
     $                    IBGRD1,ICOUNT,IBGRD2,PSI,IPEAK,ITIME
        WRITE (COUT,12000) IH,IK,IL,THETA,TIME,NATT,
     $                    IBGRD1,ICOUNT,IBGRD2,PSI,IPEAK,ITIME
        CALL GWRITE (ITP,' ')
      ENDIF
      IF (KI .EQ. 'IP') THEN
        WRITE (IIP,13000) IH,IK,IL,THETA,OMEGA,CHI,PHI,PSI,
     $                    IPEAK
      ENDIF
      RETURN
10000 FORMAT (' Scan Collision')
11000 FORMAT (/,3X, ' h   k   l   2-Theta Time',
     $            '   Att Bkg  Peak   Bkg   Psi  Inet ')
12000 FORMAT (3I4,F7.2,F7.3,1X,I1,I5,I7,I5,F7.2,I7,I4)
13000 FORMAT (3I4,5F8.2,I8)
      END
C-----------------------------------------------------------------------
C  Set the display and the circles
C-----------------------------------------------------------------------
      SUBROUTINE SETIT (NJREF)
      INCLUDE 'COMDIF'
      IF (NJREF .LT. 0) THEN
        RH = IH
        RK = IK
        RL = IL
        NJREF = -NJREF
      ELSE
        RH = RFREE(1)
        RK = RFREE(2)
        RL = RFREE(3)
      ENDIF
      IF (ABS(RH - IH) .GT. 0.0001 .OR.
     $    ABS(RK - IK) .GT. 0.0001 .OR.
     $    ABS(RL - IL) .GT. 0.0001) THEN
        WRITE (COUT,10100) RH,RK,RL,THETA,OMEGA,CHI,PHI,PSI
      ELSE
        WRITE (COUT,10000) IH,IK,IL,THETA,OMEGA,CHI,PHI,PSI
      ENDIF
      CALL GWRITE (ITP,' ')
      CALL HKLN (IH,IK,IL,NJREF)
      CALL ANGSET (THETA,OMEGA,CHI,PHI,NATT,ICC)
      IF (ICC .NE. 0) THEN
        WRITE (COUT,11000)
        CALL GWRITE (ITP,' ')
      ENDIF
      KI = ' '
      RETURN
10000 FORMAT (3I4,5F8.3)
10100 FORMAT (8F8.3)
11000 FORMAT (' Setting Collision')
      END
