
CD-Section: Multiples deconvolution
C These are routines for retrieving the reflections makrked as multiples from 
C the LIRL-list for multiples deconvolution. The deconvoluted multiples are 
C then added with scaled intensities to the LIRL-reflection list
CD-end

C LAST UPDATE: 
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C**********************************
C**     LSM_MULTIPLES_DECONV     **
C**********************************
C
CD-Routine: Multiples deconvolutions LSM_MULTIPLES_DECONV
C This routine deconvolutes reflections marked as multiples (energy overlapps)
C and adds their scaled(!) intensities to the LIRL used. The wavelength will 
C be  stored as 0.0 and the multiples flag with be set to MULT=0 to identify 
C deconvoluted multiples when needed.  
CD-end
CD-Fortran:

      SUBROUTINE LSM_MULTIPLES_DECONV (LINDX, TUNE,  
     +                   IRFTYP, NUMOUT, IERR, MESSAGE)
CD-end
C
      INCLUDE 'implicit_none.finc'
C
C Purpose: Multiples deconvolution and storage
C
C Author:  S. Arzt, September 1997
C
C Arguments:
C
      INTEGER LINDX
      INTEGER IRFTYP
      INTEGER NUMOUT(12)
      INTEGER IERR
      CHARACTER*120 MESSAGE
      REAL TUNE(3)

CD-Parameters:
C  LINDX     i (R)     The index of the Laue Integrated Reflections List 
C  TUNE()    r (R)     Tuning parameters specific to the refinement type
C                      If LSQMQL   TUNE(1) = tolerance (ACC)
C                                  TUNE(2) = step size (H)
C  IRFTYP    i (R)     Refinement routine type =1 Use LSQMIN
C                                                   =2 Use LSQMQL
C  NUMOUT()  i (W)     Array containing various details of the deconvolution
C  IERR      i (W)     Error flag = 0 OK
C                                 = 1 Error
C  MESSAGE   c (W)     Error message if IERR is non-zero
CD-end
C
C====== PARAMETERS:
C
      INCLUDE 'limits.finc'
C
C====== GLOBALS:
C
      INCLUDE 'use_reflns.finc'
      INCLUDE 'scale_presets.finc'
      INCLUDE 'other_scale.finc'
      INCLUDE 'scp.finc'
      INCLUDE 'scps_counters.finc'
      INCLUDE 'deconv.finc'
      INCLUDE 'lsm_flags.finc'

C
C====== FUNCTION TYPES:
C
      EXTERNAL LSM_MULTFUN_F
      EXTERNAL LSM_MULTFUN_SIG
      INTEGER KDMSTR
      INTEGER LENSTR      
      INTEGER LSC_NEXT_MULTREFLN
      INTEGER LSM_INDX       
      INTEGER LSM_NORM_RANGE
      REAL LSM_ABSC_MU
      REAL STHLSQ
