C LAST UPDATE:
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C*******************************************
C**         Program 'LSCALE'              **  
C*******************************************
C Purpose:  Read one or more Laue data files, wavelengths
C           normalization, scaling and apply various corrections.
C
C                               
C Daresbury Laue Software Suite, May 1997
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

      INCLUDE 'implicit_none.finc'
      INCLUDE 'lscale_limits.finc'
C
C====== PARAMETERS:
C
 
C
C====== GLOBALS:
C

C
C====== FUNCTION TYPES:
C
      INTEGER KDMSTR
      INTEGER LENSTR
      INTEGER ICMPR
      INTEGER CCPNUN
      EXTERNAL CCPNUN
      LOGICAL CCPEXS
C
C====== LOCALS:
C
      LOGICAL EOF
      LOGICAL NONKDM
      LOGICAL CYCLE
      LOGICAL NORM1
      LOGICAL ABSCORGLOB1
      LOGICAL ABSCORLOC1
      LOGICAL REF_SC1
      LOGICAL REF_BFAC1
      LOGICAL REFERENCE
      LOGICAL MULTDECONV
      LOGICAL EXISTS
      LOGICAL READ_IN
      LOGICAL EXOUT
      LOGICAL LAMOPT
      LOGICAL CENTYP
      LOGICAL REFSETANA
      LOGICAL PLMERGE
      LOGICAL MTZ_FLAG
      LOGICAL REFSET 
      LOGICAL BATCH_FL
      LOGICAL PARA_IN
      LOGICAL EXTERN
      INTEGER IPLATE_SC1 
      INTEGER IPACK_SC1
      INTEGER IPACK_BFAC1
      INTEGER IERR, KERR, JERR, INDIRECT, IUN_PAR, IUN_OUT
      INTEGER NPACK
      INTEGER IPACK
      INTEGER I, J, IR
      INTEGER MAXE, MAXSTR
      INTEGER NCYC, KCYC
      INTEGER NSYMM
      INTEGER KFLAG, IFLAG
      INTEGER KDX, MINDX
      INTEGER ND(206)
      INTEGER IVAL(206)
      INTEGER NUM_INP
      INTEGER ISTAT
      INTEGER ITYP
      INTEGER IRFTYP
      INTEGER IREF
      INTEGER IEND
      INTEGER MTZ_IDX
      INTEGER KPACK(10)
      INTEGER IPACK_ID(10)
      INTEGER NSPOT
      INTEGER IFAIL
      INTEGER IUN_GE1
      INTEGER IUN_GE2
      INTEGER IUN_PAR_OUT
      INTEGER IUN_LOG
      INTEGER MLAUE(10), KSYM
      INTEGER IHKL(3), JHKL(3)   
      INTEGER NLAB
      INTEGER MODEL_FL 
      INTEGER IDXL(3)
      INTEGER IDATA(3)
      INTEGER ICS, KCS, IIC
      INTEGER LREC
      INTEGER INCHARM
      INTEGER NREFINE
      INTEGER NUMOUT(12), NUMMULT, NUMSIG, NUMSPAT, NUMOVL, NUMMEAS 
      INTEGER MTOK
      PARAMETER (MTOK=20)
      INTEGER IPOINT(6)
      INTEGER IH, IK, IL, IPLATE
      INTEGER MULT, MINHARM, MAXHARM 
      INTEGER ISPAT, IOVLD, IBAD, IMEAS
      INTEGER ICODE, ICLOS
      REAL FVAL(206)
      REAL CPU,ELAPS
      REAL DLAM
      REAL ALMBDA
      REAL ADATA(10)
      REAL XFD, YFD, ALAM
      REAL AI, SIGI
      REAL RESOL
      REAL REFSC
      REAL SIGCUT
      REAL CUTOFF
      REAL ALAMMAX, ALAMMIN
      REAL FMIN
      REAL TUNE(3)  
      CHARACTER*2000 LIN 
      CHARACTER*120 STR
      CHARACTER*120 MESSAGE
      CHARACTER*80 ERRSTR
      CHARACTER*80 BADTOK
      CHARACTER*250 VALSTR
      CHARACTER*250 PARNAME      
      CHARACTER*250 FILNAM, REFFILNAM
      CHARACTER*250 FILGE1
      CHARACTER*250 FILGE2
      CHARACTER*250 MTZ_FILE
      CHARACTER*3 FTYP_IN
      CHARACTER*30 PRGLAB(7)
      CHARACTER*1 CTYP(7)
      CHARACTER*30 PRGLAB_OUT(7)

      DATA PRGLAB/'H','K','L','FP','SIGFP','    ','    '/
      DATA CTYP/'H','H','H','F','Q',' ',' '/

C     CHARACTER*120 STR            !Message string
C     CHARACTER*80 ERRSTR          !Error string
C     CHARACTER*80 BADTOK          !Bad token string
      

C
C====== CODE:
C
      CPU = 0.0
      ELAPS = 0.0
      CALL CCPFYP
c      CALL CCPTIM (0, CPU, ELAPS)
C
C====== Initialization
C

      LIN = ' '
      STR = ' '
      MESSAGE = ' '
      ERRSTR = ' '
      BADTOK = ' '
      VALSTR = ' '
      FTYP_IN = ' '
      REFERENCE = .FALSE.
      REFSETANA  = .FALSE.
      MAXSTR = LEN(VALSTR)
      MAXE = LEN(ERRSTR)
      READ_IN =.FALSE.
      PLMERGE = .FALSE.
      MULTDECONV = .FALSE.
      MTZ_FLAG = .FALSE.
      REFSET = .FALSE.
      MODEL_FL = 0
      BATCH_FL = .FALSE.
      PARA_IN = .FALSE.
      NREFINE = 0
      FMIN = 0.0
      TUNE(1) = 0.0
      TUNE(2) = 0.0
      TUNE(3) = 0.0
C
C====== Set logical unit nos.
C
      IUN_GE1 = 10
      IUN_GE2 = 11
      IUN_PAR = 5
      IUN_LOG = 6
      IUN_OUT = CCPNUN ()
      INDIRECT = 0
      EOF = .TRUE.
      IFAIL = 0
      CALL CCPOPN(IUN_PAR,'DATA',5,1,I,IFAIL)
      CALL CCPOPN(IUN_LOG,'PRINTER',6,1,I,IFAIL)

C
C====== write header for log-file
C
      WRITE(IUN_LOG,1000)
C
C====== Set up  keyword parameters
C
      CALL LSM_SETLSP(KDX)
      CALL LSM_KEYSETUP(KDX)
C
C====== Set up  LIRL
C
      CALL LIRLF_INIT (1000, 1000, 0, 0, MINDX)
C
C====== Read in parameters file
C
      NONKDM = .FALSE.
      INDIRECT = 0
150   CALL KWD_READLINE (IUN_PAR, 10, INDIRECT, LIN, EOF, IERR)
      IF (EOF) GO TO 200
      IF (IERR.GT.0) THEN
         WRITE(IUN_LOG,3000) IERR
         WRITE(IUN_LOG,2000)
         STOP
      END IF
      CALL KWD_PARSEKDM (KDX, LIN, KFLAG, BADTOK, ERRSTR)
      IF (KFLAG.EQ.0.AND..NOT.PARA_IN) THEN
         GO TO 150
      ELSE IF (KFLAG.EQ.0.AND.PARA_IN) THEN 
         WRITE(IUN_LOG,3030) 
         WRITE(IUN_LOG,2000)
         STOP
      END IF

      IF (KFLAG.LT.0) THEN
         WRITE(IUN_LOG,3020)  LIN(1:LENSTR(LIN)), BADTOK, ERRSTR
         GO TO 150
      END IF
      IF (KFLAG.EQ.1.AND..NOT.PARA_IN) THEN
         CALL KWD_PARSESYMM (LIN, KFLAG, BADTOK, ERRSTR)
         IF (KFLAG.EQ.0) THEN
            CALL KSM_GET_NSYM (NSYMM, IFLAG)
            IF (IFLAG.EQ.0) GO TO 210
            CALL KSM_SYM_LIRL (MINDX, IERR)
            GO TO 150
         END IF
         IF (KFLAG.LT.0) THEN
            WRITE(IUN_LOG,3040) LIN(1:LENSTR(LIN)), BADTOK, ERRSTR
            STOP
         END IF
      ELSE IF (KFLAG.EQ.1.AND.PARA_IN) THEN
         CALL KWD_PARSESYMM (LIN, KFLAG, BADTOK, ERRSTR)
         IF (KFLAG.EQ.0) THEN
            WRITE(IUN_LOG,3050) 
            WRITE(IUN_LOG,2000) 
            STOP
         END IF
      END IF
      IF (KFLAG.EQ.1) THEN
         IF (INDEX(LIN,'REFINE').NE.0) THEN
            EXTERN = .FALSE.
            CALL CCPUPC(LIN)
            IF (INDEX(LIN,'EXTERNAL').NE.0) EXTERN = .TRUE.
            CALL LSCALE_GETREFINE (LIN, BATCH_FL, CYCLE, IPLATE_SC1,  
     +            IPACK_SC1, IPACK_BFAC1, NORM1,ABSCORGLOB1,  
     +            ABSCORLOC1, REF_SC1, REF_BFAC1, EXOUT,IUN_LOG) 
            NREFINE = NREFINE + 1
            PARA_IN = .TRUE.
            GO TO 10
         ELSE
            NONKDM = .TRUE.
            WRITE (IUN_LOG,3010) LIN
            GO TO 150
         END IF
      END IF
      GO TO 150
            
 10   CALL LSM_PARSETUP_LSP (KDX, IERR, ERRSTR)
      IF (IERR.NE.0) THEN
         WRITE(IUN_LOG,3210) ERRSTR
         WRITE(IUN_LOG,2000)
         STOP
      END IF

      STR = 'TITLE'
      CALL KDMF_GETVALSTR (KDX, KDMSTR(STR), LENSTR(STR),  
     +         1, 1, 70, KDMSTR(VALSTR), ISTAT,
     +         ITYP, KDMSTR(ERRSTR), MAXE, KERR)
      IF (KERR.NE.0) GOTO 810  
       
      WRITE(IUN_LOG,1010) VALSTR
      
      CALL KWD_WRITEKDM_SYMM(KDX, IUN_LOG, 2, 0, 1, IERR)

      CALL KSM_CENTRIC
C
C====== get intensities
C
      IF (.NOT.READ_IN) THEN

         STR = 'NUMIMAGES'
         CALL KDMF_GETVALUE (KDX, KDMSTR(STR),LENSTR(STR), 
     +            1, 1, 2, KDMSTR(VALSTR), FVAL, ND, IVAL, 
     +            NUM_INP, ISTAT, ITYP, KDMSTR(ERRSTR), 
     +            MAXE, KERR)  
         IF (KERR.NE.0) GOTO 810    
         NPACK =  IVAL(1)
         IF (NPACK.EQ.0) THEN
            WRITE(IUN_LOG,3220)
            WRITE(IUN_LOG,2000)
            STOP
         END IF 

         STR = 'FILETYP_INPUT'
         CALL KDMF_GETVALSTR (KDX, KDMSTR(STR), LENSTR(STR),  
     +            1, 1, 3, KDMSTR(VALSTR), ISTAT,
     +            ITYP, KDMSTR(ERRSTR), MAXE, KERR)
         IF (KERR.NE.0) GOTO 810 
         FTYP_IN = VALSTR
         IF (ISTAT.EQ.0) THEN
            WRITE (IUN_LOG,3230)        
         ELSE
            WRITE (IUN_LOG,3240) FTYP_IN
         END IF

         CALL CCPUPC(FTYP_IN)

         DO 50 IPACK = 1, NPACK
            STR = 'FILENAME_INPUT'
            CALL KDMF_GETVALSTR (KDX, KDMSTR(STR), LENSTR(STR),  
     +            IPACK, 1, MAXSTR, KDMSTR(VALSTR), ISTAT,
     +            ITYP, KDMSTR(ERRSTR), MAXE, KERR)
            IF (KERR.NE.0) GOTO 810  
            IF (ISTAT.EQ.0) THEN
               WRITE (IUN_LOG,3250)
               WRITE (IUN_LOG,2000)
               STOP
            END IF
            FILNAM = VALSTR 

            IF (FTYP_IN.EQ.'MTZ') THEN
               CALL MTZINI
               MTZ_FLAG = .TRUE.
               MTZ_IDX = 1
               CALL FILEXT(FILNAM,'mtz',MTZ_FILE,IEND)
               EXISTS = CCPEXS (MTZ_FILE)
               IF (.NOT.EXISTS) THEN
                  WRITE (IUN_LOG,3260)
                  WRITE (IUN_LOG,2000)
                  STOP
               END IF
               CALL LROPEN (MTZ_IDX, MTZ_FILE, 0, JERR) 
               IF (JERR.EQ.-1) THEN 
                  WRITE (IUN_LOG,3260)
                  WRITE (IUN_LOG,2000)
                  STOP
               END IF
               IPACK_ID(1) = -1
               KPACK(1) = IPACK
               CALL LFN_MTZLIRL (MINDX, MTZ_IDX, 1, IPACK_ID,
     +                        KPACK, 0, NSPOT, IERR)
               IF (IERR.NE.0) THEN
                  WRITE (IUN_LOG,3270) IERR
                  WRITE (IUN_LOG,2000)
                  STOP
               END IF
               WRITE (IUN_LOG,3280) IPACK, NSPOT
               CALL LRCLOS (MTZ_IDX)
            ELSE
               CALL FILEXT (FILNAM, 'xxx', FILGE1, IEND)
               FILGE1 = FILNAM(1:IEND)//'.ge1'
               FILGE2 = FILNAM(1:IEND)//'.ge2'
               IF (.NOT.CCPEXS(FILGE1)) THEN
                  WRITE (IUN_LOG,3290)
                  WRITE (IUN_LOG,2000)
                  STOP
               END IF
               IF (.NOT.CCPEXS(FILGE2)) THEN
                  WRITE (IUN_LOG,3300)
                  WRITE (IUN_LOG,2000)
                  STOP
               END IF
               IFAIL = 0
               CALL CCPDPN(-IUN_GE1,FILGE1,'READONLY','DU',19,IFAIL)
               IFAIL = 0
               CALL CCPDPN(-IUN_GE2,FILGE2,'READONLY','DU',2,IFAIL)
               CALL LFN_GELIRL (MINDX, IUN_GE1, IUN_GE2, 0, IPACK, 
     +                       NSPOT, IERR)
               IF (IERR.NE.0) THEN
                  WRITE (IUN_LOG,3310) IERR
                  WRITE (IUN_LOG,2000)
                  STOP
               END IF
               WRITE (IUN_LOG,3280) IPACK, NSPOT
               CLOSE (IUN_GE1)
               CLOSE (IUN_GE2)
            END IF
 50      CONTINUE

         CALL LIRLF_NUMREFS (MINDX, NSPOT)

