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',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