C
C====== LOCALS:
C
      INTEGER I, J, K, IHRM, NNEG
      INTEGER LAMEXT, M1N2, M2N3, M3N4, ISAVE
      INTEGER NBADSC, NEGTYP
      INTEGER NPOS, NADD, N3SIG
      INTEGER NUNIQ, NSNMTX
      INTEGER JERR, KERR
      INTEGER IREF, NSPOT1, NSPOT2, NR, NEQN, NTERMS
      INTEGER IH, IK, IL, NH, NK, NL, IHUNQ, IKUNQ, ILUNQ
      INTEGER IPACK, IPLATE
      INTEGER KPLS, KNORM  
      INTEGER KSYM, KSYMM(MXEQN), IUSE
      INTEGER MULT, MINHARM, MAXHARM, INCHARM, MAXHM, MINHM
      INTEGER ISPAT, ICLOS, IMEAS, IBAD, IOVLD, ICODE
      INTEGER MULTM(MXEQN) 
      INTEGER MINHAM(MXEQN)
      INTEGER MAXHAM(MXEQN) 
      INTEGER INCM(MXEQN)
      INTEGER IHARM(MXEQN)
      INTEGER IPK(MXEQN), IPL(MXEQN)
      INTEGER NOK, NFEW
      INTEGER NSTRANGE      
      INTEGER MAXE
      INTEGER IVAL(MAXVARR)           
      REAL FVAL(MAXVARR)
      REAL ABSC_NU, PSI_LOC, PSI_GLO             
      REAL OB_LPFAC
      REAL ABSCOR_LAMFN, STOL2, AL3C2T
      REAL AI, SIGMA, SC
      REAL XFD, YFD, XF(MXEQN), YF(MXEQN), ALAM
      REAL AXX(MXTRM)
      REAL ASIGXX(MXTRM)
      REAL ALM(MXEQN,MXTRM)
      REAL DSPAC(MXEQN,MXTRM)
      REAL SCEQ(MXEQN,MXTRM)
      REAL ASIGFF(MXEQN)
      REAL ALNOD
      REAL C2T 
      REAL CSQ2T, SSQ2T
      REAL PSIPOL
      REAL FAC
      REAL REFINT
      REAL SCM(MXEQN) 
      REAL NORMLAMMAX_SAVE
      REAL FMIN
      REAL SCPCP(MXPAR)
      LOGICAL EQN(MXEQN)
      LOGICAL ENDE, ABSNT, ENTRY
      LOGICAL MULTFL
      LOGICAL TERMFL(MXTRM)
      LOGICAL SINGLE_FLAG(MXTRM)
      LOGICAL SINGLE_EQN(MXEQN)
      CHARACTER*120 ERRSTR
      CHARACTER*80 STR
      CHARACTER*80 VALSTR
      DOUBLE PRECISION AXX_D(MXTRM)
      DOUBLE PRECISION SIGMA_D(MXTRM)
      DOUBLE PRECISION FVECC(MXEQN)
      DOUBLE PRECISION W((MXEQN+6)*MXTRM+MXEQN)
      DOUBLE PRECISION ACC, STEP, FMINDP
C
C INITIALISE
C
      LAMEXT = 0
      M1N2 = 0
      M2N3 = 0
      M3N4 = 0
      NSTRANGE = 0
      NBADSC = 0
      NOK = 0
      NSNMTX = 0
      NFEW = 0
      NUNIQ = 0
      NNEG = 0
      NPOS = 0
      NADD = 0
      N3SIG = 0
      NEGTYP = 1
      MAXHM = 1
      MINHM = MXTRM
      NTERMS = 0
      IERR = 0
      MAXE = 120
      KERR = 0
      ENDE = .FALSE.
      MESSAGE = ' '
      VALSTR = ' '
      ERRSTR = ' '
      DO 160 I = 1, MXEQN
         EQN(I) = .TRUE.
 160  CONTINUE

      ACC = 0.001
      STEP = 0.5D-5   
      MAX_LAMBDA = 0.0
      MIN_LAMBDA = 1.0E7


      CALL LIRLF_NUMREFS  (LINDX, NSPOT1)

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

C
C ====== copy refined scaling parameters
C
      DO 330 I = 1, MXPAR
         SCPCP(I) = SCP(I)
 330  CONTINUE

C
C ====== set temporarily maximum limit of last lambda range to 
C        max. lambda of set, reset at end of deconvolution

      DO 10 IREF = 1, NSPOT1
         CALL LIRLF_GETREF  (LINDX, IREF, IH, IK, IL, 
     +             IPACK, IPLATE, 
     +             KSYM, XFD, YFD, ALAM,
     +             MULT, MINHARM, MAXHARM, INCHARM, AI, SIGMA,
     +             ISPAT, ICLOS, IMEAS, IBAD, IOVLD, 
     +             ICODE, IERR)
         IF(ALAM.GT.MAX_LAMBDA) MAX_LAMBDA = ALAM
         IF(ALAM.LT.MIN_LAMBDA) MIN_LAMBDA = ALAM
 10   CONTINUE

      DO 250 K = MAXRANGE, 1, -1
         IF(NORMRAN(K)) THEN
            NORMLAMMAX_SAVE = NORMLAMMAX(K)
            ISAVE = K
            NORMLAMMAX(K) = MAX_LAMBDA
