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