C-----------------------------------------------------------------------
C  Subroutine to find peak limits in the profile
C-----------------------------------------------------------------------
      SUBROUTINE PROFIL
      INCLUDE 'COMDIF'
      DIMENSION SMOOTH(500),IHTAGS(4),ID(500)
C-----------------------------------------------------------------------
C
C   Explanation of symbols used for Profile Analysis
C
C    PLIM       Probability lower limit.  Arbitrarily 0.01
C    A12        Ratio of Int(alpha1)/Int(alpha2) (1.8)
C    NWIND      No. of profile points in the test window. (6)
C    IDEL       No. of pts in the profile + 1
C    COUNT      Sum of all profile points
C    FRAC       Ratio of 0.5*Background time/Peak time
C    SIGLIM     Inet significance limit
C    CON        No. of profile pts per degree scan (STEPDG).  This
C               gives a power of two steps for all speeds.
C    SPEED      Scan speed in degs per min.
C    D12        Alpha1 to Alpha2 seperation in degrees
C    ITYPE      Scan type indicator. 0 or 1 2Theta; 2 or 3 Omega
C    AS         Scan before Alpha1 in degrees
C    CS         Scan after  Alpha2 in degrees
C    ACOUNT(I)  Array of profile intensity values
C    IWARN      Warning flag from the measuring routine. 0 = OK.
C    IPRFLG     Profile analysis indicator. 0 = Do; 1 = Dont.
C    BGRD1      Low angle background, taken for FRAC*Peak-time
C    BGRD2      High angle background, as BGRD1.
C    RSW        PDP8E Read switch register routine.
C               RSW(N,J) Reads 1-bit switch N into J
C    STEPOF     Fraction of As (and Cs) to step off from Alpha1
C               (and Alpha2) before starting the profile analysis
C
C-----------------------------------------------------------------------
      DATA PLIM/0.01/,A12/1.8/
      IF ((IPRFLG .NE. 0 .AND. KI(1:1) .NE. 'G') .OR.
     $    IDEL .LT. 10) RETURN
C-----------------------------------------------------------------------
C  Results are sent to the printer for either :--
C    1. Individual measurements, i.e. not part of GO; or
C    2. Part of GO and Switch 4 is set to 1.
C-----------------------------------------------------------------------
      IF (KI(1:1) .EQ. 'G') THEN
        CALL RSW (4,ILPT)
      ELSE
        ILPT = 0
      ENDIF
      A1 = A12/(A12 + 1.0)
      A2 = 1.0 - A1
      NWIND = 6
      ILOW = 1
      NP = IDEL - 1
      IHIGH = NP
      SUM = COUNT
      FRAC1 = FRAC
      SIGLIM = 2.0
      CON = STEPDG
      RD12 = CON*D12
      IF (ITYPE .EQ. 2 .OR. ITYPE .EQ. 3) RD12 = RD12*0.5
      NXPTS = 1000.0/((AS + CS)*CON + RD12)
      ID12 = RD12 + 0.5
      ITOL = CON*(AS + CS)/8.0
      MAXI = 0
C-----------------------------------------------------------------------
C  Do not try to process peak top measurements
C-----------------------------------------------------------------------
      IF (ITYPE .GE. 4) RETURN
      CMAX = 0
      DO 100 I = 1,NP
        ACT = ACOUNT(I+1)
        IF (CMAX .LT. ACT) CMAX = ACT
  100 ACOUNT(I) = ACT
C-----------------------------------------------------------------------
C  Smooth the profile (5-point average)
C-----------------------------------------------------------------------
      SMOOTH(1) = (ACOUNT(1) + ACOUNT(2) + ACOUNT(3))/3.0
      SMOOTH(2) = (3.0*SMOOTH(1) + ACOUNT(4))/4.0
      DO 110 I = 3,NP-2
        SMOOTH(I) = (ACOUNT(I-2) + ACOUNT(I-1) + ACOUNT(I) +
     $               ACOUNT(I+1) + ACOUNT(I+2))/5.0
  110 CONTINUE
      SMOOTH(NP-1) = (SMOOTH(NP-2)*5 - ACOUNT(NP-4))/4.0
      SMOOTH(NP) = (4.0*SMOOTH(NP-1) - ACOUNT(NP-3))/3.0
C-----------------------------------------------------------------------
C  Test if peak is OK from MESINT or profile not needed
C-----------------------------------------------------------------------
      IF (IWARN .NE. 0) GO TO 240