!            DO 350 I = 1, NRAN
               I = ISAVE
               STR = 'NORM_COEFF_'
               CALL STR_ADDI(STR,I,0)
               IVAL(1) = NNORM(I)-1
               FVAL(2) = NORMLAMMIN(I) 
               FVAL(3) = NORMLAMMAX(I)
               DO 360 J = 1, POLCOEFFS
                  FVAL(J+3) = SCP(NCSCP(6)+J+(I-1)*POLCOEFFS)
 360           CONTINUE
               CALL KDMF_SETVALUE (KINDX, KDMSTR(STR), LENSTR(STR),
     +              0, 0, KDMSTR(VALSTR), LENSTR(VALSTR), IVAL,  
     +              FVAL, IVAL(1)+4, KDMSTR(ERRSTR), MAXE, KERR)
               IF (KERR.NE.0) GOTO 810    
! 350        CONTINUE	
            GO TO 260
         END IF
 250  CONTINUE

 260  CALL LSM_SET_RFLAGS ( -1, -1, -1, .TRUE., .FALSE., .FALSE., 
     +                    .FALSE., .FALSE.)

      CALL  LSM_REFINE (LINDX, .FALSE., IRFTYP, TUNE, FMIN,
     +                        IERR, MESSAGE)

      CALL LIRLF_SORT (LINDX, 10, IERR)
      CALL LIRLF_SORT (LINDX, 11, IERR)

      CALL LSM_TOP_MULTS_LIRL (LINDX, SIGCUT_USE,
     +                         SPOV_USE, OVLD_USE, IERR)

      CALL LSM_CALC_PRESETS 

 100  NR = LSC_NEXT_MULTREFLN (IERR)

      IF (NR.LE.-1.OR.IERR.EQ.1) THEN
C         CALL LWCLOS(2,3)


C====== reset lambda limit for max. range and old scaling parameters

         DO 340 I = 1, MXPAR
            SCP(I) = SCPCP(I)
 340     CONTINUE

         NORMLAMMAX(ISAVE) = NORMLAMMAX_SAVE

!         DO 370 I = 1, NRAN
            I = ISAVE
            STR = 'NORM_COEFF_'
            CALL STR_ADDI(STR,I,0)
            IVAL(1) = NNORM(I)-1
            FVAL(2) = NORMLAMMIN(I) 
            FVAL(3) = NORMLAMMAX(I)
            DO 380 J = 1, POLCOEFFS
               FVAL(J+3) = SCP(NCSCP(6)+J+(I-1)*POLCOEFFS)
 380        CONTINUE
            CALL KDMF_SETVALUE (KINDX, KDMSTR(STR), LENSTR(STR),
     +           0, 0, KDMSTR(VALSTR), LENSTR(VALSTR), IVAL, FVAL, 
     +           IVAL(1)+4, KDMSTR(ERRSTR), MAXE, KERR)
            IF (KERR.NE.0) GOTO 810    
! 370     CONTINUE	

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

         MARKUP_REQUIRED = .TRUE.
         SELECT_REQUIRED = .TRUE.         