C
C====== write input data details to log-file
C
         STR = 'SIGREJ_EX'
         CALL KDMF_GETVALUE (KDX, KDMSTR(STR),LENSTR(STR), 
     +              1, 1, 2, KDMSTR(VALSTR), FVAL, ND, IVAL, 
     +              NUM_INP, ISTAT, ITYP, KDMSTR(ERRSTR), 
     +              MAXE, KERR)  
         IF (KERR.NE.0) GOTO 810   
         SIGCUT = FVAL(1)

         NUMMULT = 0
         NUMSIG = 0
         NUMSPAT = 0
         NUMOVL = 0
         NUMMEAS = 0
         ALAMMAX = 0.0
         ALAMMIN = 100000.0
         DO 140 IR = 1, NSPOT
            CALL LIRLF_GETREF (MINDX, IR, IH, IK, IL, IPACK, IPLATE, 
     +                    KSYM, XFD, YFD, ALAM,
     +                    MULT, MINHARM, MAXHARM, INCHARM, AI, SIGI,
     +                    ISPAT, ICLOS, IMEAS, IBAD, IOVLD, 
     +                    ICODE, IERR)
            IF(MULT.NE.1) NUMMULT = NUMMULT + 1
            IF(ISPAT.EQ.1) NUMSPAT = NUMSPAT + 1
            IF(IOVLD.EQ.1) NUMOVL = NUMOVL +1
            IF(AI.GT.(SIGCUT*SIGI)) NUMSIG = NUMSIG + 1
            IF(IMEAS.EQ.1) NUMMEAS = NUMMEAS + 1
            IF(ALAM.LT.ALAMMIN) ALAMMIN = ALAM
            IF(ALAM.GT.ALAMMAX) ALAMMAX = ALAM
 140     CONTINUE

         WRITE (IUN_LOG,1020) NSPOT
         WRITE (IUN_LOG,1030) NUMMULT, (NUMMULT*100.0)/REAL(NSPOT)
         WRITE (IUN_LOG,1040) NUMSPAT, (NUMSPAT*100.0)/REAL(NSPOT)
         WRITE (IUN_LOG,1050) NUMOVL, (NUMOVL*100.0)/REAL(NSPOT)
         WRITE (IUN_LOG,1060) SIGCUT, NUMSIG, 
     +                               (NUMSIG*100.0)/REAL(NSPOT)
         WRITE (IUN_LOG,1070) NUMMEAS, (NUMMEAS*100.0)/REAL(NSPOT)
         WRITE (IUN_LOG,1080) ALAMMIN, ALAMMAX
C
C====== Set symmetry
C
         CALL KSM_ASUSET (MLAUE)

         DO 60 IR = 1, NSPOT
            CALL LIRLF_GETHKL(MINDX, IR, IHKL(1), IHKL(2), IHKL(3),
     +                     KSYM, IERR)
            CALL ASUPUT (IHKL, JHKL, KSYM)
            CALL LIRLF_PUTKSYM (MINDX, IR, KSYM, IERR)
 60      CONTINUE

C
C====== get reference intensities
C 
         STR = 'REFFILENAME'
         CALL KDMF_GETVALSTR (KDX, KDMSTR(STR), LENSTR(STR),  
     +              1, 1, MAXSTR, KDMSTR(VALSTR), ISTAT,
     +              ITYP, KDMSTR(ERRSTR), MAXE, KERR)
         IF (KERR.NE.0) GOTO 810  
         REFFILNAM = VALSTR 
         IF (REF_SC1.AND.REFFILNAM.EQ.' ') THEN
            WRITE (IUN_LOG,3330)
            WRITE (IUN_LOG,2000)
            STOP
         END IF
         IF (REF_SC1) THEN
            REFERENCE = .TRUE.
         END IF    

         IF (REFFILNAM.NE.' ') THEN

            REFSET = .TRUE.

            IF(.NOT.MTZ_FLAG) THEN
               CALL MTZINI
               MTZ_FLAG = .TRUE.
               MTZ_IDX = 1
            ELSE
               MTZ_IDX = 2
            END IF

            STR = 'REFSET_RESCALE'	
            CALL KDMF_GETVALUE (KDX, KDMSTR(STR),LENSTR(STR),  
     +                 1, 1, 2, KDMSTR(VALSTR), FVAL, ND, IVAL, 
     +                 NUM_INP, ISTAT, ITYP, KDMSTR(ERRSTR), 
     +                 MAXE, KERR) 
            IF (KERR.NE.0) GOTO 810    
            REFSC = FVAL(1)

            LAMOPT = .FALSE.
            STR = 'REFMTZ_DLAM'	
            CALL KDMF_GETVALUE (KDX, KDMSTR(STR),LENSTR(STR),  
     +                 1, 1, 2, KDMSTR(VALSTR), FVAL, ND, IVAL, 
     +                 NUM_INP, ISTAT, ITYP, KDMSTR(ERRSTR), 
     +                 MAXE, KERR) 
            IF (KERR.NE.0) GOTO 810    
            DLAM = FVAL(1)
 
            CENTYP = .FALSE.
            STR = 'REFMTZ_FILETYP'
            CALL KDMF_GETVALSTR (KDX, KDMSTR(STR), LENSTR(STR),  
     +                 1, 1, 15, KDMSTR(VALSTR), ISTAT,
     +                 ITYP, KDMSTR(ERRSTR), MAXE, KERR)
            IF (KERR.NE.0) GOTO 810 
            CALL CCPUPC(VALSTR)
            IF (INDEX(VALSTR,'LAMBDA').NE.0) LAMOPT = .TRUE.
            IF (INDEX(VALSTR,'SIGN').NE.0) CENTYP = .TRUE.
            IF (LAMOPT) WRITE(IUN_LOG,6600) DLAM
            IF (CENTYP) WRITE(IUN_LOG,6620) 
 
            STR = 'REFMTZ_FILEASSIGN'
            CALL KDMF_GETVALSTR (KDX, KDMSTR(STR), LENSTR(STR),  
     +                 1, 1, 200, KDMSTR(VALSTR), ISTAT,
     +                 ITYP, KDMSTR(ERRSTR), MAXE, KERR)
            IF (KERR.NE.0) GOTO 810 
            LIN = VALSTR
            CALL CCPUPC(LIN)
            NLAB = 5
            IF (LAMOPT) THEN
               NLAB = 6
               PRGLAB(6) = 'LAM'
               CTYP(6) = 'R'
            END IF
            IF (CENTYP) THEN
               NLAB = NLAB + 1
               PRGLAB(NLAB) = 'SIGN'
               CTYP(NLAB) = 'I'
            END IF

            CALL MTZ_LABL_ASSIGN (NLAB, PRGLAB, LIN, PRGLAB_OUT)
            DO 160 I = 1, NLAB
               PRGLAB(I) = PRGLAB_OUT(I)
 160        CONTINUE

            DO 75 I = 1 , NLAB
               IPOINT(I) = -1
 75         CONTINUE

            CALL FILEXT(REFFILNAM,'mtz',MTZ_FILE,IEND)
            EXISTS = CCPEXS (MTZ_FILE)
            IF (.NOT.EXISTS) THEN
               WRITE (IUN_LOG,3340)
               WRITE (IUN_LOG,2000)
               STOP
            END IF

            CALL LROPEN (MTZ_IDX, MTZ_FILE, 0, JERR) 
            IF (JERR.EQ.-1) THEN 
               WRITE (IUN_LOG,3340)
               WRITE (IUN_LOG,2000)
               STOP
            END IF
            CALL LRASSN (MTZ_IDX,PRGLAB,NLAB,IPOINT,CTYP)

            IF (LAMOPT) THEN
               CALL LIRLF_SORT  (MINDX, 5, IERR)  
               IF(IERR.LT.0) WRITE (IUN_LOG,3350) IERR
            END IF
            CALL LIRLF_SORT  (MINDX, 10, IERR)    
            IF(IERR.LT.0) WRITE (IUN_LOG,3350) IERR

            IREF = 1
            CALL LIRLF_GETREF (MINDX, IREF, IH, IK, IL, IPACK, IPLATE, 
     +                    KSYM, XFD, YFD, ALAM,
     +                    MULT, MINHARM, MAXHARM, INCHARM, AI, SIGI,
     +                    ISPAT, ICLOS, IMEAS, IBAD, IOVLD, 
     +                    ICODE, IERR)
            IF (IERR.LT.0) WRITE (IUN_LOG,3360) IERR
            CALL LIRLF_HKLUNQ  (MINDX, IREF, IH, IK, IL, IERR)    
            IF(IERR.LT.0) WRITE (IUN_LOG,3370) IERR
            
            IDXL(1) = IH
            IDXL(2) = IK
            IDXL(3) = IL
            ICS = 0
            IF (CENTYP) THEN
               ICS = 1
               IF (MOD(KSYM,2).EQ.0) ICS = -1
               CALL CENTR(IDXL,IIC)
               IF (IIC.EQ.1) ICS = 0
            END IF
            CALL LRREFF(MTZ_IDX,RESOL,ADATA,EOF)
            IF (EOF) GO TO 100
            IDATA(1) = NINT(ADATA(1))
            IDATA(2) = NINT(ADATA(2))
            IDATA(3) = NINT(ADATA(3))
            ALMBDA = 0.0
            KCS = 0
            IF (LAMOPT) THEN
               ALMBDA = ADATA(6)
               IF (CENTYP) KCS = NINT(ADATA(7))
            ELSE
               IF (CENTYP) KCS = NINT(ADATA(6))
            END IF
 80         IF (ICMPR(IDXL,IDATA,ALMBDA,ALAM,KCS,ICS,LAMOPT,DLAM)
     +      .LT.0) THEN 
            ELSE IF(ICMPR(IDXL,IDATA,ALMBDA,ALAM,KCS,ICS,LAMOPT,DLAM)
     +           .EQ.0) THEN
C
C====== Matching reflection found, store reference intensity
C

            CALL LIRLF_SET_REFINT(MINDX,IREF,ADATA(4)**2/REFSC,
     +                            2*ADATA(4)*ADATA(5)/REFSC,IERR)
               IF (IERR.LT.0) WRITE (IUN_LOG,3380) IERR
            
            ELSE
C
C====== No match, Laue>Standard, get next standard
C
 85            CALL LRREFF(MTZ_IDX,RESOL,ADATA,EOF)
               IF (EOF) GO TO 100
C
C====== Exclude reference intensities<cutoff*refsigma
C
               IF (ADATA(4).LT.SIGCUT*ADATA(5)) GO TO 85

               IDATA(1) = NINT(ADATA(1))
               IDATA(2) = NINT(ADATA(2))
               IDATA(3) = NINT(ADATA(3))
               ALMBDA = 0.0
               KCS = 0
               IF (LAMOPT) THEN
                  ALMBDA = ADATA(6)
                  IF (CENTYP) KCS = NINT(ADATA(7))
               ELSE
                  IF (CENTYP) KCS = NINT(ADATA(6))
               END IF
               GO TO 80
            END IF
