C      *****************************************************************
C       *                                                *
C       *  This version of INTLAUE prepared for export 12/10/92.           *
C      *  The history is somewhat chequered but runs something         *
C      *  like this:                                          *
C      *            The basic framework still resembles the            *
C      * original Alan Wonacott MOSFLM which was implemented on the      *
C      * Daresbury VAX by Pella Machin and Trevor Greenhough in 1982   *
C      * (ref DL/CSE/TM23). This suite of programs was exported to UAB *
C      * (Alabama) by TJG in 1984 where a major rewrite to include       *
C      * profile fitting was performed. (J.A.C., 19,400-409, 1986).      *
C      * A further major rewrite for Laue films, begun by PAM and TJG  *
C      * in 1986, has been completed by TJG and Annette Shrive in 1988.*
C      * Further modifications for new BG determination and Overlap    *
C      * deconvolution and radial masks by AKS and TJG are included in *
C      * this version, as are image plate modifications by  TJG, AKS   *
C       * and Richard Denny (Keele). To the best of our knowledge      *
C      * accreditation and ownership now reside with T.J. Greenhough   *
C      * this program being maintained and distributed from Keele       *
C      * University to both individuals and Daresbury to then form a       *
C      * part of the Daresbury Laboratory Laue Software Suite.            *
C      *                                                *
C      *****************************************************************
c
C
C
C           SUBROUTINE TO SOLVE THE BG PLANES FOR THE
C                       CURRENT BIN OR SPOT.
C                     USING THE STANDARD AM MATRIX.
C
      SUBROUTINE ABCBCK( J, AM )
C
      INCLUDE 'comuab.finc'
      INCLUDE 'combck.finc'
      INCLUDE 'comprf.finc'
C
      REAL  AM(3,3), BM3
C
      BM3 = BO(J) + 20000.0
C
C-------BG PLANE COEFFICIENTS
C
      A(J) = BOP(J)*AM(1,1) + BOQ(J)*AM(1,2) + BM3*AM(1,3)
      BZ(J)= BOP(J)*AM(2,1) + BOQ(J)*AM(2,2) + BM3*AM(2,3)
      C(J) = BOP(J)*AM(3,1) + BOQ(J)*AM(3,2) + BM3*AM(3,3)
C
      NMBN = NMBIN + 1
      IF(J.EQ.NMBN)THEN
      if(change(j)) then
c
c ---- allow tilt variation based on BGCUT*100% change in od from 
c      centre to 10 pixels away. Increase this by 25% for safety.
c
            xydev = ((fcut*1.25)/10.0) * c(j)
            if(abs(a(j)).gt.xydev.or.abs(bz(j)).gt.xydev) then
                  intpro = 99999
            end if
      end if
      RETURN
        END IF
      if(.not.batch)write(6,3)
      WRITE(8,3)
3      FORMAT(/1X,'  NBIN     A        BZ          C    ')
      if(.not.batch)write(6,4)J, A(J), BZ(J), C(J)
      WRITE(8,4)J, A(J), BZ(J), C(J)
4      FORMAT(1X,I5,2F10.4,f11.4)
C
C--------------------------------- RESET CHANGE
C
      CHANGE(J) = .FALSE.
      RETURN
      END
C
      SUBROUTINE ALPHA
C
C
C      CALL QGALPH
      RETURN
      END
C
C           SUBROUTINE TO SET UP STANDARD AM MATRIX AND
C                           INVERT
C
C
      SUBROUTINE AM1BCK(jb)
C
      INCLUDE 'combck.finc'
      INCLUDE 'commaskl.finc'
C
      REAL  AM(3,3), BUF1(3), BUF2(3)
C
C
      j = 1
      if(streak) then
        j = jb
      end if
      AM(1,1) = BPP(j)
      AM(1,2) = BPQ(j)
      AM(1,3) = BP(j)
      AM(2,1) = BPQ(j)
      AM(2,2) = BQQ(j)
      AM(2,3) = BQ(j)
      AM(3,1) = BP(j)
      AM(3,2) = BQ(j)
      AM(3,3) = BN(j)
C
C------------- STORE STANDARD AM IN AMST
C
      DO 101 IK = 1,3
      DO 101 IJ = 1,3
101      AMST(IJ,IK) = AM(IJ,IK)
C
C-------INVERT AM
C
      CALL MINV(AM, 3, DET, BUF1, BUF2)
C
C-------------PUT INVERTED AM INTO AMPRO IN COMBCK
C
      DO 3 J=1,3
      DO 3 I=1,3
3      AMPRO(I,J) = AM(I,J)
C
      RETURN
      END
C
C
C           SUBROUTINE TO ADD IN A BG POINT OF VALUE
C         B AT X,Y (RELATIVE TO CENTRE) AND SET UP THE
C            AM MATRIX WHICH HOLDS FOR ALL SPOTS UNLESS
C              OFFBCK IS CALLED TO REMOVE A POINT.
C
C
      SUBROUTINE AMBCK(jb, P, Q)
C
      INCLUDE 'combck.finc'
      INCLUDE 'comprf.finc'
      INCLUDE 'commaskl.finc'
C
      INTEGER P, Q
C
      RP = FLOAT(P)
      RQ = FLOAT(Q)
      RPQ = RP * RQ
      RPP = RP * RP
      RQQ = RQ * RQ
C
C----------------------------SET UP STANDARD AM FOR ALL BINS
C
      ist = 1
      iend = numbin + 1
      if (streak) then
         ist = jb
         iend = jb
      end if
      DO 1 J=ist,iend
      BN(J) = BN(J) + 1
      BP(J) = BP(J) + P
      BQ(J) = BQ(J) + Q
      BPQ(J) = BPQ(J) +  RPQ
      BPP(J) = BPP(J) +  RPP
      BQQ(J) = BQQ(J) +  RQQ
1      CONTINUE
      RETURN
      END
C
C
C
C
C                      *********************************************
C                      *                                           *
C                      *        ****  SUBROUTINE AREAD   ****      *
C                      *                                           *
C                      *********************************************
C
C
C
C=============================================================
C
        SUBROUTINE AREAD(IBUF,ILEN,ICHAN)
        INTEGER*2 IBUF(ILEN)
        READ (ICHAN) IBUF
        RETURN
        END
C
C
C
C
C                      *********************************************
C                      *                                           *
C                      *        ****  SUBROUTINE AVSPOT ****       *
C                      *                                           *
C                      *********************************************
C
C
C
C=============================================================
C
C                      ******      AVSPOT     ******
C
C=============================================================
C
C
C
        SUBROUTINE AVSPOT
c
cRCD ...Image Plate logical
        common/iplate/image,mar,moldyn
        logical image,mar,moldyn
C
      INCLUDE 'comori.finc'
      INCLUDE 'compro.finc'
      INCLUDE 'comras.finc'
      INCLUDE 'comrep.finc'
      INCLUDE 'comuab.finc'
      INCLUDE 'comprf.finc'
C
C---------  Include SCN, RFS, MCS, SND for old SEND file
C
      INCLUDE 'comscn.finc'
      INCLUDE 'comrfs.finc'
      INCLUDE 'commcs.finc'
      INCLUDE 'comsnd.finc'
C
        COMMON/IOO/IOUT
        COMMON/SW/ISWTCH(10)
        REAL ASPOT(5),XSH(16),YSH(16),SUMPQ(6,0:15)
        INTEGER GENBUF(10),BUFSIZ,SVMASK(5000)
        INTEGER OD(5000)
        INTEGER*2 IBUF(4),KKREC,IPXX,IPYY
        INTEGER NSH(16),TABLE(0:255),IH(6),IHD(3,50)
        INTEGER LRAS(5)
        LOGICAL FULL,YES,LDUMP
        COMMON/PEL/IOD,BUF(5120),nextr
      integer*2 buf,iod
        DATA FATNO/2/
c         DATA IRANGE /-30,0,50,100,200,400,800,1600,3200/
        EQUIVALENCE (LRAS(1),NXX),(LRAS(2),NYY)
        EQUIVALENCE (IBUF(1),KKREC),(IBUF(2),IPXX),(IBUF(3),IPYY)
        EQUIVALENCE (ASPOT(1),SPOT),(ASPOT(2),BGND),(ASPOT(3),RMSBG)
        EQUIVALENCE (ASPOT(4),DELX),(ASPOT(5),DELY)
C
C
C-----------  FACTOR USED TO ADJUST SD. OF STRONG SPOTS
        DATA EFAC/4.0/
      if(.not.batch)write(6,8877)
      WRITE(IOUT,8877)
 8877   FORMAT(' ENTER AVSPOT')
      IDR = -1
        DO 35 I=3,5
   35   LRAS(I)=IRAS(I)
C
C
C-----  DETERMINE AVERAGE FULLY RECORDED SPOT FOR EACH EXPANDED
C-----  RASTER SIZE. CHECK FOR SATISFACTORY RASTER DIMENSIONS AND
C-----  SPOT CENTERING.
C
        IFAIL=0
        call ccpdpn(-4,'AVSPOT','UNKNOWN','U',0,ifail)
c         OPEN(UNIT=4,FILE='AVSPOT.DAT',STATUS='UNKNOWN',
c      1              FORM='UNFORMATTED')
        NECX=XCEN*FACT+0.5
        NECY=YCEN*FACT+0.5
        NXCUR=0
        NNY=0
        DO 200 I=1,NREF
        READ(3)klrec,LEN,IBUF
        CALL PREAD(BUF(1),LEN,3)
        KREC=KlREC
        IX=IPXX
        IY=IPYY
        NXX=IBYTE(IBUF,7)
        NYY=IBYTE(IBUF,8)
        NXY=NXX*NYY
        IF(NXY.GT.MAXR) WRITE(IOUT,4200) MAXR,NXX,NYY,NXY
        IF(NXY.GT.MAXR.and..not.batch)write(6,4200)MAXR,NXX,NYY,NXY
4200      FORMAT(' MEASUREMENT BOX LARGER THAN EXPECTED; MAXR=',I6/
     +         'NX=',I4,'NY=',I4,'NXY=',I4)
      if(.not.image)then
        NSIZ=(NXY+1)/2
      else
      nsiz=nxy
      endif
C
C--------------  READ ARRAY OF OD.S FOR EACH SPOT
C
        IF(KREC.LT.0) GOTO 200
        IF(NXX.EQ.NXCUR) GOTO 250
        IF(NNY.NE.0.and..not.batch)write(6,1600)NNY,NXCUR
        IF(NNY.NE.0)WRITE(IOUT,1600)NNY,NXCUR
 1600   FORMAT(/,' THERE ARE ',I5,' OVEREXPANDED SPOTS FOR BOX ',
     1               'WIDTH ',I5)
        NNY=0
C       IF(NXCUR.NE.0) WRITE(4) MASK
        IF(NXCUR.EQ.0)GOTO 205
C
C----------------- HERE WHEN CURRENT MASK IS COMPLETED
C
        DO 204 J=-15,15
        WRITE(4)(MASK(K,J),K=1,5000)
  204   CONTINUE
  205   CONTINUE
        DO 210 K=1,5000
        DO 210 J=-15,15
  210   MASK(K,J)=0
        NXCUR=NXX
  250   NY=(NYY-NYS)/2
        IF(NY.LE.15)GO TO 251
        NNY=NNY+1
        GO TO 200
  251   CONTINUE
        IF(IY.LT.NECY) NY=-NY
        MASK(1,NY)=NXX*256+NYY
C
C-------------------  SUM OD.S FOR GIVEN RASTER SIZE
C
        DO 230 K=1,NXY
        if(.not.image)then
        CALL CBYTE(K)
        else
        call ip_cbyte(k)
        endif
  230   MASK(K+1,NY)=MASK(K+1,NY)+abs(int(IOD))
  200   CONTINUE
        IF(NNY.NE.0.and..not.batch)write(6,1600)NNY,NXCUR
        IF(NNY.NE.0)WRITE(IOUT,1600)NNY,NXCUR
        DO 235 J=-15,15
        WRITE(4)(MASK(K,J),K=1,5000)
  235   CONTINUE
        REWIND 4
C
C-------------------  FORM AVGE. SPOT FOR EACH RASTER SIZE
C
        WRITE(IOUT,1300)
        if(.not.batch)write(6,1300)
 1300   FORMAT('  NX   NY  RMSBG  DELX  DELY')
  300   READ(4,END=350) OD
        IF(OD(1).EQ.0) GOTO 300
        NYY=MOD(OD(1),256)
        NXX=OD(1)/256
        NXY=NXX*NYY
        IF(NXY.GT.MAXR) WRITE(IOUT,4200) MAXR,NXX,NYY,NXY
        IF(NXY.GT.MAXR.and..not.batch)write(6,4200)MAXR,NXX,NYY,NXY
        IODMIN=32767
        IODMAX=0
        DO 310 J=2,NXY+1
        IODMIN=MIN0(IODMIN,OD(J))
  310   IODMAX=MAX0(IODMAX,OD(J))
        IODMIN=IODMIN
        SCALE=255./(IODMAX-IODMIN)
        IF(SCALE.GT.1.0) SCALE=1.0
        DO 320 J=2,NXY+1
  320   OD(J)=(OD(J)-IODMIN)*SCALE+0.5
        CALL SETMASK(MASK(1,1),LRAS)
        CALL SETSUMS(MASK(1,1),LRAS,SUMPQ(1,0))
        FULL=.TRUE.
        CALL INTEG(OD(2),LRAS,MASK(1,1),SUMPQ(1,0),ASPOT,IDR,FULL)
        DELX=DELX/FACT
        DELY=DELY/FACT
        WRITE(IOUT,3000) NXX,NYY,RMSBG,DELX,DELY
        if(.not.batch)write(6,3000)NXX,NYY,RMSBG,DELX,DELY
 3000   FORMAT(2I5,3F6.1)
        IF(XTEK) CALL NEWPG
        CALL RASPLOT(OD(2),NXX,NYY,MASK(1,1),-1)
        If(Ltek) CALL SCPAUS
        GOTO 300
  350   CLOSE (UNIT=4)
        CLOSE (UNIT=3)
        ifail=0
        call ccpdpn(-3,'MOSTEMP','OLD','U',0,ifail)
c         OPEN(UNIT=3,FILE='Mostemp',STATUS='OLD',
c      1  FORM='UNFORMATTED')
      RETURN
      END
C
C
C
C                      *********************************************
C                      *                                           *
C                      *        ****  SUBROUTINE AWRITE ****       *
C                      *                                           *
C                      *********************************************
C
C
C
C
        SUBROUTINE AWRITE(IBUF,ILEN,ICHAN)
        INTEGER*2 IBUF(ILEN)
        WRITE (ICHAN) IBUF
        RETURN
        END
C
      LOGICAL FUNCTION BATCH_MODE()
C
C PARAMETERS
C
C NONE
C
C SPECIFICATION STATEMENTS AND CODE
C ---------------------------------
C
      LOGICAL CCPONL
      BATCH_MODE=.NOT.CCPONL()
      RETURN
      END
C
      SUBROUTINE BEXPAN(A,IA,NXY)
C
C ***CONVEX VERSION***
C
      INTEGER*2 A(*)
      INTEGER IA(*)
      CALL CCPBYI(IA,A,NXY)
      RETURN
      END
C
      SUBROUTINE BPACK(N,IB,IV)
C
C ***CONVEX VERSION***
C
      INTEGER*2 IB(*)
      CALL CCPSTB(IV,IB,N)
      RETURN
      END
C
      BLOCK DATA BREPRT
c added by pdc 27/6/91 to solve compilation error in process.f and report.f
c which had illegal data statements for irange
      COMMON /REPRT/ NREF,NOFR,NOLO,MAXBSI,MINBSI,
     +IRANGE,IANAL,RATIO,AVSD,NEDGE,NBOX,NBZERO,
     +IBOXS,ITOTS,IPROS,NBAD,iprange
      INTEGER NREF,NOFR,MAXBSI,MINBSI
      INTEGER IRANGE(9),IANAL(10),iprange(9)
      REAL RATIO(10),AVSD(10)
      DATA IRANGE /-30,0,50,100,200,400,800,1600,3200/
      data iprange/-30,0,800,1600,3200,6400,12800,25600,51200/
c  For Cornell ips - 12 bits doesnt seem to need higher numbers
c      DATA IpRANGE /-30,0,50,100,200,400,800,1600,3200/
      END
C
      SUBROUTINE BSWAP(K1,K2,IP)
C
C ***CONVEX VERSION***
C
      COMMON/CPEL/CIB(14000)
      INTEGER*2 CIB
      COMMON/PEL/IBA,IB(5120),NEXTR
      INTEGER*2 IB, IBA
      CALL CCPMVB(CIB,IP,IB,K1,K2-K1+1)
      IP = IP + K2 - K1 + 1
      RETURN
      END
C
      SUBROUTINE CBPACK(I)
C
C ***CONVEX VERSION***
C
      COMMON/PEL/IBA,IB(5120),NEXTR
      INTEGER*2 IB, IBA
      COMMON/CPEL/CIB(14000)
      INTEGER*2 CIB
      II = IBA
      CALL CCPSTB(II,CIB,I)
      RETURN
      END
C
      SUBROUTINE CBYTE(I)
C
C ***CONVEX VERSION***
C
      COMMON/PEL/ IBA,IB(5120),NEXTR
      INTEGER*2 IB, IBA
      CALL CCPGTB(II,IB,I)
      IBA = II
      RETURN
      END
C
C
C
C                      *********************************************
C                      *                                           *
C                      *        ****  SUBROUTINE CENTRS ****       *
C                      *                                           *
C                      *********************************************
C
C
C
C=============================================================
C
C       ****  SUBROUTINE CENTRS  ****
C
C FINDS SPOTS SUITABLE FOR REFINEMENT OF FILM CENTRE,
C CRYSTAL TO FILM DISTANCE AND FILM ORIENTATION
C THE OBSERVED C. OF G. OF THESE SPOTS IS PASSED TO
C OVERLAY REFS
C    IM test changed to use Multiplets (IM = 0) in refinement
C Sept 17th 1986 T.J.G.
c
c##### Laue mods - many changes to base refinement on nodals
c     (with nodal index less than nodlim1)
C=============================================================
C
C
        SUBROUTINE CENTRS(REPEAT)
c
cRCD ...Image Plate logical
        common/iplate/image,mar,moldyn
        logical image,mar,moldyn
c
        COMMON/SW/ISWTCH(10),oneref,noref,tworef
        COMMON/IOO/IOUT
        COMMON/PEL/IBA,IJBA(5120),NREC
        COMMON/CPEL/IARR(14000)
        INTEGER*2 iba,ijba,iarr
        COMMON/THRESH/IAVOD,IMTHR,IMREF
C
      INCLUDE 'comori.finc'
      INCLUDE 'comras.finc'
      INCLUDE 'comscn.finc'
      INCLUDE 'comrfs.finc'
      INCLUDE 'commcs.finc'
      INCLUDE 'comuab.finc'
      INCLUDE 'comlaue.finc'
      INCLUDE 'commask.finc'
      INCLUDE 'commaskl.finc'
C
        LOGICAL REPEAT,AGAIN,YES,oneref,noref,tworef
      integer lras(5)
      INTEGER NREF,WTX,VLIMIT
c      integer buf(10)
c        EQUIVALENCE (BUF(1),IHMR),(BUF(3),JX),(BUF(4),JY)
        INTEGER HWX,HWY,INDF,INDL
        LOGICAL FULL
        INTEGER X(500),Y(500),IREC(500),SHX,SHY,PNTR(100)
        INTEGER IWX(500)
        DATA MAXBUF/5000/,LIMIT/2500/,VLIMIT/4000/
        MAXREF=60
C
C------------ IAVOD FROM 18 TO 28
C------------ AND 12 TO 20.  OCT 3 1984
C------------ INCLUDE CALL TO SIZRAS FOR NPK
C------------ OK SINCE ALL UNEXPANDED
C------------ AND CGFIND ATTEMPTS BG CORRECTION
C
C#####  LAUE MODS. THRESH TO 30
C
        CALL SIZRAS(IRAS,NPK,NBG)
        IF(REPEAT) GOTO 1
        IAVOD=30
      if(image) IAVOD = 60
        GOTO 2
1       IF(.NOT.VEE) GOTO 4
        IF(VEE.AND.REPEAT) IAVOD=20
C
2       CONTINUE
        IF(IMTHR.NE.0) GOTO 4
        IF(.not.tworef.and..not.batch)write(6,999)
999     FORMAT(/1X,'  ......wait for it.......',/)
        IF(tworef) WRITE(IOUT,1000)IAVOD
        If (Batch) goto 3
        IF(tworef.and..not.batch)write(6,1000)IAVOD
1000    FORMAT(/' INNER REF THRESHOLD SET AT [',I3,
     1    '] (ADD 20? FOR STRONG IMAGES): ',$)
3       IF(tworef) read(5,*) IAVOD
1001    FORMAT(I4)
        IF(IAVOD.EQ.0) then
            IAVOD = 30
            if(image) IAVOD = 60
      endif
        IF(tworef) WRITE(IOUT,1002) IAVOD
1002    FORMAT(1H+,I5)
4       CONTINUE
        IMTHR = 1
C
        AGAIN=.TRUE.
        ISEP=200/SCNSZ
        LASTY=0
        IDOV2=CTOFD*XTOFRA/2.0
        IF(.NOT.VEE.AND.REPEAT) GOTO 10
C
C--------------------- START MEASURING
C------------ READ FULL SPOTS FROM GENERATE FILE AND SORT
C
c##### laue mods
        JADD=0
c        J1=PCKIDX+2
c        J2=J1+TOSPT-1
5       JADD=JADD+1
        NREF=0
C
C------------------------------- START LOOP
C
c##### laue mods
c        DO 9 JREC=J1,J2,JADD
c        READ(1,REC=JREC) BUF
c
c        IR=IAND(IHMR,'17'O)
c        IF(IR.NE.0) GOTO 9
c        IM=IAND(IHMR,'360'O)
C
C******************************
C
C                 Changed Sept 17th 1986 for Laues.
C                Select those flagged as multiplets
C
C******************************
C
c##### laue mods - select nodal spots
      do 9 jj = 1,numnod,jadd
      jrec = nodpt(jj)
      ir = nodal(jrec)/8
      if(ir .gt. nodlim1) go to 9
      jx = xyge(1,jrec)
      jy = xyge(2,jrec)
c        IF(IM.eq.0) GOTO 9
        IF(IABS(JY).GT.LIMIT) GOTO 9
C
C-------- TEST FOR AREA CONTAINING UNEXPANDED SPOTS FOR VEE-FILMS.
C
        IF(VEE) GOTO 6
        IF(IABS(JX).GT.LIMIT) GOTO 9
        GOTO 8
6       IF(REPEAT) GOTO 7
        IF(IABS(JX).GT.VLIMIT) GOTO 9
        GOTO 8
7       IF(IABS(IABS(JX)-IDOV2).GT.LIMIT) GOTO 9
8       NREF=NREF+1
        IREC(NREF)=JREC
        XC=JX
        YC=JY
        CALL XYCALC(XCAL,YCAL,XC,YC)
        X(NREF)=ANINT(XCAL*FACT)
        Y(NREF)=ANINT(YCAL*FACT)
        IF(NREF.EQ.500) GOTO 5
9       CONTINUE
C
C----------------------------- END LOOP
C
        GOTO 12
C
C-----------------  USE EXISTING LIST OF REFINEMENT SPOTS
C
10      DO 11 I=1,NRS
        JREC=RRS(I)
        IREC(I)=JREC
c##### laue mods - take x,y values direct from common/laue
c        READ(1,REC=JREC) BUF
c        XC=JX
c        YC=JY
      xc = xyge(1,jrec)
      yc = xyge(2,jrec)
        CALL XYCALC(XCAL,YCAL,XC,YC)
        X(I)=ANINT(XCAL*FACT)
        Y(I)=ANINT(YCAL*FACT)
11      CONTINUE
        NREF=NRS
12      IF(tworef) WRITE(IOUT,1003) NREF
        IF(tworef.and..not.batch)write(6,1003)NREF
1003    FORMAT(/I6,' NODAL SPOTS TO BE MEASURED')
        CALL SORTDN3(NREF,X,Y,IREC)
        HWX=NXS/2
        HWY=NYS/2
        NXY=NXS*NYS
        MAXB=NXY+2
        if(.not.image)then
        MAXW=(MAXB+1)/2
        MAXB=2*MAXW
        else
        maxw=maxb
        endif
        MAXN=MAXBUF/MAXW
        IF(MAXN.GT.100) MAXN=100
        NRSOLD=NRS
13      NRS=0
        IF(VEE.AND.REPEAT) NRS=NRSOLD
        IHALF=(60+NRS)/2+2
        DO 14 I=1,NREF
14      IWX(I)=NXS
        ifail=0
        call ccpdpn(-24,'TEMPSPOT','UNKNOWN','U',0,ifail)
        INDF=1
        INDL=1
        IFRST=1
        ILAST=0
        FULL=.FALSE.
C
C---------- GET THE START OF THE RASTER FOR THE FIRST SPOT OR
C--------------------- FOR A SPOT AFTER A GAP
C
15      CONTINUE
        WTX=X(INDF)+HWX
        IBLK=WTX
C
C------------ TEST IF SORTED SPOT HAS TO BE INCLUDED IN
C-------------------------- THIS SCAN
C
16      IER=-1
        CALL RDBLK(2,IBLK,IJBA,NWORD,IER)
17      IF(INDL.EQ.NREF) GOTO 18
        IF(FULL) GOTO 18
        IF(WTX.GT.X(INDL+1)+HWX) GOTO 18
        INDL=INDL+1
        IF(INDL-INDF.EQ.MAXN-1) FULL=.TRUE.
        GOTO 17
C
C----------- GET RESULTS FROM THIS SCAN AND START THE NEXT ONE
C
18      WTX=WTX-1
        IBLK=IBLK-1
C
C------ STORE OPTICAL DENSITIES FOR ALL SPOTS INCLUDED IN THIS SCAN
C
        IF(INDL.LT.INDF) GOTO 21
        DO 20 J=INDF,INDL
        MJ=MOD(J-1,MAXN)
        NJ=MJ*MAXB
        MJ=MJ+1
        IY=Y(J)
        KMN=IY-HWY
        KMX=IY+HWY
        IF(J.NE.IFRST) GOTO 19
        MFRST=MOD(IFRST-1,MAXN)+1
c
c    *****************************************************
c    I THINK IREC(j) IS UNIMPORTANT HERE. CAUSES TROUBLE. SET TO 0
c    *****************************************************
c
        IARR((MFRST-1)*MAXW+1)=0
        IADDR=(MFRST-1)*MAXB
        PNTR(MFRST)=3
        IFRST=IFRST+1
19      IZZ=PNTR(MJ)+NJ
        if(.not.image)then
        CALL BSWAP(KMN,KMX,IZZ)
        else
        call ip_bswap(kmn,kmx,izz)
        endif
        PNTR(MJ)=IZZ-NJ
        IWX(J)=IWX(J)-1
20      CONTINUE
C
C------------------ CHECK IF ONE OR MORE SPOTS ARE FINISHED
C
21      CONTINUE
        IF(IWX(INDF).EQ.0) GOTO 22
        IF(INDF.LE.INDL) GOTO 16
        FULL=.FALSE.
        GOTO 15
22      IND=ILAST*MAXW+1
        if(.not.image)then
           ijunk=ind+1
        else
           ijunk=ind+2
        endif
      if(streak) then
        lras(1) = nxs
        lras(2) = nys
          do ir=3,5
        lras(ir) = iras(ir)
        end do
        call cgmask(iarr(ijunk),lras,-1,delx,dely,
     1                  x(indf),y(indf),sod)
        avod = sod
      else
          CALL CGFIND(IARR(ijunk),-1,NXS,NYS,DELX,DELY,SOD)
          AVOD=SOD/NPK
C
C------------REPLACE NXY BY NPK.  OCT 3 1984.
C------------AVOD=SOD/NXY
C
      end if
        IF(.NOT.VEE.AND.REPEAT) GOTO 23
C
C---------------UPPER THRESH FROM 60 TO 150.  OCT 3 1984
C
        if(.not.image)then
        IF((AVOD.LT.IAVOD).OR.(AVOD.GT.150)) GOTO 24
        else
        IF((AVOD.LT.IAVOD).OR.(AVOD.GT.40000)) GOTO 24
        endif
C
C------------------ SPOTS SEPERATED BY > 5 MM
C
        IF(IABS(Y(INDF)-LASTY).LT.ISEP) GOTO 24
C
C------------ LIMIT NUMBER OF SPOTS ON RHS OF FILM
C
        IF(NRS.GT.IHALF.AND.X(INDF).GT.XCEN*FACT) GOTO 24
        IF(NRS.EQ.MAXREF) GOTO 25
        IF(ISWTCH(1).EQ.0) GOTO 23
        CALL ODPLOT(IARR(ijunk),NXS,NYS,-1)
c @@   array iarr has irec on the front, read by chkras.
23      CALL AWRITE(IARR(ijunk-1),MAXW,24)
        SHX=DELX/FACT+0.5
        SHY=DELY/FACT+0.5
        NRS=NRS+1
        LASTY=Y(INDF)
        XRS(NRS)=(X(INDF)+DELX)/FACT+0.5
        YRS(NRS)=(Y(INDF)+DELY)/FACT+0.5
        RRS(NRS)=IREC(INDF)
24      ILAST=ILAST+1
        IF(ILAST.EQ.MAXN) ILAST=0
        INDF=INDF+1
        IF(INDF.LE.NREF) GOTO 21
25      CLOSE (UNIT=24)
        IF(VEE.AND.REPEAT)GO TO 26
        IF(NRS.GT.10) GOTO 28
        GO TO 27
26      IF(NRS-NRSOLD.GT.10)GO TO 28
27      CONTINUE
        IF(.NOT.AGAIN) GOTO 28
C
C--- INSUFFICIENT REFINEMENT SPOTS FOUND. REPEAT WITH LOWER THRESHOLD
C--- THRESHOLD REDUCED BY 0.2 TO COPE WITH WEAK DATA ON CEA FILMS
C------------------------ ALAN / GARRY 16/8/82
C
C--------------------  REPLACED AT 0.8.  OCT 3 1984
C-------------------      SPECIAL WIGGLER CASE
C
        IAVOD=0.8*IAVOD
        IF(tworef) WRITE(IOUT,1004) NRS
        IF(tworef.and..not.batch)write(6,1004)NRS
1004    FORMAT(' ONLY',I5,' SPOTS FOUND-REPEATING SEARCH')
        AGAIN=.FALSE.
        GOTO 13
28      CONTINUE
        RETURN
        END
C
C
C
C                      *********************************************
C                      *                                           *
C                      *        ****  SUBROUTINE CGFIND ****       *
C                      *                                           *
C                      *********************************************
C
C
C
        SUBROUTINE CGFIND(A,IDR,NX,NY,DELX,DELY,SOD)
c
cRCD ...Image Plate logical
        common/iplate/image,mar,moldyn
        logical image,mar,moldyn
c
        INTEGER P,Q,HX,HY
        INTEGER*2 A(*)
        dimension ia(5000)
        MINOD=65000
        NXY=NX*NY
        HX=NX/2
        HY=NY/2
        if(.not.image)then
        call bexpan(a,ia,nxy)
        else
        call ip_bexpan(a,ia,nxy)
        endif
        DO 1 I=1,NXY
1       IF(MINOD.GT.ia(i)) MINOD=ia(i)
        SX=0.0
        SY=0.0
        SOD=0.0
        IJ=1
        HX=HX*IDR
        DO 2 P=-HX,HX,IDR
        DO 2 Q=-HY,HY
        IBA=IA(IJ)-MINOD
        SX=SX+P*IBA
        SY=SY+Q*IBA
        SOD=SOD+IBA
        IJ=IJ+1
2       CONTINUE
        if(sod.ne.0) goto 3
        delx = 10
        dely = 10
        return
3       DELX=SX/SOD
        DELY=SY/SOD
        RETURN
        END
C
C
C
C
C                      *********************************************
C                      *                                           *
C                      *        ****  SUBROUTINE CGFIT   ****      *
C                      *                                           *
C                      *********************************************
C
C
C
C=============================================================
C
        SUBROUTINE CGFIT(RAS,IRAS,IDR,DELX,DELY,SPOT)
c
cRCD ...Image Plate logical
        common/iplate/image,mar,moldyn
        logical image,mar,moldyn
c
        INTEGER P,Q,HX,HY,IRAS(5),S,T
        INTEGER*2 RAS(*)
        DIMENSION IA(5000)
        REAL A(10)
        EQUIVALENCE (A(1),SPP),(A(2),SQQ),(A(3),SPOD)
        EQUIVALENCE (A(4),SQOD),(A(5),SOD),(A(6),TPP),(A(7),TQQ)
        EQUIVALENCE (A(8),TOD),(A(9),TPOD),(A(10),TQOD)
        LOGICAL P1,P2
        HX=IRAS(1)/2
        HY=IRAS(2)/2
        NEXP=(2*HX+1)*(2*HY+1)
        if(.not.image)then
        CALL BEXPAN(RAS,IA,NEXP)
        else
        call ip_bexpan(ras,ia,nexp)
        endif
        IC=HX+HY-IRAS(3)
        IRX=HX-IRAS(4)
        IRY=HY-IRAS(5)
        DO 1 P=1,10
1       A(P)=0.0
        S=0
        T=0
        IJ=0
C
C------------------------ start loop
C
      hx = hx * idr
        DO 3 P=-HX,HX,idr
        IP=IABS(P)
        P1=(IP.GT.IRX)
        P2=(IP.EQ.IRX)
        DO 3 Q=-HY,HY
        IJ=IJ+1
        IQ=IABS(Q)
        IOD=IA(IJ)
        IPQ=IP+IQ
        IF(P1.OR.IPQ.GT.IC.OR.IQ.GT.IRY) GOTO 2
        IF(P2.OR.IPQ.EQ.IC.OR.IQ.EQ.IRY) GOTO 3
        T=T+1
        TPP=TPP+P*P
        TQQ=TQQ+Q*Q
        TPOD=TPOD+P*IOD
        TQOD=TQOD+Q*IOD
        TOD=TOD+IOD
        GOTO 3
2       S=S+1
        SPP=SPP+P*P
        SQQ=SQQ+Q*Q
        SPOD=SPOD+P*IOD
        SQOD=SQOD+Q*IOD
        SOD=SOD+IOD
3       CONTINUE
C
C-------------------------------  end loop
C
        B=SPOD/SPP
        C=SQOD/SQQ
        D=SOD/S
        SPOT=TOD-D*T
C
C-----------------------------CATCH ZERO SPOTS
C
        IF(SPOT.NE.0.)GO TO 4
        DELX=0.
        DELY=0.
        RETURN
4       CONTINUE
c        DELX=(TPOD-B*TPP)/SPOT*IDR
        DELX=(TPOD-B*TPP)/SPOT
        DELY=(TQOD-C*TQQ)/SPOT
C
C---------------------------  SPOT=SPOT/T IE AVERAGE IN SPOT!
C                                OCT 3 1984
C
        SPOT=SPOT/T
        RETURN
        END
C
C
C                      *********************************************
C                      *                                           *
C                      *        ****  SUBROUTINE CGFIT   ****      *
C                      *                                           *
C                      *********************************************
C
C
C
C=============================================================
C
        SUBROUTINE CGmask(RAS,IRAS,IDR,DELX,DELY,ix,iy,SPOT)
        common/iplate/image,mar,moldyn
        logical image,mar,moldyn
C
      INCLUDE 'commaskl.finc'
      INCLUDE 'commask.finc'
C
        INTEGER P,Q,HX,HY,IRAS(5),S,T
        INTEGER*2 RAS(1)
        DIMENSION IA(5000)
        REAL A(6)
        EQUIVALENCE (A(1),SPod),(A(2),SQod),(A(3),SoD)
        EQUIVALENCE (A(4),toD),(A(5),tpOD),(A(6),Tqod)
        HX=IRAS(1)/2
        HY=IRAS(2)/2
        NEXP=(2*HX+1)*(2*HY+1)
        if(.not.image)then
        CALL BEXPAN(RAS,IA,NEXP)
        else
        call ip_bexpan(ras,ia,nexp)
        endif

        DO 1 P=1,6
      rsums(p) = 0
1       A(P)=0.0
      do 11 p=1,5000
11      rmask(p) = 0
c
c      note that seekrs has idr = 1 which means that ods are
c      stored forwards in x while rmask is always back in x
c
      if(idr.eq.0) ispotr=9111
      call radmask(1,ix,iy,iras(1),iras(2),ispotr,ia)
      idir = idr
      if(idr.eq.0) idir=1
        IJ=0
C
C------------------------ start loop
C
      hx = hx * idir
        DO 3 P=-HX,HX,idir
        DO 3 Q=-HY,HY
        IJ=IJ+1
        IOD=IA(ij)
        if(rmask(ij)) 2,3,12
12      TPOD=TPOD+P*IOD
        TQOD=TQOD+Q*IOD
        TOD=TOD+IOD
        GOTO 3
2       SPOD=SPOD+P*IOD
        SQOD=SQOD+Q*IOD
        SOD=SOD+IOD
3       CONTINUE
C
C-------------------------------  end loop
C
        B=SPOD/rsums(2)
        C=SQOD/rsums(4)
        D=SOD/rsums(6)
        SPOT=TOD-D*rsums(5)
C
C-----------------------------CATCH ZERO SPOTS
C
        IF(SPOT.NE.0.)GO TO 4
        DELX=0.
        DELY=0.
        RETURN
4       CONTINUE
        DELX=(TPOD-B*rsums(1))/SPOT
c        DELX=(TPOD-B*rsums(1))/SPOT*idir
        DELY=(TQOD-C*rsums(3))/SPOT
C
C---------------------------  SPOT=SPOT/T IE AVERAGE IN SPOT!
C                                OCT 3 1984
C
        SPOT=SPOT/rsums(5)
c      write(8,69) npeak,nbg,(rsums(j),j=1,6)
c      write(8,70) b,c,d
c      if(.not.batch)write(6,69) npeak,nbg,(rsums(j),j=1,6)
c      if(.not.batch)write(6,70) b,c,d
c69      format(1x,2i4,6f6.1)
c70      format(1x,3f8.3)
c71      format(1x,8f8.3)
c      write(8,71) spod,sqod,sod,tpod,tqod,tod,delx,dely
c      if(.not.batch)write(6,71) spod,sqod,sod,tpod,tqod,tod,delx,dely
        RETURN
        END
C
      SUBROUTINE  check_file (file_name, facility, exists)
C
C Purpose: To check if specified file exists and if not then print error message
C
      implicit none
C
      character*(*)  file_name, facility
      logical        exists
C
C
C
      common /io_streams/ in_term, out_term, in_data, out_data
      integer*4           in_term, out_term, in_data, out_data
C
C in_term : main input stream (usually the terminal =5)
C out_term : main output (printer) stream (usually =6)
C in_data : input stream for data (to be written to files)
C out_data : output stream for data (to be written to files)
C
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C Local Variables:
C
C
      integer*4  i
C
C------------------------------------------------------------------------------
C
      inquire (file=file_name, exist=exists)
C
      if  (.not.exists)  then
         do i=len(file_name),1,-1
            if  (file_name(i:i).ne.' ' .and.
     1          file_name(i:i).ne.char(0))  goto 1
         end do
         i = 4
         file_name = 'file'
 1       write (out_term, 1000) facility, file_name(1:i), 7
      end if
C
      return
 1000 format(1x,a,'-E-FILNOTEX, ',a,' does not exist',a1)
      end
C
C
C             SUBROUTINE TO CHECK THE BACKGROUND VALUE B
C      AT THE POINT X,Y AND EITHER INCLUDE IT IN A NEW
C              EVALUATION OF THE BG PLANE OR THROW
C                            IT OUT.
C
C
      SUBROUTINE CHKBCK(J, JBIN, B, XX, YY, SIGN)
C
      INCLUDE 'comhat.finc'
      INCLUDE 'combck.finc'
C
      INTEGER XX, YY, SIGN
C
C--------EVALUATE BG AT THIS POINT FROM CURRENT PLANE
C
      XN = FLOAT(XX)
      YN = FLOAT(YY)
      DEV = B - A(J)*XN - BZ(J)*YN - C(J)
      NDEV = NINT(DEV)
      if(.not.endbin) goto 10
      if(endbin.and.ovlap.and.correct) then
            if(dev.le.cutu.and.dev.ge.2.5*cutl) goto 10
            REJ(2) = REJ(2) + 1
         else
            IF(DEV.LE.CUTU.AND.DEV.GE.CUTL) GOTO 10
            REJ(J) = REJ(J) + 1
      end if
C
C---------SET TO REJECT THIS POINT
C
      SIGN = -1
C
C------------ RESET AM ELEMENTS... CHANGE COMING
C
        IF(.NOT.CHANGE(J)) CALL CONBCK(0.,0.,-999.,J)
      CHANGE(J) = .TRUE.
      CALL OFFBCK(J,B,XX,YY,SIGN)
      SIGN = 1
      RETURN
C
C----------THIS POINT OK.
C
10      SIGN = 1
      SIGMA(J)=SIGMA(J)+NDEV*NDEV
      RETURN
      END
C
C
C   SUBROUTINE TO REJECT VALUES OF H(I) FOR AN
C        OVERLAPPED REFLECTION.
C
C
      SUBROUTINE CHKPHAT(ODPR,PPR,QPR,PR,PR2,nobin)
C
      INCLUDE 'combck.finc'
      INCLUDE 'comhat.finc'
C
      real shft(5000),rratio(5000)
C
      nav = hpobs(nobin)
      avj = 0.0
C
      DO 100 I=1,HPOBS(nobin)
      rratio(i) = h(i)/hsp(i,nobin)
          if(rratio(i).LT.HOVLAP) then
            avj = avj + hatp(i,1,nobin)
            goto 100
          else
            ratrej = ratrej + 1
            nav = nav - 1
        end if
100       continue
c
      avj = avj/float(nav)
      shftmn = 0.0
c
      do 150 i=1,hpobs(nobin)
      shft(i) = hatp(i,1,nobin) - avj
          if(rratio(i).lt.HOVLAP) then
            shftmn = shftmn + abs(shft(i))
        end if
150      continue
      shftmn = shftmn/float(nav)
c
      icant = 0
      prorej = 0
c
      do 200 i=1,hpobs(nobin)
      if(shft(i).le.(HCUT*shftmn)) goto 200
C
C-----------SET TO REJECT POINT
C
      icant = icant + 1
      OREJ=OREJ+1
C
      CALL OFFHAT(I,ODPR,PPR,QPR,PR,PR2,nobin)
200   CONTINUE
      if((3*icant).gt.hpobs(nobin)) prorej = 1
      if(prorej.eq.0) then
            rgdrej = rgdrej + (hpobs(nobin) - nav)
            ogdrej = ogdrej + icant
      end if
      RETURN
      END
C
C
C
C
C                      *********************************************
C                      *                                           *
C                      *        ****  SUBROUTINE CHKRAS  ****      *
C                      *                                           *
C                      *********************************************
C
C
C
C=============================================================
C
C
C       ***  SUBROUTINE CHKRAS  ***
C
C  CALCULATES AVERAGE SPOT PROFILE FROM
C  MEASUREMENTS MADE BY CENTRS.
C  DISPLAYS PROFILE AND MEASUREMENT BOX ON
C  TEKTRONIX AND ALLOWS BOX PARAMETERS TO
C  BE CHANGED.
C
C=============================================================
C
C
        SUBROUTINE CHKRAS
c
cRCD ...Image Plate logical
        common/iplate/image,mar,moldyn
        logical image,mar,moldyn
c
        COMMON/SW/ISWTCH(10),oneref,noref,tworef
        COMMON/IOO/IOUT
        COMMON/THRESH/IJNK1,IMTHR,IMREF
C
      INCLUDE 'comscn.finc'
      INCLUDE 'comras.finc'
      INCLUDE 'comuab.finc'
      INCLUDE 'commaskl.finc'
      INCLUDE 'commask.finc'
C
        INTEGER IOD(5000),KRAS(5),MASK(5000)
        INTEGER*2 BUF(2500)
        INTEGER MINOD,MAXOD
        REAL ASPOT(5),PQVAL(6)
        LOGICAL FULL,oneref,noref,tworef
        EQUIVALENCE (ASPOT(1),SPOT),(ASPOT(2),BGND),(ASPOT(3),RMSBG)
        EQUIVALENCE (ASPOT(4),DELX),(ASPOT(5),DELY)
        INTEGER*2 irec
        CHARACTER*1 JUNK
        ifail=0
        call ccpdpn(-25,'TEMPSPOT','OLD','U',0,ifail)
        IF(XTEK) CALL NEWPG
        NXY=NXS*NYS
        IF(NXY.LE.5000)GO TO 1
        if(.not.batch)write(6,1000)
        WRITE(IOUT,1000)
 1000   FORMAT(/,' MEASUREMENT BOX DIMENSIONS TOO LARGE TO DISPLAY',
     1         ' AVERAGE SPOT PROFILE',
     1         /,' NXS*NYS MUST BE LESS THAN OR EQUAL TO 5000')
        If (Batch) stop
        GO TO 9
1       CONTINUE
      if(.not.image) then
        NSIZ=(NXY+1)/2
      else
      nsiz = nxy
      endif
        DO 2 I=1,NXY
2       IOD(I)=0
C
C-------------------------- SUM ODS IN TEMSPOT
C
3       read(25,end=5)irec,(buf(i),i=1,nsiz)
        DO 4 I=1,NXY
        if(.not.image)then
        IOD(I)=IOD(I)+IBYTE(BUF,I)
        else
        iod(i)=iod(i)+ip_ibyte(buf,i)
        endif
4       CONTINUE
        GOTO 3
C
C--------------------- FIND MAX OD, SCALE RASTER SUM
C
5       MAXOD=0
        MINOD=65000
        DO 6 I=1,NXY
        MAXOD=MAX0(MAXOD,IOD(I))
6       MINOD=MIN0(MINOD,IOD(I))
        SCALE=255./(MAXOD-MINOD)
        DO 7 I=1,NXY
7       IOD(I)=(IOD(I)-MINOD)*SCALE+0.5
C
C--------------------- FIND AVERAGE SPOT SHAPE AND PLOT
C
        If (.not.ltek) goto 8
        IF(.NOT.XTEK) CALL TKCLR
8       if(.not.batch)write(6,1001)
        WRITE(IOUT,1001)
1001    FORMAT(/20X,'AVERAGE SPOT PROFILE FOR CENTRE OF IMAGE'
     +                /,20X,13('---')/)
        CALL SETMASK(MASK,IRAS)
        CALL SETSUMS(MASK,IRAS,PQVAL)
        FULL=.TRUE.
C
C--------------------------save for Batch
C
        Delxs = Delx
        Delys = Dely
        Rmsbgs = Rmsbg
        CALL INTEG(IOD,IRAS,MASK,PQVAL,ASPOT,-1,FULL)
        DELX=DELX/FACT
        DELY=DELY/FACT
        WRITE(IOUT,1002) DELX,DELY,RMSBG
        if(.not.batch)write(6,1002)DELX,DELY,RMSBG
1002    FORMAT(/' C. OF G. SHIFTS =',2F5.1,/' BACKGROUND RESIDUAL=',
     1             F5.1)
        CALL RASPLOT(IOD,NXS,NYS,MASK,-1)
C
C ----------- CHECK SHIFTS FOR CONVERGENCE
C
        Imref = Imref + 1
        Iswtch(2) = 0
        If(delx.eq.delxs.and.dely.eq.delys.and.rmsbg.eq.rmsbgs) goto 11
C
C------------ Stop at 10 cycles in Auto mode
C
        If (Imref.le.10) Iswtch(2) = 1
        If (Batch) goto 11
C
        if(.not.batch)write(6,1003)
1003    FORMAT(/' REPEAT?(Y/N) [Yes]',$)
        read(5,1004)JUNK
1004    FORMAT(A1)
        Iswtch(2) = 1
        CALL NOYES(JUNK,ISWTCH(2))
        IF(ISWTCH(2).EQ.0)GO TO 11
9       WRITE(IOUT,1005)
        if(.not.batch)write(6,1005)
1005    FORMAT(' RASTER PARAMETERS :-'/'  NXS  NYS   NC  NRX  NRY')
        if(.not.batch)write(6,1006) IRAS
        WRITE(IOUT,1006)IRAS
1006    FORMAT(5I5,'      ?')
        read(5,1007) KRAS
1007    FORMAT(5I5)
        WRITE(IOUT,1008)KRAS
1008    FORMAT(1X,5I5)
        DO 10 I=1,5
        IF(KRAS(I).EQ.0) GOTO 10
      if(kras(i).lt.0) kras(i) = 0
        IRAS(I)=KRAS(I)
10      CONTINUE
11      CONTINUE
        IF((MOD(NXS,2).NE.1).OR.(NXS.GT.69)) GOTO 12
        IF((MOD(NYS,2).NE.1).OR.(NYS.GT.69)) GOTO 12
        CLOSE (UNIT=25)
        If (Ltek) CALL TKCLR
        RETURN
12      if(.not.batch)write(6,1009)
1009    FORMAT('***NXS AND NYS MUST BE ODD INTEGERS < OR = TO 69')
        GOTO 9
        END
C
C
C
C
C
C
C                      *********************************************
C                      *                                           *
C                      *        ****  SUBROUTINE COMPR   ****      *
C                      *                                           *
C                      *********************************************
C
C
C
C=============================================================
C
C                          SUBROUTINE COMPR
C                         ------------------
C
C  COMPARES CURRENT SPOT IN 'PROCESS' WITH REFLECTIONS
C  SPECIFIED IN 'SPOTDUMP' INPUT FILE, AND
C  SETS LOGICAL VARIABLE LDUMP IF THE CURRENT REFLECTION
C  IS TO BE DUMPED THROUGH ' BADSPOTS' OUTPUT.
C
C   AUG 82
C
C============================================================
C
C
        SUBROUTINE COMPR(KREC,IHD,LDUMP,NSPT)
        LOGICAL LDUMP
        INTEGER IHD(3,50),IH(6)
        JREC=IABS(KREC)
        CALL GETHKL(KREC,IH)
        DO 1 I=1,NSPT
        LDUMP=((IH(1).EQ.IHD(1,I)).AND.
     1       (IH(2).EQ.IHD(2,I)).AND.
     1       (IH(3).EQ.IHD(3,I)))
        IF(LDUMP) return
1       CONTINUE
        RETURN
        END
C
C
C           SUBROUTINE TO GET A,B,C FOR THIS SPOT FROM COMMON
C
      SUBROUTINE CONBCK(APL,BPL,CPL,IBIN)
C
      INCLUDE 'comuab.finc'
      INCLUDE 'combck.finc'
      INCLUDE 'comprf.finc'
      INCLUDE 'comhat.finc'
C
C------------- GET CONSTANTS FOR PRINTOUT WHEN CPL NE -999
C------------- COME FOR REJ WHEN CPL = -9999
C
      IF(CPL.EQ.-9999) GOTO 2
        IF(CPL.EQ.-999.) GOTO 1
      APL = A(IBIN)
      BPL = BZ(IBIN)
      CPL = C(IBIN)
      IF(.NOT.CHANGE(IBIN)) RETURN
C
C------------RESET AM MATRIX (NON-INVERTED) FOR LATER USE
C
1       BPP(ibin) = AMST(1,1)
      BQQ(ibin) = AMST(2,2)
      BN(ibin) = AMST(3,3)
      BPQ(ibin) = AMST(1,2)
      BP(ibin) = AMST(1,3)
      BQ(ibin) = AMST(2,3)
      RETURN
2      APL = FLOAT(REJ(IBIN))
      if(correct) then
      write(8,100) rej(1)
      if(.not.batch)write(6,100)rej(1)
100      format(/1x,I7,' Background replacements for overlapped spots')
      write(8,101) rej(2)
      if(.not.batch)write(6,101)rej(2)
101      format(/1x,I7,' Background rejections for overlapped spots')
      end if
      RETURN
      END
C
C
C    Subroutine to keep track of elapsed CPU time
C
C
C
      SUBROUTINE CPUTIME(ICODE)
C
      INCLUDE 'comuab.finc'
C
      INTEGER *4 ICODE,IMSECS,IMINS,ISECS
C
        CALL CCPTIM (ICODE,CPU,ELAPS)
        Isecs = CPU
      Imins = Isecs/60
      Isecs = Isecs - 60*Imins
C
      if(icode.eq.1) then
      if (.not.batch)Write(6,1000)imins,isecs
      Write(8,1000)imins,isecs
1000  Format(/1x,' ****** Elapsed cpu: ',I3,' mins ',I3,' secs *****')
      end if
      RETURN
      END
C
      SUBROUTINE CUREND
      RETURN
      END
C
C
C
C                      *********************************************
C                      *                                           *
C                      *        ****  SUBROUTINE CURREF ****       *
C                      *                                           *
C                      *********************************************
C
C
C
C=============================================================
C
C
C       SUBROUTINE CURREF
C
C  REFINE FILM PARAMETERS FROM COORDINATES INPUT
C  FROM TEKTRONIX
C  PARAMETERS DERIVED FROM EQUATIONS
C       XOBS = DELX + RCOS*XCALC - RSIN*YCALC
C       YOBS = DELY + RCOS*YCALC + RSIN*XCALC
C       R    = SQRT(RCOS**2 + RSIN**2)
C
C=============================================================
C
C
C
        SUBROUTINE CURREF(CDX,CDY)
        DIMENSION IX(4),IY(4)
C
      INCLUDE 'comuab.finc'
      INCLUDE 'comscn.finc'
      INCLUDE 'comori.finc'
C
        COMMON/SW/ISWTCH(10),oneref,noref,tworef
        COMMON/IOO/IOUT
        LOGICAL oneref,noref,tworef
C
1       CONTINUE
C
C -------------  POSITION AT TOP OF PAGE
C
        CALL TKPLOT(0,780,1,IER)
        if(.not.batch)write(6,1000)
1000    FORMAT(' SET CURSER TO CALCULATED POSITION OF SPOT',
     1            ' (L = NODAL SPOT)',
     +           /' THEN PRESS ANY KEY ON TEKTRONIX')
        CALL CURSIS(ICHAR,IX(1),IY(1),1)
        CALL TKPLOT(0,720,1,IER)
        if(.not.batch)write(6,1001)
1001    FORMAT(' NOW REPEAT FOR OBSERVED POSITION...')
        CALL CURSIS(ICHAR,IX(2),IY(2),1)
        CALL TKPLOT(0,680,1,IER)
        if(.not.batch)write(6,1002)
1002    FORMAT(' ...AND FOR ANOTHER PAIR')
        CALL CURSIS(ICHAR,IX(3),IY(3),1)
        CALL CURSIS(ICHAR,IX(4),IY(4),1)
        DO 2 I=1,4
        IX(I)=IX(I)-512
2       IY(I)=IY(I)-390
        DXOBS=IX(2)-IX(4)
        DYOBS=IY(2)-IY(4)
        DXCAL=IX(1)-IX(3)
        DYCAL=IY(1)-IY(3)
        IF(DXOBS**2+DYOBS**2.GT.10000) GOTO 3
        CALL TKPLOT(0,0,1,IER)
        if(.not.batch)write(6,1003)
1003    FORMAT(' SEPARATION BETWEEN POSITIONS TOO SMALL-TRY AGAIN')
        GOTO 1
3       RCOS=(DXOBS*DXCAL+DYOBS*DYCAL)/(DXCAL**2+DYCAL**2)
        RSIN=(DYOBS*DXCAL-DXOBS*DYCAL)/(DXCAL**2+DYCAL**2)
        R=SQRT(RCOS**2+RSIN**2)
        XTOFRA=XTOFRA*R
        COSA=RCOS/R
        SINA=RSIN/R
        ANGLE=ATAN2(RSIN,RCOS)*180./3.14159
        COSOM=COSOM0*COSA-SINOM0*SINA
        SINOM=COSOM0*SINA+SINOM0*COSA
        SINOM0=SINOM
        COSOM0=COSOM
        OMEGA0=ATAN2(SINOM0,COSOM0)*180./3.14159
        DELX=(IX(2)+IY(1)*RSIN-IX(1)*RCOS)*5.0
        XCEN=XCEN+DELX
        CDX=CDX+DELX
        DELY=(IY(2)-IY(1)*RCOS-IX(1)*RSIN)*5.0
        YCEN=YCEN+DELY
        CDY=CDY+DELY
        CALL TKCLR
        WRITE(IOUT,1004) R,ANGLE,DELX,DELY
        if(.not.batch)write(6,1004)R,ANGLE,DELX,DELY
1004  FORMAT(/' SCALE FACTOR =',F6.3,' ROTATION OF CALCULATED PATTERN ='
     1           ,F6.2,' DEG.'/
     +          '  SHIFT IN CENTRE =',2F6.1,' (10 MICRON UNITS)'/)
        WRITE(IOUT,1005) XCEN,YCEN,OMEGA0,XTOFRA
        if(.not.batch)write(6,1005)XCEN,YCEN,OMEGA0,XTOFRA
1005    FORMAT(10X,'   XCEN    YCEN   OMEGA   XTOFRA'/
     +                10X,2I8,2F8.4/)
        CALL CUREND
        RETURN
        END
C
      SUBROUTINE CURSIS(ICH,IX,IY,IFLAG)
C
C Altered to qgcurs for intlaue.lib pdc 6/6/91
C
      character*1 ch
      call qgcurs(x,y,ch)
      ich = ichar(ch)
      ix=ifix(x)
      iy=ifix(y)
      RETURN
      END
C
C           SUBROUTINE TO SET BG CUTOFF AND IRAD IN COMMON
C
      SUBROUTINE CUTBCK(CUT,ISRAD,ISRAD2,NPWK1,NMBIN1)
C
      INCLUDE 'combck.finc'
      INCLUDE 'comprf.finc'
      INCLUDE 'comuab.finc'
C
C---------------WHILE HERE SET REJ(J) TO 0
C
      DO 100 IREJJ = 1,18
100      REJ(IREJJ) = 0
      IF(ISRAD.EQ.-1) GOTO 1
      FCUT = CUT
      CUTU = 10.0
      CUTL = - CUTU*0.8
      IRAD = ISRAD
      IRAD2 = ISRAD2
C
C-------- SET INTEN CUT OFF FOR INCLUSION IN PROFILES
C         STORED IN COMPRF
C         AND SET NMBIN (IN COMBCK) AND NUMBIN (IN COMPRF)
C
      NMBIN = NMBIN1
      NUMBIN = NMBIN1
      NPWK = NPWK1
      RETURN
C
C-------------------- SET CUTOFFS BASED ON AVEBG (CUT FROM PROCUAB)
C
1       IF(BGPLAN) GOTO 2
      CUTU = CUT * FCUT
      CUTL = - CUT * FCUT * 0.8
      WRITE(8,10) CUTU,CUTL
      if(.not.batch)write(6,10) CUTU,CUTL
10      FORMAT(/1X,' POINTS MORE THAN +',F6.1,F7.1,' FROM THE ',
     1   'BACKGROUND PLANE ARE REJECTED')
      RETURN
c
c---------- for lower films, reduce bg constants in NOB
c---------- to (c-36)*1/1.42 + 36 where 36 is reckoned to
c---------- be the base (14) + (Abg - 14)/4 (22 for ppb)
c---------- and the film factor is 1.42.
c---------- Then work out new cutoffs still
c---------- based on original input fraction.
c******** for rhino looks like 24 more appropriate
c
2      sumxob = 0.0
      do 50 i=1,numbin
      xob = (float(nob(i) - 24))/1.42 +24
      nob(i) = nint(xob)
50      sumxob = sumxob + xob
      xob = sumxob/float(numbin)
        CUTU = fcut * xob
      CUTL = - fcut * xob * 0.8
      WRITE(8,10) CUTU,CUTL
      if(.not.batch)write(6,10) CUTU,CUTL
      RETURN
      END
C
C
C
C
C                      *********************************************
C                      *                                           *
C                      *        ****  SUBROUTINE DSCAN ****       *
C                      *                                           *
C                      *********************************************
C
C
C
C=============================================================
C
C
C            ****  SUBROUTINE DSCAN  ****
C
C CHECKS REQUIRED X-LIMITS ON FILM, SCANS AREA OF FILM AND
C TRANSFERS IMAGE TO DISK FILE 'FILM' IN DIRECTORY UD4.
C
C
C=============================================================
C
C
        SUBROUTINE DSCAN
        COMMON/PEL/JDUN,IDUM(5120),NREC
        INTEGER*2 IDUM,jdun
C
C------------------------------ COMMON VARIABLES
C
      INCLUDE 'comscn.finc'
      INCLUDE 'comfid.finc'
      INCLUDE 'comori.finc'
      INCLUDE 'commcs.finc'
      INCLUDE 'comras.finc'
      INCLUDE 'comuab.finc'
      INCLUDE 'comlaue.finc'
C
        COMMON/IOO/IOUT
C
C-------------------------- LOCAL VARIABLES
C
c        INTEGER IBUF(10)
        BYTE SCLINE(4800)
c        EQUIVALENCE(IBUF(1),IHMR),(IBUF(3),JX),(IBUF(4),JY)
        I16MM=16*40/SCNSZ
        IBG=I16MM/2+1
        IYO=IYOFF-I16MM
        IYL=IYLEN+I16MM
C
C------------------------- FIND LIMITS OF SCAN
C
      ymin = 18000
      ymax = 0
        XMIN=18000
        XMAX=0
c##### laue mods - change choice of spots
c        ICOL=3+2*(FILM-1)
c        JREC=PCKIDX+1
C
C------------------------------------- start loop
C
        DO 1 I=1,TOSPT
c##### laue mods
c     get x y for measurable spots
        im = nodal(i)/8
      IMULT = (NODAL(I)-8*IM)/4
      IMEAS = (NODAL(I)-8*IM-4*IMULT)/2
      IOV = (NODAL(I)-8*IM-4*IMULT-2*IMEAS)
        if(imult.gt.0.and.iov.ne.0) goto 1
        if(film.gt.1. and .imeas.ne.0) go to 1
c
        XC= xyge(1,i)
        YC= xyge(2,i)
        CALL XYCALC(XCAL,YCAL,XC,YC)
c      write(8,333) xc,yc,xcal,ycal
c333      format(1x,'dscan: in,out: ',4(f16.2,1x))
        IX=ANINT(XCAL)
        IF(IX.LT.XMIN) XMIN=IX
        IF(IX.GT.XMAX) XMAX=IX
        Iy=ANINT(yCAL)
        IF(Iy.LT.yMIN) yMIN=Iy
        IF(Iy.GT.yMAX) yMAX=Iy
1       CONTINUE
C
C--------------------------------------end loop
C
        XMIN=XMIN*FACT-NXS
        XMIN=MAX0(1,XMIN)
        XMAX=XMAX*FACT+NXS
        XMAX=MIN0(NREC,XMAX)
c
        yMIN=yMIN*FACT-NyS
        yMIN=MAX0(1,yMIN)
        yMAX=yMAX*FACT+NyS
        yMAX=MIN0(iylen,yMAX)
C
C------------------------ POSITION CHARACTER OUTPUT
C
        IF(Ltek) call tkclr
        If (Ltek) Call TKPLOT(0,700,1,IER)
        if(.not.batch)write(6,1000) XMIN,XMAX,ymin,ymax
        WRITE(IOUT,1000)XMIN,XMAX,ymin,ymax
1000    FORMAT(/' SCAN X-LIMITS ARE ',I5,' AND ',I5,
     1          ' SCAN Y-LIMITS ARE ',I5,' AND ',I5)
C
        IF(.NOT.ONLINE) GOTO 2
C
C--------------------  SCAN BACKWARDS AS JUST FOUND FIDUCIAL 3
C
c         CALL FSCAN(XMAX,XMIN,NREC,SCLINE,IYLEN,SCNSZ,4)
2       CONTINUE
        RETURN
        END
C
      SUBROUTINE ENDTX
      CALL QGTMOD
      RETURN
      END
C
C
C
C                      *********************************************
C                      *                                           *
C                      *        ****  SUBROUTINE FIDUS ****        *
C                      *                                           *
C                      *********************************************
C
C
C
C=============================================================
C
C     LOCATES THE FIDUCIAL SPOTS, REFINES THEIR
C     POSITION AND CALCULATES THE CENTRE OF THE FILM
C     AND THE FILM TILTING ANGLE ON THE DRUM
C
C=============================================================
C
C
C
        SUBROUTINE FIDUS
C
cRCD ...Image Plate logical
        common/iplate/image,mar,moldyn
        logical image,mar,moldyn
        COMMON/PEL/IBA,IJBA(5120),NREC
        INTEGER*2 IJBA,iba
        COMMON/IOO/IOUT
        COMMON/SW/ISWTCH(10),oneref,noref,tworef
C
      INCLUDE 'comori.finc'
      INCLUDE 'comrfs.finc'
      INCLUDE 'comscn.finc'
      INCLUDE 'comfid.finc'
      INCLUDE 'commcs.finc'
      INCLUDE 'comuab.finc'
C
C---- LOCAL VARIABLES
        INTEGER DLT(4,2)
        INTEGER HFWX,HFWY,FSTX,LSTX,FSTY,LSTY
        INTEGER CTX,CTY,XF,YF,FPOS(5,2)
        LOGICAL LINE,SPOT,oneref,noref,tworef
        DATA THICK/22./
        DIMENSION NODD(5)
        DIMENSION ITHOD(6),NFIDTH(3)
        DATA ITHOD/230,200,160,128,90,40/
c
c##### laue mods
c
        dimension x_c(6),y_c(6),w_c(6),x_to_fra(6)
        dimension twists(6),tilts(6),bulges(6),y_scal(6)
      character*6 aword
C
C
        BYTE SCLINE(2400)
        if(.not.batch)write(6,1000)
        WRITE(IOUT,1000)
 1000   FORMAT(' ENTER FIDUS')
C
C------  READ CAMERA CONSTANTS FROM GENERATE FILE FOR B AND C FILMS
c
c##### laue mods - read new ge file
C
        igo = 0
        DO 99 I=1,3
99      NFIDTH(I) = 0
        IF(.not.bgplan) GOTO 1
      read(1, rec=2) aword,x_cen_fs,y_cen_fs,(w_fs(i),i=1,5)
      read(1, rec=3) w_fs(6)
      cent_in = .true.
      if(x_cen_fs(film).eq.0.and.y_cen_fs(film).eq.0) then
      cent_in = .false.
      endif
        READ(1,REC=5) x_c,y_c,w_c
        READ(1,REC=6) twists,tilts,bulges
        READ(1,rec=7) y_scal,x_to_fra
        cbar = 0
        yscal = y_scal(film)
        ccx   = nint(x_c(film)*100.)
        ccy   = nint(y_c(film)*100.*yscal)
        ccom  = w_c(film)
c
        TILT  = tilts(film)  * FDIST 
        TWIST = twists(film) * FDIST
        BULGE = bulges(film) * FDIST
        IF(VEE) BULGE=BULGE*3.14159/18000.
        VTILT=0.0
        VVERT=0.0
        XTOFRA = x_to_fra(film)
        IF(CCX.EQ.-999) STOP 31
1       continue
c
      if(cent_in) then
      xcenf = nint(x_cen_fs(film)*100.)
      ycenf = nint(y_cen_fs(film)*100.*yscal)
      omegaf = w_fs(film) * 4.0*atan(1.0)/180.
      xcen   = xcenf + ccx
      ycen   = ycenf + ccy
      omega0 = omegaf + ccom * 4.0*atan(1.0)/180.
      sinom0 = sin(omega0)
      cosom0 = cos(omega0)
        ICTF=CTOFD*XTOFRA
c
      write(iout,211)
      write(iout,102) xcenf,ycenf,yscal,w_fs(film)
      write(iout,103) ccx,ccy,yscal,ccom
      write(iout,104) ictf,xtofra
      if(.not.batch) write(6,211)
      if(.not.batch) write(6,102) xcenf,ycenf,yscal,w_fs(film)
      if(.not.batch) write(6,103) ccx,ccy,yscal,ccom
      if(.not.batch) write(6,104) ictf,xtofra
211      format(/1x,' Input Parameters from GE file: ')
102      format(/' x_cen_f: ',i8,/' y_cen_f: ',i8,
     1            ' (GE parameter * ',f6.4,')',/,' w_f    : ',
     1          f8.4,' (degrees)')
103      format(/' ccx    : ',i8,/' ccy    : ',i8,
     1            ' (GE parameter * ',f6.4,')',/,' ccom   : ',
     1          f8.4,' (degrees)')
104      format(/' xtofd  : ',i8,' (',f8.4,' )'/)
c
      if(ltek) call newpg
      return
      endif
      if(image) return
C
C----------------------------- FIDUCIAL BOX SIZE
C
        If (LTEK) CALL TKCLR
        HFWY=MM*FACT+0.5
        HFWX=HFWY
C
C----------------------------- RECORDING OF FIDUCIAL SPOTS
C
        TXFAC=0.14*SCNSZ
        DO 12 J=1,NFID
111     IGO = IGO + 1
        ITHRESH = ITHOD(IGO)
        CW=COS(OMEGAF)
        SW=SIN(OMEGAF)
        XF=(XCENF+FSPOS(J,1)*CW-FSPOS(J,2)*SW)*FACT+0.5
        YF=(YCENF+FSPOS(J,2)*CW+FSPOS(J,1)*SW)*FACT+0.5
C
C------------------- BOX IS ALWAYS SCANNED TOWARDS CENTRE OF FILM
C
        ISX=-ISIGN(1,FSPOS(J,1))
        FSTX=XF-HFWX*ISX
        LSTX=XF+HFWX*ISX
        ISY=-ISIGN(1,FSPOS(J,2))
        FSTY=YF-HFWY*ISY
        LSTY=YF+HFWY*ISY
C
C----------------------- DRAW FIDUCIAL BOXES
C
        IFX=FSTX*TXFAC
        ILX=LSTX*TXFAC
        IFY=FSTY*TXFAC
        ILY=LSTY*TXFAC
        If (Ltek) Then
                Call MOVTX(IFX,IFY)
                Call VECTX(ILX,IFY)
                Call VECTX(ILX,ILY)
                Call VECTX(IFX,ILY)
                Call VECTX(IFX,IFY)
        End If
        ACTX=FSTX
        SOD=0.0
        SXOD=0.0
        SYOD=0.0
        NOD=0
        SPOT=.FALSE.
        IF(.NOT.ONLINE) GOTO 2
C
C-----------------Scan fid area for 1+2  then 3
C                    carry info as arguments.
C
c         if(j.ne.2) call fscan(fstx,lstx,nrec,SCLINE,iylen,scnsz,J)
C
C----------------- SEARCH FOR LINE OF DENSITIES ABOVE THRESHOLD
C
2       CONTINUE
        DO 10 K=FSTX,LSTX,ISX
        IER=ISX
        CALL RDBLK(2,K,IJBA,NWORD,IER)
        ACTX=ACTX+ISX
        LINE=.FALSE.
        LB=FSTY
        LF=LSTY
        DO 5 I=FSTY,LSTY,ISY
        CALL CBYTE(I)
        IF(IBA.LT.ITHRESH) GOTO 3
        IF(LINE) GOTO 5
C
C---------------------  START OF LINE
C
        LINE=.TRUE.
        LB=I
        IB=LB*TXFAC
        JX=ACTX*TXFAC
        If (Ltek) Call MOVTX(JX,IB)
        GOTO 5
C
C----------------------  END OF LINE
C
3       IF(.NOT.LINE) GOTO 5
        LF=I-1
        IE=LF*TXFAC
        If (Ltek) Call VECTX(JX,IE)
        If (Ltek) Call ALPHA
C
C--------------------- TESTS FOR ACCEPTABLE LINE
C------------------- FID MUST LIE COMPLETELY WITHIN BOX
C
        IF(LB.EQ.FSTY) GOTO 4
C
C------------------------ MAX. LINE LENGTH IS 1.5MM
C
        ILFLB=IABS(LF-LB)
        IF(ILFLB.GT.60/SCNSZ) GOTO 4
C
C------------------------ MIN. LINE LENGTH IS 2 PIXELS
C
        IF(ILFLB.LT.2) GOTO 4
        IF(.NOT.SPOT) GOTO 7
C
C---------------------- TEST FOR OVERLAP WITH PREVIOUS LINE
C
        IF(IABS((LBP+LFP)-(LB+LF)).LT.IABS((LF-LB)+(LFP-LBP))) GOTO 7
4       LINE=.FALSE.
5       CONTINUE
        LINE=.FALSE.
C
C------------------------------ NO LINE
C
        IF(.NOT.SPOT) GOTO 10
C
C------------------------------  TESTS FOR ACCEPTABLE FID
C------------------------------  FID MUST LIE WITHIN BOX
        IF(IFSTX.EQ.FSTX) GOTO 6
C
C-----  FID MUST HAVE AREA GREATER THAN .02MM*2  IE 8*50 MICRON PIXELS
C
        IF(NOD.LT.(32/(SCNSZ*SCNSZ))) GOTO 6
        GOTO 11
C
C--------------------------------- FID REJECTED
C
6       SPOT=.FALSE.
        SOD=0.0
        SXOD=0.0
        SYOD=0.0
        NOD=0
        GOTO 10
C
C--------------------------------- LINE
C
7       LFP=LF
        LBP=LB
        IF(SPOT) GOTO 8
        IFSTX=K
        SPOT=.TRUE.
8       CONTINUE
        DO 9 I=LB,LF,ISY
        OD=IBYTE(IJBA,I)
        NOD=NOD+1
        SOD=SOD+OD
        SXOD=SXOD+OD*(ACTX-1)
9       SYOD=SYOD+OD*I
10      CONTINUE
        IF(IGO.LT.6) GOTO 111
        If (Ltek) Call TKPLOT(0,780,1,IER)
        if(.not.batch)write(6,1001) J
        WRITE(IOUT,1001)J
1001    format(' FIDUCIAL',I4,' NOT FOUND')
           If(Batch) Stop
        if(.not.batch)write(6,1002)
        WRITE(IOUT,1002)
1002    FORMAT(' ENTER NEW ESTIMATE OF POSITION OF FIDUCIAL 1 ',$)
        read(5,*)IXF,IYF
        WRITE(IOUT,*)IXF,IYF
        XCENF=-FSPOS(1,1)+IXF/FACT
        YCENF=-FSPOS(1,2)+IYF/FACT
        IGO = 0
        DO 101 KKK = 1,3
101     NFIDTH(KKK) = 0
        GO TO 1
11      IF(NOD.GT.1000/(SCNSZ*SCNSZ).and..not.batch)write(6,1003) J
        IF(NOD.GT.1000/(SCNSZ*SCNSZ))WRITE(IOUT,1003)J
1003    FORMAT( ' FIDUCIAL',I4,'  TOO LARGE')
        If (Ltek) Call ALPHA
        CTX=SXOD/SOD
        CTY=SYOD/SOD
        SOD=SOD/NOD
C
C--------------------------- CENTRE OF FIDUCIAL SPOT
C
        FPOS(J,1)=CTX/FACT
        FPOS(J,2)=CTY/FACT
C
C------------------------- SHIFTS FROM EXPECTED POSITIONS
C
        DLT(J,1)=(CTX-XF)/FACT
        DLT(J,2)=(CTY-YF)/FACT
        NODD(J)=NOD
        NFIDTH(J) = ITHOD(IGO)
        IGO = 0
12      CONTINUE
C
C------------------------ POSITION CHARACTER OUTPUT
C
        If (Ltek) Call TKPLOT(300,700,1,IER)
        WRITE(IOUT,1005)
        IF(XTEK.and..not.batch)write(6,1004)
1004    FORMAT(///////)
        if(.not.batch)write(6,1005)
        DO 13 II=1,NFID
        WRITE(IOUT,1006)II,FPOS(II,1),FPOS(II,2),DLT(II,1),
     1                 DLT(II,2),NODD(II),NFIDTH(II)
        if(.not.batch)write(6,1006)II,FPOS(II,1),FPOS(II,2),DLT(II,1)
     1                  ,DLT(II,2),NODD(II),NFIDTH(II)
13      CONTINUE
C
C---------------- CALCULATE FILM CENTRE AND TILTING ANGLE
C ----------------BOTH AS DETERMINED FROM THE MEASUREMENT AND
C-----------------AS CORRECTED USING THE CAMERA CONSTANTS
C
C ******************* mods for new fids
C
      NFP = 1
      NFC = 2
      if(fpos(1,1).gt.fpos(1,2)) then
            NFP = 2
            NFC = 1
      end if
C
C *******************
C
        XCENF=(FPOS(NFP,1)+FPOS(3,1))/2.0+0.5
        YCENF=(FPOS(NFP,2)+FPOS(3,2))/2.0+0.5
        OMEGAF=FLOAT(FPOS(3,2)-FPOS(NFC,2))/(FPOS(3,1)-FPOS(NFC,1))
      omegaf = atan(omegaf)
        XCEN=XCENF+CCX
        YCEN=YCENF+CCY
        OMEGA0=OMEGAF+CCOM*3.14159/180.
        COSOM0=COS(OMEGA0)
        SINOM0=SIN(OMEGA0)
C
C----------------------- REPORT RESULTS
C
1005    FORMAT(/' FIDUS NO.  X       Y     DX    DY  NO.POINTS THRESH')
1006    FORMAT(I6,2I8,2I6,2I8)
        ANGLE=OMEGA0*57.296
        ICTF=CTOFD*XTOFRA
        WRITE(IOUT,1007) ICTF,XTOFRA,ANGLE,XCEN,YCEN
        if(.not.batch)write(6,1007)ICTF,XTOFRA,ANGLE,XCEN,YCEN
1007    FORMAT(' POST-FIDUCIAL TRANSFORMATION.'/' XTOFD: ',I8,
     1        '   ( ',F8.4,' )'/' OMEGA: ',F8.4/' XCEN:  ',I8/
     2           ' YCEN:  ',I8/)
         RETURN
         END
C
C
C
C                      *********************************************
C                      *                                           *
C                      *        ****  SUBROUTINE FLMPLOT****       *
C                      *                                           *
C                      *********************************************
C
C
C
C=============================================================
C
C       SUBROUTINE FLMPLOT
C
C  SUPERIMPOSES IMAGE OF FILM WITH CALCULATED
C  SPOT POSITIONS.  ALLOWS REFINEMENT OF
C  FILM/DRUM TRANSFORMATION BY CURSOR INPUT
C  FROM TEKTRONIX.
C=============================================================
C
C

        SUBROUTINE FLMPLOT
        COMMON/IOO/IOUT
        COMMON/SW/ISWTCH(10),oneref,noref,tworef
C
      INCLUDE 'commcs.finc'
      INCLUDE 'comscn.finc'
      INCLUDE 'comori.finc'
      INCLUDE 'comras.finc'
      INCLUDE 'comuab.finc'
C
        LOGICAL oneref,noref,tworef
        CHARACTER*1 JUNK
        IF(XTEK)CALL NEWPG
        IF(.NOT.XTEK) CALL TKCLR
C
C ------------------- PLOT REFLEXION POSITIONS
C
        CDX=0.0
        CDY=0.0
        CALL REFPLOT(CDX,CDY)
C
C------------------  SCAN FILM AND PLOT IMAGE OF FILM
C
        CALL SPOTPLOT
        CALL TKPLOT(0,50,1,IER)
        if(.not.batch)write(6,1000)
1000    FORMAT(' DO YOU WANT TO ADJUST THIS ?(Y/N)' ,$)
        read(5,1004)JUNK
        IF(JUNK.EQ.'N')GO TO 2
        if(junk.eq.'n') goto 2
C
C------------  REFINE TRANSFORMATION USING CURSOR INPUT DATA
C
1       CALL CURREF(CDX,CDY)
        if(.not.batch)write(6,1001)
1001    format(' DO YOU WISH TO REPLOT ? (Y or N)',$)
        read(5,1004)junk
        if(junk.eq.'n') goto 2
        if(junk.eq.'N') goto 2
        CALL TKCLR
C
C------------------------  REPLOT REFLEXIONS
C
        CALL REFPLOT(CDX,CDY)
C
C--------------------------  REPLOT IMAGE
C
        CALL VECPLOT
        WRITE(IOUT,1002)
        if(.not.batch)write(6,1002)
1002    FORMAT(/'    REPEAT CURSOR INPUT?(Y/N) [No]',$)
        read(5,1004)JUNK
        WRITE(IOUT,1003)JUNK
1003    FORMAT(1X,A1)
1004    FORMAT(A1)
        Iswtch(3) = 0
        CALL NOYES(JUNK,ISWTCH(3))
        IF(ISWTCH(3).EQ.1) GOTO 1
2       CONTINUE
        CALL TKCLR
        RETURN
        END
C
C
C
C
C
C
C                      *********************************************
C                      *                                           *
C                      *        ****  SUBROUTINE FNDFLM ****       *
C                      *                                           *
C                      *********************************************
C
C
C
C=============================================================
C
C  LOCATES CORNERS OF FILM, CALCULATES Y-OFFSET
C  AND Y-LENGTH FOR SCANNER.
C  DETERMINES APPROX. FILM CENTRE.
C
C=============================================================
C
C
C
        SUBROUTINE FNDFLM
c
cRCD ...Image Plate logical
        common/iplate/image,mar,moldyn
        logical image,mar,moldyn
c
C  ONLY SINGLE BUFFER USED TO ENABLE MAXIMUM YLENGTH TO BE
C  READ IN FINDING FILM POSITION
C  Y-OFFSET AND Y-LENGTH ARE RESET AFTER FILM FOUND
        COMMON/PEL/IBA,IJBA(5120),NREC
        INTEGER*2 IJBA,iba
C
      INCLUDE 'comori.finc'
      INCLUDE 'commcs.finc'
      INCLUDE 'comscn.finc'
      INCLUDE 'comfid.finc'
      INCLUDE 'comuab.finc'
      INCLUDE 'comhis.finc'
C
        COMMON /EXTRAS/ JUMPAX
      common /io_streams/ in_term, out_term, in_data, out_data
      integer*4           in_term, out_term, in_data, out_data
      LOGICAL ERR
        LOGICAL TEST,LFOUND,HFOUND
        INTEGER SFX,SVX,BUF(10)
        REAL DUMMY(15)
c
c##### laue mods - allow 6 films
        DIMENSION IFDAT(6)
        DATA IFDAT/'A ','B ','C ', 'D ','E ','F '/
        DATA SFX/6250/,SVX/8750/
        CHARACTER*60 SFILE
      character*6 aword
        COMMON/IOO/IOUT
        CHARACTER*1 JUNK
C
C
        if(.not.batch)write(6,1000)
        WRITE(IOUT,1000)
1000    FORMAT(' ENTER FNDFLM')
        if(ltek) CALL ALPHA
        JJ=IFDAT(FILM)
        READ(1,REC=10) NPCK
        WRITE(IOUT,1001) NPCK,JJ
        if(.not.batch)write(6,1001)NPCK,JJ
1001    FORMAT(/10X,10('**')/10X,'IMAGE',I5,A1,
     1            /10X,10('**')/)
        CALL TDATE
C
C--------------------- CLEAR COLUMNS FOR B AND C FILMS
C##### laue mods - special subroutine
        IF(FILM.EQ.1) GOTO 2
c        ICOL=3+2*FILM
c        JREC=PCKIDX+1
c        DO 1 I=1,TOSPT
c        JREC=JREC+1
c        READ(1,REC=JREC) BUF
c        BUF(ICOL)=-9999
c        BUF(ICOL+1)=-9999
c        WRITE(1,REC=JREC) BUF
c1        CONTINUE
c     for laues call a subroutine
      iclear = 1
      if(.not.batch) then
       if(.not.batch)write(6,1002)
       WRITE(IOUT,1002)
1002   FORMAT( ' Clear Intensities for this film ? (Y/N) ',$)
       read(5,1003) JUNK
       WRITE(IOUT,1004) JUNK
1003   FORMAT(A1)
1004   FORMAT(1X,A1)
       CALL NOYES(JUNK,Iclear)
      end if
       IF(iclear.ne.0) call setge (tospt, film)
2        CONTINUE
C
C----  READ IN DATA FROM 'FILM' FILE WHEN SKIPPING FILM SCANNING
C----  NORMALLY:
C----  FIDUS SETS XCENF,YCENF,OMEGAF,XCEN,YCEN,COSOM0,SINOM0,XTOFRA
C----  DSCAN SETS XMIN,XMAX
C
C       SKIP ALL THIS FOR LAUES
C
        ONLINE = .false.
C       If (Batch) goto 3
C       if(.not.batch)write(6,1002)
C       WRITE(IOUT,1002)
C1002   FORMAT( ' PROCESS PREVIOUSLY SCANNED FILM IMAGE? (Y/N) ',$)
C       read(5,1003) JUNK
C       WRITE(IOUT,1004) JUNK
C1003   FORMAT(A1)
C1004   FORMAT(1X,A1)
C       CALL NOYES(JUNK,IONL)
C       IF(IONL.EQ.0) ONLINE = .TRUE.
3       if(.not.batch)write(6,1005)
        WRITE(IOUT,1005)
1005    FORMAT(' FILENAME OF DIGITIZED DATA?',$)
        read(5,1007)SFILE
        WRITE(IOUT,1006)SFILE
1006    FORMAT(1X,A60)
1007    FORMAT(A60)
        IF(.NOT.ONLINE) GOTO 4
c         OPEN(UNIT=2,FILE=SFILE,STATUS='UNKNOWN',
c      1         ACCESS='DIRECT',
c      1         FORM='UNFORMATTED',
c      1         ORGANIZATION='RELATIVE',RECL=560)
C
C-------- write last record (nrec) to speed up transfer
C
c         WRITE(2,REC=NREC) 0
        GOTO 5
4       lrec=2*nword
        call flmrcl(lrec,lw,6)
        ifail=1
        call ccpdpn(-2,sfile,'OLD','DU',lw,ifail)
        if(ifail.eq.1)goto 5
c         OPEN(UNIT=2,FILE=SFILE,STATUS='OLD',READONLY,
c      1             ACCESS='DIRECT',
c      1             FORM='UNFORMATTED',iostat=imok)
c         If(imok.eq.0) goto 5
        if(.not.batch)write(6,108)sfile
        write(iout,108)sfile
108     format(1x,' ** File ',A60,' not found **')
        goto 3
C
C----------------------------SET CONSTANTS
C
5       ITHRESH=N1OD*BASEOD
        IYOFF=0
cRCD ...Skip FID stuff for IP
        if(image)goto 999
C
      cent_in = .true.
      read(1, rec=2) aword,x_cen_fs,y_cen_fs,(w_fs(i),i=1,5)
      if(x_cen_fs(film).eq.0.and.y_cen_fs(film).eq.0) then
      cent_in = .false.
      endif
      if(cent_in) then
            if(batch) then
              read(5,1011)ItemX,ItemY
            endif
      return
        endif
C
C-------------------INPUT SCANNER PARAMETERS
C
        IF(ONLINE) GOTO 6
        IXFS = Nint(nrec/2 + fspos(1,1)*fact)
        IYFS = Nint(nword  + fspos(1,2)*fact)
C
C********************** mods for new fids
C
c      if(fspos(1,2).gt.0) then
c              IyFS = Nint(11000.*fact)
c              IxFS = Nint(2000.*fact)
c      end if
      IXF = IXFS
      IYF = IYFS
C
C *********************
C
        if(.not.batch)write(6,1008)IXF,IYF
        WRITE(IOUT,1008)IXF,IYF
1008    FORMAT(' FIRST FIDUCIAL AT (X,Y IN PIXELS) [',
     1       I4,',',I4,']:',$)
        read(5,*)IXF,IYF
1011    FORMAT(2I4)
        IF(IXF.EQ.0) IXF = IXFS
        IF(IYF.EQ.0) IYF = IYFS
        WRITE(IOUT,1012) IXF,IYF
1012    FORMAT(1H+,2I5)
        GOTO 7
C
C-------------------- ONLINE
C
6       ixf=130
        iyf=380
        WRITE(IOUT,1009)IXF,IYF
        if(.not.batch)write(6,1009)IXF,IYF
1009    FORMAT(/' FIRST FIDUCIAL AT (X,Y IN PIXELS)',2I5,/)
7       XCENF=-FSPOS(1,1)+IXF/FACT
        YCENF=-FSPOS(1,2)+IYF/FACT
        OMEGAF=0.
        IYOFF=0
        ACTX=0
        WRITE(IOUT,1010)XCENF,YCENF
        if(.not.batch)write(6,1010)XCENF,YCENF
1010    FORMAT(' FNDFLM: XCENF,YCENF',2I8)
999     RETURN
        END
C
C
C
C
C                      *********************************************
C                      *                                           *
C                      *        ****  SUBROUTINE GENSORT ****      *
C                      *                                           *
C                      *********************************************
C
C
C
C=============================================================
C
C
C       MAIN PROGRAM GENSORT
C
C
C  READS REFLEXIONS FROM GENERATE FILE,TRANSFORMS COORDINATES
C  TO SCANNER FRAME AND SORTS RECORD NUMBERS ON X-COORDINATE,
C  WRITES FILE OF SORTED RECORD NUMBERS, X AND Y-COORDINATES
C     MAXIMUM NUMBER OF REFLEXIONS = 100000/300000 (CHANGED FROM 5800
C  SEPT 1st  1986 T.J.G.
C     Value of IM changed to use Multiplets in refinement
C  SEPT 17th 1986 T.J.G.
c
c##### laue mods
c     max number of refs = 100000/300000 for 25 micron!
c     for mode = 0 for seekrs loop over nodals and check against
c                      nodlim2
c     else loop over all spots but in box integration omit spatial
c                       overlaps
C=============================================================
C
C
        SUBROUTINE GENSORT
        COMMON/TREV/NXMAX,NYMAX
        COMMON/SW/ISWTCH(10),oneref,noref,tworef
        COMMON/IOO/IOUT
C
      INCLUDE 'dimgns.finc'
      INCLUDE 'comlaue.finc'
      INCLUDE 'comuab.finc'
      INCLUDE 'commcs.finc'
      INCLUDE 'comori.finc'
      INCLUDE 'comfid.finc'
      INCLUDE 'comhat.finc'
C
C----------- Include RAS, SCN, RFS, REP for old send file.
C----------------------NEW COMSND for FNAME, MODE
C
      INCLUDE 'comsnd.finc'
      INCLUDE 'comras.finc'
      INCLUDE 'comscn.finc'
      INCLUDE 'comrep.finc'
      INCLUDE 'comrfs.finc'
C
        LOGICAL oneref,noref,tworef
        INTEGER VLIMIT,XLOW,XHIGH,YLOW,YHIGH
        DATA LIMIT/2500/,VLIMIT/4000/
      DIMENSION ISTAT(8),NREJGE(8),nusing(8)
      do 99 i=1,8
      nusing(i) = 0
      NREJGE(i)=0
99      istat(i) = 0
      nboxit = 0
      nproit = 0
C
C--------------------- OPEN SORT AND GE FILES
C
       ifail=0
       call ccpdpn(-9,'SORTTEMP','UNKNOWN','U',0,ifail)
c        OPEN(UNIT=9,FILE='SORTTEMP',STATUS='UNKNOWN',FORM='UNFORMATTED')
c########
c        OPEN(UNIT=1,FILE=FNAME,STATUS='OLD',ACCESS='DIRECT',
c     1  FORM='UNFORMATTED')
C
        if(.not.batch)write(6, 1010)
        write(iout, 1010)
 1010   format(' Preparing spot list...')
        XLOW=XMIN+(NXMAX/2+1)
        XHIGH=XMAX-(NXMAX/2+1)
        YLOW=ymin +(NYMAX/2+1)
        YHIGH=ymax -(NYMAX/2+1)
      if(.not.batch)write(6,1011)XLOW,XHIGH,YLOW,YHIGH
      WRITE(iout,1011)XLOW,XHIGH,YLOW,YHIGH
1011      FORMAT(/1X,' Spot X Limits: ',2I8,
     1             ' Spot Y Limits: ',2I8,/)
c##### laue mods
c        ICOL=3+2*(FILM-1)
c        JREC=PCKIDX+1
        NFAILY=0
        MAXREF = MAXRFL
        NFAIL=0
        NREF=0
      infail = 0
      imfail = 0
      ndfail = 0
      nofail = 0
      iifail = 0
      mofail = 0
c
c##### laue mods
      nloop = tospt
      if(mode .eq.0)nloop = numnod
C
C------------------------------------------------- START LOOP---
      do 4 ii=1,nloop
      i = ii
      if ( mode.eq.0) i =nodpt(ii)
      jrec = i
      idec(jrec)=0
      xc = xyge(1,i)
      yc = xyge(2,i)
      jx = xc
      jy = yc
C ---------------------------unpack flags
      nodali = nodal(i)
C      ir = iand(nodali, '01'x)
      im = nodal(i)/8
      IMULT = (NODAL(I)-8*IM)/4
      IMEAS = (NODAL(I)-8*IM-4*IMULT)/2
      IR = (NODAL(I)-8*IM-4*IMULT-2*IMEAS)
C      imult = iand(nodali, '04'x)
C      imeas = iand(nodali, '02'x)
C ----------------------------  statistics histogram
      Nbit = 4*imult + 2*Imeas + ir +1
      ISTAT(nbit) = ISTAT(nbit) + 1
C  --------------------------- omit overlaps if box integration
      if ((. not. profil).or.(. not. correct)) then
         if(ir.ne.0) then
            nofail = nofail + 1
            go to 4
       end if
      endif
C --------------------------- Jump to 2 for mode = 0 (refinement)
        IF(MODE.NE.0) GOTO 2
          if(im.eq.0) then
            imfail = imfail + 1
            go to 4
        end if
        IF(VEE) GOTO 1
C --------------------------- check nodal value is less than nodlim2
      if(im.gt.nodlim2) then
            ndfail = ndfail + 1
            go to 4
      end if
C --------------------------- check x and y limits
        IF(IABS(JX).LT.LIMIT.AND.IABS(JY).LT.LIMIT) THEN
         infail = infail + 1
         GOTO 4
      end if
        GOTO 2
1       IF(IABS(JX).LT.VLIMIT.AND.IABS(JY).LT.LIMIT) GOTO 4
2       CONTINUE
c
C ------ FOR BOTH MODES - imeas set for film 1 based on mint
c
        if(film.gt.1.and.imeas.ne.0) then
            iifail = iifail + 1
            go to 4
      end if
c -------------- Reject overlapped multiplets
        if((mode.ne.0).and.(imult.gt.0).and.(ir.ne.0)) then
            mofail = mofail + 1
            goto 4
      end if
        NREF=NREF+1
        IF(NREF.GT.MAXREF) GOTO 8
        IREC(NREF)=JREC
        if (mode.ne.0)then
           if(imult.gt.0) then
             irec(nref) = -jrec
           end if
             if(ir.ne.0)idec(jrec)=1
        end if
21      continue
        CALL XYCALC(XCAL,YCAL,XC,YC)
        IX(NREF)=ANINT(XCAL*FACT)
        IF(IX(NREF).GT.XLOW.AND.IX(NREF).LT.XHIGH) GOTO 3
        NFAIL=NFAIL+1
        NREF=NREF-1
        GOTO 4
3       IY(NREF)=ANINT(YCAL*FACT)
        IF(IY(NREF).GT.YLOW.AND.IY(NREF).LT.YHIGH)GO TO 31
        NFAILY=NFAILY+1
        NREF=NREF-1
      goto 4
C --------------------------- check flags for refinement nodals
31      nbit = 4*imult + 2*imeas + ir + 1
      nusing(nbit) = nusing(nbit) + 1
4       CONTINUE
C
C---------------------------------------------------------- END LOOP--
        IF(NREF.GT.0)GO TO 5
        WRITE(IOUT,1000)
1000    FORMAT(' SPOT RANGE TOO SMALL TO FIND ANY SPOTS FOR',
     1           1X,'SEEKRS REFINEMENT')
        if(.not.batch)write(6,1000)
        STOP
5       continue
      if(xtek) call tkclr
c
c      write statistics
c
      nsing = 0
      nnod = 0
      nrefnd = 0
      irejge = 0
      do 40 i=1,4
      nsing = nsing + istat(i)
      nrefnd = nrefnd + nusing(i)
      nrejge(i) = istat(i) - nusing(i)
      irejge = irejge + nrejge(i)
      j = i+4
      nrefnd = nrefnd + nusing(j)
      nrejge(j) = istat(j) - nusing(j)
      irejge = irejge + nrejge(j)
40      nnod = nnod + istat(j)
      NNref = nnod + nsing
c------------------------------WRITE STATS. BOTH MODES
      if(.not.batch)write(6,111)
      WRITE(IOUT,111)
111      format(/1x,'        Summary of input reflection data',/)
      if(.not.batch)write(6,112)nnref
      WRITE(IOUT,112)NnREF
112      format(1x,' Total number of reflections           : ',i6,/)
      if(.not.batch)write(6,113) Nsing
      WRITE(IOUT,113)NSING
113     format(1x,'                   ','  SINGLETS          : ',i6)
      if(.not.batch)write(6,117)Nnod
      WRITE(IOUT,117)NNOD
117     format(1x,'                   ',' MULTIPLETS         : ',i6,/)
c
      if(.not.batch)write(6,1211)
      write(iout,1211)
      if(.not.batch)write(6,122)
      write(iout,122)
      if(.not.batch)write(6,123)   istat(1),istat(3),istat(5),istat(7)
      if(.not.batch)write(6,124)   istat(2),istat(4),istat(6),istat(8)
      write(iout,123) istat(1),istat(3),istat(5),istat(7)
      write(iout,124) istat(2),istat(4),istat(6),istat(8)
c
      if(.not.batch)write(6,1171) irejge
      write(iout,1171) irejge
      IF(INFAIL.GT.0.and..not.batch)write(6,1172) infail
      IF(INFAIL.GT.0) write(iout,1172) infail
      IF(NFAIL.GT.0.and..not.batch)write(6,1173) nfail
      IF(NFAIL.GT.0) write(iout,1173) nfail
      IF(NFAILY.GT.0.and..not.batch)write(6,1174) nfaily
      IF(NFAILY.GT.0) write(iout,1174) nfaily
c
      IF(nofail.GT.0.and..not.batch)write(6,1181) nofail
      IF(nofail.GT.0) write(iout,1181) nofail
      IF(imfail.GT.0.and..not.batch)write(6,1182) imfail
      IF(imfail.GT.0) write(iout,1182) imfail
      IF(ndfail.GT.0.and..not.batch)write(6,1183) ndfail
      IF(ndfail.GT.0) write(iout,1183) ndfail
      IF(iifail.GT.0.and..not.batch)write(6,1184) iifail
      IF(iifail.GT.0) write(iout,1184) iifail
      IF(mofail.GT.0.and..not.batch)write(6,1185) mofail
      IF(mofail.GT.0) write(iout,1185) mofail
1171      format(1x,' Total number of rejections            : ',i6)
1181      format(1x,'                    On overlap flag    : ',i6)
1182      format(1x,'                    On nodal flag      : ',i6)
1183      format(1x,'                    On nodal index     : ',i6)
1184      format(1x,'                    On Intensity       : ',i6)
1185      format(1x,'                    On overlap/mult    : ',i6)
1172      format(1x,'                    On Inner Limits    : ',i6)
1173      format(1x,'                    On Outer X Limits  : ',i6)
1174      format(1x,'                    On Outer Y Limits  : ',i6,/)
c
      if(.not.batch)write(6,1211)
      write(iout,1211)
      if(.not.batch)write(6,122)
      write(IOUT,122)
      if(.not.batch)write(6,123)   nrejge(1),nrejge(3),nrejge(5),
     +                               nrejge(7)
      if(.not.batch)write(6,124)   nrejge(2),nrejge(4),nrejge(6),
     +                               nrejge(8)
      write(IOUT,123) nrejge(1),nrejge(3),nrejge(5),nrejge(7)
      write(IOUT,124) nrejge(2),nrejge(4),nrejge(6),nrejge(8)
c
      if(mode.eq.0) then
      if(.not.batch)write(6,121)Nrefnd
      write(iout,121)Nrefnd
121     format(1x,' Total number of refinement nodals     : ',i6,/)
            else
      if(.not.batch)write(6,1175)Nrefnd
      write(iout,1175)Nrefnd
1175    format(1x,' Total number of usable reflections    : ',i6,/)
      END IF
      if(.not.batch)write(6,1211)
      write(iout,1211)
      if(.not.batch)write(6,122)
      write(IOUT,122)
      if(.not.batch)write(6,123)   nusing(1),nusing(3),nusing(5),
     +                             nusing(7)
      if(.not.batch)write(6,124)   nusing(2),nusing(4),nusing(6),
     +                             nusing(8)
      write(IOUT,123) nusing(1),nusing(3),nusing(5),nusing(7)
      write(IOUT,124) nusing(2),nusing(4),nusing(6),nusing(8)
c
1211    format(1x,'                     SINGLET             MULTIPLET')
122     format(1x,'            ','Measurable    Weak',
     1                       '    Measurable    Weak')
123      format(1x,' Separated   ',i6,   3x,1x,i6,6x,i6,4x,i6)
124      format(1x,' Overlapped  ',i6,   3x,1x,i6,6x,i6,4x,i6/)

C -----------------------WRITE STATS FINAL MODE PRE SORT
      if(.not.batch)write(6,1111)
1111      format(1x,'Sorting reflections.......')
      CALL SORTUP3(NREF,IX,IY,IREC)
        IS=1
        IE=NREF
        ID=1
        IF(MODE.EQ.0) GOTO 6
        IS=NREF
        IE=1
        ID=-1
6       DO 7 I=IS,IE,ID
        IRXY(1)=IREC(I)
        if(irec(i).lt.0) then
            if (PROPT) then
                  Nproit = Nproit + 1
            else
                       Nboxit = Nboxit + 1
            end if
       else
           Nproit = Nproit + 1
        end if
        IRXY(2)=IX(I)
        IRXY(3)=IY(I)
        WRITE(9) IRXY
7       CONTINUE
C
C -------------------------------WRITE STATS FINAL MODE POST SORT
      if(.not.batch)write(6,1100) nref
      write(iout,1100) nref
      if(mode.ne.0) then
      if(.not.batch)write(6,1101) Nproit
      if(.not.batch)write(6,1102) Nboxit
      write(iout,1101) Nproit
      write(iout,1102) Nboxit
      end if
1100      format(1x,' Number of reflections sorted   : ',i6)
1101      format(1x,' Number to be profile fitted    : ',I6)
1102      format(1x,' Number to be box summed        : ',I6)
      if(xtek) call newpg
        CLOSE (UNIT=9)
        RETURN
8       WRITE(IOUT,1003)
        if(.not.batch)write(6,1003)
1003    FORMAT('BUFFERS TOO SMALL FOR SORT')
        STOP
        END
C
c     routine for extracting x,y and flags from Laue
c     data file to store in core
c     input is from Version 2 ge1/ge2 files
c
c     Pella Machin       Sep 1986
c
c
      subroutine getgexy(inunit,nref,ifilm,mint,iprof, nodmax)
c
      integer*1  mhkl(4), nodhkl(4)
C
      INCLUDE 'comlaue.finc'
      INCLUDE 'comuab.finc'
C
      integer*2 intens(24), mflags2
      dimension ibuf(19),buf(19)
      DIMENSION ISTAT(8),nodref(8)
      DIMENSION NCHECK(7,2000)
c
      equivalence (ibuf(1), buf(1))
      equivalence (ibuf(3), intens(1))
      equivalence (ibuf(15),mhkl(1))
      equivalence (ibuf(17),nodhkl(1))
      common/ioo/iout
c
      integer*2 mask31
      data mask31/'001f'x/
c
c     byte array nodal contains nodal n value (5 bits),
c     wavelength ov flag as 1 bit (1=overlap, 0 else)
c     measurable flag as one bit (0=yes,1=no)
c     spatial overlap as one bit (1=overlap, 0 else)
c
      NBAD = 0
      NN = 0
      do 99 i=1,8
      nodref(i)=0
99      istat(i) = 0
      j=0
      write (6, 1010)
 1010 format(' Reading reflections . . .')
c
c     main loop over all reflections
c
      do 100 i=1,nref
      jrec=10+i
      read(inunit, rec=jrec, err=990) ibuf
      xyge(1,i) = buf(1)*100.
      xyge(2,i) = buf(2)*100.
c
      imeas = 0
c     check intensity threshold if not first film IN A RUN!
c         Sept 5th., 1992. decided not necessary - stops
c       lower films being refined if one above not integrated!
c
c     iprof is 0/1 for box/profiles
c      if (ifilm .gt .1 ) then
c         jj=iprof*12  + (ifilm-1)
c         ilast = intens(jj)
c         if(ilast.le.mint) imeas = 1
c      endif
c
      mflags2 = mhkl(1)
      iov = iand (mflags2, '0040'x)
      imult = iand (mflags2,mask31)
C      imult = iand (mflags2, '001F'x)
      nod = iand (mflags2, '0020'x)
c      IF(IMULT.EQ.1.AND.NODHKL(1).EQ.0) GOTO 75
c      IF(IMULT.GT.1.AND.NODHKL(1).GT.0) GOTO 75
c      NBAD = NBAD + 1
c      IF(NBAD.GT.75) GOTO 75
c      IF(NBAD.EQ.1) THEN
c          IF(XTEK) THEN
c            CALL NEWPG
c            if(.not.batch)write(6,71)
c            WRITE(IOUT,71)
c          END IF
c      END IF
c71    FORMAT(/1X,' FLAG ERROR: NO,Rec,X,Y,NOD,Nodhkl,Imult,Imeas,Iov')
c      NX = NINT(XYGE(1,I))
c      NY = NINT(XYGE(2,I))
c     if(.not.batch)write(6,72)NBAD,I,NX,NY,Nod,NODHKL(1),IMULT,IMEAS,IOV
c      WRITE(IOUT,72)NBAD,I,NX,NY,Nod,NODHKL(1),IMULT,IMEAS,IOV
c72      format(4x,9I8)
c75      continue
      IMULT = IMULT - 1
      if (imult.gt.0) imult = 1
      if(iov.ne.0) iov = 1
      if(nod. eq. 0. and. nodhkl(1). eq.0) go to 30
      if(nod. ne. 0. and. nodhkl(1). ne.0) go to 30
c
c     error with nodals
  900 if(.not.batch)write(6,902) i, nod, nodhkl(1)
      write(iout, 902) i, nod, nodhkl(1)
  902 format(' ** error in nodal flags for spot',i5,
     1 ' flag=',i4,' number=',i5)
      nod = 0
      nodhkl(1)=0
      go to 30
c
c     error on file input
  990 if(.not.batch)write(6,992)i, jrec
      write(iout,992) i, jrec
  992 format(' ** error on input in getgexy, spot=',i5,
     1 ' record=',i6)
      stop
c
c     nodal flags OK so store info (packed) and pointer
c      (after checking nodal value does not exceed max)
   30 if(nodhkl(1). gt. nodmax) then
        nod = 0
        nodhkl(1) = 0
      endif
      nodal(i)= nodhkl(1)*8 + imult*4 +imeas*2 +iov
      if(nod. ne. 0) then
         j=j+1
         if(j.le.2000) then
            nodpt(j)= i
c check flags for refinement nodals
      nbit = 4*imult + 2*imeas + iov + 1
      nodref(nbit) = nodref(nbit) + 1
         endif
      endif
c
      NN = NN + 1
      Nbit = 4*imult + 2*Imeas + iov +1
      ISTAT(nbit) = ISTAT(nbit) + 1
c
  100 continue
c
      IF(XTEK) CALL TKCLR
      if(j.gt.2000) then
         if(.not.batch)write(6,110) j
  110    format(' over 2000 nodals (',i5,'), rest lost')
         j=2000
      endif
      numnod = j
c
c      write statistics
c
      nsingle = 0
      nnodal = 0
      do 40 i=1,4
      nsingle = nsingle + istat(i)
      j = i+4
40      nnodal = nnodal + istat(j)
c
      if(.not.batch)write(6,111)
      write(IOUT,111)
111      format(/1x,'            Summary of reflection data',/)
      if(.not.batch)write(6,112)NN
      write(IOUT,112)NN
112      format(1x,' Total number of reflections           : ',i6,/)
c
      if(.not.batch)write(6,113) Nsingle
      if(.not.batch)write(6,114)
      if(.not.batch)write(6,115) istat(1),istat(3)
      if(.not.batch)write(6,116) istat(2),istat(4)
      write(IOUT,113) Nsingle
      write(IOUT,114)
      write(IOUT,115) istat(1),istat(3)
      write(IOUT,116) istat(2),istat(4)
113     format(1x,'                   ','  SINGLETS          : ',i6)
114     format(1x,'              ','Measurable      Weak')
115      format(1x,' Separated     ',i6,   3x,3x,i6)
116      format(1x,' Overlapped    ',i6,   3x,3x,i6,/)
c
      if(.not.batch)write(6,117)Nnodal
      if(.not.batch)write(6,118)
      if(.not.batch)write(6,119) istat(5),istat(7)
      if(.not.batch)write(6,120) istat(6),istat(8)
      write(IOUT,117)Nnodal
      write(IOUT,118)
      write(IOUT,119) istat(5),istat(7)
      write(IOUT,120) istat(6),istat(8)
117     format(1x,'                   ',' MULTIPLETS         : ',i6)
118     format(1x,'              ','Measurable      Weak')
119      format(1x,' Separated     ',i6,   3x,3x,i6)
120      format(1x,' Overlapped    ',i6,   3x,3x,i6,/)
c
      if(.not.batch)write(6,121)Numnod
      write(IOUT,121)Numnod
      if(.not.batch)write(6,1211)
      write(iout,1211)
      if(.not.batch)write(6,122)
      if(.not.batch)write(6,123) nodref(1),nodref(3),nodref(5),
     1  nodref(7)
      if(.not.batch)write(6,124) nodref(2),nodref(4),nodref(6),
     1  nodref(8)
      write(IOUT,122)
      write(IOUT,123) nodref(1),nodref(3),nodref(5),nodref(7)
      write(IOUT,124) nodref(2),nodref(4),nodref(6),nodref(8)
121     format(1x,'               ','REFINEMENT NODALS       : ',i6,/)
1211    format(1x,'                     SINGLET             MULTIPLET')
122     format(1x,'            ','Measurable    Weak',
     1                       '    Measurable    Weak')
123      format(1x,' Separated   ',i6,   3x,1x,i6,6x,i6,4x,i6)
124      format(1x,' Overlapped  ',i6,   3x,1x,i6,6x,i6,4x,i6/)
      IF(XTEK) CALL NEWPG
C -----------------------DEBUG - WRITE NODPT ARRAY
c      if(.not.batch)write(6,56)
c      WRITE(IOUT,56)
c56      FORMAT(/1X,  ' NODAL ARRAY: Rec,X,Y,Nodhkl,Imult,Imeas,Iov',/)
c      DO 60 J=1,NUMNOD
c      I = NODPT(J)
c      IM = NODAL(I)/8
c      nodali = nodal(i)
c      IMULT = IAND(NODALi, '04'X)
c      IOV   = IAND(NODALi, '01'X)
c      IMEAS = IAND(NODALi, '02'X)
c      NCHECK(1,J) = I
c      NCHECK(2,J) = XYGE(1,I)
c      NCHECK(3,J) = XYGE(2,I)
c      NCHECK(4,J) = IM
c      NCHECK(5,J) = IMULT
c      NCHECK(6,J) = IMEAS
c60      NCHECK(7,J) = IOV
c          if(.not.batch)write(6,61) ((ncheck(i,j),i=1,7),j=1,numnod)
c          write(IOUT,61) ((ncheck(i,j),i=1,7),j=1,numnod)
c61      format(1x,7i5,4x,7i5)
c          if(xtek)call newpg
      return
      end
C
C
C
C
C
C
C                      *********************************************
C                      *                                           *
C                      *        ****  SUBROUTINE GETHKL  ****      *
C                      *                                           *
C                      *********************************************
C
C
C
C=============================================================
C
C
C       SUBROUTINE GETHKL
C
C  READS AND UNPACKS H,K,L,M,X,Y
C  FROM THE GENERATE FILE.
C
c##### laue mods
c     get from version 2 ge1/ge2 file
C=============================================================
C
C
C
        SUBROUTINE GETHKL(JREC,IH)
        INTEGER IH(6)
c##### laue mods throughout
c       integer JBUF(10)
      integer ibuf(19)
      real*4  rbuf(19)
      integer*1 mhkl(4)
      equivalence (ibuf(15),mhkl(1))
      equivalence (ibuf(1), rbuf(1))
c        READ(1,REC=JREC) JBUF
c        IH(1)=IAND(JBUF(1),'177400'O)/256
c        IF(IH(1).GE.128)IH(1)=-256+IH(1)
c        IH(2)=IAND(JBUF(2),'377'O)
c        IF(IH(2).GE.128)IH(2)=-256+IH(2)
c        IH(3)=IAND(JBUF(2),'177400'O)/256
c        IF(IH(3).GE.128)IH(3)=-256+IH(3)
c        IH(4)=IAND(JBUF(1),'360'O)/16
c        IH(5)=JBUF(3)
c        IH(6)=JBUF(4)
      read(1, rec=jrec+10) ibuf
      ih(1) = mhkl(2)
      ih(2) = mhkl(3)
      ih(3) = mhkl(4)
      ih(5) = rbuf(1)*100. + sign(.5, rbuf(1))
      ih(6) = rbuf(2)*100. + sign(.5, rbuf(2))
c     ???????
      ih(4) = 0
        RETURN
        END
C
C
C     SUBROUTINE TO SET UP THE HAT-MATRIX.
C
C
      SUBROUTINE HATHAT(nobin)
C
      INCLUDE 'comprf.finc'
      INCLUDE 'comhat.finc'
C
      REAL XTX(3,3),BUF1(3),BUF2(3),
     *     XXINV(5000,3),HATT(3,5000)
C
C-----------SET UP HAT MATRIX
C
      IF(PORB.EQ.1)THEN
        NN=HPOBS(nobin)
      ELSE
        NN=HNOBS
      END IF
      DO 100 I=1,NN
         DO 110 J=1,3
            IF(PORB.EQ.1)THEN
              HAT(I,J)=HATP(I,J,nobin)
            ELSE
              HAT(I,J)=HATB(I,J)
            END IF
            HATT(J,I)=HAT(I,J)
110      CONTINUE
100   CONTINUE
C
      DO 200 I=1,3
      DO 200 J=1,3
         XTX(I,J)=0.0
         DO 210 K=1,NN
            PROD=HATT(I,K)*HAT(K,J)
            XTX(I,J)=XTX(I,J)+PROD
210      CONTINUE
200   CONTINUE
C
C-----------------INVERT XTX
C
      CALL MINV(XTX,3,DET,BUF1,BUF2)
C
      DO 300 I=1,NN
         DO 310 J=1,3
            XXINV(I,J)=0.0
            DO 320 K=1,3
               PROD=HAT(I,K)*XTX(K,J)
               XXINV(I,J)=XXINV(I,J)+PROD
320         CONTINUE
310      CONTINUE
300   CONTINUE
C
C----------CALCULATE H(I)'S-----------
C
      DO 400 I=1,NN
         H(I)=0.0
         DO 410 K=1,3
            PROD=XXINV(I,K)*HATT(K,I)
            H(I)=H(I)+PROD
410      CONTINUE
400   CONTINUE
      RETURN
      END
C
C
C
C
C                      *********************************************
C                      *                                           *
C                      *        ****  SUBROUTINE HISBCK  ****      *
C                      *                                           *
C                      *********************************************
C
C
C
C=============================================================
C
      SUBROUTINE HISBCK(IXIN,IYIN,IBGIN,NBGIN,NCODE)
C
      INCLUDE 'comhis.finc'
      INCLUDE 'commcs.finc'
      INCLUDE 'comuab.finc'
      INCLUDE 'combck.finc'
      INCLUDE 'comfid.finc'
C
      common/iplate/image,mar,moldyn
      logical image,mar,moldyn
      LOGICAL    ERR
      INTEGER    INTENS, ISTRIP(4800), FILM_UNIT
      COMMON /IO_STREAMS/ IN_TERM, OUT_TERM, IN_DATA, OUT_DATA
      INTEGER             IN_TERM, OUT_TERM, IN_DATA, OUT_DATA
      character*60 sfile
      goto (100,200,300,100,400), ncode
c
c    store x,y coordinates of histogram bin
c    or retrieve bg for integration
c
100      if(.not.BGPLAN) then
      ixhbg = (((ixin-xmin) * 12)/(xmax-xmin)) + 1
      iyhbg = (((iyin-ymin) * 12)/(ymax-ymin)) + 1
        else
      ixhbg = (((ixin-xhmin) * 12)/(xhmax-xhmin)) + 1
      iyhbg = (((iyin-yhmin) * 12)/(yhmax-yhmin)) + 1
      end if
      if(ixhbg.lt.1) ixhbg = 1
      if(iyhbg.lt.1) iyhbg = 1
      if(ixhbg.gt.12) ixhbg = 12
      if(iyhbg.gt.12) iyhbg = 12
      if(ncode.eq.1) return
c
c   retrieve correct bg for this spot
c   note reduction for lower already achieved
c   below (ncode = 5)
c
      Ibgin = histbg(ixhbg,iyhbg)
c
c   set correct cuts for this spot
c
      cutu = fcut * float(Ibgin)
      cutl = -0.8 * fcut * float(Ibgin)
      return
c
c    add av bg for this spot into histogram
c
200      histbg(ixhbg,iyhbg) = histbg(ixhbg,iyhbg) +
     1                        nint(float(Ibgin)/float(nbgin))
      histn(ixhbg,iyhbg) = histn(ixhbg,iyhbg) + 1
      return
c
c    finally get average in each bin and print out
c    check for zeros and replace by av of neighbours
c
300     itemp = 0
         do ii = 1,12
      do jj = 1,12
            if(histn(ii,jj).eq.0) then
               if(ii.eq.1.and.jj.eq.1) then
                  itemp = 1
               else
               ist = max0(1,ii - 1)
               iend = min0(12,ii + 1)
               jst = max0(1,jj - 1)
               jend = min0(12,jj + 1)
                sub = 0
               hsum = 0
                 do ik = ist,iend
                  do jk = jst,jend
                  hsum = hsum + float(histbg(ik,jk))
                  sub = sub + float(histn(ik,jk))
                  end do
                 end do
               if(sub.eq.0) sub=1
               histn(ii,jj) = 1
               histbg(ii,jj) = nint(hsum/sub)
               end if
            end if
      end do
      end do
            if(itemp.eq.1) then
                sub = 0
               hsum = 0
                 do ik = 1,2
                  do jk = 1,2
                  if(.not.(ik.eq.1.and.jk.eq.1)) then
                  hsum = hsum + float(histbg(ik,jk))
                  sub = sub + float(histn(ik,jk))
                  end if
                  end do
                 end do
               if(sub.eq.0) sub=1
               histn(1,1) = 1
               histbg(1,1) = nint(hsum/sub)
            end if
c
c  save the histogram in lastbg
c
      do ii = 1,12
      do jj = 1,12
            if(histn(ii,jj).eq.0) histn(ii,jj) = 1
            histbg(ii,jj) = histbg(ii,jj) / histn(ii,jj)
            lastbg(ii,jj) = histbg(ii,jj)
      end do
      end do
c
c now make sure we store 'A' film x,y limits in common (his)
c as its these that determine the array position for lower
c films!
c
      xhmin = xmin
      xhmax = xmax
      yhmin = ymin
      yhmax = ymax
c
c
c    print out
c
999      if(.not.batch) write(6,1000)
      write(8,1000)
1000      format(/1x,' Background histogram ',/)
CCC      do ii = 1,12
      do ii = 12,1,-1
        if(.not.BGPLAN) then
CCC        if(.not.batch)write(6,1001) (histbg(jj,ii),jj=12,1,-1)
CCC                      write(8,1001) (histbg(jj,ii),jj=12,1,-1)
        if(.not.batch)write(6,1001) (histbg(jj,ii),jj=1,12)
                      write(8,1001) (histbg(jj,ii),jj=1,12)
        else
CCC        if(.not.batch)write(6,1001) (histbg1(jj,ii),jj=12,1,-1)
CCC                      write(8,1001) (histbg1(jj,ii),jj=12,1,-1)
        if(.not.batch)write(6,1001) (histbg1(jj,ii),jj=1,12)
                      write(8,1001) (histbg1(jj,ii),jj=1,12)
        end if
      end do
1001      format(1x,12i4)
c
      if(BGPLAN) then
      if(.not.batch) write(6,1004)
      write(8,1004)
1004      format(/1x,' Corrected Background histogram ',/)
CCC      do ii = 1,12
      do ii = 12,1,-1
CCC        if(.not.batch)write(6,1001) (histbg(jj,ii),jj=12,1,-1)
CCC                      write(8,1001) (histbg(jj,ii),jj=12,1,-1)
        if(.not.batch)write(6,1001) (histbg(jj,ii),jj=1,12)
                      write(8,1001) (histbg(jj,ii),jj=1,12)
      end do
      end if
      if(ltek) call newpg
      return
c
c ****** >>>>>>>>>>>>    entry for lower films
c
400      do i=1,12
      do j=1,12
      histbg(i,j) = 0
      histbg1(i,j) = 0
      histn(i,j) = 0
      histn1(i,j) = 0
      end do
      end do
      nbadbg = 0
      if(.not.batch) write(6,1002)
      write(8,1002)
1002      format(/1x,' . . . forming Background histogram ',/)
c
c  Base histogram area on same limits as A film
c
      FILM_UNIT = 2
      call flmopn(-2,sfile,iylen,1,OUT_TERM,ERR)
      IF (Image) THEN
         CALL IMPPOS(FILM_UNIT,xhmin,OUT_TERM,ERR)
      ELSE
         CALL FLMPOS(FILM_UNIT,xhmin,OUT_TERM,ERR)
      END IF
c
      do ixstrp = xhmin,xhmax

         IF (Image) THEN
            CALL IMPLRD(FILM_UNIT,ISTRIP,iylen,OUT_TERM,ERR)
         ELSE
            CALL FILMRD(FILM_UNIT,ISTRIP,iylen,OUT_TERM,ERR)
         END IF
c
      ixhbg = (((ixstrp-xhmin) * 12)/(xhmax-xhmin)) + 1
      if(ixhbg.lt.1) ixhbg = 1
      if(ixhbg.gt.12) ixhbg = 12
c
      do j= yhmin,yhmax
        iyhbg = (((j-yhmin) * 12)/(yhmax-yhmin)) + 1
        if(iyhbg.lt.1) iyhbg = 1
        if(iyhbg.gt.12) iyhbg = 12
c
c    add  od's for this stripe into histogram
c    if intensity is much bigger than expected (ie a spot?)
c    dont add in!
c
        intens = istrip(j)
        if(image) intens = intens/1000 + 1
          histbg1(ixhbg,iyhbg) = histbg1(ixhbg,iyhbg) + intens
          histn1(ixhbg,iyhbg) = histn1(ixhbg,iyhbg) + 1
        if(istrip(j).gt.(lastbg(ixhbg,iyhbg)+10)) then
          goto 450
        end if
        histbg(ixhbg,iyhbg) = histbg(ixhbg,iyhbg) + intens
        histn(ixhbg,iyhbg) = histn(ixhbg,iyhbg) + 1
450        continue
      end do
      end do
c
      close (unit=2)
c
c    finally get average in each bin and print out
c    check for zeros and replace by formula and
c    warn!
c
      do ii = 1,12
      do jj = 1,12
            if(histbg(ii,jj).eq.0) then
        histbg(ii,jj) = (float(lastbg(ii,jj) - 36))/1.42 +36
       histn(ii,jj) = 1
       nbadbg = 1
            end if
      end do
      end do
c
      do ii = 1,12
      do jj = 1,12
            histbg(ii,jj) = histbg(ii,jj) / histn(ii,jj)
            if(image) histbg(ii,jj) = histbg(ii,jj)*1000.
            histbg1(ii,jj) = histbg1(ii,jj) / histn1(ii,jj)
            if(image) histbg1(ii,jj) = histbg1(ii,jj)*1000.
            lastbg(ii,jj) = histbg(ii,jj)
      end do
      end do
c
      if(nbadbg.eq.1) then
        if(.not.batch) write(6,1003)
        write(8,1003)
1003      format(/1x,' **** WARNING - abnormal Background ****',/)
      end if
c
c now print out
c
      goto 999
c
c    entry for lower films. reduce values in histogram
c    according to:
c---------- for lower films, reduce bg constants in hist
c---------- to (c-36)*1/1.42 + 36 where 36 is reckoned to
c---------- be the base (14) + (Abg - 14)/4 (22 for ppb)
c---------- and the film factor is 1.42.
c **** for rhino, looks like 24 more appropriate
c
c400      do ii = 1,12
c      do jj = 1,12
c      histbg(ii,jj) = (float(histbg(ii,jj) - 24))/1.42 +24
c      end do
c      end do
c
c now print out
c
c      goto 999
      end
C
C ***BYTE PACKING, NON-STANDARD COMMONS ETC.***
C
C     Unpack bytes
C
      INTEGER FUNCTION IBYTE(IJBA,N)
C
C ***CONVEX VERSION***
C
      INTEGER*2 IJBA(*)
      CALL CCPGTB(IBYTE,IJBA,N)
      RETURN
      END
C
      SUBROUTINE INITT
c   initialize graphics and vdu
      CHARACTER*20 TRM
      ITTYP = 0
      CALL UGTENV('TERM',TRM)
      IF(TRM(1:5).EQ.'xterm') ITTYP = 1
      CALL QGINIT(0,6,ITTYP,LUNSTI(0),LUNSTO(0))
      RETURN
      END
C
C
C
C
C                      *********************************************
C                      *                                           *
C                      *        ****  SUBROUTINE INTEG  ****       *
C                      *                                           *
C                      *********************************************
C
C
C
C=============================================================
C
C
        SUBROUTINE INTEG(RAS,IRAS,MASK,PQVAL,ASPOT,IDR,FULL)
        INTEGER RAS(1),IRAS(5),MASK(1),IDR,P,Q,HX,HY
        REAL ASPOT(5),PQVAL(6)
        LOGICAL FULL
        INTEGER SPOD,SQOD,TPOD,TQOD,SOD,TOD
        INTEGER SPD(-35:35),SQD(-35:35),TPD(-35:35),TQD(-35:35)
        HX=IRAS(1)/2
        HY=IRAS(2)/2
        DO 1 Q=-HY,HY
        SQD(Q)=0
1       TQD(Q)=0
        IJ=0
C
C-------------------------- start sum loop
C
        DO 4 P=-HX,HX
        SPD(P)=0
        TPD(P)=0
        DO 4 Q=-HY,HY
        IJ=IJ+1
        IOD=RAS(IJ)
        IF(MASK(IJ)) 3,4,2
C
C-------------------------  SUMS FOR PEAK
C
2       TPD(P)=TPD(P)+IOD
        IF(.NOT.FULL) GOTO 4
        TQD(Q)=TQD(Q)+IOD
        GOTO 4
C
C----------------------  SUMS FOR BACKGROUND
C
3       SPD(P)=SPD(P)+IOD
        SQD(Q)=SQD(Q)+IOD
4       CONTINUE
C
C--------------------------- end sum loop
C
        SOD=(SPD(0)+SPD(1)+SPD(-1))
        TOD=(TPD(0)+TPD(1)+TPD(-1))
        SPOD=(SPD(1)-SPD(-1))
        DO 5 P=2,HX
        SOD=SOD+(SPD(P)+SPD(-P))
        TOD=TOD+(TPD(P)+TPD(-P))
5       SPOD=SPOD+P*(SPD(P)-SPD(-P))
        SQOD=(SQD(1)-SQD(-1))
        DO 6 Q=2,HY
6       SQOD=SQOD+Q*(SQD(Q)-SQD(-Q))
        IF(.NOT.FULL) GOTO 9
        TPOD=(TPD(1)-TPD(-1))
        DO 7 P=2,HX
7       TPOD=TPOD+P*(TPD(P)-TPD(-P))
        IF(.NOT.FULL) GOTO 9
        TQOD=(TQD(1)-TQD(-1))
        DO 8 Q=2,HY
8       TQOD=TQOD+Q*(TQD(Q)-TQD(-Q))
C
C-------------------------  BACKGROUND CONSTANTS
C
9       A=SPOD/PQVAL(2)
        B=SQOD/PQVAL(4)
        C=SOD/PQVAL(6)
        ASPOT(2)=C*PQVAL(5)
        ASPOT(1)=TOD-ASPOT(2)
C
C---------- CALCULATE RMS. BACKGROUND RESIDUAL AFTER PLANE FITTING
C
        SD=0.0
        IJ=0
        DO 10 P=-HX,HX
        APC=A*P+C
        DO 10 Q=-HY,HY
        IJ=IJ+1
        IF(MASK(IJ).GE.0) GOTO 10
        DIFF=RAS(IJ)-(APC+B*Q)
        SD=SD+DIFF*DIFF
10      CONTINUE
        ASPOT(3)=SQRT(SD/PQVAL(6))
        IF(.NOT.FULL) RETURN
C
C-------------------------- CATCH ZERO SPOTS
C
        IF(ASPOT(1).NE.0.0)GO TO 11
        ASPOT(4)=0.
        ASPOT(5)=0.
        RETURN
11      CONTINUE
        ASPOT(4)=(TPOD-A*PQVAL(1))/ASPOT(1)*IDR
        ASPOT(5)=(TQOD-B*PQVAL(3))/ASPOT(1)
        RETURN
        END
C
      SUBROUTINE IP_BEXPAN(A,IA,NXY)
      INTEGER*2 A(*)
      DIMENSION IA(*)
      CALL CCPI2I(IA,A,NXY,.FALSE.,.FALSE.)
      RETURN
      END
C
      SUBROUTINE IP_BPACK(N,IB,IV)
      INTEGER*2 IB(*),JV
      JV=IV
      IB(N)=JV
      RETURN
      END
C
      SUBROUTINE IP_BSWAP(K1,K2,IP)
      COMMON/PEL/IOD,IBUF(5120),NEXTR
      COMMON/CPEL/IARR(14000)
      INTEGER*2 IOD,IBUF,IARR
      DO 110 K=K1,K2
       IARR(IP)=IBUF(K)
       IP=IP+1
110   CONTINUE
      RETURN
      END
C
      SUBROUTINE IP_CBPACK(I)
      COMMON/PEL/IOD,IBUF(5120),NEXTR
      COMMON/CPEL/IARR(14000)
      INTEGER*2 IOD,IBUF,IARR
      IARR(I)=IOD
      RETURN
      END
C
      SUBROUTINE IP_CBYTE(I)
      COMMON/PEL/IOD,IBUF(5120),NEXTR
      INTEGER*2 IOD,IBUF
      IOD=IBUF(I)
      RETURN
      END
C
      INTEGER FUNCTION IP_IBYTE(IJBA,N)
      INTEGER*2 IJBA(*)
      CALL CCPGI2(IP_IBYTE,IJBA,N)
      RETURN
      END
C
C
C
C
C
C
C                      *********************************************
C                      *                                           *
C                      *        ****  SUBROUTINE MEAS    ****      *
C                      *                                           *
C                      *********************************************
C
C
C
C=============================================================
C
C
C                PROGRAMME MEAS.
C                ----------------
C
C READS STRIPES FROM DISK FILE 'FILM' INTO ARRAY BA.
C SELECTS DATA FOR INDIVIDUAL SPOTS INTO ARRAY BB.
C AS SPOTS ARE COMPLETED, THEY ARE WRITTEN ONTO DISK FILE MOSCO.SP
C EACH RECORD CONTAINS THE DATA FOR ONE SPOT.
C IT STARTS WITH 3 WORDS CONTAINING RECORD NO.,X,Y AND THEN
C A WORD CONTAINING 2*HFWX+1 IN ONE BYTE AND 2*HFWY+1 IN THE OTHER.
C THE OPTICAL DENSITIES THEN FOLLOW,PACKED INTO BYTES.
C
C==============================================================
C
C
C
        SUBROUTINE MEAS
c
cRCD ...Image Plate logical
        common/iplate/image,mar,moldyn
        logical image,mar,moldyn
c
      INCLUDE 'comscn.finc'
      INCLUDE 'comlaue.finc'
C
C----------- Include ORI, MCS, RFS, REP for old SEND file
C
      INCLUDE 'comuab.finc'
      INCLUDE 'comori.finc'
      INCLUDE 'commcs.finc'
      INCLUDE 'comrfs.finc'
      INCLUDE 'comrep.finc'
      INCLUDE 'comras.finc'
C
        COMMON/IOO/IOUT
        COMMON/SW/ISWTCH(10),oneref,noref,tworef
        COMMON/PEL/KJBA,IJBA(5120),nextr
        INTEGER*2 IJBA,kjba
        COMMON/CPEL/BB(14000)
        INTEGER*2 BB
c
c*****************************************
c NEW COMMON TO HANG ON TO RECORD NUMBER > 32767
c*****************************************
c      ADDED TO COMLAUE
C      common/lauebb/NBBREC(300000 OR 100000)
      INTEGER NBBTEM(14000)
C
        LOGICAL oneref,noref,tworef
        INTEGER TWORD,NSP,PNTR,ACTREF
        INTEGER XC,YC,RC,WTX,PNTB(120),PNTC(120),PNTD
        INTEGER HFWX,HFWY,BUF(3),NSIZ,FWX
        INTEGER X(120),Y(120),REC(120),IWORD(120)
        INTEGER HW(240),WX(240)
        LOGICAL FULL,REND,YFULL
        EQUIVALENCE (BUF(1),RC),(BUF(2),XC),(BUF(3),YC)
        DATA TWORD/14000/,NSP/120/
C
        if(.not.batch)write(6,1000)
        WRITE(IOUT,1000)
1000    FORMAT(' COLLECTING DENSITY DATA FOR EACH SPOT ')
C
C---------------- OPEN INPUT AND OUTPUT FILES
C
        ifail=0
        call ccpdpn(-4,'SORTTEMP','OLD','U',0,ifail)
        ifail=0
        call ccpdpn(-26,'MOSTEMP','UNKNOWN','U',0,ifail)
C
C--------------- GET INFORMATION ON 200 SPOTS FROM SORT FILE
C
        IHTOFD=CTOFD*XTOFRA*FACT*0.5
        NECX=XCEN*FACT+0.5
        NECY=YCEN*FACT+0.5
        NR=0
      NDONE = 1
        IWORD(NSP)=0
        PNTB(NSP)=1
        DO 1 M=1,NSP
        ASSIGN 1 TO IRETN
        GOTO 16
1       CONTINUE
C
C---------  PNTB,PNTC
C           THESE ARE MARKERS IN BB TO SHOW WHERE IT IS FILLED
C---------- INDF,INDL:-
C           SHOW WHICH REFLECTIONS ARE ACTIVE IN SORTED FILE
C
        INDF=1
        LINDF=INDF
        INDL=1
        MINDF=1
        ACTREF=0
        YFULL=.FALSE.
        FULL=.FALSE.
        REND=.FALSE.
C
C------------ START SCAN FOR THE FIRST SPOT OR SPOT AFTER A GAP
C
2       WTX=X(MINDF)+HW(2*MINDF-1)
        IBLK=WTX
C
C------------------- INCLUDE THE SPOT IN THIS SCAN
C
3       IER=-1
        CALL RDBLK(2,IBLK,IJBA,NWORD,IER)
        IF(IER.EQ.1) GOTO 4
        WRITE(IOUT,1001) IER
        if(.not.batch)write(6,1001)IER
1001    FORMAT(/'ERROR ON DISK BLOCK READ : IER=',I4/)
        STOP
4       IF(INDL.EQ.NREF) GOTO 7
        IF(FULL) GOTO 7
        MINDL=MOD(INDL,NSP) + 1
        IF(WTX.GT.X(MINDL)+HW(2*MINDL-1)) GOTO 7
        IF (INDL-INDF.GE.NSP-1) GO TO 5
        IF (MINDL.EQ.MINDF) GO TO 6
        PNTD=PNTB(MINDL)-PNTB(MINDF)
        IF(PNTD.GT.0.OR.PNTD.LT.-IWORD(MINDL)) GOTO 6
5       YFULL=.TRUE.
        FULL=.TRUE.
        GOTO 4
6       INDL=INDL+1
        GOTO 4
C
C------------ GET THE INFORMATION FOR THIS SCAN AND START A NEW ONE
C
7       CONTINUE
        IBLK=IBLK-1
C
C---------------- WRITE SPOTS COLLECTED IN THIS STRIPE TO BB
C
        DO 9 J=INDF,INDL
        MJ=MOD(J-1,NSP)+1
        YC=Y(MJ)
        KMN=YC-HW(2*MJ)
        KMX=YC+HW(2*MJ)
        PNTR=PNTC(MJ)
C
C--------- PNTR IS USED AS WORD POINTER THEN CHANGED TO BYTE POINTER
C
        IF(PNTR.NE.PNTB(MJ)) GOTO 8
c
c*************************************************************
c
c  PUT RECORD NUMBER INTO  NBBTEM
c
c*************************************************************
c
      NBBTEM(PNTR) = REC(MJ)
      IF(IABS(REC(MJ)).LE.32000) THEN
              BB(PNTR)=REC(MJ)
           ELSE
            BB(PNTR)= 0
      END IF
        BB(PNTR+1)=X(MJ)
        BB(PNTR+2)=YC
C
C----------------------- MULTIPLY BOTH BYTES BY 2 AFTER ADDING 1
C
        IFULLX=2*HW(2*MJ-1)+1
        IFULLY=2*HW(2*MJ)+1
C@@@@        BB(PNTR+3)=256*IFULLY+IFULLX
      CALL BPACK(7,BB(PNTR),IFULLX)
      CALL BPACK(8,BB(PNTR),IFULLY)
        if(.not.image)then
        PNTR=2*PNTR+7
        else
        pntr=pntr+4
        endif
8       CONTINUE
        if(.not.image)then
        CALL BSWAP(KMN,KMX,PNTR)
        else
        call ip_bswap(kmn,kmx,pntr)
        endif
        PNTC(MJ)=PNTR
        WX(MJ)=WX(MJ)-1
9       CONTINUE
        IF(INDL-INDF+1.GT.ACTREF) ACTREF=INDL-INDF +1
        WTX=WTX-1
C
C--------------------- SEE IF SPOT IS FINISHED
C
10      IF(WX(MINDF).EQ.0) GOTO 14
C
C-----------  READ NEW SPOTS FOR THOSE COMPLETED ON THIS STRIPE
C
11      IF(LINDF.EQ.INDF) GOTO 13
        M=MOD(LINDF-1,NSP)+1
        IF(REND) GOTO 12
        ASSIGN 12 TO IRETN
        GOTO 16
12      LINDF=LINDF+1
        GOTO 11
13      IF(INDF.LE.INDL) GOTO 3
        FULL=.FALSE.
        GOTO 2
C
C-------------------- WRITE OUT COMPLETED SPOTS AND READ IN NEW ONES
C                              hopefully one at once!
14      LEN=IWORD(MINDF)-4
        IST=PNTB(MINDF)
        CALL PWRITE(nbbtem(ist),BB(IST),BB(IST+4),LEN,26)
C
C**************************************************************
C
C MAKE SURE WEVE GOT REC. NO IN NBBREC
C
C**************************************************************
      NBBREC(NDONE) = NBBTEM(IST)
      IF(IABS(NBBREC(NDONE)).GT.32000) GOTO 141
      IF(NBBREC(NDONE).EQ.BB(IST)) THEN
            GOTO 141
          ELSE
              if(.not.batch)write(6,142) NDONE,NBBREC(NDONE),BB(IST)
142              FORMAT(1X,'ERROR. NUM, NBBREC, BB(IST) :',3I8)
            STOP
      END IF
141      NDONE = NDONE + 1
        IF(ISWTCH(1).EQ.0) GOTO 15
        NXX=2*HW(2*MINDF-1)+1
        NYY=2*HW(2*MINDF)+1
        CALL ODPLOT(BB(PNTB(MINDF)+4),NXX,NYY,-1)
15      INDF=INDF+1
        MINDF=MOD(INDF-1,NSP)+1
        IF(INDF.LE.NREF) GOTO 10
        IF(YFULL) WRITE(IOUT,1002)
        IF(YFULL.and..not.batch)write(6,1002)
1002    FORMAT('  BUFFER WAS FULL')
        WRITE(IOUT,1003) ACTREF
        if(.not.batch)write(6,1003)ACTREF
1003    FORMAT('  MAX. NO. OF ACTIVE REFLEXIONS=',I6)
        WRITE(IOUT,1004) NREF
        if(.not.batch)write(6,1004)NREF
1004    FORMAT(I6,' REFLEXIONS RECORDED IN MEAS')
        CLOSE (UNIT=2)
        CLOSE(UNIT=26)
        RETURN
16      READ(4,END=17) BUF
        NR=NR+1
        X(M)=XC
        Y(M)=YC
        REC(M)=RC
        FX=IABS(XC-NECX)
        IFX=FX
        IF(VEE) FX=IABS(IFX-IHTOFD)
        FY=IABS(YC-NECY)
        N1=FX*(FX*VARAS(2)+VARAS(1))+0.5
        N2=FY*(FY*VARAS(3)+VARAS(1))+0.5
        HFWX=(NXS+N1)/2
        HFWY=(NYS+N2)/2
        FWX=2*HFWX+1
        HW(2*M-1)=HFWX
        HW(2*M)=HFWY
        WX(M)=FWX
        if(.not.image)then
        IWORD(M)=(FWX*(2*HFWY+1)+1)/2+4
        else
        iword(m)=fwx*(2*hfwy+1)+4
        endif
        M1=M-1
        IF(M.EQ.1) M1=NSP
        PNTB(M)=PNTB(M1)+IWORD(M1)
        IF(PNTB(M)+IWORD(M).GT.TWORD) PNTB(M)=1
        PNTC(M)=PNTB(M)
        GOTO IRETN
17      REND=.TRUE.
        IF(NR.EQ.NREF) GOTO IRETN
        WRITE(IOUT,1005) NREF,NR
        if(.not.batch)write(6,1005)NREF,NR
1005    FORMAT(/'SHOULD BE',I6,'RECORDS'/'EOF AFTER',I6,'RECORDS'/)
        STOP
        END
C
C
C
C                      *********************************************
C                      *                                           *
C                      *        ****  SUBROUTINE MINV   ****       *
C                      *                                           *
C                      *********************************************
C
C
C
C=============================================================
C
C       SUBROUTINE MINV SEE SSP PAGE 118
C
C=============================================================
C
C
C
        SUBROUTINE MINV(A,N,D,RL,RM)
        REAL A(*),RL(*),RM(*),D
        INTEGER L(N),M(N)
        D=1.0
        NK=-N
        DO 18 K=1,N
        NK=NK+N
        L(K)=K
        M(K)=K
        KK=NK+K
        BIGA=A(KK)
        DO 2 J=K,N
        IZ=N*(J-1)
        DO 2 I=K,N
        IJ=IZ+I
        IF(ABS(BIGA)-ABS(A(IJ))) 1,2,2
1       BIGA=A(IJ)
        L(K)=I
        M(K)=J
2       CONTINUE
C
C  ------------------------  INTERCHANGE ROWS
C
        J=L(K)
        IF(J-K) 5,5,3
3       KI=K-N
        DO 4 I=1,N
        KI=KI+N
        HOLD=-A(KI)
        JI=KI-K+J
        A(KI)=A(JI)
4       A(JI)=HOLD
C
C  ------------------------- INTERCHANGE COLUMNS
C
5       I=M(K)
        IF(I-K)8,8,6
6       JP=N*(I-1)
        DO 7 J=1,N
        JK=NK+J
        JI=JP+J
        HOLD=-A(JK)
        A(JK)=A(JI)
7       A(JI)=HOLD
C
C  ----------------------  DIVIDE COLUMN BY MINUS PIVOT
C
8       IF(BIGA)10,9,10
9       D=0.0
        RETURN
10      DO 12 I=1,N
        IF(I-K) 11,12,11
11      IK=NK+I
        A(IK)=A(IK)/(-BIGA)
12      CONTINUE
C
C --------------------------  REDUCE MATRIX
C
        DO 15 I=1,N
        IK=NK+I
        HOLD=A(IK)
        IJ=I-N
        DO 15 J=1,N
        IJ=IJ+N
        IF(I-K)13,15,13
13      IF(J-K) 14,15,14
14      KJ=IJ-I+K
        A(IJ)=HOLD*A(KJ)+A(IJ)
15      CONTINUE
C
C ----------------------------  DIVIDE ROW BY PIVOT
C
        KJ=K-N
        DO 17 J=1,N
        KJ=KJ+N
        IF(J-K) 16,17,16
16      A(KJ)=A(KJ)/BIGA
17      CONTINUE
C
C ----------------------- PRODUCT OF PIVOTS
C
C       D=D*BIGA
C
C --------------------REPLACE PIVOT BY RECIPROCAL
C
        A(KK)=1.0/BIGA
18      CONTINUE
C
C ------------------FINAL ROW AND COLUMN INTERCHANGE
C
        K=N
19      K=(K-1)
        IF(K) 26,26,20
20      I=L(K)
        IF(I-K) 23,23,21
21      JQ=N*(K-1)
        JR=N*(I-1)
        DO 22 J=1,N
        JK=JQ+J
        HOLD=A(JK)
        JI=JR+J
        A(JK)=-A(JI)
22      A(JI)=HOLD
23      J=M(K)
        IF(J-K) 19,19,24
24      KI=K-N
        DO 25 I=1,N
        KI=KI+N
        HOLD=A(KI)
        JI=KI-K+J
        A(KI)=-A(JI)
25      A(JI)=HOLD
        GOTO 19
26      RETURN
        END
C      *****************************************************************
C       *                                                *
C       *  This version of INTLAUE prepared for export 12/10/92.           *
C      *  The history is somewhat chequered but runs something         *
C      *  like this:                                          *
C      *            The basic framework still resembles the            *
C      * original Alan Wonacott MOSFLM which was implemented on the      *
C      * Daresbury VAX by Pella Machin and Trevor Greenhough in 1982   *
C      * (ref DL/CSE/TM23). This suite of programs was exported to UAB *
C      * (Alabama) by TJG in 1984 where a major rewrite to include       *
C      * profile fitting was performed. (J.A.C., 19,400-409, 1986).      *
C      * A further major rewrite for Laue films, begun by PAM and TJG  *
C      * in 1986, has been completed by TJG and Annette Shrive in 1988.*
C      * Further modifications for new BG determination and Overlap    *
C      * deconvolution and radial masks by AKS and TJG are included in *
C      * this version, as are image plate modifications by  TJG, AKS   *
C       * and Richard Denny (Keele). To the best of our knowledge      *
C      * accreditation and ownership now reside with T.J. Greenhough   *
C      * this program being maintained and distributed from Keele       *
C      * University to both individuals and Daresbury to then form a       *
C      * part of the Daresbury Laboratory Laue Software Suite.            *
C      *                                                *
C      *****************************************************************
C
c
c
        PROGRAM MOSUAB
C
C       COMMON VARIABLES
c
cRCD ...Image Plate logical
        common/iplate/image,mar,moldyn
        logical image,mar,moldyn
C
      INCLUDE 'comsnd.finc'
      INCLUDE 'comori.finc'
      INCLUDE 'comras.finc'
      INCLUDE 'comscn.finc'
      INCLUDE 'comfid.finc'
      INCLUDE 'comrfs.finc'
      INCLUDE 'commcs.finc'
      INCLUDE 'comuab.finc'
      INCLUDE 'comhat.finc'
      INCLUDE 'comtem.finc'
      INCLUDE 'commask.finc'
      INCLUDE 'commaskl.finc'
C
        COMMON /EXTRAS/ JUMPAX
        COMMON/THRESH/IJNK1,IMTHR,IMREF
        COMMON/IOO/IOUT
        common/PEL/IBA,IDUM(5120),NEXTR
      integer*2 idum,iba
        COMMON/SW/ISWTCH(10),oneref,noref,tworef
        Character*4 stat,toggle(2)
        Data toggle(1)/'OFF '/,toggle(2)/' ON '/
      character*6 aword
      integer intdm(9)
      real realdm(6)
        DATA NWORD/2560/,ELIMIT/8./
        LOGICAL REPEAT,MORE,Batch_Mode,oneref,noref,tworef
      EXTERNAL BREPRT
c##### laue mods - insert extra common for open_ge and initialise
      common/io_streams/ in_term, out_term, in_data, out_data
      integer*4          in_term, out_term, in_data, out_data
      dimension x_c(6), y_c(6), w_c(6), y_scal(6), x_to_fra(6)
      real*4 twists(6), tilts(6), bulges(6)
      common/fgname/ge_file,iendpos
      character*40 ge_file
        character*1 junk
c
      ge_file = 'interactive'
      in_term = 5
      out_term = 6
      in_data = 5
      out_data = 6
c
C --- CONFUSING. BGPLAN IS ACTUALLY TO TELL US IF WE ARE
C---  DOING B AND/OR C FILMS IN SAME RUN AS A
C
C---------------------- initialize Timer
C
        iflag=0
        call ccptim(iflag,cpu,elaps)
        IBA=0
C
C       open unit 11 for reading. **Use unit 5 now instead**
C
c         open(unit=11,file='SYS$INPUT:',status='UNKNOWN')
C
c##### laue mods Temp mod while debugging
c
c        OPEN(UNIT=8,file='intlaue.log',STATUS='NEW',
c    1          DISP='PRINT/DELETE')
        ifail=0
        call ccpdpn(-8,'LOGFILE','NEW','F',0,ifail)
c         OPEN(UNIT=8,file='intlaue.log',STATUS='NEW')
        IOUT=8
C
C
C-----------------------------FIND OUT IF BATCH
C
        Iswtch(1) = 0
        Iswtch(2) = 1
        Iswtch(3) = 0
        Iswtch(4) = 0
        Iswtch(5) = 0
        Iswtch(9) = 0
        Ltek = .False.
        Xtek = .False.
        Batch = Batch_Mode()
        If (Batch) Isw2 = Iswtch(2)
C
      mar = .false.
      moldyn = .false.
      image = .false.
        CORRECT=.FALSE.
      cent_in = .false.
      streak =.false.
      imaxod = 230
C
C------ open unit 10 for interactive mode ***Use unit 6 now***
C
c         If(Batch) open(unit=10,file='NL:',status='unknown')
c         If(.Not.Batch) open(unit=10,file='SYS$OUTPUT:',status='unknown')
        If (Batch) goto 10
C
C---------------------------CHECK ON TERMINAL STATUS
C
C=====================================================
C       CALL TKCLR
C       CALL MOVTX(0,0)  ****** FOR DL ****
C       CALL TKCLR
        LTEK = .TRUE.
        XTEK = .TRUE.
C=====================================================
C       if(.not.batch)write(6,1010)
C       WRITE(IOUT,1010)
C1010    FORMAT(/1X,' IS THE TEKTRONIX AVAILABLE? (Y/N)',$)
C       read(5,1020) JUNK
1020    FORMAT(A1)
C        WRITE(IOUT,1030)JUNK
1030    FORMAT(1X,A1)
C        CALL NOYES(JUNK,ISTEK)
C       LTEK=.FALSE.
C       IF(ISTEK.EQ.1) LTEK=.TRUE.
C       if(.not.batch)write(6,1040)
C       WRITE(IOUT,1040)
C1040   FORMAT(/1X,' IS THIS A TEKTRONIX TERMINAL? (Y/N)',$)
C       read(5,1020) JUNK
C       WRITE(IOUT,1030)JUNK
C       CALL NOYES(JUNK,ISTEK)
C       XTEK=.FALSE.
C       IF(ISTEK.EQ.1) XTEK=.TRUE.
c          IF(LTEK) OPEN (UNIT=12,FILE='SYS$SCOPE:',STATUS='UNKNOWN',
c      1      CARRIAGECONTROL='NONE',SHARED)
        call initt
      call qgentr
C
C---------------------- NEXT 2 LINES NOT FOR DL
C
        IF(LTEK) CALL MOVTX(0,0)
        IF(LTEK) CALL TKCLR
C
C------------------------------ WRITE HEADER
C
10      if(.not.batch)write(6,1050)
        WRITE(iout,1050)
1050    FORMAT( /,15X,'  INTLAUE: Laue Image Integration Software',
     1          /,15X,'  ----------------------------------------',
     2          /,15X,'      T.J. Greenhough and A.K. Shrive',
     3          /,15X,'University of Keele and Daresbury Laboratory',
     4          /,15X,'(with thanks to P.A. Machin & A.J. Wonacott)',
     5          /,15x,'      Latest Update March 2nd, 1994.',/)
       CALL CPUTIME(0)
C
C------------------  GET GENERATE FILENAME AND OPEN IT
C
c##### laue mods - open ge file
c
20       call open_ge(1, 13, ge_file, iendpos, iendrec)
c
C
C-------------------------------- SWITCH OPTIONS
C---------------------------- CHECK FOR AV SPOT PROFILE
C
c------------------------ remove Iprp from end for Laues
c
        If(Batch) then
            read(5,*) Iswtch(2),Iswtch(4),Iswtch(5),Ipro,Iprw,
     1                       Ibth,Icorr,Istreak,Ibinv,IPorF,iouter
            if(IPorF.ge.1) image = .true.
            dstor = 1
            if(IPorF.eq.1) then
                  mar = .true.
                  dstor =2 
            endif
            if(IPorF.eq.2) then
                  moldyn = .true.
                  dstor = 3
                  IPorF = 1
            endif
      else
            write(6,907)
              write(iout,907)
907     format(' IMAGE PLATE DATA (Y/N) [N]:',$)
              read(5,1020) junk
              write(iout,1030)junk
            IPorF = 0
              if(junk.eq.'Y'.or.junk.eq.'y') then
                  image=.true.
                  IPorF = 1
                  Imaxod = 65000
            endif
            write(6,9071)
              write(iout,9071)
9071    format(' MAR (Spiral) IMAGE PLATE DATA (Y/N) [N]:',$)
              read(5,1020) junk
              write(iout,1030)junk
            dstor =3 
            moldyn = .true.
              if(junk.eq.'Y'.or.junk.eq.'y') then
                  mar=.true.
                  moldyn = .false.
                  dstor =2 
            endif
            dstor = 1
        endif
c
        Isw2 = Iswtch(2)
        If(Batch) Iswtch(5) = 1 - Iswtch(5)
        If(Batch) goto 110
        ISWTCH(1)=0
        ISWTCH(9)=0
c
        if(.not.batch)write(6,1090)
        WRITE(IOUT,1090)
1090    FORMAT(' INNER REF AND AVERAGE SPOT PROFILE AFTER IMAGE',
     1              1X,'CENTERING?(Y/N) [No]',$)
        read(5,1020)JUNK
        WRITE(IOUT,1030)JUNK
        iswtch(2) = 0
        CALL NOYES(JUNK,ISWTCH(2))
      ISW2=ISWTCH(2)
c
      if(.not.moldyn) then
        if(.not.batch)write(6,1091)
        WRITE(IOUT,1091)
1091    FORMAT(' OUTER REFINEMENT (Y/N) [Yes]',$)
      iouter = 1
      else
        if(.not.batch)write(6,1092)
        WRITE(IOUT,1092)
1092    FORMAT(' OUTER REFINEMENT (Y/N) [No]',$)
      iouter = 0
      endif
        read(5,1020)JUNK
        WRITE(IOUT,1030)JUNK
        CALL NOYES(JUNK,iouter)
C
C-------------------------CHECK FOR SPOT PROFILES IN PROCESS
C
        if(.not.batch)write(6,1100)
        WRITE(IOUT,1100)
1100    FORMAT(' CALC AND DISPLAY AV SPOT PROFILES ',
     1           'IN PROCESS?(Y/N) [No]',$)
        read(5,1020)JUNK
        WRITE(IOUT,1030)JUNK
        iswtch(4) = 0
        CALL NOYES(JUNK,ISWTCH(4))
C
C------------------------- CHECK ON B AND C FILM STRATEGY
C
      if(.not.image) then
        if(.not.batch)write(6,1110)
        WRITE(IOUT,1110)
1110    FORMAT(' FORCE LOWER FILMS TO BE MEASURED ',
     1           'AS A ?(Y/N) [Yes]',$)
        read(5,1020)JUNK
        WRITE(IOUT,1030)JUNK
        iswtch(5) = 1
        CALL NOYES(JUNK,ISWTCH(5))
        ISWTCH(5)=1-ISWTCH(5)
      endif
C
C-------------------RETURN HERE FOR FURTHER FILMS NOT B,C
C
  100   CONTINUE
C
C---------------------------------- NOW GET PROFILE STRATEGY
C
        PROFIL = .FALSE.
        If(Batch) goto 110
        if(.not.batch)write(6,1120)
        WRITE(IOUT,1120)
1120    FORMAT(' DO YOU REQUIRE PROFILE FITTING?(Y/N) [Yes]',$)
        read(5,1020)JUNK
        WRITE(IOUT,1030)JUNK
        ipro = 1
        CALL NOYES(JUNK,IPRO)
110     IF(IPRO.NE.0) PROFIL=.TRUE.
        IBOTH = .FALSE.
        IF(.NOT.PROFIL) GOTO 140
        If(Batch) goto 113
        if(.not.batch)write(6,112)
        WRITE(IOUT,112)
112     FORMAT(' PROFILES AND BOX INTEGRATION?(Y/N) [No]',$)
        read(5,1020)JUNK
        WRITE(IOUT,1030)JUNK
        ibth = 0
        CALL NOYES(JUNK,Ibth)
113     IF(Ibth.ne.0) IBOTH=.TRUE.
        IF(BATCH) GOTO 1131
        if(.not.batch)write(6,1121)
        WRITE(IOUT,1121)
1121    FORMAT(' DO YOU WANT TO CORRECT FOR OVERLAPS? (Y/N) [No]',$)
        read(5,1020)JUNK
        WRITE(IOUT,1030)JUNK
        ICORR=0
        CALL NOYES(JUNK,ICORR)
1131    IF(ICORR.EQ.1)THEN
          CORRECT=.TRUE.
          HOVLAP=1.1
      hcut = 5.0
          IF(.NOT.BATCH)THEN
          if(.not.batch)write(6,1122)
          WRITE(IOUT,1122)
          read(5,*)HOVLAP,hcut
          IF(HOVLAP.EQ.0.0)HOVLAP=1.1
      if(hcut.eq.0.0) hcut = 5.0
          WRITE(IOUT,1126)HOVLAP,hcut
          END IF
        END IF
1122    FORMAT(' ENTER REJECTION LEVELS FOR OVERLAPS [1.1,5.0]:',$)
1123    FORMAT(2F8.4)
1126    FORMAT(1H+,2X,2F8.4,/)
C
C---------------------------------  GET BG CONSTANTS
C
        CUT = 0.2
        NUMBIN = 17
        inrad = 0
        inrad2 = 0
        If(Batch) THEN
         read(5,*) numbin, cut, hovlap, hcut, npwk1,
     1                 IMAXOD, INRAD, INRAD2
1125     format(I4,3F8.4,4I4)
         goto 115
        END IF
        if(.not.batch)write(6,1130)cut,numbin
        WRITE(IOUT,1130)cut,numbin
1130    FORMAT(' ENTER BG FRAC ,NUMBER OF BINS (5,9,17):[',
     1            f7.5,',',i3,']:',$)
        read(5,*)CUT,nUMBIN
1135    FORMAT(F8.4,I4)
        IF(CUT.EQ.0) CUT = 0.2
        IF(NUMBIN.EQ.0) NUMBIN = 17
        WRITE(IOUT,1140)CUT,NUMBIN
1140    FORMAT(1H+,2x,F8.4,I5)
C
C----------------- FIND BIN RADII BASED ON RESOLUTION
C
115     NOUTER = (NUMBIN-1)
        NINOUT = (NUMBIN/16) +1
        NEQUAL = NOUTER/NINOUT + NOUTER
          If(Batch.and.Inrad.ne.0) goto 118
        INRAD  = (1200**3)/NEQUAL
        CUBERT = 1.0/3.0
c***********************
c   multiply by 2 here for 25micron (cube root of 2 cubed)
C***********************
        INRAD  = 2*(FLOAT(INRAD)**(CUBERT))
          If(Batch) goto 118
116     write(iout,1145)inrad
        if(.not.batch)write(6,1145) inrad
1145    format(/1x,'INNER BIN RADIUS IN RASTERS [',I4,'] :',$)
        read(5,*) INRADI
1146    FORMAT(I4)
        IF(INRADI.NE.0) INRAD = INRADI
        write(iout,1147)inrad
1147    format(1H+,I5)
118     IF(NINOUT.LE.1) GOTO 119
          if(Batch.and.Inrad2.ne.0) goto 120
c***********************
c   multiply by 2 here for 25micron (cube root of 2 cubed)
C***********************
        RAD2 = ((1200**3) + (FLOAT(INRAD)**3)/(2.0**3))/2.0
        INRAD2 = 2*(RAD2**CUBERT)
          If(Batch) goto 120
        WRITE(IOUT,1144) INRAD2
        if(.not.batch)write(6,1144) INRAD2
1144    FORMAT(' OUTER BIN RADIUS IN RASTERS [',I4,'] :',$)
        read(5,1146) INRADI
        IF(INRADI.NE.0) INRAD2 = INRADI
        write(iout,1147)inrad2
119          If(Batch) goto 120
C
C----------------- GET MIN INT FOR INCLUSION IN PROFILES
C                 AND MAXIMUM ALLOWABLE OD FOR THIS MEDIUM
C  Note that input imaxod is uncorrected for film characteristics
C
      if(image) then
        inod = 65000
        innpwk = 150
      else
        inod = 230
        innpwk = 40
      endif
        if(.not.batch)write(6,1150)innpwk,inod
        WRITE(IOUT,1150)innpwk,inod
1150    FORMAT(/1x,'ENTER MIN I FOR PROFILES AND MAX OD [',
     1       i5,i6,']:',$)
        read(5,*)NPWK1,IMAXOD
1148    FORMAT(I4,I4)
        if(npwk1.eq.0) npwk1 = innpwk
      if(imaxod.eq.0)  imaxod = inod
        WRITE(IOUT,1160)NPWK1,IMAXOD
1160    FORMAT(1h+,2x,2I5)
C
C---------------- CHECK FOR VARIABLE WEIGHTED PROFILES
C
        if(.not.batch)write(6,1170)
        WRITE(IOUT,1170)
1170    FORMAT(/,' DO YOU REQUIRE VARIABLE ',
     1          'WEIGHTED PROFILES?(Y/N) [Yes]',$)
        read(5,1020)JUNK
        WRITE(IOUT,1030)JUNK
        iprw = 1
        CALL NOYES(JUNK,IPRW)
120     WTPRO=.FALSE.
        IF(IPRW.NE.0) WTPRO=.TRUE.
C
C---------------- CHECK FOR PARTIAL PROFILES
C                multiplets for laues. assume always yes
C
        PROPT =.true.
c       If(Batch) goto 130
c        if(.not.batch)write(6,1180)
c        WRITE(IOUT,1180)
c1180    FORMAT(' APPLY PROFILES TO PARTIALS?(Y/N)',$)
c        read(5,1020)JUNK
c        WRITE(IOUT,1030)JUNK
c        CALL NOYES(JUNK,IPRP)
c130     PROPT=.FALSE.
c        IF(IPRP.NE.0) PROPT=.TRUE.
        CALL CUTBCK(CUT,INRAD,INRAD2,NPWK1,NUMBIN)
140     streak = .false.
      binvar = .false.
      If(Batch) then
            if(istreak.ne.0) streak=.true.
            if(streak) then
                      read(5,*)cmask,dmask,kmask,bminor,border
                    if (ibinv.ne.0) binvar=.true.
                    if (binvar) then
                       read(5,*)ammax,ammin,themaxx
                       themax = themaxx*atan(1.0)/45.
                    end if
                    goto 145
            end if
            goto 150
      end if
c
        if(.not.batch)write(6,1119)
        WRITE(IOUT,1119)
1119    FORMAT(' DO YOU REQUIRE VARIABLE RADIAL MASKS?(Y/N) [Yes]',$)
        read(5,1020)JUNK
        WRITE(IOUT,1030)JUNK
        istreak = 1
        CALL NOYES(JUNK,Istreak)
      IF(Istreak.ne.0) streak=.true.
      if(.not.streak) goto 141
        if(.not.batch)write(6,1118)
        WRITE(IOUT,1118)
1118    FORMAT(/1x,'ENTER Amajor,Dmask,Kmask,Bminor,Border',
     1              '[0.8,100.0,0.0,0.4,1.0]:',$)
        read(5,1117)cmask,dmask,kmask,bminor,border
1117    FORMAT(5f8.4)
145     if(cmask.eq.0.0) cmask= 0.8
       if(dmask.eq.0.0) dmask=100.0
      if(bminor.eq.0.0) bminor = 0.4
      if(border.eq.0.0) border = 1.0
      if(batch) goto 146
        WRITE(IOUT,1116)cmask,dmask,kmask,bminor,border
1116    FORMAT(1h+,2x,5f8.4)
146     if(streak)then
          if(.not.batch) then
            write(6,2119)
            WRITE(IOUT,2119)
2119        FORMAT(' DO YOU REQUIRE VARIABLE BINNING?(Y/N) [No]',$)
            read(5,1020)JUNK
            WRITE(IOUT,1030)JUNK
            ibinv = 0
            CALL NOYES(JUNK,Ibinv)
            IF(Ibinv.ne.0) binvar=.true.
            if(.not.binvar) goto 141
            write(iout,2118)cmask,cmask
2118        format(/1x,'ENTER Amax,Amin,Themax',
     1                '[',2f5.2,',0.0]:',$)
            read(5,2117)ammax,ammin,themaxx
2117        format(3f8.4)
          end if
          if(ammax.eq.0.0) ammax = cmask
          if(ammin.eq.0.0) ammin = cmask
          if(themaxx.eq.0.0) themax = 0.0
          if(batch) goto 150
          themax = themaxx*atan(1.0)/45.
          WRITE(IOUT,2116)ammax,ammin,themaxx
2116      FORMAT(1h+,2x,3f8.4)
        end if
141      if(batch) goto 150
        If(.not.LTEK) goto 150
C
C----------------- CHECK FOR FILMPLOT
C
        if(.not.image) then
            if(.not.batch) write(6,1185)
              WRITE(IOUT,1185)
        else
            if(.not.batch) write(6,1186)
              WRITE(IOUT,1186)
      endif
1185    FORMAT(' FILMPLOT AFTER LOADING FIDUCIALS?(Y/N) [No]',$)
1186    FORMAT(' PLOT IMAGE AND CALCULATED PATTERN?(Y/N) [No]',$)
        read(5,1020)JUNK
        WRITE(IOUT,1030)JUNK
        Iswtch(3) = 0
        CALL NOYES(JUNK,ISWTCH(3))
C
C------------------  READ GENERATE FILE AND POSITION
C------------------------- FOR CORRECT FILM
C
150     BGPLAN = .FALSE.
      if(streak) then
            wtpro = .false.
            iprw = 0
      end if
c
c---sort out ref options
c
      noref  = .false.
        oneref = .false.
      tworef = .true.
      if(iswtch(2).gt.iouter) then
            iswtch(2) = iswtch(2) - 1
            isw2 = iswtch(2)
      endif
      itemp = iswtch(2) + iouter
        IF(itemp.EQ.0) noref = .true.
        IF(itemp.EQ.1) ONEREF = .true.
      if(itemp.ne.2) tworef = .false.
c
c------------------------ output for batch
c
c         If(.not.batch) goto 155
        Write(iout,1190)
      Write(iout,1138)toggle(IPorF+1)
        Write(iout,1191)toggle(ISW2+1)
        Write(iout,1157)toggle(Iouter+1)
        Write(iout,1192)toggle(Iswtch(4) +1)
        if(.not.image) Write(iout,1193)toggle(2-Iswtch(5))
        Write(iout,1139)toggle(Ipro+1)
      Write(iout,1155)toggle(Istreak+1)
      Write(iout,1156)cmask,dmask,kmask,bminor,border
      Write(iout,2155)toggle(Ibinv+1)
      Write(iout,2156)ammax,ammin,themaxx
        if(.not.profil) goto 155
        Write(iout,1149)toggle(icorr+1)
        Write(iout,1195)toggle(iprw+1)
        Write(iout,1159)toggle(Ibth+1)
        Write(iout,1196)numbin
        Write(iout,1197)inrad
        If(NINOUT.gt.1)Write(iout,1198)inrad2
        Write(iout,1189)cut,hovlap,hcut
        Write(iout,1199)npwk1,imaxod
1190    format(/1x,' Control data:')
1138    format(2x ,'     Image plate processing         ',A)
1191    format(2x ,'     Inner ref and average spot     ',A)
1157    format(2x ,'     Outer refinement               ',A)
1192    format(2x ,'     Average expanded spot display  ',A)
1193    format(2x ,'     Measure lower films as A film  ',A)
1139    format(2x ,'     Profile fitting                ',A)
1155      format(2x ,'     Radial Masking                 ',A)
1156    format(2x ,'     Mask Definition (a,d,k,b,bg)  ',
     1         5F7.3)
2155      format(2x ,'     Variable binning              ',A)
2156      format(2x ,'     Bin variation (amax,amin,themax)  ',
     1         3F8.3)
1149    format(2x ,'     Overlap deconvolution          ',A)
1195    format(2x ,'     Variable weighted profiles     ',A)
1159    format(2x ,'     Profile and Box integration    ',A)
1196    format(2x ,'     Number of profile bins        ',I4)
1197    format(2x ,'     Inner bin radius (rasters)    ',I4)
1198    format(2x ,'     Outer bin radius (rasters)    ',I4)
1189    format(2x ,'     Bg cutoff, Pk cutoffs (H,J)   ',
     1         3F8.3)
1199    format(2x ,'     Profile min and max OD        ',2I6)
C
C---------- Now get going!
C
155     CALL START
C
C----------------------------  SEARCH FOR FILM CORNERS
C
C------------------------------RETURN HERE FOR B AND C
C
160     ISWTCH(2)=ISW2
        if(film.gt.1) imaxod = 230
        CALL FNDFLM
        REPEAT=.FALSE.
C
C----------------------  LOCATE FIDUCIAL MARKS
C
         CALL FIDUS
c        if(.not.image)CALL FIDUS
C
C----------------------  TRANSFER FILM IMAGE TO DISK
C
        CALL DSCAN
        CALL CPUTIME(1)
C
C
        MORE=.TRUE.
        Imthr = 0
        Imref = 1
        Irep = 0
        I2REF = .FALSE.
        IF(FILM.GT.1.AND.ISWTCH(5).EQ.0) GOTO 290
        IF(ISWTCH(3).EQ.1) GOTO 200
C
C-----------------  FIND REFINEMENT SPOTS IN CENTRAL PORTION OF FILM
C
180     CALL CENTRS(REPEAT)
      if(oneref) goto 240
      if(noref) goto 240
        IF(NRS.GT.10) GOTO 190
        WRITE(IOUT,1200) NRS
        if(.not.batch)write(6,1200)NRS
1200    FORMAT(' ONLY',I6,' REFINEMENT SPOTS FOUND')
        GOTO 200
C
C------------------------- REFINEMENT OF FILM TRANSFORMATION
C
190     If(oneref) goto 240
      If(noref) goto 240
        If(vee) then
                CALL RVDIST
        Else
                CALL RDIST
        End If
        IF(RMSRES.LT.6) GOTO 210
C
C-------------------------  PLOT CALCULATED SPOT POSITIONS TOGETHER
C-------------------------    WITH DISPLAYED SPOTS FROM FILM SCAN
C
200     If(.not.Ltek) stop
        CALL FLMPLOT
        GOTO 180
210     IF(.NOT.MORE) GOTO 220
        MORE=.FALSE.
        IF(ESTART.GT.ELIMIT) GOTO 180
220     IF(ISWTCH(2).EQ.0) GOTO 240
        IF(REPEAT) GOTO 230
        IF(VEE) CALL SELECT
        REPEAT=.TRUE.
        NRSOLD=NRS
        GOTO 180
C
C------------------------- CHECK ON MEASUREMENT BOX DIMENSIONS
C
230     CALL CHKRAS
        NRS=NRSOLD
        IF(ISWTCH(2).EQ.1) GOTO 180

C
C------------------------- CALCULATE VARIABLE BOX PARAMETERS,
C------------------------- MAXX,MAXY AND MAXR
C
240     CALL CPUTIME(1)
        CALL RMAXR
C
c ---- use this for no entry into spot finding
c
c      if(noref) then
c            call rdist
c            goto 280
c      endif
C
C----------------- REPLACE WRSEND BY MODE = 0 HERE
C
        MODE = 0
C
C------------------------- SELECT 20 REFINEMENT SPOTS FROM CENTRS
C
        IF(.NOT.(VEE.AND.REPEAT)) CALL SELECT
C
C------------------------- SORT FULLY RECORDED SPOTS FROM GENERATE FILE
C
        CALL GENSORT
C
C------------------------- SEARCH FOR REFINEMENT SPOTS OVER WHOLE OF FILM
C
c####################################
        if(Oneref) nrs=0
      if(Noref) nrs=0
c####################################
        NRSOLD=NRS
        MORE=.TRUE.
250     NRS=NRSOLD
        CALL CPUTIME(1)
        CALL SEEKRS
C
C------------------------- REFINEMENT OF FILM TRANSFORMATION
C
        If(vee) then
                CALL RVDIST
        Else
                CALL RDIST
        End IF
c
c---- jump out now for noref (noref!)
c
      if(noref) goto 280
c
        If (Irep.eq.1) goto 270
        If (Batch) Irep = 1
        If (Batch) goto 260
        if(.not.batch)write(6,1210)
1210    FORMAT(' DO YOU WANT TO REPEAT THIS REFINEMENT? [Yes]',$)
        read(5,1020)JUNK
        Irep = 1
        CALL NOYES(JUNK,IREP)
        IF(IREP.EQ.0) GOTO 270
C
C---------------------------- REPLACE WRSEND BY MODE = 0 HERE
C
260     MODE = 0
        CALL GENSORT
        GOTO 250
270     IF(.NOT.MORE) GOTO 280
        MORE=.FALSE.
        IF(ESTART.GT.ELIMIT) GOTO 250

C
C------------------------- WRITE REFINED FILM PARAMETERS BACK
C------------------------- TO GENERATE FILE
C
280     ITILT=TILT/FDIST
        ITWIST=TWIST/FDIST
        IBULGE=BULGE/FDIST
        IF(VEE) IBULGE=BULGE/FDIST*18000./3.14159
c
c##### laue mods
c
c      NOW READ IN GE FILE PARAMETERS, CORRECT FOR THIS RUN
c      AND WRITE BACK OUT. NOTE THAT THE CENTRES READ IN
c      ARE NOT CHANGED BY THE PROGRAM!
c      *** WRITE OUT EVEN IF CENT_IN IS NOT TRUE ***
c      Lower films NOT_AS_A are done below
c
c********** READ IN GE PARAMETERS
c
      if (ltek) call newpg
      read(1,rec=2) aword,x_cen_fs,y_cen_fs,(w_fs(i),i=1,5)
      read(1,rec=3) w_fs(6),intdm,realdm,intg1,intg2,intg3
      read(1,rec=5) x_c,y_c, w_c, delta
      read(1,rec=6) twists, tilts, bulges, dump
      read(1,rec=7) y_scal, x_to_fra, mint, epsi, roff_in, toff_in
c
c********** PRINT OUT GE PARAMETERS
c
      write(8,1770)
      if(.not.batch) write(6,1770)
      write(8,1771) x_cen_fs(film),y_cen_fs(film),
     1                w_fs(film),x_c(film),y_c(film),w_c(film),
     1                y_scal(film),x_to_fra(film)
      if(.not.batch) write(6,1771) x_cen_fs(film),y_cen_fs(film),
     1                 w_fs(film),x_c(film),y_c(film),w_c(film),
     1                 y_scal(film),x_to_fra(film)
      if(.not.image) then
        write(8,1772) twists(film),tilts(film),bulges(film)
           if(.not.batch) then 
               write(6,1772) twists(film),tilts(film),bulges(film)
           endif
      else if (mar) then
        write(8,1773) twists(film),tilts(film),roff_in,toff_in
           if(.not.batch) then 
               write(6,1773) twists(film),tilts(film),roff_in,toff_in
           endif
      else if(moldyn) then
        write(8,1774) twists(film),tilts(film)
           if(.not.batch) then 
               write(6,1774) twists(film),tilts(film)
           endif
      endif
1770  format(/1x,' Input  x_cen  y_cen   w_f    x_c    y_c    w_c   ',
     1                        'y_scale xtofra')
1771      format(1x,7x,2f7.2,6f7.4,/)
1772      format(2x,'Input  twist,tilt,bulge: ',3f9.4)
1773      format(2x,'Input  twist,tilt,roff,toff: ',4f9.4)
1774      format(2x,'Input  twist,tilt: ',2f9.4)
c
c********** UPDATE GE PARAMETERS
c
      x_cen_fs(film)=float(xcenf)/100.
      y_cen_fs(film)=float(ycenf)/(100.*yscal)
      w_fs(film) = omegaf*180./(4.0*atan(1.0))      
      x_c(film) = float(ccx)/100.
      y_c(film) = float(ccy)/(100.*yscal)
      w_c(film) = ccom
      twists(film) = twist/fdist
      tilts(film) = tilt/fdist
      bulges(film) = bulge/fdist
      y_scal(film)=yscal
      x_to_fra(film)=xtofra
c
c********** WRITE OUT NEW GE PARAMETERS
c
      write(1,rec=2) aword,x_cen_fs,y_cen_fs,(w_fs(i),i=1,5)
      write(1,rec=3) w_fs(6),intdm,realdm,intg1,intg2,intg3
        write(1,rec=5) x_c, y_c, w_c, delta
        write(1,rec=6) twists, tilts, bulges, dump
        write(1,rec=7) y_scal, x_to_fra, mint, epsi, roff, toff
c
c********** PRINT OUT NEW GE PARAMETERS
c
      write(8,1775)
      if(.not.batch) write(6,1775)
      write(8,1776) x_cen_fs(film),y_cen_fs(film),
     1                w_fs(film),x_c(film),y_c(film),w_c(film),
     1                y_scal(film),x_to_fra(film)
      if(.not.batch) write(6,1776) x_cen_fs(film),y_cen_fs(film),
     1                 w_fs(film),x_c(film),y_c(film),w_c(film),
     1                 y_scal(film),x_to_fra(film)
      if(.not.image) then
        write(8,1777) twists(film),tilts(film),bulges(film)
           if(.not.batch) then 
               write(6,1777) twists(film),tilts(film),bulges(film)
           endif
      else if (mar) then
        write(8,1778) twists(film),tilts(film),roff,toff
           if(.not.batch) then 
               write(6,1778) twists(film),tilts(film),roff,toff
           endif
      else if(moldyn) then
        write(8,1779) twists(film),tilts(film)
           if(.not.batch) then 
               write(6,1779) twists(film),tilts(film)
           endif
      endif
1775  format(1x,' Output x_cen  y_cen   w_f    x_c    y_c',
     1                        '    w_c   y_scale xtofra')
1776      format(1x,7x,2f7.2,6f7.4,/)
1777      format(2x,'Output twist,tilt,bulge: ',3f9.4)
1778      format(2x,'Output twist,tilt,roff,toff: ',4f9.4)
1779      format(2x,'Output twist,tilt: ',2f9.4)
c
c ************************************************************
c
        if(.not.batch) then
            write(6,1786)
1786    FORMAT(' Terminate processing now? (Y/N) [Yes]',$)
        read(5,1020)JUNK
      if(junk.eq.'N'.or.junk.eq.'n') goto 310
      close unit=1
      stop
      endif
c
c ************************************************************
c
        GOTO 310
C
C---------------- MEASURE REFINEMENT SPOTS ON 'B' OR 'C' FILM IN A PACK
C
290     CALL RMAXR
        IF(LTEK) CALL TKCLR
c
c----- use this to skip spot finding
c
c      if(noref) then
c            call rdist
c            goto 310
c      endif
        CALL NEXT
C
C------------------------- REFINEMENT OF FILM TRANSFORMATION
C
        If(vee) then
                CALL RVDIST
        Else
                CALL RDIST
        End IF
c
c---- jump out now for noref 
c
      if(noref) goto 310
c
300     IF(.NOT.MORE) GOTO 310
        MORE=.FALSE.
        GOTO 290
C
C------------------------- REPLACE WRSEND BY MODE = 1 HERE
C
310     MODE = 1
c
c------------------------ write back new xtofra,yscal if lower film
c                         measured same as A. That for A and those
c                         lower films not as A is done above.
c
        IF(FILM.eq.1.OR.ISWTCH(5).ne.0) GOTO 312
c
c********** READ IN GE PARAMETERS
c
      if (ltek) call newpg
      read(1,rec=2) aword,x_cen_fs,y_cen_fs,(w_fs(i),i=1,5)
      read(1,rec=3) w_fs(6),intdm,realdm,intg1,intg2,intg3
      read(1,rec=5) x_c,y_c, w_c, delta
      read(1,rec=6) twists, tilts, bulges, dump
      read(1,rec=7) y_scal, x_to_fra, mint
c
c********** PRINT OUT GE PARAMETERS
c
      write(8,1770)
      if(.not.batch) write(6,1770)
      write(8,1771) x_cen_fs(film),y_cen_fs(film),
     1                w_fs(film),x_c(film),y_c(film),w_c(film),
     1                y_scal(film),x_to_fra(film)
      if(.not.batch) write(6,1771) x_cen_fs(film),y_cen_fs(film),
     1                 w_fs(film),x_c(film),y_c(film),w_c(film),
     1                 y_scal(film),x_to_fra(film)
      write(8,1772) twists(film),tilts(film),bulges(film)
      if(.not.batch) then 
               write(6,1772) twists(film),tilts(film),bulges(film)
      endif
c
c********** UPDATE GE PARAMETERS
c
      x_cen_fs(film)=float(xcenf)/100.
      y_cen_fs(film)=float(ycenf)/(100.*yscal)
      w_fs(film) = omegaf*180./(4.0*atan(1.0))      
      x_c(film) = float(ccx)/100.
      y_c(film) = float(ccy)/(100.*yscal)
      w_c(film) = ccom
      twists(film) = twist/fdist
      tilts(film) = tilt/fdist
      bulges(film) = bulge/fdist
      y_scal(film)=yscal
      x_to_fra(film)=xtofra
c
c********** WRITE OUT NEW GE PARAMETERS
c
      write(1,rec=2) aword,x_cen_fs,y_cen_fs,(w_fs(i),i=1,5)
      write(1,rec=3) w_fs(6),intdm,realdm,intg1,intg2,intg3
        write(1,rec=5) x_c, y_c, w_c, delta
        write(1,rec=6) twists, tilts, bulges, dump
        write(1,rec=7) y_scal, x_to_fra, mint
c
c********** PRINT OUT NEW GE PARAMETERS
c
      write(8,1775)
      if(.not.batch) write(6,1775)
      write(8,1776) x_cen_fs(film),y_cen_fs(film),
     1                w_fs(film),x_c(film),y_c(film),w_c(film),
     1                y_scal(film),x_to_fra(film)
      if(.not.batch) write(6,1776) x_cen_fs(film),y_cen_fs(film),
     1                 w_fs(film),x_c(film),y_c(film),w_c(film),
     1                 y_scal(film),x_to_fra(film)
        write(8,1777) twists(film),tilts(film),bulges(film)
        if(.not.batch) then 
               write(6,1777) twists(film),tilts(film),bulges(film)
        endif
c
c ************************************************************
c
        if(.not.batch) then
            write(6,1786)
        read(5,1020)JUNK
      if(junk.eq.'N'.or.junk.eq.'n') goto 312
      close unit=1
      stop
      endif
c
c ************************************************************
c
312     continue
c
c##### laue mods
c
C
C------------------------- CLOSE TEKTRONIX CHANNEL
C
        IF(XTEK) CALL ENDTX
C
C------------------------- SORT ALL REFLEXIONS IN GENERATE FILE
C
        CALL GENSORT
C
C------------------------- MEASURE ALL REFLEXIONS IN FILE
C
        Call CPUTIME(1)
        CALL MEAS
C
C------------------------- PROCESS THE MEASUREMENTS FOR EACH SPOT
C
        Call CPUTIME(1)
        CALL PROCESS
        Call CPUTIME(1)
        FILM=FILM+1
        BGPLAN = .TRUE.
        If(Batch) read(5,1220) Stat
1220    format(A)
        If(stat.eq.'STOP') goto 330
        If(stat.eq.'stop') goto 330
        If(stat.eq.'END ') goto 20
        If(stat.eq.'end ') goto 20
c
c##### laue mods
c
      if(image) goto 330
        If (Film.gt.Films) goto 320
        if(batch) goto 1226
        IMORE = 1
        if(.not.batch)write(6,1225)
1225    FORMAT(' PROCESS NEXT FILM IN PACK ?(Y/N) [YES]',$)
        read(5,1020)JUNK
        CALL NOYES(JUNK,IMORE)
        IF(IMORE.EQ.0) GOTO 330
1226    If(Ltek) Call NEWPG
        GO TO 160
C
C-------------------- END OF PACK
C
320     continue
        imore = 0
        if(.not.batch)write(6,1230)
1230    FORMAT(' ANY MORE FILMS TO PROCESS?(Y/N) [NO]',$)
        read(5,1020)JUNK
        CALL NOYES(JUNK,IMORE)
        If(Ltek) CALL TKCLR
        IF(IMORE.EQ.1) GOTO 100
330     continue
        STOP
        END
c
      SUBROUTINE MOVTX(IX,IY)
c   replace movetx with calls to qgmove pdc 6/6/91
      X = FLOAT(IX)
      Y = FLOAT(IY)
      CALL QGMOVE(X,Y)
      RETURN
      END
C
      SUBROUTINE NEWPG
      CALL SCPAUS
      CALL TKCLR
      RETURN
      END
C
C
C
C                      *********************************************
C                      *                                           *
C                      *        ****  SUBROUTINE NEXT   ****       *
C                      *                                           *
C                      *********************************************
C
C
C
C=============================================================
C
C
C       ****  SUBROUTINE NEXT  ****
C
C FINDS SPOTS SUITABLE FOR REFINEMENT OF FILM CENTRE,
C CRYSTAL TO FILM DISTANCE AND FILM ORIENTATION
C USING SPOTS CHOSEN FROM THOSE MEASURED ON
C A PREVIOUS FILM PACK.
C THE OBSERVED C. OF G. OF THESE SPOTS IS PASSED TO
C OVERLAY REFS
C
C      Changed to select Multiplets (IM = 1) for refinement
C Sept 17th 1986 T.J.G.
c
c##### laue mods - changed to read from core and to select
c               nodals lt nodlim1
C=============================================================
C
C
        SUBROUTINE NEXT
        COMMON/SW/ISWTCH(10),oneref,noref,tworef
        COMMON/IOO/IOUT
        COMMON/PEL/IBA,IJBA(5120),nextr
        COMMON/CPEL/IARR(14000)
        INTEGER*2 IJBA,iba
        INTEGER*2 IARR
        LOGICAL oneref,noref,tworef
C
      INCLUDE 'comori.finc'
      INCLUDE 'comras.finc'
      INCLUDE 'comscn.finc'
      INCLUDE 'comrfs.finc'
      INCLUDE 'commcs.finc'
      INCLUDE 'commask.finc'
      INCLUDE 'commaskl.finc'
      INCLUDE 'comlaue.finc'
      INCLUDE 'comuab.finc'
C
        INTEGER WTX
      integer*2 intens(24)
      integer ibuf(19)
      equivalence (ibuf(3),intens(1))
        LOGICAL FULL
        INTEGER INDF,INDL,LRAS(5)
        INTEGER X(256),Y(256),IREC(256),ISPOT(256),SHX,SHY,PNTR(256)
        INTEGER IWX(256),HWX(256),HWY(256)
        integer nsd(6),numnsd(6)
        EQUIVALENCE (LRAS(1),NXX),(LRAS(2),NYY)
        DATA MAXBUF/5000/
        data nsd /1,5,10,15,20,25/
        CHARACTER*1 JUNK
C
C-----------------------------------------
C
      nzeros = 0
      nbigxy = 0
        DO 1 I=3,5
1       LRAS(I)=IRAS(I)
        IHTOFD=CTOFD*XTOFRA*FACT*0.5
        NECX=XCEN*FACT+0.5
        NECY=YCEN*FACT+0.5
        NRS=0
        DO 2 I=1,256
        ISPOT(I)=0
2       CONTINUE
        do 21 i=1,6
21      numnsd(i) = 0
c        JREC=PCKIDX+1
c        XSIZBIN=(MAXX/8.)
c        YSIZBIN=(MAXY/8.)
      xsizbin = float(xmax - xmin)/16
      ysizbin = float(ymax - ymin)/16
c       IA=3+2*(FILM-1)
      ia= 0
      if(profil) ia = 12
      ia=ia + film-1
C
C------------------  SEARCH FOR STRONGEST FULL SPOTS IN
C----------------------  SUBDIVISIONS OF FILM
C
c##### laue mods
c        DO 3 I=1,TOSPT
c        JREC=JREC+1
c        READ(1,REC=JREC) BUF
c        IR=IAND(IHMR,'17'O)
c        IF(IR.NE.0) GOTO 3
c        IM=IAND(IHMR,'360'O)
C
C************************
C                          FROM IM.NE.0 TO IM.EQ.0
C************************
C
c        IF(IM.EQ.0) GOTO 3
      do 3 ii= 1,numnod
      i = nodpt(Ii)
      im = nodal(i)/8
      if(im.eq.0) goto 3
      if(im.gt.nodlim2) goto 3
      IMULT = (NODAL(I)-8*IM)/4
      IMEAS = (NODAL(I)-8*IM-4*IMULT)/2
      IOV = (NODAL(I)-8*IM-4*IMULT-2*IMEAS)
c        if(imult.gt.0.and.iov.ne.0) goto 3
c        if(film.gt.1. and .imeas.ne.0) go to 3
      jrec = i
c
c        IF(BUF(IA).EQ.9999.OR.BUF(IA).LE.0) GOTO 3
c        XC=JX
c        YC=JY
      read(1,rec=10+i) ibuf
      if(intens(ia).ge.9999.or.intens(ia).le.0) go to 3
      if(intens(ia+6).ge.9999.or.intens(ia+6).le.0) go to 3
      xc = xyge(1,i)
      yc = xyge(2,i)
        CALL XYCALC(XCAL,YCAL,XC,YC)
      k = nint(  (xcal*fact - float(xmin))   / xsizbin)
c        K=(MAXX+XC)/XSIZBIN
        IF(K.GT.15) K=15
        if(k.lt.0) k=0
      j = nint(  (ycal*fact - float(ymin))   / ysizbin) + 1
c        J=(MAXY+YC)/YSIZBIN + 1
        IF(J.LT.1) J=1
        IF(J.GT.16) J=16
        INDX=(k*16)+j
      if(indx.lt.1.or.indx.gt.256) goto 3
c####
c        ISDR=BUF(IA)/BUF(IA+1)
      isdr = intens(ia)/intens(ia+6)
      if(isdr.le.0) goto 3
        IF(ISDR.LT.ISPOT(INDX)) GOTO 3
        ISPOT(INDX)=ISDR
        IREC(INDX)=JREC
c        CALL XYCALC(XCAL,YCAL,XC,YC)
        X(INDX)=ANINT(XCAL*FACT)
        Y(INDX)=ANINT(YCAL*FACT)
3       CONTINUE
c
c------------------------- reduce by sd test but not below 30
c
        do 31 i=1,256
      if(ispot(i).eq.0) goto 31
        nbinsd = (Ispot(i)/5) + 1
        if(nbinsd.gt.6) nbinsd = 6
        if(nbinsd.lt.1) nbinsd = 1
        numnsd(nbinsd) = numnsd(nbinsd) + 1
31      continue
        if(.not.batch)write(6,310) nsd
        write(8,310)  nsd
        if(.not.batch)write(6,311) numnsd
        write(8,311)  numnsd
310     format(/1x,' I/sdI    ',6i6)
311     format( 1x,' Number   ',6i6)
        ntotsd = 0
        do 32 i=1,6
        ii = 7-i
        ntotsd = ntotsd + numnsd(ii)
        nscut = nsd(ii)
        if(ntotsd.ge.30) goto 33
32      continue
33      if(.not.batch)write(6,312) ntotsd,nscut
        write(8,312)  ntotsd,nscut
312     format(/5x,i4,' spots selected with I/sdI above ',i3,/)
C
C-------------------------  COUNT NUMBER OF SPOTS FOUND
C
        NREF=0
        DO 4 I=1,256
        IF(ISPOT(I).LT.nscut) GOTO 4
        NREF=NREF+1
        Y(NREF)=Y(I)
        IREC(NREF)=IREC(I)
        X(NREF)=X(I)
4       CONTINUE
        WRITE(IOUT,1000) NREF
1000    FORMAT(I6,' SPOTS TO BE MEASURED')
        if(.not.batch)write(6,1000)NREF
        CALL SORTDN3(NREF,X,Y,IREC)
C
C------------------------------  SET UP VARIABLE RASTERS
C
        DO 5 I=1,NREF
        FX=IABS(X(I)-NECX)
        IFX=FX
        IF(VEE) FX=IABS(IFX-IHTOFD)
        FY=IABS(Y(I)-NECY)
        N1=FX*(FX*VARAS(2)+VARAS(1))+0.5
        N2=FY*(FY*VARAS(3)+VARAS(1))+0.5
        IHWX=(NXS+N1)/2
        HWX(I)=IHWX
        HWY(I)=(NYS+N2)/2
        IWX(I)=IHWX*2+1
5       CONTINUE
        MAXB=MAXR
        MAXW=(MAXB+1)/2
        MAXB=2*MAXW
        MAXN=MAXBUF/MAXW
        INDF=1
        INDL=1
        IFRST=1
        ILAST=0
        FULL=.FALSE.
C
C------------ GET THE START OF THE RASTER FOR THE FIRST SPOT OR
C------------ FOR A SPOT AFTER A GAP
C
6       CONTINUE
        WTX=X(INDF)+HWX(INDF)
        IBLK=WTX
C
C--------------- TEST IF SORTED SPOT HAS TO BE INCLUDED IN
C----------------- THIS SCAN
C
7       IER=-1
        CALL RDBLK(2,IBLK,IJBA,NWORD,IER)
8       IF(INDL.EQ.NREF) GOTO 9
        IF(FULL) GOTO 9
        IF(WTX.GT.X(INDL+1)+HWX(INDL+1)) GOTO 9
        INDL=INDL+1
        IF(INDL-INDF.EQ.MAXN-1) FULL=.TRUE.
        GOTO 8
C
C----------- GET RESULTS FROM THIS SCAN AND START THE NEXT ONE
C
9       WTX=WTX-1
        IBLK=IBLK-1
C
C----- STORE OPTICAL DENSITIES FOR ALL SPOTS INCLUDED IN THIS SCAN
C
        IF(INDL.LT.INDF) GOTO 13
        DO 12 J=INDF,INDL
        MJ=MOD(J-1,MAXN)
        NJ=MJ*MAXB
        MJ=MJ+1
        IY=Y(J)
        KMN=IY-HWY(J)
        KMX=IY+HWY(J)
        DO 11 K=KMN,KMX
        CALL CBYTE(K)
        IF(J.NE.IFRST) GOTO 10
        PNTR(IFRST)=1
        IFRST=IFRST+1
10      IZZ=PNTR(J)+NJ
        CALL CBPACK(IZZ)
        PNTR(J)=PNTR(J)+1
11      CONTINUE
        IWX(J)=IWX(J)-1
12      CONTINUE
C
C--------------------- CHECK IF ONE OR MORE SPOTS ARE FINISHED
C
13      CONTINUE
        IF(IWX(INDF).EQ.0) GOTO 14
        IF(INDF.LE.INDL) GOTO 7
        FULL=.FALSE.
        GOTO 6
14      IND=ILAST*MAXW+1
        ILAST=ILAST+1
        NXX=HWX(INDF)*2+1
        NYY=HWY(INDF)*2+1
      if(streak) then
        call cgmask(iarr(ind),lras,-1,delx,dely,
     1                  x(indf),y(indf),sod)
      else
          CALL CGFIT(IARR(IND),LRAS,-1,DELX,DELY,SOD)
      end if
      if(sod.le.0) then
            nzeros = nzeros + 1
            goto 151
      end if
      if(abs(delx).lt.float(nxx).and.abs(dely).lt.float(nyy))
     1  then
              IF(ISWTCH(1).EQ.0) GOTO 15
              CALL ODPLOT(IARR(IND),NXX,NYY,-1)
            goto 15
      end if
      nbigxy = nbigxy + 1
      goto 151
15      SHX=DELX/FACT+0.5
        SHY=DELY/FACT+0.5
        NRS=NRS+1
        XRS(NRS)=(X(INDF)+DELX)/FACT+0.5
        YRS(NRS)=(Y(INDF)+DELY)/FACT+0.5
        RRS(NRS)=IREC(INDF)
151      continue
        IF(ILAST.EQ.MAXN) ILAST=0
        INDF=INDF+1
        IF(INDF.LE.NREF) GOTO 13
      if(nzeros.gt.0) then
            if(.not.batch) write(6,141)nzeros
            write(8,141)nzeros      
141      format(1x,i4,' zero intensity spots have been rejected ')
      end if
      if(nbigxy.gt.0) then
            if(.not.batch) write(6,142)nbigxy
            write(8,142)nbigxy
142      format(1x,i4,' large error spots have been rejected ')
      end if
        RETURN
        END
C
C
      SUBROUTINE NOYES(I1,I2)
      CHARACTER*(*) I1
      IF(I1.EQ.'Y')I2=1
      IF(I1.EQ.'y')I2=1
      IF(I1.EQ.'N')I2=0
      IF(I1.EQ.'n')I2=0
      RETURN
      END
C
C   SUBROUTINE TO PUT OD'S IN HAT ARRAY.
C
      SUBROUTINE ODPHAT(HX,HY,MASK,IBIN,nobin)
C
      INCLUDE 'comprf.finc'
      INCLUDE 'combck.finc'
      INCLUDE 'comhat.finc'
      INCLUDE 'comuab.finc'
C
      INTEGER MASK(1),P,Q,HX,HY
C
      N=0
      IJ=0
      idir = -1
      DO 2 P=-HX,HX,idir
      DO 2 Q=-HY,HY
      IJ=IJ+1
                  IF (MASK(IJ)) 2,2,1
1     IK=IJ+1
      N=N+1
      IOD=IP(IK,IBIN)
      IPROB=IP(IK,NOBIN)
      IF(WTPRO) IPROB=IPW(IK)
      PR=FLOAT(IPROB)
      IF(PR.EQ.0.0)PR=1.0
      HATP(N,1,nobin)=(FLOAT(IOD)-A(IBIN)*FLOAT(P)
     1           -BZ(IBIN)*FLOAT(Q)-C(IBIN))/PR
c      if(float(iprob).eq.0.0) then
c            if(abs(hatp(n,1,nobin)).gt.0.5) then
c              hatp(n,1,nobin) = (hatp(n,1,nobin) /
c    1                   abs(hatp(n,1,nobin))) * 0.5
c            end if
c      end if
      HATP(N,4,nobin)=float(iprob)
      HATP(N,5,nobin)=FLOAT(IOD)
2     CONTINUE
      RETURN
      END
C
C
C
C
C                      *********************************************
C                      *                                           *
C                      *        ****  SUBROUTINE ODPLOT  ****      *
C                      *                                           *
C                      *********************************************
C
C
C
C=============================================================
C
C
C       SUBROUTINE ODPLOT
C
C  PLOTS ARRAY OF OPTICAL DENSITIES FOR SPOT ON
C  TEKTRONIX.OD.S ARE STORED IN A BYTE ARRAY AND
C  ARE PLOTTED AS OD/3.
C  CALLED BY CENTRS,SEEKRS,MESS,NEXT FOR OPTIONAL
C  OUTPUT OF SPOTS
C
C=============================================================
C
        SUBROUTINE ODPLOT(BB,IWX,IWY,IDR)
c
cRCD ...Image Plate logical
        common/iplate/image,mar,moldyn
        logical image,mar,moldyn
c
        INTEGER IA(30)
        INTEGER*2 BB(1)
C        OPEN(UNIT=7,FILE='TT:',STATUS='UNKNOWN')
        NXY=IWX*IWY
        N=NXY
        IF(IDR.EQ.1) N=IWY
        DO 2 J=1,IWY
        IJ=N-J+1
        DO 1 I=1,IWX
        if(.not.image)then
        IA(I)=IBYTE(BB,IJ)/3
        else
        ia(i)=ip_ibyte(bb,ij)/3
        endif
        IJ=IJ+IDR*IWY
1       CONTINUE
        WRITE(6,1000) (IA(K),K=1,IWX)
1000    FORMAT(24I3)
2       CONTINUE
c         CLOSE (UNIT=7)
        RETURN
        END
C
C
C           SUBROUTINE TO TAKE OUT A BG POINT OF VALUE
C         B AT X,Y (RELATIVE TO CENTRE) FROM THE PLANE SUMS .
C                    NEED TO DO ALL ELEMENTS SINCE
C                   AM WILL NEED REEVALUATING
C
      SUBROUTINE OFFBCK(J, B, P, Q, SIGN)
C
      INCLUDE 'combck.finc'
      INCLUDE 'comprf.finc'
C
      INTEGER P, Q, SIGN
C
C
      RP = FLOAT(P)
      RQ = FLOAT(Q)
      BN(J) = BN(J) - 1
      BP(J) = BP(J) - P
      BQ(J) = BQ(J) - Q
      BPQ(J) = BPQ(J) -  RP * RQ
      BPP(J) = BPP(J) -  RP * RP
      BQQ(J) = BQQ(J) -  RQ * RQ
C
C------------------  TAKE OFF BM
C
      BOP(J) = BOP(J) -  B * RP
      BOQ(J) = BOQ(J) -  B * RQ
      BO(J) = BO(J) -  B
      IF(bn(j).ge.4) RETURN
c      if(.not.batch)write(6,311)bn(j)
c      WRITE(8,311)bn(j)
c311      FORMAT(1X,' ** BG POINTS REDUCED TO',I3,' IN OFFBCK **')
      intpro = 99999
      RETURN
      END
C
C
C           SUBROUTINE TO TAKE OUT A J VALUE WHEN
C             CALCULATING THE INTENSITY FOR AN
C                 OVERLAPPED PROFILE.
C
      SUBROUTINE OFFHAT(I,ODPR,PPR,QPR,PR,PR2,nobin)
C
      INCLUDE 'combck.finc'
      INCLUDE 'comprf.finc'
      INCLUDE 'comhat.finc'
C
C--------------SET TO TAKE OFF VALUES
C
        ODPR=ODPR-HATP(I,5,nobin)*HATP(I,4,nobin)
        PPR=PPR-HATP(I,2,nobin)*HATP(I,4,nobin)
        QPR=QPR-HATP(I,3,nobin)*HATP(I,4,nobin)
        PR=PR-HATP(I,4,nobin)
        PR2=PR2-HATP(I,4,nobin)*HATP(I,4,nobin)
C
      RETURN
      END
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE  open_ge (in_data1, in_data2, file_name, end_pos,
     1                     end_rec)
C
C Purpose: To open .ge files using the given units and filename
C          Note that if the filename 'interactive' is supplied
C          then the user is prompted for a filename
C          Also note that filenames can have extensions, but these are removed
C
      implicit none
C
      integer*4      in_data1, in_data2, end_rec
      character*(*)  file_name
      integer        end_pos
C
C
      common /io_streams/ in_term, out_term, in_data, out_data
      integer*4           in_term, out_term, in_data, out_data
C
C in_term : main input stream (usually the terminal =5)
C out_term : main output (printer) stream (usually =6)
C in_data : input stream for data (to be written to files)
C out_data : output stream for data (to be written to files)
C
C CALLS   0:
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
C Local Variables:
C
      integer*4     i, IFAIL
      character*30  fname, fname1, fname2
      logical       exists1, exists2
C
C fname : filename of .ge input file
C fname1 : filename with .ge1 appended
C fname2 : filename with .ge2 appended
C
C--------------------------------------------------------------------------
C
 1    if  (file_name.eq.'interactive')  then
         call  parse_file ('?_ge_file: ', 'ge1', fname, i)
       else
         call  parse_file (file_name, 'ge1', fname, i)
      end if
      file_name = fname
      end_pos = i
C
      fname1 = fname(1:i) // '.ge1'
      fname2 = fname(1:i) // '.ge2'
C
      call  check_file (fname1, '%OPEN_GE', exists1)
      call  check_file (fname2, '%OPEN_GE', exists2)
C
      if  (.not.(exists1.and.exists2))  then
         file_name = 'interactive'
         goto 1
      end if
C
      IFAIL=0
      CALL CCPDPN(-in_data1,fname1,'OLD','DU',19,IFAIL)
C      open(unit=in_data1, file=fname1, status='old', recl=19,
C     1     form='unformatted', access='direct')
C
      IFAIL=0
      CALL CCPDPN(-in_data2,fname2,'OLD','DU',2,IFAIL)
C      open(unit=in_data2, file=fname2, status='old', recl=2,
C     1     form='unformatted', access='direct')
C
      write (8, 1000) fname(1:i)
C
      read (unit=in_data1,rec=10) i,end_rec
      if  (end_rec.lt.1)  then
         read (unit=in_data1,rec=9) i,i,end_rec
      end if
      end_rec = end_rec + 10
C
      return
 1000 format(1x,'input ge file is ',a)
      end
C
      SUBROUTINE  parse_file (filename, ext, parsed_name, end_pos)
C
C Purpose: To parse filename and add .ext if it has no extension
C
      implicit none
C
      character*(*)  filename, parsed_name
      character*3    ext
      integer*4      end_pos
C
C
      common /io_streams/ in_term, out_term, in_data, out_data
      integer*4           in_term, out_term, in_data, out_data
C
C in_term : main input stream (usually the terminal =5)
C out_term : main output (printer) stream (usually =6)
C in_data : input stream for data (to be written to files)
C out_data : output stream for data (to be written to files)
C
C CALLS   0:
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
C Local Variables:
C
      integer*4     i, lenfname
      character*30  fname
C
C fname : filename of .ge input file
C
C--------------------------------------------------------------------------
C
      fname = filename
C
      if  (filename(1:1).eq.'?')  then
C
 1       write (out_term, 1000) filename(2:)
         read (in_term, 1010) fname
         if (fname(1:1).eq.' ') goto 1
         write (8, 1011) fname
C
      end if
C
      lenfname = len(fname)
      i = lenfname
      do while (fname(i:i).ne.']' .and. fname(i:i).ne.'.' .and. i.gt.1)
         i = i - 1
      end do
C
C========  Check if extension is present
C
      if  (fname(i:i).eq.'.') then
         end_pos = i - 1
         parsed_name = fname
       else
         i = 1
         do while (fname(i:i).ne.' ' .and. i.lt.lenfname)
            i = i + 1
         end do
         if  (i.eq.lenfname) then
            stop ' parsefile: Fatal error, filename too long'
         end if
         end_pos = i - 1
         parsed_name = fname(:end_pos) // '.' // ext
      end if
C
      return
C
 1000 format(1x,a,$)
 1010 format(a30)
 1011 format(1x,a30)
      end
C
C
C
C                      *********************************************
C                      *                                           *
C                      *        ****  SUBROUTINE PLTRAS ****       *
C                      *                                           *
C                      *********************************************
C
C
C
C
C
        SUBROUTINE PLTRAS(IRAS)
        INTEGER IRAS(5),P,Q
C
      INCLUDE 'comuab.finc'
C
        COMMON/IOO/IOUT
        If (Batch) goto 1
        If (.not.Ltek) goto 1
        IF(.NOT.XTEK)CALL TKCLR
1       IF(XTEK) CALL NEWPG
C
C ------------------
C                    Introduce scale = 15 for X direction
C                               sept 8. trevor
C
        J=15
        K=20
        N=0
        IHX=IRAS(1)/2
        IHY=IRAS(2)/2
        IX=J*IHX
        IY=K*IHY
        if(.not.ltek) goto 3
2     CALL MOVTX(-IX+512,IY+300)
      CALL VECTX(IX+512,IY+300)
      CALL VECTX(IX+512,-IY+300)
      CALL VECTX(-IX+512,-IY+300)
      CALL VECTX(-IX+512,IY+300)
        IX=J*(IHX-IRAS(4))
        IY=K*(IHY-IRAS(5))
        N=N+1
        IF(N.EQ.1) GOTO 2
      CALL ALPHA
        IX=J*IHX
        IY=K*IHY
        ICX=IX-J*IRAS(3)
        ICY=IY-K*IRAS(3)
C
        KX1=ICX+512
        KX2=IX+512
        KX3=-ICX+512
        KX4=-IX+512
        KY1=IY+300
        KY2=ICY+300
        KY3=-IY+300
        KY4=-ICY+300
      CALL MOVTX(KX1,KY1)
      CALL VECTX(KX2,KY2)
      CALL MOVTX(KX1,KY3)
      CALL VECTX(KX2,KY4)
      CALL MOVTX(KX3,KY1)
      CALL VECTX(KX4,KY2)
      CALL MOVTX(KX3,KY3)
      CALL VECTX(KX4,KY4)
      CALL ALPHA
3      IC=IHX+IHY-IRAS(3)
        IRX=IHX-IRAS(4)
        IRY=IHY-IRAS(5)
        NPEAK=0
        NBG=0
        NMISS=0
        DO 6 P=-IHX,IHX
        IP=IABS(P)
        DO 6 Q=-IHY,IHY
        IQ=IABS(Q)
        IPQ=IP+IQ
        IF((IPQ.GT.IC).OR.(IP.GT.IRX).OR.(IQ.GT.IRY)) GOTO 4
        IF((IPQ.LT.IC).AND.(IP.LT.IRX).AND.(IQ.LT.IRY)) GOTO 5
        NMISS=NMISS+1
        GOTO 6
4       NBG=NBG+1
        GOTO 6
5       NPEAK=NPEAK+1
6       CONTINUE
C
C -------------------POSITION TEXT AT TOP OF PAGE
C
        if(ltek) CALL TKPLOT(0,760,1,IER)
        WRITE(IOUT,1000)
        if(.not.batch)write(6,1000)
1000    FORMAT(/,' MEASUREMENT BOX PARAMETERS.')
        WRITE(IOUT,1001) NPEAK,NBG,NMISS
        if(.not.batch)write(6,1001)NPEAK,NBG,NMISS
1001    FORMAT(' FOR THIS BOX THERE ARE',I5,' POINTS IN THE PEAK',/,
     1'                       ',I5,' POINTS IN THE BACKGROUND',/,
     1'                    AND',I5,' POINTS OMITTED')
        RETURN
        END
C
C
C
C
C                      *********************************************
C                      *                                           *
C                      *        ****  SUBROUTINE PREAD   ****      *
C                      *                                           *
C                      *********************************************
C
C
C
C=============================================================
C
      SUBROUTINE PREAD(IB,L,IU)
      INTEGER*2 IB(L)
      READ(IU)IB
      RETURN
      END
C
C
C
C
C                      *********************************************
C                      *                                           *
C                      *        ****  SUBROUTINE PROBIN ****       *
C                      *                                           *
C                      *********************************************
C
C         IBIN IS THE SPOT BIN (NUMBIN+1 FOR INTEGRATION PASS)
C         NOBIN IS THE STANDARD PROFILE BIN (=IBIN FOR STANDARDS)
C
C=============================================================
C
C
        SUBROUTINE PROBIN(IRAS,MASK,IBIN,NOBIN)
C
      INCLUDE 'comuab.finc'
      INCLUDE 'comprf.finc'
      INCLUDE 'combck.finc'
      INCLUDE 'comhat.finc'
      INCLUDE 'commaskl.finc'
C
        INTEGER IRAS(5),MASK(1),P,Q,HX,HY,SIGN,BJN
cRCD ...Image Plate logical
        common/iplate/image,mar,moldyn
        logical image,mar,moldyn
      IOUT = 8
        HX=IRAS(1)/2
        HY=IRAS(2)/2
      idir = -1
      hx = hx * idir
C
C-------------------------ZERO ARRAYS FOR THIS BIN
C
      CHANGE(IBIN) = .FALSE.
      CALL SETBCK(IBIN)
      IPSC(IBIN) = 999.0
      SIGN = 1
C
C--------------------START AT 2ND POINT IN IP ARRAY
C
      if(endbin) then
      nobi = nob(ibin)
      if(nobin.eq.nobi) goto 7007
      if(.not.batch) write(6,7006) ibin, nobi, nobin
      write(8,7006) ibin, nobi, nobin
7006      format(1x,' problem in probin: ibin, nobi, nobin',
     1        3i5)
      end if
7007      continue
c
      REPB = 2.0
C ----------------- Cornell ips were poor - needed REPB = 3.0
C      if(image) REPB = 3.0
        BJN=0
        IJ=0
        PORB=0
        DO 2 P=-HX,HX,idir
        DO 2 Q=-HY,HY
      IJ=IJ+1
      IF (MASK(IJ)) 1,2,2
1       IK=IJ+1
        XOD= XIP(IK,IBIN)
      IF(ENDBIN) then
      XOD = FLOAT(IP(IK,IBIN))
         if(ovlap.and.correct) then
c            nobi = nob(ibin)
            xot = float(nob(nobin)) + repb*cutu
               if(xod.gt.xot) then
                  ip(ik,ibin) = nob(nobin)
                  XOD = FLOAT(IP(IK,IBIN))
                  rej(1) = rej(1) + 1
               end if
         end if
      end if
C
C----------------------- SET UP STANDARD AM FIRST TIME
C------------------------- SET UP P & Q IN HAT ARRAY
C
      if (endbin) then
            goto 11
      end if
      if(.not.streak) then
          IF(IBIN.NE.1) GOTO 11
        end if
        CALL AMBCK(ibin,P,Q)
c        CALL SETHAT(BJN,P,Q)
C
C-----------------------  SUMS FOR BACKGROUND
C
11      CALL SUMBCK(IBIN,XOD,P,Q,SIGN)
2       CONTINUE
C
C-----------------------  SET STANDARD AM
C
      nobbi = ibin
      if(endbin) nobbi = nob(ibin)
c
      if (streak) then
                  call am1bck(nobbi)
            else
                  IF(IBIN.EQ.1) THEN
                    CALL AM1BCK(ibin)
                  end if
      end if
C
C----------------------- EVALUATE BG PLANE
C
      CALL ABCBCK(IBIN,AMPRO)
C
C----------------------- CHECK BG PLANE
C
      intpro=9999
      IJ=0
        DO 4 P=-HX,HX,idir
        DO 4 Q=-HY,HY
        IJ=IJ+1
      IF (MASK(IJ)) 3,4,4
3      IK=IJ+1
        XOD= XIP(IK,IBIN)
      IF(ENDBIN) XOD = FLOAT(IP(IK,IBIN))
        CALL CHKBCK(IBIN,nobin,XOD,P,Q,SIGN)
4       CONTINUE
c        END IF
C
C------------------------  REDO BG PLANE IF NECCESSARY
C
      IF(.NOT.CHANGE(IBIN)) GOTO 5
      if(intpro.eq.99999) return
      CALL SLVBCK(IBIN)      
      if(intpro.eq.99999) return
C
C-------------------------MAKE PROFILE-------------------
C
C
C--------------------------  WHOLE SPOT FOR STANDARDS
C
5      IF(ENDBIN) GOTO 9
      IJ=0
        DO 8 P=-HX,HX,idir
        DO 8 Q=-HY,HY
        IJ=IJ+1
      IK=IJ+1
        XOD= XIP(IK,IBIN)
      SIGN = 1
      IF (MASK(IJ)) 6,6,7
6      SIGN = -1
7       CONTINUE
        CALL PROSET(IBIN,XOD,P,Q,SIGN)
      IP(IK,IBIN) = NINT(XOD/10000.)
      XIP(IK,IBIN)= XOD/10000.
8      CONTINUE
C
C------------------------WRITE OUT INFO ON THIS BIN
C
      if(.not.batch)write(6,1000)IBIN
      WRITE(IOUT,1000)IBIN
1000      FORMAT(1X,' *** BIN N0. ',I3,' FINISHED ***')      
C
C---------------------  SCALE THE PROFILE
C
      CALL PROSCL (IBIN,IRAS(1),IRAS(2),HX,HY)
C
C--------------------   CHECK PROFILE FITTED INTENSITY
C
9      Call PROCAL (IBIN,NOBIN,IRAS(1),IRAS(2),HX,HY,MASK)
C
        RETURN
        END
C
C
C                EVALUATE PROFILE FITTED INTENSITY
C
C
C
C=============================================================
C
C
        SUBROUTINE PROCAL(IBIN,NOBIN,IRAS1,IRAS2,HX,HY,MASK)
C
      INCLUDE 'comprf.finc'
      INCLUDE 'combck.finc'
      INCLUDE 'comuab.finc'
      INCLUDE 'comhat.finc'
      INCLUDE 'comtem.finc'
      INCLUDE 'commaskl.finc'
C
        INTEGER MASK(1),P,Q,HX,HY,BKN
      REAL ODPR,PPR,QPR,PR,PR2,PRT,podsav,qodsav
      DATA IOVER/0/
      IOUT = 8
      INTPRO = 9999
      INTP = 9999
      PODSUM = 0.0
      QODSUM = 0.0
      idir = -1
        HX=IRAS1/2
        HY=IRAS2/2
      hx = hx * idir
      NPS = 1
      NMBN = NUMBIN + 1
c      if(ibin.eq.nmbn.and.BN(nmbn).eq.0) then
c       write(iout,500)
c       if(.not.batch)write(6,500)
c500       format(1x,' ** NO POINTS IN BG. REJECT THIS SPOT** ')
c       RETURN
c      END IF
C
C--------------------START AT 2ND POINT IN IP ARRAY
C
1      ODPR = 0.0
      QPR = 0.0
      PPR = 0.0
      PR  = 0.0
      PR2 = 0.0
        IJ=0
      nsat = 0
        BKN =0
        PORB = 1
        DO 4 P=-HX,HX,idir
        DO 4 Q=-HY,HY
      IJ=IJ+1
            IF (MASK(IJ)) 4,4,2
2       IK=IJ+1
c
      if(nps.eq.1) then
       if(correct) then
          if(.not.endbin) then
            call sethat(ibin,bkn,p,q)
          end if
       end if
      end if
c
        IOD= IP(IK,NMBN)
      IF(IOD.GT.Isan) NSAT = NSAT + 1
      IF(NSAT.GT.IOVER) RETURN
      IPROB = IP(IK,NOBIN)
      IF(.NOT.ENDBIN) GOTO 3
      IF(WTPRO) IPROB = IPW(IK)
3      IF(NPS.EQ.2) IPROB=1
C
C----------------------------SUMS FOR PEAK
C
      ODPR = ODPR + FLOAT(IOD * IPROB)
      PPR = PPR + FLOAT(P * IPROB)
      QPR = QPR + FLOAT(Q * IPROB)
      PR = PR + FLOAT(IPROB)
      PR2 = PR2 + FLOAT(IPROB * IPROB)
        PRT = PR
      PODSUM = PODSUM + FLOAT(IOD*P)
      QODSUM = QODSUM + FLOAT(IOD*Q)
4       CONTINUE
C------------------- SET UP HAT-MATRIX & H
C
      if(nps.eq.1) then
          if(correct) then
c
             if(.not.endbin) then
             if(xtek) call newpg
             CALL STPHAT(ibin,HX,HY)
             if(xtek) call newpg
             end if
c
               IF(ENDBIN.AND.OVLAP)THEN
               CALL ODPHAT(HX,HY,MASK,NMBN,nobin)
                 CALL HATHAT(nobin)
                 CALL CHKPHAT(ODPR,PPR,QPR,PR,PR2,nobin)
               if(prorej.eq.1) then
                nopuse = nopuse + 1
                return
               end if
               END IF
          end if
      end if
C
C-----------------------  GET INTENSITY
C
      INTPRO=(ODPR-A(IBIN)*PPR-BZ(IBIN)*QPR-C(IBIN)*PR)*PRT/PR2 + 0.5
C
C---------------------  PRINT OUT
C
      IF(.not.endbin) goto 5
      If(.not.iboth) return
5      IF(NPS.EQ.1) then
       INSAV = INTPRO
       podsav = podsum
       qodsav = qodsum
      end if
      NPS = NPS + 1
      IF(NPS.EQ.2) GOTO 1
      INTP = INTPRO
      INTPRO = INSAV
      podsum = podsav
      qodsum = qodsav
      if(endbin) return
      WRITE(8,1000) IBIN, INTPRO, intp
      if(.not.batch)write(6,1000) IBIN,INTPRO, intp
1000      FORMAT(1h1,1X,'BIN ',I2,' PROFILE FIT I = ',I7,
     1        '   INTEGRATED  I = ',I7)
c      WRITE(8,1001) IBIN, INTP
c      if(.not.batch)write(6,1001) IBIN,INTP
c1001      FORMAT(2X,'BIN ',I2,' INTEGRATED  I = ',I5)
        RETURN
        END
C
C
C
C
C                      *********************************************
C                      *                                           *
C                      *        ****  SUBROUTINE PROCESS ****      *
C                      *                                           *
C                      *********************************************
C
C
C
C=============================================================
C
C                      ******      PROCESS     ******
C
c##### laue mods
C   Mods for specific Laue processing. Back from Pella 25 Sept 1986
C
C=============================================================
C
C
C
        SUBROUTINE PROCESS
c
cRCD ...Image Plate logical
        common/iplate/image,mar,moldyn
        logical image,mar,moldyn
C
      INCLUDE 'comhis.finc'
      INCLUDE 'comori.finc'
      INCLUDE 'compro.finc'
      INCLUDE 'comras.finc'
      INCLUDE 'comrep.finc'
      INCLUDE 'comuab.finc'
      INCLUDE 'comprf.finc'
      INCLUDE 'comhat.finc'
      INCLUDE 'comtem.finc'
C
C---------  Include SCN, RFS, MCS, SND for old SEND file
C
      INCLUDE 'comscn.finc'
      INCLUDE 'comrfs.finc'
      INCLUDE 'commcs.finc'
      INCLUDE 'comsnd.finc'
      INCLUDE 'commask.finc'
      INCLUDE 'commaskl.finc'
C
        COMMON/IOO/IOUT
        COMMON/SW/ISWTCH(10)
        REAL ASPOT(5),XSH(16),YSH(16),SUMPQ(6,0:15)
        INTEGER GENBUF(10),BUFSIZ,SVMASK(5000)
        INTEGER OD(5000)
        INTEGER*2 IBUF(4),KKREC,IPXX,IPYY
        INTEGER NSH(16),TABLE(0:255),IH(6),IHD(3,50)
        INTEGER LRAS(5)
        LOGICAL FULL,YES,LDUMP,END4
        COMMON/PEL/IOD,BUF(5120),nextr
      integer*2 buf,iod
        DATA FATNO/0/
c         DATA IRANGE /-30,0,50,100,200,400,800,1600,3200/
        EQUIVALENCE (LRAS(1),NXX),(LRAS(2),NYY)
        EQUIVALENCE (IBUF(1),KKREC),(IBUF(2),IPXX),(IBUF(3),IPYY)
        EQUIVALENCE (ASPOT(1),SPOT),(ASPOT(2),BGND),(ASPOT(3),RMSBG)
        EQUIVALENCE (ASPOT(4),DELX),(ASPOT(5),DELY)
        CHARACTER*1 JUNK
        SAVE
C
        ENDBIN=.FALSE.
C
C-----------  FACTOR USED TO ADJUST SD. OF STRONG SPOTS
C
        DATA EFAC/4.0/
        if(.not.batch)write(6,1000)
        WRITE(IOUT,1000)
1000    FORMAT(' ENTER PROCESS')
        IF(XTEK) CALL NEWPG
        If(.not.ltek) goto 10
        IF(.NOT.XTEK) CALL TKCLR
10      continue
c
c
c
c cmask input is constant eta*D or FULL spot size (mm) for k=0
c bminor input is full width in mm
c dmask is cf in mm
c kmask is scale: 0 for constant, 1 for MMH
c all read in in mosuab and converted
c in SEEKRS for a,b ellipse axes
c
c      if(streak) then
c            if(.not.bgplan) then
c                    bminor = bminor/2.0*100.*fact
c                    cmask = cmask/2.0*100.*fact
c                    dmask = dmask*100.*fact
c            end if
c      end if
C
C----------------------- CHECK BOX SIZE
C
        IF(MAXR.LE.5000)GO TO 20
        STOP ' MEASUREMENT BOX TOO LARGE'
20      CONTINUE
C
C-------------- OPEN FILES FOR INPUT.
C
        ifail=0
        call ccpdpn(-3,'MOSTEMP','OLD','U',0,ifail)
c         OPEN(UNIT=3,FILE='Mostemp',STATUS='OLD',
c      1            FORM='UNFORMATTED')
C
C------ OPEN FILE FOR DUMPING SPECIFIED REFLECTIONS TO BADSPOTS FILE
C
        IF(ISWTCH(9).EQ.0)GO TO 40
        if(.not.batch)write(6,1010)
        WRITE(IOUT,1010)
1010    FORMAT(/,' BADSPOTS OUTPUT WILL CONTAIN SPECIFIED REFLECTIONS',
     1         1X,'READ IN FROM SPOTDUMP INPUT FILE ')
        ifail=0
        call ccpdpn(-21,'SPOTDUMP','UNKNOWN','F',0,ifail)
c         OPEN(UNIT=5,FILE='SPOTDU.DAT',STATUS='UNKNOWN')
        READ (21,*)NSPT
        IF(NSPT.GT.50)NSPT=50
        DO 30 I=1,NSPT
        READ(21,*) (IHD(K,I),K=1,3)
30      CONTINUE
40      CONTINUE
C
C------------------  COLUMN FOR OUTPUT INTENSITY
C
c##### laue mods
c
      iprof = 0
      if(profil) iprof = 12
      ifill = 4 + iprof +film
        IDR=-1
        BUFSIZ=1000
C
C------------------  GENERATE LOOK-UP TABLE
C
        if(.not.image)then
        CFAC=CURV/N1OD
        BASE=BASEOD*N1OD
        DO 50 I=0,255
        TRUOD=I-BASE
        TABLE(I)=TRUOD*(1.0+CFAC*TRUOD)+0.5
50      TABLE(I)=AMAX0(0,TABLE(I))
        ISAN = Table(imaxod)
        else
        isan = imaxod
        endif
C
C---------------------  CLEAR FOR STATISTICS
C
        itots = 0
        iboxs = 0
        ipros = 0
        NOLO=0
        NEDGE=0
        NBOX=0
        NBZERO=0
        NOFR=0
        MAXBSI=0
        MINBSI=200
      nopuse = 0
        OREJ=0
      ratrej = 0
      ogdrej = 0
      rgdrej = 0
        DO 60 I=1,10
        IANAL(I)=0
        AVSD(I)=0.0
60      RATIO(I)=0.0
        DO 70 I=1,16
        XSH(I)=0.
        YSH(I)=0.
70      NSH(I)=0
C
C-----------------  DETERMINE SCALE FACTOR FOR INTENSITIES
C
        CALL SETMASK(MASK(1,1),IRAS)
        CALL SETSUMS(MASK(1,1),IRAS,SUMPQ(1,1))
        SCAI=50./SUMPQ(5,1)
      if(streak) then
            scai=50./(4.0*bminor*cmask)
      end if
      if(image) scai = scai/10.0
        if(.not.batch)write(6,701) scai
        WRITE(IOUT,701) scai
701     FORMAT(1x,' Scale factor for Intensities:  ',f12.4)
        DO 80 I=3,5
80      LRAS(I)=IRAS(I)
C
C ------------- SET SWITCH (4) ACCORDING TO PROFILES
C
        IF(PROFIL) ISWTCH(4)=1
        IF(PROFIL) GOTO 90
        IF(ISWTCH(4).EQ.0) GOTO 170
C
C------------------- AVERAGE SPOT IN BINS
C
        CALL AVSPOT
C
C--------------------- PROFILE AVERAGES IN BINS
C-------------------  SKIP FORMING PROFILES IF B OR C FILM
C                               IN SAME RUN.
C      But set up the background histogram for lower films
C
90      Call cputime(1)
      IF(BGPLAN) then
            call hisbck(0,0,0,0,5)
            GOTO 170
      end if
      if(.not.batch)write(6,1020)
        WRITE(IOUT,1020)
1020    FORMAT(' FORM PROFILES')
C
C
        NECX=XCEN*FACT+0.5
        NECY=YCEN*FACT+0.5
C
C---------------SET ARRAYS TO ZERO
C
      do 62 i=1,12
      do 61 j=1,12
      histbg(i,j) = 0
      histn(i,j) = 0
61      continue
62      continue
        DO 100 NOBIN=1,NUMBIN+1
        NOB(NOBIN) = 0
        IXBIN(NOBIN) = 0
        IYBIN(NOBIN) = 0
        DO 100 K=1,5000
        XIP(K,NOBIN) = 0.0
100     IP(K,NOBIN)=0
C
C-------------------- UNEXPANDED SPOT
C
        NPY = NYS
        NPX = NXS
        NPXY = NPX * NPY
        NPACK = NPX*256+NPY
C
C------------------------
C------------------------  LOOP OVER ALL REFLECTIONS
C------------------------
C
        DO 110 I=1,NREF
C
C--------------  READ ARRAY OF OD.S FOR EACH SPOT
C
        READ(3)klrec,LEN,IBUF
        CALL PREAD(BUF(1),LEN,3)
C
C---------------  NOT FOR PARTIALS
C
        IF(KlREC.LT.0) GOTO 110
        IF(IDEC(KLREC).EQ.1) GOTO 110
        KREC=Klrec
        IX=IPXX
        IY=IPYY
        NXX=IBYTE(IBUF,7)
        NYY=IBYTE(IBUF,8)
        NXY=NXX*NYY
        IF(NXY.GT.MAXR) WRITE(IOUT,1230) MAXR,NXX,NYY,NXY
        IF(NXY.GT.MAXR.and..not.batch)write(6,1230)MAXR,NXX,NYY,NXY
        NSIZ=(NXY+1)/2
C
C----------------SET UP BIN NUMBER NOBIN
C
        IF(NUMBIN.EQ.5) THEN
                CALL PRONUM5(NOBIN,IX,IY,NECX,NECY,I)
          ELSE
        if (streak) then
                call pronum17(nobin,ix,iy,necx,necy,i)
          else
                CALL PRONUM(NOBIN,IX,IY,NECX,NECY,I)
        end if
        END IF
c
c    store bg histogram array address
c    prosel will put bg into this slot
c
      call hisbck(IX,IY,0,0,1)
C
C-----------------SELECT ONLY THE OD'S IN THE UNEXPANDED SPOT
C------------------            PUT INTO IP
C
        CALL PROSEL(NOBIN,NXX,NYY,TABLE)
C
C----------------- RETURNING NOBIN = -1 MEANS WEAK OR OVLOAD
C----------------- PROSEL HAS NOT ADDED THIS SPOT IN
C
        IF(NOBIN.EQ.-1) GOTO 110
C
C------------------SET UP AVERAGE COORDS IN EACH BIN
C
        IXBIN(NOBIN) = IXBIN(NOBIN) + (IX - NECX)
        IYBIN(NOBIN) = IYBIN(NOBIN) + (IY - NECY)
C
C----------------- ADD UP NUMBER IN BIN
C
        NOB(NOBIN) = NOB(NOBIN) + 1
C
C--------------------END OF LOOP
C
110     CONTINUE
c
c    form and print background histogram
c
      call hisbck(1,1,0,0,3)
C
C---------------------- NOW SET NXX, NYY TO NPX, NPY
C
        NXX = NPX
        NYY = NPY
        NXY = NPXY
C
C--------------------- GET MASK READY. CONSTANT BOX
C
        CALL SETMASK(MASK(1,1),LRAS)
        CALL SETSUMS(MASK(1,1),LRAS,SUMPQ(1,0))
C
C------------------------LOOP OVER BINS
C
        DO 140 IBIN = 1, NUMBIN
C
C----------------PACK SPOT SIZE INTO WORD 1 OF IP
C
        IP(1,IBIN)=NPACK
C
C----------------GET BIN CENTRE
C
        IF(NOB(IBIN).EQ.0) GOTO 140
        IXBIN(IBIN) = IXBIN(IBIN) / NOB(IBIN)
        IYBIN(IBIN) = IYBIN(IBIN) / NOB(IBIN)
C
C------------------FORM AVGE. SPOT FOR EACH BIN.
C
        DO 130 INEED = 2,NPXY+1
        XIP(INEED,IBIN) = FLOAT (IP(INEED,IBIN))/FLOAT(NOB(IBIN))
        IP (INEED,IBIN) = NINT (XIP(INEED,IBIN))
        OD (INEED)      =        IP(INEED,IBIN)
C
C---------------- SAVE RAW SPOT IN BIN NUMBIN+1 FOR EVALUATION
C
130     IP(INEED,NUMBIN+1) = IP(INEED,IBIN)
        FULL=.TRUE.
c
      if(streak) then
      call radmask(-1,ixbin(ibin),iybin(ibin),nxx,nyy,isp,od(2))
        CALL INTEG(OD(2),LRAS,RMASK,rsums,ASPOT,IDR,FULL)
            else
        CALL INTEG(OD(2),LRAS,MASK(1,1),SUMPQ(1,0),ASPOT,IDR,FULL)
      end if
c
        DELX=DELX/FACT
        DELY=DELY/FACT
C
C-------------------SAVE INTEGRATED INTENSITY FOR PROBIN
C
        IPJ(IBIN) =  SPOT + 0.5
        WRITE(IOUT,1040)
        if(.not.batch)write(6,1045)
1040    FORMAT(1h1,'   BIN NOBIN XAV  YAV  ',
     1      'NX   NY   INT   RMSBG  DELX  DELY')
1045    FORMAT('   BIN NOBIN XAV  YAV  ',
     1      'NX   NY   INT   RMSBG  DELX  DELY')
        WRITE(IOUT,1050)IBIN,NOB(IBIN),IXBIN(IBIN),IYBIN(IBIN),
     1                  NXX,NYY,IPJ(IBIN),RMSBG,DELX,DELY
        if(.not.batch)write(6,1060)IBIN,NOB(IBIN),IXBIN(IBIN),
     1             IYBIN(IBIN),NXX,NYY,IPJ(IBIN),RMSBG,DELX,DELY
1050    FORMAT(1x,6I5,i7,3F6.1)
1060    FORMAT(2X,6I5,i7,3F6.1)
C
C----------------------SET UP STANDARD PROFILES
C--------------------- CALL PROFILE MAIN ROUTINE
C
        NOBINN = IBIN
      if(streak) then
        CALL PROBIN(LRAS,rmask,IBIN,NOBINN)
         else
        CALL PROBIN(LRAS,MASK(1,1),IBIN,NOBINN)
      end if
        IF(XTEK) CALL NEWPG
c
      if(streak) then
        CALL RASPLOT(IP(2,IBIN),NXX,NYY,rmask,-1)
         else
        CALL RASPLOT(IP(2,IBIN),NXX,NYY,MASK(1,1),-1)
      end if
c
        IF(XTEK) CALL SCPAUS
        IF(XTEK) CALL TKCLR
c
      if(streak) then
      do 138 irmask = 1,5000
138      rmaskb(ibin,irmask) = rmask(irmask)
      do 139 irsum = 1,6
139      rsumsb(ibin,irsum) = rsums(irsum)
      end if
c      
140     CONTINUE
        If(.not.Ltek) goto 150
        IF(.NOT.XTEK) CALL TKCLR
C
C--------------------- GET WEIGHTING CONSTANT FOR VARIABLE
C--------------------- PROFILE ANALYSIS IF REQUIRED.
C
150     IF(WTPRO) CALL PROVAR
C
C------------------------SAVE MASK FOR PROFILE FITTING
C
        DO 160 IMS = 1,5000
160      SVMASK(IMS) = MASK(IMS,1)
        CLOSE (UNIT=4)
        CLOSE (UNIT=3)
        ifail=0
        call ccpdpn(-3,'MOSTEMP','OLD','U',0,ifail)
c         OPEN(UNIT=3,FILE='Mostemp',STATUS='OLD',
c      1  FORM='UNFORMATTED')
C
C                                    ********************
C
C------------------------START CALCULATION OF INTEGRATED INTENSITIES
C
C                                    ********************
C
170     CONTINUE
        Write(6,1070)
        Write(Iout,1070)
1070    format(' BEGIN INTEGRATION')
        Call cputime(1)
C
C=====================================
C
        IF(.NOT.PROFIL) GOTO 200
C
C----------------------- GET AVEBG
C----------------------- FIRST CHECK FOR B &/OR C FILM
C
        IF(BGPLAN) GOTO 190
        AVEBG = 0.0
        DO 180 IBN = 1,NUMBIN
        CALL CONBCK(APL,BPL,CPL,IBN)
      nob(ibn) = nint(cpl)
180     AVEBG = AVEBG + CPL
        CUT = AVEBG/FLOAT(NUMBIN)
190     CALL CUTBCK(CUT,-1,-1,-1,-1)
200     ifail=0
        call ccpdpn(-4,'BADSPOTS','UNKNOWN','U',0,ifail)
c 200     OPEN(UNIT=4,FILE='BADSPO.DAT',STATUS='UNKNOWN',
c      1            FORM='UNFORMATTED')
        NBAD=0
        QFAC=G1OD*G1OD*N1OD/(2.*(10./FACT)**2)
        NXCUR=0
        J=0
C
C-------------------------------  BIN NUMBER NUMBIN+1 FOR INTEG
C
        IBIN = NUMBIN+1
        nobin = numbin+1
        ENDBIN=.TRUE.
        IF(XTEK) CALL NEWPG
C
C ---------------------------  LOOP OVER REFLEXIONS
C
C
C  ******************************   BOTH METHODS  ********************
C
C
C
        DO 500 I=1,NREF
        J=J+1
        READ(3)klrec,LEN,IBUF
        CALL PREAD(BUF,LEN,3)
        KREC=Klrec
C
        OVLAP=.FALSE.
C
        IX=IPXX
        IY=IPYY
        IREC(J)=IABS(KREC)
        FULL=.FALSE.
        IF(KREC.LT.0) GOTO 210
        IF(IDEC(KLREC).EQ.1) OVLAP=.TRUE.
        FULL=.TRUE.
        NOFR=NOFR+1
210     NXX=IBYTE(IBUF,7)
C
C-------------------------BRANCH FOR PROFILES
C
        IF(PROFIL.AND.FULL) GOTO 270
        IF(PROPT) GOTO 270
C
C
C *********************************  NON - PROFILES ***************
C
C ------------------  TEST FOR CHANGE OF NXX FOR SETTING MASKS
C
        iboxs = iboxs + 1
        IF(NXX.EQ.NXCUR) GOTO 230
        NXCUR=NXX
        NYY=NYS
        DO 220 K=0,15
        CALL SETMASK(MASK(1,K),LRAS)
        CALL SETSUMS(MASK(1,K),LRAS,SUMPQ(1,K))
        NYY=NYY+2
        NXY=NXX*NYY
        IF(NXY.GT.MAXR) GOTO 230
        IF(NYY.GT.70)GO TO 230
220     CONTINUE
230     NYY=IBYTE(IBUF,8)
C
C---------------------------------
C
        IF(NXX.GT.70.OR.NYY.GT.70)GO TO 390
        NXY=NXX*NYY
        IF(NXY.GT.MAXR) WRITE(IOUT,1230) MAXR,NXX,NYY,NXY
        IF(NXY.GT.MAXR.and..not.batch)write(6,1230)MAXR,NXX,NYY,NXY
        NSIZ=(NXY+1)/2
        NN=(NYY-NYS)/2
        IF(NN.LE.15)GO TO 240
        if(.not.batch)write(6,1080)NYY,NYS
        WRITE(IOUT,1080)NYY,NYS
1080    FORMAT(' BOX IS OVEREXPANDED IN Y, NYY=',I5,' NYS=',I5)
        STOP ' OVEREXPANDED BOX'
240     CONTINUE
        TPEAK=SUMPQ(5,NN)
        TBGND=SUMPQ(6,NN)
C
C-------------------  READ DENSITIES FOR ONE SPOT
C-------------------  CORRECT DENSITIES
C
        N=0
        DO 250 K=1,NXY
        if(.not.image)then
        CALL CBYTE(K)
        else
        call ip_cbyte(k)
        endif
        IF(IOD.EQ.0)GO TO 400
c********************* ovload od from CUTOFF to IMAXOD (in comtem)
        if(.not.image)then
        IF(IOD.GT.IMAXOD) N=N+1
        OD(K)=TABLE(IOD)
        else
        if(abs(int(iod)).gt.imaxod) n=n+1
        od(k)=abs(int(iod))
        endif
250     CONTINUE
        IF(N.GT.FATNO) GOTO 410
        IF(ISWTCH(1).EQ.0) GOTO 260
        IF(XTEK) CALL NEWPG
        CALL RASPLOT(OD,NXX,NYY,MASK(1,NN),-1)
        if (Ltek) CALL SCPAUS
260     continue
      CALL INTEG(OD,LRAS,MASK(1,NN),SUMPQ(1,NN),ASPOT,IDR,FULL)
        ISPOT=SCAI*SPOT+0.5
C ******************************************************************
c
      if(streak) then
c      if(ispot.gt.600) then
      call radmask(1,ix,iy,nxx,nyy,ispot,od)
        TPEAK=SUMPQ(5,NN)
        TBGND=SUMPQ(6,NN)
        CALL INTEG(OD,LRAS,RMASK,rsums,ASPOT,IDR,FULL)
      tpeak = rsums(5)
      tbgnd = rsums(6)
      ispot = scai*spot+0.5
c      irspot = scai *spot+0.5
c      if(.not.batch)write(6,2601) irspot
c      write(8,2601) irspot
c2601      format(/1x,' Radial mask I = ',I8)
c      end if
      end if
        GOTO 300
C
C
C       FOR NON PROFILES NOW GOT SPOT, SHIFTS, BGND, RMSBG,
C                                TPEAK, TBGND,
C
C   ************************* PROFILE ONLY ********************
C
C
C-------------------NOW EVALUATE PROFILE FITTED INTENSITY
C-------------------FOR FULLYS AND PARTIALS IF NEEDED
C
C-------------------------------ZERO IP(.,NUMBIN+1)
C
270     CONTINUE
        ipros = ipros + 1
        DO 280 IMN = 1,5000
280     IP(IMN,NUMBIN+1) = 0
        NYY=IBYTE(IBUF,8)
C
C-------------------FIRST SELECT STANDARD PROFILE BIN
C
        IF(NUMBIN.EQ.5) THEN
                CALL PRONUM5(NOBIN,IX,IY,NECX,NECY,I)
          ELSE
        if (streak) then
                call pronum17(nobin,ix,iy,necx,necy,i)
          else
                CALL PRONUM(NOBIN,IX,IY,NECX,NECY,I)
        end if
        END IF
            nob(ibin) = nobin
c
      if(nobin.eq.numbin) goto 400
c
c     now select background from histogram and
c     put cutu, cutl into combck and bg into nob(nobin)
c     as usual
c
      call hisbck(ix,iy,nob(nobin),0,4)
c
      if(streak) then
      do mbin = 1,5000
      rmask(mbin) = rmaskb(nob(ibin),mbin)      
      end do
      do mbin = 1,6
      rsums(mbin) = rsumsb(nob(ibin),mbin)
      end do
      end if
C
C------------------- GET WEIGHTED PROFILE IF REQUIRED
C
        IF(WTPRO) CALL PROWT(IX,IY,NECX,NECY,I,SVMASK)
C
C------------------- NOW SELECT REQUIRED OD'S
C------------------- PUT INTO IP BIN NUMBIN+1. i.e. IP(N,NUMBIN+1)
C
        CALL PROSEL(IBIN,NXX,NYY,TABLE)
C
C------------------- NOW GET INTENSITY
C
      if(streak) then
              CALL PROBIN(IRAS,rmask,IBIN,NOBIN)
      else
            CALL PROBIN(IRAS,svmask,IBIN,NOBIN)
      end if
C
C------------------  CHECK FOR OVERLOADS
C
c------ problem with bg - to many rejects or too tilted.
c
        if(intpro.eq.99999) then
        nbzero = nbzero + 1
        goto 420
      end if
        IF(INTPRO.NE.9999) GOTO 290
        GOTO 410
C
C------------------- GET PARAMS FOR SHIFTS,SD AND STATS
C
290     CALL PROSIG(DELX,DELY,TPEAK,TBGND,RMSBG,BGND)
        SPOT = FLOAT(INTPRO)
        ISPOT = SCAI*INTPRO+0.5
        intbox = -9999
        if(iboth) intbox = scai*intp+0.5
        DELX = DELX * IDR
C
C
C  ***************************** BOTH *************************
C
C ----------- CALCULATE STANDARD DEVIATION OF INTENSITY
C
300     VSPOT=QFAC*SPOT
        VBG=TPEAK*RMSBG
        if(image) vbg=tpeak*rmsbg*rmsbg
        if(.not.image)then
        ISDBSI=SCAI*SQRT(2*VBG+EFAC*ABS(VSPOT))+0.5
        else
      isdbsi=scai*sqrt(vbg + vbg/tpeak)+0.5
c        isdbsi=scai*sqrt(vbg/tbgnd+vbg/tpeak)+0.5
        endif
        INTEN(J)=ISPOT
        intenb(j) = intbox
        ISD(J)=ISDBSI
c
c***************** for now ...
c
        isdb(j) = isd(j)
c
        SIGPRO = ISDBSI
        IBGND=SCAI*BGND+0.5
        IF(BGND.GT.0.0)GO TO 310
      WRITE(IOUT,1090)IX,IY,IREC(j),intpro
        if(.not.batch)write(6,1090)IX,IY,irec(j),intpro
1090    FORMAT('** ZERO BACKGROUND SPOT, X,Y,REC,intpro **',4I8)
        BGND=0.01
310     CONTINUE
        if(.not.image)then
        BGRATIO=RMSBG/SQRT(QFAC*BGND/TPEAK)
        else
        bgratio=1.0
        endif
c
c **************** skip plot and stats for baddies ***********
c                           5th March 1987
c
        IF((BGRATIO.ge.3.).or.(ISPOT.le.-5*ISDBSI)) GOTO 360
c
        IF(.NOT.FULL) GOTO 320
        if(.not.image)then
        IF(ISPOT.LT.IRANGE(3)) GOTO 320
        else
        if(ispot.lt.iprange(3)) goto 320
        endif
        XX=IX/FACT
        YY=IY/FACT
        DELX=DELX/FACT
        DELY=DELY/FACT
        if ((ltek).AND.(.not.batch)) CALL RESIDPL(XX,YY,DELX,DELY)
        IXX=XX-XCEN
        IYY=YY-YCEN
        CALL XYSHIFT(DELX,DELY,IXX,IYY,XSH,YSH,NSH,1)
320     MAXBSI=MAX0(MAXBSI,ISPOT)
        MINBSI=MIN0(MINBSI,ISPOT)
C
C------------------------- GET STATISTICS
C
        DO 330 K=1,9
        if(.not.image)then
        IF(ISPOT.LT.IRANGE(K)) GOTO 340
        else
        if(ispot.lt.iprange(k)) goto 340
        endif
330     CONTINUE
        K=10
340     IANAL(K)=IANAL(K)+1
        RATIO(K)=RATIO(K)+BGRATIO
        AVSD(K)=AVSD(K)+ISDBSI
        IF(ISWTCH(9).EQ.0)GO TO 350
        CALL COMPR(KREC,IHD,LDUMP,NSPT)
        IF(.NOT.LDUMP)GO TO 430
        GO TO 360
350     IF((BGRATIO.LT.3.).AND.(ISPOT.GT.-5*ISDBSI)) GOTO 430
360     IF(PROFIL.AND.FULL) GOTO 370
        IF(PROPT) GOTO 370
        WRITE(4) KREC,ISPOT,ISDBSI,IBGND,RMSBG,BGRATIO,NXY,NXX,NYY
        WRITE(4)(OD(II),II=1,NXY)
        GOTO 380
370     WRITE(4) KREC,ISPOT,ISDBSI,IBGND,RMSBG,BGRATIO,NPXY,NPX,NPY
        WRITE(4)(IP(II,NUMBIN+1),II=2,NPXY+1)
380     CONTINUE
        NBAD=NBAD+1
        GOTO 430
390     NBOX=NBOX+1
        GO TO 420
400     NEDGE=NEDGE+1
        GO TO 420
410     NOLO=NOLO+1
420     CONTINUE
        INTEN(J)=-9999
        intenb(j) = -9999
        ISD(J)=-9999
        SIGPRO = -9999
        GOTO 460
430     CONTINUE
C
C
C************************************ PROFILE ONLY
C
C------------------- CHECK RESULTS
C
        itots = itots + 1
        if(.not.image)then
        IF(INTEN(J).LT.IRANGE(8)) GOTO 460
        else
        if(inten(j).lt.iprange(8)) goto 460
        endif
        IF(.NOT.PROFIL) GOTO 450
        IF ( ( .NOT. PROPT ) .AND. ( .NOT. FULL) )  GOTO 450
        IF(INTPRO.EQ.9999) GOTO 440
        INTPRO = INTPRO * SCAI + 0.5
440     Call Conbck(Ap,Bp,Cp,Ibin)
        IDUMX = NINT(DELX/5.0)
        IDUMY = NINT(DELY/5.0)
        WRITE(IOUT,1100)INTEN(J),ISD(J),Intenb(j),Isdb(j),
     1            IBIN,NOB(ibin),NPX,
     2            NPY,AP,BP,CP,rsums(5),rsums(6),IDUMX,IDUMY
1100    FORMAT(1X,4I6,3X,4I3,3F8.3,2f8.1,3X,2I4)
        GOTO 460
C
C------------------------ NON PROFILE PARTIAL IN PROFILE RUN
C
450     CONTINUE
        if(.not.image)then
        IF(INTEN(J).LT.IRANGE(8)) GOTO 460
        else
        if(inten(j).lt.iprange(8)) goto 460
        endif
        WRITE(IOUT,1110)INTEN(J),ISD(J)
1110    FORMAT(1X,3I6)
C
C
C   ************************  BOTH HERE *******************
C
C-------------- WRITE OUT IF BUFFER FULL
C
460     IF(J.LT.BUFSIZ) GOTO 500
        CALL WRGEN(J,1)
        J=0
C
C
500     CONTINUE
C
C------------------------------END OF INTEGRATION LOOP
C
        if(ltek) CALL TKPLOT(0,760,1,IER)
        Write(6,1120)
        Write(Iout,1120)
1120    format(1x,//,' END INTEGRATION')
        Call cputime(1)
        If (.not.Ltek) goto 510
        IF(XTEK) CALL NEWPG
C
C---------------------------- WRITE OUT REJECTIONS
C
510     CONT = -9999.
        CALL CONBCK(REJI,AJUNK,CONT,IBIN)
        IREJI = REJI
        IF(IREJI.EQ.1)THEN
              if(.not.batch)write(6,1130) IREJI
              WRITE(8,1130) IREJI
            ELSE
              if(.not.batch)write(6,1131)IREJI
              WRITE(8,1131)IREJI
        END IF
1130    FORMAT(/1X,I12,' Background point was rejected')
1131    FORMAT(/1X,I12,' Background points were rejected')
c
      if(correct) then
      if(.not.batch)write(6,1134) nopuse
      write(8,1134) nopuse
1134      format(/1x,i12,' Spots could not be deconvoluted')
      if(.not.batch)write(6,1135) ratrej
      write(8,1135) ratrej
1135      format(/1x,i12,' H change rejections in total')
      if(.not.batch)write(6,1136) rgdrej
      write(8,1136) rgdrej
1136      format(/1x,i12,' H change rejections in good spots')
          IF(OREJ.EQ.1)THEN
              if(.not.batch)write(6,1132)OREJ
              WRITE(8,1132)OREJ
          ELSE
              if(.not.batch)write(6,1133)OREJ
              WRITE(8,1133)OREJ
          END IF
1132    FORMAT(/1X,I12,' J value rejection in total')
1133    FORMAT(/1X,I12,' J value rejections in total')
      if(.not.batch)write(6,1137) ogdrej
      write(8,1137) ogdrej
1137      format(/1x,i12,' J value rejections in good spots',/)
      end if
c
        IF(J.GT.0)CALL WRGEN(J,1)
        DO 520 I=1,10
        IF (IANAL(I).EQ.0) GO TO 520
        RATIO(I)=RATIO(I)/IANAL(I)
        AVSD(I)=AVSD(I)/IANAL(I)
520     CONTINUE
      nolo = nolo - nopuse
        CALL REPORT
        CALL XYSHIFT(0.0,0.0,0,0,XSH,YSH,NSH,2)
        CLOSE (UNIT=3)
        endfile (unit=4)
        REWIND (unit=4)
        if (ltek) CALL ALPHA
        if(.not.batch)write(6,1140) NBAD
        WRITE(IOUT,1140)NBAD
1140    FORMAT(' ',i8,'BAD SPOTS BASED ON BGRATIO or I/SIGI')
        IF (NBAD.EQ.0) GO TO 600
C
        END4 = .FALSE.
        If (Batch) goto 525
        if(.not.batch)write(6,1150)
        WRITE(IOUT,1150)
1150    FORMAT(' DO YOU WANT TO CHECK BAD SPOTS(Y/N)? [No]',$)
        read(5,1153)JUNK
        WRITE(IOUT,1154)JUNK
1153    format(a1)
1154    format(1x,a1)
        icheck = 0
        CALL NOYES(JUNK,Icheck)
        Yes = .false.
        If(Icheck.eq.1) Yes = .true.
        NCHK = NBAD
        If(.not.YES) goto 525
        if(.not.batch)write(6,1156)NCHK
        WRITE(IOUT,1156)NCHK
1156    FORMAT(' NUMBER OF SPOTS TO CHECK ? [',I4,'] ',$)
        read(5,*)JNK
1157    FORMAT(I4)
        WRITE(IOUT,1158)JNK
1158    FORMAT(1H+,37X,I4)
        IF(JNK.NE.0) NCHK = JNK
        IF(YES)GO TO 540
C
C----- FLAG NBAD SPOTS AS REJECTED IN GENVEE FILE
C
525     N = 0
        DO 530 I=1,1000
        READ(4,end=531)KREC,ISPOT
        READ(4,end=531)JNK
        INTEN(I)=ISPOT
        ISD(I)=-9999
        IREC(I)=IABS(KREC)
        N = N+1
530     CONTINUE
        GOTO 590
531     END4 = .TRUE.
        GO TO 590
540     CONTINUE
        IMAP=0
        if(batch) goto 550
        if(.not.batch)write(6,1160)
1160    FORMAT(' DO YOU WANT A PLOT OF EACH SPOT?(Y/N) [No]',$)
        read(5,1153)JUNK
        WRITE(IOUT,1154)JUNK
        iMAP = 0
        CALL NOYES(JUNK,IMAP)
        If(Ltek) CALL TKCLR
550     N=0
C
C
        DO 580 I=1,1000
        READ(4,END=581) KREC,ISPOT,ISDBSI,IBGND,BGRMS,BGRATIO,NXY,NXX,NYY
        READ(4,END=581)(OD(II),II=1,NXY)
        IF(I.GT.NCHK) GOTO 570
        JREC=IABS(KREC)
        CALL GETHKL(JREC,IH)
        if(.not.batch)write(6,1170)
        WRITE(IOUT,1170)
1170    FORMAT(/'  H   K   L    M   X     Y   INTEN   S.D. BGRATIO')
        WRITE(IOUT,1180) IH,ISPOT,ISDBSI,BGRATIO
        if(.not.batch)write(6,1180)IH,ISPOT,ISDBSI,BGRATIO
1180    FORMAT(4I4,4I6,F8.1/)
        IF(IMAP.EQ.1)GO TO 560
        CALL SETMASK(MASK(1,0),LRAS)
        CALL RASPLOT(OD,NXX,NYY,MASK(1,0),-1)
560     CONTINUE
        yes = .true.
        if(batch) goto 570
        if(.not.batch)write(6,1190)
        WRITE(IOUT,1190)
1190    FORMAT(' REJECT (Y OR N)? [Yes]',$)
        read(5,1153)JUNK
        WRITE(IOUT,1154)JUNK
        ijunK = 1
        CALL NOYES(JUNK,ijunK)
        If(ijunk.eq.0) Yes = .false.
        if(ltek)CALL TKCLR
        IF(.NOT.YES) GOTO 580
570      N=N+1
        INTEN(N)=ISPOT
        ISD(N)=-9999
        IREC(N)=IABS(KREC)
580     CONTINUE
581     END4 = .TRUE.
        IF(N.EQ.0)GO TO 600
590     CALL WRGEN(N,1)
C
        If(END4) then
                goto 600
        else
                if(batch.or.icheck.eq.0) then
                        goto 525
                else
                        goto 550
                end if
        END IF
C
600     CONTINUE
        CLOSE (UNIT=4)
        WRITE(IOUT,1220)
        if(.not.batch)write(6,1220)
1220    FORMAT(1X,/,15('@@@@')/)
1230    FORMAT(' MEASUREMENT BOX LARGER THAN EXPECTED; MAXR=',I6/
     +         'NX=',I4,'NY=',I4,'NXY=',I4)
        RETURN
        END
C
C
C                     PROFILE BIN SELECTION ROUTINE
C                 RETURN BIN NUMBER IN NOBIN
C
      SUBROUTINE PRONUM(NOBIN,IX,IY,NECX,NECY,I)
C
      INCLUDE 'comprf.finc'
C
      IXRES = IX - NECX
      IYRES = IY - NECY
      IRESN = IXRES*IXRES + IYRES*IYRES
      IRESN = SQRT(FLOAT(IRESN)) + 0.5
      NOBIN = NUMBIN
      NADD =0
      IF(IRESN.LE.IRAD) RETURN
      IF(IRESN.LE.IRAD2) NADD = 8
      NADD1 = 0
      ANGL =  FLOAT(IXRES)/FLOAT(ABS(IYRES) + 1)
      IF(ABS(ANGL).GT.1.0) NADD1 = 1
      IF(IX-NECX) 1,3,3
1      NOBIN = 1 + NADD + NADD1
      IF(IY-NECY) 5,2,2
2      NOBIN = 3 + NADD + NADD1
      GOTO 5
3      NOBIN = 5 + NADD + NADD1
      IF(IY-NECY) 4,5,5
4      NOBIN = 7 + NADD + NADD1
5      CONTINUE
C
C
      RETURN
      END
C
C
C                     PROFILE BIN SELECTION ROUTINE
C                 RETURN BIN NUMBER IN NOBIN
C
      SUBROUTINE PRONUM17(NOBIN,IX,IY,NECX,NECY,I)
C
      INCLUDE 'comprf.finc'
C
      IXRES = IX - NECX
      IYRES = IY - NECY
      IRESN = IXRES*IXRES + IYRES*IYRES
      IRESN = SQRT(FLOAT(IRESN)) + 0.5
      NOBIN = NUMBIN
      NADD =0
      IF(IRESN.LE.IRAD) RETURN
c      IF(IRESN.LE.IRAD2) NADD = 8
      NADD1 = 0
      ANGL =  FLOAT(IXRES)/FLOAT(ABS(IYRES) + 1)
      IF(ABS(ANGL).GT.1.0) NADD1 = 1
        if((abs(angl).gt.2.0).or.(abs(angl).lt.0.5)) then
            if(numbin.eq.17) nadd = 8
      end if
      IF(IX-NECX) 1,3,3
1      NOBIN = 1 + NADD + NADD1
      IF(IY-NECY) 5,2,2
2      NOBIN = 3 + NADD + NADD1
      GOTO 5
3      NOBIN = 5 + NADD + NADD1
      IF(IY-NECY) 4,5,5
4      NOBIN = 7 + NADD + NADD1
5      CONTINUE
C
C
      RETURN
      END
C
C
C                PROFILE BIN SELECTION ROUTINE
C                 RETURN BIN NUMBER IN NOBIN
C       ***** PRONUM5 SPECIFIC FOR 5 BINS ONLY *****
C
      SUBROUTINE PRONUM5(NOBIN,IX,IY,NECX,NECY,I)
C
      INCLUDE 'comprf.finc'
C
      IXRES = IX - NECX
      IYRES = IY - NECY
      IRESN = IXRES*IXRES + IYRES*IYRES
      IRESN = SQRT(FLOAT(IRESN)) + 0.5
      NOBIN = 5
      IF(IRESN.LE.IRAD) RETURN
      IF(IX-NECX) 1,3,3
1      NOBIN = 1
      IF(IY-NECY) 5,2,2
2      NOBIN = 2
      GOTO 5
3      NOBIN = 3
      IF(IY-NECY) 4,5,5
4      NOBIN = 4
5      CONTINUE
C
C
      RETURN
      END
C
C
C                        SUBROUTINE TO SCALE PROFILES
C
      SUBROUTINE PROSCL(J, IRAS1 ,IRAS2 ,HX,HY)
      INTEGER  HX, HY
C
      INCLUDE 'comuab.finc'
      INCLUDE 'comprf.finc'
      INCLUDE 'combck.finc'
C
C-------------  SCALE IPSC(J)
C
      NXY = IRAS1 * IRAS2
      DO 1 N = 2,NXY+1
      IP(N,J) = NINT((IPSC(J) * XIP(N,J)))
C
C--------------   SET NEGATIVES TO ZERO HERE
C
1      IF(IP(N,J).LT.0) IP(N,J)=0
c      if(.not.batch)write(6,1102)J
c      WRITE(8,1102)J
c1102      FORMAT(1X,' *** BIN N0. ',I3,' SCALED PROFILE ***')      
      WRITE(8,100) IPSC(J)
      if(.not.batch)write(6,100) IPSC(J)
100      FORMAT(1X,'      BIN SCALE FACTOR IS ',F8.4)
C
C---------------  PRINT OUT BACKWARDS AS ON FILM
C
      IST= 2
      IEND = NXY + 1
      IDIR = -IRAS2
      DO 600 IO = -HY,HY
      WRITE(8,601) (IP(IJ,J),IJ=IEND,IST,IDIR)
      if(.not.batch)write(6,602) (IP(IJ,J),IJ=IEND,IST,IDIR)
602      FORMAT(2X,40I3)
601      FORMAT(/1X,40I3)
      IEND = IEND - 1
600      CONTINUE
        RETURN
      END
C
C
C                  SUBROUTINE TO SELECT OD'S IN THE UNEXPANDED AREA
C                               OF THE SPOT FOR PROFILE FITTING.
C
C--------------- ARRAY IP, RAW UNSCALED SPOT, RETURNED IN IP
C                           FOR STANDARDS PROFILE IS
C                  SO FAR UNSCALED AND NOT AVERAGED.
C
C
      SUBROUTINE PROSEL(IBIN,NXX,NYY,TABLE)
C
cRCD Image Plate logical...
        common/iplate/image,mar,moldyn
        logical image,mar,moldyn
C
      INCLUDE 'comhis.finc'
      INCLUDE 'comprf.finc'
      INCLUDE 'comras.finc'
      INCLUDE 'comtem.finc'
C
C       EXTERNAL PEL
      COMMON /PEL/IOD,BUF(5120),nextr
        integer*2 buf,iod
      INTEGER TABLE(0:255),PSUM,BSUM
      dimension nip(5000)
C
      integer i4od
C
C-----------------SELECT ONLY THE OD'S IN THE UNEXPANDED SPOT
C
      NXY   = NXX * NYY
      ISTX  = (NXX - NPX)/2 + 1
      ISTY  = (NYY - NPY)/2 + 1
      IENDX = ISTX + NPX -1
      IENDY = ISTY + NPY -1
      N1ROW = (ISTX-1)*NYY
      N2ROW = (IENDX * NYY)+1
      INY1  = ISTY+NRY-1
      INY2  = IENDY-NRY+1
      NXY1  = N1ROW+(NRX*NYY)
      NXY2  = N2ROW-(NRX*NYY)
C
C----------------ROUGH BG/PEAK POINTS FOR WEAK SPOTS
C----------------WHEN FORMING STANDARDS. UNEXPANDED
C----------------AREA ONLY
C
      NPK = (NPX-2*NRX)*(NPY-2*NRY)
      NBG = 0
C
C----------------------  SUM OD.S FOR GIVEN RASTER SIZE
C                             PUT INTO STANDARD PROFILE
C                                  ARRAY IP(5000,IBIN)
      NMBN = NUMBIN + 1
      PSUM = 0
      BSUM = 0
      KIP = 0
      J = 0
        DO 898 K=1,NXY
        if(.not.image)then
        CALL CBYTE(K)
        else
        call ip_cbyte(k)
        endif
C
C--------------------SELECT REQUIRED DENSITIES
C                   WITHIN UNEXPANDED AREA ONLY FOR PROFILES
C
      IF((K.LE.N1ROW).or.(K.GE.N2ROW)) GOTO 898
      J = J + 1
      IF (J.LT.ISTY) GOTO 898
      IF (J.GT.IENDY) GOTO 897
      KIP = KIP + 1
C
C--------------------  MAKE IOD TABLE(IOD) FOR REAL PROCESSING
C--------------------  check for overloads when forming standards
C
        i4od = abs(int(iod))
c
      IF(IBIN.NE.NMBN) Then
C
            if(.not.image)then
            if(TABLE(iod).ge.IMAXOD) Then
                  ibin = -1
                  RETURN
            End If
            else
                if(i4od.ge.imaxod)then
                        ibin = -1
                        RETURN
                endif
            endif
C
C            ---- PSUM IS TOTAL COUNT IN SPOT AREA
C            ---- BSUM IS TOTAL COUNTS OVER BG AREA
C            ---- BOTH FOR UNEXPANDED SPOT ONLY
C            ---- NEEDED IN SPOT SELECTION FOR STANDARDS
C
C            -----  PUT IOD INTO NIP TEMPORARILY FOR STANDARDS
C            -----  IN CASE WE THROW SPOT OUT FROM STANDARD SUM
C
C
            if(.not.image)then
            PSUM = PSUM + TABLE(IOD)
            IF( (J.LE.INY1).OR.(J.GE.INY2).OR.
     1          (K.LE.NXY1).OR.(K.GE.NXY2) ) then
                     BSUM = BSUM + TABLE(IOD)
                   nbg = nbg + 1
            end if
            NIP(KIP) = TABLE(IOD)
            else
            PSUM = PSUM + i4od
            IF( (J.LE.INY1).OR.(J.GE.INY2).OR.
     1          (K.LE.NXY1).OR.(K.GE.NXY2) ) then
                     BSUM = BSUM + i4od
                   nbg = nbg + 1
            end if
            NIP(KIP) = i4od
            endif
C
C
      Else
            if(.not.image)then
            IP(KIP+1,IBIN) = IP(KIP+1,IBIN) + TABLE(IOD)
            else
                ip(kip+1,ibin) = ip(kip+1,ibin) + i4od
            endif
      End If
C
  897      IF (J.EQ.NYY) J = 0
  898      CONTINUE
      IF(KIP.NE.NPXY) STOP 'STOP AT 898 IN PROSEL: KIP NE NPXY'
C
C------------------ CHECK FOR WEAK SPOT
C------------------ WHEN FORMING STANDARDS
C
            if(ibin.eq.NMBN) Return
          BAV = FLOAT(BSUM) / FLOAT(NBG)
          IAPX = PSUM - FLOAT(NPXY) * BAV      
c
c      include in background histogram
c
      call hisbck(1,1,BSUM,nbg,2)
c
          IF(IAPX.LT.NPWK) GOTO 910
C
C------------------ GOOD SPOT, INCLUDE IN STANDARD
C
      DO 900 K = 1,NPXY
900      IP(K+1,IBIN) = IP(K+1,IBIN) + NIP(K)
      RETURN
C
C------------------- FLAG OVERLOADS AND WEAKSPOTS BY IBIN=-1
C------------------- ONLY WHEN FORMING STANDARDS
C
910      ibin = -1
      RETURN
      END
C
C
C                        SUBROUTINE TO SET UP PROFILES
C                       FOR STANDARDS. READING B AT P,Q
C
C                     IPROB(P,Q) = J*(B - Pa - Qb - c)/J*J
C
      SUBROUTINE PROSET(J, B,XX, YY, SIGN)
      INTEGER XX, YY, SIGN
C
      INCLUDE 'comprf.finc'
      INCLUDE 'combck.finc'
C
C-------------  PUT IPJ(J) INTO THE SCALING
C
      XP = FLOAT(XX)
      YP = FLOAT(YY)
      B = B - XP*A(J) - YP * BZ(J) - C(J)
C
C-------------SCALE BY 10000. TO RETURN B
C
      B =  B * 10000.
      IF(B.LE.0) RETURN
C
C---------------   DONT USE BG POINTS FOR SCALING
C
      IF(SIGN.LE.0) RETURN
      BSCAL = 1000000./B
      IF(BSCAL. LT. IPSC(J)) IPSC(J) = BSCAL
C
C--------------  GET NUMBER OF POINTS IN PEAK FOR LATER
C
      IF(J.NE.1) RETURN
      PN = PN + 1
      PPSUM = PPSUM + XP * XP
      QQSUM = QQSUM + YP * YP
      RETURN
      END
C
C
C           SUBROUTINE TO GET CONSTANTS FOR THIS SPOT
C
      SUBROUTINE PROSIG(DELX,DELY,TP,TB,RMSBG,BGND)
C
      INCLUDE 'comuab.finc'
      INCLUDE 'combck.finc'
      INCLUDE 'comprf.finc'
      INCLUDE 'commask.finc'
      INCLUDE 'commaskl.finc'
C
      NMBN = NUMBIN + 1
      TP = FLOAT(PN)
      if (streak) then
            tp = rsums(5)
      end if
      IF(TP.gt.0) GOTO 3112
      if(.not.batch)write(6,3111) tp
      WRITE(8,3111) tp
3111      FORMAT(/1X,' Problem in prosig: TP is ', f10.3,/)
3112      IF(.NOT.CHANGE(NMBN)) BN(NMBN) = AMST(3,3)
      TB = FLOAT(BN(NMBN))
      IF(TB.NE.0) GOTO 312
      if(.not.batch)write(6,311)
      WRITE(8,311)
311      FORMAT(/1X,' STOP AT RMSBG .. /TB IN PROSIG',
     1               ' TB IS ZERO',/)
      STOP
312      CONTINUE
      RMSBG = SQRT(FLOAT(SIGMA(NMBN))/TB)
      IF(rmsbg.GT.0.0) then
        if(streak) then
        if(tb.gt.5.and.tb.le.rsums(6)) GOTO 3122
        else
        if(tb.gt.5.and.tb.le.amst(3,3)) GOTO 3122
        end if
      end if
      if(.not.batch)write(6,3121) rmsbg,tb,tp
      WRITE(8,3121) rmsbg,tb,tp
3121      FORMAT(1X,' Problem in prosig: RMSBG,TB,TP are: ',
     1              3f8.3)
3122      BGND = BO(NMBN)+20000.0
      IF(INTPRO.LE.0) RETURN
      pps = ppsum
      qqs = qqsum
      if (streak) then
       pps = rsums(1)
       qqs = rsums(3)
      end if
      DELX = (PODSUM - A(NMBN)*PPS)/FLOAT(INTPRO)
      DELY = (QODSUM - BZ(NMBN)*QQs)/FLOAT(INTPRO)
      RETURN
      END
C
C
C            PROFILE VARIABLE WEIGHTING CONSTANT
C
      SUBROUTINE PROVAR
C
      INCLUDE 'comuab.finc'
      INCLUDE 'comprf.finc'
C
      DIMENSION AVAR(18)
      REAL WT
C
C------------------ LOOP OVER BINS
C
      NMBN = NUMBIN - 1
      if(numbin.eq.17) nmbn = 8
      DO 1 IK=1,NMBN      
      if(numbin.eq.17) then
            ixres = ixbin(ik) - ixbin (ik+8)
            iyres = iybin(ik) - iybin (ik+8)
            ixres = ixres * ixres
            iyres = iyres * iyres
        else
            IXRES = IXBIN(IK) * IXBIN(IK)
            IYRES = IYBIN(IK) * IYBIN(IK)
      end if
      WT =  FLOAT(IXRES + IYRES)
C
C---------------- GET AVAR = .05 AT OUTER BIN CENTRES
C
      AVAR(IK) = 3.0/WT
1      CONTINUE
C
C-------------------  LOOK AT SOME RESULTS
C
      SUMW = 0
      DO 2 IK = 1,NMBN
      SUMW = SUMW + AVAR(IK)
      WRITE(8,3)IK, AVAR(IK)
      if(.not.batch)write(6,3)IK, AVAR(IK)
2      CONTINUE
      ACONS = SUMW/FLOAT(NMBN)
      WRITE(8,4) ACONS
      if(.not.batch)write(6,4) ACONS
3      FORMAT(2X,' BIN ',I3,' Weighting Constant ACONS = ',F12.8)
4      FORMAT(/1X,'                    Average ACONS = ',F12.8)
      RETURN
      END
C
C
C                     PROFILE VARIABLE WEIGHTING
C
      SUBROUTINE PROWT(IX,IY,NECX,NECY,I,MASK)
C
      INCLUDE 'comprf.finc'
C
      INTEGER MASK(1)
      REAL SUMW,SUMWP,WT,MAX,EXWT(18)
      IPW(1) = NPX * 256 + NPY
        IJ=0
      MAX = -999.
      IXSH = IX - NECX
      IYSH = IY - NECY
      NMBN = NUMBIN + 1
C
C------------------ SET UP WTS
C
      SUMW = 0.0
      ibin2 = numbin
      if(numbin.eq.17) then
            if(nob(nmbn).ne.17) ibin2 = 16
      end if
      DO 10 IK = 1,ibin2
      IXRES = IXBIN(IK) - IXSH
      IYRES = IYBIN(IK) - IYSH
      WT = - ACONS * FLOAT(IXRES*IXRES + IYRES*IYRES)      
      EXWT(IK) = EXP(WT)
      SUMW = SUMW + EXWT(IK)
10      continue
C
C------------------ LOOP OVER PROFILE
C
      DO 40 IPRO = 2,NPXY+1
      SUMWP = 0.0
      IJ = IJ + 1
C
C----------------  ONLY FOR PEAK
C
      IF (MASK(IJ)) 40,40,20
C
C-----------------  LOOP OVER BINS
C
20      CONTINUE
      DO 30 IK = 1,ibin2
      SUMWP = SUMWP + EXWT(IK) * FLOAT(IP(IPRO,IK))
30      CONTINUE
C
C------------------ USE XIP(..,NUMBIN+1) FOR SCALING
C
      XIP(IPRO,NMBN) = SUMWP/SUMW
      IF(XIP(IPRO,NMBN).GE.MAX) MAX = XIP(IPRO,NMBN)
40      CONTINUE
C
C------------------- NOW SCALE
C
      DO 50 IPRO = 2,NPXY+1
      IPW(IPRO) = NINT(100. * XIP(IPRO,NMBN)/MAX)
50      CONTINUE
C
      RETURN
      END
C
C
C
C
C                      *********************************************
C                      *                                           *
C                      *        ****  SUBROUTINE PWRITE  ****      *
C                      *                                           *
C                      *********************************************
C
C
C
C=============================================================
C
      SUBROUTINE PWRITE(IREC,IA,IB,L,IU)
      INTEGER*2 IA(4),IB(L)
      WRITE(IU)irec,L,IA
      WRITE(IU)IB
      RETURN
      END
c
c  Program designed to create a mask for radial streaks
c
      subroutine radmask(irecm,ixmin,iymin,nxm2,nym2,ispotr,odm)
C
      INCLUDE 'comras.finc'
      INCLUDE 'comscn.finc'
      INCLUDE 'comori.finc'
      INCLUDE 'commcs.finc'
      INCLUDE 'commask.finc'
      INCLUDE 'commaskl.finc'
C
      integer odm(5000)
      integer tem(5000)
c
      logical output
c
c  Get xcen,ycen from common ORI, both in 10micron units positive
c  incoming ixmin,iymin are in rasters, positive for irecm=1
c                           in rasters about centre for irecm=-1
c  convert to rasters about centre using fact (0.2 for 50micron)
c
c      eg, xcen,ycen 6000,6000
c           ixmin,iymin   200,1700
c           fact = 0.2
c
      ixm = ixmin
      iym = iymin
      if(irecm.eq.1) then
            ixm = anint(  (float(ixmin) - xcen*fact)  )
            iym = anint(  (float(iymin) - ycen*fact)  )
      end if
c
c LATER ? get NXS and NYS (box size) from common RAS
c
       nxm = nxm2/2
       nym = nym2/2
c
c cmask is constant eta*D or FULL spot size (mm) for k=0
c bminor is full width in mm
c dmask is cf in mm
c kmask is scale: 0 for constant, 1 for MMH
c all read in in mosuab and converted in procuab
c Set mask array to zero initially
c
      do 1 j=1,5000
1     rmask(j) = 0
      do 11 j=1,6
11      rsums(j) = 0.0
c
      pi = 4.0*atan(1.0)
c
c seekrs finds values for a & b as follows
c
c       bminor = bminor/2.0*100.*fact
c       cmask = cmask/2.0*100.*fact
c       dmask = dmask*100.*fact
c
         jxstart = ixm - nxm
         jxend   = ixm + nxm
         kystart = iym - nym
         kyend   = iym + nym
      if (ixm.eq.0) then
         theta = pi/2.0
         if(iym.lt.0)then
         theta = 1.5*pi
         end if
         goto 1001
      end if
c
      theta = atan(float(iym)/float(ixm))
      if (ixm.lt.0) then
           theta = theta + pi
      else
         if(iym.lt.0)then
           theta = theta + 2.0*pi
         end if
      end if
1001      continue
      radius = sqrt(float(ixm**2) + float(iym**2))
      if (binvar) then
         angle = theta - themax
         anew = ammin**2*sin(angle)**2+ammax**2*cos(angle)**2
         amajor = sqrt(anew) *(1. + kmask*radius/dmask)
      else
         amajor = cmask *(1. + kmask*radius/dmask)
      end if
      imark = 0
c
c ods are stored as if film scanned backwards (IDIR = -1)
c An old throwback from interactive work.
c RMASK must therefore be stored the same way.
c Printing of masks, spots, profiles etc by RASPLOT, PROSCL
c and here are now the same. Eventually need to use IDIR since
c not sure which way spot refinement works.
c
            do j=jxend,jxstart,-1
      do k=kystart,kyend
      imark = imark + 1
         xprime = (float(j)-ixm)*cos(theta)
         xprime = xprime + (float(k)-iym)*sin(theta)
         yprime = (float(k)-iym)*cos(theta)
         yprime = yprime - (float(j)-ixm)*sin(theta)
         abg    = amajor + 1.0 + border
         bbg    = bminor + 1.0 + border
         ellipb = (xprime**2/abg**2) + (yprime**2/bbg**2)
         if (ellipb.le.1.0) then
           aig    = amajor + 1.0
           big    = bminor + 1.0
           ellipi = (xprime**2/aig**2) + (yprime**2/big**2)
           if(ellipi.le.1.0)then
             ellip  = (xprime**2/amajor**2) + (yprime**2/bminor**2)
             if(ellip.le.1.0)then
c PEAK
      rsums(1) = rsums(1) + (jxend-j-nxm)*(jxend-j-nxm)
      rsums(3) = rsums(3) + (k-kystart-nym)*(k-kystart-nym)
      rsums(5) = rsums(5) + 1
               rmask(imark) = 1
               goto 1002
             end if
             goto 1002
           end if
C BACKGROUND
      rsums(2) = rsums(2) + (jxend-j-nxm)*(jxend-j-nxm)
      rsums(4) = rsums(4) + (k-kystart-nym)*(k-kystart-nym)
      rsums(6) = rsums(6) + 1
           rmask(imark) = -1
         end if
1002  end do
      end do
c
      if(ispotr.eq.9111) then
            ii = 0 
            do 990 i=1,nxm2
            kst = nxm2*nym2-(i*nym2)+1
            kend = kst + nym2 - 1
            do 989 j=kst,kend
            ii = ii + 1
989            tem(ii) = rmask(j)
990            continue
            nxy2 = (nxm2*nym2) + 1
            do 991 j=1,nxy2
991            rmask(j) = tem(j)
      end if
c
c      call cputime(1)
c
c Write mask array to output file
c
c      output = .true.
c       if(output)then
c      if(irecm.ge.0.and.ispotr.lt.1000) goto 964
c      write(8,975)nxm2,nym2,ixm,iym
c975      format(1h1,' box size ',2i8,6x,' spot at ',2i8)
c      if(.not.batch)write(6,976)nxm2,nym2,ixm,iym
c976      format(1x,' box size ',2i8,6x,' spot at ',2i8)
c
c      write(8,9751) rsums
c      if(.not.batch)write(6,9751) rsums
c9751      format(1x,' Rsums = ',6f10.0)
c
c      do 990 i=1,nym2
c      kst = nxm2*nym2-i+1
c      kend = nym2-i+1
c      write(8,981) (rmask(k),k=kst,kend,-nym2)
c      if(.not.batch)write(6,981) (rmask(k),k=kst,kend,-nym2)
c981      format(1x,34i3)
c990      continue
c
c      if(.not.batch)write(6,982)
c      write(8,982)
c982      format(1x,//)
c
c      do 991 i=1,nym2
c      kst = nxm2*nym2-i+1
c      kend = nym2-i+1
c      write(8,981) (odm(k),k=kst,kend,-nym2)
c      if(.not.batch)write(6,981) (odm(k),k=kst,kend,-nym2)
c991      continue
c
c        end if
c      if(.not.batch)write(6,2601) ispotr
c      write(8,2601) ispotr
c2601      format(/1x,' Square  mask I = ',I8)
c964      continue
c
c      do 990 i=1,nym2
c      kst = nxm2*nym2-i+1
c      kend = kst + (nxm2-1)*nym2
c      write(8,981) (rmask(k),k=kst,kend,nym2)
c      if(.not.batch)write(6,981) (rmask(k),k=kst,kend,nym2)
c990      continue
c
c      do 991 i=1,nym2
c      kst = i
c      kend = kst + (nxm2 - 1)*nym2
c      write(8,981) (odm(k),k=kst,kend,nym2)
c      if(.not.batch)write(6,981) (odm(k),k=kst,kend,nym2)
c991      continue
      return
      end
C
C
C
C
C                      *********************************************
C                      *                                           *
C                      *        ****  SUBROUTINE RASPLOT ****      *
C                      *                                           *
C                      *********************************************
C
C
C
C=============================================================
C
        SUBROUTINE RASPLOT(BB,IWX,IWY,MASK,IDR)
C
      INCLUDE 'comuab.finc'
      INCLUDE 'comsnd.finc'
      INCLUDE 'commaskl.finc'
C
        INTEGER BB(1),MASK(1)
        CHARACTER*1 IA(72),ISYMB(-1:1),KSYMB
        COMMON/IOO/IOUT
        DATA ISYMB/'-','*',' '/
        DATA KSYMB/' '/
        CHARACTER*1 ICHAR(0:36)
        DATA ICHAR/'0','1','2','3','4','5','6','7','8','9',
     1    'A','B','C','D','E','F','G','H','I','J','K','L',
     1    'M','N','O','P','Q','R','S','T','U','V','W','X',
     1    'Y','Z',']'/
C
C---------------------------- SET SYMBOLS
C
        DO 1 I=1,72
1       IA(I)=KSYMB
        If (Batch) goto 2
C        OPEN(UNIT=7,FILE='TT:',STATUS='UNKNOWN',DISPOSE='DELETE')
2       NXY=IWX*IWY
        N=NXY
        IF(IDR.EQ.1) N=IWY
        If (.not.Ltek) goto 3
        IF(.NOT.XTEK) CALL TKCLR
3       DO 6 J=1,IWY
        IJ=N-J+1
        JJ=1
        DO 4 I=1,IWX
        NUM=(BB(IJ)*36)/255
        IA(JJ)=ISYMB(MASK(IJ))
        IA(JJ+1)=ICHAR(NUM)
      if (streak) then
            if(mode.eq.1) then
                  if(ia(jj).eq.isymb(0)) then
                         ia(jj+1)=isymb(0)
                  end if
                  ia(jj) = ksymb
            end if
      end if
c
        JJ=JJ+2
        IJ=IJ+IDR*IWY
4       CONTINUE
        IF(XTEK) WRITE(6,1000) IA
        IF((.NOT.ltek).AND.(.NOT.xtek).AND.(.NOT.batch)) WRITE(6,1000)IA
1000    FORMAT(1X,72A1)
        If (.not.Ltek) goto 5
        IF(.NOT.XTEK) WRITE(6,1001) IA
1001    FORMAT(9X,72A1)
5       WRITE(IOUT,1002)IA
1002    FORMAT(20X,72A1)
6       CONTINUE
C        CLOSE (UNIT=7)
        RETURN
        END
C
      SUBROUTINE RDBLK(IUNIT,IBLK,IBA,LEN,IER)
C     READ A RECORD FROM THE DA DISK FILE OF DIGITIZED DATA
cRCD ...Image Plate logical
      common/iplate/image,mar,moldyn
      logical image,mar,moldyn
c
cRCD ...Set up temps and masks for byte swapping and reflection of stripe
      INTEGER*2 IBA(LEN),temp(5120),temp1,temp2,maska,maskb
      data maska,maskb/'377'o,'177400'o/
c
C   C   JUNK=IBLK+IER
      IER=1
cRCD ...Standard film read
      if(.not.image)then
      READ(IUNIT,REC=IBLK,ERR=90)IBA
C      FIND(IUNIT,REC=JUNK)
      RETURN
      else
cRCD ...Image Plate read - swap bytes if necessary
      read(iunit,rec=iblk,err=90)IBA
      do 10 i=1,len
c          temp1 = ishft(iand(iba(i),maska),8)
c          temp2 = ishft(iand(iba(i),maskb),-8)
c          temp(i) = ior(temp1,temp2)
         temp(i) = iba(i)
10    continue
cRCD ...Reverse order of stripe if necessary
      do 20 i=1,len
c         ii=len-i+1
         ii=i
         iba(i) = temp(ii)
20    continue
      return
      endif
   90 IER=-1
      write(6,*)' ***** ERROR IN RDBLK *****'
      write(6,91) IBLK,LEN
91      format(1x,' IBLK = ',i7,'  LEN = ',i7)
      STOP
      END
C
C
C
C
C
C
C                      *********************************************
C                      *                                           *
C                      *        ****  SUBROUTINE RDIST  ****       *
C                      *                                           *
C                      *********************************************
C
C
C
C=============================================================
C
C
C            ****  SUBROUTINE RDIST  ****
C
C REFINES FILM CENTRE, FILM ORIENTATION, CRYSTAL TO FILM DISTANCE, YSCAL
C AND FILM DISTORTIONS FOR FLAT FILMS USING A NON-LINEAR LEAST SQUARES
C METHOD AND REPORTS NEW FIDUCIAL CONSTANTS
C
C
c##### laue mods - spot information taken from common/laue
C=============================================================
C
C
        SUBROUTINE RDIST
c
cRCD ...Image Plate Logical
        common/iplate/image,mar,moldyn
        logical image,mar,moldyn
c
        COMMON/IOO/IOUT
        COMMON/SW/ISWTCH(10),oneref,noref,tworef
C
      INCLUDE 'comori.finc'
      INCLUDE 'comfid.finc'
      INCLUDE 'comrfs.finc'
      INCLUDE 'commcs.finc'
      INCLUDE 'comuab.finc'
      INCLUDE 'comlaue.finc'
C
        INTEGER XGEN(512),YGEN(512)
        REAL CLCX(512),CLCY(512)
        REAL RF(100),R(10),RR(10),W(10),DDX(10),DDY(10)
        LOGICAL BAD(512),oneref,noref,tworef
c##### laue mods
c      integer buf(10)
c      EQUIVALENCE (BUF(3),IX),(BUF(4),IY)
C
cRCD ...Define variables for AGWL's MOSFLM IP refinement
        real cpsi,spsi
C
C----------------  COORDINATES USED IN THIS OVERLAY
C
C---- (CLCX,CLCY) ARE FROM THE GENERATE-FILE AND THEREFORE
C                 IN 10 MICRON UNITS RELATIVE TO THE CENTRE
C                 OF THE DIFFRACTION PATTERN
C--- (XRS,YRS)   ARE IN 10 MICRON UNITS (FROM OVERLAY SEEKRS OR NEXT)
C
C--- LEAST SQUARES REFINEMENT OF XTOFRA,XCEN,YCEN AND OMEGA0
C--- DONE BY FITTING OBSERVED POSITIONS (XRS,YRS) TO THOSE
C--- IN THE GENERATE-FILE (CLCX,CLCY)
C
C--- NO. OF PARAMETERS TO REFINE
        NP=8
cRCD ...Allow for 9 variables of MAR IP (AGWL's MOSFLM)
        if(mar)np=9
      if(moldyn) np=7
        NP2=NP*NP
        OMEGA0=ASIN(SINOM0)
        NOTRY=0
      if(.not.noref) then
        WRITE(IOUT,1000) NRS
        if (.not.batch)WRITE(6,1000)NRS
 1000   FORMAT(/' FILM DISTORTION REFINEMENT USING',I3,' SPOTS'/)
C
      else
        WRITE(IOUT,2003) NRS
        if (.not.batch)WRITE(6,2003)NRS
 2003   FORMAT(/' CALCULATE RESIDUALS FOR ',I3,' UNREFINED SPOTS'/)
      endif
        NXD=ANINT(CTOFD*XTOFRA)
        ITILT=TILT/FDIST
        ITWIST=TWIST/FDIST
        if(.not.image)then
        IBULGE=BULGE/FDIST
        WRITE(IOUT,2005)XCEN,YCEN,XTOFRA,NXD,YSCAL,ITILT,ITWIST,
     1      IBULGE
        if (.not.batch)
     1  WRITE(6,2005)XCEN,YCEN,XTOFRA,NXD,YSCAL,ITILT,ITWIST,
     1      IBULGE
        else if (mar) then
        WRITE(IOUT,2007)XCEN,YCEN,XTOFRA,NXD,YSCAL,ITILT,ITWIST,
     1      roff,toff
        if (.not.batch)
     1  WRITE(6,2007)XCEN,YCEN,XTOFRA,NXD,YSCAL,ITILT,ITWIST,
     1      roff,toff
      else if (moldyn) then
        WRITE(IOUT,2004)XCEN,YCEN,XTOFRA,NXD,YSCAL,ITILT,ITWIST
      write(iout,2002)spdx_min,spdx_max,(spdx(ni),ni=1,nspdx)
      write(iout,2012)spdy_min,spdy_max,(spdy(ni),ni=1,nspdy)
      write(iout,2013)spdxy
        if (.not.batch) then
        WRITE(6,2004)XCEN,YCEN,XTOFRA,NXD,YSCAL,ITILT,ITWIST
      write(6,2002)spdx_min,spdx_max,(spdx(ni),ni=1,nspdx)
      write(6,2012)spdy_min,spdy_max,(spdy(ni),ni=1,nspdy)
      write(6,2013)spdxy
      endif
        endif
2007    FORMAT(/' STARTING PARAMETERS:  ',/
     1    2X,'    XCEN    YCEN  XTOFRA   XTOFD  YSCALE    TILT   TWIST'
     2        ,'   Roff    Toff',/2X,2I8,F8.4,I8,F8.4,2I8,2f7.1/)
2005    FORMAT(/' STARTING PARAMETERS:  ',/
     1    10X,'    XCEN    YCEN  XTOFRA   XTOFD  YSCALE    TILT   TWIST'
     2        ,' BULGE',/10X,2I8,F8.4,I8,F8.4,3I8/)
2004    FORMAT(/' STARTING PARAMETERS:  ',/
     1    10X,'    XCEN    YCEN  XTOFRA   XTOFD  YSCALE    TILT   TWIST'
     2        ,/10X,2I8,F8.4,I8,F8.4,2I8/)
2002      format(1x,' IP x  distortion: ',2f12.2,/(8f10.7))
2012      format(1x,' IP y  distortion: ',2f12.2,/(8f10.7))
2013      format(1x,' IP xy distortion: ',f10.7,/)
c
      ang0 = omega0 * 57.296
      angf = omegaf * 57.296
        CCOM=(OMEGA0-OMEGAF)*57.296
        WRITE(IOUT,2006) CCX,CCY,CCOM,
     1                 angf,ang0,sinom0,cosom0
        if (.not.batch)WRITE(6,2006)CCX,CCY,CCOM,
     1                 angf,ang0,sinom0,cosom0
2006    FORMAT(' STARTING CAMERA CONSTANTS.'/' CCX: ',I8/
     1      ' CCY: ',I8/' CCOM:',F8.4/
     1      ' wF : ',f8.4/' w0  :',F8.4/
     1      ' sinw:',f8.4/' cosw:',F8.4/)
C
C------------------  READ COORDS FROM GENERATE FILE
c##### laue mods - coords from core
c
C
        DO 1 J=1,NRS
        IR=RRS(J)
c        READ(1,REC=IR) BUF
c        XGEN(J)=IX
c        YGEN(J)=IY
      xgen(j) = xyge(1,ir)
      ygen(j) = xyge(2,ir)
        BAD(J)=.FALSE.
1       CONTINUE
        GOTO 10
2       WRITE(IOUT,1001) RMSRES
        if (.not.batch)WRITE(6,1001)RMSRES
1001    FORMAT('  STARTING RESIDUAL=',F5.1)
        ESTART=RMSRES
      if(noref) return
3       CONTINUE
C
C--------------------- START LOOP FOR NON-LINEAR REFINEMENT
C
        DO 9 ICYC=1,2
C
C------------------------ INITIALIZE SUMS
C
        DO 4 K=1,NP
4       W(K)=0.0
        DO 5 K=1,NP2
5       RF(K)=0.0
C
C------------------------- SET UP NORMAL EQUATIONS
C
        DO 7 J=1,NRS
        IF(BAD(J)) GOTO 7
        XG=float(XGEN(J))
        YG=float(YGEN(J))
        RG=SQRT(XG*XG+YG*YG)
        XM=XG*COSOM0-YG*SINOM0
        YM=YG*COSOM0+XG*SINOM0
        if(rg.eq.0.0)then
        cpsi = 1.0
        spsi = 0.0
        else
        cpsi = xm/rg
        spsi = ym/rg
        endif
        dxtof = xtofra+tilt*xg+twist*yg+bulge*rg
        if(image) dxtof = xtofra+tilt*xg+twist*yg
c xcen
        DDX(1)=1.0
        DDY(1)=0.0
c ycen
        DDX(2)=0.0
        DDY(2)=1.0
c omega
        DDX(3)=-ym*dxtof
        DDY(3)=xm*yscal*dxtof
c yscal
        DDX(4)=0.0
        DDY(4)=ym*dxtof
c xtofra
        DDX(5)=xm
        DDY(5)=ym*yscal
c tilt
        DDX(6)=xg*xm
        DDY(6)=xg*ym*yscal
c twist
        DDX(7)=yg*xm
        DDY(7)=yg*ym*yscal
c bulge
        if(.not.image)then
        DDX(8)=rg*xm
        DDY(8)=rg*ym*yscal
c roff,toff
        else if (mar) then
        ddx(8)=cpsi
        ddy(8)=spsi
        ddx(9)=-spsi
        ddy(9)=cpsi
        endif
C
      if(moldyn) then
            call xymd (xc1,yc1,xg,yg)
      else
        CALL XYCALC(XC1,YC1,XG,YG)
      endif
        XO=float(XRS(J))-XC1
        YO=float(YRS(J))-YC1
        IK=0
        DO 6 I=1,NP
        W(I)=W(I)+DDX(I)*XO+DDY(I)*YO
        DO 6 K=1,NP
        IK=IK+1
        RF(IK)=RF(IK)+DDX(I)*DDX(K)+DDY(I)*DDY(K)
6       CONTINUE
7       CONTINUE
C
C-----------------------------  SOLVE
C
        CALL MINV(RF,NP,DET,R,RR)
        IK=0
        DO 8 I=1,NP
        R(I)=0.0
        DO 8 K=1,NP
        IK=IK+1
        R(I)=R(I)+RF(IK)*W(K)
8       CONTINUE
C
C------------------------------ UPDATE PARAMETERS
C
        XCEN=XCEN+nint(R(1)+.5)
        YCEN=YCEN+nint(R(2)+.5)
        OMEGA0=OMEGA0+R(3)
        YSCAL=YSCAL+R(4)
        XTOFRA=XTOFRA+R(5)
        TILT=TILT+R(6)
        TWIST=TWIST+R(7)
        if(.not.image) then
          BULGE=BULGE+R(8)
        else if (mar) then
          roff = roff+R(8)
          toff = toff+r(9)
      end if
        SINOM0=SIN(OMEGA0)
        COSOM0=COS(OMEGA0)
9       CONTINUE
C
C----------------------- END OF NON-LINEAR REFINEMENT LOOP
C
C--------------------- CALCULATE STD.DEVS. AND TEST RESIDUALS
C
        NOTRY=NOTRY+1
10      RESMX=0
        RESD=0.0
C
C---------------------------START LOOP
C
        DO 11 J=1,NRS
        XG=float(XGEN(J))
        YG=float(YGEN(J))
        CALL XYCALC(CLCX(J),CLCY(J),XG,YG)
        IF(BAD(J)) GOTO 11
        DX=CLCX(J)-float(XRS(J))
        DY=CLCY(J)-float(YRS(J))
        RES=DX*DX+DY*DY
        RESD=RESD+RES
        IF(RES.LT.RESMX) GOTO 11
        RESMX=RES
        MXJ=J
11      CONTINUE
C
C-----------------------  END LOOP. TEST RESIDUALS
C
        RESMX=SQRT(RESMX)
        RMSRES=SQRT(RESD/(NRS-NOTRY+1))
        RESLIM=2.*RMSRES
        IF(NOTRY.EQ.0) GOTO 2
        IF(NOTRY.EQ.1) WRITE(IOUT,1002) RMSRES
        IF(NOTRY.EQ.1.AND..NOT.BATCH)WRITE(6,1002)RMSRES
1002    FORMAT('  RESIDUAL AFTER 1 CYCLE=',F5.1)
        IF(NOTRY.GT.NRS/10) GOTO 12
        IF(RESMX.LT.RESLIM) GOTO 12
        BAD(MXJ)=.TRUE.
        GOTO 3
12      CONTINUE
C
C---------------------------- PRINT OUT
C
C       IF(NOTRY.GT.1) WRITE(IOUT,1003)
        IF(XTEK) CALL NEWPG
1003    FORMAT(/'  REJECTS (ERROR>2*RMS RESID.)'
     1  /'     XOBS    XCAL    DELX    YOBS    YCAL    DELY ')
        If(.Not.Ltek) goto 13
        IF(.NOT.XTEK) CALL TKCLR
13      CONTINUE
        DO 14 J=1,NRS
        DX=float(XRS(J))-CLCX(J)
        DY=float(YRS(J))-CLCY(J)
        If (Ltek) CALL RESIDPL(CLCX(J),CLCY(J),DX,DY)
14      CONTINUE
        If (Ltek) CALL TKPLOT(0,0,1,IER)
        IF(XTEK) CALL NEWPG
        IF(NOTRY.GT.1)WRITE(IOUT,1003)
        IF(NOTRY.GT.1.AND..NOT.BATCH)WRITE(6,1003)
        DO 15 J=1,NRS
        IF(.NOT.BAD(J))GO TO 15
        DX=float(XRS(J))-CLCX(J)
        DY=float(YRS(J))-CLCY(J)
      nxobs = xrs(j) - xcen
      nyobs = yrs(j) - ycen
      nxcal = nint(clcx(j)) - xcen
      nycal = nint(clcy(j)) - ycen
        if (.not.batch)WRITE(6,1004)nxobs,nxcal,dx,nyobs,nycal,dy
        WRITE(IOUT,1004) nxobs,nxcal,dx,nyobs,nycal,dy
1004    FORMAT(' ',2(1x,i7,1x,i7,2x,F6.1))
15      CONTINUE
        NXD=ANINT(CTOFD*XTOFRA)
        ITILT=TILT/FDIST
        ITWIST=TWIST/FDIST

        if(.not.image)then
        IBULGE=BULGE/FDIST
        WRITE(IOUT,1005)RMSRES,XCEN,YCEN,XTOFRA,NXD,YSCAL,ITILT,ITWIST,
     1      IBULGE
        if (.not.batch)
     1  WRITE(6,1005)RMSRES,XCEN,YCEN,XTOFRA,NXD,YSCAL,ITILT,ITWIST,
     1      IBULGE
        else if (mar) then
        WRITE(IOUT,1007)RMSRES,XCEN,YCEN,XTOFRA,NXD,YSCAL,ITILT,ITWIST,
     1      roff,toff
        if (.not.batch)
     1  WRITE(6,1007)RMSRES,XCEN,YCEN,XTOFRA,NXD,YSCAL,ITILT,ITWIST,
     1      roff,toff
        else 
        WRITE(IOUT,1008)RMSRES,XCEN,YCEN,XTOFRA,NXD,YSCAL,ITILT,ITWIST
        if (.not.batch)
     1  WRITE(6,1008)RMSRES,XCEN,YCEN,XTOFRA,NXD,YSCAL,ITILT,ITWIST
        endif

1008    FORMAT(/' FINAL RMS RESIDUAL:  ',F8.1/
     1    2X,'    XCEN    YCEN  XTOFRA   XTOFD  YSCALE    TILT   TWIST'
     2        ,/2X,2I8,F8.4,I8,F8.4,2I8/)
1007    FORMAT(/' FINAL RMS RESIDUAL:  ',F8.1/
     1    2X,'    XCEN    YCEN  XTOFRA   XTOFD  YSCALE    TILT   TWIST'
     2        ,'   Roff    Toff',/2X,2I8,F8.4,I8,F8.4,2I8,2f7.1/)
1005    FORMAT(/' FINAL RMS RESIDUAL:  ',F8.1/
     1    10X,'    XCEN    YCEN  XTOFRA   XTOFD  YSCALE    TILT   TWIST'
     2        ,' BULGE',/10X,2I8,F8.4,I8,F8.4,3I8/)
C
C------------- PRINT REFINED CAMERA CONSTANTS
C
        CCXs=float(XCEN-XCENF)
        CCYs=float(YCEN-YCENF)
c
        ccx = nint(ccxs*cos(omegaf)+ccys*sin(omegaf))
        ccy = nint(-ccxs*sin(omegaf)+ccys*cos(omegaf))
c
      ang0 = omega0 * 57.296
      angf = omegaf * 57.296
c
        CCOM=(OMEGA0-OMEGAF)*57.296
        WRITE(IOUT,1006) CCX,CCY,CCOM,
     1                 angf,ang0,sinom0,cosom0
        if (.not.batch)WRITE(6,1006)CCX,CCY,CCOM,
     1                 angf,ang0,sinom0,cosom0
1006    FORMAT(' REFINED CAMERA CONSTANTS.'/' CCX: ',I8/
     1      ' CCY: ',I8/' CCOM:',F8.4/
     1      ' wF : ',f8.4/' w0  :',F8.4/
     1      ' sinw:',f8.4/' cosw:',F8.4/)
        RETURN
        END
C
C
C
C                      *********************************************
C                      *                                           *
C                      *        ****  SUBROUTINE REFPLOT****       *
C                      *                                           *
C                      *********************************************
C
C
C
C=============================================================
C
C       SUBROUTINE REFPLOT
C
C  PLOTS REFLEXIONS COORDINATES FOR CENTRAL
C  AREA OF FILM ( L -FULLY RECORDED;
C  INVERTED L -PARTIALLY RECORDED;ELONGATED L -
C  ZERO LEVEL REFLEXIONS)
C       Changed to plot only multiplets (IM NE 0)
C       and limits chenged
C Sept 17th 1986 T.J.G.
c
c##### laue mods - plot only nodals
C============================================================
C
C

        SUBROUTINE REFPLOT(CDX,CDY)
C
      INCLUDE 'commcs.finc'
      INCLUDE 'comscn.finc'
      INCLUDE 'comori.finc'
      INCLUDE 'comras.finc'
      INCLUDE 'comlaue.finc'
C
        COMMON /EXTRAS/ JUMPAX
c##### laue mods
c        INTEGER ABUF(10),H(3)
C
c        IR=PCKIDX+1
c        DO 1 I=1,TOSPT
c        IR=IR+1
c        READ(1,REC=IR) ABUF
c        IF(IABS(ABUF(3)).GT.2500) GOTO 1
c        IF(IABS(ABUF(4)).GT.1900) GOTO 1
C
C---------------- UNPACK H,K,L,M FROM FIRST TWO WORDS
C
c        H(1)=IAND(ABUF(1),'177400'O)/256
c        IF(H(1).GE.128)H(1)=-256+H(1)
c        H(2)=IAND(ABUF(2),'377'O)
c        IF(H(2).GE.128)H(2)=-256+H(2)
c        H(3)=IAND(ABUF(2),'177400'O)/256
c        IF(H(3).GE.128)H(3)=-256+H(3)
c        IM=IAND(ABUF(1),'360'O)
C *********
C
C----------------- Remove partials from filmplot for LAUE's
C                  and change idelx,idely from 10,10 to 3,12
C                  REMEMBERING that jumpax is always set to 0
C                           Sept 8th 1986. Trevor
C
C       IDELX=10
C       IF(IM.NE.0) IDELX=-10
C       IDELY=IDELX
c       IF(IM.EQ.0) GOTO 1
c       IDELX = 3
c        IF(IM.NE.0) IDELX=-IDELX
c        IDELY=12*(3/idelx)
C
C *********

c        IF(H(JUMPAX).EQ.0) IDELX=3*IDELX
c        X=ABUF(3)
c        Y=ABUF(4)
c##### laue mods - code to replace that above
c     only plot nodals
c
      idelx = 10
      idely = 10
      do 1 ii=1,numnod
      i = nodpt(ii)
      x = xyge(1,i)
      y = xyge(2,i)
      if(abs(x) . gt. 5000) go to 1
      if(abs(y) . gt. 3800) go to 1
        CALL XYCALC(XC,YC,X,Y)
        IX=0.1*(XC-XCEN+CDX)+512
        IY=0.1*(YC-YCEN+CDY)+390
C
C ------------------------  CHECK FOR EDGE OF SCREEN
C
        IF(IX.GT.993.OR.IX.LT.31)GO TO 1
        CALL MOVTX(IX,IY)
        CALL VECTX(IX+IDELX,IY)
        CALL MOVTX(IX,IY)
        CALL VECTX(IX,IY+IDELY)
        CALL ALPHA
   1    CONTINUE
        RETURN
        END
C
C
C
C
C                      *********************************************
C                      *                                           *
C                      *        ****  SUBROUTINE REPORT  ****      *
C                      *                                           *
C                      *********************************************
C
C
C
C=============================================================
C
        SUBROUTINE REPORT
cRCD ...Image Plate logical
        common/iplate/image,mar,moldyn
        logical image,mar,moldyn
c
        COMMON/IOO/IOUT
        COMMON/SW/ISWTCH(10),oneref,noref,tworef
        LOGICAL oneref,noref,tworef
C
      INCLUDE 'comrep.finc'
      INCLUDE 'comuab.finc'
C
      ITOTS = ITOTS - NBAD
        WRITE(IOUT,1000) NREF,NOFR,IPROS,IBOXS,ITOTS,NOLO,NEDGE,NBZERO,
     1                   NBAD,NBOX
        if (.not.batch)
     1  WRITE(6,1000)   NREF,NOFR,IPROS,IBOXS,ITOTS,NOLO,NEDGE,NBZERO,
     1                   NBAD,NBOX
1000    FORMAT(' ',i8,' SPOTS MEASURED ON THIS FILM'/' '
     1            ,i8,' ARE SINGLETS'/' '
     1            ,i8,' PROFILE FITTED'/' '
     1            ,i8,' BOX SUMMED'/' '
     1            ,i8,' GOOD SPOTS'/' '
     1            ,i8,'     REJECTED AS OVERLOADS'/' '
     1            ,i8,'     REJECTED OVER SCAN LIMIT (Including ',
     1                      'central bin)'/' '
     1            ,i8,'     REJECTED ON BAD BACKGROUND'/' '
     1            ,i8,'     REJECTED ON BGRATIO OR I/SIGI'/' '
     1            ,i8,'     REJECTED ON OVERLARGE BOX')
      if(ltek) call newpg
C
cRCD ...Change ranges for IP data
        if(.not.image)then
        WRITE(IOUT,1003) IRANGE
        if (.not.batch)WRITE(6,1003)IRANGE
        else
        WRITE(IOUT,1003) iprange
        if (.not.batch)WRITE(6,1003)iprange
        endif
1003    FORMAT(/'    ANALYSIS OF INTENSITIES'/'   RANGES ',9I7)
        WRITE(IOUT,1004) IANAL
        if (.not.batch)WRITE(6,1004)IANAL
1004    FORMAT('    NO. ',10I7)
        WRITE(IOUT,1005) RATIO
        if (.not.batch)WRITE(6,1005)RATIO
1005    FORMAT(' BGRATIO',10F7.1)
        if (.not.batch)WRITE(6,1006)AVSD
        WRITE(IOUT,1006)AVSD
1006    FORMAT('   AVSD ',10F7.1)
        WRITE(IOUT,1007) MAXBSI,MINBSI
        if (.not.batch)WRITE(6,1007)MAXBSI,MINBSI
1007    FORMAT(/'  MAXIMUM INTENSITY=',I7/'  MINIMUM INTENSITY=',I7)
        RETURN
        END
C
C
C
C
C                      *********************************************
C                      *                                           *
C                      *        ****  SUBROUTINE RESIDPL ****      *
C                      *                                           *
C                      *********************************************
C
C
C
C=============================================================
C
        SUBROUTINE RESIDPL(XCAL,YCAL,DX,DY)
C
      INCLUDE 'comori.finc'
C
        INTEGER X,Y
        REAL DX,DY,XCAL,YCAL
C
C------------ REDUC CHANGED FROM 16 TO 32. (CORRECT SIZE TEKPLOT)
C                            OCT 3 1984.
C
        REDUC=32.
c
c --- change dx reduc to that in lauegen etc - 5x
c
      dreduc = 5./reduc
        X=(XCAL-XCEN)/REDUC+512
        Y=(YCAL-YCEN)/REDUC+380
        CALL MOVTX(X,Y)
C
C--------------- 2*DX TO DX (RE 16 TO 32 CHANGE). OCT 3 1984.
C
      if(abs(dx).gt.64.) dx = (dx/abs(dx))*64.
      if(abs(dy).gt.64.) dy = (dy/abs(dy))*64.
        IX=X+dreduc*DX
        IY=Y+dreduc*DY
        CALL VECTX(IX,IY)
        DXY=dreduc*SQRT(DX*DX+DY*DY)
C
C--------------- 2*DX TO DX (RE 16 TO 32 CHANGE). OCT 3 1984.
C
        IX=-dreduc*DY/DXY
        IY=dreduc*DX/DXY
        CALL MOVTX(X+IX,Y+IY)
        CALL VECTX(X-IX,Y-IY)
        CALL ALPHA
        RETURN
        END
C
C
C
C
C                      *********************************************
C                      *                                           *
C                      *        ****  SUBROUTINE RMAXR  ****       *
C                      *                                           *
C                      *********************************************
C
C
C
C=============================================================
C
C
C       **** SUBROUTINE RMAXR ****
C
C  DETERMINES MAXIMUM X AND Y COORDINATES OF
C  REFLEXIONS IN GENERATE FILE, BOX EXPANSION
C  COEFFICIENTS AND CHECKS THAT DIMENSIONS OF
C  THE EXPANDED BOX ARE WITHIN LIMITS.
C
C
c##### laue mods - re selection of spots
c     only take measurable spots without spatial overlaps
C==============================================================
C
C
        SUBROUTINE RMAXR
        COMMON/TREV/NXMAX,NYMAX
        COMMON/IOO/IOUT
        COMMON/SW/ISWTCH(10),oneref,noref,tworef
c##### laue mods
c        INTEGER BUF(10)
         LOGICAL oneref,noref,tworef
C
      INCLUDE 'comuab.finc'
      INCLUDE 'comlaue.finc'
      INCLUDE 'comori.finc'
      INCLUDE 'comscn.finc'
      INCLUDE 'comras.finc'
      INCLUDE 'commcs.finc'
      INCLUDE 'comrfs.finc'
      INCLUDE 'comfid.finc'
C
c        EQUIVALENCE (BUF(1),IHMR),(BUF(3),JX),(BUF(4),JY)
        XTOFD=DTOFD*FACT
        VVAR=.5/(XTOFD*XTOFD*XTOFRA*XTOFRA)
        VARAS(1)=20./(DTOFD*XTOFRA)
        VARAS(2)=(NXS-MAX0(2*NRX+2,0))*VVAR
        VARAS(3)=(NYS-MAX0(2*NRY+2,0))*VVAR
        FACT1=FACT*1.01*XTOFRA
C
C------ INCREASED BY 1% TO ALLOW FOR XTOFRA, CCOM, DISTORTION, ETC.
C
        DOV2=CTOFD*.5*FACT1
        MAXX=0
        MAXY=0
        MAXR=0
        NXMAX=0
        NYMAX=0
c##### laue mods
c        JREC=PCKIDX+1
C
C-------  READ SPOTS FROM GENERATE FILE AND CALCULATE SIZE
C-------  OF EXPANDED MEASUREMENT BOX.
C
C---------------------------start loop
C
        DO 1 I=1,TOSPT
c##### laue mods
c        JREC=JREC+1
c        READ(1,REC=JREC) BUF
c        IR=IAND(IHMR,'17'O)
c        IF(IR.NE.0) GOTO 1
c        JX=IABS(JX)
c     ignore spots if unmeasurable or flagged overlaps
c ***** dont! TRevor
c      nodali = nodal(i)
c      ir = iand (nodali, '03'x)
c      if(ir.ne.0)go to 1
      jx = abs( xyge(1,i))
        MAXX=MAX0(MAXX,JX)
        XC=JX*FACT1
        IF(VEE) XC=ABS(XC-DOV2)
c        JY=IABS(JY)
      jy = abs(xyge(2,i))
        MAXY=MAX0(MAXY,JY)
        YC=JY*FACT1
        NX=XC*(XC*VARAS(2)+VARAS(1))+.5
        NY=YC*(YC*VARAS(3)+VARAS(1))+.5
        NX=((NX+1)/2)*2+NXS
        NXMAX=MAX0(NXMAX,NX)
        NY=((NY+1)/2)*2+NYS
        NYMAX=MAX0(NYMAX,NY)
        KRAS=(NX+1)*(NY+1)
        MAXR=MAX0(MAXR,KRAS)
1       CONTINUE
C
C----------------------------end loop
C
        IF(MAXR.GT.5000) WRITE(IOUT,1000) MAXR
        IF(MAXR.GT.5000.and..not.batch)write(6,1000)MAXR
1000    FORMAT(' EXPANDED RASTER LARGER THAN BUFFER (5000 POINTS)=',I6)
        IF(NXMAX.GT.69.OR.NYMAX.GT.69) WRITE(IOUT,1001) NXMAX,NYMAX
        IF(NXMAX.GT.69.OR.NYMAX.GT.69.and..not.batch)
     1      write(6,1001)NXMAX,NYMAX
1001    FORMAT(' EXPANDED BOX DIMENSION LARGER THAN 69 POINTS=',2I6)
        RETURN
        END
C
C
C
C
C
C                      *********************************************
C                      *                                           *
C                      *        ****  SUBROUTINE RVDIST ****       *
C                      *                                           *
C                      *********************************************
C
C
C
C=============================================================
C
C
C            ****  SUBROUTINE RVDIST  ****
C
C REFINES FILM CENTRE, FILM ORIENTATION, CRYSTAL TO FILM DISTANCE,
C YSCAL, BAR CONSTANT, AND FILM DISTORTIONS FOR VEE-SHAPED FILMS
C USING A NON-LINEAR LEAST SQUARES METHOD
C AND REPORTS NEW FIDUCIAL CONSTANTS
C
C=============================================================
C
C
C
        SUBROUTINE RVDIST
        COMMON/SW/ISWTCH(10),oneref,noref,tworef
        COMMON/IOO/IOUT
C COMMON VARIABLES
C
      INCLUDE 'comori.finc'
      INCLUDE 'comfid.finc'
      INCLUDE 'comrfs.finc'
      INCLUDE 'commcs.finc'
      INCLUDE 'comuab.finc'
C
C LOCAL VARIABLES
        INTEGER XGEN(256),YGEN(256),BUF(10)
        REAL CLCX(256),CLCY(256)
        REAL RF(121),R(11),RR(11),W(11),DDX(11),DDY(11)
        LOGICAL BAD(256),oneref,noref,tworef
        EQUIVALENCE (RF(1),BUF(1))
        EQUIVALENCE (BUF(3),IX),(BUF(4),IY)
        DATA A0/2.86E-7/,B0/2.78E-8/
C
C--- A0 AND B0 DEFINE SHAPE OF BULGE
C---  COORDINATES USED IN THIS OVERLAY
C (CLCX,CLCY) ARE FROM THE GENERATE-FILE AND THEREFORE
C             IN 10 MICRON UNITS RELATIVE TO THE CENTRE
C             OF THE DIFFRACTION PATTERN
C-- (XRS,YRS)   ARE IN 10 MICRON UNITS (FROM OVERLAY SEEKRS OR NEXT)
C-- LEAST SQUARES REFINEMENT OF XTOFRA,XCEN,YCEN AND OMEGA0
C-- DONE BY FITTING OBSERVED POSITIONS (XRS,YRS) TO THOSE
C-- IN THE GENERATE-FILE (CLCX,CLCY)
C
        DOV2=CTOFD/2.*XTOFRA
        RADEG=18000./3.14159
C
C-------------------- NO. OF PARAMETERS TO REFINE
C
        NP=11
        NP2=NP*NP
        IF(XTEK) CALL NEWPG
        OMEGA0=ASIN(SINOM0)
        NOTRY=0
        WRITE(IOUT,1000) NRS
        if(.not.batch)write(6,1000)NRS
1000    FORMAT(/' FILM DISTORTION REFINEMENT USING',I3,' SPOTS'/)
C
C----------------- READ COORDS FROM GENERATE FILE
C
        DO 1 J=1,NRS
        IR=RRS(J)
        READ(1,REC=IR) BUF
        XGEN(J)=IX
        YGEN(J)=IY
        BAD(J)=.FALSE.
1       CONTINUE
        GOTO 12
2       WRITE(IOUT,1001) RMSRES
        if(.not.batch)write(6,1001)RMSRES
1001    FORMAT('  STARTING RESIDUAL=',F5.1)
        ESTART=RMSRES
C
C--------------------- START MAIN REFINEMENT LOOP
C
3       CONTINUE
C
C------------------ START LOOP FOR NON-LINEAR REFINEMENT
C
        DO 11 ICYC=1,2
C
C-------------------- INITIALIZE SUMS
C
        DO 4 K=1,NP
4       W(K)=0.0
        DO 5 K=1,NP2
5       RF(K)=0.0
C
C---------------------- SET UP NORMAL EQUATIONS
C
        DO 9 J=1,NRS
        IF(BAD(J)) GOTO 9
        XG=XGEN(J)
        YG=YGEN(J)
        XM=XG*COSOM0-YG*SINOM0
        YM=YG*COSOM0+XG*SINOM0
        XN=-YM*XTOFRA
        YN=XM*XTOFRA*YSCAL
        ABSX=ABS(XG)
        SNX=SIGN(1.0,XG)
        XDASH=ABSX-4300.
        XD=(ABSX-DOV2)
        XX=XDASH*XDASH*A0
        YY=YG*YG*B0
        FB=EXP(-XX-YY)
        FR=FB*XD
        BY=FB*YG
        DDX(1)=1.0
        DDX(2)=0.0
        DDX(3)=XM
        DDX(4)=0.0
        DDX(7)=-SNX*COSOM0
        DDX(8)=XN+SNX*CBAR*SINOM0
        DDX(9)=XG*YG
        DDX(10)=XG*XG
        DDX(11)=XG*SNX
        DDY(1)=0.0
        DDY(2)=1.0
        DDY(3)=0.0
        DDY(4)=YM
        DDY(7)=-SNX*SINOM0
        DDY(8)=YN-SNX*CBAR*COSOM0
        DDY(9)=YG*YG
        DDY(10)=YG*XG
        DDY(11)=YG*SNX
        IF(XG.LT.0) GOTO 6
C
C-------------------- POSITIVE XG
C
        DDX(5)=0.0
        DDX(6)=-FR
        DDY(5)=0.0
        DDY(6)=-BY
        GOTO 7
C
C------------------- NEGATIVE XG
C
6       DDX(5)=FR
        DDX(6)=0.0
        DDY(5)=-BY
        DDY(6)=0.0
7       CONTINUE
        CALL XYCALC(XC1,YC1,XG,YG)
        XO=XRS(J)-XC1
        YO=YRS(J)-YC1
        IK=0
        DO 8 I=1,NP
        W(I)=W(I)+DDX(I)*XO+DDY(I)*YO
        DO 8 K=1,NP
        IK=IK+1
        RF(IK)=RF(IK)+DDX(I)*DDX(K)+DDY(I)*DDY(K)
8       CONTINUE
9       CONTINUE
C
C--------------------------- SOLVE
C
        CALL MINV(RF,NP,DET,R,RR)
        IK=0
        DO 10 I=1,NP
        R(I)=0.0
        DO 10 K=1,NP
        IK=IK+1
        R(I)=R(I)+RF(IK)*W(K)
10      CONTINUE
        XCEN=XCEN+R(1)+.5
        YCEN=YCEN+R(2)+.5
        R(4)=R(4)+YSCAL*XTOFRA
        XTOFRA=XTOFRA+R(3)
        YSCAL=R(4)/XTOFRA
        VBNEG=VBNEG+R(5)
        VBPOS=VBPOS+R(6)
        CBAR=CBAR+R(7)+.5
        OMEGA0=OMEGA0+R(8)
        SINOM0=SIN(OMEGA0)
        COSOM0=COS(OMEGA0)
        VTWIST=VTWIST+R(9)
        VTILT=VTILT+R(10)
        VVERT=VVERT+R(11)
11      CONTINUE
C
C--------------- END OF INNER REFINEMENT LOOP
C
C-------------- CALCULATE STD.DEVS. AND TEST RESIDUALS
C
        NOTRY=NOTRY+1
12      RESMX=0
        RESD=0.0
        DO 13 J=1,NRS
        XG=XGEN(J)
        YG=YGEN(J)
        CALL XYCALC(CLCX(J),CLCY(J),XG,YG)
        IF(BAD(J)) GOTO 13
        DX=CLCX(J)-XRS(J)
        DY=CLCY(J)-YRS(J)
        RES=DX*DX+DY*DY
        RESD=RESD+RES
        IF(RES.LT.RESMX) GOTO 13
        RESMX=RES
        MXJ=J
13      CONTINUE
        RESMX=SQRT(RESMX)
        RMSRES=SQRT(RESD/(NRS-NOTRY+1))
        RESLIM=2.5*RMSRES
        IF(NOTRY.EQ.0) GOTO 2
        IF(NOTRY.EQ.1) WRITE(IOUT,1002) RMSRES
        IF(NOTRY.EQ.1.and..not.batch)write(6,1002)RMSRES
1002    FORMAT('  RESIDUAL AFTER 1 CYCLE=',F5.1)
        IF(NOTRY.GT.NRS/10) GOTO 14
        IF(RESMX.LT.RESLIM) GOTO 14
        BAD(MXJ)=.TRUE.
        GOTO 3
14      CONTINUE
C
C----------------------- PRINT OUT
C
        IF(XTEK) CALL NEWPG
        If (.not.Ltek) goto 15
        IF(.NOT.XTEK) CALL TKCLR
15      Continue
        DO 16 J=1,NRS
        DX=XRS(J)-CLCX(J)
        DY=YRS(J)-CLCY(J)
        If (Ltek) CALL RESIDPL(CLCX(J),CLCY(J),DX,DY)
16      CONTINUE
        If (Ltek) CALL TKPLOT(0,760,1,IER)
        IF(XTEK)CALL NEWPG
        IF(NOTRY.GT.1.and..not.batch)write(6,1003)
        IF(NOTRY.GT.1)WRITE(IOUT,1003)
1003    FORMAT(/'  REJECTED REFLEXIONS (ERROR>2.5*RMS RESID.)'
     1           /'     XOBS   DELX   YOBS  DELY ')
        DO 17 J=1,NRS
        IF(.NOT.BAD(J))GO TO 17
        DX=XRS(J)-CLCX(J)
        DY=YRS(J)-CLCY(J)
        if(.not.batch)write(6,1004)XRS(J)-XCEN,DX,YRS(J)-YCEN,DY
        WRITE(IOUT,1004)XRS(J)-XCEN,DX,YRS(J)-YCEN,DY
1004    FORMAT(' ',2(2X,I6,F5.1))
17      CONTINUE
        NXD=ANINT(CTOFD*XTOFRA)
        IBNEG=VBNEG*CTOFD
        IBPOS=VBPOS*CTOFD
        ITILT=VTILT*CTOFD*RADEG
        ITWIST=VTWIST*CTOFD*RADEG
        IVERT=VVERT*CTOFD
        WRITE(IOUT,1005) RMSRES,XCEN,YCEN,XTOFRA,NXD,YSCAL,IBNEG,
     1  IBPOS,CBAR,ITILT,ITWIST,IVERT
        if(.not.batch)write(6,1005)RMSRES,XCEN,YCEN,XTOFRA,NXD,YSCAL,IBNEG,
     1            IBPOS,CBAR,ITILT,ITWIST,IVERT
1005    FORMAT(/' FINAL RMS RESIDUAL:  ',F8.1/
     1     1X,' XCEN  YCEN  XTOFRA  XTOFD YSCALE  -BULGE +BULGE',
     2     ' CBAR XTILT ITWIST  IVERT'/1X,2I6,F8.4,I7,F8.4,6I6/)
C
C--------------- PRINT REFINED FIDUCIAL CONSTANTS
C
        CCX=XCEN-XCENF
        CCY=YCEN-YCENF
        CCOM=(OMEGA0-OMEGAF)*57.296
        WRITE(IOUT,1006) CCX,CCY,CCOM
        if(.not.batch)write(6,1006)CCX,CCY,CCOM
 1006   FORMAT(' REFINED CAMERA CONSTANTS.'/' CCX: ',I8/
     1         ' CCY: ',I8/' CCOM:',F8.4/)
        If (Ltek) CALL ALPHA
        RETURN
        END
      SUBROUTINE SCPAUS
      WRITE(6,111)
  111 FORMAT(' TYPE RETURN TO CONTINUE ',$)
      READ(5,112)JUNK
  112 FORMAT(A1)
      RETURN
      END
C
C
C
C
C                      *********************************************
C                      *                                           *
C                      *        ****  SUBROUTINE GENSORT ****      *
C                      *                                           *
C                      *********************************************
C
C                      ******** EXTRACTED: 17/2/88 TJG *********
C
C
C
C
C                      *********************************************
C                      *                                           *
C                      *        ****  SUBROUTINE SEEKRS ****       *
C                      *                                           *
C                      *********************************************
C
C
C
C=============================================================
C
C SEARCHES OUTSIDE OF FILM FOR REFINEMENT SPOTS.
C FILM IS DIVIDED INTO SECTORS WITHIN WHICH
C AFIXED NO. OF SPOTS SHOULD BE FOUND.
C MEASURES STRIPES FROM SCANNER INTO ARRAY BA.
C SELECTS DATA FOR PARTICULAR SPOTS INTO ARRAY BB.
C COMPLETED SPOTS ARE TESTED FOR INTEGRATED INTENSITY
C AND SEPARATION.
C
C=============================================================
C
C
C
        SUBROUTINE SEEKRS
c
cRCD ...Image Plate logical
        common/iplate/image,mar,moldyn
        logical image,mar,moldyn
c
        COMMON/IOO/IOUT
        COMMON/THRESH/JNK1,IODS,ISIZS
        COMMON/SW/ISWTCH(10),oneref,noref,tworef
        LOGICAL oneref,noref,tworef
C
      INCLUDE 'comtem.finc'
      INCLUDE 'comori.finc'
      INCLUDE 'comras.finc'
      INCLUDE 'comscn.finc'
      INCLUDE 'comrfs.finc'
      INCLUDE 'commcs.finc'
      INCLUDE 'comuab.finc'
      INCLUDE 'commaskl.finc'
C
C--------------- Get COMREP for NREF
C
      INCLUDE 'comrep.finc'
C
        COMMON/PEL/IBA,IJBA(5120),NREC
        INTEGER*2 IJBA,iba
        COMMON/CPEL/BB(14000)
        INTEGER*2 BB
        INTEGER IBIN,JBIN,SBIN,LBIN,LRAS(5)
        INTEGER NOSPT,XC,YC,RC,PNTR(120)
        INTEGER HFWX,HFWY,BUF(3),NSIZ,WTX
        INTEGER X(200),Y(200),REC(200),SHX,SHY
        INTEGER INF1(200),INF2(200),INF3(200)
        LOGICAL FULL,YES
        EQUIVALENCE (BUF(1),RC),(BUF(2),XC),(BUF(3),YC)
        EQUIVALENCE (LRAS(1),NXX),(LRAS(2),NYY)
        DATA MAXBUF/7000/
C
C----------------------- START SEEKRS
C
        DO 1 I=3,5
1       LRAS(I)=IRAS(I)
C
C----------------- SET MAXIMUM RASTER SIZE IN WORDS
C
        MAXB=MAXR+4
        if(.not.image)then
        MAXW=(MAXB+1)/2
        MAXB=2*MAXW
        else
        maxw=maxb
        endif
        MAXN=MAXBUF/MAXW
        IF(MAXN.GT.100) MAXN=100
c
c-------------------- set max av od as 0.6*maxod
c
      maxi = nint(float(imaxod)*0.6)
C
C-------------------- OPEN INPUT SORT FILE
C
        ifail=0
        call ccpdpn(-4,'SORTTEMP','OLD','U',0,ifail)
c         OPEN(UNIT=4,FILE='Sorttemp',STATUS='OLD',FORM='UNFORMATTED')
C
C-------------- GET INFORMATION ON SPOTS FROM SORT FILE
C
        IHTOFD=CTOFD*XTOFRA*FACT*0.5
        NECX=XCEN*FACT+0.5
        NECY=YCEN*FACT+0.5
        LBIN=2*28
        NBIN=8
        SBIN=NREF/NBIN
        IF(SBIN.LE.200) GOTO 2
        NBIN=NREF/200+1
        NBIN=2*((NBIN+1)/2)
        SBIN=NREF/NBIN
        LBIN=2*230/NBIN
2       WRITE(IOUT,1000) NREF,NBIN
        if(.not.batch)write(6,1000)NREF,NBIN
 1000   FORMAT(I6,' REFLEXIONS TO BE MEASURED IN',I4,' BINS')
C
C----------------IOD FROM 6 TO 2.  TREVOR OCT 3 1984
C----------------ISIZ FROM 3 TO 1.
C
        IF(I2REF) GOTO 21
        IODS=4
        IF(NBIN.GT.10) IODS=4
        ISIZS=2
      if(image) then
            IODS = 10
            ISIZS = 10
      endif
C*******
21      if(.not.image) WRITE(IOUT,1001)IODS,ISIZS
        if(image) WRITE(IOUT,1234)IODS,ISIZS
        If (Batch.and.I2ref) goto 4
        If (Batch) goto 3
        if(.not.batch) then
            if(.not.image) write(6,1001)IODS,ISIZS
            if(image) write(6,1234)IODS,ISIZS
      endif
1001    FORMAT(/' THRESHOLDS (3,1 weak; 5,3 strong). [',
     1          I3,',',I3,']: ',$)
1234    FORMAT(/' THRESHOLDS (7,5 weak; 10,15 strong). [',
     1          I3,',',I3,']: ',$)
3       read(5,*) NIODS,NISIZS
1002    format(2I4)
        if(Niods.ne.0) Iods = iabs(Niods)
        if(Nisizs.ne.0) Isizs = Nisizs
        if(Niods.lt.0) Isizs = 0
4       WRITE(IOUT,1003) IODS,ISIZS
1003    FORMAT(1h+,2I5)
        I2REF = .TRUE.
C
C--------------- NOW FIND SPOTS
C
        IOD = IODS
        ISIZ = ISIZS
        ISEP=nint(0.5*160./SCNSZ)
        LASTX=0
        LASTY=0
C
C---------------------------- LOOP OVER ALL SPOTS
C
        DO 18 NB=1,NBIN
C
C--------------------------- LOOP OVER BINS
C
        DO 5 NOSPT=1,SBIN
        READ(4) BUF
      if(.not.profil) then
        FX=IABS(XC-NECX)
        IFX=FX
        IF(VEE) FX=IABS(IFX-IHTOFD)
        FY=IABS(YC-NECY)
        N1=FX*(FX*VARAS(2)+VARAS(1))+0.5
        N2=FY*(FY*VARAS(3)+VARAS(1))+0.5
      else
      n1 = 0
      n2 = 0
      endif
        HFWX=(NXS+N1)/2
        HFWY=(NYS+N2)/2
        X(NOSPT)=XC
        Y(NOSPT)=YC
        REC(NOSPT)=RC
        INF1(NOSPT)=2*HFWX+1
        INF2(NOSPT)=HFWX
        INF3(NOSPT)=HFWY
5       CONTINUE
C
C-------------- SET FLAGS TO INITIAL VALUES
C----------------------- IFRST,ILAST:-
C--------------THESE ARE MARKERS IN BB TO SHOW WHERE IT IS FILLED
C------------------------INDF,INDL:-
C--------------SHOW WHICH REFLECTIONS ARE ACTIVE IN SORTED FILE
C
        INDF=1
        INDL=1
        IBIN=0
        IFRST=1
        ILAST=0
C
C---------- START SCAN FOR THE FIRST SPOT OR SPOT AFTER A GAP
C
6       CONTINUE
        WTX=X(INDF)-INF2(INDF)
        IBLK=WTX
C
C------------ INCLUDE THE SPOT IN THIS SCAN
C
7       IER=1
        CALL RDBLK(2,IBLK,IJBA,NWORD,IER)
8       IF(INDL.EQ.SBIN) GOTO 9
        IF(FULL) GOTO 9
        MINDL=INDL+1
        IF(WTX.LT.X(MINDL)-INF2(MINDL)) GOTO 9
        INDL=INDL+1
        IF(INDL-INDF.EQ.MAXN-1) FULL=.TRUE.
        GOTO 8
C
C--------- GET THE INFORMATION FOR THIS SCAN AND START A NEW ONE
C
9       CONTINUE
C
C---------- WRITE SPOTS COLLECTED IN THIS STRIPE TO BB
C
        IF(INDL.LT.INDF) GOTO 12
        DO 11 J=INDF,INDL
        MJ=MOD(J-1,MAXN)
        YC=Y(J)
        KMN=YC-INF3(J)
        KMX=YC+INF3(J)
        NJ=MJ*MAXB
        MJ=MJ+1
        IF(J.NE.IFRST) GOTO 10
        MFRST=MOD(IFRST-1,MAXN)+1
c
c    *****************************************************
c    I THINK REC(j) IS UNIMPORTANT HERE. CAUSES TROUBLE. SET TO 0
c    *****************************************************
c
        BB((MFRST-1)*MAXW+1)=0
        IADDR=(MFRST-1)*MAXB
        IN=INF2(J)*2+1
        IZZ=IADDR+3
        if(.not.image)then
        CALL BPACK(IZZ,BB,IN)
        else
        call ip_bpack(izz,bb,in)
        endif
        IN=INF3(J)*2+1
        IZZ=IZZ+1
        if(.not.image)then
        CALL BPACK(IZZ,BB,IN)
        else
        call ip_bpack(izz,bb,in)
        endif
        PNTR(MFRST)=5
        IFRST=IFRST+1
10      IZZ=PNTR(MJ)+NJ
        if(.not.image)then
        CALL BSWAP(KMN,KMX,IZZ)
        else
        call ip_bswap(kmn,kmx,izz)
        endif
        PNTR(MJ)=IZZ-NJ
        INF1(J)=INF1(J)-1
11      CONTINUE
12      WTX=WTX+1
        IBLK=IBLK+1
C
C--------------- SEE IF SPOT IS FINISHED
C
13      IF(INF1(INDF).EQ.0) GOTO 14
        IF(INDF.LE.INDL) GOTO 7
        FULL=.FALSE.
        GOTO 6
C
C----------- WRITE OUT COMPLETED SPOTS AND READ IN NEW ONES
C
14      IND=ILAST*MAXW+1
        NXX=2*INF2(INDF)+1
        NYY=2*INF3(INDF)+1
        NXY=NXX*NYY
C
        if(.not.image)then
           ijunk=ind+2
        else
           ijunk=ind+4
        endif
      if(streak) then
        call cgmask(bb(ijunk),lras,0,delx,dely,
     1                  x(indf),y(indf),spot)
      else
          CALL CGFIT(BB(ijunk),LRAS,+1,DELX,DELY,SPOT)
      end if
C
C---------------UPPER THRESH FROM 80 TO 100.  OCT 3 1984
C          *****        AND CHANGED CGFIT TO GIVE SPOT/NPK
C                         IE IAVOD SINCE IN THIS VERSION
C                         NPEAK IS UNEXPANDED SIZE!!
C
C       IAVOD=SPOT/NPEAK
C
        IAVOD=SPOT
        if(.not.image)then
        IF((IAVOD.LT.IOD).OR.(IAVOD.GT.maxi)) GOTO 15
        else
        if((iavod.lt.iod).or.(iavod.gt.maxi)) goto 15
        endif
C
C------------  SPOT SEPARATION  > 4 MM
C
        IF(IABS(X(INDF))-LASTX.GE.ISEP) LASTY=0
        IF(IABS(Y(INDF)-LASTY).LT.ISEP) GOTO 15
        LASTX=X(INDF)
        IBIN=IBIN+1
      if(.not.image)then
        NSIZ=(PNTR(ILAST+1)+1)/2
      else
      nsiz=pntr(ilast+1)
      endif
        SHX=DELX/FACT+0.5
        SHY=DELY/FACT+0.5
        NRS=NRS+1
        LASTY=Y(INDF)
        XRS(NRS)=ANINT((X(INDF)+DELX)/FACT)
        YRS(NRS)=ANINT((Y(INDF)+DELY)/FACT)
        RRS(NRS)=REC(INDF)
        IF(ISWTCH(1).EQ.0) GOTO 15
        WRITE(IOUT,1004) NRS,SHX,SHY,IAVOD
        if(.not.batch)write(6,1004)NRS,SHX,SHY,IAVOD
1004    FORMAT('SPOT',I4,' C.OF G. SHIFTS',2F6.1,' AV.OD.',I6)
        CALL ODPLOT(BB(IND+2),NXX,NYY,1)
15      ILAST=ILAST+1
        IF(ILAST.EQ.MAXN) ILAST=0
        INDF=INDF+1
        IF(IBIN.EQ.LBIN) GOTO 16
        IF(INDF.LT.SBIN) GOTO 13
        WRITE(IOUT,1005) IBIN,NB
        if(.not.batch)write(6,1005)IBIN,NB
1005    FORMAT(' ONLY',I6,' SPOTS FOUND IN BIN',I4)
16      IF(NB.NE.NBIN/2) GOTO 17
        ISIZ=-ISIZ
        IOD=IOD-ISIZ
17      IOD=IOD+ISIZ
18      CONTINUE
        CLOSE (UNIT=4)
        RETURN
        END
C
C
C
C                      *********************************************
C                      *                                           *
C                      *        ****  SUBROUTINE SELECT ****       *
C                      *                                           *
C                      *********************************************
C
C
C
C=============================================================
C
        SUBROUTINE SELECT
C
      INCLUDE 'comrfs.finc'
C
        IF(NRS.LE.20) RETURN
        SEP=200
1       SEP=SEP+100
        DSEP=SEP*SEP
        I=1
2       J=I+1
3       DX=IABS(XRS(I)-XRS(J))
        IF(DX.GT.SEP) GOTO 7
        DY=IABS(YRS(I)-YRS(J))
        IF(DY.GT.SEP) GOTO 6
        DR=DX*DX+DY*DY
        IF(DR.GT.DSEP) GOTO 6
        NRS=NRS-1
        IF(J.GT.NRS) GOTO 5
        DO 4 K=J,NRS
        XRS(K)=XRS(K+1)
        YRS(K)=YRS(K+1)
4       RRS(K)=RRS(K+1)
5       IF(NRS.EQ.20) RETURN
6       IF(J.GE.NRS) GOTO 7
        J=J+1
        GOTO 3
7       IF(I.EQ.NRS-1) GOTO 1
        I=I+1
        GOTO 2
        END
C
C
C             SUBROUTINE TO INITIALIZE COMMON BCK DATA
C
C
      SUBROUTINE SETBCK(J)
C
      INCLUDE 'combck.finc'
C
      NNEG = 0
      NSAT = 0
      BN(J) = 0
      BP(J) = 0
      BQ(J) = 0
      BO(J) = -20000.
      PS(J) = 0
      QS(J) = 0
      MS(J) = 0
      SS(J) = 0.0
      SMS(J) = 0.0
      BPQ(J) = 0.0
      BPP(J) = 0.0
      BQQ(J) = 0.0
      BOP(J) = 0.0
      BOQ(J) = 0.0
C      REJ(J) = 0
      SIGMA(J) = 0
      IF(J.NE.1) RETURN
      PN = 0
      PPSUM = 0.0
      QQSUM = 0.0
      RETURN
      END
c     set intensity for  this film
      subroutine setge(nspot, ifilm)
C
      INCLUDE 'comuab.finc'
C
      integer*2 ibuf(38)
      iprof = 0
      if(profil)iprof=12
      if(.not.batch)write(6,100)
  100 format(' clearing intensities for this film ....')
c
      jrec = 10
      ii = 4 +iprof + ifilm
      do i = 1,nspot
      jrec = jrec +1
      read (1,rec=jrec) ibuf
      ibuf(ii) = -9999
      ibuf(ii+6) = -9999
      write(1,rec = jrec) ibuf
      enddo
      return
      end
C
C    SUBROUTINE TO SET-UP ARRAYS & CONSTANTS FOR
C           HAT-MATRIX.
C
      SUBROUTINE SETHAT(ibin,N,P,Q)
C
      INCLUDE 'combck.finc'
      INCLUDE 'comhat.finc'
C
      INTEGER P,Q
      nopuse = 0
C
      HN=N+1
      HAT(HN,2)=FLOAT(P)
      HAT(HN,3)=FLOAT(Q)
      N=N+1
C
      IF(PORB.EQ.1)THEN
      HATP(HN,2,ibin)=HAT(HN,2)
      HATP(HN,3,ibin)=HAT(HN,3)
      HPOBS(ibin)=HN
      ELSE
      HATB(HN,2)=HAT(HN,2)
      HATB(HN,3)=HAT(HN,3)
      HNOBS=HN
      END IF
C
      RETURN
      END
C
C
C
C
C                      *********************************************
C                      *                                           *
C                      *        ****  SUBROUTINE SETMASK ****      *
C                      *                                           *
C                      *********************************************
C
C
C
C=============================================================
C
C
        SUBROUTINE SETMASK(MASK,IRAS)
        INTEGER MASK(1),IRAS(5),HX,HY,P,Q
        LOGICAL P1,P2
        HX=IRAS(1)/2
        HY=IRAS(2)/2
        IC=HX+HY-IRAS(3)
        IRX=HX-IRAS(4)
        IRY=HY-IRAS(5)
        IJ=0
C
C---------------------------------start loop
C
        DO 3 P=-HX,HX
        IP=IABS(P)
        P1=(IP.GT.IRX)
        P2=(IP.EQ.IRX)
        DO 3 Q=-HY,HY
        IJ=IJ+1
        IQ=IABS(Q)
        IPQ=IP+IQ
        IF(P1.OR.IPQ.GT.IC.OR.IQ.GT.IRY) GOTO 1
        IF(P2.OR.IPQ.EQ.IC.OR.IQ.EQ.IRY) GOTO 2
        MASK(IJ)=1
        GOTO 3
1       MASK(IJ)=-1
        GOTO 3
2       MASK(IJ)=0
3       CONTINUE
C
C-------------------------------------end loop
C
        RETURN
        END
C
C
C
C
C
C                      *********************************************
C                      *                                           *
C                      *        ****  SUBROUTINE SETSUMS ****      *
C                      *                                           *
C                      *********************************************
C
C
C
C=============================================================
C
C
C
C       LATEST REVISION-  1 JUNE 1979
C
C CALLED BY PROCESS
C THIS ROUTINE CALCULATES SUMS USED IN THE ROUTINE INTEG
C
C
C============================================================
C
C
        SUBROUTINE SETSUMS(MASK,IRAS,PQVAL)
        INTEGER IRAS(*),MASK(*)
        REAL PQVAL(6)
        INTEGER S,T
        HX=IRAS(1)/2
        HY=IRAS(2)/2
        T=0
        S=0
        TPP=0.0
        SPP=0.0
        TQQ=0.0
        SQQ=0.0
        IJ=0
C
C---------------------------- start loop
C
        DO 3 P=-HX,HX
        PP=P*P
        DO 3 Q=-HY,HY
        IJ=IJ+1
        IF (MASK(IJ))2,3,1
C
C--------------------------- SUMS FOR THE PEAK
C
1       T=T+1
        QQ=Q*Q
        TPP=TPP+PP
        TQQ=TQQ+QQ
        GO TO 3
C
C------------------------- SUMS FOR THE BACKGROUND
C
2       S=S+1
        QQ=Q*Q
        SPP=SPP+PP
        SQQ=SQQ+QQ
3       CONTINUE
C
C--------------------------end loop
C
        PQVAL(1)=TPP
        PQVAL(2)=SPP
        PQVAL(3)=TQQ
        PQVAL(4)=SQQ
        PQVAL(5)=T
        PQVAL(6)=S
        RETURN
        END
C
C
C
C                      *********************************************
C                      *                                           *
C                      *        ****  SUBROUTINE SIZRAS ****       *
C                      *                                           *
C                      *********************************************
C
C
C
C
C
        SUBROUTINE SIZRAS(IRAS,NPEAK,NBG)
        INTEGER IRAS(5),P,Q
        IHX=IRAS(1)/2
        IHY=IRAS(2)/2
        IC=IHX+IHY-IRAS(3)
        IRX=IHX-IRAS(4)
        IRY=IHY-IRAS(5)
        NPEAK=0
        NBG=0
        NMISS=0
C
C---------------------------------start loop
C
        DO 3 P=-IHX,IHX
        IP=IABS(P)
        DO 3 Q=-IHY,IHY
        IQ=IABS(Q)
        IPQ=IP+IQ
        IF((IPQ.GT.IC).OR.(IP.GT.IRX).OR.(IQ.GT.IRY)) GOTO 1
        IF((IPQ.LT.IC).AND.(IP.LT.IRX).AND.(IQ.LT.IRY)) GOTO 2
        NMISS=NMISS+1
        GOTO 3
1       NBG=NBG+1
        GOTO 3
2       NPEAK=NPEAK+1
3       CONTINUE
C
C------------------------------- end loop
C
        RETURN
        END
C
C
C           SUBROUTINE TO SOLVE THE BG PLANES FOR THE
C                       CURRENT BIN OR SPOT.
C               IF CHANGE FROM STANDARD IS REQUIRED.
C
      SUBROUTINE SLVBCK( J )
C
      INCLUDE 'comuab.finc'
      INCLUDE 'combck.finc'
C
      REAL AM(3,3), BM(3), BUF1(3), BUF2(3)
C
C
      AM(1,1) = BPP(J)
      AM(1,2) = BPQ(J)
      AM(1,3) = BP(J)
      AM(2,1) = BPQ(J)
      AM(2,2) = BQQ(J)
      AM(2,3) = BQ(J)
      AM(3,1) = BP(J)
      AM(3,2) = BQ(J)
      AM(3,3) = BN(J)
      IF(J.EQ.NMBIN+1) GOTO 101
      if(.not.batch)write(6,98) J
      WRITE(8,98) J
 98   FORMAT(1X,'  MATRIX  AM  FOR  BIN  ',I5)
      DO 100 JM = 1,3
      WRITE(8,99) (AM(IM,JM),IM=1,3)
      if(.not.batch)write(6,99) (AM(IM,JM),IM=1,3)
 99   FORMAT(2X,3F10.4)
 100  CONTINUE
 101  CONTINUE
C
C--------------------------INVERT AM
C
      CALL MINV(AM, 3, DET, BUF1, BUF2)
C
C------------------------CALL ABCBCK
C
      CALL ABCBCK(J,AM)
C
      RETURN
      END
C
C
C
C                      *********************************************
C                      *                                           *
C                      *        ****  SUBROUTINE SORT  ****        *
C                      *                                           *
C                      *********************************************
C
C
C
C=============================================================
C
C REF.
C COMM.ACM VOL.12 #3 MARCH 1969, R.C.SINGLETON
C
C=============================================================
C
C
        SUBROUTINE SORTDN3(N,A,B,C)
        DIMENSION A(N),B(N),C(N),IL(16),IU(16)
        INTEGER A,B,C,T,TT,X,Y
        M=1
        I=1
        J=N
1       IF(I.GE.J) GOTO 9
2       K=I
        IJ=(I+J)/2
        T=A(IJ)
        IF(A(I).GE.T) GOTO 3
        A(IJ)=A(I)
        A(I)=T
        T=A(IJ)
        X=B(I)
        B(I)=B(IJ)
        B(IJ)=X
        Y=C(I)
        C(I)=C(IJ)
        C(IJ)=Y
3       L=J
        IF(A(J).LE.T) GOTO 6
        IF(A(J).GT.A(I)) GOTO 4
        A(IJ)=A(J)
        A(J)=T
        T=A(IJ)
        X=B(IJ)
        B(IJ)=B(J)
        B(J)=X
        Y=C(IJ)
        C(IJ)=C(J)
        C(J)=Y
        GOTO 6
4       A(IJ)=A(I)
        A(I)=A(J)
        A(J)=T
        T=A(IJ)
        X=B(J)
        B(J)=B(IJ)
        B(IJ)=B(I)
        B(I)=X
        Y=C(J)
        C(J)=C(IJ)
        C(IJ)=C(I)
        C(I)=Y
        GOTO 6
5       A(L)=A(K)
        A(K)=TT
        X=B(L)
        B(L)=B(K)
        B(K)=X
        Y=C(L)
        C(L)=C(K)
        C(K)=Y
6       L=L-1
        IF(A(L).LT.T) GOTO 6
        TT=A(L)
7       K=K+1
        IF(A(K).GT.T) GOTO 7
        IF(K.LE.L) GOTO 5
        IF((L-I).LE.(J-K)) GOTO 8
        IL(M)=I
        IU(M)=L
        I=K
        M=M+1
        GOTO 10
8       IL(M)=K
        IU(M)=J
        J=L
        M=M+1
        GOTO 10
9       M=M-1
        IF(M.EQ.0) GOTO 13
        I=IL(M)
        J=IU(M)
10      IF((J-I).GE.11) GOTO 2
        IF(I.EQ.1) GOTO 1
        I=I-1
11      I=I+1
        IF(I.EQ.J) GOTO 9
        T=A(I+1)
        IF(A(I).GE.T) GOTO 11
        X=B(I+1)
        Y=C(I+1)
        K=I
12      A(K+1)=A(K)
        B(K+1)=B(K)
        C(K+1)=C(K)
        K=K-1
        IF(T.GT.A(K)) GOTO 12
        A(K+1)=T
        B(K+1)=X
        C(K+1)=Y
        GOTO 11
13      RETURN
        END
C
C
C
C
C
C                      *********************************************
C                      *                                           *
C                      *        ****  SUBROUTINE SORTUP3 ****      *
C                      *                                           *
C                      *********************************************
C
C
C
C=============================================================
C
C       SUBROUTINE SORT
C
C REF.
C COMM.ACM VOL.12 #3 MARCH 1969, R.C.SINGLETON
C
C============================================================
C
C
        SUBROUTINE SORTUP3(N,A,B,C)
        DIMENSION A(N),B(N),C(N),IL(16),IU(16)
        INTEGER A,B,C,T,TT,X,Y
        M=1
        I=1
        J=N
1       IF(I.GE.J) GOTO 9
2       K=I
        IJ=(I+J)/2
        T=A(IJ)
        IF(A(I).LE.T) GOTO 3
        A(IJ)=A(I)
        A(I)=T
        T=A(IJ)
        X=B(I)
        B(I)=B(IJ)
        B(IJ)=X
        Y=C(I)
        C(I)=C(IJ)
        C(IJ)=Y
3       L=J
        IF(A(J).GE.T) GOTO 6
        IF(A(J).LT.A(I)) GOTO 4
        A(IJ)=A(J)
        A(J)=T
        T=A(IJ)
        X=B(IJ)
        B(IJ)=B(J)
        B(J)=X
        Y=C(IJ)
        C(IJ)=C(J)
        C(J)=Y
        GOTO 6
4       A(IJ)=A(I)
        A(I)=A(J)
        A(J)=T
        T=A(IJ)
        X=B(J)
        B(J)=B(IJ)
        B(IJ)=B(I)
        B(I)=X
        Y=C(J)
        C(J)=C(IJ)
        C(IJ)=C(I)
        C(I)=Y
        GOTO 6
5       A(L)=A(K)
        A(K)=TT
        X=B(L)
        B(L)=B(K)
        B(K)=X
        Y=C(L)
        C(L)=C(K)
        C(K)=Y
6       L=L-1
        IF(A(L).GT.T) GOTO 6
        TT=A(L)
7       K=K+1
        IF(A(K).LT.T) GOTO 7
        IF(K.LE.L) GOTO 5
        IF((L-I).LE.(J-K)) GOTO 8
        IL(M)=I
        IU(M)=L
        I=K
        M=M+1
        GOTO 10
8       IL(M)=K
        IU(M)=J
        J=L
        M=M+1
        GOTO 10
9       M=M-1
        IF(M.EQ.0) GOTO 13
        I=IL(M)
        J=IU(M)
10      IF((J-I).GE.11) GOTO 2
        IF(I.EQ.1) GOTO 1
        I=I-1
11      I=I+1
        IF(I.EQ.J) GOTO 9
        T=A(I+1)
        IF(A(I).LE.T) GOTO 11
        X=B(I+1)
        Y=C(I+1)
        K=I
12      A(K+1)=A(K)
        B(K+1)=B(K)
        C(K+1)=C(K)
        K=K-1
        IF(T.LT.A(K)) GOTO 12
        A(K+1)=T
        B(K+1)=X
        C(K+1)=Y
        GOTO 11
13      RETURN
        END
C
C
C
C                      *********************************************
C                      *                                           *
C                      *        ****  SUBROUTINE SPOTPLOT ****     *
C                      *                                           *
C                      *********************************************
C
C
C
C=============================================================
C
C
C       SUBROUTINE SPOTPLOT
C
C  SCANS CENTRAL AREA OF FILM AND PLOTS IMAGE
C  OF FILM ON TEKTRONIX.
C
C=============================================================
C
C
C
C
        SUBROUTINE SPOTPLOT
c
cRCD ...Image Plate logical
        common/iplate/image,mar,moldyn
        logical image,mar,moldyn
C
      INCLUDE 'comori.finc'
      INCLUDE 'comras.finc'
      INCLUDE 'comscn.finc'
C
        LOGICAL VEC
        INTEGER NH(40)
        COMMON/PEL/IBA,IJBA(5120),NREC
        INTEGER*2 iba,IJBA
      integer i4ba,kpx,jpx
        COMMON/PLOTSC/DLSCAL
        DATA INTV/4/
C
C--------------  FILE USED FOR STORING IMAGE OF FILM
C
        ifail=0
        call ccpdpn(-22,'SPOTVEC','UNKNOWN','U',0,ifail)
        DO 1 J=1,40
1       NH(J)=0
        if(.not.image)then
        ITHRESH=70
        else
        ithresh=20000
        endif
c       **** NSCAN+1 is total number of scans required ****
        XNSCAN=2.0*25.6*100.0*fact
        NSCAN = XNSCAN
        IYCEN=YCEN*FACT
        IXCEN=XCEN*FACT
c       **** IBLK here is the starting stripe of data ****
        IBLK=IXCEN-2560*FACT
        NSTEP=4/SCNSZ
        if(nstep.eq.0)nstep=1
      stepn = 4.0/scnsz
        scal=0.1*stepn/fact
        jlim=int(float(1024)/scal)
        klim=int(float(780)/scal)
        NBLK=NSTEP
        DO 8 JPX=0,jlim,2
        j=jpx*scal
        IER=NBLK
        CALL RDBLK(2,IBLK,IJBA,NWORD,IER)
        IBLK=IBLK+NBLK
        VEC=.FALSE.
        IADDR=IYCEN-1950*FACT
        DO 4 KPX=0,klim,2
        k=kpx*scal
        if(.not.image)then
        CALL CBYTE(IADDR)
        else
        call ip_cbyte(iaddr)
        endif
        IADDR=IADDR+NSTEP
        i4ba=abs(int(iba))
C
C------------- HISTOGRAM FOR FIRST TEN SCAN LINES
C
        IF(J.GT.20) GOTO 2
        N=MIN0(I4BA/4+1,40)
        NH(N)=NH(N)+1
        GOTO 6
2       IF(I4BA.LT.ITHRESH) GOTO 3
        IF(VEC) GOTO 4
        IB=K
        VEC=.TRUE.
        CALL MOVTX(J,IB)
        WRITE(22) J,IB
        GOTO 4
3       IF(.NOT.VEC) GOTO 4
        IE=(K-1)
        VEC=.FALSE.
        CALL VECTX(J,IE)
        CALL ALPHA
        WRITE(22) J,IE
4       CONTINUE
        IF (.NOT.VEC) GO TO 5
        CALL VECTX(J,780)
        CALL ALPHA
        WRITE(22) J,780
5       IF(J.GT.20) GOTO 8
6       NMAX=0
        DO 7 K=1,40
        IF(NH(K).LT.NMAX) GOTO 7
        NMAX=NH(K)
        NK=K
7       CONTINUE
        ITHRESH=(INTV*NK)*DLSCAL
8       CONTINUE
        CLOSE (UNIT=22)
        RETURN
        END
c##### Laue mods for Version 2 ge1/ge2 file      Sep 1986
C
C
C
C                      *********************************************
C                      *                                           *
C                      *        ****  SUBROUTINE START ****        *
C                      *                                           *
C                      *********************************************
C
C
C
C=============================================================
C READS INPUT PARTLY FROM GENERATE-FILE PARTLY FROM SCANNER
C AND PREPARES COMMON VARIABLES FOR LATER OVERLAYS
C  DISPLAYS MEASUREMENT BOX AND ALLOWS CHANGES
C  OF PARAMETERS.
C=============================================================
C
C
C
        SUBROUTINE START
c
C
C   ------------------------ COMMON VARIABLES
C
C
cRCD ...Image Plate logical
        common/iplate/image,mar,moldyn
        logical image,mar,moldyn
      INCLUDE 'comori.finc'
      INCLUDE 'comscn.finc'
      INCLUDE 'comras.finc'
      INCLUDE 'comfid.finc'
      INCLUDE 'commcs.finc'
      INCLUDE 'comrfs.finc'
      INCLUDE 'comuab.finc'
      INCLUDE 'commaskl.finc'
      INCLUDE 'commask.finc'
      INCLUDE 'comlaue.finc'
C
        COMMON /EXTRAS/ JUMPAX
C
C  ------------------------  LOCAL VARIABLES
C
c##### Laue mods - extra arrays for header info
c      original buffer array removed
C
        character*76 title
      character*6 crystal_id
        dimension x_c(6), y_c(6), w_c(6), y_scal(6), x_to_fra(6)
        dimension twists(6),tilts(6),bulges(6),dummy4(13)
        INTEGER ibuf(19), HXS,HYS,TST
        INTEGER    PACKID,PACK,DMM(5)
        INTEGER CORX(2),CORY(2),CORBAR(2)
        REAL CORANG(2),rast
        COMMON/SW/ISWTCH(10),oneref,noref,tworef
        COMMON/IOO/IOUT
        common/pel/iba,ijba(5120),nrec
        integer*2 ijba,iba
        LOGICAL oneref,noref,tworef
        common/plotsc/dlscal
      common/fgname/ge_file,iendpos
      character*40 ge_file,genfile
        character*1 junk
c
c##### laue mods - increase to 6 films per pack
        DIMENSION IFDAT(6),IFLDAT(6)
        DATA IFDAT/'A ','B ','C ','D ','E ','F '/
        DATA IFLDAT/'a ','b ','c ','d ','e ','f '/
C
C---------------------- ASK FOR PACKID AND FILM
C
c##### laue mods - remove idxfil = 1
1       continue
        if(.not.batch)write(6,900)
        if(.not.batch)WRITE(IOUT,900)
900     FORMAT(' PACK NUMBER (FREE FORMAT):',$)
        read(5,*) PACKID
        IF(.NOT.BATCH)write(iout,905) packid
905     format(1h+,I4)
c
        if(image) goto 21
      if(.not.batch)write(6,910)
        if(.not.batch)WRITE(IOUT,910)
910     FORMAT(' FILM NUMBER (A,B,C,D,E,F):',$)
        read(5,920) FILM
920     FORMAT(A1)
        IF(.NOT.BATCH)write(iout,930) film
930     format(1h+,a1)
c##### laue mods - increase to 6 films
        DO 2 I=1, 6
        IF(FILM.EQ.IFDAT(I))GO TO 3
        IF(FILM.EQ.IFLDAT(I))GO TO 3
2       CONTINUE
21      I=1
3       FILM=I
c
c##### laue mods - read title and crystal and general header info
c
      read(1, rec=1) title
      read(1, rec=2) crystal_id,x_cen_fs,y_cen_fs,(w_fs(i),i=1,5)
      read(1, rec=3) w_fs(6)
      cent_in = .true.
      if(x_cen_fs(film).eq.0.and.y_cen_fs(film).eq.0) then
      cent_in = .false.
      endif
c
c##### laue mods - read raster(mm) and box sizes
c
      read(1,rec=4) rastin,iras,dummy4
      rast = (rastin*1000.)
C
C------------ SCANSZ IS THE SCANNER UNIT IN MULTIPLES OF 25 MICRONS
C
        SCNSZ=RAST/25.
C
C--------------FACT IS THE FACTOR USED THROUGH-OUT THE PROGRAM TO
C------ TRANSFORM FROM GENERATE-FILE UNITS (10 MICRON) TO SCANNER UNITS.
C
        FACT=0.4/SCNSZ
      if(streak) then
            if(.not.bgplan) then
                    bminor = bminor/2.0*100.*fact
                    cmask = cmask/2.0*100.*fact
                    dmask = dmask*100.*fact
             if (binvar) then
                ammax = ammax/2.0*100.*fact
                ammin = ammin/2.0*100.*fact
             end if
            end if
      end if
c
c##### laue mods - read twists,tilts,bulges,c_to_fd (mm)
c
      read(1,rec=6) twists, tilts, bulges, c_to_fd
      itilt  = tilts(film)
      itwist = twists(film)
      ibulge = bulges(film)
      ctofd  = nint(c_to_fd * 100.0)
c
c##### laue mods - read x_c, y_c, w_c, delta (mm)
c
      read(1, rec=5) x_c, y_c, w_c, delta
c
c##### laue mods - convert delta to 10 micron
c
      delta = delta * 100.
c
c##### laue mods - read y_scal, x_to_fra, mint
c
      read(1, rec=7) y_scal, x_to_fra, mint
      yscal  =  y_scal(Film)
      xtofra =  x_to_fra(Film)
c
c##### laue mods - convert from mm units to 10 micron
c
      ccx    =  nint(x_c(Film)*100.)
      ccy    =  nint(y_c(Film)*100.*yscal)
      ccom   =  w_c(Film)
c
c##### laue mods - read pack and spot numbers
c
      read(1,rec=10) ibuf
      pack = ibuf(1)
      tospt = ibuf(2)
c
c##### laue mods - select 'nodal' limits
c
       write(iout, 4)
C
        IF(.not.batch) THEN
         if(.not.batch)write(6, 4)
    4    format(/,' APPROX NUMBERS OF REFINEMENT NODALS [300,1000]:',$)
         read(5,*) lim1,lim2
    5    format(2i8)
        ELSE
         Read(5,*) lim1,lim2
        END IF
C
      if(lim1.eq. 0)lim1 = 300
      if(lim2 .eq.0)lim2 = 1000
      write(iout,6)lim1,lim2
6     format(1h+,2I8)
c     initialise nodlims to use all nodals
      nodlim1 = 12
      nodlim2 = 12
      nodmax = 12
      do i = 1,12
         if(ibuf(i+6).le.lim1) nodlim1 = i
         if(ibuf(i+6).le.lim2) nodlim2 = i
         if(ibuf(i+6).le.2000) nodmax = i
      enddo
c
c##### laue mods - set miscellaneous values for laues
c
      packs = 1
      jumpax = 1
      ivee = 0
      films = 6
      cbar   =  0
c
c##### laue mods - base box on delta overlap value
c
c      iras(1) = (delta * fact) + 1
c      if(mod(iras(1),2).eq.0) iras(1) = iras(1)+1
c      iras(2)= iras(1)
c      iras(3) = 5
c      iras(4) = 1
c      iras(5) = iras(4)
c
      iprof = 0
      if (profil) iprof = 1
      call getgexy(1, tospt, film, mint, iprof, nodmax)
      if(xtek) call tkclr
C
C--------------------------------- PRINT TITLE
C##### laue mods
c
        WRITE(IOUT,1002)
        if(.not.batch)write(6,1002)
1002    FORMAT(/10X,10('*****')/)
        WRITE(IOUT,1003) crystal_id(1:6), title
        if(.not.batch)write(6,1003) crystal_id(1:6), title
1003    FORMAT (20X,a6,/,1x,a76)
C
C----------------------------- PRINT PACKID AND FILM
C
        I=IFDAT(FILM)
        WRITE(IOUT,1004) PACKID,I
        if(.not.batch)write(6,1004)PACKID,I
1004    FORMAT(20X,'IMAGE  ',I5,A1)
        WRITE(IOUT,1002)
        if(.not.batch)write(6,1002)
C
C
C-------------------- PRINT SCANNER UNIT
C
c##### laue mods - replace buf(6) by rast
c
        WRITE(IOUT,1005) rast
        if(.not.batch)write(6,1005) rast
1005    FORMAT(' SCANNER UNIT:',f7.2,'  MICRONS')

C
C---------------------------- GET BOX PARAMETERS IN SCANNER UNITS
C-------------- TRANSFORM SOME OF THE BOX PARAMETERS TO ODD NUMBER
C------------------------------ OF SCANNER UNITS
C
        Ichange = 0
11      HXS=NXS/2
        HYS=NYS/2
        NXS=HXS*2+1
        NYS=HYS*2+1
C
C-------------------- PRINT BOX PARAMETERS AND READ NEW ONES
C--------------------------- DRAW SHAPE OF MEASUREMENT BOX
C
        CALL PLTRAS(IRAS)
        WRITE(IOUT,1006)
        WRITE(IOUT,1007) IRAS
        if(Ichange.eq.1) goto 13
        if(.not.batch)write(6,1006)
        if(.not.batch)write(6,1007)IRAS
        IF(.NOT.BATCH)read(5,1008) DMM
        IF(BATCH)read(5,*) DMM
1006    FORMAT('  NXS  NYS   NC  NRX  NRY ')
1007    FORMAT(5I5,' ? (I5 INPUT TO MODIFY)')
1008    FORMAT(5I5)
        if(batch) ichange = 1
        TST=0
        DO 12 I=1,5
        IF(DMM(I).EQ.0) GOTO 12
      if(dmm(i).lt.0) dmm(i) = 0
        TST=1
        IRAS(I)=DMM(I)
12      CONTINUE
        IF(TST.EQ.1) GOTO 11
13      IF(XTEK)CALL TKCLR
C
C----------------------- UPDATE RASTER PARAMETERS ON GENERATE FILE
C##### laue mods
c
        WRITE(1,REC=4) Rastin,Iras,Dummy4
C
C---------------------- TAKE CARE OF PERPENDICULAR DISTANCE TO FILM
C------------------------ FOR VEE-SHAPED CASSETTE = CTOFD*SQRT(3)/2
C
        DTOFD=CTOFD
        IF(VEE) DTOFD=DTOFD*0.866
C
C----------- FACTOR TO CONVERT FROM 1/100TH DEG TO DISTORTION UNITS
C
        FDIST=3.14159/(CTOFD*18000.)
C
C------  NOTE THAT FOR VEE FILMS, TILT IS EQUIVALENT TO VBNEG, TWIST IS
C-----------  EQUIVALENT TO VBPOS AND BULGE IS EQUIVALENT TO VTWIST.
C-----------  ONLY VALUES OF TILT, TWIST AND BULGE ARE STORED BACK
C----------------  IN THE GENERATE FILE FOR B AND C FILMS.
C
        BULGE=BULGEs(film)*FDIST
        IF(VEE) FDIST=1.0/CTOFD
        TWIST=TWISTs(film)*FDIST
        TILT=TILTs(film)*FDIST
        VTILT=0.0
        VVERT=0.0
C
C----------------------------------------------------
c
      genfile = ge_file(1:iendpos) // '.gen'
      if(.not.batch)write(6,788)genfile
      write(iout,788)genfile
788      format(1x,'Opening constants file ',a)
c------------------------------------------------------
C-------------------- READ CONSTANTS FROM FILE 'laueflm.dat'
C##### laue mods
c
7881    OPEN(UNIT=4,FILE=genfile,STATUS='OLD',iostat = imok)
      if(imok.eq.0) goto 7889
      if(.not.batch)write(6,7882) genfile
      write(iout,7882) genfile
7882      format(1x,' ** Unable to find file ** ',a)
      if(batch) then
            if(genfile.eq.'laueflm.dat') stop
            genfile = 'laueflm.dat'
           else
            if(.not.batch)write(6,7883)
            write(iout,7883)
7883      format(/1x,'Name of constants file? ',$)
      read(5,7884) genfile
7884      format(a40)
      end if
      goto 7881
c
c##### laue mods - change laueflm.dat to reduced info on fiducials
c
7889      continue
        do 789 irgen = 1,8
789     read(4,790,end=791) crap
790     format(a1)
      goto 792
791     rewind 4
792      if(mar) then 
                  read(1, rec=7) y_scal, x_to_fra, mint,eps,roff,toff
            if(roff.eq.0.0.and.toff.eq.0.0) then
               read (4,*) crap1,crap2,roff,toff
                     write(1, rec=7) y_scal, x_to_fra, mint,eps,roff,toff
            else
               read(4,790) crap
            endif
      else
            read (4,790) crap
      end if
      read (4,*) yscgen
      read (4,*) crap      
      READ (4,*) NFID,((FSPOS(I,K),K=1,2),I=1,NFID)
        READ (4,*) WFILM,MM,N1OD,BASEOD,G1OD,CURV
        MM=50*MM
        READ(4,*)NREC,IYLEN,DLSCAL,xcenp,ycenp,rastin
        xcenf=xcenp/fact
        ycenf=ycenp/fact
        if(.not.image)then
        NWORD=IYLEN/2
        else
        nword=iylen
        xcen=xcenf+ccx
        ycen=ycenf+ccy
        cosom0=cos(omega0)
        sinom0=sin(omega0)
        endif
c
c----- read new genfile line for line scan ip distortion
c
      if(moldyn) then
      write(8,7922)
7922      format(1x,' logical moldyn set as .TRUE.')
      read(4,*,end=7925) spdx_min,spdx_max,nspdx,(spdx(ni),ni=1,nspdx)
      read(4,*,end=7925) spdy_min,spdy_max,nspdy,(spdy(ni),ni=1,nspdy)
      read(4,*,end=7925) spdxy
      spdx_min = spdx_min*100.
      spdx_max = spdx_max*100.
      spdy_min = spdy_min*100.
      spdy_max = spdy_max*100.
7925    CONTINUE
      endif
c
      if(fspos(1,1).lt.-3000) then
            goto 799
      else
            do 793 ifd = 1,nfid
            do 793 kfd = 1,2
793            fspos(ifd,kfd) = ((fspos(ifd,kfd) - nword)*rast)/10
      end if
799     CLOSE (UNIT=4)
      if(.not.image) then
        WRITE(IOUT,1009) BASEOD,G1OD,CURV
        if(.not.batch)write(6,1009)BASEOD,G1OD,CURV
1009    FORMAT(/10X,'FILM CHARACTERISTICS'/' BASE O.D.=',F4.2,
     1    ' GRANULARITY=',F4.1,' NON-LINEARITY FACTOR=',F5.2/)
1010    FORMAT(18A4)
      endif
        RETURN
        END
C
C
C     SUBROUTINE TO SET UP THE STANDARD HAT-MATRIX.
C
C
      SUBROUTINE STPHAT(ibin,HX,HY)
C
      INCLUDE 'comuab.finc'
      INCLUDE 'comhat.finc'
      INCLUDE 'commaskl.finc'
C
      REAL XTX(3,3),BUF1(3),BUF2(3),
     *     XXINV(5000,3),HATT(3,5000),
     *     HATTSP(3,5000),HATSP(5000,3)
      INTEGER HX,HY,hprint(5000)
c   zero counters
      ratrej = 0
      rgdrej = 0
      ogdrej = 0
      idir = -1
C
C-----------SET UP HATSP MATRIX
C
        NN=HPOBS(ibin)
      DO 100 I=1,NN
      HATP(I,1,ibin) = 1
         DO 110 J=1,3
              HATSP(I,J)=HATP(I,J,ibin)
            HATTSP(J,I)=HATSP(I,J)
110      CONTINUE
100   CONTINUE
C
      DO 200 I=1,3
      DO 200 J=1,3
         XTX(I,J)=0.0
         DO 210 K=1,NN
            PROD=HATTSP(I,K)*HATSP(K,J)
            XTX(I,J)=XTX(I,J)+PROD
210      CONTINUE
200   CONTINUE
C
C-----------------INVERT XTX
C
      CALL MINV(XTX,3,DET,BUF1,BUF2)
C
      DO 300 I=1,NN
         DO 310 J=1,3
            XXINV(I,J)=0.0
            DO 320 K=1,3
               PROD=HATSP(I,K)*XTX(K,J)
               XXINV(I,J)=XXINV(I,J)+PROD
320         CONTINUE
310      CONTINUE
300   CONTINUE
C
C----------CALCULATE HSP(I)'S-----------
C
      DO 400 I=1,NN
         Hsp(I,ibin)=0.0
         DO 410 K=1,3
            PROD=XXINV(I,K)*HATTSP(K,I)
            HSP(I,ibin)=HSP(I,ibin)+PROD
410      CONTINUE
400   CONTINUE
C
C-------------------------- PUT INTO ARRAY HX,HY
C
c      if(.not.correct) return
c      if(.not.streak) return
c      NP = 0
c      DO 510 I=-Hx,Hx,idir
c      DO 509 J=-Hy,Hy
c      NP = NP + 1
c      hprint(np) = 0
c      DO 508 K=1,NN
c      IF(int(HATP(K,2,ibin)).EQ.I.AND.int(HATP(K,3,ibin)).EQ.J)
c     1          THEN
c            HPRINT(NP) = nint(1000.*HSP(K,ibin))
c            goto 509
c      END IF
c508      CONTINUE
c509      CONTINUE
c510      CONTINUE
C
c      if(.not.batch)write(6,606) ibin
c606      format(1x,' Standard values of H(i) for bin ',i3,/)
c      write(8,607) ibin
c607      format(1h1,' Standard values of H(i) for bin ',i3,/)
c      nend = ((2*iabs(hx) + 1) * (2*iabs(hy) + 1))
c      nst = 1
c      istp = -(2*hy + 1)
c      DO 610 I=-hy,hy
c      WRITE(8,609) (HPRINT(J),J=nend,nst,istp)
c      if(.not.batch)write(6,608) (HPRINT(J),J=nend,nst,istp)
c608      FORMAT(2X,40i3)
c609      FORMAT(/1x,40i3)
c      nend = nend - 1
c610      CONTINUE
C      
C
      RETURN
      END
C
C
C           SUBROUTINE TO ADD IN A BG POINT OF VALUE
C         B AT X,Y (RELATIVE TO CENTRE). THE ELEMENTS OF
C       THE AM MATRIX ARE TAKEN CARE OF IN AMBCK, AND THEN
C         BY OFFBCK IF POINT(S) ARE REMOVED.
C
      SUBROUTINE SUMBCK(J, B, P, Q, SIGN)
C
      INCLUDE 'combck.finc'
      INCLUDE 'comprf.finc'
C
      INTEGER P, Q, SIGN
C
      BOP(J) = BOP(J) +  B * FLOAT(P)
      BOQ(J) = BOQ(J) +  B * FLOAT(Q)
      BO(J) = BO(J) +  B
      RETURN
      END
C
C
C
C                      *********************************************
C                      *                                           *
C                      *        ****  SUBROUTINE TDATE ****        *
C                      *                                           *
C                      *********************************************
C
C
C
        SUBROUTINE TDATE
C
      INCLUDE 'comuab.finc'
C
        CHARACTER*8 ITIME
        COMMON/IOO/IOUT
        DIMENSION JDATE(3)
        CALL UIDATE(JDATE(2),JDATE(1),JDATE(3))
        CALL UTIME(ITIME)
        WRITE(IOUT,1000) (ITIME),(JDATE(J),J=1,3)
        if(.not.batch)write(6,1000)(ITIME),(JDATE(J),J=1,3)
1000    FORMAT(' OUTPUT FROM INTLAUE AT ',A8,' ON ',I2
     1              ,'/',I2,'/',I2,'.',//)
        RETURN
        END
C
      SUBROUTINE TKCLR
      CALL QGCLR
      RETURN
      END
C
      SUBROUTINE TKPLOT(KX,KY,IFLAG,ICHK)
C
C PARAMETERS
C
C     KX (I)   X POSITION (ACROSS SCREEN LEFT TO RIGHT) 0 TO 1023
C     KY (I)   Y POSITION (UP SCREEN BOTTOM TO TOP) 0 TO 767
C  IFLAG (I)   =0 DRAW, =1 MOVE, =2 POINT PLOT
C   ICHK (O)   =1 OK, =0 ERROR IN CALL
C
C
C SPECIFICATION STATEMENTS
C ------------------------
C
      CHARACTER*1 GS, FS
      CHARACTER*4 POS
C
C CODE
C ----
C
      CALL QGENTR
      GS=CHAR(29)
      FS=CHAR(28)
      ICHK=1
      IF (IFLAG.GT.2) THEN
         ICHK=0
         RETURN
      ENDIF
      IX = KX
      IY = KY
      IF (IX.LT.0) IX=0
      IF (IX.GT.1023) IX=1023
      IF (IY.LT.0) IY=0
      IF (IY.GT.767) IY=767
      X=FLOAT(IX)
      Y=FLOAT(IY)
      IF (IFLAG.EQ.1) THEN
       CALL QGMOVE(X,Y)
       RETURN
      ENDIF
c
      IF (IFLAG.EQ.0) THEN
       CALL QGDRAW(X,Y)
       RETURN
      ENDIF
c
      IF (IFLAG.EQ.2) THEN
      JXH = IX/32
      JYH = IY/32
      JXL = IX-32*JXH
      JYL = IY-32*JYH
      POS(1:1) = CHAR(JYH+32)
      POS(2:2) = CHAR(JYL+96)
      POS(3:3) = CHAR(JXH+32)
      POS(4:4) = CHAR(JXL+64)
      CALL QGSEND (POS)
      ENDIF
      RETURN
      END
C
C
C
C
C
C                      *********************************************
C                      *                                           *
C                      *        ****  SUBROUTINE VECPLOT****       *
C                      *                                           *
C                      *********************************************
C
C
C
C=============================================================
C
C
C       SUBROUTINE VECPLOT
C
C  PLOTS IMAGE OF FILM FROM STORED VECTORS
C
C
C=============================================================
C
C
        SUBROUTINE VECPLOT
        ifail=0
        call ccpdpn(-23,'SPOTVEC','OLD','U',0,ifail)
1       READ(23,END=2) IX,IY
        CALL MOVTX(IX,IY)
        READ(23,END=2) IX,IY
        CALL VECTX(IX,IY)
        CALL ALPHA
        GOTO 1
2       CLOSE (UNIT=23)
        RETURN
        END
C
      SUBROUTINE VECTX(IX,IY)
C  REPLACE LAUELIB ROUTINE WITH QGDRAW
      X=FLOAT(IX)
      Y=FLOAT(IY)
      CALL QGDRAW(X,Y)
      RETURN
      END
C
C
C
C
C                      *********************************************
C                      *                                           *
C                      *        ****  SUBROUTINE WRGEN   ****      *
C                      *                                           *
C                      *********************************************
C
C
C
c##### laue mods
C=============================================================
C
        SUBROUTINE WRGEN(N,UNIT)
c        INTEGER GENBUF(10)
      integer*2 genbuf(38)
      integer UNIT
C
      INCLUDE 'comlaue.finc'
      INCLUDE 'comuab.finc'
      INCLUDE 'comras.finc'
      INCLUDE 'compro.finc'
C
        integer irsav(1000)
c
c save record numbers before sorting if IBOTH
c
        if(IBOTH) then
         do 100 irs = 1,n
100      irsav(irs) = irec(irs)
        END IF
c
        CALL SORTUP3(N,IREC,INTEN,ISD)
        DO 1 I=1,N
        NREC=IREC(I) + 10
        READ(UNIT,REC=NREC) GENBUF
        IF (INTEN(I).LE.32767) THEN
           GENBUF(IFILL)=INTEN(I)
        ELSE
           GENBUF(IFILL)=32767
        ENDIF
        IF(ISD(I).LE.32767) THEN
           GENBUF(IFILL+6 )=ISD(I)
        ELSE
           GENBUF(IFILL+6)=32767
        ENDIF
        WRITE(UNIT,REC=NREC) GENBUF
c     if this intensity is lt MINT set the 'no measure' flag
c     for subsequent films
      if ( inten(i).lt.mint) then
       if (inten(i).ne.-9999) then
         nodal(nrec-10) = or(int(nodal(nrec-10)),2)
       endif
      endif
c       if(inten(i).lt.1600) goto 1
c       if(inten(i).eq.9999) goto 1
c       write(8,1000) irec(i),inten(i),isd(i)
c1000   format(1x,' In wrgen, Rec,I  and sd  (step 1):',3i7)
  1     CONTINUE
        if(.not.iboth) return
        CALL SORTUP3(N,IRSAV,INTENb,ISDb)
        DO 2 I=1,N
        NREC=IREC(I) + 10
        READ(UNIT,REC=NREC) GENBUF
        GENBUF(IFILL-12)=INTENb(I)
        GENBUF(IFILL-6 )=ISDb(I)
        WRITE(UNIT,REC=NREC) GENBUF
c       if(inten(i).lt.1600) goto 2
c       if(inten(i).eq.9999) goto 2
c       write(8,2000) irec(i),intenb(i),isdb(i)
c2000   format(1x,' In wrgen, Rec,Ib and sdb (step 2):',3i7)
2       continue
        RETURN
        END
C
C
C
C                      *********************************************
C                      *                                           *
C                      *        ****  SUBROUTINE XYCAL  ****       *
C                      *                                           *
C                      *********************************************
C
C
C
C=============================================================
C
C
C
        SUBROUTINE XYCALC(XC,YC,X,Y)
        REAL XC,YC,X,Y
        DATA A0/2.86E-7/,B0/2.78E-8/
cRCD ...Image Plate Logical
        common/iplate/image,mar,moldyn
        logical image,mar,moldyn
C
C------- A0 AND B0 DEFINE SHAPE OF BULGE FOR VEE FILMS
C------- THESE VALUES GIVE 2% AT X=3700 AND Y=6000
C
      INCLUDE 'comori.finc'
      INCLUDE 'commcs.finc'
c
c--- change comori to add distortion type and type 3 distortion
c--- distortion type is dstor, 3 for line scan ip
C
        XM=X*COSOM0-Y*SINOM0
        YM=X*SINOM0+Y*COSOM0
        IF(VEE) GOTO 1
        R=SQRT(X*X+Y*Y)
cRCD ...Change the calculation for AGWL's MOSFLM IP refinables
        if(r.eq.0.0)then
        cpsi = 1.0
        spsi = 0.0
        else
        cpsi = xm/r
        spsi = ym/r
        endif
c
        if(.not.image)then
        DXTOF=XTOFRA+TILT*X+TWIST*Y+BULGE*R
        XC=DXTOF*XM+XCEN
        YC=DXTOF*YM*YSCAL+YCEN
c
c----- MAR roff, toff parameters (if dstor ne 3)
c
        else if (mar) then
        dxtof=xtofra+tilt*x+twist*y
        xc=dxtof*xm+xcen-toff*spsi+roff*cpsi
        yc=dxtof*ym*yscal+ycen+toff*cpsi+roff*spsi
c
c----- line scan ip, new distortion correction
c
      else if(moldyn) then
              dxtof=xtofra+tilt*x+twist*y
              xc   = dxtof * xm
              yc   = dxtof * ym
c
            xc   = xc + SPDXY*yc
c
                XD = XC
                IF (XD.LT.SPDX_MIN) XD = SPDX_MIN
                IF (XD.GT.SPDX_MAX) XD = SPDX_MAX
                D = 0.0
                DD = 0.0
                XP = (2.0*XD-SPDX_MIN-SPDX_MAX)/(SPDX_MAX-SPDX_MIN)
                XP2 = 2.0*XP
                DO 100 I=NSPDX,2,-1
                   SV = D
                   D = XP2*D - DD + SPDX(I)
                   DD = SV
100             CONTINUE
                XC = XC + 100.0*(XP*D - DD + 0.5*SPDX(1))
                YD = YC
                IF (YD.LT.SPDY_MIN) YD = SPDY_MIN
                IF (YD.GT.SPDY_MAX) YD = SPDY_MAX
                D = 0.0
                DD = 0.0
                YP = (2.0*YD-SPDY_MIN-SPDY_MAX)/(SPDY_MAX-SPDY_MIN)
                YP2 = 2.0*YP
                DO 110 I = NSPDY,2,-1
                   SV = D
                   D = YP2*D - DD + SPDY(I) 
                   DD = SV
110             CONTINUE
                YC = YC + 100.0*(YP*D - DD + 0.5*SPDY(1))

            xc = xc + xcen
            yc = yc * yscal + ycen
      endif
        RETURN
C
C------- CONFUSING CHOICE OF VARIABLE NAMES
C------- BNEG=TWIST*CTOFD(*SIN(VEE))
C------- BPOS=BULGE*CTOFD(*SIN(VEE))
C------- XSHIFT=TILT*CTOFD(*TAN(VEE))
C
 1      CONTINUE
        DOV2=CTOFD/2
        ABSX=ABS(X)
        XDASH=ABSX-4300.
        XD=(ABSX-DOV2)
        XX=XDASH*XDASH*A0
        YY=Y*Y*B0
        FB=EXP(-XX-YY)
        FR=FB*XD
        BY=FB*Y
        SB=CBAR*SINOM0
        CB=CBAR*COSOM0
        DISTOR=VTILT*X + VTWIST*Y + VVERT*SIGN(1.0,X)
C
C------ FOLLOWING 2 LINES ARE VERSION REFINING VEE XSHIFT PARAMETER
C------ XC=XM*XTOFRA+XCEN+ABSX*TILT
C------ YC=YM*XTOFRA*YSCAL+YCEN+TILT*Y*SIGN(1.0,X)
C------ FOLLOWING 2 LINES ARE VERSION REFINING VEE TWIST PARAMETER
C------ XC=XM*XTOFRA+XCEN+TILT*X*Y
C------ YC=YM*XTOFRA*YSCAL+YCEN+TILT*Y*Y
C------ COORDS FOR REFINING TILT, TWIST AND VERT
C
        XC=XM*XTOFRA+XCEN+X*DISTOR
        YC=YM*XTOFRA*YSCAL+YCEN+Y*DISTOR
        IF(X.LT.0.0) GOTO 2
C
C------------------------- POSITIVE X
C
        XC=XC-VBPOS*FR-CB
        YC=YC-VBPOS*BY-SB
        RETURN
C
C------------------------- NEGATIVE X
C
 2      XC=XC+VBNEG*FR+CB
        YC=YC-VBNEG*BY+SB
        RETURN
        END
c**********************************************************
C
C
C
C                      *********************************************
C                      *                                           *
C                      *        ****  SUBROUTINE XYMD   ****       *
C                      *                                           *
C                      *********************************************
C
C
C
C=============================================================
C
C
C
        SUBROUTINE XYMD(XC,YC,X,Y)
        REAL XC,YC,X,Y
        DATA A0/2.86E-7/,B0/2.78E-8/
cRCD ...Image Plate Logical
        common/iplate/image,mar,moldyn
        logical image,mar,moldyn
C
C------- A0 AND B0 DEFINE SHAPE OF BULGE FOR VEE FILMS
C------- THESE VALUES GIVE 2% AT X=3700 AND Y=6000
C
      INCLUDE 'comori.finc'
      INCLUDE 'commcs.finc'
c
c--- change comori to add distortion type and type 3 distortion
c--- distortion type is dstor, 3 for line scan ip
C
        XM=X*COSOM0-Y*SINOM0
        YM=X*SINOM0+Y*COSOM0
c
c----- line scan ip, new distortion correction
c
              dxtof=xtofra+tilt*x+twist*y
              xc   = dxtof * xm
              yc   = dxtof * ym
c
            xc   = xc + SPDXY*yc
c
                XD = XC
                IF (XD.LT.SPDX_MIN) XD = SPDX_MIN
                IF (XD.GT.SPDX_MAX) XD = SPDX_MAX
                D = 0.0
                DD = 0.0
                XP = (2.0*XD-SPDX_MIN-SPDX_MAX)/(SPDX_MAX-SPDX_MIN)
                XP2 = 2.0*XP
                DO 100 I=NSPDX,2,-1
                   SV = D
                   D = XP2*D - DD + SPDX(I)
                   DD = SV
100             CONTINUE
                XC = XC + 100.0*(XP*D - DD + 0.5*SPDX(1))
                YD = YC
                IF (YD.LT.SPDY_MIN) YD = SPDY_MIN
                IF (YD.GT.SPDY_MAX) YD = SPDY_MAX
                D = 0.0
                DD = 0.0
                YP = (2.0*YD-SPDY_MIN-SPDY_MAX)/(SPDY_MAX-SPDY_MIN)
                YP2 = 2.0*YP
                DO 110 I = NSPDY,2,-1
                   SV = D
                   D = YP2*D - DD + SPDY(I) 
                   DD = SV
110             CONTINUE
                YC = YC + 100.0*(YP*D - DD + 0.5*SPDY(1))

            xc = xc + xcen
            yc = yc * yscal + ycen
        RETURN
      END
c**********************************************************
C
C
C
C
C                      *********************************************
C                      *                                           *
C                      *        ****  SUBROUTINE XYSHIFT ****      *
C                      *                                           *
C                      *********************************************
C
C
C
C=============================================================
C
        SUBROUTINE XYSHIFT(XSHIFT,YSHIFT,IX,IY,XSH,YSH,NSH,K)
cRCD ...Image Plate logical
        common/iplate/image,mar,moldyn
        logical image,mar,moldyn
c
        REAL XSHIFT,YSHIFT,XSH(1),YSH(1)
        INTEGER IX,IY,NSH(1)
        COMMON/IOO/IOUT
        COMMON/SW/ISWTCH(10),oneref,noref,tworef
C
      INCLUDE 'comuab.finc'
C
        CHARACTER*1 JUNK
        LOGICAL oneref,noref,tworef
        GOTO (1,2),K
1       I = (IX + 9600)/3200 + (((9600 - IY)/3200) - 1) * 4
cRCD ...Change this for 9cm IP
        if(mar)
     1  I = (IX + 14100)/4700 + (((14100 - IY)/4700) - 1) * 4
cTJG ...Change this for cornell IP
      if(moldyn)
     1  I = (IX + 19200)/6400 + (((16500 - IY)/5500) - 1) * 4
        XSH(I)=XSH(I)+XSHIFT
        YSH(I)=YSH(I)+YSHIFT
        NSH(I)=NSH(I)+1
        RETURN
2       DO 3 J=1,16
        IF(NSH(J).EQ.0) GOTO 3
        XSH(J)=XSH(J)/NSH(J)
        YSH(J)=YSH(J)/NSH(J)
3       CONTINUE
        WRITE(IOUT,1000)
        if (.not.batch)WRITE(6,1000)
        WRITE(IOUT,1001) (NSH(I),XSH(I),YSH(I),I=1,16)
        if (.not.batch)WRITE(6,1001)(NSH(I),XSH(I),YSH(I),I=1,16)
1000    FORMAT(//'     ANALYSIS OF C. OF G. SHIFTS FOR STRONG',
     1        '  SINGLETS (10 MICRON UNITS)'/
     1        '    NO.    DX    DY   NO.    DX    DY',
     1        '   NO.    DX   DY    NO.    DX   DY')
1001    FORMAT(4(I6,2F6.1)/)
        RETURN
        END
