C-----------------------------------------------------------------------
C         Routine to print intensity data from the IDATA file 
C
C  The data is listed on the terminal if KI = '2', or
C                             LPT     if KI = '3'.
C
C  For the BI command, the 25 reflections which are in the 2theta 
C  range and have the highest Inet/Sigma(Inet) are saved, sorted and 
C  printed.
C
C  2theta values are calculated from the R matrix in COMMON.
C-----------------------------------------------------------------------
      SUBROUTINE PRNINT
      INCLUDE 'COMDIF'
      PARAMETER (NSIG = 50)
      DIMENSION VEC(3),ENREFB(10),
     $          IHSIG(NSIG),IKSIG(NSIG),ILSIG(NSIG),
     $          INSIG(NSIG),RDSIG(NSIG),THSIG(NSIG)
C      EQUIVALENCE (ACOUNT(  1),IHSIG(1)),(ACOUNT( 51),IKSIG(1)),
C     $            (ACOUNT(101),ILSIG(1)),(ACOUNT(151),INSIG(1)),
C     $            (ACOUNT(201),RDSIG(1)),(ACOUNT(251),THSIG(1)),
C     $            (NREFB(1),ENREFB(1))
      DATA MOST/25/
      IF (KI .EQ. 'BI') THEN
        WRITE (COUT,10000) MOST
        CALL YESNO ('Y',ANS)
        IF (ANS .EQ. 'N') THEN
          KI = ' '
          RETURN
        ENDIF
      ENDIF
      IP = 0
      IF (KI .EQ. '2') IOUT = ITP
      IF (KI .EQ. '3') IOUT = LPT
      NSAVE = NBLOCK
      IF (NATTEN .GT. 0 .AND. KI .NE. 'BI') THEN
        DO 100 I = 1,NATTEN+1
          J = I - 1
          WRITE (COUT,12000) J,ATTEN(I)
          CALL GWRITE (IOUT,' ')
  100   CONTINUE
      ENDIF
      IF (KI .EQ.'BI') THEN
        WRITE (COUT,13000)
        SIGMIN = 100000.0
      ELSE
        WRITE (COUT,14000)
      ENDIF
      CALL FREEFM (ITR)
      TPMIN = RFREE(1)
      TPMAX = RFREE(2)
      SIGRAT = RFREE(3)
      IRRFLG = 0
      IF (TPMIN .EQ. 0 .AND. TPMAX .EQ. 0) THEN
        TPMIN = THEMIN
        TPMAX = THEMAX
        SIGRAT = -100000.0
        IRRFLG = 1
      ENDIF
      CALL LENFIL (IID,LASTBL)
  110 WRITE (COUT,15000) LASTBL
      CALL FREEFM (ITR)
      NBEGIN = IFREE(1)
      IF (NBEGIN .LT. 20) NBEGIN = 20
      NEND   = IFREE(2)
      IF (NEND .EQ. 0) NEND = NBEGIN
      IF (NEND .GT. LASTBL) NEND = LASTBL
      IALL = 0
      IF (NEND .EQ. LASTBL) IALL = 1
      IF (KI .EQ. 'BI') WRITE (LPT,17000)
      NBLOCK = NBEGIN
      ISAVE = 0
C-----------------------------------------------------------------------
C  Read the specified blocks of intensity data
C-----------------------------------------------------------------------
      DO 150 J = NBEGIN,NEND
        READ (IID,REC=NBLOCK) 
     $         IHK,ILA,BCOUNT,BBGR1,BBGR2,BTIME,ENREFB,BPSI
        NBLOCK = NBLOCK + 1
C-----------------------------------------------------------------------
C Unpack indices and NATT
C-----------------------------------------------------------------------
        DO 140 NB = 1,10
          ITEMP = IHK(NB)/1000
          IH = ITEMP - 500
          IK = IHK(NB) - 500 - 1000*ITEMP
          ITEMP = ILA(NB)/1000
          IL = ITEMP - 500
          IA = ILA(NB) - 1000*ITEMP
          IF (IH .EQ. 99) THEN
            THET2 = 0.0
            GO TO 140
          ENDIF
C-----------------------------------------------------------------------
C Calculate the 2theta value
C-----------------------------------------------------------------------
          SUM = 0.0
          DO 120 I = 1,3
            VEC(I) = R(I,1)*IH + R(I,2)*IK + R(I,3)*IL
            SUM = SUM + VEC(I)*VEC(I)
  120     CONTINUE
          SINSQ = 0.25*SUM
          IF (SINSQ .GE. 1.0) THEN
            NBLOCK = NBLOCK - 1
            WRITE (COUT,17100) NBLOCK,IH,IK,IL
            CALL GWRITE (ITP,' ')
            GO TO 110
          ENDIF
          THET2 = 2.0*DEG*ATAN(SQRT(SINSQ/(1.0 - SINSQ)))
          IF (KI .EQ. 'BI') THEN
            IF (THET2 .LT. TPMIN) GO TO 140
          ELSE
            IF (BPSI(NB) .LT. 900.0 .OR.
     $         (BPSI(NB) .GE. 900.0 .AND. IRRFLG .EQ. 0)) THEN
              IF (THET2 .LT. TPMIN .OR. THET2 .GT. TPMAX) GO TO 140
            ENDIF
          ENDIF