C-----------------------------------------------------------------------
C  Work out Inet and sigma(Inet)
C-----------------------------------------------------------------------
      BTOT = (BGRD1 + BGRD2)/(FRAC + FRAC)
      BKN = BTOT/NP
      TOP = COUNT - BTOT
      BOT = SQRT(COUNT + BTOT/(FRAC + FRAC))
C-----------------------------------------------------------------------
C  If GO mode and no profile analysis print results for non-standards
C-----------------------------------------------------------------------
      IF (IPRFLG .NE. 0 .AND. KI(1:1) .EQ. 'G') THEN
        IF (ISTAN .EQ. 0) THEN
          ITOP = TOP + 0.5
          IBOT = BOT + 0.5
          IF (TOP .LE. SIGLIM*BOT) THEN
            IF (ILPT .EQ. 0) WRITE (LPT,10000)  IH,IK,IL,ITOP,IBOT,NREF
            WRITE (COUT,10000) IH,IK,IL,ITOP,IBOT,NREF
          ELSE
            IF (NATT .NE. 0) THEN
              IF (ILPT .EQ. 0) 
     $        WRITE (LPT,15100)  IH,IK,IL,NATT,ITOP,IBOT,NREF
              WRITE (COUT,15100) IH,IK,IL,NATT,ITOP,IBOT,NREF
            ELSE
              IF (ILPT .EQ. 0) 
     $        WRITE (LPT,15200)  IH,IK,IL,ITOP,IBOT,NREF
              WRITE (COUT,15200) IH,IK,IL,ITOP,IBOT,NREF
            ENDIF
          ENDIF
          CALL GWRITE (ITP,' ')
          GO TO 240
        ENDIF
      ENDIF
C-----------------------------------------------------------------------
C  Test if peak is considered significant and print if not
C-----------------------------------------------------------------------
      IF (TOP .LE. SIGLIM*BOT) IWARN = 1
      IF (IWARN .NE. 0) THEN
        ITOP = TOP + 0.5
        IBOT = BOT + 0.5
        IF (ILPT .EQ. 0) WRITE (LPT,10000) IH,IK,IL,ITOP,IBOT,NREF
        WRITE (COUT,10000) IH,IK,IL,ITOP,IBOT,NREF
        CALL GWRITE (ITP,' ')
      ENDIF
      IF (IWARN .NE. 0) GO TO 240
C-----------------------------------------------------------------------
C  Profile is OK and significant.  Print smoothed profile if Demo
C-----------------------------------------------------------------------
      IF (KI .EQ. 'DE') THEN
        WRITE (COUT,11000)
        CALL GWRITE (ITP,' ')
        WRITE (COUT,12000) (SMOOTH(J),J = 1,NP)
        CALL GWRITE (ITP,' ')
      ENDIF
C-----------------------------------------------------------------------
C  Test that there are no funny bumps in the profile, by ensuring that
C  the max of the peak is near the correct position.
C  MAXA is the calculated position of the alpha peak
C  MAXI is the intensity weighted maximum
C-----------------------------------------------------------------------
      MAXA = AS*CON + RD12*A2 + 0.5
      SUMI = 0
      SUMNI = 0
      DO 120 N = 1,NP
        D = SMOOTH(N) - BKN
        SUMI = SUMI + D
        SUMNI = SUMNI + N*D
  120 CONTINUE
      MAXI = 0.5 + SUMNI/SUMI
C-----------------------------------------------------------------------
C  Allow for a variable acceptance window
C-----------------------------------------------------------------------
      CALL RSW(8,I)
       ITOL =  5*I + ITOL
      CALL RSW(7,I)
       ITOL = 10*I + ITOL
      CALL RSW(6,I)
       ITOL = 20*I + ITOL
      IF (ABS(MAXI-MAXA) .GT. ITOL) THEN
        IF (TOP .GT. 2.0*SIGLIM*BOT) THEN
          IWARN = 2
          WRITE (COUT,14000) IH,IK,IL,MAXI,MAXA,BGRD1,COUNT,BGRD2
          CALL GWRITE (ITP,' ')
          IF (ILPT .EQ. 0) 
     $        WRITE (LPT,14000) IH,IK,IL,MAXI,MAXA,BGRD1,COUNT,BGRD2
        ELSE
          WRITE (COUT,14100) IH,IK,IL,MAXI,MAXA,BGRD1,COUNT,BGRD2
          CALL GWRITE (ITP,' ')
          IF (ILPT .EQ. 0) 
     $        WRITE (LPT,14100) IH,IK,IL,MAXI,MAXA,BGRD1,COUNT,BGRD2
        ENDIF
        GO TO 240
      ENDIF