C
C====== Match or no match & Laue<Standard, get next Laue
C
 90         IREF = IREF + 1
            IF (IREF.LE.NSPOT) THEN
               CALL LIRLF_GETREF  (MINDX, IREF, IH, IK, IL, 
     +                    IPACK, IPLATE, KSYM, XFD, YFD, ALAM,
     +                    MULT, MINHARM, MAXHARM, INCHARM, AI, SIGI,
     +                    ISPAT, ICLOS, IMEAS, IBAD, IOVLD, 
     +                    ICODE, IERR)
               IF (IERR.LT.0) WRITE (IUN_LOG,3360) IERR
               CALL LIRLF_HKLUNQ  (MINDX, IREF, IH, IK, IL, IERR)        
               IF(IERR.LT.0) WRITE (IUN_LOG,3370) IERR
               IDXL(1) = IH
               IDXL(2) = IK
               IDXL(3) = IL
               ICS = 0
               IF (CENTYP) THEN
                  ICS = 1
                  IF (MOD(KSYM,2).EQ.0) ICS = -1
                  CALL CENTR(IDXL,IIC)
                  IF (IIC.EQ.1) ICS = 0
               ENDIF
               GO TO 80
            END IF 
 100        CALL LRCLOS (MTZ_IDX)
         END IF   
         READ_IN = .TRUE.
      END IF   

C====== simulated absorption data input for testing ONLY

      MODEL_FL = 0
      IF (MODEL_FL.NE.0) CALL APPLY_MODEL(KDX,MINDX,NSPOT,MODEL_FL)

C
C====== read in lsm-parameters
C
      CALL LSM_KDMCOPY(1, IERR, ERRSTR)
      IF (IERR.NE.0) WRITE (IUN_LOG,3390) ERRSTR

C
C====== start refinement
C
      WRITE(IUN_LOG,3060) NREFINE
      IF (IPLATE_SC1.GE.0) WRITE(IUN_LOG,3070)
      IF (IPACK_SC1.GE.0) WRITE(IUN_LOG,3080)
      IF (IPACK_BFAC1.GE.0) WRITE(IUN_LOG,3090)
      IF (NORM1) WRITE(IUN_LOG,3100)
      IF (ABSCORGLOB1) WRITE(IUN_LOG,3110)
      IF (ABSCORLOC1) WRITE(IUN_LOG,3120)
      IF (REF_SC1) WRITE(IUN_LOG,3130)
      IF (REF_BFAC1) WRITE(IUN_LOG,3140)
      IF (CYCLE) THEN
         WRITE(IUN_LOG,3160)
      ELSE
         WRITE(IUN_LOG,3150)
      END IF
      IF (EXTERN) THEN
         WRITE (IUN_LOG,3170)
      ELSE
         WRITE(IUN_LOG,3180)
      END IF
      IF (EXOUT) THEN
         WRITE(IUN_LOG,3190)
      ELSE
         WRITE(IUN_LOG,3200)
      END IF

      STR = 'NCYCLE'
      CALL KDMF_GETVALUE (KDX, KDMSTR(STR),LENSTR(STR), 1, 1, 
     +                    2, KDMSTR(VALSTR), FVAL, ND, IVAL, 
     +                    NUM_INP, ISTAT, ITYP, KDMSTR(ERRSTR), 
     +                    MAXE, KERR)  
      IF (KERR.NE.0) GOTO 810    
      NCYC = IVAL(1)

      CALL LSM_ABSOPT_LSP 

      CALL LSM_OMIT_LSP (IERR, ERRSTR)
      IF (IERR.NE.0) WRITE (IUN_LOG,3400) ERRSTR
C
C====== Get flags for reflection selection
C
      CALL LSM_SELECT_SCREFS_LSP (IERR, REFERENCE, ERRSTR)
      IF (IERR.NE.0) WRITE (IUN_LOG,3410) ERRSTR
      
C
C====== Get refinement flags
C      
      CALL LSC_ANALYSES(MINDX,REFERENCE,0,0,.FALSE.,0.0)

      CALL LSM_SELECT_PKPL (0,0) 

      STR = 'CUTOFF'
      CALL KDMF_GETVALUE (KDX, KDMSTR(STR),LENSTR(STR), 
     +           1, 1, 2, KDMSTR(VALSTR), FVAL, ND, IVAL, 
     +           NUM_INP, ISTAT, ITYP, KDMSTR(ERRSTR), 
     +           MAXE, KERR)  
      IF (KERR.NE.0) GOTO 810   
      CUTOFF = FVAL(1)

C====== IRFTYP SET TO USE LSQMQL LEAST SQUARE ROUTINE IN REFINEMENT

      IRFTYP = 2
      IF (IRFTYP.EQ.2) THEN
         TUNE(1) = 0.001
         TUNE(2) = 0.5E-5   
      ELSE
         TUNE(1) = 0.001
         TUNE(2) = 0.5E-4  
         TUNE(3) = 0.7
      END IF

      KCYC = 0
      IF (EXOUT) KCYC = 1
      IF (.NOT.CYCLE) THEN
         NCYC = 1
         CALL LSC_RFACTS_LSP(MINDX, IUN_LOG, .FALSE., IERR)  
         IF (IERR.NE.0) WRITE (IUN_LOG,3420)
         DO 20 I = 1, NCYC + KCYC
            CALL LSM_SET_RFLAGS (IPLATE_SC1, IPACK_SC1,
     +         IPACK_BFAC1, NORM1, ABSCORGLOB1, ABSCORLOC1, 
     +         REF_SC1, REF_BFAC1)
            CALL LSM_REFINE (MINDX, REFERENCE, IRFTYP, TUNE, FMIN, 
     +                       IERR, MESSAGE) 
            IF(IERR.LT.0) THEN
               WRITE (IUN_LOG,3430) MESSAGE
            ELSE IF (IERR.GT.0) THEN
               WRITE (IUN_LOG,3440) IERR
               WRITE (IUN_LOG,2000)
               STOP
            END IF
            CALL LSM_KDMCOPY(2, IERR, ERRSTR)
            IF (IERR.NE.0) WRITE (IUN_LOG,3390) ERRSTR
            IF (EXOUT.AND.I.EQ.NCYC) THEN
               CALL LSC_RFACTS_LSP(MINDX, IUN_LOG, .TRUE., IERR)  
               IF (IERR.NE.0) WRITE (IUN_LOG,3420)
               WRITE (IUN_LOG,3450) FMIN
               CALL LSC_ANALYSES (MINDX, REFERENCE, 0, 0, 
     +                            EXOUT, CUTOFF)
            END IF
 20      CONTINUE   
      ELSE 
         DO 30 I = 1, NCYC + KCYC
            CALL LSM_SET_RFLAGS (IPLATE_SC1, IPACK_SC1,
     +         IPACK_BFAC1, NORM1, ABSCORGLOB1, ABSCORLOC1, 
     +         REF_SC1, REF_BFAC1)
            CALL LSC_RFACTS_LSP(MINDX, IUN_LOG, .FALSE., IERR)  
            IF (IERR.NE.0) WRITE (IUN_LOG,3420)
            WRITE (IUN_LOG,3450) FMIN

            IF (IPLATE_SC1.NE.-1) THEN
               CALL LSM_SET_RFLAGS (IPLATE_SC1, -1,
     +                      -1, .FALSE., .FALSE., .FALSE., 
     +                      .FALSE., .FALSE.)
               CALL LSM_REFINE (MINDX, REFERENCE, IRFTYP, 
     +                       TUNE, FMIN, IERR, MESSAGE) 
               IF(IERR.LT.0) THEN
                  WRITE (IUN_LOG,3430) MESSAGE
               ELSE IF (IERR.GT.0) THEN
                  WRITE (IUN_LOG,3440) IERR
                  WRITE (IUN_LOG,2000)
                  STOP
               END IF
               CALL LSM_KDMCOPY(2, IERR, ERRSTR)
               IF (IERR.NE.0) WRITE (IUN_LOG,3390) ERRSTR
            END IF

            IF (IPACK_SC1.NE.-1) THEN
               CALL LSM_SET_RFLAGS ( -1, IPACK_SC1,
     +                       -1, .FALSE., .FALSE., .FALSE., 
     +                       .FALSE., .FALSE.)
               CALL LSM_REFINE (MINDX, REFERENCE, IRFTYP, 
     +                       TUNE, FMIN, IERR, MESSAGE) 
               IF(IERR.LT.0) THEN
                  WRITE (IUN_LOG,3430) MESSAGE
               ELSE IF (IERR.GT.0) THEN
                  WRITE (IUN_LOG,3440) IERR
                  WRITE (IUN_LOG,2000)
                  STOP
               END IF
               CALL LSM_KDMCOPY(2, IERR, ERRSTR)
               IF (IERR.NE.0) WRITE (IUN_LOG,3390) ERRSTR
            END IF

            IF (IPACK_BFAC1.NE.-1) THEN
               CALL LSM_SET_RFLAGS ( -1, -1,
     +                    IPACK_BFAC1, .FALSE., .FALSE., .FALSE., 
     +                    .FALSE., .FALSE.)
               CALL LSM_REFINE (MINDX, REFERENCE, IRFTYP, 
     +                       TUNE, FMIN, IERR, MESSAGE) 
               IF(IERR.LT.0) THEN
                  WRITE (IUN_LOG,3430) MESSAGE
               ELSE IF (IERR.GT.0) THEN
                  WRITE (IUN_LOG,3440) IERR
                  WRITE (IUN_LOG,2000)
                  STOP
               END IF
               CALL LSM_KDMCOPY(2, IERR, ERRSTR)
               IF (IERR.NE.0) WRITE (IUN_LOG,3390) ERRSTR
            END IF
         
            IF (NORM1) THEN
               CALL LSM_SET_RFLAGS ( -1, -1,
     +                    -1, .TRUE., .FALSE., .FALSE., 
     +                    .FALSE., .FALSE.)
               CALL LSM_REFINE (MINDX, REFERENCE, IRFTYP, 
     +                       TUNE, FMIN, IERR, MESSAGE) 
               IF(IERR.LT.0) THEN
                  WRITE (IUN_LOG,3430) MESSAGE
               ELSE IF (IERR.GT.0) THEN
                  WRITE (IUN_LOG,3440) IERR
                  WRITE (IUN_LOG,2000)
                  STOP
               END IF
               CALL LSM_KDMCOPY(2, IERR, ERRSTR)
               IF (IERR.NE.0) WRITE (IUN_LOG,3390) ERRSTR
            END IF

            IF ( REF_SC1) THEN
               CALL LSM_SET_RFLAGS ( -1, -1,
     +                    -1, .FALSE., .FALSE., .FALSE., 
     +                    .TRUE., .FALSE.)
               CALL LSM_REFINE (MINDX, REFERENCE, IRFTYP, 
     +                       TUNE, FMIN, IERR, MESSAGE) 
               IF(IERR.LT.0) THEN
                  WRITE (IUN_LOG,3430) MESSAGE
               ELSE IF (IERR.GT.0) THEN
                  WRITE (IUN_LOG,3440) IERR
                  WRITE (IUN_LOG,2000)
                  STOP
               END IF
               CALL LSM_KDMCOPY(2, IERR, ERRSTR)
               IF (IERR.NE.0) WRITE (IUN_LOG,3390) ERRSTR
            END IF

            IF ( REF_BFAC1) THEN
               CALL LSM_SET_RFLAGS ( -1, -1,
     +                    -1, .FALSE., .FALSE., .FALSE., 
     +                    .FALSE., .TRUE.)
               CALL LSM_REFINE (MINDX, REFERENCE, IRFTYP, 
     +                       TUNE, FMIN, IERR, MESSAGE) 
               IF(IERR.LT.0) THEN
                  WRITE (IUN_LOG,3430) MESSAGE
               ELSE IF (IERR.GT.0) THEN
                  WRITE (IUN_LOG,3440) IERR
                  WRITE (IUN_LOG,2000)
                  STOP
               END IF
               CALL LSM_KDMCOPY(2, IERR, ERRSTR)
               IF (IERR.NE.0) WRITE (IUN_LOG,3390) ERRSTR
            END IF

            IF (ABSCORGLOB1) THEN
               CALL LSM_SET_RFLAGS ( -1, -1,
     +                    -1, .FALSE., .TRUE., .FALSE., 
     +                    .FALSE., .FALSE.)
               CALL LSM_REFINE (MINDX, REFERENCE, IRFTYP, 
     +                       TUNE, FMIN, IERR, MESSAGE) 
               IF(IERR.LT.0) THEN
                  WRITE (IUN_LOG,3430) MESSAGE
               ELSE IF (IERR.GT.0) THEN
                  WRITE (IUN_LOG,3440) IERR
                  WRITE (IUN_LOG,2000)
                  STOP
               END IF  
               CALL LSM_KDMCOPY(2, IERR, ERRSTR)
               IF (IERR.NE.0) WRITE (IUN_LOG,3390) ERRSTR
            END IF

            IF (ABSCORLOC1) THEN
               CALL LSM_SET_RFLAGS ( -1, -1,
     +                    -1, .FALSE., .FALSE., .TRUE., 
     +                  .FALSE., .FALSE.)
               DO 70 J = 1, NPACK
                  CALL LSM_ABSCOR_RFN (MINDX, IPACK, REFERENCE, 
     +                IRFTYP, TUNE, FMIN, IERR, MESSAGE)
                  CALL LSM_KDMCOPY(2, IERR, ERRSTR)
                  IF (IERR.NE.0) WRITE (IUN_LOG,3390) ERRSTR
 70            CONTINUE
            END IF

            IF (EXOUT.AND.I.EQ.NCYC) THEN
               CALL LSC_RFACTS_LSP(MINDX, IUN_LOG, .TRUE., IERR)  
               IF (IERR.NE.0) WRITE (IUN_LOG,3420)
               WRITE (IUN_LOG,3450) FMIN
               CALL LSC_ANALYSES(MINDX, REFERENCE,  
     +                          0, 0, EXOUT, CUTOFF)
            END IF
 30      CONTINUE
      END IF

      CALL LSM_KDMCOPY(2, IERR, ERRSTR)
      IF (IERR.NE.0) WRITE (IUN_LOG,3390) ERRSTR

      CALL LSC_RFACTS_LSP(MINDX, IUN_LOG, .TRUE., IERR)  
      IF (IERR.NE.0) WRITE (IUN_LOG,3420)
      WRITE (IUN_LOG,3450) FMIN

      GO TO 150