C
C OUTPUT COUNTS
C
         CALL LIRLF_NUMREFS  (LINDX, NSPOT2)

         NUMOUT(1) = NBADSC
         NUMOUT(2) = NUNIQ
         NUMOUT(3) = NOK
         NUMOUT(4) = NSTRANGE  
         NUMOUT(5) = NFEW
         NUMOUT(6) = M1N2
         NUMOUT(7) = M2N3
         NUMOUT(8) = M3N4
         NUMOUT(9) = NPOS
         NUMOUT(10) = NSNMTX 
         NUMOUT(11) = NSPOT2 - NSPOT1
         NUMOUT(12) = N3SIG

         RETURN

      END IF

      IF (NR.EQ.1) GO TO 100
      MULTFL = .FALSE.
      MAXHM = 0

      DO 20 I = 1, NR
         CALL LIRLF_GETREF (LINDX, LSM_INDX(I), IH, IK, IL, IPACK,  
     +          IPLATE,KSYM, XFD, YFD, ALAM,
     +          MULT, MINHARM, MAXHARM, INCHARM, AI, SIGMA,
     +          ISPAT, ICLOS, IMEAS, IBAD, IOVLD, 
     +          ICODE, IERR)
         MULTM(I) = MULT
         MINHAM(I) = MINHARM
         MAXHAM(I) = MAXHARM
         IF(MAXHARM .GT.MAXHM) MAXHM = MAXHARM
         IF(MINHARM .LT.MINHM) MINHM = MINHARM
         INCM(I) = INCHARM
         IF(MULT.GT.1) MULTFL = .TRUE.
 20   CONTINUE
      IF (.NOT.MULTFL) GO TO 100
      NUNIQ = NUNIQ + 1
      IF (NR.GT.MXEQN) THEN
         IERR = 1
         MESSAGE = ' MAXIMUM NUMBER OF EQUATIONS FOR MULTIPLES'
     +             //' DECONVOLUTION OF '
         CALL STR_ADDI (MESSAGE, MXEQN, 1)
         MESSAGE = MESSAGE//' EXCEEDED'
         RETURN
      END IF
      DO 140 I = 1, MXEQN 
         SINGLE_EQN(I) = .FALSE.
         DO 150 J = 1, MXTRM
            COEF(I,J) = 0.0
            ALM(I,J) = 0.0
            DSPAC(I,J) = 0.0
            IHARM(J) = 0
            SINGLE_FLAG(J) = .FALSE.
 150     CONTINUE
 140  CONTINUE            
      NTERMS = 0
      NEQN = 0
      DO 130 I = 1, NR
         CALL LIRLF_GETREF (LINDX, LSM_INDX(I), IH, IK, IL, IPACK,  
     +          IPLATE,KSYM, XFD, YFD, ALAM,
     +          MULT, MINHARM, MAXHARM, INCHARM, AI, SIGMA,
     +          ISPAT, ICLOS, IMEAS, IBAD, IOVLD, 
     +          ICODE, IERR)
         CALL LIRLF_LSM_SCALOBS (LINDX,LSM_INDX(I), 
     +          IPACK, IPLATE, AI, SIGMA, ALAM, REFINT,
     +          ABSC_NU, PSI_LOC, PSI_GLO, STOL2,
     +          AL3C2T, ABSCOR_LAMFN, OB_LPFAC,
     +          KNORM, KPLS, IUSE, IERR)
         CALL LIRLF_NODUNQ (LINDX, LSM_INDX(I), NH, NK, NL, ALNOD, IERR)
         CALL LIRLF_HKLUNQ (LINDX, LSM_INDX(I), IHUNQ,IKUNQ,ILUNQ, IERR)
         CALL LSM_CALCSCFAC (SC, IPACK, IPLATE, KPLS, KNORM,
     +          ABSC_NU, PSI_LOC, PSI_GLO, ABSCOR_LAMFN,  
     +          STOL2, ALAM, AL3C2T, OB_LPFAC,  .TRUE.,
     +          PQ00_GLOB_STORE, P00_LOC_STORE, AKNORM_STORE,
     +          ANORMREF_STORE, IERR)
         KSYMM(NEQN+1) = KSYM
         XF(NEQN+1) = XFD
         YF(NEQN+1) = YFD
         IPK(NEQN+1) = IPACK
         IPL(NEQN+1) = IPLATE
         WT(NEQN+1) = 1.0/(SIGMA*SIGMA)
         SCM(NEQN+1) = SC
         AFF(NEQN+1) = AI
         ASIGFF(NEQN+1) = SIGMA
         IF(MULT.EQ.1) THEN
            SINGLE_EQN(I) = .TRUE.
            IHRM = 0
            IF(NH.NE.0) THEN
               IHRM = ABS(IHUNQ/NH)
            ELSE IF (NK.NE.0) THEN
               IHRM = ABS(IKUNQ/NK)
            ELSE IF (NL.NE.0) THEN
               IHRM = ABS(ILUNQ/NL)
            END IF
            SINGLE_FLAG(IHRM) = .TRUE.
            MINHAM(I) = IHRM
            MAXHAM(I) = IHRM
            MINHARM = IHRM
            INCM(I) = 1
         END IF
         DO 40 IHRM = MINHAM(I), MAXHAM(I), INCM(I)
           ENTRY = .FALSE.
            IH = IHRM*NH
            IK = IHRM*NK
            IL = IHRM*NL
            CALL KSM_SYSABS (IH,IK,IL,ABSNT)         
            IF (ABSNT) THEN
               GO TO 40
            END IF
            ALAM = (ALAM*(MINHARM*1.0))/(IHRM*1.0)
            KNORM = LSM_NORM_RANGE(ALAM) 
            IF(KNORM.EQ.0) THEN
               IF(ALAM.LT.NORMLAMMIN(1)) THEN
                  NBADSC = NBADSC + 1
                  GO TO 130
               ELSE
                  KNORM = ISAVE
                  LAMEXT = LAMEXT + 1
                  GO TO 240
 230              CONTINUE
               END IF
            END IF
 240        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)))
            AL3C2T = ALAM**3/C2T
            OB_LPFAC = EXP(COVFAC/C2T) * 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)
                     OB_LPFAC = OB_LPFAC * FAC 
               END IF
            END IF
            IF (IPLATE.EQ.1) THEN
               KPLS = 1
            ELSE
               KPLS = 0
               DO 180 K = 1, MAXRANGE
                  IF (ALAM.GE.PLSCALELAMMIN(K).AND.
     +                ALAM.LE.PLSCALELAMMAX(K)) THEN           
                      KPLS = K
                      GO TO 190
                  END IF
 180           CONTINUE  
 190           CONTINUE
            END IF

            CALL LSM_CALCSCFAC (SC, IPACK, IPLATE, KPLS, KNORM,
     +          ABSC_NU, PSI_LOC, PSI_GLO, ABSCOR_LAMFN,  
     +          STOL2, ALAM, AL3C2T, OB_LPFAC,  .TRUE.,
     +          PQ00_GLOB_STORE, P00_LOC_STORE, AKNORM_STORE,
     +          ANORMREF_STORE, IERR)
            IF (SC.GT.0.0) THEN     
               COEF(NEQN+1,IHRM) = 1.0/(SC)
               ALM(NEQN+1,IHRM) = ALAM
               DSPAC(NEQN+1,IHRM) = SQRT(1.0/(4.0*STOL2))
               SCEQ(NEQN+1,IHRM) = SC
            ELSE
                GO TO 130
            END IF
 40      CONTINUE
         NEQN = NEQN + 1
 130  CONTINUE

      IF (NEQN.EQ.0) THEN
         NSTRANGE = NSTRANGE + 1
         GO TO 100
      END IF

      NTERMS = 0
      DO 110 IHRM = 1,MAXHM
         ENTRY = .FALSE.
         DO 80 I = 1, NEQN
            IF (COEF(I,IHRM).NE.0.0) ENTRY = .TRUE.
 80      CONTINUE
         IF (ENTRY) THEN
            NTERMS = NTERMS + 1
            IHARM(NTERMS) = IHRM
            DO 888 I = 1, NEQN
               COEF(I,NTERMS) = COEF(I,IHRM)
               DSPAC(I,NTERMS) = DSPAC(I,IHRM)
               ALM(I,NTERMS) = ALM(I,IHRM)
               SCEQ(I,NTERMS) = SCEQ(I,IHRM)
 888        CONTINUE
         END IF
 110  CONTINUE

      IF (NEQN.GE.NTERMS.AND.NTERMS.GT.0) THEN
         NOK =  NOK + 1
      ELSE
         NFEW = NFEW + 1
         IF(NEQN.EQ.1.AND.NTERMS.EQ.2) THEN
            M1N2 = M1N2 + 1
         ELSE IF(NEQN.EQ.2.AND.NTERMS.EQ.3) THEN
            M2N3 = M2N3 + 1
         ELSE IF(NEQN.EQ.3.AND.NTERMS.EQ.4) THEN
            M3N4 = M3N4 + 1
         ELSE
         END IF
         GO TO 100
      END IF
 500  CONTINUE


