C== REEK == SUBROUTINE REEK(IHKLSTR,MODE) C ============================= C IMPLICIT NONE C ! C ! This routine replaces an earlier version and provides for C ! generalization of goniostat angles etc. This is adapted from C ! routines in MADNES from which the following comments are drawn; C ! C ! This routine replaces an earlier version written by C ! Albrecht Messerschmidt. C ! The algorithm uses the geometric treatment of G.N. Reeke. C ! The code is derived from that originally written by C ! R.M. Sweet for prediction of reflections occuring on C ! oscillation photographs, but has been generalised to allow C ! for a general X-ray beam direction (defined by vector S0). C ! C ! Harry Powell MRC-LMB Cambridge, 08-Mar-2001 C ! C ! Peter Brick, Andrew Leslie, Jean Claude Thierry, Alan J. Wonacott C ! C ! 10-Feb-1992 J. W. Pflugrath Cold Spring Harbor Laboratory C ! Add ROTS and ROTE to argument list and remove references to PHIS, PHIE C ! C ! 29-Jan-1988 J. W. Pflugrath Cold Spring Harbor Laboratory C ! Last update for floating point reflection positions C ! C ! 13-Nov-1987 A. G. W. Leslie, P. Brick, A. J. Wonacott Imperial College C ! Implementation of Reeke algorithm. C ! C ! *************************************************************** C---- Modified from subroutine OSCF1 from UCLA SCAN-12 SYSTEM C C---- Contains George Reeke's geometric treatment C C IHKLSTR Array containing reflections for strategy option C MODE Indicates where REEK has been called from C 0 Most places C 1 Called from NEWLIST C 2 Called from TESTOVER C C C March 1978 R.M. Sweet C C On entry: C C PHIBEG beginning rotation angle about Z for this pack C PHIEND end rotation angle about Z for this pack C DELPHI(I=1,3) missetting angles for the X, Y and Z axes C AMAT(3,3) contains the orientation matrix X = AMAT . H C C C C C .. Include files .. C&&*&& include ../inc/parameter.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file parameter.h C---- START of include file parameter.h C C PARAMETERS C IYLENGTH.. maximum number of I*2 words of data in the C "fast" (ie most rapidly changing) direction in the C digitised image. This will be HALF the number of pixels C for film data (each pixel is stored in one byte) C but will equal the number of pixels for IP data. C IXWDTH... The maximum number of "stripes" of data in the scanned image C ie the number of pixels in the "slow" direction C (This is the Y direction in the MOSFLM convention) C Note that the array "IMAGE" used to store the image is C declared as size IYLENGTH*IXWDTH I*2 words for IP data C and 2*IYLENGTH*IXWDTH BYTES for film data. C If this exceeds the C available memory, set ixwdth=1, recompile program C and use keyword "NOCORE" when running program. C Note that for the POSTREF and ADDPART options, C two images have to be stored in memory at once so C IXWDTH should be twice the number of records in an C image. C MAXHEAD maximum length of image header (in 4 byte words) C NREFLS.... maximum number of spots per film in generate file (10000) C MAXBOX.... maximum number of pixels in measurement box (1000) C MAXDIM.... maximum box size in either direction (pixels) (41) C MAXPAX.... maximum number of packs per generate file (1000) C MXDOV2..... maxdim/2 C MAXBUFF... maximum size of buffer (I*2) for storing ods C of active spots in subroutine meas(20000). C Must be .GE. MAXBOX*(NNLINE-1) for subroutine process C MREF...... maximum number of reflections to be used in post C refinement (6000) C NEXPAND... maximum number of expansions of the input measurement C box (2) C NMASKS.... maximum number of different profiles (25). Note the C connection between this parameter and NNLINE C NVECT..... maximum number of vectors for storing scanned image C in filmplot (10000) C NIMAX..... maximum number of images to be used together in C postrefinement (NADD or WIDTH options) (30) C NNLINE... maximum number of boundary lines for setting up C the areas for profile fitting. The maximum possible C number of standard profiles will be (NNLINE-1)**2 C although for a circular detector the actual number C may be less than this as some boxes will lie entirely C outside the detector. C NREJMAX... Maximum number of rejected background pixels, resulting C either from overlap of adjacent spots or outliers from C the background plane C NSPOTS... Maximum number of found spots (for autoindexing) that can C be stored (for all images). Also maximum number in C a file wriitten by IMSTILLS that can be C stored/displayed/edited. THis must be an even number C MCOLS.... Number of columns in output MTZ file C MCOLSTR.. Number of columns in output MTZ file for strategy option C C MTZ Orientation block C MBLENG is total length of block, MBLINT, MBLREA are numbers C of integers & reals C NRPAR.... Maximum number of refineable parameters for detector C positional refinement (subroutine RDIST) C NSEGMAX.. Maximum number of segments in STRATEGY C MULTMAX... Maximum number of observations with same hkl in COMPLETE C MAXDIFF... Maximum number of different packs that a given hkl occurs on C NRESBIN... Maximum number of resolution bins (COMPLETE) C C MAXIMG... Maximum number of images that can be read in using the IMAGE C keyword or the "read Image" menu option. C MXSPOT... Maximum number of spots that can be found on one image C (before rejection on spot size). C MXCENT... Maximum number of active spots during spot finding C (findspots) C C MGRA, NGRA... maximum number of reflections and images over which a C reflection can be spread for postrefinement. C C .. Parameters .. INTEGER IXWDTH PARAMETER (IXWDTH=8192) c PARAMETER (IXWDTH=12288) INTEGER IYLENGTH PARAMETER (IYLENGTH=4096) c PARAMETER (IYLENGTH=6144) INTEGER MAXHEAD PARAMETER (MAXHEAD=5000) INTEGER MAXBOX PARAMETER (MAXBOX=1500) INTEGER MAXBUFF PARAMETER (MAXBUFF=20000) INTEGER MAXDIM PARAMETER (MAXDIM=41) INTEGER MAXPAX PARAMETER (MAXPAX=1000) INTEGER MXDOV2 PARAMETER (MXDOV2=MAXDIM/2) INTEGER NEXPAND PARAMETER (NEXPAND=2) INTEGER NMASKS PARAMETER (NMASKS=25) INTEGER NREFLS PARAMETER (NREFLS=100000) INTEGER MREF PARAMETER (MREF=6000) INTEGER NVECT PARAMETER (NVECT=10000) INTEGER NIMAX PARAMETER (NIMAX=30) INTEGER NNLINE PARAMETER (NNLINE=6) INTEGER NREJMAX PARAMETER (NREJMAX=600) INTEGER NSPOTS PARAMETER (NSPOTS=5000) INTEGER MCOLS PARAMETER (MCOLS=16) INTEGER MCOLSTR PARAMETER (MCOLSTR=6) INTEGER NREFSTR C C---- Each reflection for strategy run needs MCOLSTR I*2 words C plus an I*4 word for the merging C PARAMETER (NREFSTR = IXWDTH*IYLENGTH/(2+MCOLSTR)) INTEGER MBLENG,MBLINT,MBLREA PARAMETER (MBLENG=185,MBLINT=29,MBLREA=156) INTEGER NRPAR PARAMETER (NRPAR=14) INTEGER NSEGMAX PARAMETER (NSEGMAX=100) INTEGER MULTMAX PARAMETER (MULTMAX=100) INTEGER MAXDIFF PARAMETER (MAXDIFF=100) INTEGER NRESBIN PARAMETER (NRESBIN=20) INTEGER MXSPOT PARAMETER (MXSPOT=5000) INTEGER MAXIMG PARAMETER (MAXIMG=100) INTEGER NPIXBG PARAMETER (NPIXBG=51) INTEGER MXCENT PARAMETER (MXCENT=500) INTEGER NGRA,MGRA PARAMETER (NGRA=20) PARAMETER (MGRA=20000) C&&*&& end_include ../inc/parameter.f C C .. C .. Scalar Arguments .. INTEGER MODE C .. C .. Array Arguments .. INTEGER*2 IHKLSTR(MCOLSTR,NREFSTR) C C C .. Local Scalars .. real a1,sca1,avecx,vecx,p1,p2,px1,px2 REAL A,AVEC,DELEPS1,DJUNK,DSTMAX2,DTOR,FP,FP2,FQ,FR,GAMMAX,PA,PB, + PC,PD,PI,PMAX,PMAXE,PMIN,PMINE,PX,PY,PZ,QMAXE,QMINE,S1, + S1P2R2,S2,S3,S4,S5,S5P,S6,S6P,SIN2T,SINSQ,SINTH,T1,T2, + TANTMAX,DELEPS2,DRATIO,PXCEN,PYCEN,EPS, + DSTMIN2 integer istat,j1,j2 INTEGER I,IER,IFAIL,IFREC,ILOOP,IP,IPLB,IPLE,IQ,IQLB,IQLE, + IQMAX,IQMIN,IR,IRMAX,IRMIN,ISIGN,J,K, + KT,L,NLOOP,NRT,ICOUNT,ISPOT,INVFLAG,ISWUNG, + ISYSAB,IFLAG LOGICAL ABSNT C .. C .. Local Arrays .. real s0(3),pmn(2),pmx(2),xr(3) REAL B0BEG(3,3),B0END(3,3),BBEG(3,3),BEND(3,3),CA(3,3),P(3,3,2), + P0(3,3,2),P0OLD(3,3,2),P1H(2),P1H0(2),P2H(2),P2H0(2),P3H(2), + P3H0(2),POLD(3,3,2),PP(3,4,2),PX0(2),PY0(2),PZ0(2),Q(3,3,2), + QU(2),RLB(2),RLE(2),RMPB(3,3),RMPE(3,3),RS0(2),RS1(2),RT(2), + RU0(2),RU1(2),RU2(2),T(4,4),VEC(3),X12(2),Y12(2),Z12(2), $ ORTMAT(3,3),rotmat(3,3),phiaxis(3) INTEGER NRTA(2) C .. C .. External Subroutines .. EXTERNAL DSTAR,JSWTCH,LIMITS,LOOPST,MATMUL3,MINV33,QUAD2,SETAX, + SPTEST,STORSPOT,SURMP,SWITCH,MSYSABS,XYSPOT,WMTZSP, + EPSLON C .. C .. External Functions .. REAL DOT EXTERNAL DOT C .. C .. Intrinsic Functions .. INTRINSIC ABS,ATAN,ATAN2,INT,MAX,MIN,MOD,NINT,REAL,SIGN,SIN,SQRT C .. C .. Common blocks .. C&&*&& include ../inc/cell.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file cell.h C---- START of include file cell.h C C CELL cell dimensions (real space) C RCELL reciprocal cell parameters in dimensionless rlu C C .. Arrays in Common /CELLCOM/ .. REAL UMAT,BMAT,GMAT,CELL,RCELL,UMATCELL INTEGER LCELL,ICRYST,NUMSPG,NLAUE C .. C .. Common Block /CELLCOM/ .. COMMON /CELLCOM/UMAT(3,3),BMAT(3,3),GMAT(3,3),CELL(6),RCELL(6), $ UMATCELL(6),LCELL(6),ICRYST,NUMSPG,NLAUE C .. C C C&&*&& end_include ../inc/cell.f C&&*&& include ../inc/debug.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file debug.h C---- START of include file debug.h C C C C .. Arrays in common /DEBUG/ .. REAL XWARN INTEGER NDEBUG,IWARN LOGICAL DEBUG,LPRINT,DUMP,WARN C C .. Scalars in common /DEBUG/ .. REAL BGRLIM INTEGER NDUMP,IDUMP,MXDUMP LOGICAL SPOT C C .. C .. Common Block /DEBUG/.. COMMON /DEBUG/XWARN(20,100),BGRLIM,NDEBUG(80),IWARN(20,100), $ NDUMP,IDUMP,MXDUMP,DEBUG(80),LPRINT(20),DUMP(30), + WARN(100),SPOT C .. C C&&*&& end_include ../inc/debug.f C&&*&& include ../inc/extras.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file extras.h C---- START of include file extras.h C C C .. Scalars in common /EXTRAS/ .. INTEGER JUMPAX,NPACKS LOGICAL ISKIP,AFILM,BFILM,CFILM,STARTA,STARTB,STARTC C .. C .. Common block /EXTRAS/ .. COMMON /EXTRAS/JUMPAX,NPACKS,ISKIP,AFILM,BFILM,CFILM,STARTA, + STARTB,STARTC C .. C C C&&*&& end_include ../inc/extras.f C&&*&& include ../inc/fid.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file fid.h C---- START of include file fid.h C C XCENF,YCENF Coordinates (in 10 micron units) of the direct beam C position relative to an origin at the position of the C first pixel in the digitised image.(The SCANNER C coordinate frame). C For IP data this comes from the defined C direct beam coordinates, for film data it is the C midpoint of fiducials 1 and 3. C C CCX,CCY The difference (in 10 micron units) between the C refined position of the direct beam (XCEN,YCEN) and C the ideal direct beam coordinates (XCENF,YCENF), C in the SCANNER coordinate frame. C CCX,CCY are updated in RDIST. They are in "pixels" C rather than mm (but expressed in 10micron units). C C DTOFD The distance (in 10 micron units) from the crystal C to the detector along a normal to the detector. C For flat, unswung detectors, or swung on a 2 theta arm, C this is the same as CTOFD and XTOFD. It differs for C Vee shaped cassettes. Assigned in START and never changed. C Only actually used in RMAXR for calculating box sizes. C C .. Arrays in common /FID/ .. REAL CCOMABC INTEGER FSPOS,CCXABC,CCYABC C .. C .. Scalars in common /FID/ .. REAL OMEGAF,CCOM,DTOFD,XCENF,YCENF INTEGER MM,MMDB,NFID,CCX,CCY,IYOFF C .. C .. Common block /FID/ .. COMMON /FID/CCOMABC(3),OMEGAF,CCOM,DTOFD,XCENF,YCENF,FSPOS(4,2), + CCXABC(3),CCYABC(3),MM,MMDB,NFID,CCX,CCY,IYOFF C .. C C C&&*&& end_include ../inc/fid.f C&&*&& include ../inc/ioo.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file ioo.h C---- START of include file ioo.h C C C C .. Scalars in common block /IOO/ .. INTEGER IOUT,IUNIT,ITIN,ITOUT,INOD,INMO,IDU,NWRN,IBRIEF,ISUMMR, + ICOORD,SERVERFD LOGICAL ONLINE,ONEFILE,FHEADER,BRIEF,GRAPH,IOERR, $ NODISPLAY,LBELL,JPGOUT,SOCKLO C .. C .. Common block /IOO/ .. c COMMON /IOO/IOUT,IUNIT,ONLINE,ITIN,ITOUT,INOD,INMO,IDU,NWRN, c + ONEFILE,FHEADER,BRIEF,IBRIEF,GRAPH,ISUMMR,ICOORD, c + IOERR,NODISPLAY,LBELL C .. C C COMMON /IOO/IOUT,IUNIT,ITIN,ITOUT,INOD,INMO,IDU,NWRN,IBRIEF, + ISUMMR,ICOORD,SERVERFD,ONLINE,ONEFILE, + FHEADER,BRIEF,GRAPH,IOERR,NODISPLAY,LBELL,JPGOUT, $ SOCKLO C&&*&& end_include ../inc/ioo.f C&&*&& include ../inc/lmb.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file lmb.h C---- START of include file lmb.h C ODSCAL is to scale image numbers into the range 0-255 for plotting C average profiles. C GAIN should be equal to the overall gain (image counts per X-ray photon) C of the system, and is used to evaluate standard deviations based on C counting statistics assuming independent pixels (ie point spread function C less than pixel size). C INVERTX true if image is inverted in the slow (X) direction when read in. C ISCAL is to scale final integrated intensities and sigmas C IDIVIDE is the adc offset C ICONST is a constant to be added to all pixels (normally zero) to C allow processing of images with zero pixel values in the scanned C area. C IMGP is true if working with image plate data C SPIRAL is true for scanners with a spiral readout (Mar, DIP2000) C ORTHOG is true for scanners with orthogonal scan (FUJI, RAXIS, MD) C NULLPIX is the value of pixels within the image but not in the active C area of the detector C TILED is true if there are inactive areas of the detector within the C inscribing circle or square. C C NTILEX Number of tiles in X direction C NTILEY Number of tiles in Y direction C TILEX X Coordinates of the midpoints of the null areas between tiles C TILEY Y Coordinates of the midpoints of the null areas between tiles C TILEWX Width of the null areas between tiles in X C TILEWY Width of the null areas between tiles in Y C MACHINE and MODEL denote the type of detector. C C MACHINE is used in the following subroutines: C GETBLK, GETHDR, INTPXL, INTPXL2, MXDSPL, OPENODS, PROCESS, PUTPXL C Currently coded types are: C C MACHINE MODEL COMMENTS C ======= ===== ======== C MAR 180, 300, 345 C RAXI(S) RAXISII, RAXISIV C MD C FUJI C CCD1 CCD1 Princetown CCD at CHESS,Tiff format C CCD2 CCD ? ESRF CCD detector C ADSC QUAD1 ADSC 2x2 CCD detector C C .. Scalars in Common Block /LMB/ .. REAL ODSCAL,GAIN,LOGA,LOGB INTEGER ISCAL,IDIVIDE,ICONST,NULLPIX,NTILEX,NTILEY LOGICAL IMGP,INVERTX,SPIRAL,ORTHOG,CIRCULAR,TILED,SETADC CHARACTER MACHINE*4,MODEL*8 C .. C .. Arrays in common /LMB/ INTEGER TILEX,TILEY,TILEWX,TILEWY C C .. Common Block /LMB/ .. COMMON /LMB/ ODSCAL,GAIN,LOGA,LOGB,ISCAL,IDIVIDE,ICONST, + NULLPIX,NTILEX,NTILEY,TILEX(20),TILEY(20), + TILEWX(20),TILEWY(20),IMGP,INVERTX,SPIRAL, + ORTHOG,CIRCULAR,TILED,SETADC COMMON /LMBC/ MACHINE,MODEL C&&*&& end_include ../inc/lmb.f C&&*&& include ../inc/loop.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file loop.h C---- START of include file loop.h C C C .. Scalars in Common Block /LOOP/ .. INTEGER IRLB,IRLE C .. C .. Common Block /LOOP/ .. COMMON /LOOP/IRLB(2),IRLE(2) C .. C C C&&*&& end_include ../inc/loop.f C&&*&& include ../inc/misc.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file misc.h C---- START of include file misc.h C C C C .. Scalars in common /MISC/ .. REAL PHIBEG,PHIEND,RMIN,RMAX,WAVE INTEGER IPACKID,MININT,IERRFLG C .. C .. Arrays in common /MISC/ .. REAL DELPHI,RESANI INTEGER IAX C .. C .. LOGICAL LOGICAL ANITES C .. C .. Common Block /MISC/ .. COMMON /MISC/DELPHI(3),RESANI(3),PHIBEG,PHIEND,RMIN,RMAX,WAVE, $ IAX(3),IPACKID,MININT,IERRFLG,ANITES C .. C C C&&*&& end_include ../inc/misc.f C&&*&& include ../inc/ori.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file ori.h C---- START of include file ori.h C C XCEN,YCEN Coordinates (in 10 micron units) of the direct beam C position relative to an origin at the position of the C first pixel in the digitised image.(The SCANNER C coordinate frame). These parameters are refined for C each image. C C XCEN0,YCEN0 Coordinates of direct beam position at zero swing angle. C (Needed for pxtomm conversion for swung detectors) C These values are assigned on the basis of input direct C beam coordinates, corrected for swing angle if necessary. C They are not (currently) updated during refinement. C C XOFF,YOFF Distance between centre of detector and direct beam. C C .. C .. Arrays in common /ORI/ .. LOGICAL FIXPAR C C .. Scalars in common block /ORI/ .. REAL COSOM0,SINOM0,XTOFRA,YSCAL,TILT,TWIST,BULGE, + VBNEG,VBPOS,VTILT,VTWIST,VVERT,TOFF,BULGE2,PBULGE,ROFF, + RDTOFF,RDROFF,ROFFPHI,TOFFPHI,JUNK3,XCEN,YCEN,XCEN0,YCEN0, + XOFF,YOFF,TILTMAT,TWISTMAT,DETNOR,DPSIX INTEGER CBAR,NODES,NPHI,IJUNK2,IJUNK3 LOGICAL RESETCCOM C .. C .. Common Block /ORI/ .. COMMON /ORI/COSOM0,SINOM0,XTOFRA,YSCAL,TILT,TWIST,BULGE, $ VBNEG,VBPOS,VTILT,VTWIST,VVERT,TOFF,BULGE2,PBULGE,ROFF, $ RDTOFF,RDROFF,ROFFPHI,TOFFPHI,JUNK3,XCEN,YCEN,XCEN0, + YCEN0,XOFF,YOFF,TILTMAT,TWISTMAT,DPSIX,DETNOR(3),CBAR, + NODES,NPHI,IJUNK2,IJUNK3,FIXPAR(NRPAR), $ RESETCCOM C .. C C C&&*&& end_include ../inc/ori.f C&&*&& include ../inc/gendata.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file gendata.h C---- START of include file gendata.h C C IMG Partiality indicator. 0 for full reflections, 1 to 100 C for partials. Negative for partials at the start of the C rotation range, +ve for partials at the end of the C rotation. Set in subroutine REEK using DELEPS calculated C in subroutine DSTAR C C IRG Reflection flag (Set by SPTEST called from DSTAR) C = 0 Spot can be measured C = 1 Outside R, X, Y limits C = 2 Overlapping spot (set later) C = 3 Too wide in phi (more than NWMAX images) C = 4 DST .GT. DSTMAX Not included in final film list - C used only to check for overlaps at edge of film. C = 10 Spot is within cusp, but will be observed...not included C in final spot list but must be included in predicted C pattern C C = 21 Spot present on 2 images, this is 1st C = 22 Spot present on 2 images, this is 2nd C C = 31 Spot present on 3 images, this is 1st C = 32 Spot present on 3 images, this is 2nd C = 33 Spot present on 3 images, this is 3rd C C = 41 Spot present on 4 images, this is 1st C = 42 Spot present on 4 images, this is 2nd C = 43 Spot present on 3 images, this is 3rd C = 44 Spot present on 4 images, this is 4th C C etc etc C C XG Virtual detector X coordinate in 10 micron units, relative to C an origin at the direct beam position. X is parallel to the C Y axis in the laboratory frame, ie orthogonal to the rotation C axis. C C YG Virtual detector Y coordinate in 10 micron units, relative to C an origin at the direct beam position. Y is parallel to the C Z axis in the laboratory frame, ie the rotation axis. C C IX,IY are the coordinates of the reflection in pixels C (integers) wrt the first pixel in the image (lower left corner C cameramans view). For testing for spot overlap, these C coordinates are in 10 micron units. Also used for display C pixel coordinates when displaying predicted pattern. C C IREC Pointer to the record number of a particular spot in the C list of generated reflections. C C C .. C .. Arrays in common /GENDATA/ .. REAL FRACG,PHIG,PHIWG,XG,YG INTEGER INTG,IPRO,IX,IY,IREC INTEGER*2 IRG,IMG,IGFLAG,ISDPRO,ISDG,IHG,IKG,ILG,IMPARTG, + MISYMG C .. Scalars in common /GENDATA/ .. INTEGER IPACKREC,IPACKHEAD,IRECLAST C .. C .. Common block /GENDATA/ .. COMMON /GENDATA/FRACG(NREFLS),PHIG(NREFLS),PHIWG(NREFLS), $ XG(NREFLS),YG(NREFLS),INTG(NREFLS),IPRO(NREFLS), $ IX(NREFLS),IY(NREFLS),IREC(NREFLS),IRG(NREFLS),IMG(NREFLS), + IGFLAG(NREFLS),ISDPRO(NREFLS),ISDG(NREFLS), + IHG(NREFLS),IKG(NREFLS),ILG(NREFLS),IMPARTG(NREFLS), + MISYMG(NREFLS),IPACKREC,IPACKHEAD,IRECLAST + C .. C C C&&*&& end_include ../inc/gendata.f C&&*&& include ../inc/postreek.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C C common block so we don't have to recalculate values of FRAC, PHIW, PHI C for new post-refinement C REAL PHI,PHIW,FRAC COMMON /POSTREEK/ PHI,PHIW,FRAC C&&*&& end_include ../inc/postreek.f C&&*&& include ../inc/film_no.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C integer id common /film_num/ id C&&*&& end_include ../inc/film_no.f C&&*&& include ../inc/reek_mod.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C REAL X,Y INTEGER IHKL,KHF COMMON /REEK_MOD/ X,Y,IHKL(3),KHF C&&*&& end_include ../inc/reek_mod.f C&&*&& include ../inc/reeke.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file reeke.h C---- START of include file reeke.h C C TOR For synchrotron sources, degree of polarisation of the beam C IMONO Collimation flag for polarisation. C = 0 Pinhole or mirrors C = 1 Graphite Monochromator C = 2 Synchrotron, use TOR C NWMAX Maximum reflection width in images C DSTMAX dimensionless rlu, = WAVE/RES where RES is the maximum C resolution in Angstrom. C DSTMIN dimensionless rlu, = WAVE/DMAX where DMAX is the maximum C Bragg spacing C C .. Scalars in common block /REEKE/ .. REAL X1,X2,Y1,Y2,Z1,Z2,XYS,DSTAR2,DSTMAX,DSTPL,DSTPL2, + DIVH,DIVV,DELAMB,ETA,DELCOR,DSTMAXS,TOR,DSTMIN,WMAX INTEGER ISYN,IMONO,NWMAX,IPAD C .. C .. logicals in common block /REEKE/ .. LOGICAL LOGETA,NUREEK C .. C .. Arrays in common block /REEKE/ .. REAL RMC,AMAT C .. C .. Common Block /REEKE/ .. COMMON /REEKE/RMC(3,3),AMAT(3,3),X1,X2,Y1,Y2,Z1,Z2,XYS,DSTAR2, + DSTMAX,DSTPL,DSTPL2,DIVH,DIVV,DELAMB,ETA,DELCOR, + DSTMAXS,TOR,DSTMIN,WMAX,ISYN,IMONO,NWMAX,IPAD,LOGETA,NUREEK C .. C C C&&*&& end_include ../inc/reeke.f C&&*&& include ../inc/savall.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C---- START of include file savall.h C C NSAVIMG Number of images used in autoindexing C ISAVIMG Array storing image numbers used in last autoindexing C NSAVSEG Number of segments used in last postref run C ISFIRST Array storing image number of the first image C in all segments of last postref run. C SAVMATSR Indicates whether last matrix was determined by C autoindexing (Autoindexing) or by postref (Post refinement) C SAVMATNAM Name of the matrix file C SAVENAM Name of savefile C SVSCN SCANNER keyword C SVSITE SITE keyword C RES High resolution limit given on RESOL keyword C RESLOW Low resolution limit given on RESOL keyword C C .. Scalars in common block /SAVALL/ .. REAL RES,RESLOW INTEGER NSAVIMG,NDIR,NSAVSEG CHARACTER SAVMATSTR*80,SAVMATNAM*80,SAVENAM*80,SVSCN*80, + SVSITE*80 LOGICAL IISCN,IISITE,IIWAVE,IIDIV,IIDISP,IINULL,IIRAST,IISEP, + IIOVER,IIPIX,IIBACK,IIRES C .. C .. Arrays in common block /SAVALL/ .. C INTEGER ISAVIMG(MAXIMG),ISFIRST(100) C .. Common Block /SAVALL/ .. COMMON /SAVALL/ RES,RESLOW,ISAVIMG,ISFIRST,NSAVIMG,NDIR,NSAVSEG, + IISCN,IISITE,IIWAVE,IIDIV,IIDISP,IINULL,IIRAST,IISEP, + IIOVER,IIPIX,IIBACK,IIRES C C COMMON /SAVALLC/ SAVMATSTR,SAVMATNAM,SAVENAM,SVSCN,SVSITE C .. C C C&&*&& end_include ../inc/savall.f C&&*&& include ../inc/scn.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file scn.h C---- START of include file scn.h C C SCNSZ is pixel size (in microns) divided by 25 C RAST pixel size in slow direction in mm C FACT multiplying by FACT converts from 10 micron units C (the standard unit internal to the program) into pixels C IYLEN The number of pixels in the Y (fastest changing) direction C in the digitised image. C NREC The number of pixels in the X (slow) direction in the C digitised image. C NWORD The number of I*2 words in the Y direction. C NBYTE The number of bytes in Y direction = NWORD/2 C NHBYTE Number of bytes in header C C ICURR When several images are stored in a single file, ICURR is the C pointer to the first record of the current image in the direct C access file (only implemented for film data) C NEXTRA The number of additional (unused) bytes padding the end of C each record in image file C BYTSWAP True if the "endedness" (Big-endian/Little-endian) of the C machine that MOSFLM is running on is different to that of the C machine on which the image was written. This is determined by C looking at the value of NXPIX in the header record of the C image file (subroutine GETHDR) C C .. Scalars in common block /SCN/ .. REAL FACT,SCNSZ,RAST INTEGER NBYTE,NREC,NWORD,IYLEN,ICURR,NEXTRA,NHBYTE LOGICAL BYTSWAP C .. C .. Common Block /SCN/ .. COMMON /SCN/ FACT,SCNSZ,RAST,NBYTE,NREC,NWORD,IYLEN,ICURR,NEXTRA, + NHBYTE,BYTSWAP C&&*&& end_include ../inc/scn.f C&&*&& include ../inc/sys.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file sys.h C---- START of include file sys.h C C C .. Scalars in Common Block /SYS/ .. INTEGER ISYS C .. C .. Arrays in Common Block /SYS/ .. INTEGER KSYS C .. C .. Common Block /SYS/ .. COMMON /SYS/ISYS,KSYS(3) C .. C C C&&*&& end_include ../inc/sys.f C&&*&& include ../inc/strat.f C--- awk generated include file strat.h C---- START of include file strat.h C C---- Stores variables for use in STRATEGY option C IROTAX is the axis closest to the rotation axis C PHIROTAX is the angle this axis makes with the rotation axis C C PHIZONE is the phi value at which axis "IZONEAX" is along the C X-ray beam. (IZONEAX = 1 is a, =2 is b, =3 is c) C PHIPAD is the rotation to be added to PHILAUE to ensure generation C of all unique data, and will depend on angle between the C unique axis and the rotation axis. C AUTANOM if true tries to maximise number of anomalous pairs C CELLSCAL is the scale factor applied to the cell edges to C speed up the calculation. C SHRUNK is TRUE if the cell has been scaled by CELLSCAL C ISTRUN is used to increment input phi angles by multiples of C 360 degrees, so that phi values in different parts can C be recognised. It starts at zero. C FIRSTRAT Starts as TRUE (set in MOSDATA) and is set to FALSE once C the MTZ file has been opened for a STRATEGY run. C Reset TRUE after EXITing from STRATGEY prompt. C C .. Scalars in common /STRAT/ .. INTEGER NSEGM,IPCKCUR,NSTRAT,NUNIQ,NSTRUN,ISTRUN,NSEGAUTO, + IZONEAX,IROTAX,NLAST,NNPACKS,NLASTPACK LOGICAL STRATEGY,AUTO,SIZESET,AUTANOM,SHRUNK,FIRSTRAT, + NEWSTRAT,WAITINP,OFFPHI REAL ROTAUTO,PHILAUE,PHIPAD,PHIZONE,PHIROTAX,CELLSCAL C .. C .. Arrays in common /STRAT/ .. REAL PHIST,PHIFIN,PHIINC,PHIADD,PHISEGA INTEGER IFIRSTONE C .. C .. Common Block /STRAT/ .. COMMON /STRAT/ PHIST(NSEGMAX),PHIFIN(NSEGMAX),PHIINC(NSEGMAX), + PHIADD(NSEGMAX),PHISEGA(NSEGMAX),ROTAUTO,PHILAUE,PHIPAD, $ PHIZONE,PHIROTAX,CELLSCAL,IFIRSTONE(NSEGMAX), $ NSEGM,IPCKCUR,NSTRAT,NUNIQ, + NSTRUN,ISTRUN,NSEGAUTO, + IZONEAX,IROTAX,NLAST,NNPACKS,NLASTPACK, + STRATEGY,AUTO,SIZESET,AUTANOM,SHRUNK, + FIRSTRAT,NEWSTRAT,WAITINP, + OFFPHI C .. C C C&&*&& end_include ../inc/strat.f C&&*&& include ../inc/tgen.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file tgen.h C---- START of include file tgen.h C C---- Stores variables for use in TESTGEN option C C .. Arrays in common /TGEN/ .. c REAL XOVER c INTEGER ISTATS C C .. Scalars in common /TGEN/ .. REAL XOVER,PHSTART,PHEND,PHSTEP,OSCMIN,OSCMAX,SDIVH,SDIVV, + SDELCOR,SDELAMB,SETA,OSCANG,PCMAX INTEGER ISTATS LOGICAL TESTGEN,TESTRAT C .. C .. C .. Common Block /TGEN/ .. COMMON /TGEN/XOVER(2),PHSTART,PHEND,PHSTEP,OSCMIN,OSCMAX, + SDIVH,SDIVV,SDELCOR,SDELAMB,SETA,OSCANG,PCMAX, $ ISTATS(MAXPAX,3),TESTGEN,TESTRAT C&&*&& end_include ../inc/tgen.f C&&*&& include ../inc/tiltlog.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C---- awk generated include file tiltlog.h C---- START of include file tiltlog.h C C for things connected with the new definitions of TILT and TWIST C C .. Scalars in common block /TILTLOG/ .. LOGICAL NUTWIST COMMON /TILTLOG/NUTWIST C&&*&& end_include ../inc/tiltlog.f C&&*&& include ../inc/xy.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file xy.h C---- START of include file xy.h C C .. Scalars in common block /XY/ .. REAL XTOFD,SINV,COSV,TANV,TWOTHETA INTEGER ICASS C .. C .. Common Block /XY/ .. COMMON /XY/XTOFD,SINV,COSV,TANV,TWOTHETA,ICASS C .. C C XTOFD.... Crystal to detector distance in 10 micron units. Read from C keyworded input and never changed. C C Spot positions are calculated in S/R XYSPOT (Called from C REEK) and are for an "ideal" detector at a distance of XTOFD. C These are converted into pixel positions in S/R MMTOPX C which applies the multiplicative factor XTOFRA to allow C for refinement of the distance. XTOFRA is the parameter C that is actually refined (in RDIST), rather than XTOFD. C The refined distance that is printed in the logfile is C actually XTOFRA*XTOFD C C ICASS.... Indicates detector type: C 0 Flat film C 1 Vee shaped cassettes C 2 FAST detector (only used in TESTGEN mode of OSCGEN) C 3 Swung out FAST (ditto) C 4 IP detector C TWOTHETA Detector swing angle (degrees) C&&*&& end_include ../inc/xy.f C .. C .. Statement Functions .. INTEGER INTB,INTE C .. C .. Equivalences .. EQUIVALENCE (P0OLD(1,1,1),BBEG), (P0OLD(1,1,2),BEND) EQUIVALENCE (POLD(1,1,1),B0BEG), (POLD(1,1,2),B0END) EQUIVALENCE (X12(1),X1), (Y12(1),Y1), (Z12(1),Z1) C .. SAVE C .. Data statements .. DATA PP/24*0.0/,ICOUNT/0/ S0/-1.0,0,0/ phiaxis/ 0.0, 0.0, 1.0 / C C Statement functions C INTB(A) = INT(A - 3.0) INTE(A) = INT(A + 3.0) C PI = ATAN(1.0)*4 DTOR = PI/180.0 DSTMAX2 = DSTMAX**2 DSTMIN2 = DSTMIN**2 DSTPL2 = DSTPL**2 IF(ANITES)CALL ANIRES(ORTMAT) ISTAT = 0 C C C234567890C234567890C234567890C234567890C234567890C234567890C234567890C IF (DEBUG(29)) THEN IF (ONLINE) WRITE (ITOUT,FMT=6000) AMAT,RMC,PHIBEG,PHIEND, + DELPHI,DIVH,DIVV,ETA,DSTMAX,DSTMIN,DSTPL,GMAT WRITE (IOUT,FMT=6000) AMAT,RMC,PHIBEG,PHIEND,DELPHI,DIVH,DIVV, + ETA,DSTMAX,DSTMIN,DSTPL,GMAT END IF 6000 FORMAT (/1X,'In REEKE',/1X,'AMAT',3(/,1X,3F12.6), + /1X,'RMC',3(/,1X,3F12.6),/1X,'PHI', + 'BEG,END ',2F6.1,' DELPHI ',3F6.2,/1X,'DIVH,DIVV,ETA,DSTM', + 'AX, DSTMIN, DSTPL',6F9.6,/1X,'GMAT ',3(/,1X,3F12.6)) C C---- Test for writing a "spots" file C IF (DUMP(8)) THEN ISPOT = 10 CALL CCPDPN (ISPOT,'SPOTLIST','UNKNOWN','F',80,IFAIL) INVFLAG = 0 IF (INVERTX) INVFLAG = 1 ISWUNG = 0 IF (ABS(TWOTHETA).GT.0.01) ISWUNG = 1 WRITE(ISPOT,FMT=6020) NREC,IYLEN,RAST,YSCAL,OMEGAF/DTOR, + INVFLAG,ISWUNG 6020 FORMAT(1X,2I10,F10.3,F10.6,F10.2,2I5) PXCEN = 0.01*XCEN PYCEN = 0.01*YCEN/YSCAL IF (INVERTX) PXCEN = NREC*RAST - PXCEN WRITE(ISPOT,FMT=6022) PXCEN,PYCEN 6022 FORMAT(1X,2F10.3) END IF C C---- Calculate setting matrix at each end of scan C C---- Set up beginning rot about z in RMPB C C *********************************** CALL SURMP((PHIBEG+DELPHI(3))*DTOR,RMPB) C *********************************** C C---- Set up end rot about z in RMPE C C *********************************** CALL SURMP((PHIEND+DELPHI(3))*DTOR,RMPE) C *********************************** C C---- Apply X and Y missetting angles CA = RMC . AMAT C C ******************* CALL MATMUL3(CA,RMC,AMAT) C ******************* C C---- Orientation at beginning of scan BBEG = RMPB . CA C C ******************** CALL MATMUL3(BBEG,RMPB,CA) C ******************** C C---- Orientation at end of scan BEND = RMPE . CA C C ******************** CALL MATMUL3(BEND,RMPE,CA) C ******************** C C---- Now repeat the above but now with the Z rot extended by the C maximum possible spot width C TANTMAX = SQRT(4.0-DSTMAX**2)*DSTMAX GAMMAX = MAX(DIVH,DIVV,ETA) + DELAMB*TANTMAX C C ****************************************** CALL SURMP((PHIBEG+DELPHI(3))*DTOR-GAMMAX,RMPB) CALL SURMP((PHIEND+DELPHI(3))*DTOR+GAMMAX,RMPE) CALL MATMUL3(CA,RMC,AMAT) CALL MATMUL3(B0BEG,RMPB,CA) CALL MATMUL3(B0END,RMPE,CA) C ****************************************** C C---- Determine choice of r.l. axes for loops - IAX(1) C (approx along X) will C be the fastest varying and IAX(3) C (approx along rot axis) the slowest C C ******************** CALL SETAX(BBEG,BEND,IAX) C ******************** JUMPAX = IAX(3) C C Compute start and end of rotation range in radians: C C hrp 11012001 STARTR = ROTS * DG2RD C hrp 11012001 ENDR = ROTE * DG2RD C C C Consider axis IAX(1) to be IP, IAX(2) to be IQ, IAX(3) to be IR C C Fix up ordering of setting matrices to be in column C order IP, IQ, IR C Note that BBEG and BEND are equivalenced to POLD C and B0BEG and B0END are equivalenced to P0OLD C DO 7 I = 1,2 DO 5 J = 1, 3 DO 2 K = 1, 3 P(J,K,I) = POLD(J,IAX(K),I) P0(J,K,I) = P0OLD(J,IAX(K),I) 2 CONTINUE 5 CONTINUE 7 CONTINUE C C Set PP (Pprime) as a 3x4(x2) matrix. Translation to move origin C to center of the Ewald sphere. S0 is a unit vector antiparallel C to the X-ray beam. C DO 30 I = 1, 2 DO 20 K = 1, 3 PP(K,4,I) = -S0(K) DO 10 J = 1, 3 PP(K,J,I) = P(K,J,I) 10 CONTINUE 20 CONTINUE 30 CONTINUE C C Calculate the reciprocal metric tensor T = PP(trans) . PP C The 3*3 portion of matrix is same at beginning and end of rotation C Note that RT, RS1, RU2 and QU don't depend on L and thus don't need C to be calculated twice. C PP is used here to calculate T but is not used again C DO 80 L = 1, 2 DO 75 I = 1, 4 DO 70 J = 1, 4 T1 = 0.0 DO 60 K = 1, 3 T1 = T1 + PP(K,I,L) * PP(K,J,L) 60 ENDDO T(I,J) = T1 70 ENDDO 75 ENDDO C RT(L) = T(2,3)**2 - T(3,3) * T(2,2) RS1(L) = T(1,3) * T(2,3) - T(3,3) * T(1,2) RS0(L) = T(2,3) * T(3,4) - T(2,4) * T(3,3) RU2(L) = T(1,3)**2 - T(1,1) * T(3,3) RU1(L) = 2.0 * (T(1,3) * T(3,4) - T(1,4) * T(3,3)) RU0(L) = T(3,4)**2 QU(L) = T(3,3) CALL MINV33(Q(1,1,L),P(1,1,L),DJUNK) 80 CONTINUE C S1 = T(1,1) S2 = T(2,2) S3 = T(3,3) S4 = T(3,2) + T(2,3) S5 = T(1,3) + T(3,1) S6 = T(1,2) + T(2,1) C PA = S4 * S4 - 4.0 * S2 * S3 PB = S4 * S5 - 2.0 * S3 * S6 PC = S5 * S5 - 4.0 * S1 * S3 PD = 4.0 * S3 * DSTMAX2 C C Initialisation complete C C Get IP looping limits C PMIN = 1.E20 PMAX = -1.E20 SINTH = 0.5 * SQRT(DSTMAX2) SINSQ = SINTH**2 SIN2T = SIN(2.0 * ATAN2(SINTH, SQRT(1.0-SINSQ))) C C Ewald sphere limit and limiting sphere both computed here. C Note that in order to allow for a general X-ray beam direction, C the algorithm for calculating the limiting sphere index limits C has been changed from that proposed by Reeke, and is now C essentially the same as the algorithm used for the Ewald sphere. C C C DO 101 J = 2,5 I = J/2 T1 = (-Q(1,1,I)*2.0*SINSQ+ (-1)**J*SIN2T* + SQRT(Q(1,2,I)**2+Q(1,3,I)**2)) PMIN = MIN(PMIN,T1) PMAX = MAX(PMAX,T1) 101 CONTINUE C C PMINE = 1.E20 PMAXE = -1.E20 C DO 120 I = 1, 2 C C Determine if the reciprocal lattice vector closest to the X-ray C beam is parallel or antiparallel. Remember S0 is antiparallel to C X-ray beam ! C SCA1 = DOT(P(1,1,I), S0) ISIGN = -INT( SIGN(1.1, SCA1) ) DO 100 J = 1, 3 J1 = MOD(J,3) + 1 J2 = MOD(J+1,3) + 1 VEC(J) = P(J1,2,I) * P(J2,3,I) - P(J1,3,I) * P(J2,2,I) 100 CONTINUE C C VEC is the vector normal to the reciprocal lattice planes with C IP index zero. C T1 = 0.0 T2 = 0.0 C C DO 110 J = 1,3 T1 = T1 + VEC(J)**2 T2 = T2 + P(J,1,I) * VEC(J) 110 CONTINUE C C T2 is the volume of the reciprocal space unit cell. Because of C the permutation of axes (by IAX), this may be negative. C AVEC = SQRT(T1) T2 = 1.0 / ABS(T2) C C Limiting sphere limits C VECX = DOT(S0,VEC) AVECX = ABS(VECX) A1 = T1 - AVECX * AVECX IF (A1 .GT. 0.0) THEN A1 = SQRT(A1) ELSE A1 = 0.0 ENDIF PX1 = -ISIGN * T2 * (2. * SINSQ * AVECX + SIN2T * A1) PX2 = -ISIGN * T2 * (2. * SINSQ * AVECX - SIN2T * A1) P1 = AMIN1(PX1, PX2) P2 = AMAX1(PX1, PX2) C C Ewald sphere limits C T1 = -ISIGN * T2 * (AVEC + AVECX) T2 = ISIGN * T2 * (AVEC - AVECX) PMINE = AMIN1(T1, T2) PMAXE = AMAX1(T1, T2) C C Select limits on basis of ISIGN C IF (ISIGN .GT. 0) THEN PMN(I) = AMAX1(P1, PMINE) PMX(I) = AMAX1(P2, PMAXE) ELSE PMN(I) = AMIN1(P1, PMINE) PMX(I) = AMIN1(P2, PMAXE) ENDIF 120 CONTINUE C C Select overall limits C PMIN = AMIN1(PMN(1), PMN(2)) PMAX = AMAX1(PMX(1), PMX(2)) IPLB = INTB(PMIN) IPLE = INTE(PMAX) IF (DEBUG(29)) THEN WRITE(IOUT,FMT=6006) IPLB,IPLE IF (ONLINE) WRITE(ITOUT,FMT=6006) IPLB,IPLE 6006 FORMAT(1x,'P loop limits',2I5) END IF C C Loop over IP C DO 460 IP = IPLB, IPLE C C Calculate a few P-dependent constants C FP = FLOAT(IP) FP2 = FP * FP S5P = S5 * FP S6P = S6 * FP S1P2R2 = FP2 * S1 - DSTMAX2 C C Calculate looping limits for IQ C limiting sphere C C hrp 11012001 CALL PRDQD2(PA, FP * PB, (FP2 * PC + PD), VEC, NRT) CALL QUAD2(NRT,PA,FP*PB, (FP2*PC+PD),VEC) C IF ((NRT-1).EQ.0) THEN IQMIN = INTB(VEC(1)) IQMAX = INTE(VEC(1)) ELSE IF ((NRT-1).GT.0) THEN IQMIN = INTB(MIN(VEC(1),VEC(2))) IQMAX = INTE(MAX(VEC(1),VEC(2))) ELSE GO TO 460 END IF C C Ewald sphere C QMINE = 1.E20 QMAXE = -1.E20 C c DO 195 I = 1, 3 c P1H0(I) = P0(I,1,1) * FP c 195 CONTINUE DO 200 I = 1, 2 P1H0(I) = P0(1,1,I)*FP P2H0(I) = P0(2,1,I)*FP P3H0(I) = P0(3,1,I)*FP P1H(I) = P(1,1,I) * FP - S0(1) P2H(I) = P(2,1,I) * FP - S0(2) P3H(I) = P(3,1,I) * FP - S0(3) T1 = RU0(I) + FP * (RU1(I) + FP * RU2(I)) C CALL QUAD2(NRTA(I),RT(I), (FP*RS1(I)+RS0(I)),T1,VEC) C IF((NRTA(I)-1).EQ.0)THEN QMINE = AMIN1(QMINE, VEC(1)) QMAXE = AMAX1(QMAXE, VEC(1)) ELSEIF((NRTA(I)-1).GT.0)THEN QMINE = AMIN1(QMINE, VEC(1), VEC(2)) QMAXE = AMAX1(QMAXE, VEC(1), VEC(2)) ENDIF 200 ENDDO C IF (NRTA(1) .EQ. 0 .AND. NRTA(2) .EQ. 0) GOTO 460 C C Choose most restrictive limits C IQLB = INTB(QMINE) IQLE = INTE(QMAXE) CALL LIMITS(IER,IQLB,IQLE,IQMIN,IQMAX) IF (IER .NE. 0) GOTO 460 c IF (DEBUG(29)) THEN c WRITE(IOUT,FMT=6008) IQLB,IQLE c IF (ONLINE) WRITE(ITOUT,FMT=6008) IQLB,IQLE c 6008 FORMAT(1x,'Q loop limits',2I5) c END IF C C Loop over IQ C DO 450 IQ = IQLB, IQLE FQ = REAL(IQ) C C Get looping limits for IR C D* limit C T1 = S1P2R2 + FQ * (FQ * S2 + S6P) C CALL QUAD2(NRT,S3, (0.5* (S4*FQ+S5P)),T1,VEC) C IF ((NRT-1).EQ.0) THEN IRMIN = INTB(VEC(1)) IRMAX = INTE(VEC(1)) ELSE IF ((NRT-1).GT.0) THEN IRMIN = INTB(MIN(VEC(1),VEC(2))) IRMAX = INTE(MAX(VEC(1),VEC(2))) ELSE GO TO 450 END IF C C Ewald sphere limits C 230 DO 260 I = 1, 2 PX = P1H(I) + P(1,2,I) * FQ PY = P2H(I) + P(2,2,I) * FQ PZ = P3H(I) + P(3,2,I) * FQ T1 = PX * PX + PY * PY + PZ * PZ - 1.0 T2 = P(1,3,I) * PX + P(2,3,I) * PY + P(3,3,I) * PZ C CALL QUAD2(NRTA(I),QU(I),T2,T1,VEC) C IF ((NRTA(I)-1).EQ.0) THEN RLB(I) = VEC(1) RLE(I) = VEC(1) ELSE IF ((NRTA(I)-1).GT.0) THEN RLB(I) = MIN(VEC(1),VEC(2)) RLE(I) = MAX(VEC(1),VEC(2)) END IF 260 CONTINUE C C Use quadratic roots to set up loop limits depending on sphere C intersections and adjust loops to other limits. C NLOOP = 1 C C IF (NRTA(1).GT.0) THEN C C IF (NRTA(2).GT.0) THEN IF (RLB(1).GT.RLB(2)) THEN C C *********************** CALL JSWTCH(NRTA(1),NRTA(2)) CALL SWITCH(RLB(1),RLB(2)) CALL SWITCH(RLE(1),RLE(2)) C *********************** C END IF C C IF (NRTA(1).NE.1) THEN IF (NRTA(2).EQ.2) THEN IF (RLE(2).LE.RLE(1)) THEN NLOOP = 2 C C ***************************************** CALL LOOPST(NLOOP,RLB(1),RLB(2), + RLE(2),RLE(1)) C ***************************************** C GO TO 330 ELSE IF (RLB(2).LT.RLE(1)) THEN NLOOP = 2 C C ***************************************** CALL LOOPST(NLOOP,RLB(1),RLB(2), + RLE(1),RLE(2)) C ***************************************** C GO TO 330 END IF END IF END IF NLOOP = 2 END IF C C ELSE IF (NRTA(2).LE.0) THEN GO TO 450 ELSE NRTA(1) = NRTA(2) RLB(1) = RLB(2) RLE(1) = RLE(2) END IF C C ***************************************** CALL LOOPST(NLOOP,RLB(1),RLE(1),RLB(2),RLE(2)) C ***************************************** C C---- Check IR limits C C *************************************** 330 CALL LIMITS(IER,IRLB(1),IRLE(1),IRMIN,IRMAX) C *************************************** C IF (IER.NE.0) THEN C C IF (NLOOP.EQ.1) THEN GO TO 450 ELSE NLOOP = 1 END IF C C ELSE IF (NLOOP.EQ.1) THEN GO TO 370 END IF C C *************************************** CALL JSWTCH(IRLB(1),IRLB(2)) CALL JSWTCH(IRLE(1),IRLE(2)) CALL LIMITS(IER,IRLB(1),IRLE(1),IRMIN,IRMAX) C *************************************** C IF (IER.NE.0) THEN C C IF (NLOOP.EQ.1) THEN GO TO 450 ELSE C C *********************** CALL JSWTCH(IRLB(1),IRLB(2)) CALL JSWTCH(IRLE(1),IRLE(2)) C *********************** C NLOOP = 1 END IF END IF 370 CONTINUE C C Loop over IR C C DO 380 I = 1, 2 PX0(I) = P0(1,2,I)*FQ + P1H0(I) PY0(I) = P0(2,2,I)*FQ + P2H0(I) PZ0(I) = P0(3,2,I)*FQ + P3H0(I) 380 CONTINUE C C---- If (nloop.eq.2), check that r limits do not overlap (a.g.w.l.) C and if one limit is the same, only do a single loop with C extended limits C IF (NLOOP.EQ.2) THEN C C IF ((IRLE(2).GT.IRLE(1)) .AND. + (IRLB(2).LE.IRLE(1))) IRLB(2) = IRLE(1) + 1 IF ((IRLE(1).GT.IRLE(2)) .AND. + (IRLB(1).LE.IRLE(2))) IRLB(1) = IRLE(2) + 1 IF (IRLE(2).EQ.IRLE(1)) THEN IRLB(1) = MIN(IRLB(1),IRLB(2)) NLOOP = 1 END IF C C IF (IRLB(2).EQ.IRLB(1)) THEN IRLE(1) = MAX(IRLE(1),IRLE(2)) NLOOP = 1 END IF END IF C DO 445 ILOOP = 1, NLOOP DO 440 IR = IRLB(ILOOP), IRLE(ILOOP) IHKL(IAX(1)) = IP IHKL(IAX(2)) = IQ IHKL(IAX(3)) = IR C C---- stuff from old Reeke code here... C C C---- Test for any systematic absences from centering C C *********************** IF (ISYS.NE.0) CALL MSYSABS(IHKL,ABSNT) C *********************** C C---- For strategy option, need to eliminate axial absences too C IF (STRATEGY) THEN ISYSAB = 0 C C *********************** CALL EPSLON(IHKL,EPS,ISYSAB) C *********************** C C---- Test for systematic absences ABSNT = .FALSE. IF (ISYSAB .EQ. 1)ABSNT = .TRUE. END IF IF (.NOT.ABSNT) THEN FR = REAL(IR) C C DO 2000 I = 1,2 X12(I) = P0(1,3,I)*FR + PX0(I) Y12(I) = P0(2,3,I)*FR + PY0(I) Z12(I) = P0(3,3,I)*FR + PZ0(I) 2000 CONTINUE C C ********************************************* CALL DSTAR(IP,IQ,IR,KT,KHF,DELEPS1,DELEPS2, + PHI,PHIW,DRATIO) C ********************************************* C IF (DEBUG(29).AND.(ICOUNT.LT.NDEBUG(29))) + THEN C C IF (ONLINE) WRITE (ITOUT,FMT=6002) + IP,IQ,IR,KT,KHF,DRATIO,DELEPS1,DELEPS2 WRITE (IOUT,FMT=6002) IP,IQ,IR,KT, + KHF,DRATIO,DELEPS1,DELEPS2 END IF C C---- Skip this reflection unless good spot OR within cusp (want to C plot reflections within cusp) C IF ((KT.EQ.0).OR.(KT.EQ.-3)) THEN C C---- Calc detector coords, etc. C C new code needs correction for real PHI of reflection... C IF(NUREEK)THEN CALL RTMATS(DTOR*(PHI-PHIBEG), $ PHIAXIS,3,ROTMAT) CALL MAT_VEC_MUL_3X3(ROTMAT,X1,Y1,Z1) CALL PRDDET(x,y,x1,y1,z1,s0,ier) ELSE CALL XYSPOT(Y1,Y2,Z1,DSTAR2,XYS,X,Y) ENDIF C ******************************* C IF (DEBUG(29).AND.(ICOUNT.LT.NDEBUG(29))) + THEN ICOUNT = ICOUNT + 1 c IF (ONLINE) WRITE (ITOUT,FMT=6004) X,Y C WRITE (IOUT,FMT=6004) X,Y WRITE (IOUT,FMT=6004) X,Y,X1,X2,Y1, $ Y2,Z1,Z2,DSTAR2,XYS,PHI,PHIBEG,ROTMAT, $ S0 END IF C C IFREC = 0 FRAC = 1.0 C C---- Set fraction recorded for fulls to be ratio of distance from C sphere at end of oscillation (which ever end is closer) to spot radius. C IF (KHF.EQ.0) FRAC = MAX(DRATIO,1.0) C C---- Ensure IFREC never goes to zero C IF (KHF.NE.0) THEN IF (ABS(DELEPS2).LE.0.00001) THEN C C---- Partial at start of oscillation only C IFREC = NINT(DELEPS1*100.0 + + SIGN(1.0,DELEPS1)) FRAC = 0.5*(1.0 - COS(DELEPS1*PI)) ELSE IF (ABS(DELEPS1).LE.0.00001) THEN C C---- Partial at end of oscillation only C IFREC = NINT(DELEPS2*100.0 + + SIGN(1.0,DELEPS2)) FRAC = 0.5*(1.0 - COS(DELEPS2*PI)) ELSE C C---- Spot is cut off at both ends C IFREC = NINT((ABS(DELEPS1) - + (1.0 - DELEPS2))*100) IFREC = MAX(1,IFREC) IFREC = MIN(100,IFREC) FRAC = 0.5*(1.0 - COS(DELEPS1*PI)) FRAC = FRAC - + (1.0 - 0.5*(1.0 - + COS(DELEPS2*PI))) END IF END IF C C---- Testing IFREC non-zero for a fully C IF ((IFREC.EQ.0).AND.(KHF.NE.0)) THEN WRITE(6,*)'**** ERROR IFREC,KHF', + IFREC,KHF END IF C C---- Note that for a sinusoid rocking curve the fraction recorded IFREC C C IFREC = (1-COS(DELEPS*PI))/2. C C but do we really need to store this - wouldn't DELEPS be better? C Alan suggests 100*DELEPS C C If not within cusp,test this spot for R,X,Y and DSTAR limits. C KHF used to test for cut-off both ends. C IF (KT.EQ.0) THEN C C---- First test for anisotropic resolution limits for integration C IF(ANITES)THEN DSTMAX2 = 0.0 DO 207 I=1,3 DJUNK = 0.0 DO 203 J=1,3 DJUNK = DJUNK + $ ORTMAT(I,J)* $ FLOAT(IHKL(J)) 203 ENDDO DSTMAX2 = DSTMAX2 + DJUNK**2 207 ENDDO DSTMAX2 = DSTAR2/DSTMAX2 ENDIF C ************************************ CALL SPTEST(X,Y,DSTAR2,DSTMAX2,DSTMIN2, + KHF,IFAIL) C ************************************ ELSE C C---- Spot with cups, flag with IFAIL=10, set IFREC to 1 so it is C not counted as fully recorded C IFREC = 1 IFAIL = 10 END IF C C---- Write out the whole thing here C C C---- For strategy option, only write out fully recorded reflections C which do not fail any test C IF (STRATEGY) THEN C C ******************************* IF (IFAIL.EQ.0) + CALL WMTZSP(IHKL,PHI,IHKLSTR) C ******************************* ELSE IFLAG = 0 C ******************************************** CALL STORSPOT(IHKL,IFREC,IFAIL,X,Y, + PHI,PHIW,FRAC,IFLAG) C ******************************************** C---- Test error return (more than NREFLS reflections generated) C IF (IFLAG.EQ.-1) THEN IF (TESTGEN) THEN MODE = -2 RETURN ELSE WRITE (IOUT,FMT=6010) NREFLS IF (ONLINE) WRITE + (ITOUT,FMT=6010) NREFLS IF (MODE.EQ.1) THEN MODE = -1 RETURN ELSE CALL SHUTDOWN END IF END IF END IF 6010 FORMAT (/1X,'**** ERROR - Too many ', + 'spots generated',/,1X, + /1X,'The current limit is ',I6, + /,1X,'You will have to change ', + 'the parameter NREFLS ',/, + 1X,'with a global edit', + ' and then recompile the program') C END IF END IF END IF C C---- Stuff from old Reeke loop above here C C C End of IR loop C 440 CONTINUE 445 CONTINUE C C End of IQ loop C 450 CONTINUE C C End of IP loop C 460 CONTINUE C C C---- Close SPOTLIST file C IF (DUMP(8)) THEN WRITE (ISPOT,FMT='(1X,5F8.2)') + - 999.0,-999.0,-999.0,-999.0,-999.0 CLOSE(ISPOT) END IF C C RETURN C C---- Format statements C 6002 FORMAT (1X,'IP,IQ,IR',3I4,' KT=',I2,' KH=',I4,' dratio=',F6.2, $ ' DELEPS1,2 = ',2f8.3) 6004 FORMAT (1X,'reeke',/,'X AND Y',2(F8.0,1X),/,' X1 - Z2 ',6F16.7, $ /,' DSTAR2 = ',F12.5,' XYS = ',F12.5,' PHI, PHIBEG = ', $ 2F8.2,/,'ROTMAT = ',3(F8.5,1X),2(/,9X,3(F8.5,1X)),/, $ ' S0 = ',3F8.5) C END C C C C C ================================================================= SUBROUTINE CELREF(NCYCLE,REIDX,N,IH,IK,IL,IX,IY,IPHI,ACHSE,IC,ICS, @ Q,ORGX,ORGY,F,S0L,ED,U,RCELL,SDU,SDCELL,SDPHI,SDXY,SDCUTOFF, $ NBAD,IER) C ================================================================= IMPLICIT NONE C C C C******* ********* C******* LEAST-SQUARES REFINEMENT OF ********* C******* DETECTOR AND CRYSTAL PARAMETERS ********* C******* ********* C*********************************************************************** C******* ********* C******* W. KABSCH September 1991 ********* C******* derived from version 11-1987 ********* C******* ********* C*********************************************************************** C C SUBROUTINES REQUIRED: DGELS,GONSYS,INVERS,MATCOP,RFMATMUL,METRIC,UNORM C C*********************************************************************** C C Harry has done some editing here! To make it easier to follow, I've C tidied up the ends of DO loops and tried to eliminate GOTOs wherever C relatively easy. I've also changed subroutines to normal MOSFLM routines C where there's a 1:1 correspondence. This is all because I want to use the C method but don't need all the functionality that this code provides! C C Harry Powell, March 8th 1999 C C??????????????????????????????????????????????????????????????????????? C C NCYCLE - NUMBER OF REFINEMENT CYCLES (GIVEN) C REIDX - INTEGER*2 ARRAY(12) PROVIDING A POSSIBILITY OF (GIVEN) C REINDEXING THE REFLECTIONS. C THE MEANING OF THE 12 NUMBERS IS DEFINED AS: C H' =REIDX(1)*H+REIDX( 2)*K+REIDX( 3)*L+REIDX( 4) C K' =REIDX(5)*H+REIDX( 6)*K+REIDX( 7)*L+REIDX( 8) C L' =REIDX(9)*H+REIDX(10)*K+REIDX(11)*L+REIDX(12) C WHERE H',K',L' ARE THE NEW INDICES. C N - NUMBER OF REFLECTIONS (INTEGER*4) (GIVEN) C IH - INTEGER*2 ARRAY SPECIFYING H-INDICES FOR A LIST (GIVEN) C OF N REFLECTIONS. C IK - INTEGER*2 ARRAY SPECIFYING K-INDICES FOR A LIST (GIVEN) C OF N REFLECTIONS. C IL - INTEGER*2 ARRAY SPECIFYING L-INDICES FOR A LIST (GIVEN) C OF N REFLECTIONS. C IX - INTEGER*4 ARRAY SPECIFYING X-POSITION ON DETECTOR (GIVEN) C FOR EACH SPOT IN THE LIST ( TENTH OF A PIXEL) C IY - INTEGER*4 ARRAY SPECIFYING Y-POSITION ON DETECTOR (GIVEN) C FOR EACH SPOT IN THE LIST ( TENTH OF A PIXEL) C IPHI - INTEGER*4 ARRAY SPECIFYING ANGULAR POSITION OF (GIVEN) C SPINDLE WHERE REFLECTION WITH INDICES IH,IK,IL C WAS DIFFRACTING. THE VALUES ARE GIVEN IN UNITS C OF A HUNDRETH OF A DEGREE. C ACHSE - ARRAY(3) SPECIFYING LAB COORDINATES OF ROTATION AXIS (GIVEN) C IC - NUMBER SPECIFYING A SUBSET OF PARAMETERS WHICH (GIVEN) C ARE TO BE REFINED. (UNIT CELL PARAMETERS ARE C TREATED SEPARATELY BY THE VALUE OF "ICS".) C 1: REFINE ALL PARAMETERS C 2: FIX THE ORIENTATION OF THE DETECTOR C 3: FIX THE ORIENTATION OF THE DETECTOR AND THE C DISTANCE BETWEEN DETECTOR AND CRYSTAL. C 4: FIX THE ORIENTATION OF THE DETECTOR AND THE C DIRECTION OF THE DIRECT BEAM. C 5: FIX THE ORIENTATION OF THE DETECTOR, THE C DISTANCE BETWEEN DETECTOR AND CRYSTAL, AND C THE DIRECTION OF THE DIRECT BEAM. C 6: FIX THE DIRECTION OF THE DIRECT BEAM AND THE C ORIENTATION OF THE UNIT CELL. C 7: FIX THE DISTANCE BETWEEN DETECTOR AND CRYSTAL, C THE ORIENTATION OF THE DETECTOR, THE DIRECTION C OF THE DIRECT BEAM AND THE ORIENTATION OF THE C UNIT CELL. C ICS - NUMBER SPECIFYING REFINEMENT CONSTRAINTS ON THE (GIVEN) C UNIT CELL PARAMETERS ARISING FROM SYMMETRY. C 0: DO NOT REFINE CELL PARAMETERS. C >0: REFINE INDEPENDENT CELL PARAMETERS. THE C INDEPENDENT PARAMETERS ARE DERIVED FROM C THE VALUE OF "ICS". C 1: TRICLINIC C 2: MONOCLINIC FIRST SETTING C 3: MONOCLINIC SECOND SETTING C 4: ORTHORHOMBIC C 5: TETRAGONAL C 6: TRIGONAL C 7: HEXAGONAL C 8: CUBIC C Q - LENGTH OF A PIXEL IN MILLIMETERS (GIVEN) C ORGX - X- AND Y-COORDINATES (PIXELS) ON DETECTOR SUCH (UPDATED) C ORGY - THAT THE DETECTOR NORMAL WOULD INTERSECT THE (UPDATED) C CRYSTAL C F - CRYSTAL TO DETECTOR DISTANCE (MM). (UPDATED) C S0L - COORDINATES OF INCIDENT X-RAY BEAM WAVE VECTOR. (UPDATED) C ONLY THE DIRECTION OF S0L IS REFINED. C LENGTH OF S0L IS 1.0/LAMBDA. ( RECIPROCAL ANGSTROEM ) C ED - REAL ARRAY(3,3) SPECIFYING LAB COORDINATES OF (UPDATED) C DETECTOR AXES. C U - ARRAY(3,3) CONTAINING ORIENTATION MATRIX (UPDATED) C RCELL - ARRAY OF LENGTH 6 OF RECIPROCAL UNIT CELL PARAMETERS(UPDATED) C IN RECIPROCAL ANGSTROEM AND DEGREES. C SDU - ESTIMATED STANDARD DEVIATION (DEGREES) (RESULT) C FOR ORIENTATION MATRIX U C SDCELL - ARRAY(6) OF STANDARD DEVIATIONS (RESULT) C ( RECIPROCAL ANGSTROEM AND DEGREES ) FOR C RECIPROCAL UNIT CELL PARAMETERS. C SDPHI - STANDARD DEVIATION OF ANGULAR POSITION OF SPINDLE (UPDATED) C ( DEGREES ). A POSITIVE INPUT VALUE IS C USED TO CALCULATE THE WEIGHTS OF THE OBSERVED C SPINDLE POSITIONS OF THE REFLECTIONS. C A NON-POSITIVE VALUE INDICATES THAT A DEFAULT C VALUE OF 0.1 DEGREES SHOULD BE USED. C ON RETURN, SDPHI CONTAINS THE ESTIMATED STANDARD C DEVIATION OF THE SPINDLE ANGLE AT WHICH THE C REFLECTIONS WERE DIFFRACTING. C SDXY - STANDARD DEVIATION OF SPOT POSITION ON DETECTOR (UPDATED) C (PIXELS). A POSITIVE INPUT VALUE IS USED TO C CALCULATE THE WEIGHTS OF THE OBSERVED SPOT C POSITIONS OF THE REFLECTIONS. C A NON-POSITIVE VALUE INDICATES THAT A DEFAULT C VALUE OF ONE PIXEL SHOULD BE USED. C ON RETURN, SDXY CONTAINS THE ESTIMATED STANDARD C DEVIATION OF THE SPOT POSITIONS ON THE DETECTOR. C IER - ERROR INDICATOR SET BY SUBROUTINE . NORMALLY IER IS (RESULT) C NUMBER OF ACCEPTED REFLECTIONS. C >0 : NO ERROR. C 0 : INSUFFICIENT NUMBER OF ACCEPTED REFLECTIONS C -1 : Q IS NOT POSITIVE C -2 : F IS ZERO OR ILLEGAL DETECTOR ORIENTATION C -3 : ILLEGAL CELL PARAMETERS C -4 : ILLEGAL ROTATION AXIS OR DIRECT BEAM WAVE VECTOR C -5 : ILLEGAL CRYSTAL ORIENTATION MATRIX U C -6 : NCYCLE MUST BE BETWEEN 1 AND 10 C -7 : REINDEXING TRANSFORMATION IS SINGULAR C C*********************************************************************** INTEGER M,IC,ICS,NCYCLE,ICYCLE,MXFREE,MMFREE,NRIGHT,MXRIGHT, 1 MFREE,IRANK,I,J,MM,MY1,MY2,SPLIT,NCHECK,NBAD(3) INTEGER*4 N,NY,IER,NACC,SEED PARAMETER (MXFREE=14,MMFREE=(MXFREE*MXFREE+MXFREE)/2,NRIGHT=11, 1 MXRIGHT=MXFREE*NRIGHT) INTEGER*4 IX(*),IY(*),IPHI(*) INTEGER*2 IH(*),IK(*),IL(*),IP(6,8),MCS(8), 1 VAR(MXFREE,7),REIDX(12) REAL*8 QD(MMFREE),RD(MXRIGHT),AVGX(MXFREE),AVGY(MXFREE), 1 AVX(NRIGHT),AVY(NRIGHT),Z,EPS,ONE,ZERO REAL DXCALC(MXFREE),DYCALC(MXFREE),DELX(NRIGHT),DELY(NRIGHT), 1 ESD(MXFREE),DCPHIC(MXFREE),DSPHIC(MXFREE),RCPHI(NRIGHT), 2 RSPHI(NRIGHT),B(6),ZELLE(6),RZELLE(6),RCELL(6),CELL(6), 3 SDCELL(6),ACHSE(3),S0L(3),S0G(3),DS0G(3),A0(3,3),A(3,3), 4 DA(3,3,6),U(3,3),UG(3,3),DUG(3,3,3),EG(3,3),ED(3,3), 5 EDG(3,3),EDG0(3,3),DEDG(3,3,3),BASIS(3,3),XG(3),X0G(3), 6 DX0G(3,MXFREE),DXG(3),SG(3),DSG(3),SD(3),DSD(3),WPHI, 7 WXY,ESDPHI,ESDXY,SDPHI0,SDXY0,SDPHI,SDXY,SDU,ERROR,Q,F, 8 ORGX,ORGY,FH,FK,FL,XOBS,YOBS,XCALC,YCALC,CPHI,SPHI, 9 CPHIC,SPHIC,RHOQ,DRHOQ,R,RR,DRR,T1,T2,T3,T4,RAD,RAD100, $ DELERR,SDCUTOFF PARAMETER (RAD=57.29578,RAD100=100.0*RAD, 1 ZERO=0.0D+0,ONE=1.0D+0,EPS=1.0D-05) C&&*&& include ../inc/parameter.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file parameter.h C---- START of include file parameter.h C C PARAMETERS C IYLENGTH.. maximum number of I*2 words of data in the C "fast" (ie most rapidly changing) direction in the C digitised image. This will be HALF the number of pixels C for film data (each pixel is stored in one byte) C but will equal the number of pixels for IP data. C IXWDTH... The maximum number of "stripes" of data in the scanned image C ie the number of pixels in the "slow" direction C (This is the Y direction in the MOSFLM convention) C Note that the array "IMAGE" used to store the image is C declared as size IYLENGTH*IXWDTH I*2 words for IP data C and 2*IYLENGTH*IXWDTH BYTES for film data. C If this exceeds the C available memory, set ixwdth=1, recompile program C and use keyword "NOCORE" when running program. C Note that for the POSTREF and ADDPART options, C two images have to be stored in memory at once so C IXWDTH should be twice the number of records in an C image. C MAXHEAD maximum length of image header (in 4 byte words) C NREFLS.... maximum number of spots per film in generate file (10000) C MAXBOX.... maximum number of pixels in measurement box (1000) C MAXDIM.... maximum box size in either direction (pixels) (41) C MAXPAX.... maximum number of packs per generate file (1000) C MXDOV2..... maxdim/2 C MAXBUFF... maximum size of buffer (I*2) for storing ods C of active spots in subroutine meas(20000). C Must be .GE. MAXBOX*(NNLINE-1) for subroutine process C MREF...... maximum number of reflections to be used in post C refinement (6000) C NEXPAND... maximum number of expansions of the input measurement C box (2) C NMASKS.... maximum number of different profiles (25). Note the C connection between this parameter and NNLINE C NVECT..... maximum number of vectors for storing scanned image C in filmplot (10000) C NIMAX..... maximum number of images to be used together in C postrefinement (NADD or WIDTH options) (30) C NNLINE... maximum number of boundary lines for setting up C the areas for profile fitting. The maximum possible C number of standard profiles will be (NNLINE-1)**2 C although for a circular detector the actual number C may be less than this as some boxes will lie entirely C outside the detector. C NREJMAX... Maximum number of rejected background pixels, resulting C either from overlap of adjacent spots or outliers from C the background plane C NSPOTS... Maximum number of found spots (for autoindexing) that can C be stored (for all images). Also maximum number in C a file wriitten by IMSTILLS that can be C stored/displayed/edited. THis must be an even number C MCOLS.... Number of columns in output MTZ file C MCOLSTR.. Number of columns in output MTZ file for strategy option C C MTZ Orientation block C MBLENG is total length of block, MBLINT, MBLREA are numbers C of integers & reals C NRPAR.... Maximum number of refineable parameters for detector C positional refinement (subroutine RDIST) C NSEGMAX.. Maximum number of segments in STRATEGY C MULTMAX... Maximum number of observations with same hkl in COMPLETE C MAXDIFF... Maximum number of different packs that a given hkl occurs on C NRESBIN... Maximum number of resolution bins (COMPLETE) C C MAXIMG... Maximum number of images that can be read in using the IMAGE C keyword or the "read Image" menu option. C MXSPOT... Maximum number of spots that can be found on one image C (before rejection on spot size). C MXCENT... Maximum number of active spots during spot finding C (findspots) C C MGRA, NGRA... maximum number of reflections and images over which a C reflection can be spread for postrefinement. C C .. Parameters .. INTEGER IXWDTH PARAMETER (IXWDTH=8192) c PARAMETER (IXWDTH=12288) INTEGER IYLENGTH PARAMETER (IYLENGTH=4096) c PARAMETER (IYLENGTH=6144) INTEGER MAXHEAD PARAMETER (MAXHEAD=5000) INTEGER MAXBOX PARAMETER (MAXBOX=1500) INTEGER MAXBUFF PARAMETER (MAXBUFF=20000) INTEGER MAXDIM PARAMETER (MAXDIM=41) INTEGER MAXPAX PARAMETER (MAXPAX=1000) INTEGER MXDOV2 PARAMETER (MXDOV2=MAXDIM/2) INTEGER NEXPAND PARAMETER (NEXPAND=2) INTEGER NMASKS PARAMETER (NMASKS=25) INTEGER NREFLS PARAMETER (NREFLS=100000) INTEGER MREF PARAMETER (MREF=6000) INTEGER NVECT PARAMETER (NVECT=10000) INTEGER NIMAX PARAMETER (NIMAX=30) INTEGER NNLINE PARAMETER (NNLINE=6) INTEGER NREJMAX PARAMETER (NREJMAX=600) INTEGER NSPOTS PARAMETER (NSPOTS=5000) INTEGER MCOLS PARAMETER (MCOLS=16) INTEGER MCOLSTR PARAMETER (MCOLSTR=6) INTEGER NREFSTR C C---- Each reflection for strategy run needs MCOLSTR I*2 words C plus an I*4 word for the merging C PARAMETER (NREFSTR = IXWDTH*IYLENGTH/(2+MCOLSTR)) INTEGER MBLENG,MBLINT,MBLREA PARAMETER (MBLENG=185,MBLINT=29,MBLREA=156) INTEGER NRPAR PARAMETER (NRPAR=14) INTEGER NSEGMAX PARAMETER (NSEGMAX=100) INTEGER MULTMAX PARAMETER (MULTMAX=100) INTEGER MAXDIFF PARAMETER (MAXDIFF=100) INTEGER NRESBIN PARAMETER (NRESBIN=20) INTEGER MXSPOT PARAMETER (MXSPOT=5000) INTEGER MAXIMG PARAMETER (MAXIMG=100) INTEGER NPIXBG PARAMETER (NPIXBG=51) INTEGER MXCENT PARAMETER (MXCENT=500) INTEGER NGRA,MGRA PARAMETER (NGRA=20) PARAMETER (MGRA=20000) C&&*&& end_include ../inc/parameter.f C&&*&& include ../inc/ioo.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file ioo.h C---- START of include file ioo.h C C C C .. Scalars in common block /IOO/ .. INTEGER IOUT,IUNIT,ITIN,ITOUT,INOD,INMO,IDU,NWRN,IBRIEF,ISUMMR, + ICOORD,SERVERFD LOGICAL ONLINE,ONEFILE,FHEADER,BRIEF,GRAPH,IOERR, $ NODISPLAY,LBELL,JPGOUT,SOCKLO C .. C .. Common block /IOO/ .. c COMMON /IOO/IOUT,IUNIT,ONLINE,ITIN,ITOUT,INOD,INMO,IDU,NWRN, c + ONEFILE,FHEADER,BRIEF,IBRIEF,GRAPH,ISUMMR,ICOORD, c + IOERR,NODISPLAY,LBELL C .. C C COMMON /IOO/IOUT,IUNIT,ITIN,ITOUT,INOD,INMO,IDU,NWRN,IBRIEF, + ISUMMR,ICOORD,SERVERFD,ONLINE,ONEFILE, + FHEADER,BRIEF,GRAPH,IOERR,NODISPLAY,LBELL,JPGOUT, $ SOCKLO C&&*&& end_include ../inc/ioo.f C&&*&& include ../inc/ioosum.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file ioosum.h C---- START of include file ioosum.h C C .. Scalars in common block /IOOSUM/ INTEGER NLSUM1,NLSUM2,NSUMSTART1,NSUMSTART2 C C .. Arrays in common block /IOOSUMC/ .. CHARACTER*133 LINESUM1(MAXPAX),LINESUM2(MAXPAX) CHARACTER*101 IOLINE(100) C .. C .. Common block /IOOSUM/ .. COMMON /IOOSUM/ NLSUM1,NLSUM2,NSUMSTART1,NSUMSTART2 C .. C .. Common block /IOOSUMC/ .. COMMON /IOOSUMC/ LINESUM1,LINESUM2,IOLINE C&&*&& end_include ../inc/ioosum.f C&&*&& include ../inc/debug.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file debug.h C---- START of include file debug.h C C C C .. Arrays in common /DEBUG/ .. REAL XWARN INTEGER NDEBUG,IWARN LOGICAL DEBUG,LPRINT,DUMP,WARN C C .. Scalars in common /DEBUG/ .. REAL BGRLIM INTEGER NDUMP,IDUMP,MXDUMP LOGICAL SPOT C C .. C .. Common Block /DEBUG/.. COMMON /DEBUG/XWARN(20,100),BGRLIM,NDEBUG(80),IWARN(20,100), $ NDUMP,IDUMP,MXDUMP,DEBUG(80),LPRINT(20),DUMP(30), + WARN(100),SPOT C .. C C&&*&& end_include ../inc/debug.f LOGICAL NULINE C C--- Scalars for XDL i/o C CHARACTER LINE*90 C*********************************************************************** DATA IP/ 1,2,3,4,5,6, 1,2,3,0,0,4, 1 1,2,3,0,4,0, 1,2,3,0,0,0, 2 1,1,2,0,0,0, 1,1,1,2,2,2, 3 1,1,2,0,0,0, 1,1,1,0,0,0/ DATA MCS/ 6,4,4,3,2,2,2,1/ DATA VAR/ 1,1,1,1,1,1,1,1,6*1, 1,0,1,0,1,1,1,1,6*1, 1 0,0,1,0,1,1,1,1,6*1, 1,0,0,0,0,1,1,1,6*1, 2 0,0,0,0,0,1,1,1,6*1, 1,1,1,1,0,0,0,0,6*1, 3 0,0,0,0,0,0,0,0,6*1/ DATA DELERR / 0.1 / C C C C IER=-3 SDU=0.0 DO 10 MY1=1,6 IF (RCELL(MY1).LE.0.0) RETURN IF ((MY1.GT.3).AND.(RCELL(MY1).GT.179.0))RETURN 10 SDCELL(MY1)=0.0 C C---- get number of independent parameters C IF ((ICS.GT.0).AND.(ICS.LT.9))THEN M=MCS(ICS) ELSE M=0 ENDIF MFREE=M+8 C C---- check for sufficient number of reflections C IER=0 IF (N.LE.MFREE)RETURN C C---- check if crystal orientation and cell parameters C should be separated C IF (IC.LT.1)IC=1 IF (IC.GT.7)IC=7 IF ((ICS.EQ.1).AND.(IC.LT.6))THEN SPLIT=0 ELSE SPLIT=1 ENDIF C C---- check q,f C IF (Q.LE.0.0)IER=-1 IF (F.le.1e-5)IER=-2 IF (IER.LT.0)RETURN C C---- get weights for observational equations C IF (SDPHI.LE.0.0)SDPHI=0.1 SDPHI0=SDPHI/RAD WPHI=1.0/SDPHI0**2 IF (SDXY.LE.0.0)SDXY=1.0 SDXY0=SDXY*Q WXY=1.0/SDXY0**2 C C---- check number of refine cycles C IER=-6 IF ((NCYCLE.LT.1).OR.(NCYCLE.GT.10))RETURN C C---- check reindexing transformation C IER=-7 I=REIDX(1)*(REIDX(6)*REIDX(11)-REIDX(7)*REIDX(10)) 1 -REIDX(2)*(REIDX(5)*REIDX(11)-REIDX(7)*REIDX( 9)) 2 +REIDX(3)*(REIDX(5)*REIDX(10)-REIDX(6)*REIDX( 9)) IF (I.EQ.0)RETURN C C---- define goniostat system C CALL GONSYS(ACHSE,S0L,S0G,EG,I) IF (I.NE.0)THEN IER=-4 RETURN ENDIF C C---- renormalize crystal orientation matrix to orthogonal form to C prevent accumulation of rounding errors. C CALL UNORM(U,I) IF (I.NE.0)THEN IER=-5 RETURN ENDIF C C---- get representation of crystal orientation matrix C with respect to goniostat system C CALL MINV33(A,EG,R) CALL MATMUL3(UG,A,U) C C---- get representation of detector orientation matrix C * with respect to goniostat system C CALL UNORM(ED,I) IF (I.NE.0)THEN IER=-2 RETURN ENDIF CALL MATMUL3(EDG,A,ED) C C---- save original detector orientation matrix C CALL MATCOP(EDG,EDG0) C C---- refinement loop C C derivatives of sin/cos of spindle position with respect to C distance and orientation of the detector are always zero. C DO 20 J=1,4 DSPHIC(J)=0.0 DCPHIC(J)=0.0 20 ENDDO DO 570 ICYCLE=1,NCYCLE IF(DEBUG(70))THEN CALL RECCEL(CELL,RCELL,1.0) IF(ONLINE)WRITE(*,6800)ICYCLE 6800 FORMAT('CELREF CYCLE NUMBER ',I1,' STARTING') IF(ONLINE)WRITE(*,6820)NCYCLE,REIDX,N,ACHSE,IC,ICS, @ Q,ORGX,ORGY,F,S0L,((ED(I,J),J=1,3),I=1,3), 1 ((UG(I,J),J=1,3),I=1,3),RCELL,CELL,SDU,SDCELL,SDPHI, + SDXY,IER WRITE(IOUT,6800)ICYCLE WRITE(IOUT,6820)NCYCLE,REIDX,N,ACHSE,IC,ICS, @ Q,ORGX,ORGY,F,S0L,((ED(I,J),J=1,3),I=1,3), 1 ((UG(I,J),J=1,3),I=1,3),RCELL,CELL,SDU,SDCELL,SDPHI, + SDXY,IER 6820 format(72(1H-),/,'NCYCLE = ',i2,/,'REIDX0 = ',4i2,2(/,9X,4I2),/, $ 'NREF = ',i5,/,'ACHSE = ',3F5.2,/, $ 'IC = ',i2,' ICS = ',i2,' RAST = ',F8.4,/, $ 'ORGX = ',F8.2,' ORGY = ',F8.2,' XTD = ',F8.2,/, $ 'S0L = ',3F12.6,/,'ED = ',3F5.2,2(/,5X,3F5.2),/, $ 'UG = ',3F10.6,2(/,7X,3F10.6),/,'RCELL = ', $ 6f9.4,/,'CELL = ', $ 6f9.4,/,'SDU = ',f10.6,/,'SDCELL = ',6F10.4, $ /,'SDPHI = ',F10.6,' SDXY = ',F10.6,' IERR = ',I4,/, $ 72(1H=),/) endif ESDPHI=0.0 ESDXY =0.0 C C---- clear normal matrix and right hand sides C DO 30 MY1=1,MMFREE QD(MY1)=ZERO 30 ENDDO DO 40 MY1=1,MXRIGHT RD(MY1)=ZERO 40 ENDDO DO 50 MY1=1,MXFREE AVGX(MY1)=ZERO AVGY(MY1)=ZERO 50 ENDDO DO 60 MY1=1,NRIGHT AVX(MY1)=ZERO AVY(MY1)=ZERO 60 ENDDO C---- calculate derivative of detector orientation matrix C DO 70 J=1,3 DEDG(1,J,1)= 0.0 DEDG(2,J,1)=-EDG(3,J) DEDG(3,J,1)= EDG(2,J) DEDG(1,J,2)= EDG(3,J) DEDG(2,J,2)= 0.0 DEDG(3,J,2)=-EDG(1,J) DEDG(1,J,3)=-EDG(2,J) DEDG(2,J,3)= EDG(1,J) DEDG(3,J,3)= 0.0 70 ENDDO C C---- calculate derivatives of direct beam wavevector C DS0G(1)= 0.0 DS0G(2)=-S0G(3) DS0G(3)= S0G(2) C C---- calculate derivative of crystal orientation matrix C IF (SPLIT.NE.0)THEN DO 80 J=1,3 DUG(1,J,1)= 0.0 DUG(2,J,1)=-UG(3,J) DUG(3,J,1)= UG(2,J) DUG(1,J,2)= UG(3,J) DUG(2,J,2)= 0.0 DUG(3,J,2)=-UG(1,J) DUG(1,J,3)=-UG(2,J) DUG(2,J,3)= UG(1,J) DUG(3,J,3)= 0.0 80 ENDDO ENDIF C C---- calculate setting matrix C C 90 CONTINUE DO 100 I=1,3 R=RCELL(I+3)/RAD B(I) =COS(R) B(I+3)=SIN(R) DO 97 J=1,3 A0(I,J)=0.0 DO 93 MY1=1,6 DA(I,J,MY1)=0.0 93 ENDDO 97 ENDDO 100 ENDDO A0(1,1)=RCELL(1)*B(5) A0(1,2)=RCELL(2)*(B(3)-B(1)*B(2))/B(5) A0(2,2)=SQRT((RCELL(2)*B(4))**2-A0(1,2)**2) A0(3,1)=RCELL(1)*B(2) A0(3,2)=RCELL(2)*B(1) A0(3,3)=RCELL(3) IF ((M.GE.1).AND.(SPLIT.NE.0))THEN C C---- calculate derivatives of setting matrix with respect to C independent cell parameters C DA(1,1,1)=B(5) DA(3,1,1)=B(2) DA(1,2,2)=A0(1,2)/RCELL(2) DA(2,2,2)=A0(2,2)/RCELL(2) DA(3,2,2)=A0(3,2)/RCELL(2) DA(3,3,3)=1.0 DA(1,2,4)=RCELL(2)*B(4)*B(2)/B(5) DA(2,2,4)=(A0(3,2)*B(4)-A0(1,2)*DA(1,2,4))/A0(2,2) DA(3,2,4)=-RCELL(2)*B(4) DA(1,1,5)=A0(3,1) DA(3,1,5)=-A0(1,1) DA(1,2,5)=A0(3,2)-A0(1,2)*B(2)/B(5) DA(2,2,5)=-A0(1,2)*DA(1,2,5)/A0(2,2) DA(1,2,6)=-RCELL(2)*B(6)/B(5) DA(2,2,6)=-A0(1,2)*DA(1,2,6)/A0(2,2) DO 130 I=1,3 DO 127 J=1,3 DO 110 MY1=1,M B(MY1)=0.0 110 ENDDO DO 120 MY1=1,6 MY2=IP(MY1,ICS) IF (MY2.GT.0)B(MY2)=B(MY2)+DA(I,J,MY1) 120 ENDDO DO 123 MY1=1,M DA(I,J,MY1)=B(MY1) 123 ENDDO 127 ENDDO 130 ENDDO DO 150 MY1=1,M DO 140 I=1,3 DO 135 J=1,3 A(I,J)=UG(I,1)*DA(1,J,MY1)+UG(I,2)* $ DA(2,J,MY1)+UG(I,3)*DA(3,J,MY1) 135 ENDDO 140 ENDDO DO 148 I=1,3 DO 145 J=1,3 DA(I,J,MY1)=A(I,J) 145 ENDDO 148 ENDDO 150 ENDDO ENDIF 160 CALL MATMUL3(A,UG,A0) C C---- enter contributions of observational equations C NACC=0 SEED=1009 c DO 165 NY = 1,N c IF ((IH(NY).EQ.0).AND.(IK(NY).EQ.0).AND.(IL(NY).EQ.0)) c + NBAD(1) = NBAD(1) + 1 c 165 ENDDO IF(NBAD(1).EQ.N)THEN IER = 0 RETURN ENDIF DO 330 NY=1,N C C---- apply reindexing C IF ((IH(NY).NE.0).OR.(IK(NY).NE.0).OR.(IL(NY).NE.0))THEN FH=REIDX(1)*IH(NY)+REIDX( 2)*IK(NY)+ $ REIDX( 3)*IL(NY)+REIDX( 4) FK=REIDX(5)*IH(NY)+REIDX( 6)*IK(NY)+ $ REIDX( 7)*IL(NY)+REIDX( 8) FL=REIDX(9)*IH(NY)+REIDX(10)*IK(NY)+ $ REIDX(11)*IL(NY)+REIDX(12) XOBS=(IX(NY)/10.0-ORGX)*Q YOBS=(IY(NY)/10.0-ORGY)*Q R=IPHI(NY)/RAD100 CPHI=COS(R) SPHI=SIN(R) C C---- get goniostat coordinates of reflection at phi=0 C DO 170 I=1,3 X0G(I)=A(I,1)*FH+A(I,2)*FK+A(I,3)*FL 170 ENDDO C C---- get goniostat coordinates of reflection at diffraction C RR=X0G(1)**2+X0G(2)**2+X0G(3)**2 RHOQ=RR-X0G(2)**2 XG(3)=-(RR*0.5+X0G(2)*S0G(2))/S0G(3) XG(2)=X0G(2) XG(1)=RHOQ-XG(3)**2 IF (XG(1).LE.0.0)GO TO 325 XG(1)=SQRT(XG(1)) IF ((X0G(1)*CPHI+X0G(3)*SPHI).LT.0.0)XG(1)=-XG(1) C C---- calculate sin/cos of spindle position at diffraction C CPHIC=(XG(1)*X0G(1)+XG(3)*X0G(3))/RHOQ SPHIC=(XG(1)*X0G(3)-XG(3)*X0G(1))/RHOQ C C---- get goniostat coordinates of diffracted beam wavevector C DO 180 I=1,3 SG(I)=S0G(I)+XG(I) 180 ENDDO C C---- get detector coordinates of diffracted beam wavevector C DO 190 I=1,3 SD(I)=EDG(1,I)*SG(1)+EDG(2,I)*SG(2)+EDG(3,I)*SG(3) 190 ENDDO IF (SD(3).le.1e-5)GO TO 325 C C---- get detector coordinates of intersection point of diffracted C beam with detector surface C XCALC=F*SD(1)/SD(3) YCALC=F*SD(2)/SD(3) 6840 FORMAT('+++++ DPS ++++++',/, $ ' H K L IP(X) IP(Y) X(OBS)', $ ' Y(OBS) X(CALC) Y(CALC)') 6860 FORMAT(3I4,2I7,4F12.5) IF (DEBUG(70))THEN IF(NY.EQ.1) THEN IF(ONLINE)WRITE(*,FMT=6840) WRITE(IOUT,FMT=6840) ENDIF IF (NY.LE.10) THEN IF(ONLINE)WRITE(*,FMT=6860)IH(NY),IK(NY),IL(NY), $ IX(NY),IY(NY),XOBS,YOBS,XCALC,YCALC WRITE(IOUT,FMT=6860)IH(NY),IK(NY),IL(NY),IX(NY), $ IY(NY),XOBS,YOBS,XCALC,YCALC ENDIF ENDIF NACC=NACC+1 C C---- derivatives with respect to f C DXCALC(1)=SD(1)/SD(3) DYCALC(1)=SD(2)/SD(3) C C---- derivatives with respect to detector orientation C DO 200 MY1=1,3 T1=DEDG(1,1,MY1)*SG(1)+DEDG(2,1,MY1)*SG(2)+ $ DEDG(3,1,MY1)*SG(3) T2=DEDG(1,2,MY1)*SG(1)+DEDG(2,2,MY1)*SG(2)+ $ DEDG(3,2,MY1)*SG(3) T3=DEDG(1,3,MY1)*SG(1)+DEDG(2,3,MY1)*SG(2)+ $ DEDG(3,3,MY1)*SG(3) DXCALC(MY1+1)=(T1*F-T3*XCALC)/SD(3) DYCALC(MY1+1)=(T2*F-T3*YCALC)/SD(3) 200 ENDDO C C---- derivatives with respect to kappa C ..... derivatives of goniostat coordinates "xg" C DXG(3)=X0G(2)-XG(3)*S0G(2)/S0G(3) DXG(1)=-XG(3)*DXG(3)/XG(1) C C ..... derivatives of sin/cos of spindle position C DSPHIC(5)=(DXG(1)*X0G(3)-DXG(3)*X0G(1))/RHOQ DCPHIC(5)=(DXG(1)*X0G(1)+DXG(3)*X0G(3))/RHOQ C C ..... derivatives of goniostat coordinates of "sg" C DSG(1)=DXG(1) DSG(2)=-S0G(3) DSG(3)=DXG(3)+S0G(2) C C ..... detector coordinates of derivatives of C diffracted beam wavevector C DO 210 I=1,3 DS D(I)=EDG(1,I)*DSG(1)+EDG(2,I)* $ DSG(2)+EDG(3,I)*DSG(3) 210 ENDDO C C ..... derivatives of calculated detector coordinates C DXCALC(5)=(DSD(1)*F-DSD(3)*XCALC)/SD(3) DYCALC(5)=(DSD(2)*F-DSD(3)*YCALC)/SD(3) C C---- derivatives with respect to reciprocal cell setting matrix C IF (SPLIT.NE.1)THEN DO 220 I=1,3 DO 215 J=1,M+3 DX0G(I,J)=0.0 215 ENDDO 220 ENDDO DO 230 I=1,3 DX0G(I,I )=FH DX0G(I,I+3)=FK DX0G(I,I+6)=FL 230 ENDDO GO TO 260 C C---- derivatives with respect to unit cell orientation C ENDIF 240 DX0G(1,1)= 0.0 DX0G(2,1)=-X0G(3) DX0G(3,1)= X0G(2) DX0G(1,2)= X0G(3) DX0G(2,2)= 0.0 DX0G(3,2)=-X0G(1) DX0G(1,3)=-X0G(2) DX0G(2,3)= X0G(1) DX0G(3,3)= 0.0 IF (M.GE.1)THEN C C ..... derivatives with respect to independent cell parameters C DO 250 MY1=1,M DO 245 I=1,3 DX0G(I,MY1+3)=DA(I,1,MY1)*FH+DA(I,2,MY1)* $ FK+DA(I,3,MY1)*FL 245 ENDDO 250 ENDDO C C ..... derivatives with respect to unit cell orientation and C independent cell parameters C ENDIF 260 DO 280 J=1,M+3 DRR=X0G(1)*DX0G(1,J)+X0G(2)*DX0G(2,J)+X0G(3)*DX0G(3,J) DXG(3)=-(DRR+S0G(2)*DX0G(2,J))/S0G(3) DXG(1)=(DRR-X0G(2)*DX0G(2,J)-XG(3)*DXG(3))/XG(1) DRHOQ=2.0*(X0G(1)*DX0G(1,J)+X0G(3)*DX0G(3,J)) DSPHIC(J+5)=(DXG(1)*X0G(3)+XG(1)*DX0G(3,J) @ -DXG(3)*X0G(1)-XG(3)*DX0G(1,J)-SPHIC*DRHOQ)/RHOQ DCPHIC(J+5)=(DXG(1)*X0G(1)+XG(1)*DX0G(1,J) @ +DXG(3)*X0G(3)+XG(3)*DX0G(3,J)-CPHIC*DRHOQ)/RHOQ C C ..... derivatives of goniostat coordinates of "sg" C DSG(1)=DXG(1) DSG(2)=DX0G(2,J) DSG(3)=DXG(3) C C ..... detector coordinates of derivatives of C diffracted beam wavevector C DO 270 I=1,3 DSD(I)=EDG(1,I)*DSG(1)+EDG(2,I)* $ DSG(2)+EDG(3,I)*DSG(3) 270 ENDDO C C ..... derivatives of calculated detector coordinates C DXCALC(J+5)=(DSD(1)*F-DSD(3)*XCALC)/SD(3) DYCALC(J+5)=(DSD(2)*F-DSD(3)*YCALC)/SD(3) 280 ENDDO C C---- calculate residuals C RCPHI(1)=CPHIC-CPHI RSPHI(1)=SPHIC-SPHI DELX(1)=XCALC-XOBS DELY(1)=YCALC-YOBS C C---- remove outliers from next refinement round C IF((SQRT((DELX(1)**2)+(DELY(1)**2)).GE.SDCUTOFF* $ SDXY*Q).AND.(ICYCLE.GT.2))THEN IH(NY) = 0 IK(NY) = 0 IL(NY) = 0 NBAD(1) = NBAD(1) + 1 ENDIF C C---- add normally distributed random errors to residuals C R=SQRT(RR/RHOQ)*SDPHI0 DO 290 MY1=2,NRIGHT SEED=MOD(151*SEED+1,20011) ERROR=(SEED/20011.0-0.5)*R RCPHI(MY1)=RCPHI(1)+SPHI*ERROR RSPHI(MY1)=RSPHI(1)-CPHI*ERROR SEED=MOD(151*SEED+1,20011) DELX(MY1)=DELX(1)-(SEED/20011.0-0.5)*SDXY0 SEED=MOD(151*SEED+1,20011) DELY(MY1)=DELY(1)-(SEED/20011.0-0.5)*SDXY0 290 ENDDO C C---- add contributions to determine root-mean-square of residuals C ESDPHI=ESDPHI+(RCPHI(1)**2+RSPHI(1)**2)*RHOQ/RR ESDXY=ESDXY+DELX(1)**2+DELY(1)**2 C C---- add contribution of this reflection to normal equations C MM=0 DO 310 MY1=1,MFREE AVGX(MY1)=AVGX(MY1)+DXCALC(MY1) AVGY(MY1)=AVGY(MY1)+DYCALC(MY1) T1=DSPHIC(MY1)*WPHI*RHOQ/RR T2=DCPHIC(MY1)*WPHI*RHOQ/RR T3=DXCALC(MY1)*WXY T4=DYCALC(MY1)*WXY J=MY1 DO 300 MY2=1,NRIGHT RD(J)=RD(J)-RSPHI(MY2)*T1-RCPHI(MY2)*T2-DELX(MY2)* $ T3-DELY(MY2)*T4 J=J+MFREE 300 ENDDO DO 305 MY2=1,MY1 MM=MM+1 QD(MM)=QD(MM)+T1*DSPHIC(MY2)+T2*DCPHIC(MY2) @ +T3*DXCALC(MY2)+T4*DYCALC(MY2) 305 ENDDO 310 ENDDO DO 320 MY2=1,NRIGHT AVX(MY2)=AVX(MY2)+DELX(MY2) AVY(MY2)=AVY(MY2)+DELY(MY2) 320 ENDDO ENDIF 325 CONTINUE ! okay for a GOTO target 330 ENDDO C C---- get estimated standard deviations of observed reflection C positions and angles C IF (NACC.LE.MFREE)THEN IER=0 RETURN ENDIF SDPHI=RAD*SQRT(ESDPHI/(NACC-MFREE)) SDXY=SQRT(ESDXY/(NACC-MFREE))/Q C C---- get mean-values of residuals C DO 340 MY2=1,NRIGHT AVX(MY2)=AVX(MY2)/NACC AVY(MY2)=AVY(MY2)/NACC 340 ENDDO C C---- get mean-values of gradients C DO 350 MY1=1,MFREE AVGX(MY1)=AVGX(MY1)/NACC AVGY(MY1)=AVGY(MY1)/NACC 350 ENDDO C C---- correct origin C ORGX=ORGX-AVX(1)/Q ORGY=ORGY-AVY(1)/Q C C---- early termination because goal has already been achieved C IF ((SDPHI.GE.0.01).OR.(SDXY.GT.0.05))THEN C IF ((SDPHI.LT.0.01).AND.(SDXY.LE.0.05))GO TO 600 C C---- subtract mean-values of residuals from right-hand side C and tensor product of mean gradients from normal matrix C MM=0 DO 370 MY1=1,MFREE J=MY1 DO 360 MY2=1,NRIGHT RD(J)=RD(J)+WXY*NACC*(AVX(MY2)*AVGX(MY1)+ $ AVY(MY2)*AVGY(MY1)) J=J+MFREE 360 ENDDO DO 365 MY2=1,MY1 MM=MM+1 QD(MM)=QD(MM)-WXY*NACC*(AVGX(MY1)*AVGX(MY2)+ $ AVGY(MY1)*AVGY(MY2)) 365 ENDDO 370 ENDDO C C---- rescale system of equations C MM=0 DO 380 MY1=1,MFREE MM=MM+MY1 Z=QD(MM) IF (Z.GT.ZERO)Z=ONE/DSQRT(Z) AVGX(MY1)=Z ESD(MY1)=Z J=MY1 DO 375 MY2=1,NRIGHT RD(J)=RD(J)*Z J=J+MFREE 375 ENDDO 380 ENDDO MM=0 DO 390 MY1=1,MFREE DO 385 MY2=1,MY1 MM=MM+1 QD(MM)=QD(MM)*AVGX(MY1)*AVGX(MY2) 385 ENDDO 390 ENDDO C C---- remove fixed parameters from the normal equations C MM=0 DO 430 MY1=1,MFREE IF (VAR(MY1,IC).EQ.0)THEN J=MY1 DO 400 MY2=1,NRIGHT RD(J)=ZERO J=J+MFREE 400 ENDDO ENDIF 410 DO 420 MY2=1,MY1 MM=MM+1 IF (((VAR(MY1,IC).EQ.0).OR.(VAR(MY2,IC).EQ.0)) $ .AND.(MY2.NE.MY1)) @ QD(MM)=ZERO 420 ENDDO QD(MM)=ONE 430 ENDDO C C---- solve normal equations C CALL DGELS(RD,QD,MFREE,NRIGHT,EPS,IRANK,AVGX) DO 450 MY1=1,MFREE Z=ZERO MM=MY1 DO 440 MY2=1,NRIGHT RD(MM)=RD(MM)*ESD(MY1) Z=Z+(RD(MM)-RD(MY1))**2 MM=MM+MFREE 440 ENDDO ESD(MY1)=DSQRT(Z/(NRIGHT-1)) 450 ENDDO C C---- get scaling factor for standard deviations of cell parameters C T1=SDPHI/SQRT(SDPHI**2+(SDPHI0*RAD)**2) C C t2=sdxy/sqrt(sdxy**2+(sdxy0/q)**2) C C---- apply corrections and calculate estimated standard deviations C for the refined parameters C C ..... detector distance C F=F+RD(1) C C ..... detector orientation C DO 460 J=1,3 DO 455 I=1,3 EDG(I,J)=EDG(I,J) @ +RD(2)*DEDG(I,J,1)+RD(3)*DEDG(I,J,2)+ $ RD(4)*DEDG(I,J,3) 455 ENDDO 460 ENDDO CALL UNORM(EDG,I) IF (I.NE.0)THEN IER=-2 RETURN ENDIF C C .....incident x-ray beam (kappa) C R=RD(5) CPHI=COS(R) SPHI=SIN(R) R=S0G(2)*CPHI-S0G(3)*SPHI S0G(3)=S0G(3)*CPHI+S0G(2)*SPHI S0G(2)=R IF (SPLIT.NE.0)THEN C C .....orientation matrix C DO 470 J=1,3 DO 465 I=1,3 UG(I,J)=UG(I,J)+RD(6)*DUG(I,J,1)+ $ RD(7)*DUG(I,J,2)+RD(8)*DUG(I,J,3) 465 ENDDO 470 ENDDO CALL UNORM(UG,I) IF (I.NE.0)THEN IER=-5 RETURN ENDIF SDU=RAD*SQRT(ESD(6)**2+ESD(7)**2+ESD(8)**2) C C .....reciprocal cell dimensions C DO 480 MY1=1,6 B(MY1)=RCELL(MY1) RZELLE(MY1)=RCELL(MY1) SDCELL(MY1)=0.0 480 ENDDO IF (M.LT.1)GO TO 565 DO 500 I=1,NRIGHT DO 490 MY1=1,6 MY2=IP(MY1,ICS) IF (MY2.GT.0)THEN IF (MY1.LT.4)THEN R=RD(MY2+8+MFREE*(I-1)) ELSE R=RAD*RD(MY2+8+MFREE*(I-1)) ENDIF RZELLE(MY1)=B(MY1)+R ENDIF 485 CONTINUE 490 ENDDO c CALL INVCEL(ZELLE,RZELLE,R) CALL RECCEL(ZELLE,RZELLE,1.0) DO 495 MY1=1,6 IF (I.EQ.1)THEN CELL(MY1)=ZELLE(MY1) RCELL(MY1)=RZELLE(MY1) ELSE SDCELL(MY1)=SDCELL(MY1)+ $ (ZELLE(MY1)-CELL(MY1))**2 ENDIF 495 ENDDO 500 ENDDO GO TO 540 C C---- update rec. setting matrix and extract cell parameters and C crystal orientation C ENDIF 510 DO 530 MY1=1,NRIGHT DO 520 I=1,3 DO 515 J=1,3 A0(I,J)=A(I,J)+RD(I+3*(J-1)+5+MFREE*(MY1-1)) 515 ENDDO 520 ENDDO IF (MY1.EQ.1)CALL MATCOP(A0,U) CALL MINV33(BASIS,A0,R) CALL METRIC(BASIS,ZELLE,IER) CALL RECCEL(RZELLE,ZELLE,1.0) c CALL INVCEL(RZELLE,ZELLE,R) DO 525 I=1,6 IF (MY1.EQ.1)THEN CELL(I)=ZELLE(I) RCELL(I)=RZELLE(I) ELSE SDCELL(I)=SDCELL(I)+(ZELLE(I)-CELL(I))**2 ENDIF 525 ENDDO 530 ENDDO CALL RFSETMAT(RCELL,A) CALL MINV33(BASIS,A,R) CALL MATMUL3(UG,U,BASIS) 540 DO 550 I=1,6 SDCELL(I)=SQRT(T1*SDCELL(I)/(NRIGHT-1)) 550 ENDDO ELSE GOTO 600 !early termination because goal has already been achieved ENDIF 565 CONTINUE 570 ENDDO C C---- end of refinement loop C C 600 IF (IC.NE.5)THEN C C---- transform back to laboratory coordinate system C CPHI=0.0 SPHI=0.0 DO 610 I=1,3 CPHI=CPHI+EDG0(3,I)*EDG(3,I)+EDG0(1,I)*EDG(1,I) SPHI=SPHI+EDG0(1,I)*EDG(3,I)-EDG0(3,I)*EDG(1,I) 610 ENDDO R=SQRT(CPHI**2+SPHI**2) CPHI=CPHI/R SPHI=SPHI/R DO 620 I=1,3 R=EG(1,I)*CPHI+EG(3,I)*SPHI EG(3,I)=EG(3,I)*CPHI-EG(1,I)*SPHI EG(1,I)=R 620 ENDDO ENDIF 630 CALL MATMUL3(ED,EG,EDG) CALL MATMUL3(U,EG,UG) DO 640 I=1,3 S0L(I)=EG(I,2)*S0G(2)+EG(I,3)*S0G(3) 640 ENDDO IER=NACC 650 RETURN END C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C== MAIN == PROGRAM MOSFLM C ============== IMPLICIT NONE C C This version currently maintained by A.G.W. Leslie, C MRC Laboratory of Molecular Biology C Hills Road, C Cambridge C CB2 2QH C C Tel. 01223-248011 Ext 2212,2235 C E-mail address: ANDREW@UK.AC.CAM.MRC-LMB C C This version has been developed from the Imperial College C VAX version due to: C C A.G.W. LESLIE, A.J. WONACOTT, P. BRICK AND S. DOCKERILL C BLACKETT LABORATORY,IMPERIAL COLLEGE,LONDON SW7 2BZ UK C C Based in turn on the Nova version of C A.J. WONACOTT, S. DOCKERILL AND P. BRICK. C C and derived originally from the Cambridge version of C J. NYBORG and A.J.WONACOTT C C Last format 6430 C C Common block PARAMETER C .. Include files .. C&&*&& include ../inc/parameter.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file parameter.h C---- START of include file parameter.h C C PARAMETERS C IYLENGTH.. maximum number of I*2 words of data in the C "fast" (ie most rapidly changing) direction in the C digitised image. This will be HALF the number of pixels C for film data (each pixel is stored in one byte) C but will equal the number of pixels for IP data. C IXWDTH... The maximum number of "stripes" of data in the scanned image C ie the number of pixels in the "slow" direction C (This is the Y direction in the MOSFLM convention) C Note that the array "IMAGE" used to store the image is C declared as size IYLENGTH*IXWDTH I*2 words for IP data C and 2*IYLENGTH*IXWDTH BYTES for film data. C If this exceeds the C available memory, set ixwdth=1, recompile program C and use keyword "NOCORE" when running program. C Note that for the POSTREF and ADDPART options, C two images have to be stored in memory at once so C IXWDTH should be twice the number of records in an C image. C MAXHEAD maximum length of image header (in 4 byte words) C NREFLS.... maximum number of spots per film in generate file (10000) C MAXBOX.... maximum number of pixels in measurement box (1000) C MAXDIM.... maximum box size in either direction (pixels) (41) C MAXPAX.... maximum number of packs per generate file (1000) C MXDOV2..... maxdim/2 C MAXBUFF... maximum size of buffer (I*2) for storing ods C of active spots in subroutine meas(20000). C Must be .GE. MAXBOX*(NNLINE-1) for subroutine process C MREF...... maximum number of reflections to be used in post C refinement (6000) C NEXPAND... maximum number of expansions of the input measurement C box (2) C NMASKS.... maximum number of different profiles (25). Note the C connection between this parameter and NNLINE C NVECT..... maximum number of vectors for storing scanned image C in filmplot (10000) C NIMAX..... maximum number of images to be used together in C postrefinement (NADD or WIDTH options) (30) C NNLINE... maximum number of boundary lines for setting up C the areas for profile fitting. The maximum possible C number of standard profiles will be (NNLINE-1)**2 C although for a circular detector the actual number C may be less than this as some boxes will lie entirely C outside the detector. C NREJMAX... Maximum number of rejected background pixels, resulting C either from overlap of adjacent spots or outliers from C the background plane C NSPOTS... Maximum number of found spots (for autoindexing) that can C be stored (for all images). Also maximum number in C a file wriitten by IMSTILLS that can be C stored/displayed/edited. THis must be an even number C MCOLS.... Number of columns in output MTZ file C MCOLSTR.. Number of columns in output MTZ file for strategy option C C MTZ Orientation block C MBLENG is total length of block, MBLINT, MBLREA are numbers C of integers & reals C NRPAR.... Maximum number of refineable parameters for detector C positional refinement (subroutine RDIST) C NSEGMAX.. Maximum number of segments in STRATEGY C MULTMAX... Maximum number of observations with same hkl in COMPLETE C MAXDIFF... Maximum number of different packs that a given hkl occurs on C NRESBIN... Maximum number of resolution bins (COMPLETE) C C MAXIMG... Maximum number of images that can be read in using the IMAGE C keyword or the "read Image" menu option. C MXSPOT... Maximum number of spots that can be found on one image C (before rejection on spot size). C MXCENT... Maximum number of active spots during spot finding C (findspots) C C MGRA, NGRA... maximum number of reflections and images over which a C reflection can be spread for postrefinement. C C .. Parameters .. INTEGER IXWDTH PARAMETER (IXWDTH=8192) c PARAMETER (IXWDTH=12288) INTEGER IYLENGTH PARAMETER (IYLENGTH=4096) c PARAMETER (IYLENGTH=6144) INTEGER MAXHEAD PARAMETER (MAXHEAD=5000) INTEGER MAXBOX PARAMETER (MAXBOX=1500) INTEGER MAXBUFF PARAMETER (MAXBUFF=20000) INTEGER MAXDIM PARAMETER (MAXDIM=41) INTEGER MAXPAX PARAMETER (MAXPAX=1000) INTEGER MXDOV2 PARAMETER (MXDOV2=MAXDIM/2) INTEGER NEXPAND PARAMETER (NEXPAND=2) INTEGER NMASKS PARAMETER (NMASKS=25) INTEGER NREFLS PARAMETER (NREFLS=100000) INTEGER MREF PARAMETER (MREF=6000) INTEGER NVECT PARAMETER (NVECT=10000) INTEGER NIMAX PARAMETER (NIMAX=30) INTEGER NNLINE PARAMETER (NNLINE=6) INTEGER NREJMAX PARAMETER (NREJMAX=600) INTEGER NSPOTS PARAMETER (NSPOTS=5000) INTEGER MCOLS PARAMETER (MCOLS=16) INTEGER MCOLSTR PARAMETER (MCOLSTR=6) INTEGER NREFSTR C C---- Each reflection for strategy run needs MCOLSTR I*2 words C plus an I*4 word for the merging C PARAMETER (NREFSTR = IXWDTH*IYLENGTH/(2+MCOLSTR)) INTEGER MBLENG,MBLINT,MBLREA PARAMETER (MBLENG=185,MBLINT=29,MBLREA=156) INTEGER NRPAR PARAMETER (NRPAR=14) INTEGER NSEGMAX PARAMETER (NSEGMAX=100) INTEGER MULTMAX PARAMETER (MULTMAX=100) INTEGER MAXDIFF PARAMETER (MAXDIFF=100) INTEGER NRESBIN PARAMETER (NRESBIN=20) INTEGER MXSPOT PARAMETER (MXSPOT=5000) INTEGER MAXIMG PARAMETER (MAXIMG=100) INTEGER NPIXBG PARAMETER (NPIXBG=51) INTEGER MXCENT PARAMETER (MXCENT=500) INTEGER NGRA,MGRA PARAMETER (NGRA=20) PARAMETER (MGRA=20000) C&&*&& end_include ../inc/parameter.f C&&*&& include ../inc/mxdinc.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file mxdinc.h C---- START of include file mxdinc.h C C c common block for mxd routines: various parameters for XDL routines c c base_width width of base frame c base_height height of base frame c men_x,men_y position of menu area c par_x,par_y position of parameter area C C IORDER (R) Order of the data in the input image c with respect to two local axes ax1, ax2 e.g. c (xf, yf) as a number from 1 to 8. c 1 +ax1 slow +ax2 fast (+xf, +yf) c 2 +ax1 slow -ax2 fast (+xf, -yf) c 3 -ax1 slow +ax2 fast (-xf, +yf) c 4 -ax1 slow -ax2 fast (-xf, -yf) c 5 +ax2 slow +ax1 fast (+yf, +xf) c 6 +ax2 slow -ax1 fast (+yf, -xf) c 7 -ax2 slow +ax1 fast (-yf, +xf) c 8 -ax2 slow -ax1 fast (-yf, -xf) c c c JORDER (R) Display order with respect to the two c local axes (1 to 8) along the X-windows c axes X horizontal (left to right), Y vertical c (top to bottom ) with origin at top left c 1 +ax1 X (horiz) +ax2 Y (vert) (+xf, +yf) c 2 +ax1 X (horiz) -ax2 Y (vert) (+xf, -yf) c 3 -ax1 X (horiz) +ax2 Y (vert) (-xf, +yf) c 4 -ax1 X (horiz) -ax2 Y (vert) (-xf, -yf) c 5 +ax2 X (horiz) +ax1 Y (vert) (+yf, +xf) c 6 +ax2 X (horiz) -ax1 Y (vert) (+yf, -xf) c 7 -ax2 X (horiz) +ax1 Y (vert) (-yf, +xf) c 8 -ax2 X (horiz) -ax1 Y (vert) (-yf, -xf) c c (2 was standard for Laue programs) c c nxp_cmp number of pixels compressed to 1 in horizontal c display direction c nyp_cmp number of pixels compressed to 1 in vertical c display direction c nxdpx number of horizontal pixels in displayed image c nydpx number of vertical pixels in displayed image c img_horiz image direction for horizontal display (=1 fast, 2 slow) c img_vert image direction for vertical display (=1 fast, 2 slow) c img_map(4) mapping of image to display c imgmap(1) 1st point on fast axis (Yms) c imgmap(2) 1st point on slow axis (Zms) c imgmap(3) increment on fast axis c imgmap(4) increment on slow c img_x,img_y x, y position of image c men_x, men_y x, y position of menu c par_x, par_y x, y position of parameter table c io_x, io_y x, y position of IO area c not_x, not_y x, y position of notice area (parameter table c with no values) c pmn_x, pmn_y x, y position of popup abort menu c ppb_x, ppb_y x, y position of popup progress bar c busy_x, busy_y x, y position of busy window c img_width,img_height width, height of image window c men_width, men_height width, height of menu window c par_width, par_height width, height of parameter window c io_width, io_height width, height of IO window c not_width, not_height width, height of notice area c pmn_width, pmn_height width, height of Abort menu c ppb_width width of progress bar c busy_width, busy_height width, height of busy box c sub_process .true. if program is sub-process of eg clips, .false. c if standalone c C IFTYPE 1 = unsigned byte data C 2 = unsigned two-byte data (i2) C 3 = signed integer data C 4 = 'squashed i2' data (if Intensity>32767 C store as 65536-Intensity/8) INTEGER BASE_WIDTH,BASE_HEIGHT, $ IMAGE_ORDER,JIMAGE_ORDER,NXP_CMP,NYP_CMP, $ NXDPX,NYDPX, $ IMG_HORIZ,IMG_VERT,IMG_MAP(4), $ IMG_X,IMG_Y,MEN_X,MEN_Y,PAR_X,PAR_Y,IO_X,IO_Y, $ NOT_X,NOT_Y,PMN_X, PMN_Y,PPB_X, PPB_Y, BUSY_X, BUSY_Y, $ BUSY_Y2,IFTYPE INTEGER IMG_WIDTH, IMG_HEIGHT, MEN_WIDTH, MEN_HEIGHT, $ PAR_WIDTH, PAR_HEIGHT, IO_WIDTH, IO_HEIGHT, $ NOT_WIDTH, NOT_HEIGHT, PMN_WIDTH, PMN_HEIGHT, $ PPB_WIDTH, BUSY_WIDTH, BUSY_HEIGHT LOGICAL SUB_PROCESS, BLANK C c DON'T forget to declare function xdlstr as integer INTEGER XDLSTR EXTERNAL XDLSTR c c ivhbas view object handle for base frame c ivhimg view object handle for image c ivhpar view object handle for parameter table c ivhmen view object handle for menu c ivhio view object handle for io area c ivhio2 view object handle for second io area (pick option) c ivhio3 view object handle for third io area (output) c ivhnot view object handle for notice area (parameter table) c ivhpmn view object handle for popup wait menu c ivhppb view object handle for popup progress bar c ivhblank view object handle for blank object c ivhbusy view object handle for busy object c ivhbusy2 view object handle for second (2 line) busy object INTEGER IVHBAS, IVHIMG, IVHPAR, IVHMEN, IVHIO, IVHNOT, IVHPMN, $ IVHPPB, IVHBLANK, IVHBUSY, IVHIO2, IVHBUSY2, IVHIO3 PARAMETER (IVHBAS=1, IVHIMG=2, IVHPAR=3, IVHMEN=4, IVHIO=5, $ IVHNOT=6, IVHPMN=7, IVHPPB=8, IVHBLANK=9, IVHBUSY=10, $ IVHIO2=11, IVHBUSY2=12, IVHIO3=13) c Border boundary between windows INTEGER BORDER PARAMETER (BORDER = 4) c icset colour set number INTEGER ICSET PARAMETER (ICSET=1) c c iord axis order of image c = 1 xf slow, yf fast INTEGER IORD PARAMETER (IORD = 1) c c minw,minh minimum width and height for image display object INTEGER MINW,MINH PARAMETER (MINW=0, MINH=0) c c ixopix, iyopix pixel origin of displayed part INTEGER IXOPIX,IYOPIX PARAMETER (IXOPIX=1, IYOPIX=1) c c ibg background menu, =0 for none INTEGER IBG PARAMETER (IBG=0) c c iovly overlay option INTEGER IOVLY PARAMETER (IOVLY=1) c c max_pixel maximum number of pixels to use for image display: c this will be used to control possible compression c of the image INTEGER MAX_PIXEL PARAMETER (MAX_PIXEL = 800) c Image stuff c disp_img true if image has been displayed c LOGICAL DISP_IMG c c ifd file descriptor, = -1 for no file INTEGER IFD PARAMETER (IFD=0) c c Parameter table stuff c max_par_col maximum number of parameter columns c max_par_rows maximum number of parameter rows c max_par_name maximum length of name c max_par_str maximum value length c par_title = -1 no title +1 title present c par_font font (3=medium) c par_menu = 1 if popup menus allowed c disp_par true if parameter table hsa been displayed c LOGICAL DISP_PAR INTEGER MAX_PAR_COL, MAX_PAR_ROWS, MAX_PAR_NAME, MAX_PAR_STR, $ PAR_TITLE, PAR_FONT, PAR_MENU PARAMETER (MAX_PAR_COL = 1, MAX_PAR_ROWS = 50, $ MAX_PAR_NAME = 17, MAX_PAR_STR = 7, $ PAR_TITLE = 1, PAR_FONT = 2, PAR_MENU = 0) C c Menu stuff c max_men_itms maximum number of menu items c max_men_name maximum number of characters in menu item c men_font menu font number (3=medium) c men_quit_flag = 1 to allow for quit box c max_men_title maximum length of menu title c disp_menu true if menu displayed LOGICAL DISP_MENU INTEGER MAX_MEN_ITMS, MAX_MEN_NAME, MEN_FONT, MEN_QUIT_FLAG, $ MAX_MEN_TITLE PARAMETER (MAX_MEN_ITMS = 19, MAX_MEN_NAME = 19, MEN_FONT = 4, $ MEN_QUIT_FLAG = 1, MAX_MEN_TITLE = 9) c c IO area stuff c io_font font number c disp_io true if io area displayed c disp_io2 true if SECOND io area displayed c disp_io3 true if THIRD io area displayed C NSCROLL number of pages to hold for scrolling LOGICAL DISP_IO,DISP_IO2,DISP_IO3 INTEGER IO_FONT,NSCROLL PARAMETER (IO_FONT=2) PARAMETER (NSCROLL=0) c Notice area stuff (notice area is a parameter table with no values) c max_not_col maximum number of parameter columns c max_not_rows maximum number of parameter rows c max_not_name maximum length of name c max_not_str maximum value length c not_title = -1 no title +1 title present c not_font font (3=medium) c not_menu = 1 if popup menus allowed c disp_not true if menu displayed LOGICAL DISP_NOT INTEGER MAX_NOT_COL, MAX_NOT_ROWS, MAX_NOT_NAME, MAX_NOT_STR, $ NOT_TITLE, NOT_FONT, NOT_MENU PARAMETER (MAX_NOT_COL = 1, MAX_NOT_ROWS = 18, $ MAX_NOT_NAME = 23, $ MAX_NOT_STR = 0, $ NOT_TITLE = +1, NOT_FONT = 2, NOT_MENU = 0) c c Menu stuff for Abort menu c max_pmn_itms maximum number of menu items c max_pmn_name maximum number of characters in menu item c pmn_font menu font number (3=medium) c pmn_quit_flag = 1 to allow for quit box c max_pmn_title maximum length of menu title INTEGER MAX_PMN_ITMS, MAX_PMN_NAME, PMN_FONT, PMN_QUIT_FLAG, $ MAX_PMN_TITLE PARAMETER (MAX_PMN_ITMS = 0, MAX_PMN_NAME = 12, PMN_FONT = 4, $ PMN_QUIT_FLAG = 1, MAX_PMN_TITLE = 15) c Stuff for progress bar c ppb_font font number (3=medium) c ppb_colr colour INTEGER PPB_FONT, PPB_COLR PARAMETER (PPB_FONT = 4, PPB_COLR=3) c Busy box INTEGER BUSY_FONT PARAMETER (BUSY_FONT = 3) c c len_dialog length of dialog box INTEGER LEN_DIALOG PARAMETER (LEN_DIALOG = 60) c c Overlays c c Circles c cir_ivec vector set number for circles c cir_colr colour for circles c cir_iovl overlay number for circles c cir_symb symbol for centre INTEGER CIR_IVEC, CIR_COLR, CIR_IOVL, CIR_SYMB PARAMETER (CIR_IVEC=3, CIR_COLR=6, CIR_IOVL=2, CIR_SYMB=4) C C---- Residual vectors C IRV_VEC Vector set number C IRV_COL Colour (1 red, 2 yellow, 3 green) C IRV_OVL Overlay number INTEGER IRV_VEC, IRV_COL, IRV_OVL PARAMETER (IRV_VEC=4, IRV_COL=1, IRV_OVL=2) c Measure c c mes_colr colour for measure crosses INTEGER MES_COLR PARAMETER (MES_COLR=1) c Vertical Crosses c cross_iovl overlay number for circles c cross_symb symbol for centre INTEGER CROSS_IOVL, CROSS_SYMB PARAMETER (CROSS_IOVL=2, CROSS_SYMB=3) c Boxes c box_iovl overlay number for boxes c box_symb symbol for centre INTEGER BOX_IOVL, BOX_SYMB, BOX_VEC PARAMETER (BOX_VEC=2,BOX_IOVL=2, BOX_SYMB=13) c Circles c CIRC_iovl overlay number for circles c CIRC_symb symbol for centre INTEGER CIRC_IOVL, CIRC_VEC PARAMETER (CIRC_VEC=5,CIRC_IOVL=2) c Crosses c cross_iovl overlay number for circles c cross_symb symbol for centre INTEGER XCROSS_IOVL, XCROSS_SYMB PARAMETER (XCROSS_IOVL=2, XCROSS_SYMB=13) C C---- common block last of all C COMMON /MXDCMI/ BASE_WIDTH,BASE_HEIGHT, $ IMAGE_ORDER,JIMAGE_ORDER,NXP_CMP,NYP_CMP, $ NXDPX,NYDPX, $ IMG_HORIZ,IMG_VERT,IMG_MAP, $ IMG_X,IMG_Y,MEN_X,MEN_Y,PAR_X,PAR_Y,IO_X,IO_Y, $ NOT_X,NOT_Y,PMN_X, PMN_Y,PPB_X, PPB_Y, BUSY_X, BUSY_Y, $ BUSY_Y2, IFTYPE, $ IMG_WIDTH, IMG_HEIGHT, MEN_WIDTH, MEN_HEIGHT, $ PAR_WIDTH, PAR_HEIGHT, IO_WIDTH, IO_HEIGHT, $ NOT_WIDTH, NOT_HEIGHT, PMN_WIDTH, PMN_HEIGHT, $ PPB_WIDTH, BUSY_WIDTH, BUSY_HEIGHT, $ SUB_PROCESS,BLANK,DISP_IMG,DISP_PAR,DISP_MENU, $ DISP_IO,DISP_IO2,DISP_IO3,DISP_NOT C&&*&& end_include ../inc/mxdinc.f C INTEGER NPARM PARAMETER (NPARM = 200) C .. C .. Local Scalars .. REAL CCXS,CCYS,ELIMIT,ELIMIT2,ELIMIT3,OMEGA0,RADEG,SAVECCOM, + SBULGE,STILT,STWIST,SVBNEG,SVBPOS,SVTILT,SVTWIST,SVVERT, + SXTOFRA,SYSCAL,TEMP,X,SBULGE2,STOFF,DTOR,RESID, + RDIVH,RDIVV,RETA,PI, + WELIMIT,XLIMIT,CCOMLAST,CCOMAX,ROFFLAST,ROFFMAX,WRMAX, + PHIXLAST,PHIYLAST,PHIZLAST,DELPHIMAX,AVBGRMAX,AVBGRMIN, + ROFFSAVE,CCOMSAVE,TOFFLAST,TOFFMAX,TOFFSAVE,SROFF, + SDMISS,YSCALERR,RAD,XSEP,YSEP,RFP INTEGER I,IBNEG,IBPOS,IBULGE,ICASSP,ICTF,ICYC,IF,IFAIL,IFILM, + IFIRSTGOOD,IFIRSTPACK,IPACK,IREP,ITILT,ITWIST, + IVERT,IXERRI,J,JPACK,K,MODE,MODEWR,NACFLM,NCC,MINREFAV, + NFILMS,NFIRSTI,NFLMO,NFOUND,NFP,NMR,NPROFL,NRSOLD, + NRX,NRY,NXS,NYS,SAVECBAR,SAVECCX,SAVECCY,LDUM, + ITOFF,NPACKSAVE,NOWRITE,NREPEAT,NADDP,MTZPRT, + MODEOP,JFILMS,JSTART,IFIRSTP,IPT,IPTR,NCH, + NUMBLOCK,NBADMAX,IROFF,ISEG,IDTMP,ISTARTS,MODEG,NFULLF, + MODECTRL,ISUB,IFIRSTPSEG,MINREFS,MODESP,IERR,ISTAT, + MODEDISP,IERR2,IXP,IYP,IBUTTON,L,IXM,IYM, + LINELEN,NUMLIN,ITOG,IPAUSE,MODEGSR,NIMAGSV, + LASTREC,NADD_STORE,ICHECK,portno,INIT_MODE,NSINGRPT, + IRPTPACK,NFRPT LOGICAL AVPROFILE,BADSTART,CENTRE,DOPROFILE,FAIL,FILMPLT, + FIRSTTIME,FORCE,GENLIST,GENOPEN,GWRITE,LIST,NEWGENF, + OLDLIST,OVRLDS,PARTLS,PROCESSA,RESCAN,TREAT_AS_AFILM, + UPDATE,YES,ADDPP,STORCELL,PRFIRST,FINAL, + RRWEIGHT,USEWEIGHT,OKREF,EXTRAIMG,CENTRAL,PACK,LAST, + RPTFIRST,BIGSHIFT,FIRSTPACK,DONEONCE,CENTRSRPT,LPRNT, + FORCEREAD,COORDOPN,FIXPARTLS,RPTIMG,FIRSTWARN,SNEWGENF, $ EFILE,PRFINISH CHARACTER ABC*3,FWORK*100,CELLSTR*50,LINE*80,STR1*1,LINE2*80, + VALUESTR*80,STR3*3,MOSLPFILE*60,FULLFN*100, $ STR2*2,VERNO*100,REMOTEMOSFLMHOST*32 C .. C .. Local Arrays .. REAL RSUMM(12,MAXPAX),XERR(MAXPAX),PRFSUM(25,MAXPAX),SCELL(6), + SDELPHI(3),SVXCEN(NIMAX),SVYCEN(NIMAX),RPTSHIFT(3,6), + OLDCELL(6) INTEGER ISUMM(20,MAXPAX),IXERR(MAXPAX),NERR(MAXPAX), + PRFSUMI(MAXPAX),ISKIPI(2*MAXPAX),IRSAVE(62), + IPACKSTART(MAXPAX),MODE2(2),LASTFILM(100),INTDUM(2) LOGICAL BADPACK(MAXPAX,3),SUMP(MAXPAX),PRFRPT1(MAXPAX), + ADDP(MAXPAX),PRF(MAXPAX),PRFHS(MAXPAX),PRNEGM(MAXPAX), + PRFRPT2(MAXPAX) CHARACTER SUMMCH(MAXPAX)*1 C CHARACTER*10 CCP4VERSION C C---- Things for parser C INTEGER IBEG(NPARM),IDEC(NPARM),IEND(NPARM),ITYP(NPARM) REAL VALUE(NPARM) INTEGER NTOK C .. C .. External Functions .. INTEGER LENSTR,CCPE2I LOGICAL CCPONL,VAXVMS EXTERNAL CCPONL,LENSTR,VAXVMS,CCPE2I C .. C .. External Subroutines .. EXTERNAL AUTOMATCH,BELL,CENTRS,CHKRAS,CONTROL,FIDUS, + FINDPACK,GENERATE,GENSORT, + MEAS,NEXT,NOYES,OPENODS,PFINDPACK, + PRDIST,PROCESS,PSTART,PWRGEN,QCLOSE,QSEEK,RDIST,RMAXR, + SEEKRS,MSELECT,SUMMERR,WRGEN,YESNO,POSTREFL, + CCPFYP,UGTENV,WARNINGS,PRSETUP,CCPOPN,CCPDPN,VERSION, + DET,XDISP,OVERLAP2,SHUTDOWN,XDLF_FLUSH_EVENTS,STARTMTZ, + MXDBSY,GETSEPRAS,MXDWIO,MXDRIO,WRMTZ,NEWFN,PRSUMMARY C .. EXTERNAL MOSDATA C .. C .. Intrinsic Functions .. INTRINSIC COS,NINT,SIN C .. C .. Common blocks .. C&&*&& include ../inc/amatch.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file amatch.h C---- START of include file amatch.h C C C .. Scalars in Common /AMATCH/ .. C .. REAL RCONV,OVRLAP,RESOL1,RESOL2,AELIMIT,ARMSLIM, + SECANGLE,DAMP,TRUECCOM,ETAMAX,AWRMSLIM,MOSNEW, $ SLOPE,INTERCEPT INTEGER NSTEP,NCYCA,NPASS,N2,N3,N4,N5,N6,N7,N8,N9,N10,NBEAM LOGICAL MATCH,NOCENT,NOREFINE,RMOSAIC C .. C .. Common block /AMATCH/ .. COMMON /AMATCH/RCONV,OVRLAP,RESOL1,RESOL2,AELIMIT,ARMSLIM, + SECANGLE,DAMP,TRUECCOM,ETAMAX,AWRMSLIM,MOSNEW, $ SLOPE,INTERCEPT,NSTEP,NCYCA,NPASS,N2,N3,N4,N5,N6,N7, $ N8,N9,N10,NBEAM,MATCH,NOCENT,NOREFINE,RMOSAIC C .. C C C&&*&& end_include ../inc/amatch.f C&&*&& include ../inc/ccondata.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file ccondata.h C---- START of include file ccondata.h C C C .. Scalars in Common /CCONDATA/ .. CHARACTER GENFILE*200,CCFILE*200,ODEXT*8,WAXFN*134, + GTITLE*80,IDENT*40,NEWMATNAM*80,MTZNAM*80,PGNAME*10, + SPGNAM*10,ODFILE*200,SEPCHAR*1,SNEWMATNAM*80, + TEMPLSTART*100,TEMPLEND*100,TEMPLSAV*100 C .. C .. Arrays in Common /CCONDATA/ .. CHARACTER FDISK(10)*80,INLINE(1000)*80 C .. C .. Common block /CCONDATA/ .. COMMON /CCONDATA/GENFILE,CCFILE,ODEXT,WAXFN,GTITLE,IDENT, + NEWMATNAM,MTZNAM,PGNAME,SPGNAM,ODFILE, + SEPCHAR,SNEWMATNAM,TEMPLSTART,TEMPLEND, $ TEMPLSAV,FDISK,INLINE C .. C C C&&*&& end_include ../inc/ccondata.f C&&*&& include ../inc/cconst8.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file cconst8.h C---- START of include file cconst8.h C C C .. Arrays in Common /CCONST8/ .. REAL CCOMA INTEGER CCXA,CCYA,CBARA C .. C .. Common block /CCONST8/ .. COMMON /CCONST8/CCOMA(8),CCXA(8),CCYA(8),CBARA(8) C .. C C C C&&*&& end_include ../inc/cconst8.f C&&*&& include ../inc/cell.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file cell.h C---- START of include file cell.h C C CELL cell dimensions (real space) C RCELL reciprocal cell parameters in dimensionless rlu C C .. Arrays in Common /CELLCOM/ .. REAL UMAT,BMAT,GMAT,CELL,RCELL,UMATCELL INTEGER LCELL,ICRYST,NUMSPG,NLAUE C .. C .. Common Block /CELLCOM/ .. COMMON /CELLCOM/UMAT(3,3),BMAT(3,3),GMAT(3,3),CELL(6),RCELL(6), $ UMATCELL(6),LCELL(6),ICRYST,NUMSPG,NLAUE C .. C C C&&*&& end_include ../inc/cell.f C&&*&& include ../inc/condata.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file condata.h C---- START of include file condata.h C C C FIXSWAP Forces reversal of normal byte-swapping choice. C C---- SUMPART True if two images are to be stored in memory at the C same time. This will be the case if post-refinement C (other than POSTHOC post-refinement for off-line C scanners) is being performed. Note that SUMPART is NOT C used to determine if partials should be added across C images (this is ADDPART) C C---- NEWPREF True if allowing partials over multiple images in post- C refinement. C C---- ADDPART True if partials are to be summed across images. This is C only appropriate for fixed origin (ie on-line) C scanners where the X-ray dose is identical for C each image. C Direct beam coordinates C These are read into XMM(3), YMM(3) where (3) is for A,B,C packs C Immediately on reading in, these values are transferred C into XCENMM, YCENMM, XCENMMIN(J,3) where J=1->MAXPAX. C C If an IMAGE keyword has been given, XCENMM(1,1)=XMM(1) and C YCENMM(1)=YSCAL*YMM(1). If swung out, YCENMM(1,1) is updated. C If a BEAM keyword has not been given, XMM,YMM, XCENMM,YCENMM, C XCENMMIN are all set to the middle of the image. C Then, when reflecting input to logfile, it AGAIN sets up C XCENMM,YCENMM for all images using XMM,YMM, this time C using YSCAL to set up YCENMM, and updating YCENMM if the C detctor is swung out. (label 708), DO loop 710. If image C is "inverted", corrects XCENMM for all images. C XCEN,YCEN are set in "mosflm" to XCENF, YCENF plus C camera constants, and XCENF,YCENF are in turn set from C XCENMM,YCENMM. Thus XCENMM,YCENMM are what is actually C used to define the beam position. C HBEAMX and HBEAMY are direct beam coordinates as found in C an image header (e.g. JUPITER CCD) C C LPREF If TRUE, return to display after refinement over entire C image. Only active when integrating interactively. Set by C toggle button in Parameter window. C C LOVERLAP If TRUE, do not call the OVERLAP subroutine C ALLOUT If TRUE, all reflections (whether measured or not, or C classified as BADSPOTS or not, will be written to the C output MTZ file. C C NTDIG Number of digits in image number, returned as zero if C there is an error in the template. Only used if TEMPLATE C keyword given. C C TEMPLATE is TRUE if a TEMPLATE keyword has been given. C C NOLP If TRUE, do NOT apply the Lorentz Polarisation corrections C C MULTIMTZ True if writing each "block" of images to a separate MTZ file C C DISPMENU True if the run was started with a IMAGE keyword. Not to be C confused with WINOPEN which is true if the X-window display C is being used, but this is not necessarily starting with C a "IMAGE" keyword. C .. C .. Arrays in common /CONDATA/ .. REAL XCENMM,YCENMM,THFOIL,PHIBEGA,PHIENDA,RSYM,XMM,YMM, + XCENMMIN,YCENMMIN REAL RMSLIM,WRMSLIM,VLIM,XMID,SEP,THICK,PTMIN,REFREJ,WAIT, + PHIRNG,YSCALIN,FULLFRAC,WTIME,HBEAMX,HBEAMY C .. C .. Arrays in common /CONDATA/ .. INTEGER IDPACK,NFPACK,NFIRST,ICASSET INTEGER IPACK1A,IPACK2A,ISERAR LOGICAL AVPROF,FILMPLOT,FORCEB,FORCEC C C .. Scalars in common /CONDATA/ .. C .. INTEGER NPACK,NCYC,MAXNX,MAXNY,ITHRESHF,NSIG,IRFMIN, + IRFINC,IXSHIFT,IYSHIFT,LIMIT,NBLOCK,INOGEN,NFGEN,MINREF, + ISERADD,NSEG,NSYM,NSYMP,NRUN,NSERTOT,IWAVE,ISWUNG INTEGER IMAT,ICELL,IUMAT,LSYMM,IDIST,IBEAM,ISCAN,NLINE,NRLINE, + NTLINE,ISTARTP,IRAST,INEWMAT,ISEP,NSAVELINE,IPTIME, + ISTRT,IANGLE,IBACKS,IPOLAR,IDIVH,IDIVV,IGAIN,IBLOCK, + IHKLOUT,IGENF,INRES,NTDIG,DELAY,IMULTI LOGICAL FINDCC,READCC,NOFID,INTERPOL,CONVOL,NOMEAS, + USEPAR,USEOVR,SUMPART,USEBOX,POSTREF,ADDPART, + FIXED,POWDER,RWEIGHT,NOREF,MULTISEG,FIXSWAP,POSTHOC, + LPREF,LPINTG,DISPMENU,PRMODE,PRCELL,TEMPLATE, + LOVERLAP,ALLOUT,NOLP,NEWPREF,NOBACK,MOSEST,MOSES2, $ HARVESTREADY,HEADINFO,MULTIMTZ C .. C real arrays, then scalars, integer arrays, scalars, logicals COMMON /CONDATA/ $ XCENMM(MAXPAX,3), + YCENMM(MAXPAX,3), THFOIL(3),PHIBEGA(MAXPAX), $ PHIENDA(MAXPAX),RSYM(4,4,96),XMM(3),YMM(3), $ XCENMMIN(MAXPAX),YCENMMIN(MAXPAX), $ RMSLIM,WRMSLIM,VLIM,XMID,SEP,THICK,PTMIN,REFREJ,WAIT, + PHIRNG,YSCALIN,FULLFRAC,WTIME,HBEAMX,HBEAMY, $ IDPACK(MAXPAX),NFPACK(MAXPAX),NFIRST(MAXPAX), + ICASSET(MAXPAX),IPACK1A(50), + IPACK2A(50),ISERAR(50), $ AVPROF(MAXPAX),FILMPLOT(MAXPAX),FORCEB(MAXPAX), + FORCEC(MAXPAX), $ NPACK,NCYC,MAXNX,MAXNY,ITHRESHF,NSIG,IRFMIN, + IRFINC,IXSHIFT,IYSHIFT,LIMIT,NBLOCK,INOGEN,NFGEN,MINREF, + ISERADD,NSEG,NSYM,NSYMP,NRUN,NSERTOT,IWAVE,ISWUNG, $ IMAT,ICELL,IUMAT,LSYMM,IDIST,IBEAM,ISCAN,NLINE,NRLINE, + NTLINE,ISTARTP,IRAST,INEWMAT,ISEP,NSAVELINE,IPTIME, + ISTRT,IANGLE,IBACKS,IPOLAR,IDIVH,IDIVV,IGAIN,IBLOCK, + IHKLOUT,IGENF,INRES,NTDIG,DELAY,IMULTI, $ FINDCC,READCC,NOFID,INTERPOL,CONVOL,NOMEAS, + USEPAR,USEOVR,SUMPART,USEBOX,POSTREF,ADDPART, + FIXED,POWDER,RWEIGHT,NOREF,MULTISEG,FIXSWAP,POSTHOC, + LPREF,LPINTG,DISPMENU,PRMODE,PRCELL,TEMPLATE, + LOVERLAP,ALLOUT,NOLP,NEWPREF,NOBACK,MOSEST,MOSES2, $ HARVESTREADY,HEADINFO,MULTIMTZ C&&*&& end_include ../inc/condata.f C&&*&& include ../inc/debug.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file debug.h C---- START of include file debug.h C C C C .. Arrays in common /DEBUG/ .. REAL XWARN INTEGER NDEBUG,IWARN LOGICAL DEBUG,LPRINT,DUMP,WARN C C .. Scalars in common /DEBUG/ .. REAL BGRLIM INTEGER NDUMP,IDUMP,MXDUMP LOGICAL SPOT C C .. C .. Common Block /DEBUG/.. COMMON /DEBUG/XWARN(20,100),BGRLIM,NDEBUG(80),IWARN(20,100), $ NDUMP,IDUMP,MXDUMP,DEBUG(80),LPRINT(20),DUMP(30), + WARN(100),SPOT C .. C C&&*&& end_include ../inc/debug.f C&&*&& include ../inc/dsplyc.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file dsplyc.h C---- START of include file dsplyc.h C C******************************************************************* C C COMMON /DSPLYC/ C C IMGLOW, IMGHI low & high values of 16-bit image for scaling C integer*2 to byte: IMGLOW maps to 0; C IMGHI to maximum. Note that these are not C necessarily the actual limits of the data C JDSPWD .LT. 0 before image window has been created C = +-1 for image display that can be panned C = +-2 for non-interactive image display C MAXDEN highest level in colour table to fill up to C must be less than ~240 - number of overlay colours C LDSPSG if .true., treat image as signed, ie after dark C subtraction C if .false., treat image as unsigned C NZOOM zoom factor for image, = 0 if no zoom C JYZOOM, JZZOOM 1st pixel in zoomed image C C---- WINOPEN Flag for whether or not window is open. Do not C confuse with DISPMENU (/CONDATA/)which is true if the run was C started with a IMAGE keyword. C C C CDSPTL banner title C INTEGER IMGLOW, IMGHI, JDSPWD, MAXDEN, $ NZOOM, JYZOOM, JZZOOM LOGICAL LDSPSG,WINOPEN,LPAUSE,LHELP COMMON /DSPLYC/ IMGLOW, IMGHI, JDSPWD, * MAXDEN, NZOOM, JYZOOM, JZZOOM, LDSPSG,WINOPEN,LPAUSE,LHELP C CHARACTER CDSPTL*200 COMMON /DSPLCC/ CDSPTL C C C******************************************************************* C&&*&& end_include ../inc/dsplyc.f C&&*&& include ../inc/extras.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file extras.h C---- START of include file extras.h C C C .. Scalars in common /EXTRAS/ .. INTEGER JUMPAX,NPACKS LOGICAL ISKIP,AFILM,BFILM,CFILM,STARTA,STARTB,STARTC C .. C .. Common block /EXTRAS/ .. COMMON /EXTRAS/JUMPAX,NPACKS,ISKIP,AFILM,BFILM,CFILM,STARTA, + STARTB,STARTC C .. C C C&&*&& end_include ../inc/extras.f C&&*&& include ../inc/fid.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file fid.h C---- START of include file fid.h C C XCENF,YCENF Coordinates (in 10 micron units) of the direct beam C position relative to an origin at the position of the C first pixel in the digitised image.(The SCANNER C coordinate frame). C For IP data this comes from the defined C direct beam coordinates, for film data it is the C midpoint of fiducials 1 and 3. C C CCX,CCY The difference (in 10 micron units) between the C refined position of the direct beam (XCEN,YCEN) and C the ideal direct beam coordinates (XCENF,YCENF), C in the SCANNER coordinate frame. C CCX,CCY are updated in RDIST. They are in "pixels" C rather than mm (but expressed in 10micron units). C C DTOFD The distance (in 10 micron units) from the crystal C to the detector along a normal to the detector. C For flat, unswung detectors, or swung on a 2 theta arm, C this is the same as CTOFD and XTOFD. It differs for C Vee shaped cassettes. Assigned in START and never changed. C Only actually used in RMAXR for calculating box sizes. C C .. Arrays in common /FID/ .. REAL CCOMABC INTEGER FSPOS,CCXABC,CCYABC C .. C .. Scalars in common /FID/ .. REAL OMEGAF,CCOM,DTOFD,XCENF,YCENF INTEGER MM,MMDB,NFID,CCX,CCY,IYOFF C .. C .. Common block /FID/ .. COMMON /FID/CCOMABC(3),OMEGAF,CCOM,DTOFD,XCENF,YCENF,FSPOS(4,2), + CCXABC(3),CCYABC(3),MM,MMDB,NFID,CCX,CCY,IYOFF C .. C C C&&*&& end_include ../inc/fid.f C&&*&& include ../inc/film_no.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C integer id common /film_num/ id C&&*&& end_include ../inc/film_no.f C&&*&& include ../inc/gendata.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file gendata.h C---- START of include file gendata.h C C IMG Partiality indicator. 0 for full reflections, 1 to 100 C for partials. Negative for partials at the start of the C rotation range, +ve for partials at the end of the C rotation. Set in subroutine REEK using DELEPS calculated C in subroutine DSTAR C C IRG Reflection flag (Set by SPTEST called from DSTAR) C = 0 Spot can be measured C = 1 Outside R, X, Y limits C = 2 Overlapping spot (set later) C = 3 Too wide in phi (more than NWMAX images) C = 4 DST .GT. DSTMAX Not included in final film list - C used only to check for overlaps at edge of film. C = 10 Spot is within cusp, but will be observed...not included C in final spot list but must be included in predicted C pattern C C = 21 Spot present on 2 images, this is 1st C = 22 Spot present on 2 images, this is 2nd C C = 31 Spot present on 3 images, this is 1st C = 32 Spot present on 3 images, this is 2nd C = 33 Spot present on 3 images, this is 3rd C C = 41 Spot present on 4 images, this is 1st C = 42 Spot present on 4 images, this is 2nd C = 43 Spot present on 3 images, this is 3rd C = 44 Spot present on 4 images, this is 4th C C etc etc C C XG Virtual detector X coordinate in 10 micron units, relative to C an origin at the direct beam position. X is parallel to the C Y axis in the laboratory frame, ie orthogonal to the rotation C axis. C C YG Virtual detector Y coordinate in 10 micron units, relative to C an origin at the direct beam position. Y is parallel to the C Z axis in the laboratory frame, ie the rotation axis. C C IX,IY are the coordinates of the reflection in pixels C (integers) wrt the first pixel in the image (lower left corner C cameramans view). For testing for spot overlap, these C coordinates are in 10 micron units. Also used for display C pixel coordinates when displaying predicted pattern. C C IREC Pointer to the record number of a particular spot in the C list of generated reflections. C C C .. C .. Arrays in common /GENDATA/ .. REAL FRACG,PHIG,PHIWG,XG,YG INTEGER INTG,IPRO,IX,IY,IREC INTEGER*2 IRG,IMG,IGFLAG,ISDPRO,ISDG,IHG,IKG,ILG,IMPARTG, + MISYMG C .. Scalars in common /GENDATA/ .. INTEGER IPACKREC,IPACKHEAD,IRECLAST C .. C .. Common block /GENDATA/ .. COMMON /GENDATA/FRACG(NREFLS),PHIG(NREFLS),PHIWG(NREFLS), $ XG(NREFLS),YG(NREFLS),INTG(NREFLS),IPRO(NREFLS), $ IX(NREFLS),IY(NREFLS),IREC(NREFLS),IRG(NREFLS),IMG(NREFLS), + IGFLAG(NREFLS),ISDPRO(NREFLS),ISDG(NREFLS), + IHG(NREFLS),IKG(NREFLS),ILG(NREFLS),IMPARTG(NREFLS), + MISYMG(NREFLS),IPACKREC,IPACKHEAD,IRECLAST + C .. C C C&&*&& end_include ../inc/gendata.f C&&*&& include ../inc/graphics.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file graphics.h C---- START of include file graphics.h C C C .. Scalars in common /GRAPHICS/ .. REAL GRFACT,DISPLAY INTEGER NGR,NGX,NGY,NHX,NHY,NLI C .. C .. Common block /GRAPHICS/ .. COMMON /GRAPHICS/GRFACT,DISPLAY,NGR,NGX,NGY,NHX,NHY,NLI C .. C C C&&*&& end_include ../inc/graphics.f C&&*&& include ../inc/header.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file header.h C---- START of include file header.h C .. Scalars in common block /HEADER/ REAL HDIST,HWAVE,HPHIS,HPHIE,HRAST,HTWOTHETA,HTOR INTEGER NHEAD,NTAIL,HNULLPIX LOGICAL USEHDR,USETAIL,USEDIST,USEWAVE,USEPHI,HDRSIZE C .. C .. Arrays in common block /HEADER/ INTEGER*4 IHEAD C .. C .. Common Block /HEADER/ COMMON /HEADER/ HDIST,HWAVE,HPHIS,HPHIE,HRAST,HTWOTHETA,HTOR, $ IHEAD(MAXHEAD),NHEAD,NTAIL,HNULLPIX, + USEHDR,USETAIL,USEDIST,USEWAVE,USEPHI, + HDRSIZE C .. C&&*&& end_include ../inc/header.f C&&*&& include ../inc/ioo.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file ioo.h C---- START of include file ioo.h C C C C .. Scalars in common block /IOO/ .. INTEGER IOUT,IUNIT,ITIN,ITOUT,INOD,INMO,IDU,NWRN,IBRIEF,ISUMMR, + ICOORD,SERVERFD LOGICAL ONLINE,ONEFILE,FHEADER,BRIEF,GRAPH,IOERR, $ NODISPLAY,LBELL,JPGOUT,SOCKLO C .. C .. Common block /IOO/ .. c COMMON /IOO/IOUT,IUNIT,ONLINE,ITIN,ITOUT,INOD,INMO,IDU,NWRN, c + ONEFILE,FHEADER,BRIEF,IBRIEF,GRAPH,ISUMMR,ICOORD, c + IOERR,NODISPLAY,LBELL C .. C C COMMON /IOO/IOUT,IUNIT,ITIN,ITOUT,INOD,INMO,IDU,NWRN,IBRIEF, + ISUMMR,ICOORD,SERVERFD,ONLINE,ONEFILE, + FHEADER,BRIEF,GRAPH,IOERR,NODISPLAY,LBELL,JPGOUT, $ SOCKLO C&&*&& end_include ../inc/ioo.f C&&*&& include ../inc/iosp.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file iosp.h C---- START of include file iosp.h C C C .. Scalars in common block /IOSP/ .. INTEGER NSPOT,NFULL,NOUTGEN C .. C .. Common Block /IOSP/ .. COMMON /IOSP/NSPOT,NFULL,NOUTGEN C .. C C C&&*&& end_include ../inc/iosp.f C&&*&& include ../inc/lmb.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file lmb.h C---- START of include file lmb.h C ODSCAL is to scale image numbers into the range 0-255 for plotting C average profiles. C GAIN should be equal to the overall gain (image counts per X-ray photon) C of the system, and is used to evaluate standard deviations based on C counting statistics assuming independent pixels (ie point spread function C less than pixel size). C INVERTX true if image is inverted in the slow (X) direction when read in. C ISCAL is to scale final integrated intensities and sigmas C IDIVIDE is the adc offset C ICONST is a constant to be added to all pixels (normally zero) to C allow processing of images with zero pixel values in the scanned C area. C IMGP is true if working with image plate data C SPIRAL is true for scanners with a spiral readout (Mar, DIP2000) C ORTHOG is true for scanners with orthogonal scan (FUJI, RAXIS, MD) C NULLPIX is the value of pixels within the image but not in the active C area of the detector C TILED is true if there are inactive areas of the detector within the C inscribing circle or square. C C NTILEX Number of tiles in X direction C NTILEY Number of tiles in Y direction C TILEX X Coordinates of the midpoints of the null areas between tiles C TILEY Y Coordinates of the midpoints of the null areas between tiles C TILEWX Width of the null areas between tiles in X C TILEWY Width of the null areas between tiles in Y C MACHINE and MODEL denote the type of detector. C C MACHINE is used in the following subroutines: C GETBLK, GETHDR, INTPXL, INTPXL2, MXDSPL, OPENODS, PROCESS, PUTPXL C Currently coded types are: C C MACHINE MODEL COMMENTS C ======= ===== ======== C MAR 180, 300, 345 C RAXI(S) RAXISII, RAXISIV C MD C FUJI C CCD1 CCD1 Princetown CCD at CHESS,Tiff format C CCD2 CCD ? ESRF CCD detector C ADSC QUAD1 ADSC 2x2 CCD detector C C .. Scalars in Common Block /LMB/ .. REAL ODSCAL,GAIN,LOGA,LOGB INTEGER ISCAL,IDIVIDE,ICONST,NULLPIX,NTILEX,NTILEY LOGICAL IMGP,INVERTX,SPIRAL,ORTHOG,CIRCULAR,TILED,SETADC CHARACTER MACHINE*4,MODEL*8 C .. C .. Arrays in common /LMB/ INTEGER TILEX,TILEY,TILEWX,TILEWY C C .. Common Block /LMB/ .. COMMON /LMB/ ODSCAL,GAIN,LOGA,LOGB,ISCAL,IDIVIDE,ICONST, + NULLPIX,NTILEX,NTILEY,TILEX(20),TILEY(20), + TILEWX(20),TILEWY(20),IMGP,INVERTX,SPIRAL, + ORTHOG,CIRCULAR,TILED,SETADC COMMON /LMBC/ MACHINE,MODEL C&&*&& end_include ../inc/lmb.f C&&*&& include ../inc/mcs.f C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C C--- awk generated include file mcs.h C---- START of include file mcs.h C C C .. Scalars in common block /MCS/ .. REAL BASEOD,G1OD,CURV INTEGER FILM,FILMS,CTOFD,PCKIDX,TOSPT,N1OD,XSCMIN,XSCMAX LOGICAL VEE,VALONGX C .. C .. Common block /MCS/ .. COMMON /MCS/BASEOD,G1OD,CURV,FILM,FILMS,CTOFD,PCKIDX,TOSPT, $ N1OD,XSCMIN,XSCMAX,VEE,VALONGX C .. C CTOFD.... This was the crystal to detector distance (10 micron units) C but it has now been replaced by XTOFD in common block /XY/ C C&&*&& end_include ../inc/mcs.f C&&*&& include ../inc/misc.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file misc.h C---- START of include file misc.h C C C C .. Scalars in common /MISC/ .. REAL PHIBEG,PHIEND,RMIN,RMAX,WAVE INTEGER IPACKID,MININT,IERRFLG C .. C .. Arrays in common /MISC/ .. REAL DELPHI,RESANI INTEGER IAX C .. C .. LOGICAL LOGICAL ANITES C .. C .. Common Block /MISC/ .. COMMON /MISC/DELPHI(3),RESANI(3),PHIBEG,PHIEND,RMIN,RMAX,WAVE, $ IAX(3),IPACKID,MININT,IERRFLG,ANITES C .. C C C&&*&& end_include ../inc/misc.f C&&*&& include ../inc/misset.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C---- START of include file misset.h C C .. C .. Arrays in common /MISSET/ .. REAL RMISSETS,SDMISSETS C .. COMMON /MISSET/ RMISSETS(MAXPAX,3),SDMISSETS(MAXPAX,2) C&&*&& end_include ../inc/misset.f C&&*&& include ../inc/myprof.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file myprof.h C---- START of include file myprof.h C C C .. Arrays in Common Block /MYPROF/ .. REAL PRSCALE,XPMAX,YPMAX,XLINE,YLINE,WPROFL,WPRSUMS INTEGER ISIZE,NRFBOX,IPROFL,IBOX,IXBOX,IYBOX,NPFIRST LOGICAL BOX C .. C .. Scalars in Common Block /MYPROF/ REAL TOL,BGPKRAT,FRACREJ,BADTOL,TOLMIN,RECLEVEL INTEGER NXLINE,NYLINE,NUMBOX,IBOUND,ITRIM,NOVERLAP LOGICAL HIGHRES,LOWRES,PRSET,OFFDET,PROPT,FIXBOX,LINESET, + PROPTCEN,RECOVER,NOFIXBOX C .. C .. Common Block /MYPROF/ .. COMMON /MYPROF/PRSCALE(NMASKS,2),XPMAX(NMASKS),YPMAX(NMASKS), $ XLINE(NNLINE),YLINE(NNLINE), + WPROFL(MAXBOX,NMASKS),WPRSUMS(MAXBOX,NMASKS),TOL, + BGPKRAT,FRACREJ,BADTOL,TOLMIN,RECLEVEL, $ ISIZE(NMASKS,2),NRFBOX(NMASKS), + IPROFL(MAXBOX,NMASKS+1),IBOX(0:NNLINE,0:NNLINE), + IXBOX(NMASKS,2),IYBOX(NMASKS,2), + NPFIRST(NNLINE-1),NXLINE,NYLINE,NUMBOX,IBOUND,ITRIM, $ NOVERLAP,BOX(NMASKS),HIGHRES,LOWRES,PRSET,OFFDET, + PROPT,FIXBOX,LINESET,PROPTCEN,RECOVER,NOFIXBOX C .. C C C&&*&& end_include ../inc/myprof.f C&&*&& include ../inc/ioomtz.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file ioomtz.h C---- START of include file ioomtz.h C C C .. Scalars in common block /IOOMTZ/ .. INTEGER MTZOUT LOGICAL MTZOPEN C .. C .. Common block /IOOMTZ/ .. COMMON /IOOMTZ/ MTZOUT,MTZOPEN C&&*&& end_include ../inc/ioomtz.f C&&*&& include ../inc/ioosum.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file ioosum.h C---- START of include file ioosum.h C C .. Scalars in common block /IOOSUM/ INTEGER NLSUM1,NLSUM2,NSUMSTART1,NSUMSTART2 C C .. Arrays in common block /IOOSUMC/ .. CHARACTER*133 LINESUM1(MAXPAX),LINESUM2(MAXPAX) CHARACTER*101 IOLINE(100) C .. C .. Common block /IOOSUM/ .. COMMON /IOOSUM/ NLSUM1,NLSUM2,NSUMSTART1,NSUMSTART2 C .. C .. Common block /IOOSUMC/ .. COMMON /IOOSUMC/ LINESUM1,LINESUM2,IOLINE C&&*&& end_include ../inc/ioosum.f C&&*&& include ../inc/ori.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file ori.h C---- START of include file ori.h C C XCEN,YCEN Coordinates (in 10 micron units) of the direct beam C position relative to an origin at the position of the C first pixel in the digitised image.(The SCANNER C coordinate frame). These parameters are refined for C each image. C C XCEN0,YCEN0 Coordinates of direct beam position at zero swing angle. C (Needed for pxtomm conversion for swung detectors) C These values are assigned on the basis of input direct C beam coordinates, corrected for swing angle if necessary. C They are not (currently) updated during refinement. C C XOFF,YOFF Distance between centre of detector and direct beam. C C .. C .. Arrays in common /ORI/ .. LOGICAL FIXPAR C C .. Scalars in common block /ORI/ .. REAL COSOM0,SINOM0,XTOFRA,YSCAL,TILT,TWIST,BULGE, + VBNEG,VBPOS,VTILT,VTWIST,VVERT,TOFF,BULGE2,PBULGE,ROFF, + RDTOFF,RDROFF,ROFFPHI,TOFFPHI,JUNK3,XCEN,YCEN,XCEN0,YCEN0, + XOFF,YOFF,TILTMAT,TWISTMAT,DETNOR,DPSIX INTEGER CBAR,NODES,NPHI,IJUNK2,IJUNK3 LOGICAL RESETCCOM C .. C .. Common Block /ORI/ .. COMMON /ORI/COSOM0,SINOM0,XTOFRA,YSCAL,TILT,TWIST,BULGE, $ VBNEG,VBPOS,VTILT,VTWIST,VVERT,TOFF,BULGE2,PBULGE,ROFF, $ RDTOFF,RDROFF,ROFFPHI,TOFFPHI,JUNK3,XCEN,YCEN,XCEN0, + YCEN0,XOFF,YOFF,TILTMAT,TWISTMAT,DPSIX,DETNOR(3),CBAR, + NODES,NPHI,IJUNK2,IJUNK3,FIXPAR(NRPAR), $ RESETCCOM C .. C C C&&*&& end_include ../inc/ori.f C&&*&& include ../inc/over.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file over.h C---- START of include file over.h C C C .. Scalars in Common Block /OVER/ .. C C .. C .. Scalars in common /OVER/ .. INTEGER MINDTX,MINDTY,NPOVL,IXSEP,IYSEP C .. C .. ARRAYS in common /OVER/ .. INTEGER HKLPOVL C .. C .. Common Block /OVER/ .. COMMON /OVER/MINDTX,MINDTY,NPOVL,IXSEP,IYSEP,HKLPOVL(NREFLS/2) C .. C C C&&*&& end_include ../inc/over.f C&&*&& include ../inc/parm1.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file parm1.h C---- START of include file parm1.h C C C C .. Scalars in common block /PARM1/ .. REAL BGSIG,EFAC,EFACSQ,BGFREJ,GRADMAX,GRADMAXR,BGRAT,PKRAT, + RESD,RESDLOW INTEGER CUTOFF,NOVPIX,NDSTART,NDTOT,IXDMIN,IXDMAX,IYDMIN,IYDMAX, + IDMIN,IDMAX LOGICAL DUMPSPOT,BADPLOT,DUMPALL,BADPLOT2 C .. C .. Common Block /PARM1/ .. COMMON /PARM1/BGSIG,EFAC,EFACSQ,BGFREJ,GRADMAX,GRADMAXR, + BGRAT,PKRAT,RESD,RESDLOW,CUTOFF,NOVPIX, + NDSTART,NDTOT,IXDMIN,IXDMAX,IYDMIN,IYDMAX, + IDMIN,IDMAX,DUMPSPOT,BADPLOT,DUMPALL,BADPLOT2 C .. C C C&&*&& end_include ../inc/parm1.f C&&*&& include ../inc/parm2.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file parm2.h C---- START of include file parm2.h C C C .. Scalars in common block /PARM2/ .. REAL PRBGSIG,RMSBGPR,DISCRIM,PKWDLIM1,PKWDLIM2,PKWDLIM3,PKWDOUTL INTEGER ISDRATIO,PRCUTOFF,IPLOT,NRFMIN,NHKLD,IOUTL1,IOUTL2 LOGICAL PROFILE,PROCES,SAVEFILE,CHANGEMASK,PRBFILM,PRCFILM, + PRREAD,PRSAVE,WEIGHT,PRPART,USEOVRLD,USEDGE,VARPRO, + WTPROFILE,DISCRIMINATE,PUPDATE,PKONLY,DENSE,PRFULLS, + DECONV C .. C .. Arrays in common blocks /PEL/ and /PELC/ .. INTEGER IHD C .. C .. Common Block /PARM2/ .. COMMON /PARM2/PRBGSIG,RMSBGPR,DISCRIM,PKWDLIM1,PKWDLIM2, $ PKWDLIM3,PKWDOUTL, $ ISDRATIO,PRCUTOFF,IPLOT,NRFMIN,NHKLD,IOUTL1,IOUTL2, $ IHD(3,50), $ PROFILE,PROCES,SAVEFILE,CHANGEMASK,PRBFILM,PRCFILM, + PRREAD,PRSAVE,WEIGHT, + PRPART,USEOVRLD,USEDGE,VARPRO, + WTPROFILE,DISCRIMINATE, + PUPDATE,PKONLY,DENSE, + PRFULLS,DECONV C .. C C C&&*&& end_include ../inc/parm2.f C&&*&& include ../inc/pel.f C **** This is the IMAGE PLATE version of this common block **** C C C---- START of include file pel.h C C C .. Scalars in common blocks /PEL/ and /PELC/ .. INTEGER IBA,IPOINT,ISTART LOGICAL INCORE C .. C .. Arrays in common blocks /PEL/ and /PELC/ .. LOGICAL RDSTRIP INTEGER*2 BOXOD,IMAGE C .. C .. Common Blocks /PEL/ and /PELC/ .. COMMON /PEL/IBA,IPOINT,INCORE,RDSTRIP(IXWDTH),BOXOD(MAXBOX), + ISTART COMMON /PELC/ IMAGE(IYLENGTH*IXWDTH) C .. C C C---- END of include file pel.h C C&&*&& end_include ../inc/pel.f C&&*&& include ../inc/postchk.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file postchk.h C---- START of include file postchk.h C C DELPHIV stores the missets for the first NADD images only, C so that once NADD images have been processed their C refined missets can be saved for writing to the C summary file. C C .. Arrays in Common /POSTCHK/ REAL SDBEAM,SDCELL,SDDELPHI,DELPHIV,SHIFT LOGICAL FCELL C C .. Scalars in Common /POSTCHK/ .. C .. REAL PRRES1,PRRES2,RESIDMAX,SDFAC,SHIFTMAX,SHIFTFAC, + ANGWIDTH,CELLSHIFT,FRACMIN,FRACMAX,FRCSHIFT INTEGER PRNS,NREFPR,NADD,NRPT,IPRINTP,NPRMIN LOGICAL USEBEAM,REFCELL C .. C .. Common block /POSTCHK/ .. COMMON /POSTCHK/ SDBEAM(6),SDCELL(6),SDDELPHI(2*NIMAX), + DELPHIV(3*NIMAX),SHIFT(3),PRRES1,PRRES2,RESIDMAX, + SDFAC,SHIFTMAX,SHIFTFAC,ANGWIDTH,CELLSHIFT, $ FRACMIN,FRACMAX,FRCSHIFT, + PRNS,NREFPR,NADD,NRPT,IPRINTP, + NPRMIN,FCELL(6),USEBEAM,REFCELL C .. C C C&&*&& end_include ../inc/postchk.f C&&*&& include ../inc/praccum.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file praccum.h C---- START of include file praccum.h C C C .. C .. Arrays in common block /PRACCUM/ .. REAL PRDATA C C .. Scalars in common block /PRACCUM/ .. LOGICAL ACCUMULATE,FIRSTPASS,SECONDPASS,THIRDPASS,FIRSTFILM, + NOTREAD C .. C .. Common Block /PRACCUM/ .. COMMON /PRACCUM/PRDATA(4,50),ACCUMULATE,FIRSTPASS,SECONDPASS, + THIRDPASS,FIRSTFILM,NOTREAD C .. C C C&&*&& end_include ../inc/praccum.f C&&*&& include ../inc/precession.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file precession.h C---- START of include file precession.h C C C .. Scalars in common block /PRECESSION/ .. REAL D1,D2,PHIPREC,PSIPREC,PCTOFD,XLAMBDA LOGICAL PRECESS C .. C .. Common Block /PRECESSION/ .. COMMON /PRECESSION/D1,D2,PHIPREC,PSIPREC,PCTOFD,XLAMBDA,PRECESS C .. C C C&&*&& end_include ../inc/precession.f C&&*&& include ../inc/pro.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file pro.h C---- START of include file pro.h C C C .. Arrays in common block /PRO/ .. INTEGER*2 IDUM C .. C .. Common Block /PRO/ .. COMMON /PRO/IDUM(MAXBUFF) C .. C C C&&*&& end_include ../inc/pro.f C&&*&& include ../inc/ras.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file ras.h C---- START of include file ras.h C C C .. Scalars in common block /RAS/ .. INTEGER NEWRAS,MINT C .. C .. Arrays in common block /RAS/ .. INTEGER IRAS REAL VARAS C .. C .. Common Block /RAS/ .. COMMON /RAS/VARAS(5),IRAS(5),NEWRAS,MINT C .. C C C&&*&& end_include ../inc/ras.f C&&*&& include ../inc/reeke.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file reeke.h C---- START of include file reeke.h C C TOR For synchrotron sources, degree of polarisation of the beam C IMONO Collimation flag for polarisation. C = 0 Pinhole or mirrors C = 1 Graphite Monochromator C = 2 Synchrotron, use TOR C NWMAX Maximum reflection width in images C DSTMAX dimensionless rlu, = WAVE/RES where RES is the maximum C resolution in Angstrom. C DSTMIN dimensionless rlu, = WAVE/DMAX where DMAX is the maximum C Bragg spacing C C .. Scalars in common block /REEKE/ .. REAL X1,X2,Y1,Y2,Z1,Z2,XYS,DSTAR2,DSTMAX,DSTPL,DSTPL2, + DIVH,DIVV,DELAMB,ETA,DELCOR,DSTMAXS,TOR,DSTMIN,WMAX INTEGER ISYN,IMONO,NWMAX,IPAD C .. C .. logicals in common block /REEKE/ .. LOGICAL LOGETA,NUREEK C .. C .. Arrays in common block /REEKE/ .. REAL RMC,AMAT C .. C .. Common Block /REEKE/ .. COMMON /REEKE/RMC(3,3),AMAT(3,3),X1,X2,Y1,Y2,Z1,Z2,XYS,DSTAR2, + DSTMAX,DSTPL,DSTPL2,DIVH,DIVV,DELAMB,ETA,DELCOR, + DSTMAXS,TOR,DSTMIN,WMAX,ISYN,IMONO,NWMAX,IPAD,LOGETA,NUREEK C .. C C C&&*&& end_include ../inc/reeke.f C&&*&& include ../inc/reprt.f C--- awk generated include file reprt.h C---- START of include file reprt.h C C C C .. Scalars in common block /REPRT/ .. REAL AVBGRATIO,AVSIG,RFULL,RPART,AVPKRATIO,PKRMAXI,BGRMAXI, + RFACOV,SDRATOV,SDMON,RESCUT,STHCUT INTEGER NREF,NOFR,NOLO,MAXBSI,MINBSI,NEDGE,NBOX,NBZERO,NNEG, + NBAD,NBGRJ,NEDGE1,NPARTEND,NSPOVL,NRSYM,NHALF,NSUMPART LOGICAL PKACCEPT C .. C .. Arrays in common block /REPRT/ .. REAL RATIO,AVSD,AVSDP,AVSIG1,AVSIG2,AVINTI1,AVINTI2,AVPRI1,AVPRI2, + RMSDELI1,RMSDELI2,ABSDELI1,ABSDELI2,AVPRSIG1,AVPRSIG2, + AVDELSIG1,AVDELSIG2,PKRATIO,RSIGVSM, + FIOVSDP,FIOVSDS,PIOVSDP,PIOVSDS,DBIN INTEGER IRANGE,IANAL,IANALF,NRFLS1,NRFLS2,MEANDELI1,MEANDELI2, + NBGRHIST,IVSM,NIVSM,NRESPF,NRESPP,NRESSF,NRESSP, + IRESPF,IRESPP,IRESSF,IRESSP,ISDRESPF,ISDRESPP, + ISDRESSF,ISDRESSP C .. C .. Common Block /REPRT/ .. COMMON /REPRT/RATIO(10),AVSD(10),AVSDP(10),AVSIG1(10,2), $ AVSIG2(NMASKS,2),AVINTI1(10,2),AVINTI2(NMASKS,2), $ AVPRI1(10,2),AVPRI2(NMASKS,2),RMSDELI1(10,2), + RMSDELI2(NMASKS,2),ABSDELI1(10,2),ABSDELI2(NMASKS,2), + AVPRSIG1(10,2),AVPRSIG2(NMASKS,2),AVDELSIG1(10,2), + AVDELSIG2(NMASKS,2),PKRATIO(10),RSIGVSM(13),FIOVSDP(9), $ FIOVSDS(9),PIOVSDP(9),PIOVSDS(9),DBIN(9), $ AVBGRATIO,AVSIG,RFULL,RPART,AVPKRATIO,PKRMAXI,BGRMAXI, $ RFACOV,SDRATOV,SDMON,RESCUT,STHCUT, $ IRANGE(9),IANAL(10),IANALF(10),NRFLS1(10,2), + NRFLS2(NMASKS,2),MEANDELI1(10,2),MEANDELI2(NMASKS,2), + NBGRHIST(32),IVSM(13),NIVSM(13), + NRESPF(9),NRESPP(9),NRESSF(9),NRESSP(9), + IRESPF(9),IRESPP(9),IRESSF(9),IRESSP(9),ISDRESPF(9), + ISDRESPP(9),ISDRESSF(9),ISDRESSP(9),NREF,NOFR,NOLO, $ MAXBSI,MINBSI,NEDGE,NBOX,NBZERO,NNEG,NBAD, + NBGRJ,NEDGE1,NPARTEND,NSPOVL, + NRSYM,NHALF,NSUMPART,PKACCEPT C .. C C C&&*&& end_include ../inc/reprt.f C&&*&& include ../inc/restart.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C---- START of include file restart.h C C---- Saves image ID, IDENT and phi values in case of an abort or C when current run has finished, determines which image will be C displayed with GUI at this point. C C .. Scalars in common block /RESTART/ .. REAL RESTPHIB, RESTPHIE INTEGER RESTID CHARACTER RESTIDENT*40,RTEMPLSTART*100,RTEMPLEND*100 C .. C .. Arrays in common block /RESTART/ .. C C .. Common Block /RESTART/ .. COMMON /RESTART/ RESTPHIB,RESTPHIE,RESTID C C COMMON /RESTARTC/ RESTIDENT,RTEMPLSTART,RTEMPLEND C .. C .. C C C&&*&& end_include ../inc/restart.f C&&*&& include ../inc/rfs.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file rfs.h C---- START of include file rfs.h C C C C .. Scalars in common block /RFS/ .. REAL FDIST,ESTART,RMSRES,WRMSRES,WESTART INTEGER MAXREF,MAXX,MAXY,NRS,MAXR,NREJS C .. C .. Arrays in common block /RFS/ .. REAL XRS,YRS,WXRS,WYRS INTEGER RRS,IHKLR C .. C .. Common Block /RFS/ .. COMMON /RFS/XRS(62),YRS(62),WXRS(62),WYRS(62),FDIST,ESTART, $ RMSRES,WRMSRES,WESTART,RRS(62),IHKLR(3,62),MAXREF,MAXX, + MAXY,NRS,MAXR,NREJS C .. C C C&&*&& end_include ../inc/rfs.f C&&*&& include ../inc/savall.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C---- START of include file savall.h C C NSAVIMG Number of images used in autoindexing C ISAVIMG Array storing image numbers used in last autoindexing C NSAVSEG Number of segments used in last postref run C ISFIRST Array storing image number of the first image C in all segments of last postref run. C SAVMATSR Indicates whether last matrix was determined by C autoindexing (Autoindexing) or by postref (Post refinement) C SAVMATNAM Name of the matrix file C SAVENAM Name of savefile C SVSCN SCANNER keyword C SVSITE SITE keyword C RES High resolution limit given on RESOL keyword C RESLOW Low resolution limit given on RESOL keyword C C .. Scalars in common block /SAVALL/ .. REAL RES,RESLOW INTEGER NSAVIMG,NDIR,NSAVSEG CHARACTER SAVMATSTR*80,SAVMATNAM*80,SAVENAM*80,SVSCN*80, + SVSITE*80 LOGICAL IISCN,IISITE,IIWAVE,IIDIV,IIDISP,IINULL,IIRAST,IISEP, + IIOVER,IIPIX,IIBACK,IIRES C .. C .. Arrays in common block /SAVALL/ .. C INTEGER ISAVIMG(MAXIMG),ISFIRST(100) C .. Common Block /SAVALL/ .. COMMON /SAVALL/ RES,RESLOW,ISAVIMG,ISFIRST,NSAVIMG,NDIR,NSAVSEG, + IISCN,IISITE,IIWAVE,IIDIV,IIDISP,IINULL,IIRAST,IISEP, + IIOVER,IIPIX,IIBACK,IIRES C C COMMON /SAVALLC/ SAVMATSTR,SAVMATNAM,SAVENAM,SVSCN,SVSITE C .. C C C&&*&& end_include ../inc/savall.f C&&*&& include ../inc/scn.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file scn.h C---- START of include file scn.h C C SCNSZ is pixel size (in microns) divided by 25 C RAST pixel size in slow direction in mm C FACT multiplying by FACT converts from 10 micron units C (the standard unit internal to the program) into pixels C IYLEN The number of pixels in the Y (fastest changing) direction C in the digitised image. C NREC The number of pixels in the X (slow) direction in the C digitised image. C NWORD The number of I*2 words in the Y direction. C NBYTE The number of bytes in Y direction = NWORD/2 C NHBYTE Number of bytes in header C C ICURR When several images are stored in a single file, ICURR is the C pointer to the first record of the current image in the direct C access file (only implemented for film data) C NEXTRA The number of additional (unused) bytes padding the end of C each record in image file C BYTSWAP True if the "endedness" (Big-endian/Little-endian) of the C machine that MOSFLM is running on is different to that of the C machine on which the image was written. This is determined by C looking at the value of NXPIX in the header record of the C image file (subroutine GETHDR) C C .. Scalars in common block /SCN/ .. REAL FACT,SCNSZ,RAST INTEGER NBYTE,NREC,NWORD,IYLEN,ICURR,NEXTRA,NHBYTE LOGICAL BYTSWAP C .. C .. Common Block /SCN/ .. COMMON /SCN/ FACT,SCNSZ,RAST,NBYTE,NREC,NWORD,IYLEN,ICURR,NEXTRA, + NHBYTE,BYTSWAP C&&*&& end_include ../inc/scn.f C&&*&& include ../inc/spots2.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file spots.h C---- START of include file spots.h C C---- These stores variables associated with spot-finding routines. C Note that the final coordinates are kept in XSPT,YSPT in /SPOTS/ C C XSPOT... X coordinates (in mm) of all spots found on current C image, before rejections based on spot size C YSPOT... Y coordinates (in mm) of all spots found on current C image, before rejections based on spot size C INSPOT... Intensities of all spots found on current C image, before rejections based on spot size C ISIGSP... Standard deviations of intensities C NOIMG The pack or image number. C PHI.. Phi value of the mid-point of the image C NIMAG Total number of images read in (for autoindexing) C NEWSPT If TRUE, new format spot coordinate file, otherwise old C format. C MEDWXSPOT Median spot size in pixels in X determined in PICKSPOTS C MEDWYSPOT Median spot size in pixels in Y determined in PICKSPOTS C IRSTRT Number of the image on which to restart after an abort C C SPXMIN Minimum X coord (relative to direct beam position) for C spots C SPYMIN Minimum Y coord (relative to direct beam position) for C spots C NSPTD Number of displayed spots C THRESH Threshold for pixel to be considered part of a spot, C is (background + THRESH*sigma) C C .. Scalars in Common Block /SPOTS2/ and /SPOTS2C/ .. REAL CUTPIXMAX,CUTPIXMIN,CUTWXMAX,CUTWXMIN,CUTWYMAX,CUTWYMIN, + XSPLIT,YSPLIT,YOFFSET,XOFFSET,THRESH,RMINSP,RMAXSP, + RMINSRCH,RMAXSRCH,SCALSRCH,SPXMIN,SPYMIN,THRESHMIN, + THRESHMAX INTEGER NBINR,NBINT,IBINLIM,NPIXMIN,NPIXMAX,IIMAG,NIMAG, + MEDWXSPOT,MEDWYSPOT,NSEARCH,ITHSET,ISAFE,IRSTRT, + NSPTD LOGICAL RADX,RADY,NEWSPT,DOFIND,FOUND CHARACTER IMGTEMPL*100,IMGFN*100,IMGNUM*6 C .. C .. Arrays in common /SPOTS2/ and /SPOTS2C/ .... INTEGER NPIX,IWXSPOT,IWYSPOT,IORDER,INSPOT,NOIMG,ISDSPOT REAL BGOD,PHI,XSPOT,YSPOT,RSPOT,PHISTIM C .. C .. Common Block /SPOTS2/ and /SPOTS2C/ .... c COMMON /SPOTS2/XSPLIT,YSPLIT,NBINR,NBINT, c + IBINLIM,PHI(MAXIMG),NPIXMIN,NPIXMAX,CUTPIXMIN,CUTPIXMAX, c + CUTWXMIN,CUTWXMAX,CUTWYMIN,CUTWYMAX, c + BGOD(IXWDTH),YOFFSET,XOFFSET,RADX,RADY,THRESH,IIMAG,NIMAG, c + NPIX(MXSPOT),IWXSPOT(MXSPOT),IWYSPOT(MXSPOT), c + IORDER(MXSPOT),INSPOT(MXSPOT),XSPOT(MXSPOT), c + YSPOT(MXSPOT),RSPOT(MXSPOT),RMINSP,RMAXSP,NOIMG(MAXIMG), c + NEWSPT,DOFIND,ISDSPOT(MXSPOT),MEDWXSPOT,MEDWYSPOT, c + PHISTIM(MAXIMG),RMINSRCH,RMAXSRCH,NSEARCH,SCALSRCH, c + ITHSET,ISAFE,IRSTRT,SPXMIN,SPYMIN,THRESHMIN,THRESHMAX, c + NSPTD common /spots2/CUTPIXMAX,CUTPIXMIN,CUTWXMAX,CUTWXMIN,CUTWYMAX, + CUTWYMIN,XSPLIT,YSPLIT,YOFFSET,XOFFSET,THRESH,RMINSP,RMAXSP, + RMINSRCH,RMAXSRCH,SCALSRCH,SPXMIN,SPYMIN,THRESHMIN, + THRESHMAX,NBINR,NBINT,IBINLIM,NPIXMIN,NPIXMAX,IIMAG,NIMAG, + MEDWXSPOT,MEDWYSPOT,NSEARCH,ITHSET,ISAFE,IRSTRT, + NSPTD,RADX,RADY,NEWSPT,DOFIND,FOUND, $ NPIX(MXSPOT),IWXSPOT(MXSPOT),IWYSPOT(MXSPOT), $ IORDER(MXSPOT),INSPOT(MXSPOT),NOIMG(MAXIMG),ISDSPOT(MXSPOT), $ BGOD(IXWDTH),PHI(MAXIMG),XSPOT(MXSPOT),YSPOT(MXSPOT), $ RSPOT(MXSPOT),PHISTIM(MAXIMG) COMMON /SPOTS2C/ IMGTEMPL,IMGFN,IMGNUM C&&*&& end_include ../inc/spots2.f C&&*&& include ../inc/strat.f C--- awk generated include file strat.h C---- START of include file strat.h C C---- Stores variables for use in STRATEGY option C IROTAX is the axis closest to the rotation axis C PHIROTAX is the angle this axis makes with the rotation axis C C PHIZONE is the phi value at which axis "IZONEAX" is along the C X-ray beam. (IZONEAX = 1 is a, =2 is b, =3 is c) C PHIPAD is the rotation to be added to PHILAUE to ensure generation C of all unique data, and will depend on angle between the C unique axis and the rotation axis. C AUTANOM if true tries to maximise number of anomalous pairs C CELLSCAL is the scale factor applied to the cell edges to C speed up the calculation. C SHRUNK is TRUE if the cell has been scaled by CELLSCAL C ISTRUN is used to increment input phi angles by multiples of C 360 degrees, so that phi values in different parts can C be recognised. It starts at zero. C FIRSTRAT Starts as TRUE (set in MOSDATA) and is set to FALSE once C the MTZ file has been opened for a STRATEGY run. C Reset TRUE after EXITing from STRATGEY prompt. C C .. Scalars in common /STRAT/ .. INTEGER NSEGM,IPCKCUR,NSTRAT,NUNIQ,NSTRUN,ISTRUN,NSEGAUTO, + IZONEAX,IROTAX,NLAST,NNPACKS,NLASTPACK LOGICAL STRATEGY,AUTO,SIZESET,AUTANOM,SHRUNK,FIRSTRAT, + NEWSTRAT,WAITINP,OFFPHI REAL ROTAUTO,PHILAUE,PHIPAD,PHIZONE,PHIROTAX,CELLSCAL C .. C .. Arrays in common /STRAT/ .. REAL PHIST,PHIFIN,PHIINC,PHIADD,PHISEGA INTEGER IFIRSTONE C .. C .. Common Block /STRAT/ .. COMMON /STRAT/ PHIST(NSEGMAX),PHIFIN(NSEGMAX),PHIINC(NSEGMAX), + PHIADD(NSEGMAX),PHISEGA(NSEGMAX),ROTAUTO,PHILAUE,PHIPAD, $ PHIZONE,PHIROTAX,CELLSCAL,IFIRSTONE(NSEGMAX), $ NSEGM,IPCKCUR,NSTRAT,NUNIQ, + NSTRUN,ISTRUN,NSEGAUTO, + IZONEAX,IROTAX,NLAST,NNPACKS,NLASTPACK, + STRATEGY,AUTO,SIZESET,AUTANOM,SHRUNK, + FIRSTRAT,NEWSTRAT,WAITINP, + OFFPHI C .. C C C&&*&& end_include ../inc/strat.f C&&*&& include ../inc/tgen.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file tgen.h C---- START of include file tgen.h C C---- Stores variables for use in TESTGEN option C C .. Arrays in common /TGEN/ .. c REAL XOVER c INTEGER ISTATS C C .. Scalars in common /TGEN/ .. REAL XOVER,PHSTART,PHEND,PHSTEP,OSCMIN,OSCMAX,SDIVH,SDIVV, + SDELCOR,SDELAMB,SETA,OSCANG,PCMAX INTEGER ISTATS LOGICAL TESTGEN,TESTRAT C .. C .. C .. Common Block /TGEN/ .. COMMON /TGEN/XOVER(2),PHSTART,PHEND,PHSTEP,OSCMIN,OSCMAX, + SDIVH,SDIVV,SDELCOR,SDELAMB,SETA,OSCANG,PCMAX, $ ISTATS(MAXPAX,3),TESTGEN,TESTRAT C&&*&& end_include ../inc/tgen.f C&&*&& include ../inc/tiltlog.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C---- awk generated include file tiltlog.h C---- START of include file tiltlog.h C C for things connected with the new definitions of TILT and TWIST C C .. Scalars in common block /TILTLOG/ .. LOGICAL NUTWIST COMMON /TILTLOG/NUTWIST C&&*&& end_include ../inc/tiltlog.f C&&*&& include ../inc/virbat.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C C---- include file header for virtual batches in post-refinement C INTEGER NIVB,MAGIC,NVIRBAT,NADDMISSET,IVIRBAT LOGICAL NUPR_INT COMMON /VIRBAT/ NIVB,MAGIC,NVIRBAT,NADDMISSET, + IVIRBAT,NUPR_INT C&&*&& end_include ../inc/virbat.f C&&*&& include ../inc/xy.f C C $Id: unoptimizable.f,v 1.4 2002/07/01 13:36:04 ccb Exp $ C C--- awk generated include file xy.h C---- START of include file xy.h C C .. Scalars in common block /XY/ .. REAL XTOFD,SINV,COSV,TANV,TWOTHETA INTEGER ICASS C .. C .. Common Block /XY/ .. COMMON /XY/XTOFD,SINV,COSV,TANV,TWOTHETA,ICASS C .. C C XTOFD.... Crystal to detector distance in 10 micron units. Read from C keyworded input and never changed. C C Spot positions are calculated in S/R XYSPOT (Called from C REEK) and are for an "ideal" detector at a distance of XTOFD. C These are converted into pixel positions in S/R MMTOPX C which applies the multiplicative factor XTOFRA to allow C for refinement of the distance. XTOFRA is the parameter C that is actually refined (in RDIST), rather than XTOFD. C The refined distance that is printed in the logfile is C actually XTOFRA*XTOFD C C ICASS.... Indicates detector type: C 0 Flat film C 1 Vee shaped cassettes C 2 FAST detector (only used in TESTGEN mode of OSCGEN) C 3 Swung out FAST (ditto) C 4 IP detector C TWOTHETA Detector swing angle (degrees) C&&*&& end_include ../inc/xy.f c -harvest C&&*&& include ../inc/mharvest.f INTEGER MAXMTZ PARAMETER (MAXMTZ = 16) C .. Scalars in common block /CHARVEST/ .. CHARACTER HVERSION*80,ProjectName*20,DataSetName*20, + HBEAMLINE*10,Precipitant*80, + PNAME_COLS(MAXMTZ)*20, + DNAME_COLS(MAXMTZ)*20 C .. Scalars in common block /IHARVEST/ .. LOGICAL USECWD,PNAMEgiven,DNAMEgiven,DOHARVEST REAL PHhar,Hartemp, + HARETA(MAXPAX),HARDIV(MAXPAX),HARDIH(MAXPAX) CHARACTER*3 MKDIRMODE,CHMODMODE INTEGER KHFLMS C .. C .. Common block /CHARVEST/ .. COMMON /CHARVEST/HVERSION,ProjectName,DataSetName, + HBEAMLINE,Precipitant, + PNAME_COLS,DNAME_COLS C .. Common block /IHARVEST/ .. COMMON /IHARVEST/USECWD,PHhar,Hartemp,KHFLMS, + PNAMEgiven,DNAMEgiven,DOHARVEST, + HARETA,HARDIV,HARDIH,MKDIRMODE,CHMODMODE C .. C&&*&& end_include ../inc/mharvest.f c -harvest C C .. C .. Equivalences .. EQUIVALENCE (IRAS(1),NXS), (IRAS(2),NYS), (IRAS(3),NCC) EQUIVALENCE (IRAS(4),NRX), (IRAS(5),NRY) C .. SAVE C .. Data statements .. C C---- CENTRS refinement is repeated (once) if initial residual ESTART is C greater than ELIMIT (set to 8 below). Outer refinement is repeated C (once only) if initial residual is greater than ELIMIT2 or if final C residual is greater then ELIMIT3 C For weighted refinement, the limit is WELIMIT for all 3 cases C DATA ELIMIT/8.0/,ELIMIT2/3.0/,ELIMIT3/1.5/,WELIMIT/2.0/ DATA YSCALERR/0.0/,RPTIMG/.FALSE./,BIGSHIFT/.FALSE./ DATA FIRSTWARN/.TRUE./ DATA MAGIC /200/, PORTNO /0/ DATA PRFINISH /.FALSE./ C C---- First check to see if the version of CCP4 supports harvesting C C CALL CCP4_VERSION(CCP4VERSION) C HARVESTREADY = .TRUE. C IF(CCP4VERSION.LT.'4.0')HARVESTREADY = .FALSE. C C---- C CALL CCPFYP C c socket PORTNO = CCPE2I('MOSFLMSOCKET',PORTNO) c socket IF(PORTNO.NE.0)THEN c socket CALL UGTENV('REMMOSHOST',REMOTEMOSFLMHOST) c socket CALL OPEN_SOCKET(REMOTEMOSFLMHOST,portno,SERVERFD) c socket SOCKLO = .TRUE. c socket ELSE SOCKLO = .FALSE. c socket ENDIF C C---- new call to initialize everything C INIT_MODE = 0 CALL INITIALIZE(INIT_MODE,GENOPEN,NEWGENF) C C---- items which are declared locally in mosflm.f C FIXPARTLS = .FALSE. PROCESSA = .FALSE. LAST = .FALSE. FORCEREAD = .FALSE. COORDOPN = .FALSE. PI = ATAN(1.0)*4.0 DTOR = PI/180.0 LDUM = 80 C C---- NFLMO is number of films written to MOSFLM.OUT. C This is only greater than one when accumulating C profiles from A films. C NFLMO = 1 ABC = 'ABC' C DO 20 J = 1,3 DO 10 I = 1,MAXPAX IF (J.EQ.1) THEN PRFRPT1(I) = .FALSE. PRFRPT2(I) = .FALSE. PRFHS(I) = .FALSE. PRF(I) = .FALSE. PRNEGM(I) = .FALSE. END IF BADPACK(I,J) = .FALSE. 10 CONTINUE 20 CONTINUE FIRSTTIME = .TRUE. RPTFIRST = .FALSE. C C---- ISEG keeps track of how many times CONTROL has been called, used C in multisegment postrefinement C ISEG = 0 NREPEAT = 0 C C---- Read control information (keyworded) up to next "RUN" card C C ****************************************************** 30 CALL CONTROL(FIRSTTIME,IFIRSTPACK,NEWGENF,GENOPEN,RPTFIRST, + CELLSTR,MODECTRL) C ****************************************************** C C---- If doing data collection strategy, do it now C FIRSTWARN = .TRUE. C Chrp 15022002 C---- If FIRSTTIME is .TRUE., then ISEG should = 0. This is necessary C for automated jobs run through the Mosflm server, and should be C true anyway. C IF(FIRSTTIME)ISEG = 0 34 IF (STRATEGY) THEN XCEN = 100.0*XCENMM(1,1) YCEN = 100.0*YCENMM(1,1) SETA = ETA SDIVH = DIVH SDIVV = DIVV SDELCOR = DELCOR SDELAMB = DELAMB CALL ROTATE C C---- If STRATEGY has more than one run, then ICELL is set to 1. C Reset it to zero now so cell is not fixed. C ICELL = 0 ETA = SETA DIVH = SDIVH DIVV = SDIVV DELCOR = SDELCOR DELAMB = SDELAMB FIRSTTIME = .FALSE. C C---- If window display active, return there providing all runs have been C generated C IF (ISTRUN+1.LT.NSTRUN) GOTO 30 IF (DISPMENU) THEN ADDPART = .FALSE. SUMPART = .FALSE. POWDER = .TRUE. STRATEGY = .FALSE. FORCEREAD = .TRUE. NRUN = 1 C C---- Need to set ISEG to zero in case a multiseg refinement run is done C ISEG = 0 NIMAG = NIMAGSV GOTO 36 END IF GOTO 30 END IF C C---- TESTGEN option C IF (TESTGEN) THEN C XCEN = 100.0*XCENMM(1,1) YCEN = 100.0*YCENMM(1,1) C ******** CALL TESTOVER C ******** FIRSTTIME = .FALSE. C TESTGEN = .FALSE. GOTO 30 END IF C C---- Open coordinate file if DENSE image C C ******************************************************* 36 IF (DENSE) THEN IF (COORDOPN) CLOSE(ICOORD) CALL CCPDPN(-ICOORD,'COORDS','UNKNOWN','U',0,IFAIL) COORDOPN = .TRUE. END IF C ******************************************************* C ISEG = ISEG + 1 RPTFIRST = .FALSE. DONEONCE = .FALSE. CENTRSRPT = .FALSE. IRPTPACK = -999 C C---- If doing multi-segment post-refinement, set NBLOCK to NADD, and C set SUMPART to TRUE as it will have been set FALSE for the last image C of the preceeding segment (for second etc segments) in code below. C However, if only one segment, set NBLOCK = NADD + 1 C 6232 CONTINUE c if(online)write(itout,6233)ifirstpack,npack,nblock,naddp c write(iout,6233)ifirstpack,npack,nblock,naddp c 6233 format(/,'Ifirstpack = ',i4,', Npack = ',i4,' Nblock = ', c $ I4,' Naddp = ',I4/) IF (MULTISEG) THEN IF (NSEG.GT.1) THEN NBLOCK = NADD ELSE NBLOCK = NADD + 1 END IF IF (.NOT.NEWPREF) SUMPART = .TRUE. END IF C C---- Set up partial summation flag for all packs. Note that this C may be changed for an individual pack on calling OPENODS if C the required following image does not exit C C Note that IFIRSTPACK is a pack counter, NOT the serial number of the C pack. Thus it starts at 1 and runs to NPACK/NPACKSAVE C DO 32 IPACK = IFIRSTPACK,NPACK SUMP(IPACK) = SUMPART ADDP(IPACK) = ADDPART 32 CONTINUE C C---- Number of the current block of images C NUMBLOCK = 0 IF (NBLOCK.EQ.0) NUMBLOCK = 1 IF (NBLOCK.NE.0) FIRSTPASS = .FALSE. EXTRAIMG = .FALSE. C C---- IFIRSTP is used as a flag controlling initialisation done in call to C POSTREFL and IFIRSTPSEG is used in NEWPREF SINGLE mode to decide if we C need to do post-refinement on this image and also go back to the very C first image or not C IF (FIRSTTIME.OR.(.NOT.MULTISEG)) IFIRSTP = IFIRSTPACK IFIRSTPSEG = IFIRSTP IF (NEWPREF.AND.MULTISEG) IFIRSTPSEG = IFIRSTPACK NWRN = 0 IF (.NOT.MULTISEG) NREPEAT = 0 PRFIRST = .TRUE. ROFFMAX = 0.0 TOFFMAX = 0.0 CCOMAX = 0.0 WRMAX = 0.0 DELPHIMAX = 0.0 NBADMAX = 0 YSCALERR = 0.0 IF (DEBUG(1)) THEN WRITE(IOUT,FMT=6001) FIRSTTIME,MULTISEG,IFIRSTPACK,NPACK, + NBLOCK,SUMPART,ADDPART,ISEG,NADD,NREPEAT, + NEWPREF,IFIRSTP,IFIRSTPSEG,POSTREF,NIMAG IF (ONLINE) WRITE(ITOUT,FMT=6001) FIRSTTIME,MULTISEG, + IFIRSTPACK,NPACK,NBLOCK,SUMPART,ADDPART,ISEG,NADD, + NREPEAT,NEWPREF,IFIRSTP,IFIRSTPSEG,POSTREF,NIMAG 6001 FORMAT(//,1X,'In MAIN after calling CONTROL',/,1X, $ 'FIRSTTIME ', + L2,' MULTISEG',L2,' IFIRSTPACK',I4,' NPACK',I4,' NBLOCK', + I3,/,1X,'SUMPART',L2,' ADDPART',L2,' ISEG=',I2, + ' NADD=',I2,' NREPEAT=',I3,' NEWPREF ',L2, + ' IFIRSTP=',I3,' IFIRSTPSEG=',I3,/,1X,'POSTREF',L2, + ' NIMAG',I3) END IF C C---- Initialisation flags for FINDPACK, OPENODS, storing cell. MODEOP = 1 STORCELL = .FALSE. C C--- Initialize big array for multi-image post-refinement C INTDUM(1) = 0 INTDUM(2) = 0 IF(NEWPREF)CALL MODARRAY(0, 0.0, 0,0,INTDUM,INTDUM) C C--- If POWDER option, display image etc now C IF (POWDER) THEN C C---- Always display the image given on IMAGE keyword at MOSFLM prompt C even if other images have been read in subsequently in MXDSPL C C AL NIMAG = IRSTRT C AL ID = NOIMG(IRSTRT) C C---- In case this is restart after an aborted run, need to reassign C PHIBEG, PHIEND. Note that the menu is only put up again after an C "Abort" if the IMAGE keyword was used when starting the program C (which sets DISPMENU true). C C AL PHIBEG = PHISTIM(IRSTRT) C AL PHIEND = PHIBEG + 2.0*(PHI(IRSTRT) - PHIBEG) NIMAG = 1 ID = RESTID PHIBEG = RESTPHIB PHIEND = RESTPHIE IDENT = RESTIDENT WAXFN = IDENT IF (TEMPLATE) THEN TEMPLSTART = RTEMPLSTART TEMPLEND = RTEMPLEND END IF C ******************************************************** C---- OPENODS called in POWDER mode C CALL OPENODS(WAXFN,ID,FILM,ODEXT,FDISK,MODEOP, + PACK,ODFILE,SEPCHAR,FORCEREAD,NIMAG, + TEMPLSTART,TEMPLEND) C ******************************************************* C C---- If this is a DIP2, this is the first time the image has been read C C C---- If file does not exist, return to CONTROL C IF (ID.EQ.-999)GOTO 30 C C---- Assign PHIBEG, PHIEND if these are being read from header C IF ((ISTRT.EQ.0).OR.(IANGLE.EQ.0)) THEN PHIBEG = HPHIS PHIEND = HPHIE RESTPHIB = PHIBEG RESTPHIE = PHIEND END IF C XCEN = 100.0*XCENMM(1,1) + CCX YCEN = 100.0*YCENMM(1,1) + CCY IF (NGR.EQ.7) THEN C AL MODEDISP = 4 C C---- Mosaicity estimation immediately prior to starting MXDisplay C C IF(MOSEST)CALL ESTMOS(NIMAG) MODEDISP = 0 CALL XDISP(MODEDISP,FIRSTPACK,PACK,IFIRSTPACK,FIRSTFILM, + GENOPEN) C C---- Trap call to integrate images or postref segment C IF ((MODEDISP.EQ.9).OR.(MODEDISP.EQ.10)) THEN C C---- For post-refinement, set up first image number, as it will not C be set below and FIRSTTIME will not necessarily be true C CAL IF (MODEDISP.EQ.10) IFIRSTP = IFIRSTPACK IFIRSTP = IFIRSTPACK POWDER = .FALSE. MODEDISP = 0 C C---- Need to set up SUMP,ADDP again when integrating via MXDSPL C DO 37 IPACK = IFIRSTPACK,NPACK SUMP(IPACK) = SUMPART ADDP(IPACK) = ADDPART 37 CONTINUE C C---- Open coordinate file if DENSE image C C ******************************************************* IF (DENSE.AND.(.NOT.COORDOPN)) + CALL CCPDPN(-ICOORD,'COORDS','UNKNOWN','U',0, + IFAIL) C ******************************************************* GOTO 31 C C---- Trap call to STRATEGY option from window C ELSE IF (MODEDISP.EQ.20) THEN MODECTRL = 10 c c---- -O2 optimization on DEC Alpha cunningly omits the previous line C unless we access the variable... c WRITE(LINE,FMT='(I3)') MODECTRL FIRSTTIME = .FALSE. C C---- Set NRUN to zero so that if multiple runs are being used in STRATEGY C it will count them correctly C NRUN = 0 C C---- Save the current value of NIMAG as it is set to zero in CONTROL C NIMAGSV = NIMAG GOTO 30 ELSE IF (MODEDISP.EQ.99) THEN CALL MRESET(ISEG,RPTFIRST,GENOPEN,COORDOPN) IF (DISPMENU) THEN GOTO 34 ELSE GOTO 30 END IF END IF END IF FIRSTTIME = .FALSE. GOTO 30 END IF C C****** CALL START taken from here C C C---- Store initial missettings C 31 DO 33 I = 1,3 SDELPHI(I) = DELPHI(I) 33 CONTINUE C C C C C---- Save camera constants etc input by keywords to reinitialise C these variables for each new pack. Note that this is NOT done for C IP data, where the values should not change from image so the C refined values are better than the input ones. C SAVECCX = CCX SAVECCY = CCY SAVECCOM = CCOM SXTOFRA = XTOFRA SYSCAL = YSCAL STILT = TILT STWIST = TWIST SROFF = ROFF SBULGE = BULGE SBULGE2 = BULGE2 STOFF = TOFF C C---- Store input beam parameters, note these are now half-widths in radians C (Converted in call to START from CONTROL) C SETA = ETA SDIVH = DIVH SDIVV = DIVV C FIRSTTIME = .FALSE. C C C C---- Initialise jpack, keeps track of packs in generate file C JPACK = 0 C C---- if using profile fitting, open the "SPOTS" file SPOTOD.OUT C but ONLY if NBLOCK.EQ.0, otherwise it is done below. C IF (PROFILE.AND.(NBLOCK.EQ.0)) THEN IF (PROCES) THEN IFAIL = 1 C C ********************************** CALL CCPDPN(-INMO,'SPOTOD','SCRATCH','U',0,IFAIL) C ********************************** C SECONDPASS = .TRUE. FIRSTPASS = .FALSE. PROCESSA = .TRUE. NFLMO = NPACK - IFIRSTPACK + 1 NOTREAD = .TRUE. ELSE IFAIL = 1 C C ********************************** CALL CCPDPN(-INMO,'SPOTOD','UNKNOWN','U',80,IFAIL) C ********************************** C END IF END IF C C---- Loop over packs to be processed from this generate file in C this "run" C IF (MULTISEG) THEN IF ((ISEG.EQ.1).AND.(NREPEAT.EQ.0)) NFILMS = 0 IF (NREPEAT.EQ.0) THEN DO 29 I = 1,6 OLDCELL(I) = CELL(I) 29 CONTINUE END IF ELSE NFILMS = 0 END IF AVBGRMAX = 0.0 AVBGRMIN = 10000.0 ROFFSAVE = -999.0 TOFFSAVE = -999.0 NOWRITE = 0 NFRPT = 0 C C---- Flag for whether profiles have been read in yet C NOTREAD = .TRUE. IFIRSTGOOD = IFIRSTPACK C C---- If processing a large number C of packs in a single run, it may be advantageous to accumulate C profiles over a block of images rather than all of them (because C the profiles may well change on rotating the crystal). This is done C using the BLOCK subkeyword on the SERIAL keyword line C IF (NBLOCK.NE.0) THEN IFIRSTPACK = IFIRSTPACK - NBLOCK NPACKSAVE = NPACK NPACK = 0 END IF C 35 IF (NBLOCK.NE.0) THEN NUMBLOCK = NUMBLOCK + 1 IFIRSTPACK = IFIRSTPACK + NBLOCK NPACK = IFIRSTPACK + NBLOCK - 1 C C---- If ADDPART generate one image beyond that being processed so that C spatially overlapped partials can be detected. Only generation of C the reflection list will be done for this additional image. C Note this is NOT necessary when using NEWPREF post-refinement. C---- Can't get this to work when reading partials without further effort, C leave it for now C IF (ADDPART.AND.(.NOT.PRREAD).AND.(.NOT.NEWPREF)) THEN NPACK = NPACK + 1 EXTRAIMG = .TRUE. END IF C IF (NPACK.GT.NPACKSAVE) THEN NPACK = NPACKSAVE EXTRAIMG = .FALSE. END IF IFIRSTGOOD = IFIRSTPACK IF (.NOT.PRREAD) FIRSTPASS = .TRUE. IF (MULTISEG) THEN IF ((ISEG.EQ.1).AND.(NREPEAT.EQ.0)) NFILMS = 0 ELSE NFILMS = 0 END IF IF (DEBUG(1)) THEN WRITE(IOUT,FMT=6420) NFILMS IF (ONLINE) WRITE(ITOUT,FMT=6420) NFILMS 6420 FORMAT(1X,'NFILMS initialised (or not), now',I3) END IF AVBGRMAX = 0.0 AVBGRMIN = 10000.0 IFAIL = 1 NOWRITE = 0 NOTREAD = .TRUE. IF (NREPEAT.EQ.0) WRITE(ISUMMR,FMT=6007) 6007 FORMAT(/,/) C C ********************************** IF (NREPEAT.EQ.0) + CALL CCPDPN(-INMO,'SPOTOD','UNKNOWN','U',80,IFAIL) C ********************************** END IF C C---- Write header to summary file (don't repeat this if repeating C processing of first NADD images after post-refinement) C IF (NREPEAT.EQ.0) THEN IF (IMGP) THEN IF (.NOT.USEOVRLD) WRITE(ISUMMR,FMT=6096) 6096 FORMAT(1X,'*** WARNING *** No attempt will be made to', + ' measure overloaded reflections',/,1X,'Use keywo', + 'rds PROFILE OVERLOAD to estimate overloads by p', + 'rofile fitting') WRITE (ISUMMR,FMT=6005) WAVE/DSTMAX ELSE WRITE (ISUMMR,FMT=6004) WAVE/DSTMAX END IF C C---- Film summary heading C 6004 FORMAT(1X,'PACK CCX CCY CCOM DIST YSCALE TILT TWIST', + ' BULGE RESID WRESID FULL PART OVRL NEG BAD', + ' I/SIGI I/SIGI',/,99X,'overall (at',F4.1,'A)') C C---- Image plate summary heading C 6005 FORMAT(1X,'IMAGE CCX CCY CCOM DIST YSCALE TILT TWIST', + ' ROFF TOFF RESID WRESID FULL PART OVRL NEG BAD', + ' I/SIGI I/SIGI Rsym Nsym SDRAT',/,99X,'overall (at', $ F4.1,'A)') END IF C C C***************************************************************************** C C---- LOOP OVER PACKS C C***************************************************************************** 40 CONTINUE C C C---- generate list of spots but don't write generate file... C C HRP 21121999 C---- Assign oscillation angles C C C---- If the spot separation OR raster parameters were not defined C by the user, determine appropriate values now from the very first C image to be processed. C IF (IPACK.EQ.IFIRSTP) THEN IF ((ISEP.EQ.0).OR.(IRAST.EQ.0)) THEN MODEGSR = 0 CALL GETSEPRAS(IRAST,ISEP,IRAS,ID,MINDTX,MINDTY, + IXSEP,IYSEP,MODEGSR,IERR) IF (IERR.NE.0) THEN CALL SHUTDOWN END IF END IF END IF C C--- need to set up PHI range and beam position before calling GENERATE C PHIBEGA,PHIENDA have been set up in CONTROL, based on the phi C values for the first image (when header read to determine image size). C Note that other values in PHIBEGA,PHIENDA will only be correct if all C images have the same oscillation angle. They are updated (in OPENODS) C as each image is read in. C C---- Call GENERATE in MODE=2 (do not write generate file) to work out C NADD, NVIRBAT and whether NEWPREF is required. C PHIBEG = PHIBEGA(IFIRSTPACK) PHIEND = PHIENDA(IFIRSTPACK) XCEN = 100.0*XCENMM(1,1) YCEN = 100.0*YCENMM(1,1) CALL GENERATE(2,IFIRSTPACK,.true.,.true.,LIMIT,.true., + NEWPREF,NFGEN,.false.,NFULLF) C C---- Decide whether to use NEWPREF, but only if a keyword has not been C set explicitly (POSTREF MULTI or NOMULTI) C IF ((IMULTI.EQ.0).AND.(ISEG.EQ.1).AND.(NUMBLOCK.EQ.1).AND. + FIRSTPASS) THEN IF (NIVB.GT.2) THEN IF (.NOT.NEWPREF) THEN NEWPREF = .TRUE. IF (ADDPART.AND.(.NOT.PRREAD)) THEN NPACK = NPACK -1 EXTRAIMG = .FALSE. END IF INTDUM(1) = 0 INTDUM(2) = 0 CALL MODARRAY(0, 0.0, 0,0,INTDUM,INTDUM) SUMPART = .FALSE. END IF END IF END IF IF (NEWPREF.AND.(ISEG.EQ.1).AND.(NUMBLOCK.EQ.1).AND. + FIRSTPASS) THEN C C---- Do not assign NVIRBAT if it has been set by a keyword C IF (IVIRBAT.EQ.0) NVIRBAT = MAX(NIVB-1,1) NADDMISSET = NIVB + NIVB/2 C C---- If NADD keyword given for integration (not cell refinement) C use that value for NADDMISSET C IF (PRMODE.AND.(.NOT.MULTISEG)) NADDMISSET = NADD C C---- Ensure NADDMISSET is a multiple of NVIRBAT C IF (MOD(NADDMISSET,NVIRBAT).NE.0) + NADDMISSET = (NADDMISSET/NVIRBAT)*NVIRBAT +NVIRBAT IF (NADDMISSET.LT.1) NADDMISSET = NVIRBAT IF (MULTISEG) THEN IFIRSTPSEG = IFIRSTPACK ELSE NADD = NADDMISSET END IF WRITE(IOUT,FMT=6400) IF (ONLINE) WRITE(ITOUT,FMT=6400) 6400 FORMAT(//,1X,'*** Post-refinement will use partials ', + 'extending over several images ***',/,1X,'This is', + ' equivalent to including a POSTREF MULTI keyword.',/, + 1X,'(To prevent this, include keywords POSTREF NOMULTI.)') IF (NVIRBAT.GT.1) THEN WRITE(IOUT,FMT=6402) NVIRBAT IF (ONLINE) WRITE(ITOUT,FMT=6402) NVIRBAT 6402 FORMAT(1X,'Separate missetting angles will be refined for', + ' groups of',I3,' images.') END IF WRITE(IOUT,FMT=6404) NADDMISSET IF (ONLINE) WRITE(ITOUT,FMT=6404) NADDMISSET 6404 FORMAT(1X,'Reflections from up to',I3,' images will be', + ' used in the refinement of missetting angles.'/,/) END IF C HRP 21121999 C C---- Initialise RESETCCOM C RESETCCOM = .FALSE. C DO 250 IPACK = IFIRSTPACK,NPACK C FIRSTPACK = (IPACK.EQ.1) C C---- Set pointer to last image in this segment C IF (ISEG.GT.0) LASTFILM(ISEG) = NPACK C IF (DEBUG(1)) THEN WRITE(IOUT,FMT=6009) IPACK,IFIRSTPACK,NPACK,FIRSTPASS, + SECONDPASS,THIRDPASS IF (ONLINE) WRITE(ITOUT,FMT=6009) IPACK,IFIRSTPACK,NPACK, + FIRSTPASS,SECONDPASS,THIRDPASS 6009 FORMAT(1X,'In Loop over packs',/,1X,'IPACK=',I3, + ' IFIRSTPACK=',I4,' NPACK=',I4,' FIRSTPASS',L2, + ' SECONDPASS',L2,' THIRDPASS',L2) END IF C C---- If this is the final (extra) image which is only processed up C to the point of generating the reflection list so that spatially C overlapped summed partials can be flagged, then skip to end of C this loop if this is the second or third pass (Cannot test on C FIRSTPASS because this is never true when reading in profiles) C IF (EXTRAIMG.AND.(IPACK.EQ.NPACK).AND. + (SECONDPASS.OR.THIRDPASS)) GOTO 250 C C---- If this is multi-segment post-refinement, and this is the last pack of C the current segment, then there is no need to process it UNLESS using C NEWPREF refinement. IF ((MULTISEG).AND.(.NOT.NEWPREF).AND.(IPACK.EQ.NPACK)) + GOTO 250 C C---- NACFLM is the number of films in each pack to be included in C profile accumulation. Note that this will depend on C whether processing is starting with the A, B or C film C (hence NFIRST(IPACK), C which is 1, 2 or 3 respectively). C NACFLM = 1 IF (PRBFILM) NACFLM = 2 - NFIRST(IPACK) + 1 IF (PRCFILM) NACFLM = 3 - NFIRST(IPACK) + 1 C ID = IDPACK(IPACK) C C---- Determine which serial keyword this pack belongs to C DO 42 I = 1,50 IF ((ID.GE.IPACK1A(I)).AND.(ID.LE.IPACK2A(I))) THEN ISERADD = ISERAR(I) GOTO 44 END IF 42 CONTINUE C C---- Assign oscillation angles C 44 PHIBEG = PHIBEGA(IPACK) PHIEND = PHIENDA(IPACK) C C---- If on thirdpass, write out summary file information for the C A film of this pack C IF (THIRDPASS) THEN C C---- First check if this film has been rejected, and C write message to summary file. C DO 50 IF = 1,NACFLM IF (BADPACK(IPACK,IF)) THEN IXERRI = IXERR(IPACK) X = XERR(IPACK) C C ***************************************************** CALL SUMMERR(ISUMMR,ID,NERR(IPACK),NFPACK(IPACK), + NFGEN,IF,IXERRI,X) C ***************************************************** C GO TO 250 END IF C C NFILMS = NFILMS + 1 IF (DEBUG(1)) THEN WRITE(IOUT,FMT=6422) NFILMS IF (ONLINE) WRITE(ITOUT,FMT=6422) NFILMS 6422 FORMAT(1X,'NFILMS set to',I4,' for writing', + ' to summary file') END IF C C IF (IMGP) THEN C C---- Writes summary information for ip on detector refinement etc C needed for xloggraph C C IMAGE CCX CCY CCOM DIST YSCALE TILT TWIST ROFF TOFF RESID WRESID C FULL PART OVRL NEG BAD I/SIGI I/SIGI Rsym Nsym SDRAT c -harvest c cxEBI if the format 6067 changes then harvest mharvest.f needs to change c -harvest C WRITE (ISUMMR,FMT=6067) ISUMM(1,NFILMS), + (0.01*ISUMM(K,NFILMS),K=2,3),RSUMM(1,NFILMS), + 0.01*ISUMM(4,NFILMS), + RSUMM(2,NFILMS),(ISUMM(K,NFILMS),K=5,6), + 0.01*ISUMM(7,NFILMS),0.01*ISUMM(19,NFILMS) + ,0.01*RSUMM(3,NFILMS),RSUMM(4,NFILMS), + (ISUMM(K,NFILMS),K=9,13), + (RSUMM(K,NFILMS),K=5,7), + ISUMM(20,NFILMS),RSUMM(8,NFILMS) NLSUM1 = NLSUM1 + 1 WRITE (LINESUM1(NLSUM1),FMT=6067) ISUMM(1,NFILMS), + (0.01*ISUMM(K,NFILMS),K=2,3),RSUMM(1,NFILMS), + 0.01*ISUMM(4,NFILMS), + RSUMM(2,NFILMS),(ISUMM(K,NFILMS),K=5,6), + 0.01*ISUMM(7,NFILMS),0.01*ISUMM(19,NFILMS) + ,0.01*RSUMM(3,NFILMS),RSUMM(4,NFILMS), + (ISUMM(K,NFILMS),K=9,13), + (RSUMM(K,NFILMS),K=5,7), + ISUMM(20,NFILMS),RSUMM(8,NFILMS) ELSE WRITE (ISUMMR,FMT=6066) ISUMM(1,NFILMS), + SUMMCH(NFILMS),(0.01*ISUMM(K,NFILMS),K=2,3), + RSUMM(1,NFILMS),0.01*ISUMM(4,NFILMS), + RSUMM(2,NFILMS),(ISUMM(K,NFILMS),K=5,6), + 0.01*ISUMM(7,NFILMS), + 0.01*RSUMM(3,NFILMS),RSUMM(4,NFILMS), + (ISUMM(K,NFILMS),K=9,13), + (RSUMM(K,NFILMS),K=5,6) END IF C C---- Film format C PACK ID CCX CCY CCOM DIST YSCALE TILT TWIST BULGE C RESID WRESID FULL PART OVRL NEG BAD I/SIGI C 6066 FORMAT (1X,I3,A,3F6.2,F6.1,F6.3,I5,I6,F7.2, + F6.3,F7.1,I7,I6,2I5,I4,2F7.1) C C---- IP format C PACK CCX CCY CCOM DIST YSCALE TILT TWIST ROFF TOFF RESID WRESID C FULL PART OVRL NEG BAD I/SIGI I/SIGI Rsym Nsym SDRAT C 6067 FORMAT (2X,I4,3F6.2,F6.1,F6.3,I5,I6,2F6.2,F6.3,F7.1, + I7,I6,2I5,I4,2F7.1,F8.3,I5,F6.1) 50 CONTINUE END IF C C---- Test if this pack has been rejected already. This test only C necessary when accumulating profiles, and one of the C 'A' films has been rejected C IF (BADPACK(IPACK,1)) GO TO 250 C C---- Set flags for average spot profile, FILMPLOT, C and firstfilm for use in profile accumulation C AVPROFILE = AVPROF(IPACK) FILMPLT = FILMPLOT(IPACK) C C---- CAUTION ! ... be sure that previous packs have not been rejected C when assigning firstfilm C FIRSTFILM = (IPACK.EQ.IFIRSTGOOD) C C---- Locate the required pack in the generate file C C---- NFIRST(IPACK) stores film number (1,2 or 3) of first C film to be processed C NFIRSTI = NFIRST(IPACK) C C---- If profiles have been accumulated from several a films, C then on thirdpass, when b and c films are to be processed C we must start with the b film C just in case the profiles were actually accumulated using C the b films, increment nfirsti rather than setting to 2 C IF (THIRDPASS) THEN NFIRSTI = NFIRSTI + 1 C C---- If B films were included in forming profiles C increment NFIRTSI appropriately. C If C films were included there is no more to be done. C IF (PRBFILM) NFIRSTI = NFIRSTI + 1 IF (PRCFILM) GO TO 250 END IF C STARTA = (NFIRSTI.EQ.1) STARTB = (NFIRSTI.EQ.2) STARTC = (NFIRSTI.GE.3) C C---- If using profile fitting, must start with the A film C IF ((.NOT.THIRDPASS) .AND. PROFILE .AND. (.NOT.PRREAD) .AND. + ((STARTB.AND. (.NOT.PRBFILM)).OR. + (STARTC.AND. (.NOT.PRCFILM)))) THEN WRITE (IOUT,FMT=6008) 6008 FORMAT (//1X,'******* FATAL ERROR ******',/1X,'When using', + ' PROFILE FITTING the A film must be processed first ', + 'unless profile fitting has been',/1X,'EXPLICITLY ', + 'requested for B or C films on PROFILE keyword') IF (ONLINE) WRITE (ITOUT,FMT=6008) CALL SHUTDOWN END IF C FORCE = ((STARTB.AND.FORCEB(IPACK)) .OR. + (STARTC.AND.FORCEC(IPACK))) C C**********************************************************al C---- How many films in this pack to be processed? C NFP = 1 C C**********************************************************al C C---- If accumulating profiles and now on thirdpass, check that C there is another film in the pack to be processed C IF (THIRDPASS .AND. (NFP.EQ.NACFLM)) GO TO 250 C C AL C---- Only call FINDPACK if this pack has already been generated, C ie if this is the second pass of accumulate or if this is the C B or C film (ie thirdpass), OR if this is the first image of C the second or subsequent block of images which has already been C generated in order to flag spatially overlapping summed partials. C However, I have not yet got this to work if reading profiles, C so don't do this when reading profiles C IF ((SECONDPASS.OR.THIRDPASS).OR. + ((IPACK.EQ.IFIRSTPACK).AND.(ADDPART.AND.(.NOT.NEWPREF)) + .AND.(NUMBLOCK.GT.1) + .AND.(.NOT.PRREAD))) + THEN C C *************************************************** CALL FINDPACK(ID,FILMPLT,NFGEN,JPACK,FORCE,READCC,NOFID, + NPACK) C *************************************************** C C---- If running interactively, so that the pattern is regenerated after C refinement (MODEG=3), then if this is the first image of a new block C and ADDPART is TRUE so that spatial overlaps are checked, then C must reposition generate file now to start of this pack, or this C image will get generated twice. C IF (((IPACK.EQ.IFIRSTPACK).AND.(ADDPART.AND.(.NOT.NEWPREF)) + .AND.(NUMBLOCK.GT.1).AND.(.NOT.PRREAD)).AND.FILMPLT + .AND.(.NOT.MATCH)) THEN CALL QSEEK(IUNIT,IPACKHEAD,1,36) IPACKREC = IPACKHEAD END IF END IF C C C---- Check if pack not found, or previous film not measured C IF (ID.LT.0) THEN BADPACK(IPACK,1) = .TRUE. C C---- If this is a multi-segment refinement, abandon it. C IF (MULTISEG) THEN WRITE(IOUT,FMT=6210) IF (ONLINE) WRITE(ITOUT,FMT=6210) 6210 FORMAT(//1X,' A multisegment post-refinement will NOT ', + 'work if images have been rejected',/,1X, $ 'Run aborted') STOP END IF C C---- If this was the firstfilm, C change pack number of first good film C IF (FIRSTFILM) IFIRSTGOOD = IFIRSTGOOD + 1 NWRN = NWRN + 1 C C---- If on firstpass of accumulate run, just store the error, C otherwise write message to summary file now. C IF (FIRSTPASS) THEN NERR(IPACK) = -ID ELSE C C **************************************************** CALL SUMMERR(ISUMMR,ID,-ID,NFPACK(IPACK),NFGEN,FILM,IX,X) C **************************************************** C END IF GO TO 250 END IF C C---- Note that if accumulating profiles, proces is set true C for the second pass C set NFP=NACFLM if going straight into process C IF (PROCES) THEN NFP = NACFLM GO TO 60 END IF C C---- If accumulating profiles, then on first and second passes C only do A films,and on thirdpass do remaining films C IF (ACCUMULATE) THEN IF (FIRSTPASS) THEN NFP = NACFLM ELSE NFP = NFP - NACFLM END IF END IF C C---- loop over the images to be integrated. Note that in SECONDPASS, this C is all the images in the block. C 60 CONTINUE C C DO 240 IFILM = 1,NFP C LIST = .FALSE. RESCAN = .TRUE. C C---- Define initial value of MAXR, required when 'NEXT' is called C for central region of film. ONLY assign it for the firstfilm C because for subsequent films it has been assigned the correct C maximum from RMAXR IF (FIRSTFILM) MAXR = NXS*NYS C C---- Is this film an A,B or C? C FILM = NFIRSTI + IFILM - 1 C C ID = IDPACK(IPACK) C C---- Call OPENODS if one film per file C Don't read image file if doing PROCES IF ((ONEFILE).AND.(.NOT.PROCES)) THEN C C---- If doing SUMPART, don't read images beyond last image to be processed C IF (SUMPART.AND.(IPACK.EQ.NPACKSAVE)) THEN IF (ISTART.EQ.0) THEN ISTART = NREC ELSE IF (ISTART.EQ.NREC) THEN ISTART = 0 END IF SUMPART = .FALSE. C C---- set display filename to the PREVIOUS image that was read in. C CDSPTL = ODFILE ELSE C C---- If this is the "extra" image only used to flag spatially overlapped C summed partials, then don't read in the image C IF ((EXTRAIMG).AND.(IPACK.EQ.NPACK)) GOTO 62 IF (BRIEF) WRITE(IBRIEF,FMT=6204) 6204 FORMAT(1X,'Reading image into memory') C ******************************************************** C---- OPENODS called in normal mode C CALL OPENODS(IDENT,ID,FILM,ODEXT,FDISK,MODEOP, + PACK,ODFILE,SEPCHAR,FORCEREAD,IPACK, + TEMPLSTART,TEMPLEND) C ******************************************************* C---- If phi angles are being read from the image header, PHIBEG and C PHIEND will not yet have been assigned, so need to do that now. C Also need to assign NWMAX, maximum reflection width in images. C IF ((ISTRT.EQ.0).OR.(IANGLE.EQ.0)) THEN PHIBEG = PHIBEGA(IPACK) PHIEND = PHIENDA(IPACK) PHIRNG = PHIEND - PHIBEG C C---- Set maximum reflection width in number of images, hard limit of IPAD C IF (PHIRNG.NE.0.0) NWMAX = NINT(WMAX/PHIRNG) IF (NWMAX.GT.10) THEN IPAD = 100 WARN(27) = .TRUE. END IF NWMAX = MIN(NWMAX,IPAD) C C---- Limit NWMAX to minimum of 2, otherwise will not integrate partials C under any circumstances C NWMAX = MAX(NWMAX,2) END IF END IF C C---- Update SUMPARTIALS flag (may not have next image). Don't need to C do this for NEWPREF refinement. C SUMP(IPACK) = SUMPART IF (.NOT.NEWPREF) ADDP(IPACK) = (SUMPART.AND.ADDP(IPACK)) C C---- If od file does not exist (id set to -999 in openods), or error in read C ID = -1001, or in decoding header (id = -1002) skip to next pack C IF (ID.LE.-999) THEN C C---- ABANDON job if image file does not exist...otherwise it can get into C all sorts of problems. C IF (ID.EQ.-999) THEN WRITE(IOUT,FMT=6205) IF (ONLINE) WRITE(ITOUT,FMT=6205) 6205 FORMAT(/,/,1X,' ***** FATAL ERROR ***',/,1X, + 'Image file not found, abandoning processing') ELSE WRITE(IOUT,FMT=6380) IF (ONLINE) WRITE(ITOUT,FMT=6380) 6380 FORMAT(/,/,1X,' ***** FATAL ERROR ***',/,1X, + 'Error in reading image, abandoning ', $ 'processing') END IF IF (DISPMENU) THEN IXM = 200 IYM = 200 LINELEN = 60 NUMLIN = 3 C C Create IO window C CALL MXDCIO(0,LINELEN, NUMLIN, IXM,IYM) LINE = ' ' IF (ID.EQ.-999) THEN WRITE (LINE, 6207) 6207 FORMAT (1X,'Image does not exist (see terminal ', + 'window). Hit return to continue') ELSE WRITE (LINE, 6390) 6390 FORMAT (1X,'Error reading image (see terminal ', + 'window). Hit return to continue') END IF CALL MXDWIO(LINE, 1) CALL MXDRIO(LINE2) CALL XDLF_FLUSH_EVENTS(I) CALL MXDCIO(1,0,0,0,0) GOTO 280 END IF CALL SHUTDOWN C C---- if this was the firstfilm, change pack number of first good film C IF (FIRSTFILM) IFIRSTGOOD = IFIRSTGOOD + 1 BADPACK(IPACK,1) = .TRUE. NWRN = NWRN + 1 C C C---- If this is a multi-segment refinement, abandon it. C IF (MULTISEG) THEN WRITE(IOUT,FMT=6210) IF (ONLINE) WRITE(ITOUT,FMT=6210) STOP END IF C IF (FIRSTPASS) THEN NERR(IPACK) = 3 ELSE ID = IDPACK(IPACK) C C ************************************************** CALL SUMMERR(ISUMMR,ID,3,NFPACK(IPACK),NFGEN, $ FILM,IX,X) C ************************************************** C END IF GO TO 250 END IF END IF C AFILM = (FILM.EQ.1) BFILM = (FILM.EQ.2) CFILM = (FILM.EQ.3) C C C---- Mosaicity estimation for job without MXDisplay C C IF(MOSEST)CALL ESTMOS(NIMAG) C C C---- Go straight to process if keyword has been set C chrp06122001 62 IF (MOSES2)THEN 62 IF (ONLINE) THEN C IF (IMGP) THEN IF (PROCES) THEN WRITE (ITOUT,FMT=6015) ID,PHIBEG,PHIEND IF (BRIEF) WRITE (IBRIEF,FMT=6015) ID,PHIBEG, $ PHIEND ELSE WRITE (ITOUT,FMT=6011) ID,PHIBEG,PHIEND IF (BRIEF) WRITE (IBRIEF,FMT=6011) ID,PHIBEG, $ PHIEND END IF ELSE WRITE (ITOUT,FMT=6010) ID,ABC(FILM:FILM) END IF IF (EXTRAIMG.AND.(IPACK.EQ.NPACK)) WRITE(ITOUT,FMT=6013) END IF C 6010 FORMAT (/1X,'********************',/1X,'PROCESSING FILM', + I4,A,/1X,'********************') 6011 FORMAT (/1X,'*******************************************', + '*****',/1X,'Processing Image',I5,' Phi',F8.2,' to', + F8.2,/1X,'*****************************************', $ '*******') 6013 FORMAT(/1X,'This image will only be processed up to the ', + 'point of generating the reflection list',/,1X,'so ', + 'that spatial overlapped summed partials are dealt ', $ 'with.') 6015 FORMAT (/1X,'*******************************************', + '*****',/1X,'Integrating Image',I5,' Phi',F8.2, + ' to',F8.2,/1X,'***********************************', $ '*************') C IF (IMGP) THEN IF (PROCES) THEN WRITE (IOUT,FMT=6015) ID,PHIBEG,PHIEND ELSE WRITE (IOUT,FMT=6011) ID,PHIBEG,PHIEND IF (EXTRAIMG.AND.(IPACK.EQ.NPACK)) $ WRITE(IOUT,FMT=6013) END IF ELSE WRITE (IOUT,FMT=6010) ID,ABC(FILM:FILM) END IF IF (PROCES)THEN C C---- For accumulated profiles this is the second pass. C for the firstfilm, the whole of the SPOTOD file will C be read and the profiles accumulated. For second and C subsequent films, these profiles will be used in measuring. C ADDPP = ADDP(IPACK) C IF (WINOPEN) THEN CALL XDLF_FLUSH_EVENTS(I) CALL MXDBSY(0,'Integrating image') END IF C ****************************************** IF (.NOT.NOMEAS) CALL PROCESS(NFLMO,IXSHIFT,IYSHIFT, + ADDPP,ISKIPI,LPINTG,NEWPREF,LPINTG,NOBACK) C ****************************************** IF (WINOPEN) THEN CALL XDLF_FLUSH_EVENTS(I) CALL MXDBSY(-1, ' ') END IF C C---- Display residual vectors if requested, allows bad spot changes C IF (LPINTG.AND.FILMPLT) THEN C C---- If processing more than a single image, need to read in the C image again as it will no longer be stored in memory. However, C the image must always be read into the same "half" of array C IMAGE because we need to keep the last image of the current BLOCK C of images in memory because it has not yet been processed. C To do this, must disable updating of the pointer ISTART in C OPENODS. Do this by setting MODEOP=3 C C Note that ID has to be decremented by 1 (IDTMP=ID-1) when C SUMPART is true because OPENODS increments it by one. C IF (NPACK.GT.1) THEN IDTMP = ID IF (SUMPART) IDTMP = ID - 1 MODEOP = 3 C ******************************************************** C---- OPENODS called to display residual vectors C CALL OPENODS(IDENT,IDTMP,FILM,ODEXT,FDISK, + MODEOP,PACK,ODFILE,SEPCHAR,FORCEREAD,IPACK, + TEMPLSTART,TEMPLEND) C ******************************************************* MODEOP = 0 END IF C C---- Need to set flag to repredict the pattern C ***** Displaying image after integration ***** C MODEDISP = 5 CALL XDISP(MODEDISP,FIRSTPACK,PACK,IFIRSTPACK, + FIRSTFILM,GENOPEN) IF (MODEDISP.EQ.99) THEN C C---- Abort current run C CALL MRESET(ISEG,RPTFIRST,GENOPEN,COORDOPN) IF (DISPMENU) THEN GOTO 34 ELSE GOTO 30 END IF END IF IF (IPACK.EQ.NPACK) LPINTG = .FALSE. C C---- End of display image block C END IF C C C---- Write MTZ file C c c---- hrp07052002 - mtzout should have been set properly elsewhere, but C it seems not to be set if GENFILE hasn't been set explicity C - remind me to fix this properly. C if(mtzout.lt.1)mtzout = 1 CALL WRMTZ(ID+ISERADD,ADDPP,NEWPREF,ALLOUT,NOLP) CALL RSYMM(PROFILE) WRITE (IOUT,FMT=6142) 6142 FORMAT (1X,/15 ('@@@@'),/) IF (ONLINE) WRITE (ITOUT,FMT=6142) IF (BRIEF) WRITE (IBRIEF,FMT=6142) C **************************** NFLMO = 1 C C---- Store information for summary file C NFILMS = NFILMS + 1 IF (DEBUG(1)) THEN WRITE(IOUT,FMT=6424) NFILMS IF (ONLINE) WRITE(ITOUT,FMT=6424) NFILMS 6424 FORMAT(1X,'NFILMS set to',I4,' for storing', + ' info on integration') END IF ISUMM(9,NFILMS) = NOFR ISUMM(10,NFILMS) = NREF - NOFR ISUMM(11,NFILMS) = NOLO ISUMM(12,NFILMS) = NNEG ISUMM(13,NFILMS) = NBAD ISUMM(14,NFILMS) = NBGRJ ISUMM(20,NFILMS) = NRSYM C---- I/sig(i) overall and in highest resolution bin RSUMM(5,NFILMS) = FIOVSDP(9) RSUMM(6,NFILMS) = FIOVSDP(8) C---- If NO fully recorded reflections, use partials C IF (NRESPF(9).EQ.0) RSUMM(5,NFILMS) = PIOVSDP(9) IF (NRESPF(8).EQ.0) RSUMM(6,NFILMS) = PIOVSDP(8) C---- Rsym RSUMM(7,NFILMS) = RFACOV C---- SDRATIO for symmetry related reflections RSUMM(8,NFILMS) = SDRATOV IF (DEBUG(1)) THEN WRITE(IOUT,FMT=6330) AVBGRATIO IF (ONLINE) WRITE(ITOUT,FMT=6330) AVBGRATIO 6330 FORMAT(1X,' AVBGRATIO =',F8.3) END IF AVBGRMAX = MAX(AVBGRMAX,AVBGRATIO) AVBGRMIN = MIN(AVBGRMIN,AVBGRATIO) GO TO 240 C C---- End of "IF (PROCES) block C END IF C C---- Is this film to be treated as an A film ? C TREAT_AS_AFILM = ((BFILM.AND.FORCEB(IPACK)) .OR. + (CFILM.AND.FORCEC(IPACK))) C C IF (TREAT_AS_AFILM) THEN IF (ONLINE) WRITE (ITOUT,FMT=6012) 6012 FORMAT (1X,'This film will be processed as an ''A'' ', $ 'FILM for positional refinement') WRITE (IOUT,FMT=6012) END IF C C---- Assign camera constants for this pack if these have been C supplied. Skip this if readcc has been specified because C we want to use the values read from generate file. C Also skip this if Mar or R-axis image plate data because these C parameters should be constant from one image to the next. C C---- Note that when using NOFID option, we want to reassign C camera constants for B and C films as well, because C they will not normally be the same as the A film. C IF ((AFILM.OR.TREAT_AS_AFILM.OR.NOFID) .AND. + (.NOT.READCC).AND.(.NOT.IMGP)) THEN ICASSP = ICASSET(IPACK) C C IF (ICASSP.NE.0) THEN CCX = CCXA(ICASSP) CCY = CCYA(ICASSP) CCOM = CCOMA(ICASSP) IF (ONLINE) WRITE (ITOUT,FMT=6014) CCX,CCY,CCOM,CBAR 6014 FORMAT (1X,'Camera constants assigned to this pack', $ /,1X,'CCX=',I4, + ' CCY=',I4,' CCOM=',F6.3,' CBAR=',I4) WRITE (IOUT,FMT=6014) CCX,CCY,CCOM,CBAR ELSE C C---- Reassign values input via keywords C CCX = SAVECCX CCY = SAVECCY CCOM = SAVECCOM END IF C C---- Re-initialise other parameters C XTOFRA = SXTOFRA YSCAL = SYSCAL C C TILT = STILT TWIST = STWIST ROFF = SROFF BULGE = SBULGE BULGE2 = SBULGE2 TOFF = STOFF END IF C C IF (NOFID .AND. READCC) THEN C C---- Assign camera constants from generate file for this film C in the pack C CCX = CCXABC(FILM) CCY = CCYABC(FILM) CCOM = CCOMABC(FILM) END IF C C IF (DEBUG(1)) THEN IF (ONLINE) WRITE (ITOUT,FMT=6016) FILM,CCX,CCY,CCOM 6016 FORMAT (1X,'Before FIDUS, CCX,CCY,CCOM for FILM', $ I3,3X,2I5,F8.3) WRITE (IOUT,FMT=6016) FILM,CCX,CCY,CCOM END IF C C---- Update pointer to first strip of ods for film being processed C (set originally in openods) (ONLY FOR IMPC style file format) C C c -vms if (impc) icurr=(film-1)*nrec IF (.NOT.ONEFILE) ICURR = (FILM - 1) * NREC * NBYTE C C C C---- Set flag to indicate which records of film image have been read C** Comment out for present, image all read in OPENODS C DO 70 I = 1,IXWDTH C RDSTRIP(I) = .FALSE. C 70 CONTINUE C C---- Set pointer in IMAGE in case image is not being store in core C IPOINT = 1 C C---- DOPROFILE indicates if ods have been stored for average C spot profile in centrs. this profile determination is controlled C by logical avprofile and is only done after at least one cycle C of refinement. C DOPROFILE = .FALSE. C C---- If no fiducials, assign film centre C (in 10 mu units in scanner frame) C IF (NOFID) THEN XCENF = XCENMM(IPACK,FILM)*100.0 YCENF = YCENMM(IPACK,FILM)*100.0 C C IF (DEBUG(1)) THEN IF (ONLINE) WRITE (ITOUT,FMT=6018) XCENF,YCENF,MACHINE 6018 FORMAT (1X,'in MAIN,XCENF,YCENF from direct beam ', $ 'coords',2F8.1,/,1X,'MACHINE IS ',A) WRITE (IOUT,FMT=6018) XCENF,YCENF,MACHINE END IF END IF C C---- Update XTOFRA for B and C films C C---- Note special requirement if starting with the C film, C because the value stored on the generate file is for C the A film C IF (FILM.GT.1) XTOFRA = XTOFRA + $ (THICK+THFOIL(FILM))/DTOFD IF (STARTC) XTOFRA = XTOFRA + (THICK+THFOIL(2))/DTOFD C C---- Locate fiducial marks C C---- Do this even when NOFID, so that direct beam (if any) C can be located. C---- Note that if READCC is true CCX,CCY are not updated by C the position of the direct beam. C DO NOT call fidus for NOFID option C if READCC is specified (because CCX,CCY are read from C generate file), C or if using NOFID option and there is no direct beam. C IF ( (NFID.EQ.0) .AND. (READCC.OR. (MMDB.EQ.0))) GO TO 80 NFOUND = 0 C C ********************************** CALL FIDUS(NFOUND,ITHRESHF,NOFID,READCC) C ********************************** C 80 OMEGA0 = CCOM*3.14159/180.0 + OMEGAF COSOM0 = COS(OMEGA0) SINOM0 = SIN(OMEGA0) C C---- Must transform ccx,ccy before adding to xcenf,ycenf C ***** NOT ANY MORE **** C AL CCXS = CCX*COSOM0 - CCY*SINOM0 C AL CCYS = CCX*SINOM0 + CCY*COSOM0 CCXS = CCX CCYS = CCY C XCEN = XCENF + CCXS YCEN = YCENF + CCYS ICTF = XTOFD*XTOFRA C IF (DEBUG(1)) THEN C C ITILT = TILT/FDIST ITWIST = TWIST/FDIST IF (IMGP) THEN IROFF = NINT(ROFF) C AL IROFF2 = NINT(ROFF2) ELSE IBULGE = BULGE/FDIST END IF C C WRITE (IOUT,FMT=6022) ICURR,NREC,IFILM,NFIRSTI,AFILM, + STARTA,STARTB,STARTC,CCX,CCY,CCOM,CBAR,XTOFRA, + YSCAL,IRAS,XCENF,YCENF,XCEN,YCEN 6022 FORMAT (1X,'ICURR=',I6,' NREC=',I6,' IFILM=',I3, + ' NFIRSTI=',I3,' AFILM=',L1,' STARTA=',L1, + ' STARTB=',L1,' STARTC=',L1,/1X,'CAMERA CONSTANTS', + /1X,'CCX=',I4,' CCY=',I4,' CCOM=',F6.4,' CBAR=',I4, + /1X,'XTOFRA=',F6.4,' YSCAL=',F6.4,/,1X,'IRAS',5I4, $ ' XCENF,YCENF',2F8.1,'XCEN,YCEN',2F8.1) C C WRITE (IOUT,FMT=6026) ITILT,ITWIST,IBULGE 6026 FORMAT (2X,'ITILT=',I4,' ITWIST=',I4,' IBULGE=',I4) C C IF (ONLINE) THEN WRITE (ITOUT,FMT=6022) ICURR,NREC,IFILM,NFIRSTI,AFILM, + STARTA,STARTB,STARTC,CCX,CCY,CCOM,CBAR,XTOFRA, $ YSCAL C C WRITE (ITOUT,FMT=6026) ITILT,ITWIST,IBULGE END IF END IF C C---- Check all fiducials have been found, if not go to next pack C IF ((NFOUND.LT.NFID) .AND. (.NOT.NOFID)) THEN C C---- If this was the firstfilm, change pack number of first good film C IF (FIRSTFILM) IFIRSTGOOD = IFIRSTGOOD + 1 BADPACK(IPACK,IFILM) = .TRUE. NWRN = NWRN + 1 C C C---- If this is a multi-segment refinement, abandon it. C IF (MULTISEG) THEN WRITE(IOUT,FMT=6210) IF (ONLINE) WRITE(ITOUT,FMT=6210) STOP END IF C IF (FIRSTPASS) THEN NERR(IPACK) = 4 IXERR(IPACK) = NFOUND ELSE C C **************************************************** CALL SUMMERR(ISUMMR,ID,4,NFPACK(IPACK),NFGEN,FILM, + NFOUND,X) C **************************************************** C END IF GO TO 250 END IF C AL C---- Generate the reflections for this pack C 85 GWRITE = .TRUE. UPDATE = .TRUE. NRS = 0 C C---- If the spot separation OR raster parameters were not defined C by the user, determine appropriate values now from the very first C image to be processed. C IF (IPACK.EQ.IFIRSTP) THEN IF ((ISEP.EQ.0).OR.(IRAST.EQ.0)) THEN MODEGSR = 0 CALL GETSEPRAS(IRAST,ISEP,IRAS,ID,MINDTX,MINDTY, + IXSEP,IYSEP,MODEGSR,IERR) END IF IF (IERR.NE.0) THEN CALL SHUTDOWN END IF END IF C C---- If using "WIDTH" option, and this is a repeat run for the first C BLOCK of NADD images (because of an excessive shift in cell or C missetting angle), then pick up the refined missets for each image C rather than starting at beginning. C Introduce different tests for a MULTISEG run and an integration run C that uses a WIDTH. C C However, do not reassign missets if we are repeating this image C IF ((MULTISEG.AND.(NREPEAT.GT.0).AND. + (.NOT.FIXED).AND.(.NOT.RPTIMG)).OR. + ((NREPEAT.GT.0).AND.(.NOT.FIXED).AND. + (IPACK.LE.NADD).AND.(.NOT.RPTIMG)))THEN ISUB = ISEG DO 83 I = 1,3 DELPHI(I) = DELPHIV((IPACK-ISUB)*3+I) IF (NEWPREF) DELPHI(I) = RMISSETS(IPACK,I) 83 CONTINUE C C---- Reset direct beam coords C XCEN = SVXCEN(IPACK) YCEN = SVYCEN(IPACK) IF (DEBUG(1)) THEN WRITE(IOUT,FMT=6027) NREPEAT,NADD,IPACK,DELPHI,XCEN, + YCEN IF (ONLINE) WRITE(ITOUT,FMT=6027) NREPEAT,NADD, + IPACK,DELPHI,XCEN,YCEN END IF 6027 FORMAT(1X,'On repeat run number',I3,' over',I5,' ima', + 'ges reset the missets and beam coords for pack', + I4,/,1X,'New missets:',3F9.3,' New XCEN,YCEN', $ 2F10.2) END IF C C---- Generate the reflection list for this image, unless this is the first C image of the second (or subsequent) block of images which has C already been generated in order to allow for spatial overlap of C summed partials. In this case, FINDPACK will have been called (above). C Note that if NEWPREF post refinement is being done, this image will C NOT have been generated C IF ((IPACK.EQ.IFIRSTPACK).AND.(ADDPART.AND.(.NOT.NEWPREF)) + .AND.(NUMBLOCK.GT.1)) GOTO 87 C IF (IFILM.EQ.1) THEN MODEG = 1 IF (FILMPLT) MODEG = 2 C C---- If this image is only being generated to allow for spatial overlap, C must write the generate file even if display option is being used. C IF (EXTRAIMG.AND.(IPACK.EQ.NPACK)) MODEG = 1 NADD_STORE = NADD C **************************************** C C hrp added 28112000 in case it's been closed at the end of a POSTREF C SEGMENT run c IF(.NOT.GENOPEN)THEN c MTZOUT = 1 c CALL QOPEN(IUNIT,GENFILE,'UNKNOWN') c GENOPEN = .TRUE. c ENDIF CALL GENERATE(MODEG,ID,GWRITE,UPDATE,LIMIT,POSTREF, + NEWPREF,NFGEN,LOVERLAP,NFULLF) C **************************************** C C hrp 10121999 for virtual batches in NEWPREF refinement C c IF ((NADD.ne.NADD_STORE).and.(newpref))THEN c 6231 format(/,/,3(1X,3('***** WARNING ***** '),/), c $ 'NADD is too small and has been reset from ', c $ I2,' to ',I2,/,80('*')) c WRITE(IOUT,FMT=6231)NADD_STORE,NADD c IF(ONLINE)WRITE(ITOUT,FMT=6231)NADD_STORE,NADD c IFIRSTPACK = 1 c NPACK = NADD c do 6234 i=nadd_store,nadd c noimg(i) = noimg(i-1) + 1 c idpack(i) = idpack(i-1) + 1 c print*,'Noimg, I:',i,':',(noimg(j),j=1,i) c print*,'Idpack :',i,':',(noimg(j),j=1,i) c 6234 enddo c pause c GOTO 6232 C HRP ENDIF C C---- If this is the very first image to be processed, and there is C an insufficient number of fully recorded reflections, set flag C to use partials in refinement. C IF (FIRSTPACK) THEN IF (NSPOT.GT.0) RFP = REAL(NFULL)/REAL(NSPOT) IF (RFP.LT.FULLFRAC) FIXPARTLS = .TRUE. IF (FIXPARTLS) THEN WRITE(IOUT,FMT=6230) FULLFRAC IF (ONLINE) WRITE(ITOUT,FMT=6230) FULLFRAC END IF 6230 FORMAT(/,/,1X,'***** WARNING *****',/,1X, + '***** WARNING *****',/,1X, + '***** WARNING *****',/,1X, + 'Because the fraction of fully recorded ', + 'reflections is less than',F5.2,', partials', + /,1X,' will be included in the positional ', + 'refinement.',/,1X,'This fraction can be ', + 'reset with keywords REFINE FULLFRAC eg:',/,1X, + '"REFINE FULLFRAC 0.5" will change it to 0.5') IF (WARN(26).AND.POSTREF.AND..NOT.NEWPREF) THEN WRITE(IOUT,FMT=6360) NPRMIN IF (ONLINE) WRITE(ITOUT,FMT=6360) NPRMIN END IF 6360 FORMAT(/,1X,1X,'***** WARNING *****',/,1X, + '***** WARNING *****',/,1X, + '***** WARNING *****',/,1X, + 'There are fewer than ',I3, + ' partials extending over only',/,1X,'2 images.', + 'Post-refinement can ONLY be carried out using ', + 'reflections that extend',/,1X,'over 2 images.', + ' Thus if the mosaic spread (plus beam divereg', + 'ence) is more than',/,1X,'twice the oscillati', + 'on angle, post-refinement is not possible.',/, + 1X,'You may want',' to use a larger oscillatio', $ 'n angle.') END IF C C---- Store the pack header record number for this image. Note that NFILMS C has not yet been incremented, so use NFILMS+1 as pointer C IPACKSTART(NFILMS+1) = IPACKHEAD C C---- If osc angle not specified, give NWMAX C IF ((ISTRT.EQ.0).OR.(IANGLE.EQ.0)) THEN WRITE(IOUT,FMT=6031) NWMAX IF (ONLINE) WRITE(ITOUT,FMT=6031) NWMAX 6031 FORMAT(1X,'Partial reflections spanning more than', + I3,' images',' will NOT be integrated.',/,1X, + '(use MAXWIDTH to change but maximum width i', $ 's 10 images).') END IF C C---- If using ADDPART option, then spatially overlapped reflections occuring C at the start of the rotation range must be flagged as spatial overlaps C on the previous image. Do this by updating the IR flag in the C generate file for the previous image if NPOVL > 0. C Do NOT need to do this if using NEWPREF postrefinement. C IF (ADDPART.AND.(NPOVL.GT.0).AND.(NFILMS.GT.0) + .AND.(.NOT.NEWPREF)) THEN IF (DEBUG(1)) THEN WRITE(IOUT,FMT=6029) NPOVL,ID,NFILMS IF (ONLINE) WRITE(ITOUT,FMT=6029) NPOVL,ID,NFILMS 6029 FORMAT(1X,I5,' partial spatial overlaps for image', + I5,' NFILMS=',I3) END IF CALL OVERLAP2(IPACKSTART(NFILMS)) END IF C C---- If this is the "extra" image, jump to end of loop now C IF (EXTRAIMG.AND.(IPACK.EQ.NPACK)) GOTO 250 C C---- If not yet done, store starting cell parameters. These are only C calculated after call to GENERATE. C IF (.NOT.STORCELL) THEN DO 86 I=1,6 SCELL(I) = CELL(I) 86 CONTINUE STORCELL = .TRUE. END IF END IF C C---- Badstart indicates if the starting residual in refinement C was poor. if this is the case, centrs will be repeated, C but only once. C 87 BADSTART = .FALSE. C C---- For B and C films, choose refinement spots using intensities C measured on the A film C This option can be overridden in online version C If no fiducials, use CENTRS on B and C films. C IF (FILM.GT.1 .AND. (.NOT.TREAT_AS_AFILM) .AND. + (.NOT.NOFID)) GO TO 210 C IF (FILMPLT) THEN C IF (NGR.EQ.7) THEN MODEDISP = 0 C C---- ***** Display image prior to refinement C CALL XDISP(MODEDISP,FIRSTPACK,PACK,IFIRSTPACK, + FIRSTFILM,GENOPEN) C IF (MODEDISP.EQ.99) THEN C C---- Abort current run C CALL MRESET(ISEG,RPTFIRST,GENOPEN,COORDOPN) IF (DISPMENU) THEN GOTO 34 ELSE GOTO 30 END IF END IF C C---- If mosaic spread has changed, store new values C IF (FIRSTPACK) THEN SETA = ETA SDIVH = DIVH SDIVV = DIVV END IF IF ((MODEDISP.EQ.1).OR.(MODEDISP.EQ.3)) MATCH = .TRUE. END IF C END IF C C C---- Automatic pattern matching option C 88 IF (MATCH) THEN C ADDPP = ADDP(IPACK) C C C ****************************************************** CALL AUTOMATCH(DOPROFILE,NSIG,IXSHIFT,IYSHIFT,NPROFL, + LIMIT,SEP,VLIM,FAIL,LIST,USEBOX, + ADDPP,RWEIGHT,PTMIN, + REFREJ,THICK,FIRSTFILM,NUMBLOCK,MOSEST,IERR2) C ****************************************************** C C---- Don't generate reflection list if refining mosaic spread, or if C orientation refinement has failed C IF (FAIL.OR.RMOSAIC) GO TO 260 UPDATE = .FALSE. GWRITE = .TRUE. C C---- Reposition the generate file to start of first pack C NB This assumes AUTOMATCH is only ever run on the FIRST image in C the generate file, and not for subsequent images. In principle C there is no reason why it should not be run on every image, but C this is not yet implemented C CALL QSEEK(IUNIT,21,1,36) IPACKREC = 21 IPACKHEAD = IPACKREC MODEG = 4 C C---- If using X-window display, do not want to write the generate file yet C as parameters may be updated. C IF (FILMPLT) MODEG = 2 C C **************************************** CALL GENERATE(MODEG,ID,GWRITE,UPDATE,LIMIT,POSTREF, + NEWPREF,NFGEN,LOVERLAP,NFULLF) C **************************************** C IF (WINOPEN) CALL XDLF_FLUSH_EVENTS(I) IF (NOMEAS) GO TO 260 MATCH = .FALSE. C C---- If at least 10 fully recorded reflections in newly generated C reflection list don't bother to call CENTRS again IF (NFULLF.GT.10) GO TO 140 END IF C C---- Find refinement spots in central portion of film C cycle through the refinement of central part of film C NCYC times (default=2) C C---- If NOFID, select refinement spots for B and C films based on C measured intensities of preceeding film for CENTRS. C GENLIST = (NOFID .AND. (FILM.GT.1)) 90 CONTINUE C IF (BRIEF) WRITE(IBRIEF,FMT=6206) 6206 FORMAT(1X,'Refining detector parameters using spots from', + ' centre of image') C C---- Do initial call to set up standard profiles and to RMAXR to C calculate box sizes, as these are needed by NEXT. For IP data, C only need to do this once, but for film data the position of C the direct beam in the digitised image can vary from one C pack to the next, so need to set it up for every pack. C (Same will be true for IP data from an offline scanner) C IF (.NOT.IMGP) THEN CALL PRSETUP C *********************** IF (FIRSTFILM) CALL RMAXR(LIMIT,THICK,IERR2) C *********************** ELSE IF (FIRSTFILM.AND.NUMBLOCK.EQ.1) THEN CALL PRSETUP CALL RMAXR(LIMIT,THICK,IERR2) IF ((IERR2.EQ.1).AND.DISPMENU) THEN WRITE(LINE,FMT=6208) IRAS(1),IRAS(2) 6208 FORMAT('Overall dimensions of measurement box ', $ 'reduced to:',2I4) L = LENSTR(LINE) IXP = 400 IYP = 400 CALL XDLF_POPUP_NOTICE(IXP,IYP, XDLSTR(LINE),L, + XDLSTR(' '),0,XDLSTR('OK'),2,XDLSTR(' '), + -1,3,0,IBUTTON) END IF IF (IERR2.EQ.2) THEN IF (DISPMENU) THEN C C---- If running interactively, trap measurement box being too big C CALL MRESET(ISEG,RPTFIRST,GENOPEN,COORDOPN) GOTO 34 ELSE CALL SHUTDOWN END IF END IF END IF END IF C IF (WINOPEN) CALL MXDBSY(0,'Refining detector parameters') C C---- Initialise RRWEIGHT true if using peak/background mask, else false C RRWEIGHT = USEBOX C DO 110 ICYC = 1,NCYC C IF (WINOPEN) CALL XDLF_FLUSH_EVENTS(I) C FINAL = (ICYC.EQ.NCYC) IF (ONLINE) THEN C WRITE (ITOUT,FMT=6028) ICYC 6028 FORMAT (/1X,'Refinement cycle',I3) END IF C C WRITE (IOUT,FMT=6028) ICYC C C---- In CENTRS, the background definition of the measurement box C is not used to determine the centre of gravity (the c of g over C the whole measurement box is calculated...this gives a greater C range of convergence). in second and subsequent cycles, if the C final residual of the previous cycle is less then rmslim C (default value 6.0, can be changed by keyword "resid"), use the C same list of reflections and s/r 'next' to evaluate the true C c of g for these reflections C IF (RRWEIGHT) THEN OKREF = (WRMSRES.LE.WRMSLIM) ELSE OKREF = (RMSRES.LE.RMSLIM) END IF 104 IF (ICYC.EQ.1) OKREF = .FALSE. C IF ((ICYC.GT.1) .AND. (OKREF)) THEN C C---- For 2nd and subsequent cycles use NEXT if refinement is OK C LIST = .TRUE. C C---- Restore original list of reflections from CENTRS so they are C all remeasured by NEXT C NRS = NRSOLD DO 106 I = 1,NRS RRS(I) = IRSAVE(I) 106 CONTINUE IF (USEBOX) THEN WRITE(IOUT,FMT=6100) NRS IF (ONLINE) WRITE(ITOUT,FMT=6100) NRS 6100 FORMAT(/1X,'Repeating refinement using the same ', + 'list of',I3,' reflections') ELSE IF (ONLINE) WRITE (ITOUT,FMT=6058) NRS 6058 FORMAT (/1X,'Repeating refinement using the ', $ 'same list of',I3,' Reflections and using',/, $ 1X,'the peak/background mask') WRITE (IOUT,FMT=6058) NRS END IF C CENTRAL = .TRUE. C ***************************************************** CALL NEXT(LIST,IXSHIFT,IYSHIFT,PRECESS,MATCH,IFAIL, + PARTLS,ADDPP,CENTRAL) C ***************************************************** C USEWEIGHT = .TRUE. C C---- If not enough reflections now, go back to CENTRS, but only allow C this to happen once. C IF ((NRS.LT.MINREF).AND.(.NOT.DONEONCE)) THEN MINREFS = MINREF CENTRSRPT = .TRUE. DONEONCE = .TRUE. MINREF = MINREF + MINREF/2 OKREF = .FALSE. GOTO 104 END IF C ELSE C C---- otherwise use CENTRS C USEWEIGHT = .TRUE. MATCH = .FALSE. PARTLS = .FALSE. OVRLDS = .FALSE. OLDLIST = (ICYC.NE.1) IF (FIXPARTLS) THEN PARTLS = .TRUE. FIXPARTLS = .FALSE. END IF IF (USEPAR) PARTLS = .TRUE. IF (USEOVR) OVRLDS = .TRUE. IF (.NOT.USEBOX) THEN WRITE(IOUT,FMT=6057) IF (ONLINE) WRITE(ITOUT,FMT=6057) C C---- If not using the box, can't get sd's of centroids so refinement C must be unweighted C USEWEIGHT = .FALSE. C C---- If doing weighted refinement, set RMSLIM high so that on next C cycle it will use the peak/background mask and weighted refinement. C IF (RWEIGHT) RMSLIM = 100.0 END IF 6057 FORMAT(1X,'The peak/background mask will not be ', + 'used in determining centroids and the',/,1X, + 'refinement will not be weighted') C C---- Set ADDPART flag for this image (will always be false for last C image to be measured) C ADDPP = ADDP(IPACK) C *************************************************** CALL CENTRS(DOPROFILE,NSIG,IXSHIFT,IYSHIFT,NPROFL, + LIMIT,SEP,VLIM,MATCH,PARTLS,OVRLDS,MINREF, + OLDLIST,GENLIST,USEBOX,ADDPP,PTMIN) C *************************************************** C C---- If this was a repeat of CENTRS because a previous call to NEXT C did not find enough reflections, restore MINREF to true value C IF (CENTRSRPT) THEN MINREF = MINREFS CENTRSRPT = .FALSE. END IF C C---- IF this is the first image and PARTLS is true and the user has C not explicitly requested inclusion of partials in forming profiles, C then set flag for including partials in profile fitting also. C IF (PARTLS.AND.FIRSTPACK.AND.(.NOT.ADDPART) + .AND.(.NOT.PRPART) + .AND.(.NOT.PRFULLS)) THEN IF (USEPAR) THEN WRITE(IOUT,FMT=6102) IF (ONLINE) WRITE(ITOUT,FMT=6102) ELSE WRITE(IOUT,FMT=6103) IF (ONLINE) WRITE(ITOUT,FMT=6103) END IF 6102 FORMAT(1X,'***** WARNING *****',/,1X, + '***** WARNING *****',/,1X, + '***** WARNING *****',/,1X, + 'Because you have requested inclusion ', + 'of partials in refinement (REFINEMENT', + ' INCLUDE PARTIALS)',/,1X,'partials wi', + 'll be used in forming the standard pr', $ 'ofiles.',/,1X,'This is equivalent to ', + 'including keywords: PROFILE PARTIALS', + /,1X,'If you do NOT want to include pa', + 'rtials in forming profiles, use keywo', + 'rds: PROFILE FULLS') C 6103 FORMAT(1X,'***** WARNING *****',/,1X, + '***** WARNING *****',/,1X, + '***** WARNING *****',/,1X, + 'Because there are very few fully reco', + 'rded reflections in the central region', + /,1X,'of the image, partials will be u', + 'sed in forming the standard',/,1X,'pr', + 'ofiles. This is equivalent to includi', + 'ng keywords: PROFILE PARTIALS',/,1X, + 'If you do NOT want to include partial', + 's in forming profiles, use keywords: ', + ' PROFILE FULLS') PRPART = .TRUE. WTPROFILE = .FALSE. WARN(23) = .TRUE. END IF C C---- Update USEPAR if PARTLS has been set true in CENTRS because not enough C fully recorded reflections have been found C Set warning flag if use of partials was not requested by user C IF (PARTLS.AND.(.NOT.WARN(22).AND.(.NOT.USEPAR))) THEN USEPAR = .TRUE. WARN(22) = .TRUE. IWARN(1,22) = ID END IF NRSOLD = NRS C C---- Save this list of reflections for use in subsequent refinement using C NEXT C DO 108 I = 1,NRS IRSAVE(I) = RRS(I) 108 CONTINUE END IF C C IF (NRS.GE.MINREF) GO TO 100 WRITE (IOUT,FMT=6030) NRS 6030 FORMAT (' Only',I6,' Refinement SPOTS found') IF (BRIEF) WRITE (IBRIEF,FMT=6030) NRS IF (ONLINE) WRITE (ITOUT,FMT=6030) NRS C C---- if online, do FILMPLOT, otherwise go on to the next pack C IF (ONLINE) THEN WRITE (ITOUT,FMT=6032) IF (BRIEF) WRITE (IBRIEF,FMT=6032) 6032 FORMAT (1X,'You may either abandon this image or ', + 'inspect the image',/1X,'Do you want to insp', $ 'ect the image (Y/N) ? ',$) C C ********** CALL YESNO(YES) C ********** C IF (YES) THEN C MODEDISP = 0 C C---- ***** Display after failure of refinement ***** C CALL XDISP(MODEDISP,FIRSTPACK,PACK,IFIRSTPACK, + FIRSTFILM,GENOPEN) C IF ((MODEDISP.EQ.1).OR.(MODEDISP.EQ.3)) THEN MATCH = .TRUE. GOTO 88 ELSE IF (MODEDISP.EQ.99) THEN C C---- Abort current run C CALL MRESET(ISEG,RPTFIRST,GENOPEN,COORDOPN) IF (DISPMENU) THEN GOTO 34 ELSE GOTO 30 END IF END IF C C C---- Repeat CENTRS for adjusted pattern C GO TO 90 END IF ELSE IF (LIST) THEN WRITE(IOUT,FMT=6033) 6033 FORMAT(1X,'If there were only just over 20 refl', + 'ections in the list, try increasing LIMIT', $ 'or',/,1X,'decreasing', + ' NSIG on the REFINEMENT keyword',/,1X, + '***** ABANDONING PROCESSING, going on to', + ' next pack *****',//) ELSE WARN(4) = .TRUE. WRITE (IOUT,FMT=6034) 6034 FORMAT (///1X,'The failure to find at least 20 ', + 'spots almost certainly means that there i', $ 's an',/,1X,'error in either the camera con', + 'stants or the predicted pattern',/,1X,'for ', + 'this image'/,1X,'You are strongly advised', + ' to use the graphical display option to s', + 'ee what ',/,1X,'is wrong',/,1X, + '***** ABANDONING PROCESSING, going on to', + ' next pack *****',//) END IF END IF C C---- If this was the firstfilm, change pack number of first good film C IF (FIRSTFILM) IFIRSTGOOD = IFIRSTGOOD + 1 BADPACK(IPACK,IFILM) = .TRUE. NWRN = NWRN + 1 C C C---- If this is a multi-segment refinement, abandon it. C IF (MULTISEG) THEN WRITE(IOUT,FMT=6212) IF (ONLINE) WRITE(ITOUT,FMT=6212) 6212 FORMAT(//1X,' A multisegment post-refinement will ', + 'NOT work if images have been rejected',/,1X, $ 'Use the interactive graphics to find out why', $ ' the positional', + /,1X,'residual is so high for this image.') STOP END IF C IF (FIRSTPASS) THEN NERR(IPACK) = 5 IXERR(IPACK) = NRS ELSE C C *************************************************** CALL SUMMERR(ISUMMR,ID,5,NFPACK(IPACK),NFGEN,FILM, $ NRS,X) C *************************************************** C END IF C C GO TO 250 C C---- REFINEMENT C ========== C 100 IF (NOREF) GOTO 110 C C---- In CENTRS, only spots within 'LIMIT' 10 micron units (default 25mm) C of film centre are used C These limits can be changed by keywords 'limit' C in centrs if all central reflections are overloads. C CENTRE = .TRUE. C C C C RRWEIGHT = (RWEIGHT.AND.USEWEIGHT) C C ****************************************** CALL RDIST(CENTRE,FINAL,WELIMIT,ELIMIT,ELIMIT2,ELIMIT3, + BADSTART,RRWEIGHT,REFREJ) C ****************************************** C CENTRE = .FALSE. C C---- End of loop over refinement cycles C 110 CONTINUE C IF (RWEIGHT) THEN IF (WRMSRES.LT.WRMSLIM) GO TO 130 ELSE IF (RMSRES.LT.RMSLIM) GO TO 130 END IF C IF (ONLINE) THEN IF (WINOPEN) THEN IXM = 200 IYM = 200 LINELEN = 75 NUMLIN = 9 C C Create IO window C CALL MXDCIO(0,LINELEN, NUMLIN, IXM,IYM) LINE = ' ' WRITE(LINE,FMT=6320) WRMSRES 6320 FORMAT('Final weighted residual (',F4.1,') is too ', $ 'large.') CALL MXDWIO(LINE,1) LINE = ' ' WRITE(LINE,FMT=6322) WRMSLIM 6322 FORMAT('(Maximum is',F5.1,' set by subkeyword RESID', + ' of keyword REFINEMENT)') CALL MXDWIO(LINE,1) LINE = ' ' WRITE(LINE,FMT=6324) 6324 FORMAT('You can either reset the maximum value and ', + 'continue or abort processing.') CALL MXDWIO(LINE,1) LINE = ' ' 112 WRITE(LINE,FMT=6326) 6326 FORMAT('Do you want reset the maximum residual (Y):') CALL MXDWIO(LINE, 1) CALL MXDRIO(LINE2) C C---- Parse reply C C ****************************************** CALL MPARSE(LINE2,IBEG,IEND,ITYP,VALUE,IDEC,NTOK) C ****************************************** IF (NTOK.EQ.0) THEN STR1 = 'Y' ELSE STR1 = LINE2(IBEG(1):IEND(1)) CALL CCPUPC(STR1) END IF IF (STR1.EQ.'Y') THEN C C---- Get max residual C LINE = ' ' WRMSLIM = 100.0 114 WRITE (LINE, 6328) WRMSLIM 6328 FORMAT(1X,'New maximum residual (',F6.1,') :') CALL MXDWIO(LINE, 0) CALL MXDRIO(LINE2) C C---- Get numbers using PARSER C C ****************************************** CALL MPARSE(LINE2,IBEG,IEND,ITYP,VALUE,IDEC,NTOK) C ****************************************** IF (NTOK.EQ.0) THEN CONTINUE ELSE CALL MKEYNM(1,1,LINE2,IBEG,IEND,ITYP,NTOK) IF (IOERR) GOTO 114 WRMSLIM = VALUE(1) END IF RMSLIM = WRMSLIM ELIMIT = WRMSLIM ELIMIT2 = WRMSLIM ELIMIT3 = WRMSLIM CALL MXDCIO(1,0,0,0,0) GOTO 130 ELSE C C---- Do NOT want to reset max residual C LINE = ' ' WRITE(LINE,FMT=6340) 6340 FORMAT('Do you want abandon processing (Y):') CALL MXDWIO(LINE, 1) CALL MXDRIO(LINE2) C C---- Parse reply C C ****************************************** CALL MPARSE(LINE2,IBEG,IEND,ITYP,VALUE,IDEC,NTOK) C ****************************************** IF (NTOK.EQ.0) THEN STR1 = 'Y' ELSE STR1 = LINE2(IBEG(1):IEND(1)) CALL CCPUPC(STR1) END IF IF (STR1.EQ.'Y') THEN C C--- ABANDON C CALL MRESET(ISEG,RPTFIRST,GENOPEN,COORDOPN) IF (DISPMENU) THEN GOTO 34 ELSE GOTO 30 END IF ELSE C C---- Repeat query C GOTO 112 END IF END IF C C ELSE C C---- This block if NOT WINOPEN C IF (RWEIGHT) THEN WRITE (ITOUT,FMT=6037) WRMSLIM IF (BRIEF) WRITE (IBRIEF,FMT=6037) WRMSLIM ELSE WRITE (ITOUT,FMT=6036) RMSLIM IF (BRIEF) WRITE (IBRIEF,FMT=6036) RMSLIM END IF 6036 FORMAT (1X,'Final residual too large',/,1X,'(Max', + 'imum ',F4.1,' defined by subkeyword RESID o', + 'f REFINEMENT keyword)',/1X,'Do you want to ', + 'do more cycles of refinement (Y/N) ?',$) 6037 FORMAT (1X,'Final weighted residual too large',/, + 1X,'(Maximum ',F4.1,' defined by subkeyword ', $ 'RESID of REFINEMENT keyword)',/1X, + 'Do you want to do more cycles of refinement', $ ' (Y/N) ?',$) C C ********** CALL YESNO(YES) C ********** C IF (YES) GO TO 90 WRITE (ITOUT,FMT=6038) IF (BRIEF) WRITE (IBRIEF,FMT=6038) 6038 FORMAT (1X,'Do you want to inspect the image (Y/N)', $ '? ',$) C C ********** CALL YESNO(YES) C ********** C IF (YES) THEN C MODEDISP = 0 CALL XDISP(MODEDISP,FIRSTPACK,PACK,IFIRSTPACK, + FIRSTFILM,GENOPEN) IF (MODEDISP.EQ.99) THEN C C---- Abort current run C CALL MRESET(ISEG,RPTFIRST,GENOPEN,COORDOPN) IF (DISPMENU) THEN GOTO 34 ELSE GOTO 30 END IF END IF C C C---- Repeat CENTRS for adjusted pattern C GO TO 90 END IF WRITE (ITOUT,FMT=6040) IF (BRIEF) WRITE (IBRIEF,FMT=6040) 6040 FORMAT (1X,'You may either abandon this image or car', $ 'ry on',/1X,'Do you want to carry on (Y/N) ? ',$) C C ********** CALL YESNO(YES) C ********** C IF (YES) THEN RMSLIM = 100.0 WRMSLIM = 100.0 ELIMIT = 100.0 ELIMIT2 = 100.0 ELIMIT3 = 100.0 WRITE (ITOUT,FMT=6042) IF (BRIEF) WRITE (IBRIEF,FMT=6042) 6042 FORMAT (/1X,'** WARNING, All RMS residual limits ', $ 'set to 100.0 to continue', + /1X,'**They will not be RESET**') GO TO 130 END IF C C---- End of IF (DISPMENU) block END IF C C---- If in batch mode C ELSE IF (RWEIGHT) THEN WRITE (IOUT,FMT=6045) WRMSRES,WRMSLIM 6045 FORMAT (//1X,'The FINAL weighted residual of',F6.1, + ' is greater than the maximum allowed (', $ F4.1,')',/1X,'(Defined by ', + 'RESID keyword on REFINEMENT card)',/1X, + 'Going on to next image') ELSE WRITE (IOUT,FMT=6044) RMSRES,RMSLIM 6044 FORMAT (//1X,'The FINAL refined residual of',F6.1, $ ' is greater than the maximum allowed (',F4.1, $ ')',/1X,'(Defined by ', + 'RESID keyword on REFINEMENT card)',/1X, + 'Going on to next image') END IF END IF C C---- If this was the firstfilm, change pack number of first good film C IF (FIRSTFILM) IFIRSTGOOD = IFIRSTGOOD + 1 BADPACK(IPACK,IFILM) = .TRUE. NWRN = NWRN + 1 C C C---- If this is a multi-segment refinement, abandon it. C IF (MULTISEG) THEN WRITE(IOUT,FMT=6212) IF (ONLINE) WRITE(ITOUT,FMT=6212) STOP END IF C IF (FIRSTPASS) THEN NERR(IPACK) = 6 XERR(IPACK) = RMSRES ELSE C C ******************************************************* CALL SUMMERR(ISUMMR,ID,6,NFPACK(IPACK),NFGEN,FILM,IX, $ RMSRES) C ******************************************************* C END IF C C GO TO 250 C C---- if centrs has already been repeated due to poor initial residual C do not allow a second repeat. C 130 IF (BADSTART) GO TO 140 IF (RWEIGHT) THEN BADSTART = (WESTART.GT.WELIMIT) ELSE BADSTART = (ESTART.GT.ELIMIT) END IF C C---- Repeat centrs if initial residual high C IF (BADSTART) THEN IF (RWEIGHT) THEN XLIMIT = WELIMIT ELSE XLIMIT = ELIMIT END IF WRITE (IOUT,FMT=6046) XLIMIT 6046 FORMAT (/1X,'Repeat refinement because INITIAL RESID', $ 'UAL is greater than ',F5.1) IF (ONLINE) WRITE (ITOUT,FMT=6046) XLIMIT GO TO 90 END IF C 140 IF ((.NOT.AVPROFILE).OR.(NOREF)) GO TO 170 C C DOPROFILE = .TRUE. NRSOLD = NRS C C---- Repeat centrs to accumulate average spot profile C 150 IF (ONLINE) WRITE (ITOUT,FMT=6048) 6048 FORMAT (1X,'Accumulating spots for SPOT PROFILE') MATCH = .FALSE. PARTLS = .FALSE. OVRLDS = .FALSE. MINREFAV = 3 IF (MINREF.EQ.0) MINREFAV = 0 OLDLIST = .FALSE. IF (USEPAR) PARTLS = .TRUE. IF (USEOVR) OVRLDS = .TRUE. C C---- Set ADDPART flag for this image (will always be false for last C image to be measured) C ADDPP = ADDP(IPACK) C C ******************************************************** CALL CENTRS(DOPROFILE,NSIG,IXSHIFT,IYSHIFT,NPROFL,LIMIT, + SEP,VLIM,MATCH,PARTLS,OVRLDS,MINREFAV,OLDLIST, + GENLIST,USEBOX,ADDPP,PTMIN) C ******************************************************** C C---- Check on measurement box dimensions by displaying average C spot profile C IF (NPROFL.GT.0) THEN C C ***************************************************** CALL CHKRAS(AVPROFILE,MAXR,FIRSTFILM,FILM) C ***************************************************** C ELSE AVPROFILE = .FALSE. END IF C NRS = NRSOLD C C---- AVPROFILE is updated in CHKRAS and set false if running C in batch mode or if the measurement box is not to be C changed C IF (AVPROFILE) GO TO 150 C C---- if the "FINDCC" option has been set (used to determine C camera constants using FILMPLOT and write them back C to generate file without going on to measure the film) C then do that here C 170 IF (FINDCC) THEN MODEWR = 3 IF (NOFID) MODEWR = 2 + FILM C ADDPP = ADDP(IPACK) C C **************************** CALL WRGEN(MODEWR,PROFILE,ADDPP) C **************************** C MODEWR = 0 WRITE (ITOUT,FMT=6050) 6050 FORMAT (/1X,'Refined camera constants and distortion', + ' parameters written to generate file') C C---- For NOFID option, need to write separate CCX,CCY C for each film in pack C IF (NOFID) GO TO 240 GO TO 250 END IF C C C---- For NOFID option and B or C film, goto NEXT to refine whole film C IF (NOFID .AND. (FILM.GT.1)) GO TO 210 C C---- Recalculate the box sizes, as size of measurement box may have C changed in CHKRAS C C *********************** C *********************** IF (FIRSTFILM) THEN CALL RMAXR(LIMIT,THICK,IERR2) C *********************** IF ((IERR2.EQ.1).AND.DISPMENU) THEN WRITE(LINE,FMT=6208) IRAS(1),IRAS(2) L = LENSTR(LINE) IXP = 400 IYP = 400 CALL XDLF_POPUP_NOTICE(IXP,IYP, XDLSTR(LINE),L, + XDLSTR(' '),0,XDLSTR('OK'),2,XDLSTR(' '), + -1,3,0,IBUTTON) END IF IF (IERR2.EQ.2) THEN IF (DISPMENU) THEN C C---- If running interactively, trap measurement box being too big C CALL MRESET(ISEG,RPTFIRST,GENOPEN,COORDOPN) GOTO 34 ELSE CALL SHUTDOWN END IF END IF END IF C C---- Go straight to gensort if not refining (NOREF) C IF (NOREF) GOTO 224 C C---- select 20 refinement spots from centrs prior to choosing C spots for refinement from the outside of the film C C *********** CALL MSELECT C *********** C C---- If not already done in central refinement area, find true C centre of gravity for selected 20 spots. Skip this if C NOREF is true C IF (.NOT.LIST) THEN LIST = .TRUE. CENTRAL = .TRUE. C C ***************************************************** CALL NEXT(LIST,IXSHIFT,IYSHIFT,PRECESS,MATCH,IFAIL, + PARTLS,ADDPP,CENTRAL) C ***************************************************** C END IF C C---- Sort fully recorded spots from generate file on scanner C coordinates prior to selection of refinement spots. Limits C reflections to area outside that used in 'centrs' (ie defined C by 'limit') C C---- If partials are to be used in SEEKRS, set MODE to 3 C MODE = 0 IF (USEPAR) MODE = 3 C IF (WINOPEN) CALL XDLF_FLUSH_EVENTS(I) C **************************************************** CALL GENSORT(MODE,FORCE,LIMIT,VLIM,NMR,ADDPP,PTMIN,LAST) C **************************************************** C FORCE = .FALSE. C C---- Test for no spots found in gensort, mode set to 999 C Go straight on to measurement. IF (MODE.EQ.999) THEN WRITE(IOUT,FMT=6051) IF (ONLINE) WRITE(ITOUT,FMT=6051) 6051 FORMAT(1X,'No spots found outside central region of', + ' image',/,1X,'(defined by REFINEMENT LIMIT key', + 'word) no additional refinement will be performed') IF (WINOPEN.AND.DISP_IO3) THEN WRITE(LINE,FMT=6053) 0.01*RMSRES,WRMSRES 6053 FORMAT('Rms residual',F6.2,'mm, weighted residual', + F6.1) CALL MXDWIO(LINE,22) END IF C C---- Save the direct beam coords, in case this is a multi-segment C post refinement, or if a POSTREF WIDTH run which might be repeated C because of a large cell shift C IF (IPACK.LE.NIMAX) THEN SVXCEN(IPACK) = XCEN SVYCEN(IPACK) = YCEN END IF GOTO 224 C AL C---- If this was the firstfilm, change pack number of first good film C AL C AL IF (FIRSTFILM) IFIRSTGOOD = IFIRSTGOOD + 1 C AL BADPACK(IPACK,IFILM) = .TRUE. C AL NWRN = NWRN + 1 C AL GO TO 250 END IF C C---- Search for refinement spots over whole of film C NRSOLD = NRS BADSTART = .FALSE. NRS = NRSOLD IF (BRIEF) WRITE (IBRIEF,FMT=6052) IF (ONLINE) WRITE (ITOUT,FMT=6052) 6052 FORMAT (/1X,'Refinement using reflections over entire', $ ' image',/) WRITE (IOUT,FMT=6052) OVRLDS = .FALSE. IF (USEOVR) OVRLDS = .TRUE. C IF (WINOPEN) CALL XDLF_FLUSH_EVENTS(I) C ******************************************** CALL SEEKRS(IRFMIN,IRFINC,IXSHIFT,IYSHIFT,OVRLDS, + ADDPP) C ******************************************** IF (WINOPEN) CALL XDLF_FLUSH_EVENTS(I) C FINAL = .FALSE. C C C C ****************************************** 190 CALL RDIST(CENTRE,FINAL,WELIMIT,ELIMIT,ELIMIT2,ELIMIT3, + BADSTART,RWEIGHT,REFREJ) C ****************************************** C IREP = 0 C C IF (IREP.EQ.0) GO TO 200 C C---- Repeat refinement using 'next' and existing list of reflections C IF (ONLINE) WRITE (ITOUT,FMT=6058) NRS WRITE (IOUT,FMT=6058) NRS LIST = .TRUE. CENTRAL = .FALSE. C C ***************************************************** CALL NEXT(LIST,IXSHIFT,IYSHIFT,PRECESS,MATCH,IFAIL, + PARTLS,ADDPP,CENTRAL) C C---- Repeat refinement using new spot positions from next C GO TO 190 C C---- Only allow one repeat due to poor C 200 IF (BADSTART) GO TO 220 C C---- Repeat refinement if either initial or final residuals too high C IF (RWEIGHT) THEN BADSTART = ((WESTART.GT.WELIMIT).OR. $ (WRMSRES.GT.WELIMIT)) ELSE BADSTART = ((ESTART.GT.ELIMIT2) .OR. $ (RMSRES.GT.ELIMIT3)) END IF IF (BADSTART) THEN C C---- Repeat refinement using 'next' and existing list of reflections C IF (RWEIGHT) THEN IF (ONLINE) WRITE (ITOUT,FMT=6060) WELIMIT 6060 FORMAT(/1X,'Repeat refinement because initial or ', + 'final residual is greater than ',F5.1) WRITE (IOUT,FMT=6060) WELIMIT ELSE IF (ONLINE) WRITE (ITOUT,FMT=6055) ELIMIT2,ELIMIT3 6055 FORMAT(/1X,'Repeat refinement because initial resi', + 'dual is greater than ',F5.1,' or final resid', $ 'ual greater than ',F5.1) WRITE (IOUT,FMT=6055) ELIMIT2,ELIMIT3 END IF LIST = .TRUE. CENTRAL = .FALSE. C C ***************************************************** CALL NEXT(LIST,IXSHIFT,IYSHIFT,PRECESS,MATCH,IFAIL, + PARTLS,ADDPP,CENTRAL) C ***************************************************** C C---- Repeat refinement using new spot positions from next C GO TO 190 END IF C GO TO 220 C C---- Measure refinement spots on 'B' or 'C' film in a pack C C *********************** 210 IF (FIRSTFILM) CALL RMAXR(LIMIT,THICK,IERR2) C *********************** C LIST = .FALSE. IF (USEPAR) PARTLS = .TRUE. CENTRAL = .FALSE. C C ***************************************************** CALL NEXT(LIST,IXSHIFT,IYSHIFT,PRECESS,MATCH,IFAIL, + PARTLS,ADDPP,CENTRAL) C ***************************************************** C PARTLS = .FALSE. C C---- If insufficient refinement spots found go on to next pack C IF (IFAIL.LT.0) THEN C C ************************************************** CALL SUMMERR(ISUMMR,ID,7,NFPACK(IPACK),NFGEN,FILM,IX,X) C ************************************************** C GO TO 250 END IF C C IF (ONLINE) WRITE (ITOUT,FMT=6052) WRITE (IOUT,FMT=6052) C C C ****************************************** CALL RDIST(CENTRE,FINAL,WELIMIT,ELIMIT,ELIMIT2,ELIMIT3, + BADSTART,RWEIGHT,REFREJ) C ****************************************** C C---- Only allow one repeat C IF (BADSTART) GO TO 220 IF (RWEIGHT) THEN BADSTART = ((WESTART.GT.WELIMIT).OR. $ (WRMSRES.GT.WELIMIT)) ELSE BADSTART = ((ESTART.GT.ELIMIT2) .OR. $ (RMSRES.GT.ELIMIT3)) END IF IF (BADSTART) GO TO 210 C C 220 CONTINUE C C---- Save the direct beam coords, in case this is a multi-segment C post refinement, or if a POSTREF WIDTH run which might be repeated C because of a large cell shift C IF (IPACK.LE.NIMAX) THEN SVXCEN(IPACK) = XCEN SVYCEN(IPACK) = YCEN END IF C C---- Test final residual C IF (RWEIGHT) THEN OKREF = (WRMSRES.LE.WRMSLIM) ELSE OKREF = (RMSRES.LE.RMSLIM) END IF IF (.NOT.OKREF) THEN IF (WINOPEN) THEN IXM = 200 IYM = 200 LINELEN = 75 NUMLIN = 9 C C Create IO window C CALL MXDCIO(0,LINELEN, NUMLIN, IXM,IYM) LINE = ' ' WRITE(LINE,FMT=6320) WRMSRES CALL MXDWIO(LINE,1) LINE = ' ' WRITE(LINE,FMT=6322) WRMSLIM CALL MXDWIO(LINE,1) LINE = ' ' WRITE(LINE,FMT=6324) CALL MXDWIO(LINE,1) LINE = ' ' 212 WRITE(LINE,FMT=6326) CALL MXDWIO(LINE, 1) CALL MXDRIO(LINE2) C C---- Parse reply C C ****************************************** CALL MPARSE(LINE2,IBEG,IEND,ITYP,VALUE,IDEC,NTOK) C ****************************************** IF (NTOK.EQ.0) THEN STR1 = 'Y' ELSE STR1 = LINE2(IBEG(1):IEND(1)) CALL CCPUPC(STR1) END IF IF (STR1.EQ.'Y') THEN C C---- Get max residual C LINE = ' ' WRMSLIM = 100.0 214 WRITE (LINE, 6328) WRMSLIM CALL MXDWIO(LINE, 0) CALL MXDRIO(LINE2) C C---- Get numbers using PARSER C C ****************************************** CALL MPARSE(LINE2,IBEG,IEND,ITYP,VALUE,IDEC,NTOK) C ****************************************** IF (NTOK.EQ.0) THEN CONTINUE ELSE CALL MKEYNM(1,1,LINE2,IBEG,IEND,ITYP,NTOK) IF (IOERR) GOTO 214 WRMSLIM = VALUE(1) END IF RMSLIM = WRMSLIM ELIMIT = WRMSLIM ELIMIT2 = WRMSLIM ELIMIT3 = WRMSLIM CALL MXDCIO(1,0,0,0,0) GOTO 216 ELSE C C---- Do NOT want to reset max residual C LINE = ' ' WRITE(LINE,FMT=6340) CALL MXDWIO(LINE, 1) CALL MXDRIO(LINE2) C C---- Parse reply C C ****************************************** CALL MPARSE(LINE2,IBEG,IEND,ITYP,VALUE,IDEC,NTOK) C ****************************************** IF (NTOK.EQ.0) THEN STR1 = 'Y' ELSE STR1 = LINE2(IBEG(1):IEND(1)) CALL CCPUPC(STR1) END IF IF (STR1.EQ.'Y') THEN C C--- ABANDON C CALL MRESET(ISEG,RPTFIRST,GENOPEN,COORDOPN) IF (DISPMENU) THEN GOTO 34 ELSE GOTO 30 END IF ELSE C C---- Repeat query C GOTO 212 END IF END IF C ELSE IF (RWEIGHT) THEN IF (BRIEF) WRITE (IBRIEF,FMT=6045) WRMSRES,WRMSLIM IF (ONLINE) WRITE (ITOUT,FMT=6045) WRMSRES,WRMSLIM WRITE (IOUT,FMT=6045) WRMSRES,WRMSLIM ELSE IF (BRIEF) WRITE (IBRIEF,FMT=6044) RMSRES,RMSLIM IF (ONLINE) WRITE (ITOUT,FMT=6044) RMSRES,RMSLIM WRITE (IOUT,FMT=6044) RMSRES,RMSLIM END IF END IF C C---- If this was the firstfilm, change pack number of first good film C IF (FIRSTFILM) IFIRSTGOOD = IFIRSTGOOD + 1 BADPACK(IPACK,IFILM) = .TRUE. NWRN = NWRN + 1 C C C---- If this is a multi-segment refinement, abandon it. C IF (MULTISEG) THEN WRITE(IOUT,FMT=6212) IF (ONLINE) WRITE(ITOUT,FMT=6212) STOP END IF C IF (FIRSTPASS) THEN NERR(IPACK) = 8 XERR(IPACK) = RMSRES ELSE C C ************************************************ CALL SUMMERR(ISUMMR,ID,8,NFPACK(IPACK),NFGEN,FILM,IX, + RMSRES) C ************************************************ C END IF C C GO TO 250 END IF C C---- Sort all reflexions (fulls and partials) in generate file C C---- First check box size after final refinement C C **************************** 216 IF (FIRSTFILM) THEN CALL RMAXR(LIMIT,THICK,IERR2) IF ((IERR2.EQ.1).AND.DISPMENU) THEN WRITE(LINE,FMT=6208) IRAS(1),IRAS(2) L = LENSTR(LINE) IXP = 400 IYP = 400 CALL XDLF_POPUP_NOTICE(IXP,IYP, XDLSTR(LINE),L, + XDLSTR(' '),0,XDLSTR('OK'),2,XDLSTR(' '), + -1,3,0,IBUTTON) END IF IF (IERR2.EQ.2) THEN IF (DISPMENU) THEN C C---- If running interactively, trap measurement box being too big C CALL MRESET(ISEG,RPTFIRST,GENOPEN,COORDOPN) GOTO 34 ELSE CALL SHUTDOWN END IF END IF END IF C **************************** C IF (DEBUG(1)) THEN IF (ONLINE) WRITE (ITOUT,FMT=6062) MAXR,IRAS 6062 FORMAT (/1X,'At end of refinement, MAXR from RMAXR ',I6, + /1X,'IRAS',5I4) WRITE (IOUT,FMT=6062) MAXR,IRAS END IF C C---- Replot image if requested. Always replot if SEPARATION was not C given explicitly and this is the first image because SEPARATION C will have been updated in CHKRAS and number of overlaps may have C changed. C 224 IF ((LPREF).OR.(FILMPLT.AND.FIRSTFILM.AND.(ISEP.NE.2))) $ THEN MODEDISP = 4 CALL XDISP(MODEDISP,FIRSTPACK,PACK,IFIRSTPACK, + FIRSTFILM,GENOPEN) IF (MODEDISP.EQ.99) THEN C C---- Abort current run C CALL MRESET(ISEG,RPTFIRST,GENOPEN,COORDOPN) IF (DISPMENU) THEN GOTO 34 ELSE GOTO 30 END IF END IF END IF C C C---- If using interactive display, write the generate file now C Also write it if we want all reflections (including spatial C overlaps) written to output MTZ file. C IF ((FILMPLT.AND.(.NOT.MATCH)).OR.ALLOUT) THEN WRITE(ITOUT,FMT=6200) 6200 FORMAT(/,1X,'Generating new reflection list') MODEG = 3 CALL GENERATE(MODEG,ID,GWRITE,UPDATE,LIMIT,POSTREF, + NEWPREF,NFGEN,LOVERLAP,NFULLF) C **************************************** C---- Store the pack header record number for this image. Note that NFILMS C has not yet been incremented, so use NFILMS+1 as pointer C IPACKSTART(NFILMS+1) = IPACKHEAD END IF C IF (WINOPEN) CALL XDLF_FLUSH_EVENTS(I) C AL IF (NOMEAS) CALL SHUTDOWN MODE = 1 C C---- If summing partials over adjacent images, set MODE = 4 C otherwise if doing post-refinement, set MODE = 5. C Set LAST true if the is the last image in a run processed C with POSTREF or ADDPART ADDPP = ADDP(IPACK) C LAST = ((IPACK.EQ.NPACKSAVE).AND.(ADDPART.OR.POSTREF)) IF (ADDPART) THEN MODE = 4 ELSE IF (SUMPART) THEN MODE = 5 END IF C IF (NEWPREF) MODE = 1 C FORCE = (PRBFILM.AND.FILM.EQ.2.OR.PRCFILM.AND.FILM.EQ.3) C C **************************************************** CALL GENSORT(MODE,FORCE,LIMIT,VLIM,NMR,ADDPART,PTMIN,LAST) C **************************************************** IF (WINOPEN) CALL XDLF_FLUSH_EVENTS(I) C FORCE = .FALSE. C C---- Select optical densities for all reflections in file. C if not using profile fitting, extract integrated intensity C etc for each spot once all its ods have been collected. C C C---- If refining (cell), orientation using postrefinement, initialise C by calling POSTREFL with MODE=0. Have to test SUMPART as well, C because for the last image of a series there will be no C information to refine orientation C IF (POSTREF.AND.(SUMPART.OR.NEWPREF)) THEN MODE = 0 MODE2(1) = 0 MODE2(2) = 0 C C---- If this is the very first pack, set MODE negative so that NIMAG is set C to zero in POSTREFL (can't use FIRSTPACK as it C is incremented when C using blocks of data) C IF (IPACK.EQ.IFIRSTP) THEN MODE = -1 MODE2(1) = -1 MODE2(2) = -1 ENDIF C C---- initialize C CALL POSTREFL(MODE,MODE2,MODE2,TEMP,RESID,RETA,RDIVH, + RDIVV,FIXED,ISTAT,LASTREC,NEWPREF,iseg,MULTISEG) END IF C C---- Keep track of number of images written by MEAS to SPOTOD. If an image C is repeated as a result of a large shift in postrefinement, then C PROCESS must skip the redundant image from SPOTOD C NOWRITE = NOWRITE + 1 ISKIPI(NOWRITE) = 0 C IF (WINOPEN) CALL XDLF_FLUSH_EVENTS(I) IF (WINOPEN) THEN CALL MXDBSY(-1, ' ') CALL XDLF_FLUSH_EVENTS(I) CALL MXDBSY(0, $ 'Writing measurement boxes to scratch file') END IF C C ******************************************************* CALL MEAS(MAXR,PROFILE,INTERPOL,IXSHIFT,IYSHIFT, + ADDPP,POSTREF,ID+ISERADD,MULTISEG,LASTREC,NEWPREF) C ******************************************************* C C---- Reflections to be used for postrefinement have been accumulated in C MEAS. Now call POSTREFL again to actually do the refinement. C Note that if adding data from several images, refinement only C starts once NADD images have been processed C If doing NEWPREF mode, don't attempt to do refinement for the C first image C IF (POSTREF.AND.(SUMPART.OR. + (NEWPREF.AND.(IPACK.NE.IFIRSTPSEG)))) THEN MODE = -999 IF (WINOPEN) THEN CALL MXDBSY(-1, ' ') CALL XDLF_FLUSH_EVENTS(I) CALL MXDBSY(0,'Doing post-refinement') CALL XDLF_FLUSH_EVENTS(I) END IF MODE2(1) = ID MODE2(2) = IPACK CALL POSTREFL(MODE,MODE2,MODE2,TEMP,RESID,RETA,RDIVH, + RDIVV,FIXED,ISTAT,LASTREC,NEWPREF,ISEG,MULTISEG) C C---- Check for error return (singular equations etc). C IF (ISTAT.NE.0) THEN IF (DISPMENU) THEN C C---- If running interactively, trap failure of postrefinement C CALL MRESET(ISEG,RPTFIRST,GENOPEN,COORDOPN) GOTO 34 ELSE CALL SHUTDOWN END IF END IF C IF (WINOPEN) THEN CALL XDLF_FLUSH_EVENTS(I) CALL MXDBSY(-1, ' ') END IF IF ((RESID.GT.RESIDMAX).OR.(FRCSHIFT.GT.0.10)) THEN IF (RESID.GT.RESIDMAX) THEN WRITE(IOUT,FMT=6061) RESID,RESIDMAX IF (ONLINE) WRITE(ITOUT,FMT=6061) RESID,RESIDMAX IF (BRIEF) WRITE(IBRIEF,FMT=6061) RESID,RESIDMAX END IF IF (FRCSHIFT.GT.0.10) THEN WRITE(IOUT,FMT=6130) IF (ONLINE) WRITE(ITOUT,FMT=6130) END IF 6130 FORMAT(//1X,'***** FATAL ERROR ****',/,1X,'One or ', + 'more cell parameters has changed by more ', $ 'than 10%.',/,1X,'This means the refinement i', $ 's unstable. Try using more images.') 6061 FORMAT(//1X,'***** FATAL ERROR ****',1X,'Refinement', + ' residual from POSTCHK is',F6.3,' which is gr', $ 'eater than',/,1X,'maximum allowed value of', + F6.3,' (subkeyword MAXRESID on POSTREF keyword', $ ').',/,1X,'Processing stopped.',/,1X, + 'Check that you are using a sensible value of ', + 'the mosaic spread/beam divergence',/,1X, $ 'by predicting the pattern and checking (using', + ' the X-window graphics)',/,1X, + 'that you are predicting all observed spots.') C WRITE(ISUMMR,FMT=6059) ID,RESID,RESIDMAX 6059 FORMAT(/1X,'The post-refinement residual for pack',I4, + ' is',F6.3,' which exceeds maximum allowed valu', $ 'e of',F6.3,' (set using POSTREF MAXRESID)',/,1X, + 'Check that you are using a sensible value of t', + 'he mosaic spread/beam divergence',/,1X,'by pre', $ 'dicting the pattern and checking (using the X', + '-window graphics)',/,1X, + 'that you are predicting all observed spots.') IF (DISPMENU) THEN C C---- Abort current run C CALL MRESET(ISEG,RPTFIRST,GENOPEN,COORDOPN) GOTO 34 END IF CALL SHUTDOWN END IF C C---- Test for negative (mosaic spread + divergence) C IF (((RETA+RDIVH).LT.0.0).OR.((RETA+RDIVV).LT.0.0)) THEN WARN(16) = .TRUE. PRNEGM(NFILMS+1) = .TRUE. WRITE(IOUT,FMT=6110) IF (ONLINE) WRITE(ITOUT,FMT=6110) 6110 FORMAT(/1X,'***** WARNING ****',/,1X,'The refined ', + 'mosaic spread plus beam divergence is negati', + 've',/,1X,'This may be indicative of a large ', + 'crystal slippage or the input oscillation an', $ 'gle might be wrong',/) IF (USEBEAM) THEN IF (PRNS.EQ.1) THEN WRITE(IOUT,FMT=6112) IF (ONLINE) WRITE(ITOUT,FMT=6112) 6112 FORMAT(1X,'The mosaic spread has been set to ', + '0.05',/,1X,'It may be advisable NOT to ', + 'use the refined beam parameters (remov', $ 'e USEBEAM keyword)') ETA = 0.5*DTOR*0.05 ELSE IF (PRNS.EQ.2) THEN IF (RDIVH.LT.0.0) THEN DIVH = 0.5*DTOR*0.05 WRITE(IOUT,FMT=6114) IF (ONLINE) WRITE(ITOUT,FMT=6114) 6114 FORMAT(1X,'The horizontal divergence has b', + 'een reset to 0.05',/,1X,'It may be a', + 'dvisable NOT to use the refined beam', + ' parameters (remove USEBEAM keyword)') END IF IF (RDIVV.LT.0.0) THEN DIVV = 0.5*DTOR*0.05 WRITE(IOUT,FMT=6116) IF (ONLINE) WRITE(ITOUT,FMT=6116) 6116 FORMAT(1X,'The vertical divergence has ', + 'been reset to 0.05',/,1X,'It may ', + 'be advisable NOT to use the refin', + 'ed beam parameters (remove USEBE', $ 'AM keyword)') END IF END IF END IF END IF C C---- Test for large difference between input and refined mosaic spread C or beam divergence. C IF (PRNS.EQ.1) THEN WARN(19) = (WARN(19).OR. + (ABS(RETA-2.0*SETA).GT.0.1*2.0*SETA)) ELSE IF (PRNS.EQ.2) THEN WARN(19) = (WARN(19).OR. + (ABS(RDIVH-2.0*SDIVH).GT.0.1*2.0*SDIVH) + .OR.(ABS(RDIVV-2.0*SDIVV).GT.0.1*2.0*SDIVV)) END IF PRF(NFILMS+1) = .TRUE. C C---- Since we have now done a post-refinement, set UMATCELL(1) to zero C so that it does not check for inconsistency due to a different C wavelength being used when deriving the AMATRIX to the integration run. C UMATCELL(1) = 0.0 C C C---- Test orientation shifts. Need shift to be greater than SHIFTMAX C AND also greater than SHIFTFAC*SD to be treated as a large shift. C BIGSHIFT = .FALSE. RPTIMG = .FALSE. C C---- If not using "fixed" mode, where all images are constrained to have C the same missets, there are only 2 refined angles and sds (PSIY,PSIZ) C so change setup of SDDELPHI C DO 226 I = 1,3 SDMISS = SDDELPHI(I) IF (.NOT.FIXED) THEN IF (I.EQ.2) SDMISS = SDDELPHI(1) IF (I.EQ.3) SDMISS = SDDELPHI(2) END IF IF ((ABS(SHIFT(I)).GT.SHIFTMAX).AND. + (ABS(SHIFT(I)).GT.SHIFTFAC*SDMISS)) $ BIGSHIFT=.TRUE. 226 CONTINUE C IF (DEBUG(1)) THEN WRITE(IOUT,FMT=6118) NADD,IPACK,NADDMISSET, + (SHIFT(I),I=1,3), + (SHIFTFAC*SDDELPHI(I),I=1,3),SHIFTMAX,BIGSHIFT IF (ONLINE) WRITE(ITOUT,FMT=6118) NADD,IPACK, + NADDMISSET,(SHIFT(I),I=1,3), + (SHIFTFAC*SDDELPHI(I),I=1,3),SHIFTMAX,BIGSHIFT 6118 FORMAT(1X,'NADD=',I4,' IPACK=',I4,' NADDMISSET=',I4, + ' Shift in', + ' missets',3F7.3,/,1X,'Shiftfac*sd(delphi)', + 3F7.3,/,1X,'Max allowed shift before repeat', + F7.3,' Logical bigshift is ',L1) IF (NEWPREF) THEN CONTINUE ELSE WRITE(IOUT,FMT=6119) (DELPHIV(I),I=1,3*NADD) IF (ONLINE) WRITE(ITOUT,FMT=6119) $ (DELPHIV(I),I=1,3*NADD) 6119 FORMAT(1X,'Values in DELPHIV',/,(1X,3F10.3)) END IF END IF C C---- Single image case, or initial images (up to NADD) of multiple C image case (flagged by setting MODE=-990 in postrefl) C--- I think this should be Ok to repeat an image even after NADD have C been processed in "width" mode...lets try and see. C---- Special case. If using a block of images to refine (NADD) and this C is the NADD'th image, then we must first test for a large shift in C cell parameters because if this has happened we want to repeat C processing of the whole block of data and not just the current C image. Note that when using "NEWPREF" refinement, the condition is C that this is the NADD+1'th image rather than NADD'th C IF ((NADD.GT.1) .AND. + (((IPACK.EQ.NADD).AND.(.NOT.NEWPREF)) .OR. + ((IPACK.EQ.NADD+NSEG).AND.NEWPREF)) .AND. + (CELLSHIFT.GT.SHIFTFAC))GOTO 228 C C---- Do the same if this is a multisegment post-refinement C IF (MULTISEG.AND.(CELLSHIFT.GT.SHIFTFAC)) GOTO 228 C C--- Test for large shifts C IF ((BIGSHIFT).OR. + ((NADD.EQ.1).AND.(CELLSHIFT.GT.SHIFTFAC))) THEN C C---- First deal with orientation shift C IF (BIGSHIFT) THEN WRITE(IOUT,FMT=6063)SHIFTMAX,SHIFTFAC IF (ONLINE) WRITE(ITOUT,FMT=6063) + SHIFTMAX,SHIFTFAC IF (BRIEF) WRITE(IBRIEF,FMT=6063) + SHIFTMAX,SHIFTFAC 6063 FORMAT(//1X,'***** shift in one or more missett', + 'ing angles exceeds limit of',F6.3,' degree', + 's or',F5.2,' standard deviations *****',/, + 1X,' Repeat measurement of this image using', + ' refined missetting angles') PRFRPT1(NFILMS+1) = .TRUE. END IF C C---- Now deal with cell shift C IF (CELLSHIFT.GT.SHIFTFAC) THEN WRITE(IOUT,FMT=6065) CELLSHIFT,SHIFTFAC IF (ONLINE) WRITE(ITOUT,FMT=6065) CELLSHIFT, $ SHIFTFAC IF (BRIEF) WRITE(IBRIEF,FMT=6065) CELLSHIFT, $ SHIFTFAC 6065 FORMAT(//,1X,'***** Cell parameter shift (',F5.1, + ' sds) exceeds limit of',F5.1,' sds *****', + /,1X,'Repeat measurement of this image') PRFRPT2(NFILMS+1) = .TRUE. END IF C C---- If in NEWPREF mode, want to go back to the first image, not just C repeat measurement of the second one ! C IF ((.NOT.NEWPREF).OR.(NEWPREF.AND. + (IPACK.GT.(2*NVIRBAT)))) THEN C C---- Need to trap oscillating missetting angles, which would result C in repeating this image indefinately. C IF (IPACK.EQ.IRPTPACK) THEN NSINGRPT = NSINGRPT + 1 C C---- Check shifts against those in previous round C BIGSHIFT = .FALSE. DO 229 I = 1,3 IF ((ABS(SHIFT(I)+RPTSHIFT(I,NSINGRPT-1)).GT. + SHIFTMAX).AND. + (ABS(SHIFT(I)+RPTSHIFT(I,NSINGRPT-1)) + .GT.SHIFTFAC*SDMISS)) BIGSHIFT = .TRUE. 229 CONTINUE C C---- Do not repeat image if shifts are oscillating C IF (.NOT.BIGSHIFT) THEN WRITE(IOUT,FMT=6412) IF (ONLINE) WRITE(ITOUT,FMT=6412) 6412 FORMAT(//,1X,'*** Missets are oscillating ***', + /,1X,'Going on to the next image.') PRFRPT1(NFILMS+1) = .FALSE. GOTO 232 END IF C C---- Do not allow more than 5 repeats anyway C IF (NSINGRPT.GT.5) THEN WRITE(IOUT,FMT=6410) IF (ONLINE) WRITE(ITOUT,FMT=6410) 6410 FORMAT(//,1X,'***** TOO MANY REPEATS *****',/, + 1X,'Check orientation. Going on to the', + ' next image.') PRFRPT1(NFILMS+1) = .FALSE. GOTO 232 END IF ELSE IRPTPACK = IPACK NSINGRPT = 1 DO 227 I = 1,3 RPTSHIFT(I,1) = SHIFT(I) 227 CONTINUE END IF C C---- Only set flag to skip an image in SPOTOD if accumulating profiles C because if not, then SPOTOD is rewound by MEAS, so the second C pass on the image will overwrite the first in SPOTOD IF (FIRSTPASS) ISKIPI(NOWRITE) = 1 DOPROFILE = .FALSE. C C---- Reset AVPROFILE as this was set false in CHKRAS C AVPROFILE = AVPROF(IPACK) C C---- Position generate file to write pack header C C ******************************* CALL QSEEK(IUNIT,IPACKHEAD,1,36) C ******************************* IPACKREC = IPACKHEAD RPTIMG = .TRUE. GOTO 85 C C---- Restart C ELSE NFRPT = NFRPT + 1 IF (NFRPT.LE.5) THEN WRITE(IOUT,FMT=6351) IF (ONLINE) WRITE(ITOUT,FMT=6351) 6351 FORMAT(/,1X,'*** As this is near to the start, ' + ,'repeat integration from the first image ***') ELSE WRITE(IOUT,FMT=6352) IF (ONLINE) WRITE(ITOUT,FMT=6352) 6352 FORMAT(/,1X,'*** Too many repeats ***',/,1X, + 'Go on to the next image.') GOTO 232 END IF SHIFT(1) = 0.0 SHIFT(2) = 0.0 SHIFT(3) = 0.0 CELLSHIFT = 0.0 IF ((ISEG.EQ.1).AND.(NREPEAT.EQ.0)) THEN NFILMS = 0 ELSE NFILMS = NFILMS - (IPACK - IFIRSTPACK) END IF CAL IF (MULTISEG) THEN CAL NFILMS = NREPEAT*LASTFILM(NSEG) CAL IF (ISEG.GT.1) NFILMS = NFILMS + LASTFILM(ISEG-1) CAL ELSE CAL NFILMS = 0 CAL END IF NOWRITE = 0 C C---- Need to reset NIMAG in POSTREFL if not the first segment, C and also adjust PHIIM and IDLAST C IF (ISEG.GT.1) THEN MODE = -9999 MODE2(1) = IPACK - IFIRSTPACK CALL POSTREFL(MODE,MODE2,MODE2,TEMP,RESID,RETA, + RDIVH,RDIVV,FIXED,ISTAT,LASTREC, + NEWPREF,ISEG,MULTISEG) END IF IFIRSTGOOD = IFIRSTPACK IF (NBLOCK.NE.0) THEN IFIRSTPACK = IFIRSTPACK - NUMBLOCK*NBLOCK NPACK = 0 END IF C C---- Initialisation flags for FINDPACK, OPENODS and reposition C generate file C MODEOP = 1 C ******************** CALL QSEEK(IUNIT,21,1,36) C ******************** C JPACK = 0 IPACKREC = 21 IPACKHEAD = 21 C C---- Close the current image file. Note is is opened with DISKIO C under Unix, Fortran under VMS, but if packed the file has already C been closed. C C HRP IF (VAXVMS()) THEN C ************* C AL CLOSE (UNIT=INOD) C ************* C HRP ELSE C ***************************** C AL IF (.NOT.PACK) CALL QCLOSE(INOD) C ***************************** C HRP END IF C C---- Rewind SPOTOD file (contains measurement boxes) C REWIND(INMO) IF (DENSE) REWIND(ICOORD) IF (DEBUG(1)) THEN WRITE(IOUT,FMT=6350) IFIRSTPACK,NUMBLOCK,NBLOCK IF (ONLINE) WRITE(ITOUT,FMT=6350) IFIRSTPACK, + NUMBLOCK,NBLOCK 6350 FORMAT(1X,'RESTART, IFIRSTPACK reset to',I5, + ' NUMBLOCK, NBLOCK',2I5) END IF C C---- Reset NUMBLOCK C NUMBLOCK = 0 C C---- Call MODARRAY for statistics for this image, then to clear arrays. INTDUM(1) = 0 INTDUM(2) = 0 CALL MODARRAY(1, 0.0, 0,0,INTDUM,INTDUM) CALL MODARRAY(0,0.0,0,0,INTDUM,INTDUM) GOTO 35 END IF END IF C C---- Multiple image case C Only repeat measurement if this is the FIRST postrefinement and C in this case remeasure the first NADD packs again, up to a total C of NRPT repeats. Note that in NEWPREF mode we need to process C the first NADD+1 packs again. C Otherwise just print a warning message C 228 IF (MULTISEG.OR. + ((IPACK.EQ.NADD).AND.(.NOT.NEWPREF)).OR. + ((IPACK.EQ.NADD+NSEG).AND.NEWPREF)) THEN C C---- This is the first postref for a "width" case or any image in C a "single" case. Tests on cell shifts...no test on C orientation required because it is tested for each image. C IF (CELLSHIFT.GT.SHIFTFAC) THEN IF (MULTISEG) THEN WRITE(IOUT,FMT=6168) CELLSHIFT,SHIFTFAC IF (ONLINE) WRITE(ITOUT,FMT=6168) CELLSHIFT, $ SHIFTFAC IF (BRIEF) WRITE(IBRIEF,FMT=6168) CELLSHIFT, $ SHIFTFAC ELSE NADDP = NADD IF (NEWPREF) NADDP = NADDP + 1 WRITE(IOUT,FMT=6167) CELLSHIFT,SHIFTFAC,NADDP IF (ONLINE) WRITE(ITOUT,FMT=6167) CELLSHIFT, $ SHIFTFAC, + NADDP IF (BRIEF) WRITE(IBRIEF,FMT=6167) CELLSHIFT, $ SHIFTFAC, + NADDP END IF 6167 FORMAT(//,1X,'***** Cell parameter shift (',F5.1, + ' sds) exceeds limit of',F5.1,' sds *****', + /,1X,'Repeat measurement of first',I3, $ ' images') 6168 FORMAT(//,1X,'***** Cell parameter shift (',F5.1, $ ' sds) exceeds limit of',F5.1,' sds *****', $ /,1X,'Repeating the entire run, using the ', + 'refined cell parameters as given above') C C AL IF (NADD.GT.1) NREPEAT = NREPEAT + 1 IF (MULTISEG.OR.(NADD.GT.1)) NREPEAT = NREPEAT + 1 C C---- Write the matrix anyway C WRITE(IOUT,FMT=6302) NEWMATNAM(1:LENSTR(NEWMATNAM)) IF (ONLINE) WRITE(ITOUT,FMT=6302) + NEWMATNAM(1:LENSTR(NEWMATNAM)) 6302 FORMAT(/1X,'New orientation matrix written to', + ' (keyword NEWMAT): ',A,/,1X, + 'The missetting angles in this file are the', + ' refined missets for the FIRST image',/,1X, + 'in the post-refinement.') CALL CCPDPN (12,NEWMATNAM,'UNKNOWN','F',80,IFAIL) WRITE(12,FMT=6300) ((AMAT(I,J),J=1,3),I=1,3), + (DELPHIV(J),J=1,3), + ((UMAT(I,J),J=1,3),I=1,3),CELL, + (DELPHIV(J),J=1,3) 6300 FORMAT(3(3F12.8/),(3F12.3/),3(3F12.8/),6F12.4,/, $ 3F12.4) CLOSE (UNIT=12) IF (DISPMENU) THEN SAVMATSTR = 'postrefinement' END IF C C---- Trap too many repeats of entire run C IF (NREPEAT.GT.NRPT) THEN WRITE(IOUT,FMT=6073) NRPT IF (ONLINE) WRITE(ITOUT,FMT=6073) NRPT IF (BRIEF) WRITE(IBRIEF,FMT=6073) NRPT 6073 FORMAT(//,1X,'****** Only',I3,' repeats allow', + 'ed ***** Processing will be aborted',/, + 1X,'Check if the refinement is unstable', + ', and if so increase the number of imag', $ 'es used',/,1X,'(keywords ADD or WIDTH ', + 'on POSTREF keyword)',/,1X, + 'The number of repeats can be changed ', + 'with keyword REPEAT under POSTREF') C IF (MULTISEG) THEN C C---- Abort current run C PRFINISH = .TRUE. GOTO 230 END IF END IF C C---- If this is a postref segment run, start again by calling CONTROL C In this case the generate file is closed in CONTROL. C IF (MULTISEG) THEN RPTFIRST = .TRUE. FIRSTTIME = .TRUE. ISEG = 0 PRFINISH = .TRUE. SHIFT(1) = 0.0 SHIFT(2) = 0.0 SHIFT(3) = 0.0 GOTO 230 END IF C C C---- Restart C SHIFT(1) = 0.0 SHIFT(2) = 0.0 SHIFT(3) = 0.0 CELLSHIFT = 0.0 NFILMS = 0 NOWRITE = 0 IFIRSTGOOD = IFIRSTPACK IF (NBLOCK.NE.0) THEN IFIRSTPACK = IFIRSTPACK - NUMBLOCK*NBLOCK NPACK = 0 END IF C C---- Initialisation flags for FINDPACK, OPENODS and reposition C generate file C MODEOP = 1 C ******************** CALL QSEEK(IUNIT,21,1,36) C ******************** C JPACK = 0 IPACKREC = 21 IPACKHEAD = 21 C C---- If the BLOCK size is less than the WIDTH, some images will have been C integrated and written to MTZ file when the post-refinement is done. C In this case, need to close and re-open the MTZ file C IF (NBLOCK.LT.NADD) THEN IF (MTZOPEN) THEN MTZPRT = 0 C ********************* CALL LWCLOS(MTZOUT,MTZPRT) C ********************* CALL STARTMTZ NLSUM1 = 0 NLSUM2 = 0 END IF END IF C C---- Close the current image file. Note is is opened with DISKIO C under Unix, Fortran under VMS, but if packed the file has already C been closed. C IF (VAXVMS()) THEN C ************* C AL CLOSE (UNIT=INOD) C ************* ELSE C ***************************** C AL IF (.NOT.PACK) CALL QCLOSE(INOD) C ***************************** END IF C C C---- Rewind SPOTOD file (contains measurement boxes) C REWIND(INMO) IF (DENSE) REWIND(ICOORD) IF (DEBUG(1)) THEN WRITE(IOUT,FMT=6350) IFIRSTPACK,NUMBLOCK, $ NBLOCK IF (ONLINE) WRITE(ITOUT,FMT=6350) IFIRSTPACK, + NUMBLOCK,NBLOCK WRITE(IOUT,FMT=6119) (DELPHIV(I),I=1,3*NADD) IF (ONLINE)WRITE(ITOUT,FMT=6119)(DELPHIV(I), $ I=1,3*NADD) END IF C C---- Reset NUMBLOCK C NUMBLOCK = 0 C C---- Reinitialize arrays if doing NEWPREF C IF (NEWPREF) THEN C C---- Call MODARRAY for statistics for this image, then to clear arrays. INTDUM(1) = 0 INTDUM(2) = 0 CALL MODARRAY(1, 0.0, 0,0,INTDUM,INTDUM) CALL MODARRAY(0,0.0,0,0,INTDUM,INTDUM) END IF GOTO 35 END IF ELSE C C---- Not the first post-refinement, give warning if shift large but C do not repeat IF ((BIGSHIFT).OR.(CELLSHIFT.GT.SHIFTFAC)) THEN WRITE(IOUT,FMT=6069) SHIFTMAX,SHIFTFAC IF (ONLINE) WRITE(ITOUT,FMT=6069) SHIFTMAX, $ SHIFTFAC IF (BRIEF) WRITE(IBRIEF,FMT=6069) SHIFTMAX, $ SHIFTFAC 6069 FORMAT(/,1X,'***** WARNING *****',/,1X,'Shift', + ' in missetting angles exceeds',F6.3, + ' degrees',/,1X,'or cell parameter shift', + ' exceeds',F5.1,' sds',/,1X,'Consider us', + 'ing a smaller angular width (WIDTH or A', $ 'DD) if crystal is slipping',/,1X,'or ', + 'a larger angular width if refinement is', $ ' unstable') PRFHS(NFILMS+1) = .TRUE. END IF END IF C END IF C---- Above is end of IF (POSTREF.AND.SUMPART) block C C C---- If this is a multi-segment post-refinement run, stop once refinement is C complete for the last pack C 232 IF (MULTISEG.AND.(ISEG.EQ.NSEG).AND. + (((IPACK.EQ.NPACK-1).AND.(.NOT.NEWPREF)).OR. + ((IPACK.EQ.NPACK).AND.NEWPREF))) THEN C C---- Write new orientation matrix C WRITE(IOUT,FMT=6302) NEWMATNAM(1:LENSTR(NEWMATNAM)) IF (ONLINE) WRITE(ITOUT,FMT=6302) + NEWMATNAM(1:LENSTR(NEWMATNAM)) CALL CCPDPN (12,NEWMATNAM,'UNKNOWN','F',80,IFAIL) WRITE(12,FMT=6300) ((AMAT(I,J),J=1,3),I=1,3), + (DELPHIV(J),J=1,3), + ((UMAT(I,J),J=1,3),I=1,3),CELL, + (DELPHIV(J),J=1,3) CLOSE (UNIT=12) IF (DISPMENU) THEN SAVMATSTR = 'postrefinement' END IF PRFINISH = .TRUE. GOTO 230 CAL CALL MRESET(ISEG,RPTFIRST,GENOPEN,COORDOPN) CAL IF (DISPMENU) THEN CAL GOTO 34 CAL ELSE CALC HRP01122000 for background processing if following multiseg postrefinement CALC with integration run CALC CAL NEWGENF = .TRUE. CALc FIRSTTIME = .TRUE. CAL CALL STARTMTZ CALC HRP01122000 for background processing CAL GOTO 30 CAL END IF END IF C IF (DEBUG(1)) THEN IF (ONLINE) WRITE (ITOUT,FMT=6064) MAXR,NOWRITE, + ISKIPI(NOWRITE),IRAS 6064 FORMAT (/1X,'After calling MEAS,MAXR= ',I6,' NOWRITE=', + I3,' ISKIPI',I3,/1X,'IRAS',5I4) WRITE (IOUT,FMT=6064) MAXR,NOWRITE,ISKIPI(NOWRITE),IRAS END IF C IF (FIRSTPASS) THEN C C---- Write refined camera constants back to generate file C MODEWR = 1 C C **************************** CALL WRGEN(MODEWR,PROFILE,ADDPP) C **************************** C MODEWR = 0 C C---- If DENSE, (many close spots) write a list of spot coordinates, sorted C on scanner X coordinate, to a file (written from GENSORT) C IF (DENSE) THEN MODE = -2 IF (NEWPREF.AND.LAST) LAST = .FALSE. C **************************************************** CALL GENSORT(MODE,FORCE,LIMIT,VLIM,NMR,ADDPART, $ PTMIN,LAST) C **************************************************** IF (DEBUG(1))THEN WRITE(IOUT,FMT=6220) IF (ONLINE) WRITE(ITOUT,FMT=6220) 6220 FORMAT(1X,'Spot coordinates written to COORDS ', $ 'file') END IF END IF GO TO 230 END IF C C----- If not integrating the image, skip call to PROCESS C IF (NOMEAS) GOTO 230 C C---- Process the measurements for each spot if in profile mode C unless in second pass of accumulated profile processing C IF (PROFILE) THEN C C ADDPP = ADDP(IPACK) C C ****************************************** CALL PROCESS(NFLMO,IXSHIFT,IYSHIFT,ADDPP,ISKIPI, + LPINTG,NEWPREF,LPINTG,NOBACK) C ****************************************** C C---- Display residual vectors if requested C IF (LPINTG) THEN C C---- Need to set flag to repredict the pattern C MODEDISP = 5 CALL XDISP(MODEDISP,FIRSTPACK,PACK,IFIRSTPACK, + FIRSTFILM,GENOPEN) IF (MODEDISP.EQ.99) THEN C C---- Abort current run C CALL MRESET(ISEG,RPTFIRST,GENOPEN,COORDOPN) IF (DISPMENU) THEN GOTO 34 ELSE GOTO 30 END IF END IF END IF C C IF (.NOT.SECONDPASS) THEN REWIND INMO IF (DENSE) REWIND ICOORD END IF END IF C C---- Write summary information C 230 ICTF = NINT(XTOFRA*XTOFD) ITILT = TILT/FDIST ITWIST = TWIST/FDIST IF (IMGP) THEN IROFF = NINT(ROFF) C AL IROFF2 = NINT(ROFF2) ITOFF = NINT(TOFF) ELSE IBULGE = BULGE/FDIST END IF C C IF (.NOT.FIRSTPASS) THEN C C---- Store maximum shifts in ROFF,TOFF,CCOMEGA, number bad spots,weighted C residual etc C IF (ROFFSAVE.GT.-998.0) THEN ROFFMAX = MAX(ROFFMAX,ABS(0.01*IROFF - ROFFSAVE)) TOFFMAX = MAX(TOFFMAX,ABS(0.01*ITOFF - TOFFSAVE)) X = CCOM-CCOMSAVE IF (X.GT.180) X = X - 360.0 IF (X.LT.-180) X = X + 360.0 CCOMAX = MAX(CCOMAX,ABS(X)) END IF WRMAX = MAX(WRMAX,WRMSRES) NBADMAX = MAX(NBADMAX,NBAD) AVBGRMAX = MAX(AVBGRMAX,AVBGRATIO) AVBGRMIN = MIN(AVBGRMIN,AVBGRATIO) ROFFSAVE = 0.01*IROFF TOFFSAVE = 0.01*ITOFF CCOMSAVE = CCOM IF (IMGP) THEN WRITE (ISUMMR,FMT=6067) ID,0.01*CCX,0.01*CCY,CCOM, + 0.01*ICTF,YSCAL,ITILT,ITWIST,0.01*IROFF, + 0.01*ITOFF,0.01*RMSRES,WRMSRES, + NOFR,(NREF-NOFR),NOLO,NNEG,NBAD,FIOVSDP(9), + FIOVSDP(8),RFACOV,NRSYM,SDRATOV ELSE WRITE (ISUMMR,FMT=6066) ID,ABC(FILM:FILM),0.01*CCX, + 0.01*CCY,CCOM,0.01*ICTF,YSCAL,ITILT,ITWIST, + 0.01*IBULGE, + 0.01*RMSRES,WRMSRES,NOFR,(NREF-NOFR),NOLO,NNEG, + NBAD,FIOVSDP(9),FIOVSDP(8) END IF END IF C C---- If accumulating profiles, on first pass do not call process C store XCEN,YCEN etc C IF (FIRSTPASS) THEN NFILMS = NFILMS + 1 IF (DEBUG(1)) THEN WRITE(IOUT,FMT=6426) NFILMS,ID,NREPEAT,ISEG IF (ONLINE) WRITE(ITOUT,FMT=6426) NFILMS,ID, + NREPEAT,ISEG 6426 FORMAT(1X,'NFILMS set to',I4,' for storing', + ' detector parameters for image',I5, 'nrepeat', + I2,' iseg',I2) END IF C C---- Store information for summary file C ISUMM(1,NFILMS) = ID SUMMCH(NFILMS) = ABC(FILM:FILM) ISUMM(2,NFILMS) = CCX IF (INVERTX) ISUMM(2,NFILMS) = -CCX ISUMM(3,NFILMS) = CCY ISUMM(4,NFILMS) = ICTF ISUMM(5,NFILMS) = ITILT ISUMM(6,NFILMS) = ITWIST ISUMM(7,NFILMS) = IBULGE IF (IMGP) ISUMM(7,NFILMS) = IROFF ISUMM(8,NFILMS) = (NRS-NREJS) ISUMM(15,NFILMS) = CBAR IF (IMGP) THEN ISUMM(19,NFILMS) = ITOFF END IF RSUMM(1,NFILMS) = CCOM C C---- If CCOM has been reset to TRUECCOM in REFRT1, want to store the C actual refined value in summary file. C IF (RESETCCOM) RSUMM(1,NFILMS) = DPSIX + TRUECCOM IF ((ABS(RSUMM(1,NFILMS)).GT.100.0).AND. + (RSUMM(1,NFILMS).LT.0)) + RSUMM(1,NFILMS) = RSUMM(1,NFILMS) + 360.0 IF (RSUMM(1,NFILMS).GT.100.0) + RSUMM(1,NFILMS) = RSUMM(1,NFILMS) - 360.0 RSUMM(2,NFILMS) = YSCAL YSCALERR = MAX(ABS(YSCAL - YSCALIN),YSCALERR) RSUMM(3,NFILMS) = RMSRES IF (RWEIGHT) RSUMM(4,NFILMS) = WRMSRES RSUMM(12,NFILMS) = TOFF END IF C C---- Store summary information on post-refinement. C IF ((FIRSTPASS.OR.PRREAD).AND.POSTREF) THEN C C--- If reading profiles, then FIRSTPASS is never true, so must C increment NFILMS here. C IF (PRREAD) NFILMS = NFILMS + 1 ISUMM(1,NFILMS) = ID C C---- POSTREF summary information. If NADD>1 AND FIXED, then the parameters C for the FIRST NADD images will be identical (because the first postref C run is only done once NADD images have been processed). So when the C first post-refinement has been done, set postref summary parameters C for all these images. NOTE there will be problems if NADD is greater C than NBLOCK !! IF NOT FIXED, then all missetting angles and sds C will be different, so must pick them up from DELPHIV and SDDELPHI C from /POSTCHK/. Note that we also need to check on SUMPART, because C if there are only NADD images in total, then even when IPACK=NADD C the post-refinement will not have been carried out because the next C image was not present ! C C AL IPT = 0 C AL IPTR = 0 C C---- IPT is the pointer into DELPHIV to pick up refined missets. If NADD is C greater than the number of images in a BLOCK, then we must not start C IPT at zero, but 3*NBLOCK*(NADD/NBLOCK) C IPT = 3*NBLOCK*((NADD-1)/NBLOCK) IPTR = IPT JSTART = NFILMS IF ((NADD.GT.1).AND. + ((IPACK.EQ.NADD).AND.SUMPART.AND. + (.NOT.NEWPREF)).OR.((IPACK.EQ.NADD+1) $ .AND.NEWPREF)) JSTART = 1 C IF (NEWPREF) JSTART = NFILMS C IF (DEBUG(1)) THEN WRITE(IOUT,FMT=6310) JSTART,NFILMS,IPACK,NADD,NBLOCK, + NUMBLOCK,IPT IF (ONLINE) WRITE(ITOUT,FMT=6310) JSTART,NFILMS, + IPACK,NADD,NBLOCK,NUMBLOCK,IPT END IF 6310 FORMAT(1X,'In MOSFLM, storing postref info for summary', + ' file, JSTART=',I4,' NFILMS=',I4,' IPACK=',I4, + ' IADD=',I4,' NBLOCK=',I3,' NUMBLOCK=',I3, + ' IPT=',I3) DO 237 JFILMS = JSTART,NFILMS DO 234 I = 1,3 PRFSUM(16+I,JFILMS) = SDCELL(I)*CELL(I) PRFSUM(19+I,JFILMS) = SDCELL(I+3) PRFSUM(22+I,JFILMS) = SDBEAM(I)/DTOR XWARN(I,18) = MAX(XWARN(I,18),SDCELL(I)*CELL(I)) XWARN(I+3,18) = MAX(XWARN(I+3,18),SDCELL(I+3)) C C---- Monitor large standard dveiations in any cell parameter for C warning message. Tets for sd in cell edge greater than 0.1A and C in cell angle greater than 0.1 degrees C IF (SDCELL(I)*CELL(I).GT.0.1) THEN WARN(18) = .TRUE. IWARN(I,18) = 1 END IF IF (SDCELL(I+3).GT.0.1) THEN WARN(18) = .TRUE. IWARN(I+3,18) = 1 END IF C IF ((NADD.GT.1).AND.(.NOT.FIXED).AND. + ((IPACK.EQ.NADD).AND.SUMPART.AND.(.NOT.POSTHOC) + .OR. ((IPACK.EQ.NADD+1).AND.POSTHOC))) THEN C C---- Store values for first NADD images C IPT = IPT + 1 PRFSUM(I,JFILMS) = DELPHIV(IPT) IF (I.GT.2) GOTO 234 IPTR = IPTR + 1 PRFSUM(13+I,JFILMS) = SDDELPHI(IPTR) ELSE C C---- Have not yet done a complete post-refinement, get missets from C DELPHI PRFSUM(I,JFILMS) = DELPHI(I) IF (I.LT.3) PRFSUM(13+I,JFILMS) = SDDELPHI(I) END IF C C---- Special case for NREWPREF refinement C IF (NEWPREF) THEN C C---- In case where NVIRBAT>1, store missets for first images once a C refinement has been done. C IF ((NVIRBAT.GT.1).AND.(IPACK.EQ.(NVIRBAT+1))) THEN DO 233 J = 1,NVIRBAT PRFSUM(I,J) = RMISSETS(J,I) IF (I.LT.3) PRFSUM(13+I,J) = SDMISSETS(J,I) 233 CONTINUE END IF PRFSUM(I,JFILMS) = RMISSETS(IPACK,I) IF (I.LT.3) PRFSUM(13+I,JFILMS) = SDMISSETS(IPACK,I) END IF 234 CONTINUE c c---- missets seem to go missing for last image of first batch if newpref C if(newpref.and.(ipack.eq.nadd+1))then do 235 i=1,3,1 PRFSUM(I,JFILMS) = DELPHI(I) 235 continue endif DO 236 I = 1,6 PRFSUM(I+3,JFILMS) = CELL(I) 236 CONTINUE PRFSUM(10,JFILMS) = RETA/DTOR PRFSUM(11,JFILMS) = RDIVH/DTOR PRFSUM(12,JFILMS) = RDIVV/DTOR PRFSUM(13,JFILMS) = RESID PRFSUMI(JFILMS) = NREFPR 237 CONTINUE END IF C C---- If finished a multiseg run, go back C IF (PRFINISH) THEN PRFINISH = .FALSE. IF (RPTFIRST) GOTO 30 C C---- Display summary of refinement C CALL PRSUMMARY(NREPEAT,NSEG,LASTFILM,RSUMM,ISUMM, + PRFSUM,CELL,OLDCELL,DELPHI,NEWPREF,DISPMENU) SAVMATSTR = 'postrefinement' SAVMATNAM = NEWMATNAM C CALL MRESET(ISEG,RPTFIRST,GENOPEN,COORDOPN) IF (DISPMENU) THEN GOTO 34 ELSE GOTO 30 END IF END IF C C---- Make call to MODARRAY to remove finished reflections C INTDUM(1) = 0 INTDUM(2) = 0 IF(NEWPREF)CALL MODARRAY(1, 0.0, 0,0,INTDUM,INTDUM) C C---- end of PROCESS section from MOSES2 = .TRUE. C chrp06122001 ENDIF C C---- End of loop over films in this pack C 240 CONTINUE C C---- Close the image file. Note is is opened with DISKIO C under Unix, Fortran under VMS, but if file is packed it has C been closed automatically C IF (VAXVMS()) THEN C ************* C AL CLOSE (UNIT=INOD) C ************* ELSE C **************************** C AL IF (.NOT.PACK) CALL QCLOSE(INOD) C **************************** END IF C C---- End of loop over packs in this generate file C c -harvest KHFLMS = KHFLMS + 1 HARETA(KHFLMS) = RETA/DTOR HARDIH(KHFLMS) = RDIVH/DTOR HARDIV(KHFLMS) = RDIVV/DTOR c -harvest 250 CONTINUE C C---- If accumulating profiles, prepare for next pass C chrp06122001 IF(MOSES2)THEN IF (ACCUMULATE) THEN IF (FIRSTPASS) THEN FIRSTPASS = .FALSE. SECONDPASS = .TRUE. C C---- Position generate file to first pack C C ******************** CALL QSEEK(IUNIT,21,1,36) C ******************** C JPACK = 0 IPACKREC = 21 IPACKHEAD = 21 PROCES = .TRUE. NFLMO = NFILMS IF (.NOT.MULTISEG) NFILMS = 0 IF (DEBUG(1)) THEN WRITE(IOUT,FMT=6428) NFILMS IF (ONLINE) WRITE(ITOUT,FMT=6428) NFILMS 6428 FORMAT(1X,'NFILMS at end of FIRSTPASS',I4) END IF C C---- Rewind mosflm.out, containing "A" film images of all packs C plus B/C films if PRBFILM/PRCFILM C REWIND INMO IF (DENSE) REWIND ICOORD C C---- If doing multi-segment post-refinement, return to control to get next C set of images IF (MULTISEG) THEN FIRSTPASS = .TRUE. SECONDPASS = .FALSE. PROCES = .FALSE. GOTO 30 END IF C C---- Measure all "A" films using accumulated profiles C GO TO 40 ELSE IF (SECONDPASS) THEN IF (PROCESSA) GO TO 260 SECONDPASS = .FALSE. THIRDPASS = .TRUE. PROCES = .FALSE. NFILMS = 0 IF (DEBUG(1)) THEN WRITE(IOUT,FMT=6430) IF (ONLINE) WRITE(ITOUT,FMT=6430) 6430 FORMAT(1X,'NFILMS set to zero at end of SECONDPASS') END IF C C---- Rewind mosflm.out C REWIND INMO IF (DENSE) REWIND ICOORD C C---- Position generate file to first pack C C ******************** CALL QSEEK(IUNIT,21,1,36) C ******************** C JPACK = 0 IPACKREC = 21 IPACKHEAD = 21 C C---- Measure subsequent films in each pack C GO TO 40 ELSE IF (THIRDPASS) THEN THIRDPASS = .FALSE. END IF END IF chrp06122001 ENDIF C C---- Read next set of control data C C ********* 260 IF (ONLINE.AND.LBELL) CALL BELL C ********* C C---- Close mosflm.out file C CLOSE (UNIT=INMO) C C---- If doing postrefinement, write results to summary file C IF (POSTREF) THEN WRITE (ISUMMR,FMT=6074) IF (PRFIRST) THEN PRFIRST = .FALSE. IF (NADD.GT.1) THEN IF (FIXED) THEN WRITE (ISUMMR,FMT=6090) NADD,SCELL,SDELPHI ELSE WRITE (ISUMMR,FMT=6079) NADD,SCELL,SDELPHI END IF ELSE WRITE (ISUMMR,FMT=6085) SCELL,SDELPHI END IF IF (REFCELL) THEN WRITE (ISUMMR,FMT=6080) CELLSTR ELSE WRITE (ISUMMR,FMT=6082) END IF IF (PRNS.GT.0) THEN IF (USEBEAM) THEN WRITE (ISUMMR,FMT=6084) 2.0*SETA/DTOR,2.0*SDIVH/DTOR, + 2.0*SDIVV/DTOR ELSE WRITE (ISUMMR,FMT=6086) 2.0*SETA/DTOR, + 2.0*SDIVH/DTOR,2.0*SDIVV/DTOR END IF ELSE WRITE (ISUMMR,FMT=6088) 2.0*SETA/DTOR, + 2.0*SDIVH/DTOR,2.0*SDIVV/DTOR END IF END IF 6082 FORMAT(1X,'Cell parameters are not refined') 6080 FORMAT(1X,'The following cell parameters are being refi', $ 'ned: ',A) 6088 FORMAT(1X,'Beam parameters are not refined',/,1X,'Input', + ' values (degrees): mosaic spread (EPS)',F6.3,' ho', + 'rizontal divergence (DIVH)',F6.3,' vertical diver', + 'gence (DIVV)',F6.3) 6086 FORMAT(1X,'Beam parameters are being refined but input ', + 'values will be used',/,1X,'Input values (degrees)', + ': mosaic spread (EPS)',F6.3,' horizontal divergen', + 'ce (DIVH)',F6.3,' vertical divergence (DIVV)', + F6.3) 6084 FORMAT(1X,'Beam parameters are being refined',/,1X,'Inp', + 'ut values (degrees): mosaic spread (EPS)',F6.3, + ' horizontal divergence (DIVH)',F6.3,' vertical di', $ 'vergence (DIVV)',F6.3) 6074 FORMAT(//1X,'RESULTS OF POSTREFINEMENT') 6079 FORMAT(1X,I2,' successive pairs of images will be used', + /,1X,'Each image will have its own missetting angl', $ 'es',/,1X,'Initial cell ', + 'parameters',3F8.3,3F7.2,/,1X,'Initial missetting', + ' angles',3F9.3) 6090 FORMAT(1X,I2,' successive', + ' pairs of images will be used',/,1X,'The missett', + 'ing angles will be constrained to be identical f', + 'or all images',/,1X,'Initial cell ', + 'parameters',3F8.3,3F7.2,/,1X,'Initial missetting', + ' angles',3F9.3) 6085 FORMAT(1X,'A single', + ' pair of images will be used',/,1X,'Initial cell ', + 'parameters',3F8.3,3F7.2,/,1X,'Initial missetting', + ' angles',3F9.3) WRITE (ISUMMR,FMT=6075) 6075 FORMAT(1X,'Image PHIX PHIY PHIZ A ', + 'B C ALPHA BETA GAMMA MOSAIC DIVH DI', $ 'VV Resid NR') IF (NREPEAT.NE.0) WRITE(ISUMMR,FMT=6071) NADD,NREPEAT 6071 FORMAT(1X,'The first',I3,' images have been remeasured', + I3,' times because of shifts in missetting angles', + ' or cell parameters') NREPEAT = 0 DO 270 I = 1, NFILMS IF (PRF(I)) THEN C C---- Needed for xloggraph, post-refinement results C WRITE(ISUMMR,FMT=6072) ISUMM(1,I),(PRFSUM(K,I), + K=1,13),PRFSUMI(I) NLSUM2 = NLSUM2 + 1 WRITE(LINESUM2(NLSUM2),FMT=6072) ISUMM(1,I), + (PRFSUM(K,I),K=1,13),PRFSUMI(I) C C---- Now sd's C IF ((NADD.GT.1).AND.(FIXED)) THEN WRITE(ISUMMR,FMT=6081) (PRFSUM(K,I),K=14,25) ELSE WRITE(ISUMMR,FMT=6083) (PRFSUM(K,I),K=14,15), + (PRFSUM(K,I),K=17,25) END IF IF (PRFRPT1(I)) THEN IF (PRFRPT2(I)) THEN WRITE(ISUMMR,FMT=6122) ISUMM(1,I),SHIFTMAX, $ SHIFTFAC PRFRPT2(I) = .FALSE. ELSE WRITE(ISUMMR,FMT=6076) ISUMM(1,I),SHIFTMAX END IF PRFRPT1(I) = .FALSE. END IF IF (PRFRPT2(I)) THEN WRITE(ISUMMR,FMT=6124) ISUMM(1,I),SHIFTFAC PRFRPT2(I) = .FALSE. END IF IF (PRNEGM(I)) WRITE(ISUMMR,FMT=6120) PRNEGM(I) = .FALSE. IF (PRFHS(I)) WRITE(ISUMMR,FMT=6077) PRFHS(I) = .FALSE. ELSE WRITE(ISUMMR,FMT=6078) ISUMM(1,I) END IF 270 CONTINUE c -harvest c cxEBI if this format changes then mharvest.f needs to know 6072 FORMAT(1X,I4,2X,3F8.2,3X,6F7.2,2X,3F6.2,F7.3,I5) c -harvest 6081 FORMAT(1X,' sds',3F8.2,3X,6F7.2,2X,3F6.2) 6083 FORMAT(1X,' sds PSIY',F7.2,' PSIZ',F7.2,3X,6F7.2,2X,3F6.2) 6076 FORMAT(1X,'Image',I4,' was remeasured because the shift', + ' in orientation was greater than ',F5.2,' degrees') 6122 FORMAT(1X,'Image',I4,' remeasured, shift in', + ' orientation > ',F5.2,' degrees and in cell >', + F5.1,' sds') 6124 FORMAT(1X,'Image',I4,' was remeasured because the shift', + ' in cell was greater than ',F5.2,' sds') 6077 FORMAT(1X,'** Warning ** large shift in cell or missett', + 'ing angles, consult logfile') 6078 FORMAT(1X,I4,5X,'Post refinement was not performed for ', + 'this image') 6120 FORMAT(1X,'** Warning ** negative (mosaic spread+beam d', + 'ivergence). May be large crystal slippage or inpu', + 't oscillation angle is wrong') END IF C C---- Find largest shift in CCOM, ROFF,TOFF or missets between adjacent images C and the largest weighted residual and number of badspots C C AL WRITE(6,*),'NUMBLOCK,NFILMS',NUMBLOCK,NFILMS DO 274 I=1,NFILMS WRMAX = MAX(WRMAX,RSUMM(4,I)) NBADMAX = MAX(NBADMAX,ISUMM(13,I)) IF (I.EQ.1) GOTO 274 ROFFMAX = MAX(ROFFMAX,0.01*ABS(ISUMM(7,I)-ISUMM(7,I-1))) TOFFMAX = MAX(TOFFMAX,0.01*ABS(ISUMM(19,I)-ISUMM(19,I-1))) X = RSUMM(1,I)-RSUMM(1,I-1) IF (X.GT.180) X = X - 360.0 IF (X.LT.-180) X = X + 360.0 CCOMAX = MAX(CCOMAX,ABS(X)) C C---- Dont do a check for image 2 vs image 1 because image 1 may C not have been assigned missets because officially it was not C refined. C IF ((NUMBLOCK.EQ.1).AND.(NEWPREF).AND.(I.LT.3)) GOTO 274 DELPHIMAX = MAX(DELPHIMAX,ABS(PRFSUM(1,I)-PRFSUM(1,I-1)), + ABS(PRFSUM(2,I)-PRFSUM(2,I-1)), + ABS(PRFSUM(3,I)-PRFSUM(3,I-1))) C AL WRITE(6,*),'ROFFMAX,CCOMAX,DELPHIMAX',ROFFMAX,CCOMAX,DELPHIMAX 274 CONTINUE C C---- Now check the first image in this block with the last image in C previous block (if any) C IF (NUMBLOCK.GT.1) THEN ROFFMAX = MAX(ROFFMAX,ABS(0.01*ISUMM(7,1)-ROFFLAST)) TOFFMAX = MAX(TOFFMAX,ABS(0.01*ISUMM(19,1)-TOFFLAST)) X = RSUMM(1,1)-CCOMLAST IF (X.GT.180) X = X - 360.0 IF (X.LT.-180) X = X + 360.0 CCOMAX = MAX(CCOMAX,ABS(X)) DELPHIMAX = MAX(DELPHIMAX,ABS(PRFSUM(1,1)-PHIXLAST), + ABS(PRFSUM(2,1)-PHIYLAST), + ABS(PRFSUM(3,1)-PHIZLAST)) END IF C AL WRITE(6,*),'AFTER COMPARISON WITH LAST ROFFMAX,CCOMAX,DELPHIMAX', C AL + ROFFMAX,CCOMAX,DELPHIMAX IF (NFILMS.GT.0) THEN ROFFLAST = 0.01*ISUMM(7,NFILMS) TOFFLAST = 0.01*ISUMM(19,NFILMS) CCOMLAST = RSUMM(1,NFILMS) PHIXLAST = PRFSUM(1,NFILMS) PHIYLAST = PRFSUM(2,NFILMS) PHIZLAST = PRFSUM(3,NFILMS) C AL WRITE(6,*),'ROFFLAST,CCOLAST,PHIXYZLAST',ROFFLAST,CCOMLAST, C AL + PHIXLAST, PHIYLAST, PHIZLAST END IF C C---- If using blocks of images, go on to next block if required C IF (NBLOCK.NE.0) THEN C C---- Reset repeat measurement and post-refined flags C DO 272 I = 1,MAXPAX PRFRPT1(I) = .FALSE. PRFRPT2(I) = .FALSE. PRFHS(I) = .FALSE. PRF(I) = .FALSE. PRNEGM(I) = .FALSE. 272 CONTINUE C C---- Position generate file at last record ready for next pack, but NOT if C using ADDPART because the first image of the next block has already C been generated (to trap spatially overlapped summed partials). IN C this case can leave generate file where it was. C C ******************** IF ((ADDPART).AND.(NPACK.LT.NPACKSAVE)) THEN IF (MULTIMTZ) THEN WRITE(IOUT,FMT=6372) MTZNAM(1:LENSTR(MTZNAM)) IF (ONLINE) WRITE(ITOUT,FMT=6372) $ MTZNAM(1:LENSTR(MTZNAM)) 6372 FORMAT(/,1X,'Closing mtz file: ',A) MTZPRT = 0 CALL LWCLOS(MTZOUT,MTZPRT) C C---- Sset up new MTZ filename C CALL NEWFN(NUMBLOCK+1,MTZNAM) CALL STARTMTZ END IF GOTO 35 END IF C C---- Special test for case when there is only a single image in the last C block...without this test this last image will never be processed C IF ((ADDPART).AND.(NPACK.EQ.NPACKSAVE).AND.EXTRAIMG) THEN IF (MULTIMTZ) THEN WRITE(IOUT,FMT=6372) MTZNAM(1:LENSTR(MTZNAM)) IF (ONLINE) WRITE(ITOUT,FMT=6372) $ MTZNAM(1:LENSTR(MTZNAM)) MTZPRT = 0 CALL LWCLOS(MTZOUT,MTZPRT) C C---- Sset up new MTZ filename C CALL NEWFN(NUMBLOCK+1,MTZNAM) CALL STARTMTZ END IF GOTO 35 END IF CALL QSEEK(IUNIT,IRECLAST,1,36) IPACKREC = IRECLAST IPACKHEAD = IRECLAST IF (DEBUG(1)) THEN WRITE(IOUT,FMT=6094) IRECLAST IF (ONLINE) WRITE(ITOUT,FMT=6094) IRECLAST 6094 FORMAT(1X,'In MAIN, reposition generate file to record', $ I6) END IF C ******************** IF (NPACK.LT.NPACKSAVE) THEN IF (MULTIMTZ) THEN WRITE(IOUT,FMT=6372) MTZNAM(1:LENSTR(MTZNAM)) IF (ONLINE) WRITE(ITOUT,FMT=6372) $ MTZNAM(1:LENSTR(MTZNAM)) MTZPRT = 0 CALL LWCLOS(MTZOUT,MTZPRT) C C---- Sset up new MTZ filename C CALL NEWFN(NUMBLOCK+1,MTZNAM) CALL STARTMTZ END IF GOTO 35 END IF END IF C C---- Write number of warning messages to summary file C WARN(2) = (ROFFMAX.GT.0.10) XWARN(1,2) = ROFFMAX WARN(12) = (TOFFMAX.GT.0.10) XWARN(1,12) = TOFFMAX WARN(3) = (CCOMAX.GT.0.10) XWARN(1,3) = CCOMAX WARN(5) = (DELPHIMAX.GT.0.25*(ETA + MAX(DIVH,DIVV))/DTOR) XWARN(1,5) = DELPHIMAX WARN(6) = (WRMAX.GT.1.5) XWARN(1,6) = WRMAX WARN(7) = (NBADMAX.GE.10) IWARN(1,7) = NBADMAX WARN(9)= ((AVBGRMAX.GT.1.1).OR.(AVBGRMIN.LT.0.9)) XWARN(1,9) = AVBGRMIN XWARN(2,9) = AVBGRMAX WARN(25) = (YSCALERR.GT.0.001) XWARN(1,25) = YSCALERR CALL WARNINGS CALL GROUT C C---- If running interactively, go back to image display, otherwise C Call CONTROL again for next "run" (if any). also if doing C newpref integration in background or foreground. C 280 IF (DISPMENU) THEN CALL MRESET(ISEG,RPTFIRST,GENOPEN,COORDOPN) GOTO 34 END IF chrp06122001 MOSES2 = .TRUE. GO TO 30 END