C
C ====== End of file 
C

 200  IF (.NOT.BATCH_FL) CALL LSC_GRAPHSETUP (IERR, MESSAGE)
      IF (IERR.NE.0) THEN
         WRITE(IUN_LOG,3470) MESSAGE
         WRITE(IUN_LOG,2000)
         STOP
      END IF
C
C====== Multiples Deconvolution
C      
      STR = 'MULTIPLES'
      CALL KDMF_GETVALUE (KDX, KDMSTR(STR),LENSTR(STR), 
     +           1, 1, 2, KDMSTR(VALSTR), FVAL, ND, IVAL, 
     +           NUM_INP, ISTAT, ITYP, KDMSTR(ERRSTR), 
     +           MAXE, KERR)  
      IF (KERR.NE.0) GOTO 810   
      IF(IVAL(1).EQ.1) MULTDECONV = .TRUE.
      IF(REFSET.AND..NOT.EXTERN) THEN
         CALL LSC_SCALESTAT_OUT(MINDX, EXOUT, CUTOFF, IRFTYP, 
     +                      TUNE, IUN_LOG)
      END IF

C====== Menues

      IF(.NOT.REFERENCE.AND.REFFILNAM.EQ.' '.AND.
     +   .NOT.(ABSCORGLOB1.OR.ABSCORLOC1)) THEN
         IF (MULTDECONV) THEN
            CALL LSM_MULTIPLES_DECONV (MINDX, TUNE, 
     +        IRFTYP, NUMOUT, IERR, MESSAGE)
            IF (IERR.NE.0) THEN
               WRITE (IUN_LOG,3460) MESSAGE
               WRITE (IUN_LOG,2000)
               STOP
            END IF
            CALL LSC_DECONV_LOGOUTPUT(IUN_LOG, NUMOUT)
         END IF
         IF (.NOT.BATCH_FL) 
     +        CALL LSC_MENU1(MINDX, EXOUT, CUTOFF)
         GO TO 300

      ELSE IF (.NOT.REFERENCE.AND.REFFILNAM.EQ.' '.AND.
     +   (ABSCORGLOB1.OR.ABSCORLOC1)) THEN
         IF (MULTDECONV) THEN
            CALL LSM_MULTIPLES_DECONV (MINDX, TUNE, 
     +        IRFTYP, NUMOUT, IERR, MESSAGE)
            IF (IERR.NE.0) THEN
               WRITE (IUN_LOG,3460) MESSAGE
               WRITE (IUN_LOG,2000)
               STOP
            END IF
            CALL LSC_DECONV_LOGOUTPUT(IUN_LOG, NUMOUT)
         END IF
         IF (.NOT.BATCH_FL) 
     +        CALL LSC_MENU1ABS(MINDX, EXOUT, CUTOFF)
         GO TO 300

      ELSE IF(REFERENCE.AND.REFFILNAM.NE.' '.AND.
     +   .NOT.(ABSCORGLOB1.OR.ABSCORLOC1)) THEN 
         IF (MULTDECONV) THEN
            CALL LSM_MULTIPLES_DECONV (MINDX,TUNE, IRFTYP, 
     +                                NUMOUT, IERR, MESSAGE)
            IF (IERR.NE.0) THEN
               WRITE (IUN_LOG,3460) MESSAGE
               WRITE (IUN_LOG,2000)
               STOP
            END IF
            CALL LSC_DECONV_LOGOUTPUT(IUN_LOG, NUMOUT)
            CALL READ_REFINT_MULT (MINDX, KDX, NSPOT, SIGCUT, REFSC, 
     +                             REFFILNAM, IUN_LOG)
            CALL LSC_MULT_ANALOG(MINDX, IUN_LOG) 
         END IF 
         IF (.NOT.BATCH_FL) THEN
            CALL LSC_MENU2(MINDX, EXOUT, CUTOFF, MULTDECONV, 
     +                     IUN_LOG)
         END IF
         GO TO 300

      ELSE IF(REFERENCE.AND.REFFILNAM.NE.' '.AND.
     +   (ABSCORGLOB1.OR.ABSCORLOC1)) THEN 
         IF (MULTDECONV) THEN
            CALL LSM_MULTIPLES_DECONV (MINDX,TUNE, IRFTYP,  
     +                                NUMOUT, IERR, MESSAGE)
            IF (IERR.NE.0) THEN
               WRITE (IUN_LOG,3460) MESSAGE
               WRITE (IUN_LOG,2000)
               STOP
            END IF
            CALL LSC_DECONV_LOGOUTPUT(IUN_LOG, NUMOUT)
            CALL READ_REFINT_MULT (MINDX, KDX, NSPOT, SIGCUT, REFSC,
     +                             REFFILNAM, IUN_LOG)
            CALL LSC_MULT_ANALOG(MINDX, IUN_LOG) 
         END IF
         IF (.NOT.BATCH_FL) THEN
            CALL LSC_MENU2ABS(MINDX, EXOUT, CUTOFF, MULTDECONV, 
     +                        IUN_LOG)
         END IF
         GO TO 300
         
      ELSE IF(.NOT.REFERENCE.AND.REFFILNAM.NE.' '.AND.
     +   .NOT.(ABSCORGLOB1.OR.ABSCORLOC1)) THEN 
         IF (MULTDECONV) THEN
            CALL LSM_MULTIPLES_DECONV (MINDX,TUNE, IRFTYP,  
     +                                NUMOUT, IERR, MESSAGE)
            IF (IERR.NE.0) THEN
               WRITE (IUN_LOG,3460) MESSAGE
               WRITE (IUN_LOG,2000)
               STOP
            END IF
            CALL LSC_DECONV_LOGOUTPUT(IUN_LOG, NUMOUT)
            CALL READ_REFINT_MULT (MINDX, KDX, NSPOT,SIGCUT,REFSC,
     +                             REFFILNAM, IUN_LOG)
            CALL LSC_MULT_ANALOG(MINDX, IUN_LOG) 
         END IF
         IF (.NOT.BATCH_FL) THEN
            CALL LSC_MENU3 (MINDX, EXOUT, CUTOFF, IRFTYP, 
     +                   TUNE, MULTDECONV, IUN_LOG)
         END IF
         GO TO 300

      ELSE IF(.NOT.REFERENCE.AND.REFFILNAM.NE.' '.AND.
     +   (ABSCORGLOB1.OR.ABSCORLOC1)) THEN 
         IF (MULTDECONV) THEN
            CALL LSM_MULTIPLES_DECONV (MINDX,TUNE, IRFTYP,  
     +                                NUMOUT, IERR, MESSAGE)
            IF (IERR.NE.0) THEN
               WRITE (IUN_LOG,3460) MESSAGE
               WRITE (IUN_LOG,2000)
               STOP
            END IF
            CALL LSC_DECONV_LOGOUTPUT(IUN_LOG, NUMOUT)
            CALL READ_REFINT_MULT (MINDX, KDX, NSPOT, SIGCUT, REFSC,
     +                             REFFILNAM, IUN_LOG)
            CALL LSC_MULT_ANALOG(MINDX, IUN_LOG) 
         END IF
         IF (.NOT.BATCH_FL) THEN
            CALL LSC_MENU3ABS (MINDX, EXOUT, CUTOFF, IRFTYP, 
     +                      TUNE, MULTDECONV, IUN_LOG)
         END IF
         GO TO 300
      END IF

C
C ====== Output intensities into mtz.- and/or shelx-files
C

 300  CALL LSC_FILE_OUTPUT (KDX, MTZ_IDX+1, MINDX,
     +     IUN_OUT, IUN_LOG, REFSET)


C
C ====== Output of parameters into log-file and seperate file
C
      WRITE(IUN_LOG,2020)
      CALL KWD_WRITEKDM_SYMM(KDX, IUN_LOG, 2, 0, 8, IERR)

      STR = 'FILENAME_OUTPUT'
      CALL KDMF_GETVALSTR (KDX, KDMSTR(STR), LENSTR(STR),  
     +         1, 1, 50, KDMSTR(VALSTR), ISTAT,
     +         ITYP, KDMSTR(ERRSTR), MAXE, KERR)
      IF (KERR.NE.0) GOTO 810  
      PARNAME = VALSTR 
      IF (INDEX(PARNAME,'.').NE.0) THEN
         PARNAME = PARNAME(1:(INDEX(PARNAME,'.'))-1)
      END IF
      CALL STR_ADDS (PARNAME,'.par',0)
      IUN_PAR_OUT = CCPNUN ()
      CALL CCPDPN(IUN_PAR_OUT,PARNAME,'NEW','F',LREC,IFAIL)
      CALL KWD_WRITEKDM_SYMM(KDX,IUN_PAR_OUT, 4, 0, 8, IERR)
C      CLOSE(IUN_PAR_OUT,'KEEP')
      close(iun_par_out)

      CALL CCPERR(0,'All done ....')
C      CALL CCPTIM (1, CPU, ELAPS)
C      WRITE(IUN_LOG,1005) CPU/60.0, ELAPS/60.0

      STOP
      
 210  WRITE(IUN_LOG,3320) 
      WRITE(IUN_LOG,2000)
      STOP

 810  WRITE(IUN_LOG,2010) KERR, ERRSTR(1:LENSTR(ERRSTR))
      WRITE(IUN_LOG,2000)

      STOP
