
C LAST UPDATE:
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C**************************
C**  LSM_TOP_MULTS_LIRL  **
C**************************
C
C
CD-Routine: Reset to top of LIRL - LSM_TOP_MULTS_LIRL
C Prepare for LIRL access via LSM routines and reset the current retrieval
C position in the LIRL to the start of the list. Must be called before
C calling routines such LSM_NEXT_REFLN, LSM_NUM_NEXT, LSM_SCFAC and the LSM
C service routine LSM_NEXT_REFOBS and whenever the list needs to be re-read
C using these routines. Note that the routine sets various internal flags
C and calculates various intermediate values used in the scaling functions
C if any parameters etc. have been changed which could affect these.
CD-end
CD-Fortran:
      SUBROUTINE LSM_TOP_MULTS_LIRL (LINDX, SIGMA_CUT,
     +                              SPOV, OVLD, IERR)
CD-end
C
      INCLUDE 'implicit_none.finc'
C
C Purpose: Reset to top of LIRL; precalculate values for efficient scaling;
C          set 'use_reflection' flags
C
C Author:  Steffi Arzt, John Campbell, July 1997
C
C Arguments:
C
C
      INTEGER LINDX
      INTEGER IERR
      REAL SIGMA_CUT
      LOGICAL SPOV
      LOGICAL OVLD
C
CD-Parameters:
C  LINDX       i (R)   The index of the Laue Integrated Reflections List
C  SIGMA_CUT   r (R)   Omit reflections for which the intensity I is
C                      less than SIGMA_CUT*sig(I).
C  SPOV        l (R)   Flag = .true.  include spatially overlapped
C                                     reflections which have been
C                                     integrated,
C                           = .false. do not.
C  OVLD        l (R)   Flag = .true.  include intensity overloads,
C                           = .false. do not.
C  IERR        i (W)   Error flag =0 OK
C                                 =1 invalid LINDX or no spots present
C                                 =2 Error in sorting data
C                                 =3 Error from LSM_KDMCOPY
CD-end
C
C                      
C
C====== PARAMETERS:
C
      INCLUDE 'limits.finc'
C
C====== GLOBALS:
C
      INCLUDE 'use_reflns.finc'
      INCLUDE 'other_scale.finc'
      INCLUDE 'scp.finc'
      INCLUDE 'scps_counters.finc'
      INCLUDE 'lsm_flags.finc'
      INCLUDE 'found_pkpl.finc'
      INCLUDE 'abscor_muin.finc'
      INCLUDE 'scale_presets.finc'
      INCLUDE 'deconv.finc'

C====== FUNCTION TYPES
C
      REAL LSM_ABSC_MU
      INTEGER LSM_NORM_RANGE
      REAL STHLSQ
C
C====== LOCALS:
C
      LOGICAL REFL_OK

      INTEGER I
      INTEGER KNORM, KPLSC
      INTEGER ISIGN
      INTEGER IREF, NREFS     
      INTEGER IH, IK, IL 
      INTEGER IPACK, IPLATE   
      INTEGER KSYM
      INTEGER ISORT
      INTEGER KERR
      INTEGER MULT, MINHARM, MAXHARM 
      INTEGER ISPAT, IOVLD, IBAD, IMEAS
      INTEGER ICODE, ICLOS, JERR
      INTEGER INCHARM
      INTEGER IUSE_REF
      INTEGER ITEST
      REAL CELL(6)
      REAL STOL2, ALC2T
      REAL ALAM
      REAL ABSCOR_LAMFN
      REAL AI, SIGI
      REAL ABSCOR_NU, PSI_LOC, PSI_GLO
      REAL OB_LPFAC
      REAL C2T 
      REAL CSQ2T, SSQ2T
      REAL PSIPOL
      REAL FAC
      REAL XFD, YFD
      CHARACTER*80 ERRSTR

C
C-------------------------------------------------------------------------------
C
C
      ERRSTR = ' '
      IERR = 0
      ISIGN = 0

      CALL LIRLF_NUMREFS (LINDX, NREFS)
      IF (NREFS.LE.0) THEN
         IERR = 1
         RETURN
      END IF

!      CALL LSM_KDMCOPY (1, KERR, ERRSTR)
!      IF (KERR.NE.0) THEN
!         IERR = 3
!         RETURN
!      END IF

      CALL LIRLF_SORTORD (LINDX, ISORT)
      IF (ISORT.NE.11) THEN
         CALL LIRLF_SORT (LINDX, 11, KERR)
         IF (KERR.LT.0) THEN
            IERR = 2
            RETURN
         END IF
      END IF
      CELL(1) = A
      CELL(2) = B         
      CELL(3) = C         
      CELL(4) = ALPHA         
      CELL(5) = BETA         
      CELL(6) = GAMMA         
      CALL SETRSL(CELL(1),CELL(2),CELL(3),CELL(4),CELL(5),CELL(6))
C
C====== Find mu(lam_ref)
C
      AMULAMREF = LSM_ABSC_MU (REFABSLAM) 