C-----------------------------------------------------------------------
C  Correct for Precision mode (ITYPE = 3 or 4)
C  Allow for Precision mode with Profile Analysis
C-----------------------------------------------------------------------
          RATIO = FRAC
          NTIMES = 1
          IF (ITYPE .EQ. 3 .OR. ITYPE .EQ. 4) THEN
            NTIMES = BTIME(NB)
            RATIO = FRAC
            IF (IPRFLG .EQ. 0) NTIMES = ENREFB(NB)
          ENDIF
          IF (ITYPE .EQ. 7 .OR. ITYPE .EQ. 8) THEN
            IRAT = BTIME(NB)
            RATIO = 1000*(BTIME(NB) - IRAT)/IRAT
          ENDIF
          IF (IPRFLG .EQ. 0 .AND. BPSI(NB) .LT. 900) RATIO = BTIME(NB)
          RATIO = 1.0/(RATIO + RATIO)
          BAKGND = BBGR1(NB) + BBGR2(NB)
          INET = BCOUNT(NB) - RATIO*BAKGND
          RESD = INET/SQRT(BCOUNT(NB) + RATIO*RATIO*BAKGND)
          AT = ATTEN(IA+1)
          INET = AT*INET/NTIMES
          IF (KI .EQ. 'BI') THEN
            IF (BPSI(NB) .LT. 900.0) THEN
              IF (ISAVE .LT. NSIG) THEN
                ISAVE = ISAVE + 1
                IHSIG(ISAVE) = IH
                IKSIG(ISAVE) = IK
                ILSIG(ISAVE) = IL
                INSIG(ISAVE) = INET
                RDSIG(ISAVE) = RESD
                THSIG(ISAVE) = THET2
                IF (RESD .LT. SIGMIN) THEN
                  SIGMIN = RESD
                  IMIN = ISAVE
                ENDIF
              ELSE
                IF (RESD .GT. SIGMIN) THEN
                  IHSIG(IMIN) = IH
                  IKSIG(IMIN) = IK
                  ILSIG(IMIN) = IL
                  INSIG(IMIN) = INET
                  RDSIG(IMIN) = RESD
                  THSIG(IMIN) = THET2
                  SIGMIN = 100000.0
                  DO 130 I = 1,NSIG
                    IF (RDSIG(I) .LT. SIGMIN) THEN
                      SIGMIN = RDSIG(I)
                      IMIN = I
                    ENDIF
  130             CONTINUE
                ENDIF
              ENDIF
            ENDIF
            GO TO 140
          ENDIF
C-----------------------------------------------------------------------
C  Reflection data print for the PD command.
C  Sort out the reference reflections from the rest
C-----------------------------------------------------------------------
          IF (RESD .GE. SIGRAT) THEN
            IF (BPSI(NB) .LT. 900.0) THEN
              IF (IP .NE. 0) THEN
                IF (KI .EQ. '3') THEN
                  WRITE (COUT,18000)
                  CALL GWRITE (IOUT,' ')
                ENDIF
                IP = 0
              ENDIF
              WRITE (COUT,19000) IH,IK,IL,THET2,BTIME(NB),IA,
     $                           BBGR1(NB),BCOUNT(NB),BBGR2(NB),
     $                           BPSI(NB),INET,RESD
              CALL GWRITE (IOUT,' ')
            ELSE
              IP = 0
              DO 135 I = 1,NSTAN
                IF (IH .EQ. IHSTAN(I) .AND. 
     $              IK .EQ. IKSTAN(I) .AND.
     $              IL .EQ. ILSTAN(I)) IP = I - 1
  135         CONTINUE              
              IF (IP .EQ. 0) THEN
                IF (KI .EQ. '3') THEN
                  WRITE (COUT,18000)
                  CALL GWRITE (IOUT,' ')
                ENDIF
              ENDIF
              IP = IP + 1
              WRITE (COUT,20000) IP,IH,IK,IL,THET2,BTIME(NB),IA,
     $                           BBGR1(NB),BCOUNT(NB),BBGR2(NB),
     $                           INET,RESD
              CALL GWRITE (IOUT,' ')
            ENDIF
          ENDIF
  140   CONTINUE
  150 CONTINUE