C-----------------------------------------------------------------------
C  The profile is suitable for analysis to find the limits
C  J1 is the beginning of the low angle search
C  J2 is the beginning of the high angle search
C-----------------------------------------------------------------------
      J1 = MAXI - STEPOF*CON*AS - A2*ID12
      J2 = MAXI + STEPOF*CON*CS + A1*ID12
      IF (J1 .LE. NWIND .OR. J2 .GE. NP-NWIND) THEN
        ILOW = 1
        IHIGH = NP
        GO TO 210
      ENDIF
C-----------------------------------------------------------------------
C  Find the low angle limit by moving down from J1
C  Set the window width to 0.67*0.67*CNT/5
C  Find how many of the next NWIND values are in the window and if more
C  than half are in the window, switch on the detector PROB.
C-----------------------------------------------------------------------
      J = J1
      LIM = J - 1
      IFLAG = 0
      PROB = 1
      DO 160 I = NWIND,LIM
        CNT = SMOOTH(J)
        W = 0.08978*CNT
        SUM = 0
        DO 150 KK = J-NWIND,J-1
          DIFF = CNT - SMOOTH(KK)
          DC = DIFF*DIFF
          IF (DC .LT. W) SUM = SUM + 1
  150   CONTINUE
        IF (SUM .GE. NWIND/2) IFLAG = 1
        IF (IFLAG .NE. 0) THEN
           PROB = PROB*(NWIND - SUM)/NWIND
           IF (PROB .LE. PLIM) GO TO 170
        ENDIF
        J = J - 1
  160 CONTINUE
  170 ILOW = J-NWIND
      IF (ILOW .LE. 0) ILOW = 1
C-----------------------------------------------------------------------
C  Do the same for the high angle side
C-----------------------------------------------------------------------
      J = J2
      LIM = J + 1
      IFLAG = 0
      PROB = 1
      DO 190 I = LIM,IDEL-NWIND
        CNT = SMOOTH(J)
        W = 0.08978*CNT
        SUM = 0
        DO 180 KK = J+1,J+NWIND
          DIFF = CNT - SMOOTH(KK)
          DC = DIFF*DIFF
          IF (DC .LT. W) SUM = SUM + 1
  180   CONTINUE
        IF (SUM .GE. NWIND/2) IFLAG = 1
        IF (IFLAG .NE. 0) THEN
           PROB = PROB*(NWIND - SUM)/NWIND
           IF (PROB .LE. PLIM) GO TO 200
        ENDIF
        J = J + 1
  190 CONTINUE
  200 IHIGH = J + NWIND
      IF (IHIGH .GT. NP) IHIGH = NP
C-----------------------------------------------------------------------
C  Now work out the net count & esd for profile between
C  ILOW & IHIGH, using BGRD1 & BGRD2 plus pts between 1 to ILOW
C  and IHIGH to NP for the background
C  Revised EJG Aug 94 to allow for sloping backgrounds better
C-----------------------------------------------------------------------
  210 NPK = IHIGH - ILOW + 1
      B1 = BGRD1
      IF (ILOW .GT. 1) THEN
        DO 220 I = 1,ILOW-1
          B1 = B1 + ACOUNT(I)
  220   CONTINUE
      ENDIF
      FRAC1 = (FRAC*NP + ILOW - 1)/NPK
      PEAK = 0.0
      DO 225 I = ILOW,IHIGH
        PEAK = PEAK + ACOUNT(I)
  225 CONTINUE
      B2 = BGRD2
      IF (IHIGH .LT. NP) THEN
        DO 230 I = IHIGH+1,NP
          B2 = B2 + ACOUNT(I)
  230   CONTINUE
      ENDIF
      FRAC2 = (FRAC*NP + NP - IHIGH)/NPK
      BTOT = 0.5*(B1/FRAC1 + B2/FRAC2)
      TOP1 = PEAK - BTOT
      BOT1 = SQRT(PEAK + 0.25*(B1/(FRAC1*FRAC1) + B2/(FRAC2*FRAC2)))
      FRAC1 = 0.5*(FRAC1 + FRAC2)
      BGRD1 = BTOT*FRAC1
      SUM   = PEAK
      BGRD2 = BGRD1