C
C====== Set the 'use_reflection' flag for each reflection in the LIRL
C====== and set pre-calculated values
C
      DO 500 IREF = 1, NREFS
         CALL LIRLF_GETREF (LINDX, IREF, IH, IK, IL, IPACK, IPLATE, 
     +                 KSYM, XFD, YFD, ALAM,
     +                 MULT, MINHARM, MAXHARM, INCHARM, AI, SIGI,
     +                 ISPAT, ICLOS, IMEAS, IBAD, IOVLD, 
     +                 ICODE, JERR)
!         IF (MULT.LE.1) GO TO 500
         IF (MULT.EQ.0) GO TO 500
CC
C====== Determine  pre-calculated values
C 

C
C====== Set lambda function
C 
         ABSCOR_LAMFN = LSM_ABSC_MU(ALAM)
         IF (IABSOPT.EQ.2) ABSCOR_LAMFN = ABSCOR_LAMFN/AMULAMREF 

         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 (RADTYPE.EQ.1) THEN
            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)
C====== scal up intensities by 100 to avoid accuracy loss
              OB_LPFAC = OB_LPFAC * FAC 
            END IF
         END IF
C
C====== Calculate min and max nu- and psi-angles for local and
C       global absorption correction
C
         IF (.NOT.CYLINDER) THEN
            PSI_LOC = (ATAN(XFD/CTOF(IPACK,IPLATE)))*180.0/PI 
            ABSCOR_NU = ATAN(COS(PSI_LOC*PI/180.0)*
     +                     YFD/CTOF(IPACK,IPLATE))*180.0/PI
         ELSE
            PSI_LOC =(XFD/CTOF(IPACK,IPLATE))*180.0/PI
            ABSCOR_NU = ATAN(YFD/CTOF(IPACK,IPLATE))*180.0/PI
         END IF
         PSI_GLO = PSI_LOC - SPINDLE(IPACK)
C
C====== Get normalisation curve no.
C 
         KNORM = LSM_NORM_RANGE(ALAM) 
C
C====== Get plate/plate scaling range no.
C
         IF (IPLATE.EQ.1) THEN
            KPLSC = 1
         ELSE
            KPLSC = 0
            DO 150 I = 1, MAXRANGE
               IF (ALAM.GE.PLSCALELAMMIN(I).AND.
     +             ALAM.LE.PLSCALELAMMAX(I)) THEN           
                   KPLSC = I
                   GO TO 160
               END IF
 150        CONTINUE  
 160        CONTINUE
         END IF

         CALL LIRLF_LSM_GETRANGES (LINDX, IREF, KNORM, KPLSC, 
     +                         ABSCOR_NU, PSI_LOC, PSI_GLO,
     +                         JERR)      
         ITEST = 1
         REFL_OK = .TRUE.

         ITEST = 2
         IF (KPLSC.EQ.0) THEN
            REFL_OK = .FALSE.
            GO TO 200
         END IF

         ITEST = 3
         IF (IPACK.GT.NPK) THEN
            REFL_OK = .FALSE.
            GO TO 200
         END IF
         ITEST = 5
         IF (IPLATE.GT.NPL(IPACK)) THEN
            REFL_OK = .FALSE.
            GO TO 200
         END IF
         ITEST = 6
         IF (.NOT.PKPL_USE(IPACK,IPLATE)) THEN
            REFL_OK = .FALSE.
            GO TO 200
         END IF
         ITEST = 7
         IF (IMEAS.EQ.0) THEN
            REFL_OK = .FALSE.
            GO TO 200
         END IF
         ITEST = 8
         IF (IBAD.EQ.1) THEN
            REFL_OK = .FALSE.
            GO TO 200
         END IF
         ITEST = 9
         IF (IOVLD.EQ.1.AND. .NOT.OVLD) THEN
            REFL_OK = .FALSE.
            GO TO 200
         END IF
         ITEST = 10
         IF (ISPAT.EQ.1.AND. .NOT.SPOV) THEN
            REFL_OK = .FALSE.
            GO TO 200
         END IF
         ITEST = 11
         IF (ABS(AI).LT.SIGMA_CUT*SIGI) THEN
            REFL_OK = .FALSE.
            GO TO 200
         END IF
         ITEST = 13
         CALL LIRLF_GET_OUTLIER (LINDX, IREF, ICODE, JERR)
         IF (ICODE.NE.0) THEN
            REFL_OK = .FALSE.
            GO TO 200
         END IF
            ITEST = 14
         CALL LSM_ABSCRANGE (ABSCOR_NU, PSI_LOC, PSI_GLO, 
     +                          IPACK, JERR)
         IF (JERR.NE.0) THEN       
            REFL_OK = .FALSE.
            GO TO 200
         END IF
 200     IUSE_REF = 0
         IF (REFL_OK) IUSE_REF = 1
            CALL LIRLF_LSM_SETTEMP(LINDX, IREF, 
     +              ABSCOR_NU, PSI_LOC, PSI_GLO, STOL2, ALC2T, 
     +              ABSCOR_LAMFN, OB_LPFAC, KNORM, KPLSC, IUSE_REF, 
     +              JERR) 
 500  CONTINUE         

      IF (SIGN_SEP_USE) ISIGN = 1

      CALL LIRLF_LSM_START (LINDX, ISIGN, JERR)
      
      IF (JERR.LT.0) THEN
         IERR = 1
         RETURN
      END IF

      RETURN

      END