C-----------------------------------------------------------------------
C  Sort and print for the BI command
C-----------------------------------------------------------------------
      IF (KI .EQ. 'BI') THEN
        CALL SORTIS (RDSIG(1),ISAVE,IHSIG(1),IKSIG(1),ILSIG(1),INSIG(1),
     $               THSIG(1))
        ISIG = MOST
        IF (ISAVE .LT. MOST) ISIG = ISAVE
        DO 160 I = 1,ISIG
          WRITE (LPT,21000) IHSIG(I),IKSIG(I),ILSIG(I),
     $                      THSIG(I),INSIG(I),RDSIG(I)
  160   CONTINUE
      ENDIF
      IF (IALL .EQ. 0) THEN
        IF (KI .EQ. 'BI') THEN
          WRITE (COUT,22000)
        ELSE
          WRITE (COUT,23000)
        ENDIF
        CALL YESNO ('N',ANS)
        IF (ANS .EQ. 'Y') GO TO 110
      ENDIF
      NBLOCK = NSAVE
      KI = ' '
      RETURN
10000 FORMAT (' Search for the',I3,' biggest Inet/Sigma(Inet) (Y) ? ',$)
12000 FORMAT (5X,' Attenuator(',I1,') ',F7.2)
13000 FORMAT (' Type 2thetamin ',$)
14000 FORMAT (/' Reflns can be selected on 2theta and Inet/Sig(Inet)'/
     $        ' Type 2thetamin, 2thetamax and min(I/sigI)',
     $        ' (All Reflns)  ',$)
15000 FORMAT (' Intensity data is in records 20 to',I5/
     $        ' Type the range of records to be examined  ',$)
16000 FORMAT (/' Records',I4,' to',I4,' will be used.')
17000 FORMAT ('     h   k   l  2Theta    Inet  I/SigI')
17100 FORMAT (3I4,' in record',I5,' is incompatible with',
     $        ' the current orientation matrix.'/
     $        ' Please try again.')
18000 FORMAT ('%')
19000 FORMAT (3X,   3(I3,1X),2(F7.3,1X),I1,F5.0,F7.0,F5.0,F8.3,I8,F8.2)
20000 FORMAT (2X,I1,3(I3,1X),2(F7.3,1X),I1,F5.0,F7.0,F5.0,8X,I8,F8.2)
21000 FORMAT (3X,3(I3,1X),F7.2,I8,F8.2)
22000 FORMAT (' Do you want to search more records (N) ? ',$)
23000 FORMAT (' Do you want to print more records (N) ? ',$)
      END
C-----------------------------------------------------------------------
C  Sort the largest Inet/Sigma(Inet) values
C-----------------------------------------------------------------------
      SUBROUTINE SORTIS (RIOS,MOST,LH,LK,LL,LI,RT)
      DIMENSION RIOS(1), LH(1), LK(1), LL(1), LI(1), RT(1)
      M = 2
  100 INTVL = MOST/M
      IF (INTVL .EQ. 0) INTVL = 1
      IFIN = MOST - INTVL
  110 MARK = 0
      DO 120 I = 1,IFIN
        J = I+INTVL
        IF (RIOS(I) .LT. RIOS(J)) THEN
          TEMP    = RIOS(I)
          RIOS(I) = RIOS(J)
          RIOS(J) = TEMP
          ITEM  = LH(I)
          LH(I) = LH(J)
          LH(J) = ITEM
          ITEM  = LK(I)
          LK(I) = LK(J)
          LK(J) = ITEM
          ITEM  = LL(I)
          LL(I) = LL(J)
          LL(J) = ITEM
          ITEM  = LI(I)
          LI(I) = LI(J)
          LI(J) = ITEM
          TEMP  = RT(I)
          RT(I) = RT(J)
          RT(J) = TEMP
          MARK = 1
        ENDIF
  120 CONTINUE
      IF (MARK .EQ. 1) GO TO 110
      IF (INTVL .NE. 1) THEN 
        M = 2*M
        GO TO 100
      ENDIF
      RETURN
      END
C-----------------------------------------------------------------------
C  Subroutine to find the length of a direct-access file
C-----------------------------------------------------------------------
      SUBROUTINE LENFIL (IUNIT,LASTBL)
      DIMENSION ISTEP(4)
      DATA ISTEP/1000,100,10,1/
      NRSAVE = 0
      DO 120 I = 1,4
        IDEL = ISTEP(I)
        NOFF = NRSAVE
        N1 =  1
        N2 = 10
        IF (I .EQ. 1) N2 = 1000
        DO 100 N = N1,N2
          NREC = NOFF + N*IDEL
          READ (IUNIT, REC = NREC, IOSTAT = IERR) RJUNK
          IF (IERR .NE. 0) GO TO 110
          NRSAVE = NREC
  100   CONTINUE
  110   IF (I .EQ. 4) THEN
          LASTBL = NREC - 1
          RETURN
        ENDIF
  120 CONTINUE
      END