C-----------------------------------------------------------------------
C  Print Inet and sigma(Inet) for non-standards in GO mode
C-----------------------------------------------------------------------
      IF (KI(1:1) .EQ. 'G' .AND. ISTAN .EQ. 0) THEN
        ITOP = TOP1 + 0.5
        IBOT = BOT1 + 0.5
        IF (TOP .LE. SIGLIM*BOT) THEN
          IF (ILPT .EQ. 0) WRITE (LPT,10000)  IH,IK,IL,ITOP,IBOT,NREF
          WRITE (COUT,10000) IH,IK,IL,ITOP,IBOT,NREF
        ELSE
          IF (NATT .NE. 0) THEN
            IF (ILPT .EQ. 0) 
     $      WRITE (LPT,15100)  IH,IK,IL,NATT,ITOP,IBOT,NREF
            WRITE (COUT,15100) IH,IK,IL,NATT,ITOP,IBOT,NREF
          ELSE
            IF (ILPT .EQ. 0) 
     $      WRITE (LPT,15200)  IH,IK,IL,ITOP,IBOT,NREF
            WRITE (COUT,15200) IH,IK,IL,ITOP,IBOT,NREF
          ENDIF
        ENDIF
        CALL GWRITE (ITP,' ')
      ENDIF
  240 CALL RSW(9,JSW)
      IF (JSW .NE. 0 .and. istan .ne. 0) CALL PRFWRT (NP)
C-----------------------------------------------------------------------
C  Prepare the profile for display on the c.r.t. if wanted
C  Code below here is not needed for profile analysis
C  The display is 10-bits * 10-bits
C  If this reflection is to be plotted, the scaling is done in the
C    display routine itself as the profile is developed.
C  If the last reflection is to be plotted, the scaling is done here
C    and an origin offset is added.  Scaling is to a max of 1000 in each
C    direction and the packing is 
C       4096*scaled-counts + scaled-width + 4096*1024
C  The marks are shifted by 100 points.
C
C SR 0 = 0 for normal display; = 1 for profile display
C-----------------------------------------------------------------------
      CALL RSW (1,I)
      IF (I .NE. 0) THEN
C-----------------------------------------------------------------------
C  SR 1 = 0 not this time; = 1 for last reflection
C-----------------------------------------------------------------------
        N = NXPTS
C-----------------------------------------------------------------------
C SR 2 = 0 for raw counts; = 1 for smoothed counts
C-----------------------------------------------------------------------
          CALL RSW (2,J)
C-----------------------------------------------------------------------
C  Insert marks at ILOW,IHIGH and ALPHA1 obs and calc positions
C-----------------------------------------------------------------------
        IHTAGS(1) = AS * CON
        IHTAGS(2) = AS * CON
        IF (IWARN .NE. 1) IHTAGS(1) = MAXI - A2*ID12  
        IHTAGS(3) = ILOW
        IHTAGS(4) = IHIGH
        IF (J .NE. 0) THEN
           CALL PTPREP (NP,SMOOTH,IHTAGS)
        ELSE
           CALL PTPREP (NP,ACOUNT,IHTAGS)
        ENDIF 
      ENDIF
      CALL RSW (3,J)
      IF (J .EQ. 1) THEN
C-----------------------------------------------------------------------
C  Dump the difference profile for Ladge
C-----------------------------------------------------------------------
C      ic = 0
C      do 1000 i = 1,np
C        j = acount(i) + 0.5
C        id(i) = j - ic
C        ic = j
C 1000 continue
C         WRITE (LPT,17100) (id(I),I=1,NP)
C17100 format (10(3x,z4))
         WRITE (LPT,17000) (acount(I),I=1,NP)
         WRITE (LPT,17000) (SMOOTH(I),I=1,NP)
      ENDIF 
      RETURN
10000 FORMAT (3I4,2X,I7,'(',I4,') ',I5,' **')
11000 FORMAT (/,' The Profile counts are:')
12000 FORMAT (1X,10F7.0)
14000 FORMAT (3I4,' Max Profile',I4,', Alpha',I5,3F7.0)
14100 FORMAT (3I4,' Max Profile',I4,', Alpha',I4,3F7.0,' Weak Peak')
15000 FORMAT (3I4,F5.0,F7.0,F5.0,3I4,5F7.0/1X,F5.0,F8.4,2F6.0)
15100 FORMAT (3I4,I2,I7,'(',I4,') ',I5)
15200 FORMAT (3I4,2X,I7,'(',I4,') ',I5)
17000 FORMAT (1X,10F7.0)
      END