C
C====== Format statements for error messages and log-file entries
C
 1000 FORMAT (/,' ************************************************',
     +        /,' ************************************************',
     +        /,' ******                                    ******',
     +        /,' ******          L  S  C  A  L  E          ******',
     +        /,' ******                                    ******',
     +        /,' ******             Version 1.0            ******',
     +        /,' ******                                    ******',
     +        /,' ************************************************',
     +        /,' ************************************************',
     +        /,' *      Steffi Arzt, John W. Campbell, 1998     *',
     +        ///)
C 1005 FORMAT (/,' Refinement time CPU =',F7.1,' min, ELAPSED =',
C     +         F10.1, ' min'/)
 1005 FORMAT (/,' Refinement time CPU =',F7.1,' min',/)
 1010 FORMAT (' ',A)
 1020 FORMAT (//,' TOTAL NUMBER OF SPOTS IN INPUT_FILE: ',I19,/)
 1030 FORMAT (/,' OF THOSE ARE:',//,
     +           ' MULTIPLES               ',I16,'   (',F4.1,'%)') 
 1040 FORMAT (/,' SPATIAL OVERLAPPED      ',I16,'   (',F4.1,'%)') 
 1050 FORMAT (/,' OVERLOADS               ',I16,'   (',F4.1,'%)') 
 1060 FORMAT (/,' I>',F3.1,'*SIGMA             ',I16,
     +          '   (',F4.1,'%)') 
 1070 FORMAT (/,' INTEGRATION DONE        ',I16,'   (',F5.1,'%)') 
 1080 FORMAT (//,' WAVELENGTH RANGE IN INPUT DATA:  ',F6.3,'A  - ',
     +        F6.3,'A',//)
 1090 FORMAT (//,' KEYWORD AND PARAMETER INPUT',/)
 2000 FORMAT (//,' ******** PROCESSING STOPPED *******')
 2010 FORMAT (/,'***  ERROR  *** ',/,' ERROR CODE ',I2,
     +        'FROM READING KEYWORD PARAMETERS: ',/,' ',A)
 2020 FORMAT (//,' KEYWORD AND PARAMETER OUTPUT',/)
 3000 FORMAT (/,' ***  ERROR  *** KWD_READLINE ERROR FLAG = ', I2)
 3010 FORMAT (/,' *** WARNING *** INVALID KEYWORD DATA IN',/,
     +        ' LINE= ',A)
 3020 FORMAT (/,' ***  ERROR  *** KWD_PARSE ERROR',/,' ', A,/,
     +        ' ',A,/,' ',A)

 3030 FORMAT (/,' *** ERROR *** ',/,
     +        ' PARAMETERS MUST NOT BE CHANGED BETWEEN REFINEMENTS')

 3040 FORMAT (/,' ***  ERROR  *** KWD_PARSESYMM ERROR',/,' ', A,/,
     +        ' ',A,/,' ',A)

 3050 FORMAT (/,' *** ERROR *** ',/,
     +        ' SYMMETRY MUST NOT BE CHANGED BETWEEN REFINEMENTS')

 3060 FORMAT (//,' REFINEMENT NUMBER ',I2,
     +        /,' ====================',//,
     +        ' REFINED PARAMETERS:'//)
 3070 FORMAT ('          PLATE SCALE FACTORS',/)
 3080 FORMAT ('          IMAGE/PACK SCALE FACTORS',/)
 3090 FORMAT ('          IMAGE/PACK TEMPERATURE FACTORS',/)
 3100 FORMAT ('          WAVELENGTH NORMALISATION',/)
 3110 FORMAT ('          GLOBAL ABSORPTION CORRECTION',/)
 3120 FORMAT ('          LOCAL ABSORPTION CORRECTION',/)
 3130 FORMAT ('          REFERENCE SET SCALE FACTORS',/)
 3140 FORMAT ('          REFERENCE SET TEMPERATURE FACTORS',/)
 3150 FORMAT (/,' PARAMETERS WILL BE REFINED TOGETHER',/)
 3160 FORMAT (/,' PARAMETERS WILL BE REFINED CYCLED',/)
 3170 FORMAT (/,' REFINEMENT AGAINST EXTERNAL REFERENCE INTENSITIES',/)
 3180 FORMAT (/,' REFINEMENT AGAINST INTERNAL INTENSITIES',/)
 3190 FORMAT (/,' REFINE WITH OUTLIERS EXCLUDED',/)
 3200 FORMAT (/,' REFINE WITH OUTLIERS INCLUDED',/)
 3210 FORMAT (/,' ERROR MESSAGE FROM LSM_PARSETUP_LSP:',/,' ',A)
 3220 FORMAT (/,' NUMBER OF IMAGES/PACKS = 0')
 3230 FORMAT (/,' NO INPUT FILETYP SPECIFIED, DEFAULT IS''.ge''')
 3240 FORMAT (/,' INPUT FILETYP IS .',A)
 3250 FORMAT (/,' FILENAME FOR INPUT FILE(S) MISSING')
 3260 FORMAT (/,' ***  ERROR  ***  MTZ FILE NOT FOUND')
 3270 FORMAT (/,' ***  ERROR  ***  ERROR RETURN FROM LFN_MTZLIRL:',
     +        /,'ERROR CODE NUMBER ',I2) 
 3280 FORMAT (/,' NUMBER OF SPOTS ADDED FOR IMAGE/PACK ',I2,':',I16)
 3290 FORMAT (/,' ***  ERROR  *** ''.ge1''-FILE DOES NOT EXIST')
 3300 FORMAT (/,' ***  ERROR  *** ''.ge2''-FILE DOES NOT EXIST')
 3310 FORMAT (/,' ***  ERROR  ***  ERROR RETURN FROM LFN_GELIRL:',
     +        /,'ERROR CODE NUMBER ',I2) 
 3320 FORMAT (/,' ***  ERROR  ***  NO SYMMETRY DATA PRESENT')
 3330 FORMAT (/,' ***  ERROR  ***',/,
     +       ' ATTEMPT TO REFINE AGAINST NON-EXISTENT REFERENCE DATA')
 3340 FORMAT (/,' ***  ERROR  *** REFERENCE MTZ-FILE NOT FOUND')
 3350 FORMAT (/,' ***  ERROR  ***  ERROR RETURN FROM LIRLF_SORT:',
     +        /,'ERROR CODE NUMBER ',I2) 
 3360 FORMAT (/,' ***  ERROR  ***  ERROR RETURN FROM LIRLF_GETREF:',
     +        /,'ERROR CODE NUMBER ',I2) 
 3370 FORMAT (/,' ***  ERROR  ***  ERROR RETURN FROM LIRLF_HKLUNQ:',
     +        /,'ERROR CODE NUMBER ',I2) 
 3380 FORMAT (/,' ***  ERROR  ***  ERROR RETURN FROM LIRLF_SET_REFINT:',
     +        /,' IVALID INDEX GIVEN, LIST NOT INITIALISED OR ',
     +           ' RECORD NOT PRESENT')
 3390 FORMAT (/,' ***  ERROR  ***  ERROR RETURN FROM LSM_KDMCOPY:',
     +        /,' ',A)
 3400 FORMAT (/,' ***  ERROR  ***  ERROR RETURN FROM LSM_OMIT_LSP:',
     +        /,' ',A)
 3410 FORMAT (/,' ***  ERROR  ***  ERROR RETURN FROM ',
     +        'LSM_SELECT_SCREFS_LSP:',/,' ',A)
 3420 FORMAT (/,' ***  ERROR  ***  ERROR RETURN FROM LSC_RFACTS_LSP')
 3430 FORMAT (/,' ***  WARNING  ***  MEMORY ALLOCATION PROBLEM IN',
     +        ' LSM_REFINE',/,' ',A)
 3440 FORMAT (/,' ***  ERROR  ***  ERROR RETURN FROM LSM_REFINE',/,
     +        ' WORKSPACE FOR REFINEMENT ROUTINE LSQMQL TOO SMALL',/,
     +        ' YOU WILL HAVE TO SET THE PARAMETER ''NW'' IN THE ',/,
     +        'LSM.INC-FILE TO AT LEAST ',I12)
 3450 FORMAT (//,' MINIMISED VALUE SUMWD2',//,
     +        ' SUMWD2 IS THE SUM OVER THE SQUARES OF THE ',/,
     +        ' WEIGHTED DIFFERENCES BETWEEN SCALED INTENSITIES ',
     +        'AND MEAN INTENSITY OR REFERENCE INTENSITY',/,
     +        ' SUM[(SC*I-Imean:ref)/(SC*SIG(I))]**2',//,
     +        ' SUMWD2 = ', F14.2,//)
 3460 FORMAT (/,' ***  ERROR  ***  ERROR RETURN FROM ',
     +        'LSM_MULTIPLES_DECONV:',/,' ',A)

 3470 FORMAT (/,' ***  ERROR  ***  ERROR RETURN FROM LSM_GRAPHSETUP:',
     +        /,' ',A)
 6100 FORMAT(//,' **MAXIMUM NUMBER OF EQUATIONS FOR MULTIPLES',
     + 'DECONVOLUTION OF',I4,' EXCEEDED**')
 6600 FORMAT (/,' USING WAVELENGTH TAGGED DATA WITH DLAM CHECK OF',
     +        F7.4,' IN REFERENCE SET')
 6620 FORMAT (/,' USING I+ AND I- SEPARATED REFERENCE DATA')

      END

C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C***************************
C**   LSCALE_GETREFINE    **
C***************************
C
C
CD-Routine: Get refinement options - LSCALE_GETREFINE
CThis routine get refinement options for the parameter refinement which are
Cpassed on to LSM_SET_RFLAGS
CD-end
CD-Fortran:
      SUBROUTINE LSCALE_GETREFINE (STR, BATCH_FL, CYCLE1, IPLATE_SC1,  
     +           IPACK_SC1, IPACK_BFAC1, NORM1, ABSCORGLOB1, 
     +           ABSCORLOC1, REF_SC1, REF_BFAC1, EXOUT, IUN)
CD-end
C
      INCLUDE 'implicit_none.finc'
C
C Purpose: Get refinement options
C
C Author:  Steffi Arzt, John Campbell, July 1997
C
C Arguments:
C
      CHARACTER*2000 STR
      INTEGER IPLATE_SC1
      INTEGER IPACK_SC1 
      INTEGER IPACK_BFAC1 
      INTEGER IUN
      LOGICAL BATCH_FL
      LOGICAL CYCLE1
      LOGICAL NORM1
      LOGICAL ABSCORGLOB1
      LOGICAL ABSCORLOC1
      LOGICAL REF_SC1
      LOGICAL REF_BFAC1
      LOGICAL EXOUT
C
CD-Parameters:
C  STR          c (R)
C  BATCH_FL     l (W)   Flag =.true.  Run in batch mode (only log-file written)
C                            =.false. Run with XDL-view output windows
C  CYCLE1       l (W)   Flag =.true.  Refine parameters in cycles
C                            =.false. Refine all parameters together
C  IPLATE_SC1   i (W)   Flag >0  Refine plate scaling parameters for
C                                plate IPLATE_SC (for all packs).
C                            =0  Refine plate scaling parameters for all
C                                plates with valid data present in LIRL.
C                                (for all packs)
C                            =-1 Do not refine plate scaling parameters.
C  IPACK_SC1    i (W)   Flag >0  Refine pack scaling factor for pack
C                                IPACK_SC (must not be pack 1).
C                            =0  Refine pack scaling factors for all
C                                packs (except pack 1) with valid data
C                                present in LIRL.
C                            =-1 Do not refine pack scale factors.
C  IPACK_BFAC1  i (W)   Flag >0  Refine pack temperature factor for pack
C                                IPACK_SC (must not be pack 1),
C                            =0  Refine pack temperature factors for all
C                                packs (except pack 1) with valid data
C                                present in LIRL.
C                            =-1 Do not refine pack temperature factors.
C  NORM1        l (W)   Flag =.true.  Refine normalisation curves for all
C                                     defined ranges.
C                            =.false. Do not refine normalisation curves.
C  ABSCORGLOB1  l (W)   Flag =.true.  Refine global absorption correction.
C                            =.false. Do not refine absorption correction.
C  ABSCORLOC1   l (W)   Flag =.true.  Refine local absorption correction.
C                            =.false. Do not refine local absorption
C  REF_SC1      l (W)   Flag =.true.  Refine scale factor to reference
C                                     data.
C                            =.false. Do not refine scale factor to
C                                     reference data.
C  REF_BFAC1    l (W)   Flag =.true.  Refine temperature factor to reference
C                                     data.
C                            =.false. Do not refine temperature factor to
C                                     reference data.
C  EXOUT        l (W)   Flag =.true.  Exclude outliers
C                            =.false. Do not exclude outliers (=default)
C  IUN          i (R)   Output unit number for log-file
CD-end

C
C
C====== GLOBALS:
C

C
C====== LOCALS:
C
      CALL CCPUPC(STR)
         
      IF (INDEX(STR,'TOGETHER').NE.0) THEN 
         CYCLE1 = .FALSE.
      ELSE IF (INDEX(STR,'CYCLE').NE.0) THEN
         CYCLE1 = .TRUE.
      ELSE         
         WRITE(IUN,1000)
         CYCLE1 = .TRUE.
      END IF

      IF (INDEX(STR,'DEFAULT').NE.0) THEN
         BATCH_FL = .FALSE.
         IPLATE_SC1 = -1
         IPACK_SC1 = 0
         IPACK_BFAC1 = 0
         REF_SC1 = .FALSE.
         REF_BFAC1 = .FALSE.
         NORM1 = .TRUE. 
         ABSCORGLOB1 = .FALSE.
         ABSCORLOC1 = .FALSE.
         EXOUT = .FALSE.
         RETURN
      END IF

      IF (INDEX(STR,'NODISPLAY').NE.0) THEN
         BATCH_FL = .TRUE.
      ELSE
         BATCH_FL = .FALSE.
      END IF

      IF (INDEX(STR,'PLATE').NE.0) THEN
         IPLATE_SC1 = 0
      ELSE
         IPLATE_SC1 = -1
      END IF

      IF (INDEX(STR,'IMAGESC').NE.0) THEN
         IPACK_SC1 = 0
      ELSE
         IPACK_SC1 = -1
      END IF

      IF (INDEX(STR,'IMAGEBF').NE.0) THEN
         IPACK_BFAC1 = 0
      ELSE
         IPACK_BFAC1 = -1
      END IF

      IF (INDEX(STR,'EXTERNAL').NE.0) THEN
            REF_SC1 = .TRUE.
            REF_BFAC1 = .FALSE.
      ELSE
         REF_SC1 = .FALSE.
         REF_BFAC1 = .FALSE.
      END IF

      IF (INDEX(STR,'NORM').NE.0) THEN
         NORM1 = .TRUE.
      ELSE
         NORM1 = .FALSE.
      END IF

      IF (INDEX(STR,'GLOBABS').NE.0) THEN
         ABSCORGLOB1 = .TRUE.
      ELSE
         ABSCORGLOB1 = .FALSE.
      END IF

      IF (INDEX(STR,'LOCABS').NE.0) THEN
         ABSCORLOC1 = .TRUE.
      ELSE
         ABSCORLOC1 = .FALSE.
      END IF

      IF (INDEX(STR,'GLOBABS').NE.0.AND.
     +    INDEX(STR,'LOCABS').NE.0) THEN
         ABSCORLOC1 = .FALSE.
         WRITE(IUN,2000)
      END IF

      IF (INDEX(STR,'EXOUT').NE.0) THEN
         EXOUT = .TRUE.
      ELSE
         EXOUT = .FALSE.
      END IF

      RETURN


 1000 FORMAT (/,' ***  WARNING  ***  ',/,
     +       ' ''TOGETHER'' OR ''CYCLE'' STATEMENT MISSING',/,
     +       ' REFINEMENT OPTION SET TO ''CYCLE''') 
 2000 FORMAT (/,' ***  WARNING  ***  ',/,
     +       ' GLOBAL AND LOCAL ABSORPTION CORRECTION CAN NOT BE',
     +       ' REFINED SIMULTANEOUSLY',/,' SET TO GLOBAL')

      END

C LAST UPDATE: 
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C**************************
C**     INT_FILNAM       **
C**************************
C
C
      SUBROUTINE INT_FILNAM (IPACK, INT_TEMPL, FILNAM, I_TYP)
C
      IMPLICIT NONE
C
C Purpose: Get file name for intensities file for current pack from
C          template, explcit file name & file type parameters
C
C Author:  MODIFIED VERSION OF LAUEGEN ROUTINE
C
C Arguments:
C
      INTEGER IPACK
      CHARACTER*(*) INT_TEMPL
      CHARACTER*(*) FILNAM
      INTEGER I_TYP
C
C IPACK     (R)  Pack no.
C INT_TEMPL (R)  Template from which to form file name or blank to form name
C                from the current value of the INT_TEMPLATE parameter
C FILNAM    (W)  Returns intensities file name for current pack (Note that
C                extension will be returned as 'ge*' for .ge1/.ge2 type
C                file output.
C I_TYP     (W)  File type 1=mtz, 2= .ge1/.ge2
C
C====== Parameter statements
C 
       INTEGER MAXFLEN
       PARAMETER (MAXFLEN=250)
C
C====== GLOBALS:
C

C
C====== FUNCTION TYPES:
C
      INTEGER LENSTR
C
C====== LOCALS:
C
      INTEGER IPID
      INTEGER NDIG
      INTEGER LL
      INTEGER I
      INTEGER J
      INTEGER ILEN
      INTEGER IVAL
      INTEGER IFLAG
      INTEGER ITYP
      INTEGER IERR
      INTEGER ND
      REAL FP
      CHARACTER*(MAXFLEN) FNAM
      CHARACTER*(MAXFLEN) STR1
      CHARACTER*(MAXFLEN) STR2
      CHARACTER*(MAXFLEN) TEMPLATE
      CHARACTER*80 STR
      CHARACTER*8 FRM
      CHARACTER*2 ERRSTR

C     INTEGER IPID                  !Pack id.
C     INTEGER NDIG                  !No. of digits in '#' field
C     INTEGER LL                    !String length
C     INTEGER I                     !Temp/loop variable
C     INTEGER J                     !Temp/loop variable
C     INTEGER ILEN                  !File name less extension length
C     INTEGER IVAL                  !Integer parameter value
C     INTEGER IFLAG                 !Parameter status flag
C     INTEGER ITYP                  !Parameter type flag
C     INTEGER IERR                  !Error flag
C     INTEGER ND                    !No. of decimal places flag
C     REAL FP                       !Real parameter value
C     CHARACTER*(MAXFLEN) FNAM      !File name string
C     CHARACTER*(MAXFLEN) STR1      !Temp string
C     CHARACTER*(MAXFLEN) STR2      !Temp string
C     CHARACTER*80 STR              !Temp string
C     CHARACTER*(MAXFLEN) TEMPLATE  !File name template string
C     CHARACTER*8 FRM               !Format string
C     CHARACTER*2 ERRSTR            !Error string (dummy)

      DATA FRM /'(I25.XX)'/
C
C-------------------------------------------------------------------------------
C
C====== Find file type
C
      CALL LDM_GET ('INT_FTYPE', IPACK, 0, STR, FP, ND, IVAL,
     +              IFLAG, ITYP, IERR, ERRSTR)
      I_TYP = 1
      IF (STR.EQ.'ge') I_TYP = 2
C
C====== Form name from template
C
      IF (INT_TEMPL.EQ.' ') THEN
         CALL LDM_GET ('INT_TEMPLATE', IPACK, 0, TEMPLATE, 
     +                 FP, ND, IVAL, IFLAG, ITYP, IERR, ERRSTR)
      ELSE
         TEMPLATE = INT_TEMPL
      END IF
      NDIG  = 1
      STR1 = ' '
      STR2 = ' '
      LL = LENSTR(TEMPLATE)
      I = 0
      J = 0
10    I = I + 1
      IF (I.LE.LL) THEN
         IF (TEMPLATE(I:I).NE.'#') THEN
            J = J + 1
            STR1(J:J) = TEMPLATE(I:I)
            GO TO 10
         END IF
      END IF
20    I = I + 1
      IF (I.LE.LL) THEN
         IF (TEMPLATE(I:I).EQ.'#') THEN
            NDIG = NDIG + 1
            GO TO 20
         END IF
      END IF
      IF (I.LE.LL) STR2 = TEMPLATE(I:LL)
C
C====== Now add pack_id
C
      CALL LDM_GET_PID (IPACK, IPID, IFLAG, IERR, ERRSTR)
      FNAM = STR1
      WRITE (FRM(6:7),'(I2.2)')NDIG
      WRITE (STR,FRM) IPID
      LL = LENSTR(STR)
      J = 0
      DO 30 I = 1, LL
         IF (STR(I:I).NE.' ') THEN
            STR = STR(I:LL)
        GO TO 40
         END IF
30    CONTINUE
40    CALL STR_ADDS(FNAM,STR,0)
      CALL STR_ADDS (FNAM,STR2,0)
      IF (I_TYP.EQ.1) THEN
         FILNAM = FNAM
      ELSE
         CALL FILEXT (FNAM, 'xxx', FILNAM, ILEN)
         FNAM = FILNAM(1:ILEN)
         CALL FILEXT (FNAM, 'ge*', FILNAM, ILEN)
      END IF
      RETURN
      END

C*********************************
      SUBROUTINE APPLY_MODEL(KDX, MINDX, NSPOT, MODEL)
C*********************************
      IMPLICIT NONE

      INTEGER KDX
      INTEGER MINDX
      INTEGER NSPOT
      INTEGER MODEL

      INTEGER KDMSTR
      INTEGER LENSTR
      REAL STHLSQ

      INTEGER I, J, IREF, IH, IK, IL, IPACK, IPLATE, KSYM
      INTEGER MULT, MINHARM, MAXHARM, INCHARM
      INTEGER ISPAT, ICLOS, IMEAS, IBAD, IOVLD, ICODE, IERR
      INTEGER IVAL(10), ND(10), NUM_INP, KERR, MAXE
      INTEGER ISTAT, ITYP
      REAL CELL(6)   
      REAL XFD, YFD, ALAM, AI, SIGI, AIMM
      REAL XF, YF 
      REAL FVAL(10)
      REAL COVFAC, POLFAC
      REAL STOL2, C2T, ALC2T, OB_LPFAC, PSIPOL 
      REAL CSQ2T, SSQ2T, FAC 
      REAL AIM(-90:90,-90:90), AIC
      REAL ALAMIN, PI
      REAL PSI, SPINDLE, CTOF
      CHARACTER*80 VALSTR
      CHARACTER*80 ERRSTR
      CHARACTER*80 STR

      MAXE = 80
      PI=3.1415926535

      STR = 'A'	
      CALL KDMF_GETVALUE (KDX, KDMSTR(STR),LENSTR(STR), 1, 1, 
     +                    2, KDMSTR(VALSTR), FVAL, ND, IVAL, 
     +                    NUM_INP, ISTAT, ITYP, KDMSTR(ERRSTR), 
     +                    MAXE, KERR) 
      CELL(1) = FVAL(1)

      STR = 'B'	
      CALL KDMF_GETVALUE (KDX, KDMSTR(STR),LENSTR(STR), 1, 1, 
     +                    2, KDMSTR(VALSTR), FVAL, ND, IVAL, 
     +                    NUM_INP, ISTAT, ITYP, KDMSTR(ERRSTR), 
     +                    MAXE, KERR) 
      CELL(2) = FVAL(1)

      STR = 'C'	
      CALL KDMF_GETVALUE (KDX, KDMSTR(STR),LENSTR(STR), 1, 1, 
     +                    2, KDMSTR(VALSTR), FVAL, ND, IVAL, 
     +                    NUM_INP, ISTAT, ITYP, KDMSTR(ERRSTR), 
     +                    MAXE, KERR) 
      CELL(3) = FVAL(1)

      STR = 'ALPHA'	
      CALL KDMF_GETVALUE (KDX, KDMSTR(STR),LENSTR(STR), 1, 1, 
     +                    2, KDMSTR(VALSTR), FVAL, ND, IVAL, 
     +                    NUM_INP, ISTAT, ITYP, KDMSTR(ERRSTR), 
     +                    MAXE, KERR) 
      CELL(4) = FVAL(1)

      STR = 'BETA'	
      CALL KDMF_GETVALUE (KDX, KDMSTR(STR),LENSTR(STR), 1, 1, 
     +                    2, KDMSTR(VALSTR), FVAL, ND, IVAL, 
     +                    NUM_INP, ISTAT, ITYP, KDMSTR(ERRSTR), 
     +                    MAXE, KERR) 
      CELL(5) = FVAL(1)

      STR = 'GAMMA'	
      CALL KDMF_GETVALUE (KDX, KDMSTR(STR),LENSTR(STR), 1, 1, 
     +                    2, KDMSTR(VALSTR), FVAL, ND, IVAL, 
     +                    NUM_INP, ISTAT, ITYP, KDMSTR(ERRSTR), 
     +                    MAXE, KERR) 
      CELL(6) = FVAL(1)
           
      STR = 'COVER_FACTOR'
      CALL KDMF_GETVALUE (KDX, KDMSTR(STR),LENSTR(STR), 1, 1, 
     +                    2, KDMSTR(VALSTR), FVAL, ND, IVAL, 
     +                    NUM_INP, ISTAT, ITYP, KDMSTR(ERRSTR), 
     +                    MAXE, KERR)  
      COVFAC = FVAL(1)
      
      STR = 'POL_FAC'	
      CALL KDMF_GETVALUE (KDX, KDMSTR(STR),LENSTR(STR), 1, 1, 
     +                    2, KDMSTR(VALSTR), FVAL, ND, IVAL, 
     +                    NUM_INP, ISTAT, ITYP, KDMSTR(ERRSTR), 
     +                    MAXE, KERR) 
      POLFAC = FVAL(1)

      CALL SETRSL(CELL(1),CELL(2),CELL(3),CELL(4),CELL(5),CELL(6))

      DO 10 IREF = 1, NSPOT
         CALL LIRLF_GETREF (MINDX, IREF, IH, IK, IL, IPACK, IPLATE, 
     +                 KSYM, XFD, YFD, ALAM,
     +                 MULT, MINHARM, MAXHARM, INCHARM, AI, SIGI,
     +                 ISPAT, ICLOS, IMEAS, IBAD, IOVLD, 
     +                 ICODE, IERR)

C====== model 1: pg dependent only

         IF (MODEL.EQ.1) THEN
            XF = 0.01*XFD
            YF = 0.01*YFD
            AI = 100*(1+0.05*XF/(XF**2+0.05))*(1+0.05*YF/(YF**2+0.1))
            write(26,*)XFD,YFD,AI
            SIGI = AI/100.0
         END IF


C====== model 2: pg and lambda dependent 

         IF (MODEL.EQ.2) THEN
            XF = 0.01*XFD
            YF = 0.01*YFD
C            AI = 0.3 + 2.0*XF/(XF**2+2.2)+1.0*YF/(YF**2+0.8)
C            AI = 100.0*EXP(-ALAM**3*AI)
            AI = 0.3 + 5.0*(0.05*XF/(XF**2+0.1)+0.05*YF/(YF**2+0.15))
            AI = 100.0*EXP(-ALAM**3*AI)
            write(26,*)XFD,YFD,AI
            SIGI = AI/100.0
         END IF

C====== model 3: pg dependent only


         IF (MODEL.EQ.3) THEN
            XF = 0.01*XFD
            YF = 0.01*YFD
            AI = 0.06+0.005*XF/(XF**2+0.03)+0.002*YF/(YF**2+0.03)
            AI = 100.0*EXP(-ALAM**3*AI)
            write(26,*)XFD,YFD,AI
            SIGI = AI/100.0
         END IF

C====== model 4: pg and lambda dependent + spindle

         IF (MODEL.EQ.4) THEN
            SPINDLE = 2.0
            CTOF = 231.14
            PSI = (ATAN(XFD/CTOF))*180.0/PI-(IPACK-1)*SPINDLE
            XF = CTOF*TAN(PSI*PI/180.0)
            XF = 0.01*XF
            YF = 0.01*YFD
            AI = 0.3 + 2.5*(0.05*XF/(XF**2+0.1)+0.05*YF/(YF**2+0.15))
            AI = 100.0*EXP(-ALAM**3*AI)
            AI = AI * SIN((ALAM-0.4)*PI)
            write(26,*)XF,YF,100.0*(EXP(-ALAM**3*AI)),PSI
            SIGI = AI/10.0
         END IF


C====== model 5: pg and lambda dependent + spindle

         IF (MODEL.EQ.5) THEN
            SPINDLE = 2.0
            CTOF = 231.14
            PSI = (-ATAN(XFD/CTOF))*180.0/PI-(IPACK-1)*SPINDLE
C            PSI = (-ATAN(XFD/CTOF))*180.0/PI 
            XF = -CTOF*TAN(PSI*PI/180.0)
            XF = 0.01*XF
            YF = 0.01*YFD
            AIMM = 1.0+(3.0*(1.0*XF/(XF**2+0.1)+1.0*YF/(YF**2+0.15)))
            write(26,*)XFD,YFD,AIMM
            AI =   100.0*(EXP(-ALAM**3*0.3*0.15*AIMM))*AI
            SIGI = 100.0*(EXP(-ALAM**3*0.3*0.15*AIMM))*SIGI
         END IF


C====== model -1: pg and lambda dependent + spindle (like model 4)

         IF (MODEL.EQ.-1) THEN
            SPINDLE = 5.0
            CTOF = 152.5
            PSI = (ATAN(XFD/CTOF))*180.0/PI+(IPACK-1)*SPINDLE
C            PSI = (ATAN(XFD/CTOF))*180.0/PI+ 5.0
            XF = CTOF*TAN(PSI*PI/180.0)
            XF = 0.01*XF
            YF = 0.01*YFD
            AI = 0.3 +5.0*(0.05*XF/(XF**2+0.1)+0.05*YF/(YF**2+0.15))
            AI = 100.0*EXP(-ALAM**3*AI)
            write(26,*)XFD,YFD,AI,PSI
            SIGI = AI/100.0
         END IF

C====== model -2: pg and lambda dependent 

         IF (MODEL.EQ.-2) THEN
            SPINDLE = 5.0
            CTOF = 152.5
            PSI = (ATAN(XFD/CTOF))*180.0/PI+(IPACK-1)*SPINDLE
            XF = CTOF*TAN(PSI*PI/180.0)
            XF = 0.01*XF
            YF = 0.01*YFD
            AIC =  0.3 +0.3*XF/(XF**2+0.3)+0.04*YF/
     +                          (YF**2+0.1)
            AIC = EXP(-ALAM**3*AIC)
            AI = AI*AIC
            write(26,*)XFD,YFD,AI,aic,alam,sigi
            SIGI = SIGI*AIC
         END IF

         IF (MODEL.GT.0) THEN         
            STOL2 = STHLSQ(IH,IK,IL)
            C2T = COS(2*ASIN(ALAM*SQRT(STOL2)))
            ALC2T = ALAM**3/C2T
            OB_LPFAC = EXP(COVFAC/C2T)
            OB_LPFAC = OB_LPFAC * STOL2*ALAM**2
            IF (YFD.NE.0.0) THEN
               PSIPOL = ATAN(XFD/YFD)
               CSQ2T = C2T**2
               SSQ2T = 1.0-CSQ2T
               FAC = 2.0/(1.0+CSQ2T-POLFAC*COS(2*PSIPOL)*SSQ2T)
               OB_LPFAC = OB_LPFAC * FAC
            END IF
            AI = AI/OB_LPFAC
            SIGI = SIGI/OB_LPFAC
         END IF
         CALL LIRLF_PUTREF (MINDX, IREF, IH, IK, IL, IPACK, IPLATE, 
     +                    KSYM, XFD, YFD, ALAM,
     +                    MULT, MINHARM, MAXHARM, INCHARM, AI, SIGI,
     +                    ISPAT, ICLOS, IMEAS, IBAD, IOVLD, 
     +                    ICODE, IERR) 
10    CONTINUE

      ALAMIN = 1.3
C***********
      IF (MODEL.EQ.5) THEN
         DO 151 J = 80, -80, -10
            YF = 0.01*J
            DO 131 I = -120, 80, 10 
               XF = I
               CTOF = 231.14
               PSI = (-ATAN(XF/CTOF))*180.0/PI
               XF = -CTOF*TAN(PSI*PI/180.0)
               XF = 0.01*XF               
               AIM(I,J) = 1.0+3.0*(1.0*XF/(XF**2+0.1)+1.0*YF/
     +                          (YF**2+0.15))
               WRITE(25,*) I,J,AIM(I,J)
               if(i.eq.0.and.j.eq.0)write(6,*)'pg=',AIM(I,J)
               AIM(I,J) = 100.0*EXP(-ALAMIN**3*0.15*0.3*AIM(I,J))
               AIM(I,J) = (100.0/AIM(I,J))
               AIM(I,J) = AIM(I,J)*100.0
               if(i.eq.0.and.j.eq.0)write(6,*)'exp=',AIM(I,J)
 131           CONTINUE
 151     CONTINUE
         DO 141 J = 80, -80, -10
            WRITE(27,1000) (NINT(AIM(I,J)), I = -120, 80, 10)
C            WRITE(27,1000) (NINT(AIM(I,J)), I = -80, 80, 10)
 141        CONTINUE
      END IF

      ALAMIN = 1.3

      IF (MODEL.EQ.4) THEN
         DO 150 J = 80, -80, -10
            YF = 0.01*J
            DO 130 I = -120, 80, 10 
C            DO 130 I = -80, 80, 10 
               XF = I
               CTOF = 231.14
               PSI = (-ATAN(XF/CTOF))*180.0/PI
               XF = -CTOF*TAN(PSI*PI/180.0)
               XF = 0.01*XF               
               AIM(I,J) = 0.3 +2.5*(0.05*XF/(XF**2+0.1)+0.05*YF/
     +                           (YF**2+0.15))
               if(i.eq.0.and.j.eq.0)write(6,*)'pg=',AIM(I,J)
               AIM(I,J) = 100.0*EXP(-ALAMIN**3*AIM(I,J))
               AIM(I,J) = (100.0/AIM(I,J))
               WRITE(25,*) I,J,AIM(I,J)
               AIM(I,J) = AIM(I,J)*100.0
               if(i.eq.0.and.j.eq.0)write(6,*)'exp=',AIM(I,J)
 130        CONTINUE
 150     CONTINUE
         DO 140 J = 80, -80, -10
            WRITE(27,1000) (NINT(AIM(I,J)), I = -120, 80, 10)
C            WRITE(27,1000) (NINT(AIM(I,J)), I = -80, 80, 10)
 140     CONTINUE
      END IF

      IF (MODEL.EQ.1) THEN
         DO 40 I = -90, 90, 2
            XF = 0.01*I
            DO 50 J = -90, 90, 2
               YF = 0.01*J
               AIM(I,J) = 100.0*(1+0.05*XF/(XF**2+0.05))*
     +              (1+0.05*YF/(YF**2+0.1))
               WRITE(25,*) I,J,AIM(I,J)
               AIM(I,J) = (100.0/AIM(I,J))*100.0
               IF(SQRT(FLOAT(I*I+J*J)).GT.90.0) AIM(I,J) = 0.0
 50         CONTINUE
 40      CONTINUE
         DO 60 J = 90, -90, -10
            WRITE(27,1000) (NINT(AIM(I,J)), I = -90, 90, 10)
 60      CONTINUE
      END IF

      ALAMIN = 1.3

      IF (MODEL.EQ.2) THEN
         DO 70 I = -90, 90, 2
            XF = 0.01*I
            DO 80 J = -90, 90, 2
               YF = 0.01*J
               AIM(I,J) = 0.3 +5.0*(0.05*XF/(XF**2+0.1)+0.05*YF/
     +                                 (YF**2+0.15))
               AIM(I,J) = 100.0*EXP(-ALAMIN**3*AIM(I,J))
                WRITE(25,*) I,J,AIM(I,J)
               AIM(I,J) = (100.0/AIM(I,J))*100.0
               IF(SQRT(FLOAT(I*I+J*J)).GT.90.0) AIM(I,J) = 0.0
 80         CONTINUE
 70      CONTINUE
         DO 90 J = 90, -90, -10
            WRITE(27,1000) (NINT(AIM(I,J)), I = -90, 90, 10)
 90      CONTINUE
      END IF

      IF (MODEL.EQ.3) THEN
         DO 100 J = 90, -90, -2
            YF = 0.01*J
            DO 110 I = 90, -90, -2
               XF = 0.01*I
               AIM(I,J) = (1+0.05*XF/(XF**2+0.05))*
     +              (1+0.05*YF/(YF**2+0.1))
               AIM(I,J) = 100.0*EXP(-ALAMIN**3*AIM(I,J))
               WRITE(25,*) I,J,AIM(I,J)
               AIM(I,J) = (100.0/AIM(I,J))*100.0
               IF(SQRT(FLOAT(I*I+J*J)).GT.90.0) AIM(I,J) = 0.0
 110        CONTINUE
 100     CONTINUE
         DO 120 J = 90, -90, -10
            WRITE(27,1000) (NINT(AIM(I,J)), I = -90, 90, 10)
 120     CONTINUE
      END IF


      IF (MODEL.EQ.-1) THEN
         DO 190 J = 80, -80, -10
            YF = 0.01*J
            DO 200 I = -80, 120, 10 
C            DO 200 I = -80, 80, 10 
               XF = I
               CTOF = 152.5
               PSI = (ATAN(XF/CTOF))*180.0/PI
               XF = CTOF*TAN(PSI*PI/180.0)
               XF = 0.01*XF               
               AIM(I,J) = 0.3 +5.0*(0.05*XF/(XF**2+0.1)+0.05*YF/
     +                          (YF**2+0.15))
               if(i.eq.0.and.j.eq.0)write(6,*)'pg=',AIM(I,J)
               AIM(I,J) = 100.0*EXP(-ALAMIN**3*AIM(I,J))
               AIM(I,J) = (100.0/AIM(I,J))
               WRITE(25,*) I,J,AIM(I,J)
               AIM(I,J) = AIM(I,J)*100.0
               if(i.eq.0.and.j.eq.0)write(6,*)'exp=',AIM(I,J)
 200        CONTINUE
 190     CONTINUE
         DO 210 J = 80, -80, -10
            WRITE(27,1000) (NINT(AIM(I,J)), I = -80, 120, 10)
C            WRITE(27,1000) (NINT(AIM(I,J)), I = -80, 80, 10)
 210     CONTINUE
      END IF

      IF (MODEL.EQ.-2) THEN
         DO 160 I = -80, 120, 10
            XF = 0.01*I
            DO 170 J = -80, 80, 10
               YF = 0.01*J
               AIM(I,J) = 0.3 +0.3*XF/(XF**2+0.3)+0.04*YF/
     +                                 (YF**2+0.1)
               if(i.eq.0.and.j.eq.0)write(6,*)'pg(in)=',AIM(I,J)
               AIM(I,J) = EXP(-ALAMIN**3*AIM(I,J))
C               WRITE(25,*) I,J,1.0/AIM(I,J)
               AIM(I,J) = (100.0/AIM(I,J))
C               IF(SQRT(FLOAT(I*I+J*J)).GT.80.0) AIM(I,J) = 0.0
 170         CONTINUE
 160     CONTINUE
         DO 180 J = 80, -80, -10
            WRITE(27,1000) (NINT(AIM(I,J)), I = -80, 120, 10)
 180     CONTINUE
      END IF
      RETURN

 1000 FORMAT (25I4)
      END

C LAST UPDATE: 
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C******************************
C**     MTZ_LABL_ASSIGN      **
C******************************
C
C
C
      SUBROUTINE MTZ_LABL_ASSIGN (NPRG, PRGLAB_IN, LINE, PRGLAB_OUT)
C
C      IMPLICIT NONE
C
C Purpose: Substitute MTZ program labels based on a set of MTZ label
C          assignments held in a string
C
C Author:  John W. Campbell, September 1997
C
C Arguments:
C
      INTEGER NPRG
      CHARACTER*30 PRGLAB_IN(*)
      CHARACTER*(*) LINE
      CHARACTER*30 PRGLAB_OUT(*)
C
C NPRG       (R)    No. of program labels
C PRGLAB_IN  (R)    Array of standard program labels
C LINE       (R)    Character string containing the MTZ assignments
C                   e.g FP=FCALC SIGFP=SIGOBS
C PRGLAB_OUT (W)    Array of program labels after substitution by any
C                   assignments made
C 
C
C====== GLOBALS:
C

C
C====== FUNCTION TYPES:
C
      INTEGER NXTTOK
C
C====== LOCALS:
C
      INTEGER NP
      INTEGER I
      INTEGER IL, M1, M2, M3, M4
      CHARACTER*30 STR1
      CHARACTER*30 STR2
C
C-------------------------------------------------------------------------------
C
      DO 10 NP = 1, NPRG
         PRGLAB_OUT(NP) = PRGLAB_IN(NP)
 10   CONTINUE

      IL = 0
 20   I = NXTTOK (LINE,' =,',IL, M1, M2)
      IF (I.LE.0) RETURN
      I = NXTTOK (LINE,' =,',IL, M3, M4)
      IF (I.LE.0) RETURN
      STR2 = LINE(M1:M2)
      CALL CCPUPC (STR2)
      DO 30 NP = 1, NPRG
         STR1 = PRGLAB_IN(NP)
         CALL CCPUPC(STR1)
         IF (STR1.EQ.STR2) THEN
            PRGLAB_OUT(NP) = LINE(M3:M4)
            GO TO 20
         END IF
 30   CONTINUE
      GO TO 20
      END

C
C FUNCTION 'ICMPR'
C ================
C
C THIS FUNCTION COMPARES THE INDICES OF A LAUE REFLECTION WITH THE
C INDICES OF A STANDARD REFLECTION (WITH OPTIONAL LAMBDA CHECK)
C
      FUNCTION ICMPR(IHKL1,IHKL2,ALMBDA,BLMBDA,KCS,ICS,LAMOPT,DLAM)
C
C PARAMETERS
C
C       IHKL1 (I)   3 WORD ARRAY HOLDING LAUE REFLN INDICES
C       IHKL2 (I)   3 WORD ARRAY HOLDING STANDARD REFLN INDICES
C      ALMBDA (I)   LAMBDA VALUE OF STANDARD REFLN
C      BLMBDA (I)   LAMBDA VALUE OF LAUE REFLN
C         KCS (I)   SIGN FLAG FOR STANDARD REFLN
C         ICS (I)   SIGN FLAG FOR LAUE REFLECTION
C      LAMOPT (I)   FLAG = .TRUE. INCLUDE LAMBDA CHECK, = .FALSE. DO NOT
C        DLAM (I)   TOLERANCE FOR LAMBDA CHECK
C
C RETURNS  -1  LAUE < STANDARD
C           0  LAUE = STANDARD
C           1  LAUE > STANDARD
C
C SPECIFICATION STATEMENTS
C ------------------------
C
      DIMENSION IHKL1(3),IHKL2(3)
      LOGICAL LAMOPT
C
C COMPARE INDICES
C ---------------
C
      ICMPR = 0
      DO 20 I = 1 , 3
         IF (IHKL1(I).LT.IHKL2(I)) GO TO 30
         IF (IHKL1(I).NE.IHKL2(I)) GO TO 40
 20   CONTINUE
      IF (ICS.LT.KCS) GO TO 30
      IF (ICS.GT.KCS) GO TO 40
      IF (.NOT.LAMOPT) RETURN
      IF (ABS(ALMBDA-BLMBDA).LE.DLAM) RETURN
      IF (BLMBDA.GT.ALMBDA) GO TO 40
C
C LAUE < STANDARD
C
 30   ICMPR = -1
      RETURN
C
C LAUE > STANDARD
C
 40   ICMPR = 1

      RETURN

      END

C LAST UPDATE: 
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C******************************
C**     READ_REFINT_MULT     **
C******************************
C
C
C
      SUBROUTINE READ_REFINT_MULT (MINDX, KDX, NSPOT, SIGCUT, REFSC, 
     +                             REFFILNAM, IUN)
C
      INCLUDE 'implicit_none.finc'

C
C Purpose: Read in reference intensities again and find match with
C          deconvoluted reflections
C
C Author:  John W. Campbell, September 1997
C
C Arguments:
C
      INTEGER NSPOT, KDX
      INTEGER IUN, MINDX
      REAL SIGCUT
      REAL REFSC
      CHARACTER*250 REFFILNAM
C
C SIGCUT       (R)    sigma cutoff
C 
C
C====== GLOBALS:
C

C
C====== FUNCTION TYPES:
C
      INTEGER KDMSTR
      INTEGER LENSTR
      INTEGER ICMPR
      LOGICAL CCPEXS
C
C====== LOCALS:
C
      INTEGER I
      INTEGER ISTAT
      INTEGER ITYP
      INTEGER ND(206)
      INTEGER IVAL(206)
      INTEGER IPOINT(6)
      INTEGER NUM_INP
      INTEGER MAXE
      INTEGER KERR, IERR, JERR
      INTEGER NLAB
      INTEGER IH, IK, IL, IPLATE, IPACK
      INTEGER IREF, KSYM
      INTEGER MULT, MINHARM, MAXHARM, INCHARM
      INTEGER ISPAT, IOVLD, IBAD, IMEAS
      INTEGER ICODE, ICLOS
      INTEGER MTZ_IDX
      INTEGER IEND
      INTEGER IDXL(3)
      INTEGER ICS, KCS, IIC
      INTEGER IDATA(3)
      REAL RESOL
      REAL ADATA(10)
      REAL ALMBDA
      REAL FVAL(206)
      REAL DLAM
      REAL XFD, YFD, ALAM
      REAL AI, SIGI
      LOGICAL LAMOPT
      LOGICAL CENTYP
      LOGICAL EXISTS
      LOGICAL EOF
      CHARACTER*120 STR
      CHARACTER*250 VALSTR
      CHARACTER*80 ERRSTR
      CHARACTER*2000 LIN 
      CHARACTER*30 PRGLAB(7)
      CHARACTER*1 CTYP(7)
      CHARACTER*30 PRGLAB_OUT(7)
      CHARACTER*250 MTZ_FILE


      DATA PRGLAB/'H','K','L','FP','SIGFP','    ','    '/
      DATA CTYP/'H','H','H','F','Q',' ',' '/

      MAXE = 80
      LAMOPT = .FALSE.
      STR = 'REFMTZ_DLAM'	
      CALL KDMF_GETVALUE (KDX, KDMSTR(STR),LENSTR(STR),  
     +             1, 1, 2, KDMSTR(VALSTR), FVAL, ND, IVAL, 
     +             NUM_INP, ISTAT, ITYP, KDMSTR(ERRSTR), 
     +             MAXE, KERR) 
      IF (KERR.NE.0) GOTO 810    
      DLAM = FVAL(1)
 
      CENTYP = .FALSE.
      STR = 'REFMTZ_FILETYP'
      CALL KDMF_GETVALSTR (KDX, KDMSTR(STR), LENSTR(STR),  
     +                 1, 1, 15, KDMSTR(VALSTR), ISTAT,
     +                 ITYP, KDMSTR(ERRSTR), MAXE, KERR)
      IF (KERR.NE.0) GOTO 810 
      CALL CCPUPC(VALSTR)
      IF (INDEX(VALSTR,'LAMBDA').NE.0) LAMOPT = .TRUE.
      IF (INDEX(VALSTR,'SIGN').NE.0) CENTYP = .TRUE.
 
      STR = 'REFMTZ_FILEASSIGN'
      CALL KDMF_GETVALSTR (KDX, KDMSTR(STR), LENSTR(STR),  
     +             1, 1, 200, KDMSTR(VALSTR), ISTAT,
     +             ITYP, KDMSTR(ERRSTR), MAXE, KERR)
      IF (KERR.NE.0) GOTO 810 
      LIN = VALSTR
      CALL CCPUPC(LIN)
      NLAB = 5
      IF (LAMOPT) THEN
         NLAB = 6
         PRGLAB(6) = 'LAM'
         CTYP(6) = 'R'
      END IF
      IF (CENTYP) THEN
         NLAB = NLAB + 1
         PRGLAB(NLAB) = 'SIGN'
         CTYP(NLAB) = 'I'
      END IF
      CALL MTZ_LABL_ASSIGN (NLAB, PRGLAB, LIN, PRGLAB_OUT)
      DO 160 I = 1, NLAB
         PRGLAB(I) = PRGLAB_OUT(I)
 160  CONTINUE

      DO 75 I = 1 , NLAB
         IPOINT(I) = -1
 75   CONTINUE

      MTZ_IDX = 1
      CALL FILEXT(REFFILNAM,'mtz',MTZ_FILE,IEND)
      EXISTS = CCPEXS (MTZ_FILE)
      IF (.NOT.EXISTS) THEN
         WRITE(IUN,6000)
         WRITE(IUN,2000)
         STOP
      END IF
      CALL LROPEN (MTZ_IDX, MTZ_FILE, 0, JERR) 
      IF (JERR.EQ.-1) THEN 
         WRITE(IUN,6000)
         WRITE(IUN,2000)
         STOP
      END IF
      CALL LRASSN (MTZ_IDX,PRGLAB,NLAB,IPOINT,CTYP)

      IF (LAMOPT) THEN
         CALL LIRLF_SORT  (MINDX, 5, IERR)    
      END IF
      CALL LIRLF_SORT  (MINDX, 10, IERR)    

      IREF = 1
      CALL LIRLF_GETREF (MINDX, IREF, IH, IK, IL, IPACK, IPLATE, 
     +                    KSYM, XFD, YFD, ALAM,
     +                    MULT, MINHARM, MAXHARM, INCHARM, AI, SIGI,
     +                    ISPAT, ICLOS, IMEAS, IBAD, IOVLD, 
     +                    ICODE, IERR)
      CALL LIRLF_HKLUNQ  (MINDX, IREF, IH, IK, IL, IERR)        
      IDXL(1) = IH
      IDXL(2) = IK
      IDXL(3) = IL
      ICS = 0
      IF (CENTYP) THEN
         ICS = 1
         IF (MOD(KSYM,2).EQ.0) ICS = -1
         CALL CENTR(IDXL,IIC)
         IF (IIC.EQ.1) ICS = 0
      END IF
      CALL LRREFF(MTZ_IDX,RESOL,ADATA,EOF)
      IF (EOF) GO TO 100
      IDATA(1) = NINT(ADATA(1))
      IDATA(2) = NINT(ADATA(2))
      IDATA(3) = NINT(ADATA(3))
      ALMBDA = 0.0
      KCS = 0
      IF (LAMOPT) THEN
         ALMBDA = ADATA(6)
         IF (CENTYP) KCS = NINT(ADATA(7))
      ELSE
         IF (CENTYP) KCS = NINT(ADATA(6))
      END IF

 80   IF (ICMPR(IDXL,IDATA,ALMBDA,ALAM,KCS,ICS,LAMOPT,DLAM)
     +      .LT.0) THEN 
      ELSE IF(ICMPR(IDXL,IDATA,ALMBDA,ALAM,KCS,ICS,LAMOPT,DLAM)
     +      .EQ.0) THEN
C
C====== Matching reflection found, store reference intensity
C
         
      CALL LIRLF_SET_REFINT(MINDX,IREF,ADATA(4)**2/REFSC,
     +                            2*ADATA(4)*ADATA(5)/REFSC,IERR)
C      WRITE(6,*) 'REF HKL', IDATA(1),IDATA(2),IDATA(3)
C      WRITE(6,*) 'LAU HKL', IDXL(1),IDXL(2),IDXL(3)
      ELSE
C
C====== No match, Laue>Standard, get next standard
C
 85      CALL LRREFF(MTZ_IDX,RESOL,ADATA,EOF)
         IF (EOF) GO TO 100

C====== Exclude reference intensities<cutoff*refsigma

         IF (ADATA(4).LT.SIGCUT*ADATA(5)) GO TO 85

         IDATA(1) = NINT(ADATA(1))
         IDATA(2) = NINT(ADATA(2))
         IDATA(3) = NINT(ADATA(3))
         ALMBDA = 0.0
         KCS = 0
         IF (LAMOPT) THEN
            ALMBDA = ADATA(6)
            IF (CENTYP) KCS = NINT(ADATA(7))
         ELSE
            IF (CENTYP) KCS = NINT(ADATA(6))
         END IF
         GO TO 80
      END IF
C
C====== Match or no match & Laue<Standard, get next Laue
C
 90   IREF = IREF + 1
      IF (IREF.LE.NSPOT) THEN
         CALL LIRLF_GETREF  (MINDX, IREF, IH, IK, IL, 
     +              IPACK, IPLATE, KSYM, XFD, YFD, ALAM,
     +              MULT, MINHARM, MAXHARM, INCHARM, AI, SIGI,
     +              ISPAT, ICLOS, IMEAS, IBAD, IOVLD, 
     +              ICODE, IERR)
         CALL LIRLF_HKLUNQ  (MINDX, IREF, IH, IK, IL, IERR)        
         IDXL(1) = IH
         IDXL(2) = IK
         IDXL(3) = IL
         ICS = 0
         IF (CENTYP) THEN
            ICS = 1
            IF (MOD(KSYM,2).EQ.0) ICS = -1
            CALL CENTR(IDXL,IIC)
            IF (IIC.EQ.1) ICS = 0
         END IF
         GO TO 80
      END IF 

 100  CALL LRCLOS (MTZ_IDX)    
  
      RETURN

 810  WRITE(IUN,2002) IERR, STR(1:LENSTR(STR))
      WRITE(IUN,2000)
      STOP

 6000 FORMAT (/,' ***  ERROR  ***  REFERENCE MTZ FILE NOT FOUND')

 2002 FORMAT (/,' ***  ERROR  ***  IN READ_REFINT_MULT',
     +        /,' KDMF_GETVALUE ERROR CODE', I4, 
     +        /,'STRING: ',A)
 2000 FORMAT (//,' ******** PROCESSING STOPPED *******')

      END