C====== SET STARTING VALUES 

      DO 300 I = 1, NTERMS
         AXX_D(I) = AFF(1)/NTERMS
 300  CONTINUE

C====== SOLVE FOR F's

      CALL LSQMQL(NEQN,NTERMS,AXX_D,ACC,STEP,LSM_MULTFUN_F,
     +              FMINDP,FVECC,JERR,W)  

C====== CONVERT TO I's

      DO 310 I = 1, NTERMS
         AXX_D(I) = AXX_D(I)*AXX_D(I)
 310  CONTINUE

C====== FIND SIGMAS(I)

      CALL LSQSIG (NEQN,NTERMS,AXX_D,LSM_MULTFUN_SIG,
     +             SIGMA_D,FVECC,JERR, W)
      IF (JERR.EQ.2) THEN
         NSNMTX = NSNMTX + 1
         GO TO 100
      END IF

C====== PUT DECONVOLUTED REFLECTIONS INTO LIST

      DO 320 J = 1, NTERMS
         TERMFL(J) = .FALSE.         
 320  CONTINUE

      DO 220 I = 1, NEQN
         DO 210 J = 1, NTERMS
            IF (IHARM(J).GT.0.AND.SCEQ(I,J).NE.0.0) THEN
               IF (.NOT.TERMFL(J)) THEN
                  K = IHARM(J)
                  IF(SINGLE_FLAG(K)) GO TO 210
                  AXX(J) = AXX_D(J)
                  ASIGXX(J) = SIGMA_D(J)
                  CALL LIRLF_ADDREF  (LINDX, 
     +               K*NH, K*NK, K*NL, 
     +               IPK(I), IPL(I), 1, XF(I), YF(I), 
     +               ALM(I,J), 0, 0, 0, 0, 
     +               AXX(J), ASIGXX(J),   
     +               0, 0, 1, 0, 0, ICODE, IERR)                 
                  TERMFL(J) = .TRUE.
                  NADD = NADD + 1
                  IF(AXX(J).GE.SIGCUT_USE*ASIGXX(J)) N3SIG = N3SIG+1
               END IF
            END IF
 210     CONTINUE
 220  CONTINUE
    
      NPOS = NPOS + 1

      GO TO 100

!810   ERRSTR = ' Error code'
!      CALL STR_ADDI (ERRSTR, KERR, 1)
!      CALL STR_ADDS (ERRSTR, 
!     +  'from kdmf_get/setvalue for parameter', 1)
!      CALL STR_ADDS (ERRSTR, STR, 1)
!      IERR = 1
!      MESSAGE = ERRSTR
810   MESSAGE = ' Error code'
      CALL STR_ADDI (MESSAGE, KERR, 1)
      CALL STR_ADDS (MESSAGE, 
     +  'from kdmf_get/setvalue for parameter', 1)
      CALL STR_ADDS (MESSAGE, STR, 1)
      IERR = 1

      RETURN

      END