C-----------------------------------------------------------------------
C  Write a profile on unit 7 (32 4-byte variables per record) :--
C  Each reflection is written as several records.
C  Record 1:
C     Bytes     Symbol                  Contents
C    1 to 12   IH IK IL       h, k, l   4 bytes each
C   13 to 16    NP2           number of pts in profile + 1000*std #
C   17 to 20    ILOW          the point number on the low angle side
C                             1 if no analysis
C   21 to 24    IHIGH         the point number on the high angle side
C                             NP if no analysis
C   25 to 28    FRAC1         b/P time ratio (0.1 if no analysis)
C   29 to 32    IB1           Low angle background
C   31 to 36    ICOUNT        Sum of all NP profile points
C   37 to 40    IB2           High angle background
C   41 to 28    44 profile points  - 32000   (2 bytes each)
C
C  Record 2 on:
C    1 to 128   64 profile points
C-----------------------------------------------------------------------
      SUBROUTINE PRFWRT (NP)
      INCLUDE 'COMDIF'
      INTEGER*2 IPTS(500)
      EQUIVALENCE (ACOUNT(501),IPTS(1))
      NP2 = NP2 + 1000*NN
      IB1    = BGRD1
      ICOUNT = COUNT
      IB2    = BGRD2
      NREC = (NP + 20 + 63)/64 - 1
      DO 100 I = 1,NP
        IPTS(I) = ACOUNT(I) - 32000
  100 CONTINUE
      IPR = IOUNIT(7)
      IDREC = 32*IBYLEN
      STATUS = 'DO'
      CALL IBMFIL (PRNAME, IPR,IDREC,STATUS,IERR)
      NPR = NPR + 1
      WRITE (IPR,REC=NPR) IH,IK,IL,NP2,ILOW,IHIGH,FRAC1,IB1,ICOUNT,IB2,
     $                   (IPTS(J),J=1,44)
      IF (NREC .NE. 0) THEN
        J1 = 45
        DO 110 I = 1,NREC
          J2 = J1 + 63
          NPR = NPR + 1
          WRITE (IPR,REC=NPR) (IPTS(J),J=J1,J2)
          J1 = J2 + 1
  110   CONTINUE
      ENDIF       
      CALL IBMFIL (PRNAME,-IPR,IDREC,STATUS,IERR)
      RETURN
      END
C-----------------------------------------------------------------------
C  Routine to write the binary stored profiles to an ASCII file
C  The format of the ASCII file for each reflection is :--
C  Line 1
C  h,k,l, Npts, Ilow, Ihigh, Frac, Ib1, Icount, Ib2
C     ( 3I4, 3I5, F8.5, I6, I7, I6)
C  NREC lines  of IPTS (10I6)
C-----------------------------------------------------------------------
      SUBROUTINE PROFAS
      INCLUDE 'COMDIF'
      DIMENSION JPTS(500)
      INTEGER*2 IPTS(500)
      CHARACTER ASPROF*40
      EQUIVALENCE (ACOUNT(501),IPTS(1)),(ACOUNT(1001),JPTS(1))
      IPR = IOUNIT(7)
      IDREC = 32*IBYLEN
      CALL IBMFIL (PRNAME, IPR,IDREC,'DO',IERR)
      IAS = IOUNIT(8)
      WRITE (COUT,10000)
      ASPROF = 'DONT DO IT'//' '
      CALL ALFNUM (ASPROF)
      IF (ASPROF .EQ. ' ') ASPROF = 'PROFL7.ASC'
      CALL IBMFIL (ASPROF, IAS,IDREC,'SU',IERR)
      NPR = 0
  100 NPR = NPR + 1
      READ (IPR,REC=NPR,IOSTAT=I) 
     $      IH,IK,IL,NP2,ILOW,IHIGH,FRAC,IB1,ICOUNT,IB2,(IPTS(J),J=1,52)
      IF (I .EQ. 0) THEN
        NP = NP2 - 1000*(NP2/1000)
        NREC = (NP + 20 + 63)/64 - 1
        IF (NREC .GT. 0) THEN
          J1 = 45
          DO 110 I = 1,NREC
            J2 = J1 + 63
            NPR = NPR + 1
            READ (IPR,REC=NPR) (IPTS(J),J=J1,J2)
            J1 = J2 + 1
  110     CONTINUE
        ENDIF
        DO 120 I = 1,NP
          JPTS(I) = IPTS(I) + 32000
  120   CONTINUE
        WRITE (IAS,11000) IH,IK,IL,NP2,ILOW,IHIGH,FRAC,IB1,ICOUNT,IB2
        WRITE (IAS,12000) (JPTS(I),I=1,NP)
        GO TO 100
      ENDIF
      CALL IBMFIL (PRNAME,-IPR,IDREC,'DO',IERR)
      CALL IBMFIL (ASPROF,-IAS,IDREC,'SU',IERR)
      KI = ' '
      RETURN
10000 FORMAT (' Type the name of the ASCII file (PROFL7.ASC) ',$)
11000 FORMAT (3I4,3I5,F8.5,I6,I7,I6)
12000 FORMAT (10I6)
      END
