C************************************************************* C C This code is distributed under the terms and conditions of the C CCP4 licence agreement as `Part ii)' software. See the conditions C in the CCP4 manual for a copyright statement. C C************************************************************** C C =============== PROGRAM MTZDUMP C =============== C C This program is used to give a file dump of a standard 'MTZ' C reflection data file. The file header information is printed C followed by a summary of the reflection data which gives, for each C data column, the following information: C C Column number C Sort order (asc=ascending, desc=descending, both=all values the C same, none=not sorted) C Minimum value present C Maximum value present C Number of "missing" values present (identified by MNF) C Percentage completeness C Average value excluding "missing" values C Average absolute value excluding "missing" values C Low resolution limit of data present C High resolution limit of data present C Column type C Column label C C This information is given once for the entire file, and also C (if requested) for a set of resolution bins. C C The summary is followed by a compact but tabulated listing of the C individual reflection data. The maximum number of reflns to be printed C may be specified to give a partial listing of the data. C C The following lines of keyworded input are possible C C RESO resolution limits for LIST OF REFLECTIONS - default is all C C STATS NBIN [RESO ] C no. of resolution bins and limits for FILE STATISTICS C - default is one bin and all reflections. C If = 1, only overall summary table is given. C If > 1, both overall and partial summary C tables are given. C C LRESO listing will include 4sin**2/Lambda**2 for each reflection. C C HEAD print MTZ file header only. C C NREF LINMAX number of reflections to list = IABS(LINMAX). C If LINMAX is negative, the summary is omitted, C which speeds up the program by saving the first pass C through the file (if LINMAX = -1 then all C reflections, but no summary are printed). C No input here results in 1st 10 reflections. C C STARTHKL JHSTRT(3) indices HKL of first reflection to list. if = 0 0 0, C start at beginning. C C BATCH Print orientation data if present, N don't C C SYMMETRY Print Symmetry information if present, N don't C C SKIP followed by nskip (default none) C C END,GO,RUN start dump C C Hidden: C DEBU C C History: C April 96 - statistics tables rationalised, and breakdown C w.r.t. resolution bins added (MDW) C C .. Parameters .. INTEGER NPARM,MCOLS,MBATCH,MBIN PARAMETER(NPARM=200,MCOLS=500,MBATCH=5000,MBIN=100) C .. C .. Local Scalars .. REAL AVE1,AVE2,RESOL,RESMIN,RESMAX, + SMIN,SMAX,SSMIN,SSMAX,RANGE,PSSMIN,PSSMAX,COMPLET INTEGER IFAIL,IPRINT,J,JCOUNT,JDO110,JDO130,JDO140, + JDO160,JDO170,JDO190,JDO200,JDO210,JDO220,JDO230,JDO70, + JDO80,LDUM,LFLAG,LINMAX,NBATX,NCOL,NCOLS,NLIN,NN,NREFL, + NREFLX,NSYMX,IMI,IBN,NSKIP,NBIN,JDO111,IBIN,NSPGRX,NSYMPX LOGICAL EOF,LORFLG,LSYMM,MSTART,LRESOL,LOGRES,LOGSRES, + LOGVALM,LOGFRMAT,LHEAD CHARACTER MNF*9,SORT*5,VERSNX*10,CWORK*4, + LTYPEX*1,SPGRNX*10,PGNAMX*10 C .. C .. Local Arrays .. REAL ABSVAL(MCOLS),ADATA(MCOLS),APREV(MCOLS), + RANGES(2,MCOLS),RESCOL(2,MCOLS),RSYMX(4,4,96), + SUMVAL(MCOLS),PSUMVAL(MBIN,MCOLS),PABSVAL(MBIN,MCOLS), + PMIN(MBIN,MCOLS),PMAX(MBIN,MCOLS),COLMIN(MCOLS), + COLMAX(MCOLS) INTEGER IBATCX(MBATCH),IHKL(3),JHSTRT(3),NMISS(MCOLS), + NPMISS(MBIN,MCOLS),NPREFL(MBIN) LOGICAL IASC(MCOLS),IDESC(MCOLS),LOGMSS(MCOLS) CHARACTER CTYPS(MCOLS)*1,CLABS(MCOLS)*30,OUTSTR(MCOLS)*9 C .. C .. External Functions .. LOGICAL CCPONL EXTERNAL CCPONL INTEGER LENSTR EXTERNAL LENSTR C .. C .. External Subroutines .. EXTERNAL BLANK,CCPOPN,CCPPAG,CCPUPC,CCPRCS,LERROR, + LHPRT,LRBATS,LRCLAB,LRINFO,LROPEN,LRREFL,LRREFM,LRREWD, + LRSYMM,PRBHDR C .. C .. Intrinsic Functions .. INTRINSIC ABS,NINT C .. C .. C---- things for parser C CHARACTER KEY*4,LINE*600,CVALUE(NPARM)*4,FRMAT*120 REAL FVALUE(NPARM) LOGICAL LEND,LOGDEBUG INTEGER ITOK,NTOK,IBEG(NPARM),IEND(NPARM),ITYPE(NPARM), + IDEC(NPARM) C C---- Data Statements C C .. Data statements .. DATA JHSTRT/3*0/ C .. C C *********** CALL CCPFYP CALL MTZINI C *********** C C---- Initialise some variables C IFAIL = 0 C C ********************************** CALL CCPOPN(5,'DATA',5,1,LDUM,IFAIL) CALL CCPOPN(6,'PRINTER',6,1,LDUM,IFAIL) CALL CCPRCS(6,'MTZDUMP', '$Date: 2002/08/06 10:41:59 $') C ********************************** C LOGDEBUG = .FALSE. LEND = .FALSE. LORFLG = .FALSE. LSYMM = .FALSE. MSTART = .TRUE. LRESOL = .FALSE. LOGRES = .FALSE. LOGSRES = .FALSE. LOGVALM = .FALSE. LOGFRMAT = .FALSE. LHEAD = .FALSE. LINMAX = 10 NSKIP = 0 NBIN = 1 SMIN = 0.0 SMAX = 2.0 SSMIN = 0.0 SSMAX = 2.0 VALM = 0.0 MNF = ' ? ' C C---- Get user input C IF (CCPONL (1)) THEN WRITE(6,'(///,a)') ' Optional input follows.' WRITE(6,'(/,a,/,a,/,a,/,a,a,/,a,/,a,/,a,/,a,/,a,/,a,/,a,/,a)') 1' Keywords: RESO STATS LRESO HEAD NREF START SKIP SYMM', 1' BATCH FORMAT RUN/GO/END', 1' RESO max min - resolution limits for listing (default all)', 1' STATS [NBIN num] [RESO max min] - no. of reso. bins and limits', +' for stats.', 1' LRESO - S is given for each listed reflection', 1' HEAD - print MTZ file header only', 1' NREF num - number of reflections listed (default 10)', 1' START H0 K0 L0 - first reflection listed (default first)', 1' SKIP nskip - no. of refls. skipped before listing (default 0)', 1' SYMMETRY - list symmetry info', 1' VALM num - missing data set to this value', 1' BATCH - list batch orientation blocks', 1' FORMAT fmt - format of listed refls. .e.g. ''(3i4,10f8.2)''', +' RUN/GO/END - to start dump' ENDIF C 1 CONTINUE NTOK=NPARM LINE=' ' CALL PARSER (KEY,LINE,IBEG,IEND,ITYPE,FVALUE,CVALUE,IDEC,NTOK, + LEND,LOGDEBUG) IF (LEND) GO TO 1000 C C IF (KEY .EQ. 'END' .OR. + KEY(1:1) .EQ. 'G' .OR. + KEY .EQ. 'RUN') THEN GO TO 1000 C C---- RESOlution C ========== C C read resolution limits for listing in A, C if only one treat as high resolution limit C C ELSE IF (KEY.EQ.'RESO') THEN ITOK = 2 C C ***************************************************** CALL RDRESO(ITOK,ITYPE,FVALUE,NTOK,RESMIN,RESMAX,SMIN,SMAX) C ***************************************************** C WRITE (6,'(A,2F10.5)') 1 ' Resolution limits for listing: SMIN SMAX',SMIN,SMAX LOGRES = .TRUE. C C---- STATS C ===== C C STATS NBIN [RESO ] C Read no. of resolution bins (and optionally resolution C limits) for statistics. C If only one limit treat as high resolution limit C C ELSE IF (KEY.EQ.'STAT') THEN IF (NTOK.LT.2) THEN WRITE (6,'(A)') + ' No subkeywords given, keyword STATS ignored!' GO TO 1 ENDIF CWORK = LINE(IBEG(2):IEND(2)) CALL CCPUPC(CWORK) IF (CWORK.EQ.'NBIN') THEN CALL GTPINT(3,NBIN,NTOK,ITYPE,FVALUE) IF (NBIN.GT.MBIN) THEN WRITE(6,'(A,I3,A,I3)') ' NBIN = ',NBIN, + ' > allowed maximum. Set to: ',MBIN NBIN = MBIN ENDIF WRITE (6,'(A,I4)') + ' No. resolution bins: ',NBIN ITOK = 4 ELSE CALL CCPERR (1, '1st subkeyword must be NBIN.') ENDIF IF (NTOK.LT.ITOK) GO TO 1 CWORK = LINE(IBEG(ITOK):IEND(ITOK)) CALL CCPUPC(CWORK) IF (CWORK.EQ.'RESO') THEN ITOK = 5 C ******************************************************** CALL RDRESO(ITOK,ITYPE,FVALUE,NTOK,RESMIN,RESMAX,SSMIN,SSMAX) C ******************************************************** WRITE (6,'(A,2F10.5)') + ' Resolution limits for statistics: SSMIN SSMAX',SSMIN,SSMAX LOGSRES = .TRUE. ELSE CALL CCPERR (1, 'Illegal subkeyword.') ENDIF C C ----- DEbug c ELSE IF (KEY.EQ.'DEBU') THEN LOGDEBUG = .TRUE. C C ----- LRESO c ELSE IF (KEY.EQ.'LRES') THEN LRESOL = .TRUE. WRITE (6,'(A)') 1 ' List reflection with 4 sinsq/Lamda : ' C C ----- HEADER c ELSE IF (KEY.EQ.'HEAD') THEN LHEAD = .TRUE. C C ----- Nrefs c ELSE IF (KEY.EQ.'NREF') THEN IF (NTOK.NE.2) + CALL CCPERR (1, 'Single integer argument expected') CALL GTPINT (2,LINMAX,NTOK,ITYPE,FVALUE) WRITE (6,'(A,3I4)') 1 ' List reflection: ',LINMAX C C ----- Start at c ELSE IF (KEY.EQ.'STAR') THEN IF (NTOK.NE.4) + CALL CCPERR (1, 'Three integer arguments expected') CALL GTPINT (2,JHSTRT(1),NTOK,ITYPE,FVALUE) CALL GTPINT (3,JHSTRT(2),NTOK,ITYPE,FVALUE) CALL GTPINT (4,JHSTRT(3),NTOK,ITYPE,FVALUE) WRITE (6,'(A,3I4)') 1 ' Start at reflection: ',JHSTRT C C ----- VALM to C ELSE IF (KEY.EQ.'VALM') THEN IF (NTOK.LT.2) + CALL CCPERR (1, 'Argument expected') CALL GTPREA (2,VALM,NTOK,ITYPE,FVALUE) LOGVALM = .TRUE. WRITE (6,'(A,f10.2)') 1 ' Missing value output as: ',VALM write(6,*)LOGVALM C C ----- Skip to C ELSE IF (KEY.EQ.'SKIP') THEN IF (NTOK.NE.2) + CALL CCPERR (1, 'Single integer argument expected') CALL GTPINT (2,NSKIP,NTOK,ITYPE,FVALUE) WRITE (6,'(A,I8)') 1 ' Skip to reflection: ',NSKIP C C ----- FORMAT keyword C ELSE IF (KEY.EQ.'FORM') THEN IF (NTOK .NE. 2) + CALL CCPERR(1,'FORMAT must have one string argument') IF (IEND(2)-IBEG(2).GT.120) THEN CALL CCPERR(1,'FORMAT format string too long') ELSE FRMAT = LINE(IBEG(2):IEND(2)) LOGFRMAT = .TRUE. ENDIF C C ----- PRINT at c ELSE IF (KEY.EQ.'SYMM') THEN LSYMM = .TRUE. ELSE IF(KEY.EQ.'BATC') THEN LORFLG = .TRUE. ELSE IF (KEY.EQ.' ') THEN GO TO 1 ELSE C C----- ????? not understood C WRITE(6,*) ' Keyword ',KEY,' not recognised' END IF C GO TO 1 C 1000 CONTINUE IF(LSYMM) Write(6,*)' Symmetry to be listed' IF(LORFLG) Write(6,*)' Orientation to be listed' C CCX ONL = CCPONL(IDUM) C WRITE(6,'(A,L1)')' Logical?? ',ONL C C Cant have a given format and missing strings IF (.NOT.LOGVALM .AND. LOGFRMAT) THEN VALM = -999.0 LOGVALM = .TRUE. ENDIF C---- Open file C IFAIL = 0 IPRINT = 0 MTZIN = 1 C C ****************************** CALL LROPEN(MTZIN,'HKLIN',IPRINT,IFAIL) C ****************************** C IF (IFAIL.NE.0) THEN C C---- File doesn't exist C LFLAG = 2 IFAIL = -1 C C ************************************************ CALL LERROR(LFLAG,IFAIL,'HKLIN file does not exist') C ************************************************ C CALL CCPERR(1,' ERROR IN HKLIN') ELSE C C---- Resolution limits. C CALL LRRSOL(MTZIN,SMN,SMX) IF (.NOT.LOGRES) THEN SMIN = SMN SMAX = SMX ENDIF IF (.NOT.LOGSRES) THEN SSMIN = SMN SSMAX = SMX ENDIF RANGE = (SSMAX - SSMIN)/REAL(NBIN) C C---- Orientation data, yes or no ? (only if multi-record file) C C Find out if there are any batches, NBATX = number of batches, stored C in IBATCX. If NBATX = 0, then there are no batch headers C C ********************** CALL LRBATS(MTZIN,NBATX,IBATCX) C ********************** C IF (NBATX.EQ.0) LORFLG = .FALSE. C C---- Symmetry data, if present in header C C Return symmetry just so that I can test if there are any C C ********************** CALL LRSYMI(MTZIN,NSYMPX,LTYPEX,NSPGRX,SPGRNX,PGNAMX) CALL LRSYMM(MTZIN,NSYMX,RSYMX) C ********************** C C---- So now print the header information C IPRINT = 2 IF (LSYMM) IPRINT = 4 C C **************** CALL LHPRT(MTZIN,IPRINT) C **************** C IF (LSYMM) CALL EPSLN(NSYMX,NSYMPX,RSYMX,IPRINT) C C---- Print out batch header information if present C IF (NBATX.GT.0) THEN C C ***************** CALL BLANK('CURWIN',3) C ***************** C DO 70 JDO70 = 1,NBATX C C ****************************** CALL PRBHDR(1,IBATCX(JDO70),LORFLG) C ****************************** C 70 CONTINUE C C END IF C C---- MSTART is .false. if starting reflection is given, C 000 = no reflection C MSTART = .FALSE. C C DO 80 JDO80 = 1,3 IF (JHSTRT(JDO80).NE.0) GO TO 100 80 CONTINUE C C MSTART = .TRUE. END IF 100 CONTINUE C C "HEADER" keyword specified. Exit having printed header info. C IF (LHEAD) CALL CCPERR(0,' Header printed. Normal exit.') C ******************* CALL CCPPAG(6,NCOL,NLIN) C ******************* C NCHLIN = NCOL C C---- Initialise counts and variables C DO 110 JDO110 = 1,MCOLS SUMVAL(JDO110) = 0.0 ABSVAL(JDO110) = 0.0 RESCOL(1,JDO110) = 9999. RESCOL(2,JDO110) = 0. COLMIN(JDO110) = 1.E30 COLMAX(JDO110) = -1.E30 NMISS(JDO110) = 0 IASC(JDO110) = .TRUE. IDESC(JDO110) = .TRUE. DO 111 JDO111 = 1,MBIN NPMISS(JDO111,JDO110) = 0 PSUMVAL(JDO111,JDO110) = 0.0 PABSVAL(JDO111,JDO110) = 0.0 PMIN(JDO111,JDO110) = 1.E30 PMAX(JDO111,JDO110) = -1.E30 111 CONTINUE 110 CONTINUE C C---- Read file to collect statistics information C C ************************************ CALL LRINFO(MTZIN,VERSNX,NCOLS,NREFLX,RANGES) C ************************************ C C---- Get all column labels C C *************************** CALL LRCLAB(MTZIN,CLABS,CTYPS,NCOLS) C *************************** C C---- If LINMAX .lt. 0, skip accumulation of statistics C IF (LINMAX.GE.0) THEN NREFL = 0 DO 113 JDO111 = 1,MBIN NPREFL(JDO111) = 0 113 CONTINUE 120 CONTINUE C C---- Loop over reflections C C ************************* CALL LRREFL(MTZIN,RESOL,ADATA,EOF) C ************************* IF (.NOT.EOF) THEN IF ( LOGSRES .AND. + (RESOL .LT. SSMIN .OR. RESOL .GT. SSMAX)) GO TO 120 C C ******************** CALL LRREFM(MTZIN,LOGMSS) C ******************** C NREFL = NREFL + 1 IBIN = INT((RESOL+1.E-10-SSMIN)/RANGE) + 1 NPREFL(IBIN) = NPREFL(IBIN) + 1 C DO 130 JDO130 = 1,NCOLS IF (LOGMSS(JDO130) ) THEN NMISS(JDO130) = NMISS(JDO130) + 1 NPMISS(IBIN,JDO130) = NPMISS(IBIN,JDO130) + 1 ENDIF C NN = NREFL - NMISS(JDO130) C IF (.NOT.LOGMSS(JDO130)) THEN RESCOL(1,JDO130) = MIN(RESCOL(1,JDO130),RESOL) RESCOL(2,JDO130) = MAX(RESCOL(2,JDO130),RESOL) SUMVAL(JDO130) = SUMVAL(JDO130) + ADATA(JDO130) ABSVAL(JDO130) = ABS(ADATA(JDO130)) + ABSVAL(JDO130) PSUMVAL(IBIN,JDO130) = + PSUMVAL(IBIN,JDO130) + ADATA(JDO130) PABSVAL(IBIN,JDO130) = + PABSVAL(IBIN,JDO130) + ABS(ADATA(JDO130)) COLMIN(JDO130) = MIN(ADATA(JDO130),COLMIN(JDO130)) COLMAX(JDO130) = MAX(ADATA(JDO130),COLMAX(JDO130)) PMIN(IBIN,JDO130)=MIN(ADATA(JDO130),PMIN(IBIN,JDO130)) PMAX(IBIN,JDO130)=MAX(ADATA(JDO130),PMAX(IBIN,JDO130)) C IF (NN.GT.1) THEN IF (ADATA(JDO130).LT.APREV(JDO130)) IASC(JDO130) + = .FALSE. IF (ADATA(JDO130).GT.APREV(JDO130)) IDESC(JDO130) + = .FALSE. END IF APREV(JDO130) = ADATA(JDO130) C ENDIF C 130 CONTINUE C GO TO 120 END IF C C---- Prepare and print overall summary table C WRITE (6,'(/,/,A,F7.3,A,F7.3,/,A,/,/,2(/,2A),/)') + ' OVERALL FILE STATISTICS for resolution range ', + SSMIN,' - ',SSMAX, + ' ======================= ', + ' Col Sort Min Max Num % ', + ' Mean Mean Resolution Type Column', + ' num order Missing complete', + ' abs. Low High label ' DO 140 JDO140 = 1,NCOLS AVE1 = 0.0 AVE2 = 0.0 C NN = NREFL - NMISS(JDO140) COMPLET = REAL(NN)*100.0/REAL(NREFL) C IF (NN.GT.0) THEN AVE1 = SUMVAL(JDO140)/NN AVE2 = ABSVAL(JDO140)/NN END IF C SORT = ' NONE' IF (IASC(JDO140)) SORT = ' ASC ' IF (IDESC(JDO140)) SORT = ' DESC' IF (IASC(JDO140) .AND. IDESC(JDO140)) SORT = ' BOTH' C IF (RESCOL(1,JDO140).LT.0.) THEN RESCOL(1,JDO140) = -999 ELSE IF (NINT(RESCOL(1,JDO140)).EQ.9999) THEN RESCOL(1,JDO140) = -999 ELSE IF (RESCOL(1,JDO140).NE.0.0) THEN RESCOL(1,JDO140) = 1./SQRT(RESCOL(1,JDO140)) ENDIF IF (RESCOL(2,JDO140).LT.0.) THEN RESCOL(2,JDO140) = -999 ELSE IF (RESCOL(2,JDO140).NE.0.0) THEN RESCOL(2,JDO140) = 1./SQRT(RESCOL(2,JDO140)) ENDIF C C---- Determine whether all elements are missing C IF (NN .EQ. 0) THEN WRITE (6,'(I4,A,A7,A8,I6,F8.2,2A9,2F7.2,A4,2X,A)') + JDO140,SORT,' ? ',' ? ',NMISS(JDO140),COMPLET, + ' ? ',' ? ',RESCOL(1,JDO140), + RESCOL(2,JDO140),CTYPS(JDO140), + CLABS(JDO140)(1:LENSTR(CLABS(JDO140))) ELSE IF (CTYPS(JDO140).EQ.'H' .OR. CTYPS(JDO140).EQ.'Y' .OR. + CTYPS(JDO140).EQ.'B') THEN WRITE (6,'(I4,A,I6,I8,1X,I6,F8.2,2F9.1,2F7.2,A4,2X,A)') + JDO140,SORT,NINT(COLMIN(JDO140)), + NINT(COLMAX(JDO140)),NMISS(JDO140),COMPLET, + AVE1,AVE2,RESCOL(1,JDO140),RESCOL(2,JDO140), + CTYPS(JDO140),CLABS(JDO140)(1:LENSTR(CLABS(JDO140))) ELSE IF (CTYPS(JDO140).EQ.'S') THEN WRITE (6,'(I4,A,F7.4,F8.4,I6,F8.2,2F9.1,2F7.2,A4,2X,A)') + JDO140,SORT,COLMIN(JDO140),COLMAX(JDO140), + NMISS(JDO140),COMPLET,AVE1,AVE2, + RESCOL(1,JDO140),RESCOL(2,JDO140), + CTYPS(JDO140),CLABS(JDO140)(1:LENSTR(CLABS(JDO140))) ELSE IF (CTYPS(JDO140).EQ.'W') THEN WRITE (6,'(I4,A,F7.3,F8.3,I6,F8.2,2F9.3,2F7.2,A4,2X,A)') + JDO140,SORT,COLMIN(JDO140),COLMAX(JDO140), + NMISS(JDO140),COMPLET,AVE1,AVE2, + RESCOL(1,JDO140),RESCOL(2,JDO140), + CTYPS(JDO140),CLABS(JDO140)(1:LENSTR(CLABS(JDO140))) C C---- other col types but here number greater than 1x,f8 C ELSE IF (COLMAX(JDO140).GT.999999.5) THEN WRITE (6,'(I4,A,F8.0,F9.0,I6,F8.2,2F9.0,2F7.2,A2,2X,A)') + JDO140,SORT,COLMIN(JDO140),COLMAX(JDO140), + NMISS(JDO140),COMPLET,AVE1,AVE2, + RESCOL(1,JDO140),RESCOL(2,JDO140), + CTYPS(JDO140),CLABS(JDO140)(1:LENSTR(CLABS(JDO140))) ELSE C C---- other col types but numbers fit into f8.1 C WRITE (6,'(I4,A,F7.1,F8.1,I6,F8.2,2F9.2,2F7.2,A4,2X,A)') + JDO140,SORT,COLMIN(JDO140),COLMAX(JDO140), + NMISS(JDO140),COMPLET,AVE1,AVE2, + RESCOL(1,JDO140),RESCOL(2,JDO140), + CTYPS(JDO140),CLABS(JDO140)(1:LENSTR(CLABS(JDO140))) END IF END IF 140 CONTINUE C C---- We are counting the reflections as a sort of check. C If doesn't match file header, continue anyway. C Can differ if STATS keyword specified. C WRITE (6,6008) NREFL C IF (NREFL.NE.NREFLX) THEN WRITE (6,'(A,A,/,A,A,/,/)') + ' *** WARNING: Number of reflections used in compiling', + ' statistics does not',' match MTZ header. I hope you used', + ' the STAT keyword!' END IF IF (NBIN.EQ.1) GO TO 195 DO 190 JDO190 = 1,NBIN PSSMIN = SSMIN + REAL(JDO190-1)*RANGE PSSMAX = SSMIN + REAL(JDO190)*RANGE WRITE (6,'(/,/,A,F7.3,A,F7.3,/,A,/,/,2(/,2A),/)') + ' PARTIAL FILE STATISTICS for resolution range ', + PSSMIN,' - ',PSSMAX, + ' ----------------------- ', + ' Col Min Max Num % Mean ', + ' Mean Resolution Column', + ' num Missing complete ', + ' abs. Low High label ' IF (PSSMIN.LE.0.) THEN PSSMIN = 999.99 ELSE PSSMIN = 1./SQRT(PSSMIN) ENDIF IF (PSSMAX.LE.0.) THEN PSSMAX = 999.99 ELSE PSSMAX = 1./SQRT(PSSMAX) ENDIF DO 145 JDO140 = 1,NCOLS AVE1 = 0.0 AVE2 = 0.0 C NN = NPREFL(JDO190) - NPMISS(JDO190,JDO140) COMPLET = REAL(NN)*100.0/REAL(NPREFL(JDO190)) C IF (NN.GT.0) THEN AVE1 = PSUMVAL(JDO190,JDO140)/NN AVE2 = PABSVAL(JDO190,JDO140)/NN END IF C IF (NN .EQ. 0) THEN WRITE (6,'(I4,A7,A8,I6,F8.2,2A8,2F7.2,4X,A)') + JDO140,' ? ',' ? ',NMISS(JDO140),COMPLET, + ' ? ',' ? ',PSSMIN,PSSMAX, + CLABS(JDO140)(1:LENSTR(CLABS(JDO140))) ELSE IF (CTYPS(JDO140).EQ.'H' .OR. CTYPS(JDO140).EQ.'Y' .OR. + CTYPS(JDO140).EQ.'B') THEN WRITE (6,'(I4,I6,I8,1X,I6,F8.2,2F8.1,2F7.2,4X,A)') + JDO140,NINT(PMIN(JDO190,JDO140)), + NINT(PMAX(JDO190,JDO140)), + NPMISS(JDO190,JDO140),COMPLET,AVE1,AVE2, + PSSMIN,PSSMAX,CLABS(JDO140)(1:LENSTR(CLABS(JDO140))) ELSE IF (CTYPS(JDO140).EQ.'S') THEN WRITE (6,'(I4,F7.4,F8.4,I6,F8.2,2F8.1,2F7.2,4X,A)') + JDO140,PMIN(JDO190,JDO140),PMAX(JDO190,JDO140), + NPMISS(JDO190,JDO140),COMPLET,AVE1,AVE2, + PSSMIN,PSSMAX,CLABS(JDO140)(1:LENSTR(CLABS(JDO140))) ELSE IF (CTYPS(JDO140).EQ.'W') THEN WRITE (6,'(I4,F7.3,F8.3,I6,F8.2,2F8.3,2F7.2,4X,A)') + JDO140,PMIN(JDO190,JDO140),PMAX(JDO190,JDO140), + NPMISS(JDO190,JDO140),COMPLET,AVE1,AVE2, + PSSMIN,PSSMAX,CLABS(JDO140)(1:LENSTR(CLABS(JDO140))) C C---- other col types but here number greater than 1x,f8 C ELSE IF (PMAX(JDO190,JDO140).GT.999999.5) THEN WRITE (6,'(I4,F8.0,F9.0,I6,F8.2,2F8.0,2F7.2,4X,A)') + JDO140,PMIN(JDO190,JDO140),PMAX(JDO190,JDO140), + NPMISS(JDO190,JDO140),COMPLET,AVE1,AVE2, + PSSMIN,PSSMAX,CLABS(JDO140)(1:LENSTR(CLABS(JDO140))) ELSE C C---- other col types but numbers fit into f8.1 C WRITE (6,'(I4,F7.1,F8.1,I6,F8.2,2F8.1,2F7.2,4X,A)') + JDO140,PMIN(JDO190,JDO140),PMAX(JDO190,JDO140), + NPMISS(JDO190,JDO140),COMPLET,AVE1,AVE2, + PSSMIN,PSSMAX,CLABS(JDO140)(1:LENSTR(CLABS(JDO140))) END IF END IF 145 CONTINUE WRITE (6,6009) JDO190, NPREFL(JDO190) 6009 FORMAT (//,' No. of reflections used in partial', + ' statistics for resolution bin',I3,' = ',I6,//) 190 CONTINUE 195 CONTINUE C C---- If zero reflections, then only summary required, so finished C IF (LINMAX.EQ.0) THEN CALL CCPERR(0,' NO REFLECTIONS LISTED') END IF END IF C IF (LINMAX.EQ.-1) LINMAX = NREFLX IF (LINMAX.LT.-1) LINMAX = -LINMAX C C---- Output the reflections - in a fixed format C C---- First rewind the file C C ************* CALL LRREWD(MTZIN) C ************* C WRITE (6,'(/,A)') ' LIST OF REFLECTIONS' WRITE (6,'(A,/)') ' ===================' NREFL = 0 JCOUNT = 0 150 CONTINUE C C ***************************** CALL LRREFL(MTZIN,RESOL,ADATA,EOF) C ***************************** C IF (.NOT.EOF) THEN NREFL = NREFL + 1 IF(NREFL.LE.NSKIP) GO TO 150 C IF ( LOGRES .AND. + (RESOL .LT. SMIN .OR. RESOL .GT. SMAX)) GO TO 150 C C ******************** CALL LRREFM(MTZIN,LOGMSS) C ******************** C DO 160 JDO160 = 1,3 IHKL(JDO160) = NINT(ADATA(JDO160)) 160 CONTINUE C IF (.NOT.MSTART) THEN C DO 170 JDO170 = 1,3 IF (IHKL(JDO170).NE.JHSTRT(JDO170)) GO TO 150 170 CONTINUE C MSTART = .TRUE. END IF C JCOUNT = JCOUNT + 1 IF (JCOUNT.LE.LINMAX) THEN C C---- Different output format if standard or multi-record C IF (NBATX.GT.0) THEN IF (LOGMSS(4)) THEN WRITE(6,FMT='(/,A,A,/)') + ' *** WARNING: M/ISYM is flagged as missing,', + ' something is wrong. ***' IMI = 0 ELSE IMI = NINT(ADATA(4)) ENDIF IF (LOGMSS(5)) THEN WRITE(6,FMT='(/,A,A,/)') + ' *** WARNING: BATCH is flagged as missing,', + ' something is wrong ***' IBN = 0 ELSE IBN = NINT(ADATA(5)) ENDIF C DO 180 JDO180=6,NCOLS IF (LOGMSS(JDO180)) THEN OUTSTR(JDO180) = MNF IF(LOGVALM) THEN ADATA(JDO180) = VALM WRITE(OUTSTR(JDO180),8000) ADATA(JDO180) END IF C ELSE IF (ADATA(JDO180) .LT. 1.0E+06) THEN WRITE(OUTSTR(JDO180),8000) ADATA(JDO180) ELSE IF (ADATA(JDO180) .LT. 1.0E+07) THEN WRITE(OUTSTR(JDO180),8002) ADATA(JDO180) ELSE WRITE(OUTSTR(JDO180),8004) ADATA(JDO180) ENDIF ENDIF 180 CONTINUE IF(LOGFRMAT)THEN WRITE (6,FRMAT) IHKL, IMI, IBN, (ADATA(J),J=6,NCOLS) ELSE WRITE (6,6003) IHKL, IMI, IBN, (OUTSTR(J),J=6,NCOLS) END IF C C---- mod for agrovata o/p (old) for 3 records, column 4 = M/ISYM C but is really record C counter and has values C 0,1,2 so format 6002 C is incorrect C ELSE IF (CTYPS(4).EQ.'Y') THEN IF (LOGMSS(4)) THEN WRITE(6,FMT='(/,A,A,/)') + ' *** WARNING: M/ISYM is flagged as missing,', + ' something is wrong. ***' MISYM = 0 ELSE MISYM = NINT(ADATA(4)) ENDIF DO 200 JDO200 = 5,NCOLS IF (LOGMSS(JDO200)) THEN OUTSTR(JDO200) = MNF IF(LOGVALM) THEN ADATA(JDO200) = VALM WRITE(OUTSTR(JDO200),8000) ADATA(JDO200) END IF ELSE IF (ADATA(JDO200) .LT. 1.0E+06) THEN WRITE(OUTSTR(JDO200),8000) ADATA(JDO200) ELSE IF (ADATA(JDO200) .LT. 1.0E+07) THEN WRITE(OUTSTR(JDO200),8002) ADATA(JDO200) ELSE WRITE(OUTSTR(JDO200),8004) ADATA(JDO200) ENDIF ENDIF 200 CONTINUE IF(LOGFRMAT)THEN WRITE (6,FRMAT) IHKL, MISYM, (ADATA(J),J=5,NCOLS) ELSE WRITE (6,6022) IHKL, MISYM, (OUTSTR(J),J=5,NCOLS) END IF C C---- allow for there still being an S column, though this will go C ELSE IF (CTYPS(4).EQ.'S') THEN DO 210 JDO210 = 4,NCOLS IF (LOGMSS(JDO210)) THEN OUTSTR(JDO210) = MNF IF(LOGVALM) THEN ADATA(JDO210) = VALM WRITE(OUTSTR(JDO210),8000) ADATA(JDO210) END IF ELSE IF (ADATA(JDO210) .LT. 1.0E+06) THEN WRITE(OUTSTR(JDO210),8000) ADATA(JDO210) ELSE IF (ADATA(JDO210) .LT. 1.0E+07) THEN WRITE(OUTSTR(JDO210),8002) ADATA(JDO210) ELSE WRITE(OUTSTR(JDO210),8004) ADATA(JDO210) ENDIF ENDIF 210 CONTINUE IF(LOGFRMAT)THEN WRITE (6,FRMAT) IHKL, (ADATA(J),J=4,NCOLS) ELSE WRITE (6,6002) IHKL, (OUTSTR(J),J=4,NCOLS) END IF ELSE IF (LRESOL) THEN DO 220 JDO220 = 4,NCOLS IF (LOGMSS(JDO220)) THEN OUTSTR(JDO220) = MNF IF(LOGVALM) THEN ADATA(JDO220) = VALM WRITE(OUTSTR(JDO220),8000) ADATA(JDO220) END IF ELSE IF (ADATA(JDO220) .LT. 1.0E+06) THEN WRITE(OUTSTR(JDO220),8000) ADATA(JDO220) ELSE IF (ADATA(JDO220) .LT. 1.0E+07) THEN WRITE(OUTSTR(JDO220),8002) ADATA(JDO220) ELSE WRITE(OUTSTR(JDO220),8004) ADATA(JDO220) ENDIF ENDIF 220 CONTINUE IF(LOGFRMAT)THEN WRITE (6,FRMAT) IHKL, RESOL, (ADATA(J),J=4,NCOLS) ELSE WRITE (6,6002) IHKL, RESOL, (OUTSTR(J),J=4,NCOLS) END IF ELSE DO 230 JDO230 = 4,NCOLS IF (LOGMSS(JDO230)) THEN OUTSTR(JDO230) = MNF IF(LOGVALM) THEN ADATA(JDO230) = VALM WRITE(OUTSTR(JDO230),8000) ADATA(JDO230) END IF ELSE IF (ADATA(JDO230) .LT. 1.0E+06) THEN WRITE(OUTSTR(JDO230),8000) ADATA(JDO230) ELSE IF (ADATA(JDO230) .LT. 1.0E+07) THEN WRITE(OUTSTR(JDO230),8002) ADATA(JDO230) ELSE WRITE(OUTSTR(JDO230),8004) ADATA(JDO230) ENDIF ENDIF 230 CONTINUE IF(LOGFRMAT)THEN WRITE (6,FRMAT) IHKL, (ADATA(J),J=4,NCOLS) ELSE WRITE (6,6005) IHKL, (OUTSTR(J),J=4,NCOLS) END IF ENDIF END IF GO TO 150 END IF END IF C CALL CCPERR(0,' Normal termination of mtzdump') C C---- Format statements C 6002 FORMAT (' ',3I4,2X,F7.5,5(1X,A9),15 (/,22X,5 (1X,A9))) 6022 FORMAT (' ',3I4,2X,I6,5(1X,A9),15 (/,21X,5 (1X,A9))) 6003 FORMAT (' ',3I4,1X,I4,I6,1X,4 (A9,1X),15 (/,25X,4 (A9,1X))) 6005 FORMAT (' ',3I4,2X,6(1X,A9),15 (/,15X,6(1X,A9))) 6008 FORMAT (//,' No. of reflections used in FILE STATISTICS',I9,//) 8000 FORMAT (F9.2) 8002 FORMAT (F9.1) 8004 FORMAT (F9.0) C END C C SUBROUTINE PRBHDR(INDEX,IBATCH,LORFLG) C ======================================== C C Print out batch header for MTZ file opened with INDEX C C If LORFLG .true., print orientation block C Dummy storage for batch header information in INTEGER DUMMY(146) C C C INTEGER MBLENG,CBLENG PARAMETER (MBLENG=185,CBLENG=70+3*8) C C C .. Scalar Arguments .. INTEGER IBATCH,INDEX LOGICAL LORFLG C .. C .. Local Scalars .. INTEGER IPRINT C .. C .. Local Arrays .. REAL DUMMY(MBLENG) CHARACTER CDUMMY*(CBLENG) C .. C .. External Subroutines .. EXTERNAL LRBAT C .. C C C IF (LORFLG) THEN IPRINT = 2 ELSE IPRINT = 1 END IF C C *************************************** CALL LRBAT(INDEX,IBATCH,DUMMY,CDUMMY,IPRINT) C *************************************** C END