C-----------------------------------------------------------------------
C
C  Convert the intensity data on the direct-access IDATA.DA file, into 
C  a formatted ASCII file suitable for transmission to or processing by 
C  other computers.
C
C  The contents and format of the ASCII file are :--
C       h,k,l, Ia, Ib1, Ipeak, Ib2, Time, Nref, Ipsi
C      ( 3I4,  I2,  I6,   I7,   I6, F9.5,   I6,   I5)  where
C    Ia    is the attenuator index  (0 to 5),
C    Ib1   is the low angle background,
C    Ipeak is the total peak count,
C    Ib2   is the high angle background,
C    Time  is (time for 1 background) / (Time for peak),  i.e. FRAC
C          for normal scans, or
C          10*number of scans + FRAC for controlled precision modes,
C    Nref  is the reflection sequence number,
C    Ipsi  is the psi value, usually 0, 999 for standards.
C    
C-----------------------------------------------------------------------
      SUBROUTINE IDTOAS
      INCLUDE 'COMDIF'
      DIMENSION ENREFB(10)
      EQUIVALENCE(NREFB(1),ENREFB(1))
      CHARACTER FILEF*40,DEFNAM*10,MORE
      DEFNAM = 'IDATA.ASC '
C-----------------------------------------------------------------------
C  Print the header and connect the file IFM, the formatted ASCII file
C-----------------------------------------------------------------------
      IFM = IOUNIT(9)
  100 WRITE (COUT,10000) DEFNAM
      FILEF(1:10) = 'DONT DO IT'
      CALL ALFNUM (FILEF)
      IF (FILEF .EQ. ' ') FILEF = DEFNAM//' '
      CALL IBMFIL (FILEF,IFM,IBMREC,'SU',IERR)
      IF (IERR .NE. 0) GO TO 100
C-----------------------------------------------------------------------
C  Find the intensity data record numbers to process
C-----------------------------------------------------------------------
      CALL LENFIL (IID,LASTBL)
      WRITE (COUT,11000) LASTBL
      CALL YESNO ('Y',ANS)
  110 IF (ANS .EQ. 'Y') THEN
        ILAST = 1
        NBEGIN = 20
        NEND = LASTBL
      ELSE
        WRITE (COUT,12000)
        CALL FREEFM (ITR)
        NBEGIN = IFREE(1)
        NEND = IFREE(2)
        IF (NEND .EQ. 0) NEND = NBEGIN
        ILAST = 0
        IF (NEND .EQ. LASTBL) ILAST = 1
      ENDIF
C-----------------------------------------------------------------------
C  Write the data needed by DATRD2 etc from record 1
C-----------------------------------------------------------------------
      WRITE (IFM,12900) THEMAX,DFTYPE,DFMODL,FRAC
C-----------------------------------------------------------------------
C  Process the valid data in the selected intensity data records
C-----------------------------------------------------------------------
      DO 130 I = NBEGIN,NEND
        READ (IID,REC = I) IHK,ILA,BCOUNT,BBGR1,BBGR2,BTIME,ENREFB,BPSI
        DO 120 J = 1,10
          IF (IHK(J) .NE. 599599) THEN
            IH = IHK(J)/1000 - 500
            IK = IHK(J) - 1000*(IH + 500) - 500
            IL = ILA(J)/1000 - 500
            IA = ILA(J) - 1000*(IL + 500)
            IB1   = BBGR1(J)
            IPEAK = BCOUNT(J)
            IB2   = BBGR2(J)
            TIME  = BTIME(J)
            NREF  = ENREFB(J)
            IPSI  = BPSI(J)
            WRITE (IFM,13000) IH,IK,IL,IA,IB1,IPEAK,IB2,TIME,NREF,IPSI
          ENDIF
  120   CONTINUE
  130 CONTINUE
C-----------------------------------------------------------------------
C  Any more to processing ?
C-----------------------------------------------------------------------
      IF (ILAST .EQ. 0) THEN
        WRITE (COUT,14000)
        CALL YESNO ('N',MORE)
        IF (MORE .EQ. 'Y') GO TO 110
      ENDIF
      CALL IBMFIL (FILEF,-IFM,IBMREC,'SU',IERR)
      KI = ' '
      RETURN
10000 FORMAT (/10X,'Convert the IDATA File to ASCII'/
     $        ' Type the Output ASCII Filename (',A,') ',$)
11000 FORMAT (' Valid data is in records 20 to',I5,'. Transform it all',
     $        ' (Y) ? ',$)
12000 FORMAT (' Type the First and Last record to be transferred ',$)
12900 FORMAT (F8.3,1X,2A4,F8.4)
13000 FORMAT (3I4,I2,I6,I7,I6,F9.5,I6,I5)
14000 FORMAT (' Do you wish to transfer more records (N) ? ',$)
      END
