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 Converted to MTZ from LCF data file format C C Date: Thu Sep 12 14:51:29 BST 1991 C C The development of the MTZ files and associated software mark 1 C is part of the masterplan of the ESF/EACBM Working Group 2.1 for C better Protein Crystallographic software for Europe. C C************************************************************** C C ================ PROGRAM MTZUTILS C ================ C C---- this file contains the following subroutines: C C MAKCOL.f CLOSIT.f PCOCAT.f GENEDT.f C keyin.f PRMERG.f mtzutils.f onedsn.f C OPENIP.f OPENOP.f PROOPT.f setout.f C PRUNIQ.f WRBATS.f utilini.f sortini.f C chkres.f C C--------- description of Key_Worded Input -------------- C ================================ C C (i) SYMMETRY space_group_name (optional) C calls RDSYMM C C (ii) HISTORY "string" (optional) C Added to existing history, in order C Key_Word History C File_Number_1 History C File_Number_2 History C up until MAXHIS reached C C (iii) RUN (GO, END) [Compulsory] C C (iv) EXCLUDE (optional) C C Examples: C EXCLUDE Tom Dick Harry # ==> from File_Number_1 C EXCLUDE 1 Tom Dick Harry # ==> from File_Number_1 C EXCLUDE 2 Tom Dick Harry # ==> from File_Number_2 C C (v) INCLUDE (optional) C C Examples: C INCLUDE Tom Dick Harry # ==> from File_Number_1 C INCLUDE 1 Tom Dick Harry # ==> from File_Number_1 C INCLUDE 2 Tom Dick Harry # ==> from File_Number_2 C INCLUDE # ==> ALL columns from File_Number_1 C INCLUDE ALL # ==> ALL columns from File_Number_1 C INCLUDE 1 ALL # ==> ALL columns from File_Number_1 C INCLUDE 2 ALL # ==> ALL columns from File_Number_2 C C (vi) TITLE (optional) C C Examples: C TITLE 1 NOCHANGE C TITLE 2 NOCHANGE C TITLE NOCHANGE # ==> from File_Number_1 C TITLE REPLACE "string" # ==> from File_Number_1 C TITLE 1 REPLACE "string" # ==> from File_Number_1 C TITLE 2 REPLACE "string" # ==> from File_Number_2 C TITLE ADD "string" # ==> from File_Number_1 C TITLE 1 ADD "string" # ==> from File_Number_1 C TITLE 2 ADD "string" # ==> from File_Number_2 C C (vii) COLUMN_LABELS (optional) C C Examples: C C COLUMN_LABELS Tom=Heuy Dick=Dewey Harry=Leuy # ==> from File_Number_1 C COLUMN_LABELS 1 Tom=Heuy Dick=Dewey Harry=Leuy # ==> from File_Number_1 C COLUMN_LABELS 2 Tom=Heuy Dick=Dewey Harry=Leuy # ==> from File_Number_2 C C For MERGE option - NO column editing allowed C C (viii) SORT_ORDER h,k,l (optional) C input a combination of the strings H, K, and L C ******* This is stored but not-currently used ****** C C (ix) CELL at least a,b,c (alpha,beta,gamma default to 90.00) C (replace with RDCELL in code later) (optional) C C (x) ONEFILE This has to be compulsory if only one file C being used with exclude/include C C (xi) HEADER "string" [OPTIONAL INPUT] Printing mTZ info C string is one of the following; C C NONE sets MTZPRT = 0 (default) no header o/p C BRIEF sets MTZPRT = 1 brief header o/p C HIST sets MTZPRT = 2 brief + mtz history C ALL sets MTZPRT = 3 full header o/p from mtz reads C C (xii) RESOLUTION resmin resmax (any order) OR smin smax (any order) C resolution limits for output file. C C (xiii) COLTYPS (NOT Yet Coded - for editing Column_types) C C (xiv) AXIS - Restricts output to various zones/axes (used in C conjunction with the ZONE card (qv) C Inputs to the AXIS card are:- C H00 0K0 00L HH0 -HH0 HHH (Possible Axes) C and/or HK0 0KL H0L HHL Projections C C (xv) RZONE now coded to read in eg C C +h +k +l = 3n C l = 2n + 1 C C (xvi) SCALE: Code added March 1994 ( H. Terry EMBL Hamburg) C Allows user to scale columns by an input value. Useful C when pre-scaling data sets from different sources e.g. c from mosflm and denzo. This scale option should be used in c preference to the scale option in CAD when you want to scale c records that are in a multi-record MTZ file (those with batch c information) c C Examples are as follows: C C SCALE ALL I 3.0 -- scales all intensities in the input file by 3.0 C (intensities are column type J so you could also say SCALE ALL J.. c instead of above) c SCALE ALL F 3.0 -- scales all column types of F by the value given c SCALE ALL D -1 C c At the moment only F's and Intensities (J's) are allowed to be c scaled and column types D are allowed to have their signs changed c (ie scaled by -1) c c The SCALE ALL method will also attempt to scale the sigmas c associated with the Intensities/Amplitudes and ,where necessary c the anomalous differences and their sigmas too. (not tested too c much) - you should probably check the output to see if the program c has picked up the correct labels. It expects the sigmas etc to be c in specific column positions with respect to the F|J column. C c SCALE I SIGI 4.0 IPR 5.0 c This will scale columns labelled I and SIGI by 4.0 and the column c IPR by 5.0. No attempt will be made to find a sigma associated c with the IPR column label. You will, however, get a warning that c scaling a column without its sigma produces rubbish. c C You may only scale column types F or J or D or Q. Any other c columns will be monitored and rejected (at the moment the program c will stop if it encounters an invalid column). c C **************************************************************** c *Also the SCALE option is only available together with ONEFILE.* C **************************************************************** C C Then One of the following: C C UNIQUE C CONCAT C MERGE C C Where: C C UNIQUE == >> C This file control option speficies that each column of the two C input files with a unique label is to be copied to the output C file and that, whenever a particular reflection appears in both C the input files, the data should be merged into a single record C of the output file. C C CONCAT == >> C This file control option specifies that the data records of the C two input files are to be copied to the output file. The option C is used to create a multiple record type output file from the two C input files by merging them. C C MERGE == >> NO column editing allowed C This option creates a multi-record type merged MTZ file from two C input MTZ files. The columns in the two input files need not be C identical. The column labels in the output file will be the C common labels from the two files, the unique labels from file 1 C and the unique labels from file 2. C C**************** IMPORTANT NOTE C ============== C C FOR Column Editing FIRST for assignments as a user doing C File_1 H K L A B C File_2 H K L A C C using Key_Words as : C COLU 2 A=D C INCLUDE 1 A B C INCLUDE 2 D C C I can only see how to do this by including the edited columns C cant think --- therefore this is DIFFERENT to LCFUTILS C as in the lcf version include/exclude is on original names C HERE include/exclude is on EDITED names ??????? C C----------------------- end of key_word description ------------- C C----EXAMPLES: C ======== C C===================== mtzutils/unique.command script =============== C C #!/bin/csh -f C # C mtzutils.exe hklin1 fvb_f.mtz \ C hklin2 2hfl_vhsearch.mtz \ C hklout unique.mtz \ C << 'eof-mtzutils' C HISTORY testing unique C CELL 86.16 111.93 71.71 90.0 90.0 90.0 C HEADER ALL C UNIQUE C RUN C 'eof-mtzutils' C # C C============================ selected o/p from mtzutils/unique.log === C C Data line--- HISTORY testing unique C Data line--- CELL 86.16 111.93 71.71 90.0 90.0 90.0 C Data line--- HEADER ALL C Data line--- UNIQUE C Data line--- RUN C C Logical name: HKLIN1, Full name: /ccpe0/kxh/mtz/work/fvb_f.mtz C * Number of Columns = 9 C * Number of Reflections = 43712 C * Column Labels, Types, and Ranges : C C H H 0 42 C K H 0 55 C L H 0 33 C S S 0.0052 0.2443 C fvb_F F 0.0000 30693.3945 C fvb_SIGF Q 0.0000 1272.6178 C fvb_DANO D -15652.7822 12279.1895 C fvb_SIGDANO Q 0.0000 1330.2162 C ISYM Y 0 2 C C * Cell Dimensions : C 86.16 111.93 71.71 90.00 90.00 90.00 C C Logical name: HKLIN2, Full name: /ccpe0/kxh/mtz/work/2hfl_vhsearch.mtz C * Number of Columns = 6 C * Number of Reflections = 11287 C * Column Labels, Types, and Ranges : C C H H -17 17 C K H -17 17 C L H 0 17 C S S 0.0002 0.0624 C 2hfl_F F 1.8081 4529.9521 C 2hfl_PHCAL P -179.9908 179.9869 C C * Cell Dimensions : C 70.00 70.00 70.00 90.00 90.00 90.00 C C Logical name: HKLOUT, Full name: /ccpe0/kxh/mtz/work/unique.mtz C C Number of Columns in 1st input file 1 = 9 C Number of Columns in 2st input file 2 = 6 C C Number of reflections common to both files: 2975 C Total number of reflections forwarded to output file: 52024 C C * Number of Columns = 11 C * Number of Reflections = 52024 C * Column Labels, Types, and Ranges : C C H H -17 42 C K H -17 55 C L H 0 33 C S S 0.0000 0.0611 C 2hfl_F F 0.0000 4529.9526 C 2hfl_PHCAL P -179.9908 179.9869 C fvb_F F 0.0000 30693.3945 C fvb_SIGF Q 0.0000 1272.6178 C fvb_DANO D -15652.7822 12279.1895 C fvb_SIGDANO Q 0.0000 1330.2162 C ISYM Y 0 2 C C * Cell Dimensions : C 86.16 111.93 71.71 90.00 90.00 90.00 C C====================end of example for mtzutils/unique.log ================ C C==================== command script for unique/col_edt ======= C C #!/bin/csh -f C # C setenv SYMOP {$LIBD}symop.lib C mtzutils.exe hklin1 fvb_f.mtz \ C hklin2 2hfl_vhsearch.mtz \ C hklout unique.mtz \ C << 'eof-mtzutils' C SYMMETRY P21212 C HISTORY testing unique C CELL 86.16 111.93 71.71 90.0 90.0 90.0 C HEADER ALL C COLUMNS fvb_F=tom fvb_SIGF=Harry C COLUMNS 2 2hfl_F=DiCK C UNIQUE C RUN C 'eof-mtzutils' C # C C==================== selected log file for unique/col_edt ======= C C Data line--- SYMMETRY P21212 C Data line--- HISTORY testing unique C Data line--- CELL 86.16 111.93 71.71 90.0 90.0 90.0 C Data line--- HEADER ALL C Data line--- COLUMNS fvb_F=tom fvb_SIGF=Harry C Data line--- COLUMNS 2 2hfl_F=DiCK C Data line--- UNIQUE C Data line--- RUN C C Logical name: HKLIN1, Full name: /ccpe0/kxh/mtz/work/fvb_f.mtz C C * Number of Columns = 9 C * Number of Reflections = 43712 C * Column Labels, Types, and Ranges : C C H H 0 42 C K H 0 55 C L H 0 33 C S S 0.0052 0.2443 C fvb_F F 0.0000 30693.3945 C fvb_SIGF Q 0.0000 1272.6178 C fvb_DANO D -15652.7822 12279.1895 C fvb_SIGDANO Q 0.0000 1330.2162 C ISYM Y 0 2 C C * Cell Dimensions : C 86.16 111.93 71.71 90.00 90.00 90.00 C C Logical name: HKLIN2, Full name: /ccpe0/kxh/mtz/work/2hfl_vhsearch.mtz C C * Number of Columns = 6 C * Number of Reflections = 11287 C * Column Labels, Types, and Ranges : C C H H -17 17 C K H -17 17 C L H 0 17 C S S 0.0002 0.0624 C 2hfl_F F 1.8081 4529.9521 C 2hfl_PHCAL P -179.9908 179.9869 C C * Cell Dimensions : C 70.00 70.00 70.00 90.00 90.00 90.00 C C Logical name: HKLOUT, Full name: /ccpe0/kxh/mtz/work/unique.mtz C C Number of reflections common to both files: 2975 C Total number of reflections forwarded to output file: 52024 C C * Number of Columns = 11 C * Number of Reflections = 52024 C * Column Labels, Types, and Ranges : C C H H -17 42 C K H -17 55 C L H 0 33 C S S 0.0000 0.0611 C DiCK F 0.0000 4529.9526 C 2hfl_PHCAL P -179.9908 179.9869 C tom F 0.0000 30693.3945 C Harry Q 0.0000 1272.6178 C fvb_DANO D -15652.7822 12279.1895 C fvb_SIGDANO Q 0.0000 1330.2162 C ISYM Y 0 2 C C * Cell Dimensions : C 86.16 111.93 71.71 90.00 90.00 90.00 C C==================== end of example log file for unique/col_edt ======= C C .. Scalars in Common .. INTEGER LUNIN,LUNOUT,MTZERR,MTZIN1,MTZIN2,MTZOUT,MTZPRT C .. C .. Local Scalars .. INTEGER IFAIL,LDUM C .. C .. External Subroutines .. EXTERNAL MAKCOL,CCPFYP,CCPOPN,CCPRCS,CLOSIT, + GENEDT,KEYIN,MTZINI,OPENIP, + OPENOP,PROOPT,UTILINI C .. C .. Common blocks .. COMMON /U_INOUT/ + LUNIN, LUNOUT, MTZIN1, MTZIN2, MTZOUT, + MTZPRT, MTZERR C .. C C---- open files and print version C IFAIL = 0 LDUM = 80 C C *************************************** CALL CCPFYP CALL MTZINI CALL UTILINI CALL CCPOPN(LUNIN,'DATA',5,1,LDUM,IFAIL) CALL CCPOPN(LUNOUT,'PRINTER',6,1,LDUM,IFAIL) CALL CCPRCS(LUNOUT,'MTZUTILS','$Date: 2002/08/06 11:02:33 $') CALL KEYIN CALL OPENIP CALL GENEDT CALL MAKCOL CALL OPENOP CALL PROOPT CALL CLOSIT CALL CCPERR(0,'Normal termination') C *************************************** C END C C ================ SUBROUTINE KEYIN C ================ C c c implicit none C C C .. Parameters .. INTEGER NPARM PARAMETER (NPARM=200) INTEGER MAXSYM PARAMETER (MAXSYM=192) INTEGER MAXHIS PARAMETER (MAXHIS=30) INTEGER MCOLS PARAMETER (MCOLS=500) INTEGER MFILES_IN PARAMETER (MFILES_IN=2) INTEGER MAXZON PARAMETER (MAXZON=20) integer maxsc parameter (maxsc=12) C .. C .. Scalars in Common .. INTEGER LUNIN, LUNOUT, MTZERR, MTZIN1, MTZIN2, + MTZOUT, MTZPRT, NISYM_NEW,NLAUE_NEW, NMAT_NEW, + NSPGRP_NEW,NSYMP_NEW,NSYM_NEW, NUM_NEW_HIST REAL RESMIN, RESMAX, SMIN, SMAX LOGICAL DO_CONCAT, DO_MERGE, DO_NEW_CELL, + DO_NEW_HIST, DO_NEW_SORT, DO_NEW_SYMM, + DO_ONE_FILE, DO_S_NEW, DO_TWO_FILES, + DO_UNIQUE, LOGRES CHARACTER LATTYP_NEW*1, LAUNAM_NEW*10, + NAMSPG_NEW*10, PGNAME_NEW*10 C .. C .. Arrays in Common .. REAL CELL_NEW, RSYMT_NEW, RSYM_NEW INTEGER ISYMM_NEW, ISYMST_NEW, ISYM_NEW, LMSYM_NEW, + MSORTX_NEW, NSYMOP_NEW, NUM_EDIT_COLS, NUM_EXC_COLS, + NUM_INC_COLS LOGICAL DO_EDT_COL_NAMES, DO_EDT_TITLE, + DO_EXCLUDE, DO_INCLUDE, + DO_INC_ALL, FOUND_SYM, + SFOUND CHARACTER EDT_TITLE_MODE*4, EXC_COL_LABELS*30, + INC_COL_LABELS*30, NEW_COL_NAMES*30, + OLD_COL_NAMES*30, NEW_TITLE*70, + NEW_HIST*80 C .. C .. Local Scalars .. INTEGER I,IA,IC,IFILE,IERR,II,ISTART,ITEMP,ITEST,IWORK,IX, + IY,IP,JDO20,JDO25,JDO30, + JDO40,JDO50,JDO70,JDO4000,MTZBPR,NTOK REAL scal_inp LOGICAL LEND,NUM_FILES,inchar,firstch CHARACTER CWORK*4,KEY*4,LINE*400,H2*10 C .. C .. Local Arrays .. REAL FVALUE(NPARM) INTEGER IBEG(NPARM),IDEC(NPARM),IEND(NPARM),ITYP(NPARM) CHARACTER CHKL(3)*3,CVALUE(NPARM)*4 C .. C .. External Functions .. INTEGER LENSTR EXTERNAL LENSTR C .. C .. External Subroutines .. EXTERNAL CCPUPC,PARSER,RDSYMM C .. C .. Intrinsic Functions .. INTRINSIC MOD,NINT C .. C .. Common blocks .. COMMON /CHR_UTILS/ + INC_COL_LABELS(MCOLS,MFILES_IN), + EXC_COL_LABELS(MCOLS,MFILES_IN), + EDT_TITLE_MODE(MFILES_IN), + NEW_HIST(MAXHIS),NEW_TITLE(MFILES_IN), + OLD_COL_NAMES(MCOLS,MFILES_IN), + NEW_COL_NAMES(MCOLS,MFILES_IN) COMMON /CNEW_SYMM/ + PGNAME_NEW, NAMSPG_NEW, LAUNAM_NEW, LATTYP_NEW COMMON /INT_UTILS/ + NUM_INC_COLS(MFILES_IN), + NUM_EXC_COLS(MFILES_IN), + NUM_EDIT_COLS(MFILES_IN), + NUM_NEW_HIST, + MSORTX_NEW(5) COMMON /LOG_UTILS/ + DO_INCLUDE(MFILES_IN), + DO_INC_ALL(MFILES_IN), + DO_EXCLUDE(MFILES_IN), + DO_EDT_TITLE(MFILES_IN), + DO_EDT_COL_NAMES(MFILES_IN), + FOUND_SYM(MFILES_IN), + SFOUND(2), + DO_MERGE, DO_NEW_SORT, DO_CONCAT, + DO_UNIQUE, DO_NEW_CELL, DO_S_NEW, + DO_NEW_HIST, DO_TWO_FILES, DO_NEW_SYMM, + DO_ONE_FILE COMMON /REL_UTILS/ CELL_NEW(6) COMMON /UNEW_SYMM/ + NSPGRP_NEW, NSYM_NEW, NSYMP_NEW, + NLAUE_NEW, NISYM_NEW, NMAT_NEW, + ISYMST_NEW(MAXSYM), + LMSYM_NEW(MAXSYM), + NSYMOP_NEW(MAXSYM), + ISYMM_NEW(9,MAXSYM), + ISYM_NEW(9,MAXSYM), + RSYM_NEW(4,4,MAXSYM), + RSYMT_NEW(4,4,MAXSYM) COMMON /U_INOUT/ + LUNIN, LUNOUT, MTZIN1, MTZIN2, MTZOUT, + MTZPRT, MTZERR COMMON /RESOLN/ + RESMIN, RESMAX, SMIN, SMAX COMMON /RESCOM/ + LOGRES C logical do_scal,scale_all_f,scale_all_i,reverse_anom common /log_scal/ + do_scal,scale_all_f,scale_all_i,reverse_anom C character scal_col_label(maxsc)*30,scal_col_type(maxsc)*1 common /chr_scal/ + scal_col_label,scal_col_type C integer n_scal_col,iscol(maxsc) real scal_val(maxsc),scal_all common /num_scal/ + scal_val,scal_all,n_scal_col,iscol C LOGICAL LOGZON INTEGER IRZONE,KEYZON,NZON,IFOUND,KZSCR,NRECZO CHARACTER ZONCHR*30 COMMON /CHRZON/ ZONCHR(MAXZON) COMMON /ZONCOM/ + IRZONE(MAXZON,5),KEYZON(MAXZON),NZON(MAXZON), + IFOUND,LOGZON,KZSCR(MAXZON), + NRECZO(MAXZON) C .. C .. Save statement .. SAVE C .. C .. Data statements .. DATA CHKL /'H','K','L'/ DATA NUM_FILES /.FALSE./ C .. C C--- Set variables = 0 DO 1 I = 1,MAXZON IRZONE(I,1) = 0 IRZONE(I,2) = 0 IRZONE(I,3) = 0 IRZONE(I,4) = 0 IRZONE(I,5) = 0 KEYZON(I) = 0 KZSCR(I) = 0 NRECZO(I) = 0 NZON(I) = 0 1 CONTINUE C---- Read key-worded input C 10 CONTINUE C C NTOK = NPARM KEY = ' ' LINE = ' ' C C C ************************************************************ CALL PARSER(KEY,LINE,IBEG,IEND,ITYP,FVALUE,CVALUE,IDEC,NTOK,LEND, + .TRUE.) C ************************************************************ C C---- End of file? C IF (LEND) GO TO 100 C C ======== C---- SYMMETRY C ======== C C IF (KEY.EQ.'SYMM') THEN IWORK = 2 C C ********************************************************* CALL RDSYMM(IWORK,LINE,IBEG,IEND,ITYP,FVALUE,NTOK,NAMSPG_NEW, + NSPGRP_NEW,PGNAME_NEW,NSYM_NEW,NSYMP_NEW,RSYM_NEW) C ********************************************************* C DO_NEW_SYMM = .TRUE. GO TO 10 C C ================ C---- HISTORY "string" C ================ C C History strings to be added to mtz o/p file HKLOUT C C ELSE IF (KEY.EQ.'HIST') THEN NUM_NEW_HIST = NUM_NEW_HIST + 1 C C IF (NUM_NEW_HIST.GT.MAXHIS) THEN WRITE (LUNOUT,FMT=6000) MAXHIS 6000 FORMAT (' Sorry HISTORY now full no more lines accepted',/, + ' ONLY ',I6,' Lines of HISTORY ALLOWED') NUM_NEW_HIST = NUM_NEW_HIST - 1 GO TO 10 END IF C C ITEST = LENSTR(LINE) IF (ITEST.GT.80) ITEST = 80 NEW_HIST(NUM_NEW_HIST) = LINE(IBEG(1) :ITEST) DO_NEW_HIST = .TRUE. GO TO 10 C C ============= C---- RUN (GO, END) C ============= C ELSE IF (KEY.EQ.'RUN' .OR. KEY.EQ.'GO' .OR. KEY.EQ.'END') THEN GO TO 100 C C ======= C---- EXCLUDE C ======= C C Examples: C EXCLUDE Tom Dick Harry # ==> from File_Number_1 C EXCLUDE 1 Tom Dick Harry # ==> from File_Number_1 C EXCLUDE 2 Tom Dick Harry # ==> from File_Number_2 C ELSE IF (KEY.EQ.'EXCL') THEN C C---- Check number of tokens on the line C IF (NTOK.LE.1) THEN WRITE (LUNOUT,FMT=6002) LINE(1:LENSTR(LINE)) 6002 FORMAT + (' Error in Key_Word EXCLUDE, not enough tokens on line', + /' Ignoring Line >> ',A) GO TO 10 END IF C C---- Check if second token is an Integer, C If not then this line is for File_Number_1 C C ITYP(I) =0 null field C =1 character string C =2 number C IF (ITYP(2).EQ.2) THEN IWORK = NINT(FVALUE(2)) C C IF (IWORK.EQ.1 .OR. IWORK.EQ.2) GO TO 222 WRITE (LUNOUT,FMT=6004) LINE(1:LENSTR(LINE)) 6004 FORMAT (' Error for Key_Word EXCLUDE, File_Number Not Correct' + ,/' Ignoring Line >> ',A) GO TO 10 222 CONTINUE C C IFILE = IWORK ISTART = 3 ELSE IFILE = 1 ISTART = 2 END IF C C IF (ISTART.GT.NTOK) THEN WRITE (LUNOUT,FMT=6006) LINE(1:LENSTR(LINE)),istart 6006 FORMAT (' Error for Key_Word EXCLUDE, wrong number of tokens', + /' Ignoring this line >> ',A,' istart = ',i4) GO TO 10 END IF C C---- Test if valid file_number C IF (IFILE.EQ.1 .OR. IFILE.EQ.2) GO TO 444 WRITE (LUNOUT,FMT=6112) LINE(1:LENSTR(LINE)) 6112 FORMAT (' Error for Key_Word EXCLUDE, File_Number Not Correct', + /' Ignoring Line >> ',A) GO TO 10 444 CONTINUE C C DO_EXCLUDE(IFILE) = .TRUE. DO_INCLUDE(IFILE) = .FALSE. DO_INC_ALL(IFILE) = .FALSE. C C DO 20 JDO20 = ISTART,NTOK NUM_EXC_COLS(IFILE) = NUM_EXC_COLS(IFILE) + 1 C C IF (NUM_EXC_COLS(IFILE).GT.MCOLS) THEN WRITE (LUNOUT,FMT=6008) IFILE,MCOLS 6008 FORMAT + (' Error for Key_Word_EXCLUDE: ', + 'Too many columns requested',/ + ' For File_Number =',I2,' + Only >> ',I6,' Columns Allowed') C C ************************************* CALL CCPERR(1,' STOP in EXCLUDE Option') C ************************************* C END IF C C EXC_COL_LABELS(NUM_EXC_COLS(IFILE), + IFILE) = LINE(IBEG(JDO20) :IEND(JDO20)) 20 CONTINUE C C GO TO 10 C C ======= C---- INCLUDE C ======= C C Examples: C INCLUDE Tom Dick Harry # ==> from File_Number_1 C INCLUDE 1 Tom Dick Harry # ==> from File_Number_1 C INCLUDE 2 Tom Dick Harry # ==> from File_Number_2 C INCLUDE # ==> ALL columns from File_Number_1 C INCLUDE ALL # ==> ALL columns from File_Number_1 C INCLUDE 1 ALL # ==> ALL columns from File_Number_1 C INCLUDE 2 ALL # ==> ALL columns from File_Number_2 C ELSE IF (KEY.EQ.'INCL') THEN C C---- Check number of tokens on the line C If no more tokens then this is for File_Number_1 C and ALL columns to be included C IF (NTOK.LE.1) THEN DO_INC_ALL(1) = .TRUE. DO_INCLUDE(1) = .TRUE. DO_EXCLUDE(1) = .FALSE. GO TO 10 END IF C C---- Check if second token is an Integer, C If not then this line is for File_Number_1 C if = ALL this is also for File_number_1 C C ITYP(I) =0 null field C =1 character string C =2 number C IF (ITYP(2).EQ.1) THEN CWORK = LINE(IBEG(2) :IEND(2)) C C ************* CALL CCPUPC(CWORK) C ************* C IF (CWORK(1:3).EQ.'ALL') THEN DO_INC_ALL(1) = .TRUE. DO_INCLUDE(1) = .TRUE. DO_EXCLUDE(1) = .FALSE. GO TO 10 END IF C C---- 2nd and subsequent token are include column-label(s) C for File_Number_1 C DO_INCLUDE(1) = .TRUE. DO_EXCLUDE(1) = .FALSE. DO_INC_ALL(1) = .FALSE. IFILE = 1 C C DO 25 JDO25=2,NTOK NUM_INC_COLS(1) = NUM_INC_COLS(1) + 1 C C IF (NUM_EXC_COLS(IFILE).GT.MCOLS) THEN WRITE (LUNOUT,FMT=6010) IFILE,MCOLS 6010 FORMAT + (' Error for Key_Word_INCLUDE:', + 'Too many columns requested',/ + ' For File_Number =',I2,' Only >> ',I6, + ' Columns Allowed') C C *********************************** CALL CCPERR(1,' STOP in INCLUDE Option') C *********************************** C END IF C C INC_COL_LABELS(NUM_INC_COLS(1),1) = + LINE(IBEG(JDO25) :IEND(JDO25)) 25 CONTINUE C C GO TO 10 END IF C C IF (ITYP(2).EQ.2) THEN IWORK = NINT(FVALUE(2)) C C IF (IWORK.EQ.1 .OR. IWORK.EQ.2) GO TO 555 WRITE (LUNOUT,FMT=6012) LINE(1:LENSTR(LINE)) 6012 FORMAT (' Error for Key_Word INCLUDE, File_Number Not Correct' + ,/' Ignoring Line >> ',A) GO TO 10 555 CONTINUE C C IFILE = IWORK ISTART = 3 ELSE C C---- Actually can you ever get here ?? C IFILE = 1 ISTART = 2 END IF C C IF (ISTART.GT.NTOK) THEN WRITE (LUNOUT,FMT=6014) LINE(1:LENSTR(LINE)),istart 6014 FORMAT (' Error for Key_Word INCLUDE, wrong number of tokens', + /' Ignoring this line >> ',A,' istart = ',i4) GO TO 10 END IF C C DO_INCLUDE(IFILE) = .TRUE. DO_EXCLUDE(IFILE) = .FALSE. DO_INC_ALL(IFILE) = .FALSE. C C---- First test for ALL and file_number given C CWORK = LINE(IBEG(ISTART):IEND(ISTART)) C C ************* CALL CCPUPC(CWORK) C ************* C IF (CWORK(1:3).EQ.'ALL') THEN DO_INC_ALL(IFILE) = .TRUE. GO TO 10 END IF C C DO 30 JDO30 = ISTART,NTOK NUM_INC_COLS(IFILE) = NUM_INC_COLS(IFILE) + 1 C C IF (NUM_INC_COLS(IFILE).GT.MCOLS) THEN WRITE (LUNOUT,FMT=6016) IFILE,MCOLS 6016 FORMAT + (' Error for Key_Word_INCLUDE: ', + 'Too many columns requested',/ + ' For File_Number = ',I2, + 'Only >> ',I6,' Columns Allowed') C C *********************************** CALL CCPERR(1,' STOP in INCLUDE Option') C ********************************** C END IF C C INC_COL_LABELS(NUM_INC_COLS(IFILE), + IFILE) = LINE(IBEG(JDO30) :IEND(JDO30)) 30 CONTINUE C C GO TO 10 C C ====== C---- UNIQUE C ====== C ELSE IF (KEY.EQ.'UNIQ') THEN DO_UNIQUE = .TRUE. GO TO 10 C C ====== C---- CONCAT C ====== C ELSE IF (KEY.EQ.'CONC') THEN DO_CONCAT = .TRUE. GO TO 10 C C ===== C---- MERGE C ===== C ELSE IF (KEY.EQ.'MERG') THEN DO_MERGE = .TRUE. GO TO 10 C C ===== C---- TITLE C ===== C ELSE IF (KEY.EQ.'TITL') THEN C C---- Check number of tokens on the line C If no more tokens then this is for File_Number_1 C and Default Title_Editing of NOCHANGE used C IF (NTOK.LE.1) THEN DO_EDT_TITLE(1) = .FALSE. EDT_TITLE_MODE(1) = 'NOCH' GO TO 10 END IF C C---- Check if second token is an Integer, C If not then this line is for File_Number_1 C C ITYP(I) =0 null field C =1 character string C =2 number C IF (NTOK.GE.2) THEN IF (ITYP(2).EQ.2) THEN IWORK = NINT(FVALUE(2)) C C IF (IWORK.EQ.1 .OR. IWORK.EQ.2) GO TO 666 WRITE (LUNOUT,FMT=6018) LINE(1:LENSTR(LINE)) 6018 FORMAT + (' Error for Key_Word TITLES, File_Number Not Correct', + /' Ignoring Line >> ',A) GO TO 10 666 CONTINUE C C IFILE = IWORK ISTART = 3 ELSE IFILE = 1 ISTART = 2 END IF C C IF (ISTART.GT.NTOK) THEN WRITE (LUNOUT,FMT=6020) LINE(1:LENSTR(LINE)) 6020 FORMAT (' Error for Key_Word TITLES, wrong number of tokens' + ,/' Ignoring this line >> ',A) GO TO 10 END IF C C C---- Look at next token for Edit_Title_Mode C IF (NTOK.EQ.2) THEN C C---- input - here using TITLE integer C WRITE (LUNOUT,FMT=6022) IFILE 6022 FORMAT (' Warning for Key_Word TITLE, input line',/, + ' Using Default of NO_CHANGE to TITLE',/, + ' For Input File_Number = ',I3) EDT_TITLE_MODE(IFILE) = 'NOCH' GO TO 10 END IF C C CWORK = LINE(IBEG(ISTART) :IEND(ISTART)) C C ************* CALL CCPUPC(CWORK) C ************* C IF (CWORK.EQ.'NOCH') THEN EDT_TITLE_MODE(IFILE) = 'NOCH' DO_EDT_TITLE(IFILE) = .FALSE. ELSE IF (CWORK.EQ.'REPL') THEN EDT_TITLE_MODE(IFILE) = 'REPL' DO_EDT_TITLE(IFILE) = .TRUE. ELSE IF (CWORK(1:3).EQ.'ADD') THEN EDT_TITLE_MODE(IFILE) = 'ADD' DO_EDT_TITLE(IFILE) = .TRUE. ELSE WRITE (LUNOUT,FMT=6024) IFILE,LINE(1:LENSTR(LINE)) 6024 FORMAT (' Error for Key_Word TITLE, for File_number ',I2, + /' Edit_Title_Mode Not Understood, ', + 'Ignoring this line >>', + /A) GO TO 10 END IF C C---- Now pick up new title line C IF (DO_EDT_TITLE(IFILE)) + NEW_TITLE(IFILE) = LINE(IBEG(ISTART+1) :IEND(NTOK)) GO TO 10 ELSE C C---- Here when only one token on line, so for File_Number_1, C default is NO_CHANGE C WRITE (LUNOUT,FMT=6026) LINE(1:LENSTR(LINE)) 6026 FORMAT ( + ' Warning For Key_Word TITLE, Not enough tokens on line', + /,' Ignoring Line >> ',A) END IF GO TO 10 C C ============= C---- COLUMN_LABELS C ============= C C Examples: C C COLUMN_LABELS Tom=Heuy Dick=Dewey Harry=Leuy # ==> from c File_Number_1 C COLUMN_LABELS 1 Tom=Heuy Dick=Dewey Harry=Leuy # ==> from c File_Number_1 C COLUMN_LABELS 2 Tom=Heuy Dick=Dewey Harry=Leuy # ==> from c File_Number_2 C ELSE IF (KEY.EQ.'COLU') THEN C C---- Check number of tokens on line, C must be greater than 2 and depending C on whether File_Number given must be odd/even C IF (NTOK.LE.2) THEN WRITE (LUNOUT,FMT=6028) LINE(1:LENSTR(LINE)) 6028 FORMAT (' Error for Key_Word COLUMN_LABELS',/, + ' Not Enough Tokens on line, Ignoring Line >>',/' ',A) GO TO 10 END IF C C---- If second token NOT an integer then this is C by default for File_Number_1 C IF (ITYP(2).EQ.2) THEN IWORK = NINT(FVALUE(2)) C C IF (IWORK.EQ.1 .OR. IWORK.EQ.2) GO TO 333 WRITE (LUNOUT,FMT=6030) LINE(1:LENSTR(LINE)) 6030 FORMAT (' Error for Key_Word COLUMN_LABELS, ', + ' File_Number Not Correct',/,' Ignoring Line >> ',A) GO TO 10 333 CONTINUE C C IFILE = IWORK ISTART = 3 ELSE IFILE = 1 ISTART = 2 END IF C C---- Now check if enough pairs of tokens given C IWORK = NTOK - ISTART + 1 C C---- Must some more tokens on line C IF (IWORK.LE.0) THEN WRITE (LUNOUT,FMT=6032) LINE(1:LENSTR(LINE)) GO TO 10 END IF C C---- IWORK must be EVEN C ITEST = MOD(IWORK,2) C C IF (ITEST.NE.0) THEN WRITE (LUNOUT,FMT=6032) LINE(1:LENSTR(LINE)) 6032 FORMAT ( + ' Error in Key_Word COLUMN_LABELS,', + 'Incorrect Number of tokens',/, + ' Ignoring this line >> ',/' ',A) GO TO 10 END IF C C DO_EDT_COL_NAMES(IFILE) = .TRUE. C C DO 40 JDO40 = ISTART,NTOK,2 NUM_EDIT_COLS(IFILE) = NUM_EDIT_COLS(IFILE) + 1 C C IF (NUM_EDIT_COLS(IFILE).GT.MCOLS) THEN WRITE (LUNOUT,FMT=6034) IFILE,MCOLS,LINE(1:LENSTR(LINE)) 6034 FORMAT + (' Error with Key_Word COLUMN_LABELS, Too Many columns' + ,/' For File_Number ',I2 + ,' Only a Max number of columns = ',I6,' Allowed', + /' Ignoring this Line >> ',A) NUM_EDIT_COLS(IFILE) = NUM_EDIT_COLS(IFILE) - 1 GO TO 10 END IF C C---- Sort out order of new=old later C OLD_COL_NAMES(NUM_EDIT_COLS(IFILE),IFILE) = + LINE(IBEG(JDO40) :IEND(JDO40)) NEW_COL_NAMES(NUM_EDIT_COLS(IFILE),IFILE) = + LINE(IBEG(JDO40+1) :IEND(JDO40+1)) 40 CONTINUE C C GO TO 10 C C ========== C---- SORT_ORDER C ========== C ELSE IF (KEY.EQ.'SORT') THEN C C---- must be 4 tokens on line C C IF (NTOK.NE.4) THEN WRITE (LUNOUT,FMT=6036) LINE(1:LENSTR(LINE)) 6036 FORMAT (' Error with Key_Word SORT_ORDER, ', + ' Not enough tokens on line',/' Ignoring this line >> ',A + ) GO TO 10 END IF C C IWORK = 0 C C DO 70 JDO70 = 1,3 CWORK = LINE(IBEG(1+JDO70) :IEND(1+JDO70)) C C ************* CALL CCPUPC(CWORK) C ************* C DO 50 JDO50 = 1,3 IF (CWORK(1:1).EQ.CHKL(JDO50)) GO TO 60 50 CONTINUE C C WRITE (LUNOUT,FMT=6038) LINE(1:LENSTR(LINE)) 6038 FORMAT (' Error for Key_Word SORT_ORDER, Line Not Understood', + /' Ignoring this line >> ',A) GO TO 10 C C 60 MSORTX_NEW(JDO70) = JDO50 IWORK = IWORK + JDO50 70 CONTINUE C C IF (IWORK.NE.6) THEN WRITE (LUNOUT,FMT=6040) LINE(1:LENSTR(LINE)) 6040 FORMAT (' Error for Key_Word SORT_ORDER, cant understand it', + /' Ignoring this line >> ',A) ELSE C C DO_NEW_SORT = .TRUE. END IF GO TO 10 C C ======== C---- CELL_NEW C ======== C ELSE IF (KEY.EQ.'CELL') THEN C C *********************************** CALL RDCELL(2,ITYP,FVALUE,NTOK,CELL_NEW) C *********************************** C DO_NEW_CELL = .TRUE. C DO 66 I = 1,6 WRITE(LUNOUT,FMT=64)CELL_NEW(I) 64 FORMAT(' New value for Cell is ',F10.4) 66 CONTINUE C C GO TO 10 C C ======== C---- ONE_FILE This has to be compulsory if only one file C ======== being used with exclude/include C ELSE IF (KEY.EQ.'ONEF') THEN NUM_FILES = .TRUE. GO TO 10 C C ======= C---- HEADER C ======= C ELSE IF (KEY.EQ.'HEAD') THEN C C---- HEADER "string" [OPTIONAL INPUT] Printing mTZ info C C string is one of the following; C C NONE sets MTZPRT = 0 (default) C C no header o/p C C BRIEF sets MTZPRT = 1 C brief header o/p C C HIST sets MTZPRT = 2 C brief + mtz history C C ALL sets MTZPRT = 3 C full header o/p from mtz reads C MTZPRT = 1 C C **************************************** CALL RDHEAD(2,LINE,IBEG,IEND,ITYP,FVALUE,NTOK, + MTZPRT,MTZBPR) C **************************************** C GO TO 10 C C ========== C-----RESOLUTION C ========== C C ELSE IF (KEY.EQ.'RESO') THEN C C ************************************************** CALL RDRESO(2,ITYP,FVALUE,NTOK,RESMIN,RESMAX,SMIN,SMAX) C ************************************************** C LOGRES = .TRUE. WRITE (LUNOUT,FMT=7052) RESMIN,RESMAX,SMIN,SMAX 7052 FORMAT(' Data output will have resolution limits of ',f7.3, + ' and ',f7.3,' A', + /' i.e. limits on 4sin**2/lambda**2 of ',f7.5, + ' and ',f7.5) GO TO 10 C C ======================================================== C---- AXIS output reflection file restricted to given zone(s) C ======================================================== C ELSE IF (KEY.EQ.'AXIS') THEN C IF (NTOK.LE.1) THEN WRITE (LUNOUT,FMT=7054) LINE(1:LENSTR(LINE)) 7054 FORMAT(' Error with Key_Word AXIS ', + ' Not enough tokens on line',/, + ' Ignoring this line >> ',A) GO TO 10 END IF C C ***************************** CALL RDAXIS(2,NTOK,LINE,IBEG,IEND) C ***************************** C LOGZON = .TRUE. GO TO 10 C C ===== C---- RZONE C ===== C ELSE IF (KEY.EQ.'RZON') THEN C C c c IF (NTOK.NE.6) THEN c c WRITE (LUNOUT,FMT=7056) LINE(1:LENSTR(LINE)) c c 7056 FORMAT(' Error with Key_Word RZONE ', c c + ' Should be 6 tokens on this line',/, c c + ' Ignoring this line >> ',A) c c GO TO 10 c c END IF C C IFOUND = IFOUND + 1 IF (IFOUND.GT.MAXZON) + CALL CCPERR(1,' STOP too many axis/zone requests') C C DO 120 JDO20 = 2,NTOK IC = JDO20 - 1 C C ************************************************ CALL GTPINT(JDO20,IRZONE(IFOUND,IC),NTOK,ITYP,FVALUE) C ************************************************ C 120 CONTINUE C C ISTART = 2 IERR = 0 C C ************************************************ c CALL RDZONE(ISTART,IFOUND,NTOK,IERR,IRZONE,IBEG,IEND, c + LINE) C ************************************************ C write(6,*)' ifound irzone ',IFOUND, 1 (IRZONE(ifound,ii),ii=1,5) IF (IERR.EQ.0) THEN LOGZON = .TRUE. ZONCHR(IFOUND) = LINE(IBEG(2):IEND(NTOK)) ELSE IFOUND = IFOUND - 1 END IF C GO TO 10 C C---- SCALE May have one of the following input lines C C 1. SCALE Column_label_1 scale ....Column_label_n scale C 2. SCALE ALL F (or I/J) scale C 3. SCALE ALL D -1 - changes the signs of anomlous values. C C Can only use this option with 'ONEFILE' Can only scale C column types of type F or J (and hopefully their sigmas C get scaled automatically) or can scale columns specifically. C This scaling may produce rubbish, for instance if you scale C some intensity columns but don't input anomalous differences - C not much checking is done for this. C else if (key.eq.'SCAL') then c if (ntok.lt.2) then call ccperr(1,'Error: No information given with scale card') else C do_scal = .true. scale_all_f = .false. scale_all_i = .false. reverse_anom =.false. if (ityp(2).eq.1) then cwork = line(ibeg(2):iend(2)) call ccpupc(cwork) if (cwork(1:3).eq.'ALL') then if (ntok .ne. 4) call ccperr(1, + 'SCALE ALL should have input F[I] scale') C C After ALL should come either an F or an I (J can be used instead C of I as the column type J is an intensity by MTZ laws) or a D if c you want to change the sign of your anomalous data C cwork = line(ibeg(3):iend(3)) call ccpupc(cwork) if (cwork.eq.'F') then scale_all_F = .true. C else if (cwork.eq.'I' .or. cwork.eq.'J') then scale_all_I = .true. C else if (cwork.eq.'D') then reverse_anom = .true. else call ccperr(1, + 'Error on scale input only types F, I|J or D allowed') endif C C Now get the scale value for SCALE ALL C if (ityp(4).eq.2) then scal_all = fvalue(4) C if ( reverse_anom ) then itemp = int(scal_all) if ( itemp .ne. -1 ) then write(6,4004) scal_all 4004 format (' You may only input a value of -1 to', + ' change the anomalous signs.',/ + ' You input ',f7.2) call ccperr(1,'Error on scale input') endif endif C else call ccperr(1, + 'Error: scale value not found') endif C else C C ... so if it's not ALL then the first word after SCALE must be a c column label C istart = 2 if (ityp(istart).ne.1) then call ccperr(1, + 'Error must enter ALL or Label after SCALE') endif C firstch = .true. ix = 0 iy = 0 ip = 1 do 4000 jdo4000 = istart,ntok c if (ityp(jdo4000).eq.1) then inchar = .true. if (firstch) then firstch = .false. endif ix = ix + 1 c if (ix .gt. maxsc) call ccperr(1, + 'Too many labels found for scale') scal_col_label(ix) = + line(ibeg(jdo4000):iend(jdo4000)) C else if (ityp(jdo4000).eq.2) then C C check there are not 2 scale values input together C if (.not. inchar) call ccperr(1, + 'Error inputing scales: found 2 values together') inchar = .false. firstch = .true. iy = iy + 1 if (iy .gt. maxsc) call ccperr(1, + 'Too many labels found for scale') scal_inp = fvalue(jdo4000) endif if (.not. inchar) then ia = ip ip = ix + 1 do 4002 i = ia,ix scal_val(i) = scal_inp 4002 continue endif C 4000 continue C endif n_scal_col = ix C endif C endif C GO TO 10 C C =================================== C---- ????????? Key_Word not understood C ================================== C ELSE WRITE (LUNOUT,FMT=6050) LINE(1:LENSTR(LINE)) 6050 FORMAT (' Error Cannot understand this line',/,' ',A, + /' Line Ignored') GO TO 10 END IF C C---- Finished Key_word Input C 100 CONTINUE C C---- Do some checking Here C C-----(1) Cannot have more than EXCLUDE/INCLUDE C or UNIQUE C or CONCAT C or MERGE C C---- (2) Can only change sort order with CONCAT C IF (DO_CONCAT) THEN IF (DO_UNIQUE) THEN CALL CCPERR(1, ' ERROR Cant Have CONCAT and UNIQUE') ELSE IF (DO_MERGE) THEN CALL CCPERR(1,' ERROR Cant Have CONCAT and MERGE') ELSE IF (NUM_INC_COLS(1).NE.0 .OR. NUM_EXC_COLS(1).NE.0) THEN CALL CCPERR(1,' ERROR Cant Have CONCAT and INCLUDE/EXCLUDE') ELSE IF (NUM_INC_COLS(2).NE.0 .OR. NUM_EXC_COLS(2).NE.0) THEN CALL CCPERR(1,' ERROR Cant Have CONCAT and INCLUDE/EXCLUDE') END IF END IF C C IF (DO_UNIQUE) THEN IF (DO_CONCAT) THEN CALL CCPERR(1, ' ERROR Cant Have CONCAT and UNIQUE') ELSE IF (DO_MERGE) THEN CALL CCPERR(1,' ERROR Cant Have UNIQUE and MERGE') ELSE IF (NUM_INC_COLS(1).NE.0 .OR. NUM_EXC_COLS(1).NE.0) THEN CALL CCPERR(1,' ERROR Cant Have UNIQUE and INCLUDE/EXCLUDE') ELSE IF (NUM_INC_COLS(2).NE.0 .OR. NUM_EXC_COLS(2).NE.0) THEN CALL CCPERR(1,' ERROR Cant Have UNIQUE and INCLUDE/EXCLUDE') ELSE IF (DO_NEW_SORT) THEN WRITE(LUNOUT,FMT=6065) 6065 FORMAT(' ** WARNING ** Cant change sort order with UNIQUE',/ + ' Sort order will remain unchanged ') DO_NEW_SORT = .FALSE. END IF END IF C C IF (DO_MERGE) THEN IF (DO_UNIQUE) THEN CALL CCPERR(1,' ERROR Cant Have MERGE and UNIQUE') ELSE IF (DO_CONCAT) THEN CALL CCPERR(1,' ERROR Cant Have CONCAT and MERGE') ELSE IF (NUM_INC_COLS(2).NE.0 .OR. NUM_EXC_COLS(2).NE.0) THEN CALL CCPERR(1,' ERROR Cant Have MERGE and INCLUDE/EXCLUDE') ELSE IF (NUM_INC_COLS(1).NE.0 .OR. NUM_EXC_COLS(1).NE.0) THEN CALL CCPERR(1,' ERROR Cant Have MERGE and INCLUDE/EXCLUDE') ELSE IF (DO_NEW_SORT) THEN WRITE(LUNOUT,FMT=6071) 6071 FORMAT(' ** WARNING ** Cant change sort order with MERGE',/ + ' Sort order will remain unchanged ') DO_NEW_SORT = .FALSE. END IF END IF C C IF ((DO_INCLUDE(1).OR.DO_INCLUDE(2)) .AND. DO_NEW_SORT) + WRITE(LUNOUT,FMT=6080) 6080 FORMAT(' ** WARNING ** Cant change sort order with include',/ + ' sort order will remain unchanged ') C C IF ((DO_EXCLUDE(1).OR.DO_EXCLUDE(2)) .AND. DO_NEW_SORT) + WRITE(LUNOUT,FMT=6082) 6082 FORMAT(' ** WARNING ** Cant change sort order with exclude',/ + ' sort order will remain unchanged ') C C DO_TWO_FILES = .TRUE. C assume ONEFILE if HKLIN2 not defined CALL UGTENV ('HKLIN2',H2) IF (H2.EQ.' ') NUM_FILES = .TRUE. C IF (NUM_FILES) THEN DO_ONE_FILE = .TRUE. DO_TWO_FILES = .FALSE. END IF C C---- cant have exclude/include for same file C IF (DO_INCLUDE(1) .AND. DO_EXCLUDE(1)) + CALL CCPERR(1, + ' ERROR - Cant have exclude and include for file 1') C C IF (DO_INCLUDE(2) .AND. DO_EXCLUDE(2)) + CALL CCPERR(1, + ' ERROR - Cant have exclude and include for file 2') C C IF (.NOT.DO_INCLUDE(1) .AND. .NOT. + DO_EXCLUDE(1)) DO_INC_ALL(1) = .TRUE. IF (.NOT.DO_INCLUDE(2) .AND. .NOT. + DO_EXCLUDE(2)) DO_INC_ALL(2) = .TRUE. C C Can only scale with onefile option C if (do_scal .and. do_two_files) + call ccperr(1,'Use scale with onefile option only !') C END C C ========================= SUBROUTINE CHKRES(RES,OK) C ========================= C C C---- Checks whether a reflection with resolution RES is within C resolution limits. C The incoming arguments are RES(i/p) - the resolution of this C reflection; OK(o/p) - flag set to true if the C resolution of the this reflection is within the 4 sin2th/l**2 C limits SMIN and SMAX in COMMON /RESOLN/ C C .. C .. Scalars in Common REAL RESMIN,RESMAX,SMIN,SMAX C .. LOGICAL OK REAL RES COMMON /RESOLN/ + RESMIN, RESMAX, SMIN, SMAX SAVE C .. C C IF (RES.LT.SMIN .OR. RES.GT.SMAX) THEN OK = .FALSE. ELSE OK = .TRUE. END IF END C C ================================ SUBROUTINE CHKZON(RECOUT,OKZONE) C ================================ C INTEGER MCOLS PARAMETER (MCOLS=500) INTEGER MAXZON PARAMETER (MAXZON=20) C REAL RECOUT(MCOLS) LOGICAL OKZONE INTEGER IFOUND,IRZONE,KEYZON,KZSCR,NRECZO,NZON LOGICAL LOGZON INTEGER LOOKOUT,NCOL_ONE,NCOL_TWO,NCOLOUT,NHKLCOL,NSCOL INTEGER ICHK,ICHK1,IOK,JDO100 EXTERNAL QWRITE COMMON /ZONCOM/ + IRZONE(MAXZON,5),KEYZON(MAXZON),NZON(MAXZON), + IFOUND,LOGZON,KZSCR(MAXZON), + NRECZO(MAXZON) COMMON /EXTRA_BITS/ + NSCOL(2), NCOLOUT, + NCOL_ONE, NCOL_TWO, + NHKLCOL(3,2), LOOKOUT(MCOLS,2) SAVE /ZONCOM/, /EXTRA_BITS/ C OKZONE = .FALSE. IOK = 0 C DO 100 JDO100 = 1,IFOUND ICHK1 = (IRZONE(JDO100,1) * NINT(RECOUT(1)) + + IRZONE(JDO100,2) * NINT(RECOUT(2)) + + IRZONE(JDO100,3) * NINT(RECOUT(3)) + + IRZONE(JDO100,4) * 1000) C C IF (IRZONE(JDO100,4).EQ.0 .AND. ICHK1.NE.0) + GO TO 100 ICHK = ICHK1 IF (IRZONE(JDO100,4).NE.0) + ICHK = MOD(ICHK1,IRZONE(JDO100,4)) IF (ICHK.NE.IRZONE(JDO100,5)) GO TO 100 C C---- here save hkl record to scratch file C NRECZO(JDO100) = NRECZO(JDO100) + 1 C C *********************************** CALL QWRITE(KZSCR(JDO100),RECOUT,NCOLOUT) C *********************************** C IOK = 1 C 100 CONTINUE C IF (IOK.EQ.1) OKZONE = .TRUE. C RETURN END C C ================= SUBROUTINE CLOSIT C ================= C C .. Parameters .. INTEGER MFILES_IN PARAMETER (MFILES_IN=2) INTEGER MAXZON PARAMETER (MAXZON=20) INTEGER MCOLS PARAMETER (MCOLS=500) C .. C .. Scalars in Common .. INTEGER LUNIN, LUNOUT, MTZERR, MTZIN1, + MTZIN2, MTZOUT, MTZPRT LOGICAL DO_CONCAT, DO_MERGE, DO_NEW_CELL, + DO_NEW_HIST, DO_NEW_SORT, DO_NEW_SYMM, + DO_ONE_FILE, DO_S_NEW, DO_TWO_FILES, + DO_UNIQUE C .. C .. Arrays in Common .. LOGICAL DO_EDT_COL_NAMES, + DO_EDT_TITLE, + DO_EXCLUDE, + DO_INCLUDE, + DO_INC_ALL, + FOUND_SYM, + SFOUND C .. C .. Local Scalars .. INTEGER IERR,JDO90,JDO100,JLOOP,MTZIN,NZONE CHARACTER ZSCRNAME*12,ZWORK1*1,ZWORK2*2 REAL DUMMY,RECOUT(MCOLS),RECTMP(MCOLS) C .. C .. External Subroutines .. EXTERNAL LRCLOS,LWCLOS,QCLOSE,QREAD,QSEEK,RESET_MAGIC EXTERNAL LENSTR INTEGER LENSTR C .. C .. Common blocks .. COMMON /LOG_UTILS/ + DO_INCLUDE(MFILES_IN), + DO_INC_ALL(MFILES_IN), + DO_EXCLUDE(MFILES_IN), + DO_EDT_TITLE(MFILES_IN), + DO_EDT_COL_NAMES(MFILES_IN), + FOUND_SYM(MFILES_IN), + SFOUND(2), + DO_MERGE, DO_NEW_SORT, DO_CONCAT, + DO_UNIQUE, DO_NEW_CELL, DO_S_NEW, + DO_NEW_HIST, DO_TWO_FILES, DO_NEW_SYMM, + DO_ONE_FILE COMMON /U_INOUT/ + LUNIN, LUNOUT, MTZIN1, MTZIN2, MTZOUT, + MTZPRT, MTZERR LOGICAL LOGZON INTEGER IRZONE,KEYZON,NZON,IFOUND,KZSCR,NRECZO INTEGER LOOKOUT,NCOL_ONE,NCOL_TWO,NCOLOUT,NHKLCOL,NSCOL CHARACTER ZONCHR*30 COMMON /CHRZON/ ZONCHR(MAXZON) COMMON /ZONCOM/ + IRZONE(MAXZON,5),KEYZON(MAXZON),NZON(MAXZON), + IFOUND,LOGZON,KZSCR(MAXZON), + NRECZO(MAXZON) COMMON /EXTRA_BITS/ + NSCOL(2), NCOLOUT, + NCOL_ONE, NCOL_TWO, + NHKLCOL(3,2), LOOKOUT(MCOLS,2) C .. C .. Save statement .. SAVE C .. C MTZIN = 1 DUMMY = 0.0 C C ************* CALL LRCLOS(MTZIN) C ************* C C ************** IF (DO_TWO_FILES) CALL LRCLOS(2) C ************** C C---- test if zones/axis were requested, if so write out C to LUNOUT the picked reflections C IF (.NOT. LOGZON) GO TO 200 C DO 100 JDO100=1,IFOUND C C---- Rewind scratch files C C ********************************* CALL QSEEK (KZSCR(JDO100),1,1,NCOLOUT) C ********************************* C WRITE(LUNOUT,6608) ZONCHR(JDO100),NRECZO(JDO100) 6608 FORMAT(' Reflections for ZONE/AXIS of Type = ',A,/, + ' Number of reflections of this type = ',I10, + //) C IF ( NRECZO(JDO100).EQ.0) THEN WRITE(LUNOUT,6618) 6618 FORMAT( + ' Sorry Dear NO Reflections found for this ZONE',///) GO TO 100 END IF C NZONE = MIN(100,NRECZO(JDO100)) WRITE(LUNOUT,'(A,I10,A)')' List of first',NZONE,' reflections' C DO 90 JDO90=1,NZONE C C ****************************************************** CALL QREAD(KZSCR(JDO100),RECTMP,NCOLOUT,IERR) CALL RESET_MAGIC(MTZOUT,RECTMP,RECOUT,NCOLOUT,DUMMY,-999.0) C ****************************************************** C WRITE(LUNOUT,6606) NINT(RECOUT(1)), + NINT(RECOUT(2)), + NINT(RECOUT(3)), + (RECOUT(JLOOP),JLOOP=4,NCOLOUT) 6606 FORMAT (' ',3I4,2X,6(1X,F9.2),15 (/11X,6 (1X,F9.2))) C 90 CONTINUE C C ********************* CALL QCLOSE(KZSCR(JDO100)) C ********************* C C---- This is merely to delete the opened scratch files. C IF (JDO100.LE.9) THEN WRITE (ZWORK1,6600) JDO100 6600 FORMAT(I1) ZSCRNAME = 'Util_Zone.' // ZWORK1 ELSE WRITE(ZWORK2,6601) JDO100 6601 FORMAT(I2) ZSCRNAME = 'Util_Zone.' // ZWORK2 END IF C OPEN (UNIT=66,FILE=ZSCRNAME(1:LENSTR(ZSCRNAME)), + STATUS='OLD',ERR=1000) C CLOSE (UNIT=66,STATUS='DELETE') C 1000 CONTINUE WRITE(LUNOUT,6610) 6610 FORMAT(' ',//) 100 CONTINUE C 200 CONTINUE C C ********************* CALL LWCLOS(MTZOUT,MTZPRT) C ********************* C RETURN END C C ================= SUBROUTINE GENEDT C ================= C C .. Parameters .. INTEGER MAXSYM PARAMETER (MAXSYM=192) INTEGER MAXHIS PARAMETER (MAXHIS=30) INTEGER MCOLS PARAMETER (MCOLS=500) INTEGER MFILES_IN PARAMETER (MFILES_IN=2) INTEGER MAXBAT PARAMETER (MAXBAT=5000) C .. C .. Scalars in Common .. INTEGER LENTIT_OUT, LUNIN, LUNOUT, MTZERR, + MTZIN1, MTZIN2, MTZOUT, MTZPRT, + NHISOUT, NISYM_NEW, NLAUE_NEW, NLAUE_OUT, + NMAT_NEW, NSPGRP_NEW, NSPGRP_OUT, NSYMP_NEW, + NSYMP_OUT, NSYM_NEW, NSYM_OUT, NUMCOL_OUT, + NUM_NEW_HIST LOGICAL DO_CONCAT, DO_MERGE, DO_NEW_CELL, + DO_NEW_HIST, DO_NEW_SORT, DO_NEW_SYMM, + DO_ONE_FILE, DO_S_NEW, DO_TWO_FILES, + DO_UNIQUE CHARACTER LATTYP_NEW*1, LATTYP_OUT*1, LAUNAM_NEW*10, + NAMSPG_NEW*10, NAMSPG_OUT*10, PGNAME_NEW*10, + PGNAME_OUT*10, TITOUT*70 C .. C .. Arrays in Common .. REAL CELL_NEW, CELMTZ, CELOUT, RNGMTZ, RSYM, + RSYMT_NEW, RSYM_NEW, RSYM_OUT INTEGER ISYMM_NEW, ISYMST_NEW, ISYM_NEW, LENTIT, LMSYM_NEW, + MSORTX, MSORTX_NEW, MSORTX_OUT, MTZBLS, NBATX, + NHISIN, NLAUE, NREFLX, NSPGRP, NSYM, + NSYMOP_NEW, NSYMP, NUMCOL, NUM_EDIT_COLS, + NUM_EXC_COLS, + NUM_INC_COLS LOGICAL DO_EDT_COL_NAMES, DO_EDT_TITLE, DO_EXCLUDE, + DO_INCLUDE, DO_INC_ALL, FOUND_SYM, + SFOUND CHARACTER CTYPS*1, CTYPS_OUT*1, LATTYP*1, + EDT_TITLE_MODE*4, NAMSPG*10, PGNAME*10, + CLABS*30, CLABS_OUT*30, EXC_COL_LABELS*30, + INC_COL_LABELS*30, NEW_COL_NAMES*30, + OLD_COL_NAMES*30, NEW_TITLE*70, TITIN*70, + HISTIN*80, HISTOUT*80, NEW_HIST*80 C .. C .. Local Scalars .. INTEGER JDO100,JDO110,JDO120,JDO130,JDO140,JDO150,JDO160,JDO180, + JDO190,JDO20,JDO200,JDO210,JDO230,JDO240,JDO250,JDO30, + JDO40,JDO50,JDO60,JDO80,JDO90,LWORK1,LWORK2,MLOOP,MTZIN C .. C .. Local Arrays .. CHARACTER TITWRK(MFILES_IN)*80 C .. C .. External Functions .. INTEGER LENSTR EXTERNAL LENSTR C .. C .. External Subroutines .. EXTERNAL ASUSET C .. C .. Common blocks .. COMMON /CHR_MTZIN/ TITIN(MFILES_IN), + HISTIN(MAXHIS,MFILES_IN), + LATTYP(MFILES_IN), + PGNAME(MFILES_IN), + NAMSPG(MFILES_IN), + CLABS(MCOLS,MFILES_IN), + CTYPS(MCOLS,MFILES_IN) COMMON /CHR_MTZOUT/TITOUT, + HISTOUT(MAXHIS), + LATTYP_OUT, + PGNAME_OUT, + NAMSPG_OUT, + CLABS_OUT(MCOLS), + CTYPS_OUT(MCOLS) COMMON /CHR_UTILS/ + INC_COL_LABELS(MCOLS,MFILES_IN), + EXC_COL_LABELS(MCOLS,MFILES_IN), + EDT_TITLE_MODE(MFILES_IN), + NEW_HIST(MAXHIS),NEW_TITLE(MFILES_IN), + OLD_COL_NAMES(MCOLS,MFILES_IN), + NEW_COL_NAMES(MCOLS,MFILES_IN) COMMON /CNEW_SYMM/ + PGNAME_NEW, NAMSPG_NEW, LAUNAM_NEW, LATTYP_NEW COMMON /INT_MTZIN/ + LENTIT(MFILES_IN), NUMCOL(MFILES_IN), + NREFLX(MFILES_IN), NHISIN(MFILES_IN), + NBATX(MFILES_IN), NLAUE(MFILES_IN), + NSYM(MFILES_IN), NSYMP(MFILES_IN), + NSPGRP(MFILES_IN), MTZBLS(MAXBAT,MFILES_IN), + MSORTX(5,MFILES_IN) COMMON /INT_MTZOUT/ + LENTIT_OUT, NUMCOL_OUT, + NHISOUT, NLAUE_OUT, + NSYM_OUT, NSYMP_OUT, + NSPGRP_OUT, MSORTX_OUT(5) COMMON /INT_UTILS/ + NUM_INC_COLS(MFILES_IN), + NUM_EXC_COLS(MFILES_IN), + NUM_EDIT_COLS(MFILES_IN), + NUM_NEW_HIST, + MSORTX_NEW(5) COMMON /LOG_UTILS/ + DO_INCLUDE(MFILES_IN), + DO_INC_ALL(MFILES_IN), + DO_EXCLUDE(MFILES_IN), + DO_EDT_TITLE(MFILES_IN), + DO_EDT_COL_NAMES(MFILES_IN), + FOUND_SYM(MFILES_IN), + SFOUND(2), + DO_MERGE, DO_NEW_SORT, DO_CONCAT, + DO_UNIQUE, DO_NEW_CELL, DO_S_NEW, + DO_NEW_HIST, DO_TWO_FILES, DO_NEW_SYMM, + DO_ONE_FILE COMMON /REL_MTZIN/ + CELMTZ(6,MFILES_IN), + RNGMTZ(2,MCOLS,MFILES_IN), + RSYM(4,4,MAXSYM,MFILES_IN) COMMON /REL_MTZOUT/ + CELOUT(6), + RSYM_OUT(4,4,MAXSYM) COMMON /REL_UTILS/ CELL_NEW(6) COMMON /UNEW_SYMM/ + NSPGRP_NEW, NSYM_NEW, NSYMP_NEW, + NLAUE_NEW, NISYM_NEW, NMAT_NEW, + ISYMST_NEW(MAXSYM), + LMSYM_NEW(MAXSYM), + NSYMOP_NEW(MAXSYM), + ISYMM_NEW(9,MAXSYM), + ISYM_NEW(9,MAXSYM), + RSYM_NEW(4,4,MAXSYM), + RSYMT_NEW(4,4,MAXSYM) COMMON /U_INOUT/ + LUNIN, LUNOUT, MTZIN1, MTZIN2, MTZOUT, + MTZPRT, MTZERR C .. C .. Save statement .. SAVE C .. C .. Data statements .. DATA TITWRK/' ',' '/ C .. C MLOOP = 1 IF (DO_TWO_FILES) MLOOP = 2 C C---- all options allow for TITLE Editing C DO 10 MTZIN = 1,MLOOP TITWRK(MTZIN) = TITIN(MTZIN) C IF (DO_EDT_TITLE(MTZIN)) THEN IF (EDT_TITLE_MODE(MTZIN).EQ.'NOCH') THEN TITWRK(MTZIN) = TITIN(MTZIN) ELSE IF (EDT_TITLE_MODE(MTZIN).EQ.'REPL') THEN TITWRK(MTZIN) = NEW_TITLE(MTZIN) ELSE IF (EDT_TITLE_MODE(MTZIN).EQ.'ADD') THEN LWORK1 = LENSTR(TITIN(MTZIN)) LWORK2 = LENSTR(NEW_TITLE(MTZIN)) IF (LWORK1.EQ.0) LWORK1 = 1 IF (LWORK2.EQ.0) LWORK2 = 1 TITWRK(MTZIN) = NEW_TITLE(MTZIN) (1:LWORK2)//' '// + TITIN(MTZIN) (1:LWORK1) END IF END IF C 10 CONTINUE C C---- Final output TITLE C LWORK1 = LENSTR(TITWRK(1)) LWORK2 = LENSTR(TITWRK(2)) IF (LWORK1.EQ.0) LWORK1 = 1 IF (LWORK2.EQ.0) LWORK2 = 1 TITOUT = TITWRK(1) (1:LWORK1)//' '//TITWRK(2) (1:LWORK2) C C---- Final CELL output C IF (DO_NEW_CELL) THEN DO 20 JDO20 = 1,6 CELOUT(JDO20) = CELL_NEW(JDO20) 20 CONTINUE GO TO 70 END IF C C---- Use CELL values from File_1 C IF (CELMTZ(1,1).LE.0.0) THEN C C---- Use CELL values from File_2 if available C IF (DO_TWO_FILES) THEN IF (CELMTZ(1,2).LE.0.0) THEN WRITE (LUNOUT,FMT=6000) 6000 FORMAT (' Warning NO-cell values in either input files') C C---- Just set cellout to 0.0 C DO 30 JDO30 = 1,6 CELOUT(JDO30) = 0.0 30 CONTINUE GO TO 70 END IF C C---- now use cell values from file 2 C DO 40 JDO40 = 1,6 CELOUT(JDO40) = CELMTZ(JDO40,2) 40 CONTINUE C GO TO 70 END IF C C--- OK not two files C WRITE (LUNOUT,FMT=6002) 6002 FORMAT (' Warning NO-cell values in Input file') C C---- Just set cellout to 0.0 C DO 50 JDO50 = 1,6 CELOUT(JDO50) = 0.0 50 CONTINUE GO TO 70 END IF C C---- now use cell values from file 1 C DO 60 JDO60 = 1,6 CELOUT(JDO60) = CELMTZ(JDO60,1) 60 CONTINUE C 70 CONTINUE C C---- Set up symmetry (RDSYMM must be called first ) C IF (DO_NEW_SYMM) THEN C C ********************************************************* CALL ASUSET(NAMSPG_NEW,NSPGRP_NEW,PGNAME_NEW,NSYM_NEW,RSYM_NEW, + NSYMP_NEW,NLAUE_NEW,.TRUE.) C ********************************************************* C NSYM_OUT = NSYM_NEW NSYMP_OUT = NSYMP_NEW cc-->> ???? where is lattyp_new SET ????? LATTYP_NEW = NAMSPG_NEW(1:1) LATTYP_OUT = LATTYP_NEW NSPGRP_OUT = NSPGRP_NEW NAMSPG_OUT = NAMSPG_NEW PGNAME_OUT = PGNAME_NEW C DO 100 JDO100 = 1,NSYM_NEW DO 90 JDO90 = 1,4 DO 80 JDO80 = 1,4 RSYM_OUT(JDO80,JDO90,JDO100) = RSYM_NEW(JDO80,JDO90, + JDO100) 80 CONTINUE 90 CONTINUE 100 CONTINUE GO TO 170 C ELSE IF (FOUND_SYM(1)) THEN C C---- Use symmetry from File_Number_1 C MTZIN = 1 NSYM_OUT = NSYM(MTZIN) NSYMP_OUT = NSYMP(MTZIN) cc-->> ??? whereis lattyp(mtzin) SET ??? call lrsym LATTYP_OUT = LATTYP(MTZIN) NSPGRP_OUT = NSPGRP(MTZIN) NAMSPG_OUT = NAMSPG(MTZIN) PGNAME_OUT = PGNAME(MTZIN) C DO 130 JDO130 = 1,NSYM(MTZIN) DO 120 JDO120 = 1,4 DO 110 JDO110 = 1,4 RSYM_OUT(JDO110,JDO120,JDO130) = RSYM(JDO110,JDO120, + JDO130,MTZIN) 110 CONTINUE 120 CONTINUE 130 CONTINUE GO TO 170 C ELSE IF (DO_TWO_FILES .AND. FOUND_SYM(2)) THEN C C---- Use symmetry from File_Number_2 C MTZIN = 2 NSYM_OUT = NSYM(MTZIN) NSYMP_OUT = NSYMP(MTZIN) cc-->> ??? whereis lattyp(mtzin) SET ??? call lrsym LATTYP_OUT = LATTYP(MTZIN) NSPGRP_OUT = NSPGRP(MTZIN) NAMSPG_OUT = NAMSPG(MTZIN) PGNAME_OUT = PGNAME(MTZIN) C DO 160 JDO160 = 1,NSYM(MTZIN) DO 150 JDO150 = 1,4 DO 140 JDO140 = 1,4 RSYM_OUT(JDO140,JDO150,JDO160) = RSYM(JDO140,JDO150, + JDO160,MTZIN) 140 CONTINUE 150 CONTINUE 160 CONTINUE GO TO 170 C ELSE C C---- No symmetry found anywhere C NSYM_OUT = -99 WRITE (LUNOUT,FMT=*) ' Warning No_symmetry use in output' C END IF C 170 CONTINUE C C---- Test if SORT_ORDER changed NOT really used here, C DOES IT EVER GET USED, old lcfutils had a hidden C "ORDER" input option but not documented ????? C IF (DO_NEW_SORT) THEN DO 180 JDO180 = 1,5 MSORTX_OUT(JDO180) = MSORTX_NEW(JDO180) 180 CONTINUE GO TO 220 C C---- pick up sort order from File_Number_1 C ELSE IF (MSORTX(1,1).GT.-99) THEN DO 190 JDO190 = 1,5 MSORTX_OUT(JDO190) = MSORTX(JDO190,1) 190 CONTINUE GO TO 220 C C---- Else pick up sort order from File_Number_2 C ELSE IF (MSORTX(1,1).GT.-99 .AND. DO_TWO_FILES) THEN DO 200 JDO200 = 1,5 MSORTX_OUT(JDO200) = MSORTX(JDO200,1) 200 CONTINUE GO TO 220 C C---- No sort order found anywhere - hope for the best C Set sort order to 0 0 0 0 0 C ELSE DO 210 JDO210 = 1,5 MSORTX_OUT(JDO210) = 0 210 CONTINUE C WRITE (LUNOUT,FMT=*) ' No SORT_ORDER in any input',/ C + ' So None in any output' END IF C 220 CONTINUE C C---- Test if HISTORY to be ADDED to O/p file C C---- Check if any input history lines C NHISOUT = 0 C C---- Put Key_Word HISTORY LINES at top of array C IF (DO_NEW_HIST) THEN IF (NUM_NEW_HIST.GT.0) THEN DO 230 JDO230 = 1,NUM_NEW_HIST NHISOUT = NHISOUT + 1 C IF (NHISOUT.GT.MAXHIS) THEN NHISOUT = NHISOUT - 1 GO TO 260 END IF C HISTOUT(NHISOUT) = NEW_HIST(JDO230) 230 CONTINUE END IF END IF C C---- Add history from File_Number_1 C IF (NHISIN(1).GT.0) THEN DO 240 JDO240 = 1,NHISIN(1) NHISOUT = NHISOUT + 1 C IF (NHISOUT.GT.MAXHIS) THEN NHISOUT = NHISOUT - 1 GO TO 260 END IF C HISTOUT(NHISOUT) = HISTIN(JDO240,1) 240 CONTINUE END IF C C---- Add history from File_Number_2 C IF (NHISIN(2).GT.0) THEN DO 250 JDO250 = 1,NHISIN(2) NHISOUT = NHISOUT + 1 C IF (NHISOUT.GT.MAXHIS) THEN NHISOUT = NHISOUT - 1 GO TO 260 END IF C HISTOUT(NHISOUT) = HISTIN(JDO250,2) 250 CONTINUE END IF C 260 CONTINUE C RETURN END C C ================= SUBROUTINE MAKCOL C ================= C C .. parameters .. INTEGER MAXSYM PARAMETER (MAXSYM=192) INTEGER MAXHIS PARAMETER (MAXHIS=30) INTEGER MCOLS PARAMETER (MCOLS=500) INTEGER MSETS PARAMETER (MSETS=MCOLS) INTEGER MFILES_IN PARAMETER (MFILES_IN=2) INTEGER MAXBAT PARAMETER (MAXBAT=5000) C .. C .. scalars in common .. INTEGER LUNIN, LUNOUT, MTZERR, MTZIN1, + MTZIN2, MTZOUT, MTZPRT, NCOLOUT, + NCOL_ONE, NCOL_TWO, NUM_NEW_HIST LOGICAL DO_CONCAT, DO_MERGE, DO_NEW_CELL, DO_NEW_HIST, + DO_NEW_SORT, DO_NEW_SYMM, DO_ONE_FILE, DO_S_NEW, + DO_TWO_FILES, DO_UNIQUE CHARACTER LATTYP_OUT*1, NAMSPG_OUT*10, PGNAME_OUT*10, TITOUT*70 C .. C .. arrays in common .. INTEGER LENTIT, LOOKOUT, MSORTX, MSORTX_NEW, + MTZBLS, NBATX, NHISIN, NHKLCOL, + NLAUE, NREFLX, NSCOL, NSPGRP, + NSYM, NSYMP, NUMCOL, NUM_EDIT_COLS, + NUM_EXC_COLS, NUM_INC_COLS LOGICAL DO_EDT_COL_NAMES, DO_EDT_TITLE, + DO_EXCLUDE, DO_INCLUDE, + DO_INC_ALL, FOUND_SYM, + SFOUND CHARACTER CTYPS*1, CTYPS_OUT*1, LATTYP*1, + EDT_TITLE_MODE*4, NAMSPG*10, PGNAME*10, + CLABS*30, CLABS_OUT*30, EXC_COL_LABELS*30, + INC_COL_LABELS*30, NEW_COL_NAMES*30, OLD_COL_NAMES*30, + NEW_TITLE*70, TITIN*70, HISTIN*80, + HISTOUT*80, NEW_HIST*80 C .. C .. local scalars .. INTEGER JDO10,JDO110,JDO120,JDO140,JDO150,JDO160,JDO190,JDO20, + JDO210,JDO220,JDO240,JDO250,JDO260,JDO280,JDO30, + JDO40,JDO60,JDO70,JDO90,KWORK,LSAVE,LWORK,MLOOP,MTZIN, + NWORK LOGICAL PASSONE CHARACTER CWORK1*30,CWORK2*30 C .. C .. local arrays .. CHARACTER CHKL(3)*1,CLABS_WORK(MCOLS,MFILES_IN)*30 C .. C .. common blocks .. COMMON /CHR_MTZIN/ TITIN(MFILES_IN), + HISTIN(MAXHIS,MFILES_IN), + LATTYP(MFILES_IN), + PGNAME(MFILES_IN), + NAMSPG(MFILES_IN), + CLABS(MCOLS,MFILES_IN), + CTYPS(MCOLS,MFILES_IN) COMMON /CHR_MTZOUT/TITOUT, + HISTOUT(MAXHIS), + LATTYP_OUT, + PGNAME_OUT, + NAMSPG_OUT, + CLABS_OUT(MCOLS), + CTYPS_OUT(MCOLS) COMMON /CHR_UTILS/ + INC_COL_LABELS(MCOLS,MFILES_IN), + EXC_COL_LABELS(MCOLS,MFILES_IN), + EDT_TITLE_MODE(MFILES_IN), + NEW_HIST(MAXHIS),NEW_TITLE(MFILES_IN), + OLD_COL_NAMES(MCOLS,MFILES_IN), + NEW_COL_NAMES(MCOLS,MFILES_IN) COMMON /EXTRA_BITS/ + NSCOL(2), NCOLOUT, + NCOL_ONE, NCOL_TWO, + NHKLCOL(3,2), LOOKOUT(MCOLS,2) COMMON /INT_MTZIN/ + LENTIT(MFILES_IN), NUMCOL(MFILES_IN), + NREFLX(MFILES_IN), NHISIN(MFILES_IN), + NBATX(MFILES_IN), NLAUE(MFILES_IN), + NSYM(MFILES_IN), NSYMP(MFILES_IN), + NSPGRP(MFILES_IN), MTZBLS(MAXBAT,MFILES_IN), + MSORTX(5,MFILES_IN) COMMON /INT_UTILS/ + NUM_INC_COLS(MFILES_IN), + NUM_EXC_COLS(MFILES_IN), + NUM_EDIT_COLS(MFILES_IN), + NUM_NEW_HIST, + MSORTX_NEW(5) COMMON /LOG_UTILS/ + DO_INCLUDE(MFILES_IN), + DO_INC_ALL(MFILES_IN), + DO_EXCLUDE(MFILES_IN), + DO_EDT_TITLE(MFILES_IN), + DO_EDT_COL_NAMES(MFILES_IN), + FOUND_SYM(MFILES_IN), + SFOUND(2), + DO_MERGE, DO_NEW_SORT, DO_CONCAT, + DO_UNIQUE, DO_NEW_CELL, DO_S_NEW, + DO_NEW_HIST, DO_TWO_FILES, DO_NEW_SYMM, + DO_ONE_FILE COMMON /U_INOUT/ + LUNIN, LUNOUT, MTZIN1, MTZIN2, MTZOUT, + MTZPRT, MTZERR INTEGER SETID INTEGER NDATASETS(MFILES_IN),ISETS(MSETS,MFILES_IN), + CSETID_NFILE(MCOLS,MFILES_IN) REAL DCELL(6,MSETS,MFILES_IN),DWAVEL(MSETS,MFILES_IN) CHARACTER*64 PNAME(MSETS,MFILES_IN),DNAME(MSETS,MFILES_IN), + PNAME_OUT(MCOLS),DNAME_OUT(MCOLS) COMMON /SETS_IO/ NDATASETS,ISETS,CSETID_NFILE,DCELL,DWAVEL, + PNAME,DNAME,PNAME_OUT,DNAME_OUT C .. C .. save statement .. SAVE C .. C .. data statements .. DATA CHKL/'H','K','L'/ C .. C C---- save clabs for lrassgn so use clabs_work C and initialise lookup table C DO 20 JDO20 = 1,MFILES_IN DO 10 JDO10 = 1,MCOLS C C---- set all lookout values to unknown C LOOKOUT(JDO10,JDO20) = -99 C C---- transfer input labels to work labels C CLABS_WORK(JDO10,JDO20) = CLABS(JDO10,JDO20) 10 CONTINUE 20 CONTINUE DO 25 JDO10 = 1,MCOLS PNAME_OUT(JDO10) = ' ' DNAME_OUT(JDO10) = ' ' 25 CONTINUE C C---- check if s is a column in input files C MTZIN = 1 IF (DO_TWO_FILES) MTZIN = 2 C DO 40 JDO40 = 1,MTZIN DO 30 JDO30 = 1,NUMCOL(MTZIN) IF (CLABS(JDO30,JDO40).EQ.'S' .AND. + CTYPS(JDO30,JDO40).EQ.'S') THEN C C---- still not using these saved values properly ?? C NSCOL(JDO40) = JDO30 SFOUND(JDO40) = .TRUE. END IF 30 CONTINUE 40 CONTINUE C C---- do column editing first for assignments as a user doing C C FILE_1 H K L A B C FILE_2 H K L A C C USING KEY_WORDS AS : C C ECOL 2 A=D C INCLUDE 1 A B C INCLUDE 2 D C C i can only see how to do this by including the edited columns C cant think --- therefore this is different to lcfutils C as in the lcf version include/exclude is on original names C here include/exclude is on edited names ??????? C C---- Merge option - no column editing allowed C IF (DO_MERGE) GO TO 80 C MTZIN = 1 PASSONE = .FALSE. 50 CONTINUE C IF (DO_EDT_COL_NAMES(MTZIN)) THEN C C---- Loop over key_word input column edits C DO 70 JDO70 = 1,NUM_EDIT_COLS(MTZIN) LWORK = 0 CWORK1 = OLD_COL_NAMES(JDO70,MTZIN) CWORK2 = NEW_COL_NAMES(JDO70,MTZIN) C C---- Loop over input file column labels C DO 60 JDO60 = 1,NUMCOL(MTZIN) IF (CLABS_WORK(JDO60,MTZIN).EQ.CWORK1) THEN LWORK = 1 LSAVE = JDO60 ELSE IF (CLABS_WORK(JDO60,MTZIN).EQ.CWORK2) THEN LWORK = 2 LSAVE = JDO60 END IF 60 CONTINUE C IF (LWORK.EQ.0) THEN C C---- Cant match key_word input with file column labels C WRITE (LUNOUT,FMT=6002) MTZIN,CWORK1,CWORK2 6002 FORMAT (' Error in File_number_:',I2,/, + ' Attempt to EDIT Column Labels failed for Names',/, + ' ',A,' and ',A,/, + ' Error in Subroutine MAKCOL') C C ****************************** CALL CCPERR(1,' STOP in edit mode') C ****************************** C ELSE IF (LWORK.EQ.1) THEN C C---- Transfer into array clabs_work the new column name at the C correct column position C C ... (i) left hand value matches original value C swap with right hand value of "a=b" C WRITE (LUNOUT,6601) MTZIN, CLABS_WORK(LSAVE,MTZIN), + NEW_COL_NAMES(JDO70,MTZIN) 6601 FORMAT(' Column_Editing: for File_number: ',I2,/, + ' Old_Column_Label = ',A,/, + ' New_Column_Label = ',A) CLABS_WORK(LSAVE,MTZIN) = NEW_COL_NAMES(JDO70,MTZIN) ELSE IF (LWORK.EQ.2) THEN C C ... (ii) right hand value matches original value C swap with left hand value of "a=b" C WRITE (LUNOUT,6601) MTZIN, CLABS_WORK(LSAVE,MTZIN), + OLD_COL_NAMES(JDO70,MTZIN) CLABS_WORK(LSAVE,MTZIN) = OLD_COL_NAMES(JDO70,MTZIN) END IF 70 CONTINUE END IF C IF (PASSONE) GO TO 80 C C---- can only edit column labels of first file to be equal C to those in second file for the option concat C test if this correct in subroutine pcocat C IF (DO_CONCAT) GO TO 80 C IF (DO_TWO_FILES) THEN MTZIN = 2 PASSONE = .TRUE. GO TO 50 END IF C 80 CONTINUE C C---- do_merge, do_concat and do_unique options now C IF (DO_MERGE .OR. + DO_UNIQUE .OR. + DO_CONCAT) THEN C C---- just gather up all labels and column positions C NCOLOUT = 0 C DO 110 JDO110 = 1,NUMCOL(2) DO 90 JDO90 = 1,NUMCOL(1) IF (CLABS_WORK(JDO90,1).EQ.CLABS_WORK(JDO110,2)) THEN NCOLOUT = NCOLOUT + 1 C C---- transfer common column label from edited name in work C to output column position C CLABS_OUT(NCOLOUT) = CLABS_WORK(JDO90,1) CTYPS_OUT(NCOLOUT) = CTYPS(JDO90,1) LOOKOUT(JDO90,1) = NCOLOUT C IF (DO_MERGE) THEN LOOKOUT(JDO110,2) = NCOLOUT WRITE (LUNOUT,FMT=6004) CLABS_OUT(NCOLOUT),NCOLOUT, + JDO90,JDO110 6004 FORMAT (' For MERGE Option, common Column_Label of >> ',A,/, + ' to be position ',I3,' in HKLOUT and',/, + ' Found in position ',I3,' in HKLIN1 and',/, + ' Found in position ',I3,' in HKLIN2') ELSE IF (DO_UNIQUE) THEN LOOKOUT(JDO110,2) = NCOLOUT WRITE (LUNOUT,FMT=6006) CLABS_OUT(NCOLOUT),NCOLOUT, + JDO90,JDO110 6006 FORMAT (' For UNIQUE Option, common Column_Label of >> ',A,/, + ' to be position ',I3,' in HKLOUT and',/, + ' Found in position ',I3,' in HKLIN1 and',/, + ' Found in position ',I3,' in HKLIN2') END IF C GO TO 100 END IF 90 CONTINUE C C---- no partner for this label in file_number_2 C NCOLOUT = NCOLOUT + 1 C C---- here for unique column labels C CLABS_OUT(NCOLOUT) = CLABS_WORK(JDO110,2) CTYPS_OUT(NCOLOUT) = CTYPS(JDO110,2) LOOKOUT(JDO110,2) = NCOLOUT C IF (DO_MERGE) THEN WRITE (LUNOUT,FMT=6008) CLABS_OUT(NCOLOUT),NCOLOUT,JDO110 6008 FORMAT (' For MERGE_Option, Unique Column_Label of >> ',A,/, + ' to be position ',I3,' in HKLOUT and',/, + ' Found in position ',I3,' in HKLIN2') ELSE WRITE (LUNOUT,FMT=6010) CLABS_OUT(NCOLOUT),NCOLOUT,JDO110 6010 FORMAT (' For UNIQUE_Option, Unique Column_Label of >> ',A,/, + ' to be position ',I3,' in HKLOUT and',/, + ' Found in position ',I3,' in HKLIN2') END IF C 100 CONTINUE 110 CONTINUE C C---- now get any missing columns from file_number_1 C NWORK = NCOLOUT C DO 140 JDO140 = 1,NUMCOL(1) DO 120 JDO120 = 1,NWORK IF (CLABS_WORK(JDO140,1).EQ.CLABS_OUT(JDO120)) GO TO 130 120 CONTINUE C C---- found missing column from file_number_1 C NCOLOUT = NCOLOUT + 1 CLABS_OUT(NCOLOUT) = CLABS_WORK(JDO140,1) CTYPS_OUT(NCOLOUT) = CTYPS(JDO140,1) LOOKOUT(JDO140,1) = NCOLOUT C IF (DO_MERGE) THEN WRITE (LUNOUT,FMT=6012) CLABS_OUT(NCOLOUT),NCOLOUT,JDO140 6012 FORMAT (' For MERGE_Option, Unique Column_Label of >> ',A,/, + ' to be position ',I3,' in HKLOUT and',/, + ' Found in position ',I3,' in HKLIN1') ELSE WRITE (LUNOUT,FMT=6014) CLABS_OUT(NCOLOUT),NCOLOUT,JDO140 6014 FORMAT (' For UNIQUE_Option, Unique Column_Label of >> ',A,/, + ' to be position ',I3,' in HKLOUT and',/, + ' Found in position ',I3,' in HKLIN1') END IF C 130 CONTINUE 140 CONTINUE C C--- Now sort out dataset IDs for output columns MLOOP = 1 IF (DO_TWO_FILES) MLOOP = 2 DO 320 JDO20 = 1,MLOOP IF (NDATASETS(JDO20).LE.0) GOTO 320 DO 310 JDO10 = 1,NUMCOL(JDO20) ILOOK = LOOKOUT(JDO10,JDO20) IF (ILOOK.LE.0) GOTO 310 C---- If input file had datasets assigned, match dataset ID to names SETID = CSETID_NFILE(JDO10,JDO20) DO ISET = 1,NDATASETS(JDO20) IF (ISETS(ISET,JDO20).EQ.SETID) THEN PNAME_OUT(ILOOK) = PNAME(ISET,JDO20) DNAME_OUT(ILOOK) = DNAME(ISET,JDO20) END IF ENDDO 310 CONTINUE 320 CONTINUE C RETURN END IF C C---- now do include/exclude options C first get column positions for h k l C in input files C MLOOP = 1 IF (DO_TWO_FILES) MLOOP = 2 NCOLOUT = 0 C DO 170 MTZIN = 1,MLOOP DO 160 JDO160 = 1,3 DO 150 JDO150 = 1,NUMCOL(MTZIN) IF (CLABS_WORK(JDO150,MTZIN).EQ.CHKL(JDO160)) THEN C C---- first save col positions for hkl for later C these column positions not being used properly yet C NHKLCOL(JDO160,MTZIN) = JDO150 C C---- now make output column labels for hkl from just C file_number_1 C IF (MTZIN.EQ.1) THEN NCOLOUT = NCOLOUT + 1 CTYPS_OUT(NCOLOUT) = CTYPS(JDO150,MTZIN) CLABS_OUT(NCOLOUT) = CLABS_WORK(JDO150,MTZIN) LOOKOUT(JDO150,MTZIN) = NCOLOUT END IF END IF C 150 CONTINUE 160 CONTINUE 170 CONTINUE C IF (NCOLOUT.NE.3) THEN WRITE (LUNOUT,FMT=6016) 6016 FORMAT (' ERROR -- Cant find all of H,K,L, in input files',/, + ' using exclude/include options') C C ***************************************** CALL CCPERR(1,' STOP in exclude/include mode') C ***************************************** C END IF C PASSONE = .FALSE. MTZIN = 1 180 CONTINUE C IF (DO_INC_ALL(MTZIN)) THEN C C---- get all columns from input files C DO 210 JDO210 = 1,NUMCOL(MTZIN) C C---- check if already got it C NWORK = NCOLOUT C DO 190 JDO190 = 1,NWORK IF (CLABS_WORK(JDO210,MTZIN).EQ.CLABS_OUT(JDO190)) THEN IF (JDO190 .LE. 3) THEN GO TO 200 ELSE WRITE(LUNOUT,FMT=6017) CLABS_OUT(JDO190) CALL CCPERR(1,' PROGRAM HALTED identical output labels') ENDIF ENDIF 190 CONTINUE 6017 FORMAT(/,' Two output labels are the same, that is ',A30,/) C NCOLOUT = NCOLOUT + 1 CLABS_OUT(NCOLOUT) = CLABS_WORK(JDO210,MTZIN) CTYPS_OUT(NCOLOUT) = CTYPS(JDO210,MTZIN) LOOKOUT(JDO210,MTZIN) = NCOLOUT 200 CONTINUE 210 CONTINUE C C---- just get requested include labels C ELSE IF (DO_INCLUDE(MTZIN)) THEN KWORK = 0 DO 240 JDO240 = 1,NUM_INC_COLS(MTZIN) DO 220 JDO220 = 1,NUMCOL(MTZIN) IF (INC_COL_LABELS(JDO240,MTZIN).EQ. + CLABS_WORK(JDO220,MTZIN)) THEN NCOLOUT = NCOLOUT + 1 CLABS_OUT(NCOLOUT) = CLABS_WORK(JDO220,MTZIN) CTYPS_OUT(NCOLOUT) = CTYPS(JDO220,MTZIN) LOOKOUT(JDO220,MTZIN) = NCOLOUT KWORK = KWORK + 1 WRITE (LUNOUT,FMT=6018) CLABS_OUT(NCOLOUT),NCOLOUT,MTZIN, + JDO220 6018 FORMAT (' For HKLOUT, Column Label Name >> ',A,/, + ' will be position ',I3,/, + ' INCLUDED from File_number: ',I3,/, + ' found at position: ',I3) GO TO 230 END IF 220 CONTINUE WRITE (LUNOUT,FMT=6020) INC_COL_LABELS(JDO240,MTZIN),MTZIN 6020 FORMAT (' ERROR Requested INCLUDE Column label >> ',A,/, + ' NOT Found in File_number: ',I3) C C ************************************** CALL CCPERR(1,' STOP in finding col label') C ************************************** C 230 CONTINUE 240 CONTINUE C IF (KWORK.NE.NUM_INC_COLS(MTZIN)) THEN WRITE (LUNOUT,FMT=6022) MTZIN 6022 FORMAT (' For INCLUDE option, Request Number of Columns',/, + ' NOT all found in File_number: ',I3) C C *********************************** CALL CCPERR(1,' STOP in INCLUDE option') C *********************************** C END IF C C---- or exclude option C ELSE IF (DO_EXCLUDE(MTZIN)) THEN KWORK = 0 C DO 280 JDO280 = 1,NUMCOL(MTZIN) DO 250 JDO250 = 1,NUM_EXC_COLS(MTZIN) IF (EXC_COL_LABELS(JDO250,MTZIN).EQ. + CLABS_WORK(JDO280,MTZIN)) THEN WRITE (LUNOUT,FMT=6024) EXC_COL_LABELS(JDO250,MTZIN), + MTZIN 6024 FORMAT (' For EXCLUDE Option, Column Label >> ',A,/, + ' will be Excluded from File_Number: ',I3) KWORK = KWORK + 1 GO TO 270 END IF 250 CONTINUE C NWORK = NCOLOUT LWORK = 0 C DO 260 JDO260 = 1,NWORK IF (CLABS_WORK(JDO280,MTZIN).EQ.CLABS_OUT(JDO260)) LWORK = 1 260 CONTINUE C C---- havent yet got this label C IF (LWORK.EQ.0) THEN NCOLOUT = NCOLOUT + 1 CLABS_OUT(NCOLOUT) = CLABS_WORK(JDO280,MTZIN) CTYPS_OUT(NCOLOUT) = CTYPS(JDO280,MTZIN) LOOKOUT(JDO280,MTZIN) = NCOLOUT END IF C 270 CONTINUE 280 CONTINUE C IF (KWORK.NE.NUM_EXC_COLS(MTZIN)) THEN WRITE (LUNOUT,FMT=6026) MTZIN 6026 FORMAT (' ERROR for EXCLUDE option',/, + ' NOT all Requested Excluded Labels found in,',/, + ' File_number: ',I3) C C ************************************ CALL CCPERR(1,' STOP in excluded labels') C ************************************ C END IF C END IF C IF (PASSONE) GO TO 290 NCOL_ONE = NCOLOUT IF (DO_TWO_FILES) THEN MTZIN = 2 PASSONE = .TRUE. GO TO 180 END IF C 290 CONTINUE IF (DO_TWO_FILES) NCOL_TWO = NCOLOUT - NCOL_ONE C C--- Now sort out dataset IDs for output columns MLOOP = 1 IF (DO_TWO_FILES) MLOOP = 2 DO 340 JDO20 = 1,MLOOP IF (NDATASETS(JDO20).LE.0) GOTO 340 DO 330 JDO10 = 1,NUMCOL(JDO20) ILOOK = LOOKOUT(JDO10,JDO20) IF (ILOOK.LE.0) GOTO 330 C---- If input file had datasets assigned, match dataset ID to names SETID = CSETID_NFILE(JDO10,JDO20) DO ISET = 1,NDATASETS(JDO20) IF (ISETS(ISET,JDO20).EQ.SETID) THEN PNAME_OUT(ILOOK) = PNAME(ISET,JDO20) DNAME_OUT(ILOOK) = DNAME(ISET,JDO20) END IF ENDDO 330 CONTINUE 340 CONTINUE RETURN END C C ================= SUBROUTINE ONEDSN C ================= C C---- Processes the case of include/exclude and one input data file C C Options INCLUDE and EXCLUDE are specific to a single C input file, while options unique and concat apply C to both input files. option end marks the end of reading C file control option specification cards. as only two input C files are allowed, the file specification options include C and exclude cannot be used with options unique and concat. C when only one input file is supplied, the option end should C be used to mark the end of reading file control option cards. in C more detail the options are as follows: C C A) File control option INCLUDE C C This option applies to one of the input files. the file control C option card containing the code include is followed by a card or C cards containing a list of column labels of data items to be cop- C ied to the output file. column labels for h, k and l should C not be given among these labels. if the input file has not C got any of the labels requested for inclusion, the job will C be aborted. title editing and column label editing cards C are allowed C C B) File control option EXCLUDE C C This option applies to one of the input files. the file control C option card containing the code exclude is followed by a card or C cards containing a list of column labels of data items to be C excluded when creating the output file. C column labels corresponding to h, k and l C should not appear among these label strings as they are taken C care of automatically. the program is aborted if any requested C label string is not found among unedited column labels of the C file. title editing and column label editing cards follow the C specification of the exclude option. C C If the option include or exclude is used when only one input file C is required, the file control option onef should be used to C indicate to the program that only one input file exists. C C C .. parameters .. INTEGER MAXHIS PARAMETER (MAXHIS=30) INTEGER MCOLS PARAMETER (MCOLS=500) INTEGER MSETS PARAMETER (MSETS=MCOLS) INTEGER MFILES_IN PARAMETER (MFILES_IN=2) INTEGER MAXBAT PARAMETER (MAXBAT=5000) integer maxsc parameter (maxsc=12) INTEGER MAXZON PARAMETER (MAXZON=20) C .. C .. scalars in common .. INTEGER LUNIN, LUNOUT, MTZERR, + MTZIN1, MTZIN2, MTZOUT, MTZPRT, + NCOLOUT, NCOL_ONE, NCOL_TWO CHARACTER LATTYP_OUT*1, NAMSPG_OUT*10, + PGNAME_OUT*10, TITOUT*70 LOGICAL LOGRES C .. C .. arrays in common .. INTEGER LENTIT, LOOKOUT, MSORTX, MTZBLS, + NBATX, NHISIN, NHKLCOL, NLAUE, + NREFLX, NSCOL, NSPGRP, NSYM, + NSYMP, NUMCOL CHARACTER CTYPS*1, CTYPS_OUT*1, LATTYP*1, + NAMSPG*10, PGNAME*10, CLABS*30, + CLABS_OUT*30, TITIN*70, HISTIN*80, + HISTOUT*80 C .. C .. local scalars .. INTEGER JDO3,JDO5,MTZAPN,MTZIN,NFOUND,NTOTAL,IREJ REAL RESOL LOGICAL MTZEOF,CLEAN,OK C .. C .. local arrays .. REAL RECIN(MCOLS),RECOUT(MCOLS) INTEGER MTZLOK(MCOLS) LOGICAL LOGMSS(MCOLS) C .. C .. external subroutines .. EXTERNAL LRASSN,LRREFL,LRREFM,LWCLAB,LWREFL,SETOUT,CHKRES C .. C .. intrinsic functions INTRINSIC ABS,NINT C .. C .. common blocks .. COMMON /CHR_MTZIN/ TITIN(MFILES_IN), + HISTIN(MAXHIS,MFILES_IN), + LATTYP(MFILES_IN), + PGNAME(MFILES_IN), + NAMSPG(MFILES_IN), + CLABS(MCOLS,MFILES_IN), + CTYPS(MCOLS,MFILES_IN) COMMON /CHR_MTZOUT/TITOUT, + HISTOUT(MAXHIS), + LATTYP_OUT, + PGNAME_OUT, + NAMSPG_OUT, + CLABS_OUT(MCOLS), + CTYPS_OUT(MCOLS) COMMON /EXTRA_BITS/ + NSCOL(2), NCOLOUT, + NCOL_ONE, NCOL_TWO, + NHKLCOL(3,2), LOOKOUT(MCOLS,2) COMMON /INT_MTZIN/ + LENTIT(MFILES_IN), NUMCOL(MFILES_IN), + NREFLX(MFILES_IN), NHISIN(MFILES_IN), + NBATX(MFILES_IN), NLAUE(MFILES_IN), + NSYM(MFILES_IN), NSYMP(MFILES_IN), + NSPGRP(MFILES_IN), MTZBLS(MAXBAT,MFILES_IN), + MSORTX(5,MFILES_IN) COMMON /U_INOUT/ + LUNIN, LUNOUT, MTZIN1, MTZIN2, MTZOUT, + MTZPRT, MTZERR COMMON /RESCOM/ + LOGRES LOGICAL LOGZON INTEGER IRZONE,KEYZON,NZON,IFOUND,KZSCR,NRECZO COMMON /ZONCOM/ + IRZONE(MAXZON,5),KEYZON(MAXZON),NZON(MAXZON), + IFOUND,LOGZON,KZSCR(MAXZON), + NRECZO(MAXZON) LOGICAL OKZONE INTEGER NDATASETS(MFILES_IN),ISETS(MSETS,MFILES_IN), + CSETID_NFILE(MCOLS,MFILES_IN) REAL DCELL(6,MSETS,MFILES_IN),DWAVEL(MSETS,MFILES_IN) CHARACTER*64 PNAME(MSETS,MFILES_IN),DNAME(MSETS,MFILES_IN), + PNAME_OUT(MCOLS),DNAME_OUT(MCOLS) COMMON /SETS_IO/ NDATASETS,ISETS,CSETID_NFILE,DCELL,DWAVEL, + PNAME,DNAME,PNAME_OUT,DNAME_OUT logical do_scal,scale_all_f,scale_all_i,reverse_anom common /log_scal/ + do_scal,scale_all_f,scale_all_i,reverse_anom C character scal_col_label(maxsc)*30,scal_col_type(maxsc)*1 common /chr_scal/ + scal_col_label,scal_col_type C integer n_scal_col,iscol(maxsc) real scal_val(maxsc),scal_all common /num_scal/ + scal_val,scal_all,n_scal_col,iscol C C .. C .. save statement .. SAVE C .. C .. data statements .. DATA MTZLOK/MCOLS*-1/ C .. C MTZIN = 1 NTOTAL = 0 MTZAPN = 0 C C ************************************************** CALL LRASSN(MTZIN,CLABS(1,MTZIN),NUMCOL(MTZIN),MTZLOK, + CTYPS(1,MTZIN)) CALL LWCLAB(MTZOUT,CLABS_OUT,NCOLOUT,CTYPS_OUT,MTZAPN) CALL LWIDAS(MTZOUT,NCOLOUT,PNAME_OUT,DNAME_OUT,MTZAPN) C ************************************************** C c if ( do_scal ) then nfound = 0 C C If we've used SCALE ALL as an input then we first have to get the c column labels of either type F or type J. These will be written to c the array scal_col_labels. The labels will already be present in c this array if we input SCALE label value ...etc. c if ( scale_all_f .or. scale_all_i .or. reverse_anom) then call get_scal_cols(clabs,ctyps,numcol) endif C c foreach label in scal_col_label...... c do 5 jdo5 = 1,n_scal_col c c check each label in the input MTZFILE..... C do 3 jdo3 = 1,numcol(mtzin) c if (clabs(jdo3,1) .eq. scal_col_label(jdo5)) then c C if the input was not SCALE ALL.... we've no information about the C column types yet so get that as well c if (.not. scale_all_f .and. .not. scale_all_i + .and. .not. reverse_anom ) then scal_col_type(jdo5) = ctyps(jdo3,1) endif C nfound = nfound + 1 c c iscol stores the column number for this label c iscol(nfound) = mtzlok(jdo3) goto 4 endif 3 continue 4 continue c 5 continue if (nfound .eq. 0) then write (6,*)' ** WARNING ** Found zero columns to scale !' else C C Check input columns and try to add sigmas on the SCALE ALL input C and also on the I/F's given without sigmas C call check_scal_cols(clabs,ctyps,mtzlok) endif C endif C IREJ = 0 C 10 CONTINUE C C ******************************** CALL LRREFL(MTZIN,RESOL,RECIN,MTZEOF) C ******************************** C IF (MTZEOF) GO TO 20 C C ******************** CALL LRREFM(MTZIN,LOGMSS) C ******************** C CLEAN = .TRUE. C C *************************************** CALL SETOUT(MTZIN,RECOUT,RECIN,LOGMSS,CLEAN) C *************************************** C IF (LOGRES) THEN C C **************** CALL CHKRES(RESOL,OK) C **************** C IF (.NOT.OK) THEN IREJ = IREJ + 1 GO TO 10 C END IF END IF C C OKZONE = .TRUE. C C ****************************** IF (LOGZON) CALL CHKZON(RECOUT,OKZONE) if (do_scal) call scaleop(recout,logmss,ntotal) C ****************************** C IF (OKZONE) THEN NTOTAL = NTOTAL + 1 C C ********************* CALL LWREFL(MTZOUT,RECOUT) C ********************* C ENDIF GO TO 10 20 CONTINUE WRITE (LUNOUT,FMT=6008) NTOTAL 6008 FORMAT (' Reflections are forwarded to output file:',I10) C IF (LOGRES) WRITE (LUNOUT,FMT=6010) IREJ 6010 FORMAT (' Number of reflections rejected as outside resolution', + ' limits: ',I5) C RETURN END C C ================= SUBROUTINE OPENIP C ================= C C .. parameters .. INTEGER MAXSYM PARAMETER (MAXSYM=192) INTEGER MAXHIS PARAMETER (MAXHIS=30) INTEGER MCOLS PARAMETER (MCOLS=500) INTEGER MSETS PARAMETER (MSETS=MCOLS) INTEGER MFILES_IN PARAMETER (MFILES_IN=2) INTEGER MAXBAT PARAMETER (MAXBAT=5000) INTEGER MAXZON PARAMETER (MAXZON=20) integer maxsc parameter (maxsc=12) C .. C .. scalars in common .. INTEGER LUNIN, LUNOUT, MTZERR, MTZIN1, + MTZIN2, MTZOUT, MTZPRT LOGICAL DO_CONCAT, DO_MERGE, DO_NEW_CELL, + DO_NEW_HIST, DO_NEW_SORT, DO_NEW_SYMM, + DO_ONE_FILE, DO_S_NEW, DO_TWO_FILES, + DO_UNIQUE C .. C .. arrays in common .. REAL CELMTZ, RNGMTZ, RSYM INTEGER LENTIT, MSORTX, MTZBLS, NBATX, NHISIN, + NLAUE, NREFLX, NSPGRP, NSYM, NSYMP, + NUMCOL LOGICAL DO_EDT_COL_NAMES, DO_EDT_TITLE, + DO_EXCLUDE, DO_INCLUDE, + DO_INC_ALL, FOUND_SYM, + SFOUND CHARACTER CTYPS*1, LATTYP*1, NAMSPG*10, + PGNAME*10, CLABS*30, TITIN*70, + HISTIN*80 C .. C .. local scalars .. INTEGER IDUMMY,JJ,MLOOP,MTZIN CHARACTER VERSNX*10, H1*10 C .. C .. local arrays .. CHARACTER MTZNAMES(2)*6 C .. C .. external subroutines .. EXTERNAL ASUSET,LRBATS,LRCELL,LRCLAB,LRHIST,LRINFO,LROPEN,LRSORT, + LRSYMI,LRSYMM,LRTITL C .. C .. common blocks .. COMMON /CHR_MTZIN/ TITIN(MFILES_IN), + HISTIN(MAXHIS,MFILES_IN), + LATTYP(MFILES_IN), + PGNAME(MFILES_IN), + NAMSPG(MFILES_IN), + CLABS(MCOLS,MFILES_IN), + CTYPS(MCOLS,MFILES_IN) COMMON /INT_MTZIN/ + LENTIT(MFILES_IN), NUMCOL(MFILES_IN), + NREFLX(MFILES_IN), NHISIN(MFILES_IN), + NBATX(MFILES_IN), NLAUE(MFILES_IN), + NSYM(MFILES_IN), NSYMP(MFILES_IN), + NSPGRP(MFILES_IN), MTZBLS(MAXBAT,MFILES_IN), + MSORTX(5,MFILES_IN) COMMON /LOG_UTILS/ + DO_INCLUDE(MFILES_IN), + DO_INC_ALL(MFILES_IN), + DO_EXCLUDE(MFILES_IN), + DO_EDT_TITLE(MFILES_IN), + DO_EDT_COL_NAMES(MFILES_IN), + FOUND_SYM(MFILES_IN), + SFOUND(2), + DO_MERGE, DO_NEW_SORT, DO_CONCAT, + DO_UNIQUE, DO_NEW_CELL, DO_S_NEW, + DO_NEW_HIST, DO_TWO_FILES, DO_NEW_SYMM, + DO_ONE_FILE COMMON /REL_MTZIN/ + CELMTZ(6,MFILES_IN), + RNGMTZ(2,MCOLS,MFILES_IN), + RSYM(4,4,MAXSYM,MFILES_IN) COMMON /U_INOUT/ + LUNIN, LUNOUT, MTZIN1, MTZIN2, MTZOUT, + MTZPRT, MTZERR INTEGER JDO100,MODEZ,NMCITM CHARACTER ZSCRNAME*12,ZWORK1*1,ZWORK2*2 LOGICAL LOGZON INTEGER IRZONE,KEYZON,NZON,IFOUND,KZSCR,NRECZO CHARACTER ZONCHR*30 COMMON /CHRZON/ ZONCHR(MAXZON) COMMON /ZONCOM/ + IRZONE(MAXZON,5),KEYZON(MAXZON),NZON(MAXZON), + IFOUND,LOGZON,KZSCR(MAXZON), + NRECZO(MAXZON) INTEGER NDATASETS(MFILES_IN),ISETS(MSETS,MFILES_IN), + CSETID_NFILE(MCOLS,MFILES_IN) REAL DCELL(6,MSETS,MFILES_IN),DWAVEL(MSETS,MFILES_IN) CHARACTER*64 PNAME(MSETS,MFILES_IN),DNAME(MSETS,MFILES_IN), + PNAME_OUT(MCOLS),DNAME_OUT(MCOLS) COMMON /SETS_IO/ NDATASETS,ISETS,CSETID_NFILE,DCELL,DWAVEL, + PNAME,DNAME,PNAME_OUT,DNAME_OUT C logical do_scal,scale_all_f,scale_all_i,reverse_anom common /log_scal/ + do_scal,scale_all_f,scale_all_i,reverse_anom C character scal_col_label(maxsc)*30,scal_col_type(maxsc)*1 common /chr_scal/ + scal_col_label,scal_col_type C integer n_scal_col,iscol(maxsc) real scal_val(maxsc),scal_all common /num_scal/ + scal_val,scal_all,n_scal_col,iscol C C .. C .. save statement .. SAVE C .. C .. data statements .. DATA MTZNAMES/'HKLIN1','HKLIN2'/ C .. C DO 10 JJ = 1,5 CELMTZ(JJ,1) = 0.0 CELMTZ(JJ,2) = 0.0 MSORTX(JJ,1) = -99 MSORTX(JJ,2) = -99 10 CONTINUE C If HKLIN1 isn't assigned, look for HKLIN and use that if assigned CALL UGTENV ('HKLIN1', H1) IF (H1.EQ.' ') THEN CALL UGTENV('HKLIN', H1) IF (H1.NE.' ') MTZNAMES (1) = 'HKLIN' END IF C MLOOP = 1 IF (DO_TWO_FILES) MLOOP = 2 C DO 20 MTZIN = 1,MLOOP C C ******************************************* CALL LROPEN(MTZIN,MTZNAMES(MTZIN),MTZPRT,MTZERR) C ******************************************* C IF (MTZERR.EQ.-1) THEN WRITE (LUNOUT,FMT=*) ' Error in LROPEN for file name ', + MTZNAMES(MTZIN) CALL CCPERR(1,' STOP in lropen') END IF C C ************************************************ CALL LRINFO(MTZIN,VERSNX,NUMCOL(MTZIN),NREFLX(MTZIN), + RNGMTZ(1,1,MTZIN)) C ************************************************ C WRITE (LUNOUT,FMT=6000) MTZIN,VERSNX,NUMCOL(MTZIN), + NREFLX(MTZIN) 6000 FORMAT (/, + ' Reading from HKLIN MTZ File_Number = :',I2,/, + ' This file written with MTZLIB Version Number : ',A,/, + ' File HKLIN contains a total of ',I6,' Columns',/, + ' and a total of ',I10,' Reflections') C NHISIN(MTZIN) = 0 C C ****************************************************** CALL LRTITL(MTZIN,TITIN(MTZIN),LENTIT(MTZIN)) CALL LRHIST(MTZIN,HISTIN(1,MTZIN),NHISIN(MTZIN)) CALL LRCELL(MTZIN,CELMTZ(1,MTZIN)) CALL LRSYMI(MTZIN,NSYMP(MTZIN),LATTYP(MTZIN),NSPGRP(MTZIN), + NAMSPG(MTZIN),PGNAME(MTZIN)) C ****************************************************** C IF (NSPGRP(MTZIN).GT.0) THEN C C ************************************************** CALL LRSYMM(MTZIN,NSYM(MTZIN),RSYM(1,1,1,MTZIN)) CALL ASUSET(NAMSPG(MTZIN),NSPGRP(MTZIN),PGNAME(MTZIN), + NSYM(MTZIN),RSYM(1,1,1,MTZIN),NSYMP(MTZIN), + NLAUE(MTZIN),.TRUE.) C ************************************************** C FOUND_SYM(MTZIN) = .TRUE. ELSE WRITE (LUNOUT,FMT=6002) MTZIN 6002 FORMAT (' Warning for File_Number = ',I2,/, + ' No-Symmetry Found') END IF C C *************************************************** CALL LRBATS(MTZIN,NBATX(MTZIN),MTZBLS(1,MTZIN)) CALL LRSORT(MTZIN,MSORTX(1,MTZIN)) CALL LRCLAB(MTZIN,CLABS(1,MTZIN),CTYPS(1,MTZIN),IDUMMY) CALL LRIDC(MTZIN,PNAME(1,MTZIN),DNAME(1,MTZIN), + ISETS(1,MTZIN),DCELL(1,1,MTZIN), + DWAVEL(1,MTZIN),NDATASETS(MTZIN)) C *************************************************** C---- Get dataset IDs for file columns IF (NDATASETS(MTZIN).GT.0) + CALL LRCLID(MTZIN,CSETID_NFILE(1,MTZIN),IDUMMY) C 20 CONTINUE C C---- Test if AXIS or RZONE Key_Words given, C if so, then open scratch files to store zones C hkl values for tidy printing C IF (.NOT. LOGZON) RETURN C IF (IFOUND.LE.0) THEN C C---- Some sort of error here C C ****************************************************** CALL CCPERR(1,' Error in ZONE/AXIS input - No zones found') C ****************************************************** C END IF C MODEZ = 2 C DO 100 JDO100=1,IFOUND KZSCR(JDO100) = JDO100 + 40 C IF (JDO100.LE.9) THEN WRITE (ZWORK1,6600) JDO100 6600 FORMAT(I1) ZSCRNAME = 'Util_Zone.' // ZWORK1 ELSE WRITE(ZWORK2,6601) JDO100 6601 FORMAT(I2) ZSCRNAME = 'Util_Zone.' // ZWORK2 END IF C C **************************************** CALL QOPEN (KZSCR(JDO100),ZSCRNAME,'SCRATCH') CALL QMODE (KZSCR(JDO100),MODEZ,NMCITM) C **************************************** C 100 CONTINUE C RETURN END C C ================= SUBROUTINE OPENOP C ================= C C C .. parameters .. INTEGER MAXSYM PARAMETER (MAXSYM=192) INTEGER MAXHIS PARAMETER (MAXHIS=30) INTEGER MCOLS PARAMETER (MCOLS=500) INTEGER MSETS PARAMETER (MSETS=MCOLS) INTEGER MFILES_IN PARAMETER (MFILES_IN=2) C .. C .. scalars in common .. INTEGER LENTIT_OUT, LUNIN, LUNOUT, MTZERR, + MTZIN1, MTZIN2, MTZOUT, MTZPRT, + NHISOUT, NLAUE_OUT, NSPGRP_OUT, NSYMP_OUT, + NSYM_OUT, NUMCOL_OUT CHARACTER LATTYP_OUT*1, NAMSPG_OUT*10, + PGNAME_OUT*10, TITOUT*70 LOGICAL DO_CONCAT, DO_MERGE, DO_NEW_CELL, + DO_NEW_HIST, DO_NEW_SORT, DO_NEW_SYMM, + DO_ONE_FILE, DO_S_NEW, DO_TWO_FILES, + DO_UNIQUE C .. C .. arrays in common .. REAL CELOUT, RSYM_OUT INTEGER MSORTX_OUT CHARACTER CTYPS_OUT*1, CLABS_OUT*30, HISTOUT*80 LOGICAL DO_EDT_COL_NAMES, DO_EDT_TITLE, + DO_EXCLUDE, DO_INCLUDE, + DO_INC_ALL, FOUND_SYM, + SFOUND C .. C .. local scalars .. INTEGER MTITOT C .. C .. external subroutines .. EXTERNAL LWCELL,LWHIST,LWHSTL,LWOPEN,LWSORT,LWSYMM,LWTITL,WRBATS C .. C .. common blocks .. COMMON /CHR_MTZOUT/TITOUT, + HISTOUT(MAXHIS), + LATTYP_OUT, + PGNAME_OUT, + NAMSPG_OUT, + CLABS_OUT(MCOLS), + CTYPS_OUT(MCOLS) COMMON /INT_MTZOUT/ + LENTIT_OUT, NUMCOL_OUT, + NHISOUT, NLAUE_OUT, + NSYM_OUT, NSYMP_OUT, + NSPGRP_OUT, MSORTX_OUT(5) COMMON /REL_MTZOUT/ + CELOUT(6), + RSYM_OUT(4,4,MAXSYM) COMMON /U_INOUT/ + LUNIN, LUNOUT, MTZIN1, MTZIN2, MTZOUT, + MTZPRT, MTZERR COMMON /LOG_UTILS/ + DO_INCLUDE(MFILES_IN), + DO_INC_ALL(MFILES_IN), + DO_EXCLUDE(MFILES_IN), + DO_EDT_TITLE(MFILES_IN), + DO_EDT_COL_NAMES(MFILES_IN), + FOUND_SYM(MFILES_IN), + SFOUND(2), + DO_MERGE, DO_NEW_SORT, DO_CONCAT, + DO_UNIQUE, DO_NEW_CELL, DO_S_NEW, + DO_NEW_HIST, DO_TWO_FILES, DO_NEW_SYMM, + DO_ONE_FILE INTEGER NDATASETS(MFILES_IN),ISETS(MSETS,MFILES_IN), + CSETID_NFILE(MCOLS,MFILES_IN) REAL DCELL(6,MSETS,MFILES_IN),DWAVEL(MSETS,MFILES_IN) CHARACTER*64 PNAME(MSETS,MFILES_IN),DNAME(MSETS,MFILES_IN), + PNAME_OUT(MCOLS),DNAME_OUT(MCOLS) COMMON /SETS_IO/ NDATASETS,ISETS,CSETID_NFILE,DCELL,DWAVEL, + PNAME,DNAME,PNAME_OUT,DNAME_OUT C .. C .. save statement .. SAVE C .. C MTITOT = 0 C C **************************** CALL LWOPEN(MTZOUT,'HKLOUT') CALL LWTITL(MTZOUT,TITOUT,MTITOT) C **************************** C IF (NHISOUT.GT.0) THEN CALL LWHIST(MTZOUT,HISTOUT,NHISOUT) CALL LWHSTL (MTZOUT, 'after history:') ELSE CALL LWHSTL (MTZOUT, ' ') END IF C IF (NSYM_OUT.GT.0) THEN C C ***************************************************** CALL LWSYMM(MTZOUT,NSYM_OUT,NSYMP_OUT,RSYM_OUT,LATTYP_OUT, + NSPGRP_OUT,NAMSPG_OUT,PGNAME_OUT) C ***************************************************** C END IF C C ************************** CALL LWCELL(MTZOUT,CELOUT) CALL LWSORT(MTZOUT,MSORTX_OUT) MLOOP = 1 IF (DO_TWO_FILES) MLOOP = 2 C DO 20 I = 1,MLOOP DO J = 1,NDATASETS(I) call lwidc(MTZOUT,PNAME(J,I),DNAME(J,I), + DCELL(1,J,I),DWAVEL(J,I)) ENDDO 20 CONTINUE CALL WRBATS C ************************** C END C C ================= SUBROUTINE PCOCAT C ================= C C E) File control option CONCAT C C This file control option specifies that the data records of the C two input files are to be copied to the output file. the option C is used to create a multiple record type output file from the two C input files by merging them. the output file contains edited C titles from both the input files and edited labels from the first C input file. the labels of the first input file should be edited C to become identical with the existing labels in the second input C file failing which the program will abort. C C Concatenate two input file and create a multirecord type C of output file. the columns in the two input files must C be identical. C C C .. parameters .. INTEGER MAXHIS PARAMETER (MAXHIS=30) INTEGER MCOLS PARAMETER (MCOLS=500) INTEGER MSETS PARAMETER (MSETS=MCOLS) INTEGER MFILES_IN PARAMETER (MFILES_IN=2) INTEGER MAXSYM PARAMETER (MAXSYM=192) INTEGER MAXBAT PARAMETER (MAXBAT=5000) INTEGER MCOLS2 PARAMETER (MCOLS2=MCOLS*2) INTEGER ENDSRT PARAMETER (ENDSRT=-1) C .. C .. scalars in common .. REAL RESMAX, RESMIN, SMAX, SMIN INTEGER LENTIT_OUT, LUNIN, LUNOUT, MTZERR, + MTZIN1, MTZIN2, MTZOUT, MTZPRT, + NCOLOUT, NCOL_ONE, NCOL_TWO, NHISOUT, + NLAUE_OUT, NSPGRP_OUT, NSYMP_OUT, NSYM_OUT, + NUMCOL_OUT LOGICAL LOGRES CHARACTER LATTYP_OUT*1, NAMSPG_OUT*10, + PGNAME_OUT*10, TITOUT*70 C .. C .. arrays in common .. REAL CELMTZ, RNGMTZ, RSYM INTEGER LENTIT, LOOKOUT, MSORTX, MSORTX_OUT, + MTZBLS, NBATX, NHISIN, NHKLCOL, + NLAUE, NREFLX, NSCOL, NSPGRP, + NSYM, NSYMP, NUMCOL CHARACTER CTYPS*1, CTYPS_OUT*1, LATTYP*1, + NAMSPG*10, PGNAME*10, CLABS*30, + CLABS_OUT*30, TITIN*70, HISTIN*80, + HISTOUT*80 C .. C .. local scalars .. INTEGER I,IH,IK,IL,MTZAPN,NTOTAL,NTOSORT1,NTOSORT2,NFROMSORT, + LWORK,ISTAT,JDO10,IREJ REAL DUMMY, RESOL, VAL_MAGIC, VRSET_MAGIC LOGICAL MTZEOF,OK,SETVAL C .. C .. local arrays .. REAL RECIN_1(MCOLS), RECIN_2(MCOLS), RECOUT(MCOLS) INTEGER MTZLOK(MCOLS,2) C .. C .. external subroutines .. EXTERNAL LRASSN,LRREFL,LWCLAB,LWREFL,SET_MAGIC,SORTINI, + RESET_MAGIC C .. C .. external functions .. REAL LSTLSQ INTEGER SRTMRG,SRTRET,SRTRLS EXTERNAL LSTLSQ,SRTMRG,SRTRET,SRTRLS C .. C .. intrinsic functions .. INTRINSIC NINT,ABS C .. C .. common blocks .. COMMON /CHR_MTZIN/ TITIN(MFILES_IN), + HISTIN(MAXHIS,MFILES_IN), + LATTYP(MFILES_IN), + PGNAME(MFILES_IN), + NAMSPG(MFILES_IN), + CLABS(MCOLS,MFILES_IN), + CTYPS(MCOLS,MFILES_IN) COMMON /CHR_MTZOUT/TITOUT, + HISTOUT(MAXHIS), + LATTYP_OUT, + PGNAME_OUT, + NAMSPG_OUT, + CLABS_OUT(MCOLS), + CTYPS_OUT(MCOLS) COMMON /EXTRA_BITS/ + NSCOL(2), NCOLOUT, + NCOL_ONE, NCOL_TWO, + NHKLCOL(3,2), LOOKOUT(MCOLS,2) COMMON /INT_MTZIN/ + LENTIT(MFILES_IN), NUMCOL(MFILES_IN), + NREFLX(MFILES_IN), NHISIN(MFILES_IN), + NBATX(MFILES_IN), NLAUE(MFILES_IN), + NSYM(MFILES_IN), NSYMP(MFILES_IN), + NSPGRP(MFILES_IN), MTZBLS(MAXBAT,MFILES_IN), + MSORTX(5,MFILES_IN) COMMON /INT_MTZOUT/ + LENTIT_OUT, NUMCOL_OUT, + NHISOUT, NLAUE_OUT, + NSYM_OUT, NSYMP_OUT, + NSPGRP_OUT, MSORTX_OUT(5) COMMON /REL_MTZIN/ + CELMTZ(6,MFILES_IN), + RNGMTZ(2,MCOLS,MFILES_IN), + RSYM(4,4,MAXSYM,MFILES_IN) COMMON /U_INOUT/ + LUNIN, LUNOUT, MTZIN1, MTZIN2, MTZOUT, + MTZPRT, MTZERR COMMON /RESOLN/ + RESMIN, RESMAX, SMIN, SMAX COMMON /RESCOM/ + LOGRES INTEGER MAXZON PARAMETER (MAXZON=20) LOGICAL LOGZON,OKZONE INTEGER IRZONE,KEYZON,NZON,IFOUND,KZSCR,NRECZO CHARACTER ZONCHR*30 COMMON /CHRZON/ ZONCHR(MAXZON) COMMON /ZONCOM/ + IRZONE(MAXZON,5),KEYZON(MAXZON),NZON(MAXZON), + IFOUND,LOGZON,KZSCR(MAXZON), + NRECZO(MAXZON) INTEGER NDATASETS(MFILES_IN),ISETS(MSETS,MFILES_IN), + CSETID_NFILE(MCOLS,MFILES_IN) REAL DCELL(6,MSETS,MFILES_IN),DWAVEL(MSETS,MFILES_IN) CHARACTER*64 PNAME(MSETS,MFILES_IN),DNAME(MSETS,MFILES_IN), + PNAME_OUT(MCOLS),DNAME_OUT(MCOLS) COMMON /SETS_IO/ NDATASETS,ISETS,CSETID_NFILE,DCELL,DWAVEL, + PNAME,DNAME,PNAME_OUT,DNAME_OUT C .. C .. save statement .. SAVE C .. C .. data statements .. DATA MTZLOK/MCOLS2*-1/ C .. C NTOSORT1 = 0 NTOSORT2 = 0 NFROMSORT = 0 NTOTAL = 0 IREJ = 0 DUMMY = 0.0 C IF (NUMCOL(1) .NE. NUMCOL(2)) THEN WRITE(LUNOUT,6001) NUMCOL(1),NUMCOL(2) 6001 FORMAT(' Datasets have Different Number of Columns ',I4, + ' ',I4) C C *************************************** CALL CCPERR(1,' STOP in diff col numbers') C *************************************** C END IF C LWORK = 0 C C---- check if column labels in file_number_1 (now put in clabs_out) C are equal to column labels in file_number_2 C DO 10 JDO10 =1,NUMCOL(1) IF (CLABS_OUT(JDO10).NE.CLABS(JDO10,2)) THEN LWORK = LWORK + 1 ELSE IF (CTYPS_OUT(JDO10).NE.CTYPS(JDO10,2)) THEN LWORK = LWORK + 1 ENDIF 10 CONTINUE C IF (LWORK.GT.0) THEN WRITE(LUNOUT,6022) 6022 FORMAT(' Column Labels/Types are not the same for these', + /,' datasets in subroutine option concat') C C ******************************* CALL CCPERR(1,' STOP in col labels') C ******************************* C END IF C MTZAPN = 0 C IREJ = 0 C C ***************************************************** CALL LRASSN(1,CLABS(1,1),NUMCOL(1),MTZLOK(1,1),CTYPS(1,1)) CALL LRASSN(2,CLABS(1,2),NUMCOL(2),MTZLOK(1,2),CTYPS(1,2)) CALL LWCLAB(MTZOUT,CLABS_OUT,NCOLOUT,CTYPS_OUT,MTZAPN) CALL LWIDAS(MTZOUT,NCOLOUT,PNAME_OUT,DNAME_OUT,MTZAPN) C ***************************************************** C C---- initialise sorting C C ********************************** CALL SORTINI(MSORTX_OUT,NCOLOUT,LUNOUT) C ********************************** C C---- Handle missing number flag. Need to convert it for sort and then reset C for output file. C VRSET_MAGIC = -99999.0 DO 20 I=1,NUMCOL(1) IF (RNGMTZ(1,I,1) .LT. VRSET_MAGIC) VRSET_MAGIC = RNGMTZ(1,I,1) IF (RNGMTZ(1,I,2) .LT. VRSET_MAGIC) VRSET_MAGIC = RNGMTZ(1,I,2) 20 CONTINUE VRSET_MAGIC = 10.0 * VRSET_MAGIC C SETVAL = .FALSE. C C ***************************** CALL SET_MAGIC(1,VAL_MAGIC,SETVAL) C ***************************** C C---- process reflection data C C ... (i) file_number_1 C 50 CONTINUE C C ****************************** CALL LRREFL(1,RESOL,RECIN_1,MTZEOF) C ****************************** C IF (MTZEOF) GO TO 60 C C---- Reset missing numbers so it can be handled by sort C C ********************************************************* CALL RESET_MAGIC(1,RECIN_1,RECOUT,NUMCOL(1),DUMMY,VRSET_MAGIC) C ********************************************************* C C---- pass keys and record to sort C C ************** ISTAT = SRTRLS(RECOUT) C ************** C NTOSORT1 = NTOSORT1 + 1 C IF (ISTAT.NE.0) THEN WRITE (LUNOUT,FMT=6050) ISTAT 6050 FORMAT ( + ' MTZUTILS Failed to release record to SORT Procedure,',/, + ' for CONCAT option with File_NUMBER : 1, Status = ',I9,/) C C ************************* CALL CCPERR(1,' STOP in sort') C ************************* C END IF C GO TO 50 C C ... (i) file_number_1 C 60 CONTINUE C C ****************************** CALL LRREFL(2,RESOL,RECIN_2,MTZEOF) C ****************************** C IF (MTZEOF) GO TO 70 C C---- Reset missing values before passed to sort C C ********************************************************* CALL RESET_MAGIC(2,RECIN_2,RECOUT,NUMCOL(2),DUMMY,VRSET_MAGIC) C ********************************************************* C C---- pass keys and record to sort C C ************** ISTAT = SRTRLS(RECOUT) C ************** C NTOSORT2 = NTOSORT2 + 1 C IF (ISTAT.NE.0) THEN WRITE (LUNOUT,FMT=6051) ISTAT 6051 FORMAT ( + ' MTZUTILS Failed to release record to SORT procedure,',/, + ' for CONCAT option with File_number : 2, Status = ',I9,/) C C ************************* CALL CCPERR(1,' STOP in sort') C ************************* C END IF C GO TO 60 C 70 CONTINUE C C---- all records passed, now sort them C WRITE (LUNOUT,FMT=6060) NTOSORT1,NTOSORT2 6060 FORMAT ( + I20,' Records passed to SORT From File_number_1',/, + I20,' Records passed to SORT From File_number_2') C C ******** ISTAT = SRTMRG() C ******** C IF (ISTAT.NE.0) THEN WRITE (LUNOUT,FMT=6062) ISTAT 6062 FORMAT ( + ' MTZUTILS Detected failure in Merge Phase of SORT ',/, + ' Procedure, with CONCAT option: status = ',I9,/) C C ************************** CALL CCPERR(1,' STOP in sort ') C ************************** C END IF C 80 CONTINUE C C---- now pick up records and output C C ************** ISTAT = SRTRET(RECOUT) C ************** C IF (ISTAT.EQ.ENDSRT) GO TO 90 C IF (ISTAT.NE.0) THEN C C---- error in sort read back C WRITE (LUNOUT,FMT=6064) ISTAT 6064 FORMAT ( + ' MTZUTILS Detected Error on obtaining record from SORT ',/, + ' Procedure in Return Phase, For CONCAT option: status = ', +I4,/) C C ************************* CALL CCPERR(1,' STOP in sort') C ************************* c END IF C C---- do you apply overall resolution limits now ??? C IF (LOGRES) THEN IH = NINT(RECOUT(1)) IK = NINT(RECOUT(2)) IL = NINT(RECOUT(3)) RESOL = LSTLSQ(MTZOUT,IH,IK,IL) C C **************** CALL CHKRES(RESOL,OK) C **************** C IF (.NOT.OK) THEN IREJ = IREJ + 1 GO TO 80 END IF END IF C C C---- The data from sort has missing number flag of VRSET_MAGIC C but is output as VAL_MAGIC C C *********************************************************** CALL RESET_MAGIC(0,RECOUT,RECIN_1,NCOLOUT,VRSET_MAGIC,VAL_MAGIC) C *********************************************************** C OKZONE = .TRUE. C C ********************* IF (LOGZON) CALL CHKZON(RECOUT,OKZONE) C ********************* C IF (OKZONE) THEN NFROMSORT = NFROMSORT + 1 C C ********************** CALL LWREFL(MTZOUT,RECIN_1) C ********************** C ENDIF GO TO 80 C 90 CONTINUE C WRITE (LUNOUT,6033) NFROMSORT 6033 FORMAT( + ' Total Number of Reflections in Output File: ',I20) IF (LOGRES) WRITE (LUNOUT,FMT=6035) IREJ 6035 FORMAT( +' Number of Reflections rejected as outside Resolution ', +'Limits: ',I5) C RETURN END C SUBROUTINE PRMERG C ================= C C---- merge two input file and create a multirecord type mtz C output file. the columns in the two input files need not C be identical. C C F) File control option MERGE C C This option creates a multi-record type merged mtz file from two C input mtz files. the columns in the two input files need not be C identical. the column labels in the output file will be the C common labels from the two files, the unique labels from file 1 C and the unique labels from file 2. C C .. parameters .. INTEGER MAXHIS PARAMETER (MAXHIS=30) INTEGER MCOLS PARAMETER (MCOLS=500) INTEGER MSETS PARAMETER (MSETS=MCOLS) INTEGER MFILES_IN PARAMETER (MFILES_IN=2) INTEGER MAXBAT PARAMETER (MAXBAT=5000) INTEGER MCOLS2 PARAMETER (MCOLS2=MCOLS*2) C .. C .. scalars in common .. INTEGER LENTIT_OUT, LUNIN, LUNOUT, MTZERR, + MTZIN1, MTZIN2, MTZOUT, MTZPRT, + NCOLOUT, NCOL_ONE, NCOL_TWO, NHISOUT, + NLAUE_OUT, NSPGRP_OUT, NSYMP_OUT, NSYM_OUT, + NUMCOL_OUT LOGICAL LOGRES CHARACTER LATTYP_OUT*1, NAMSPG_OUT*10, + PGNAME_OUT*10, TITOUT*70 C .. C .. arrays in common .. INTEGER LENTIT, LOOKOUT, MSORTX, MSORTX_OUT, + MTZBLS, NBATX, NHISIN, NHKLCOL, + NLAUE, NREFLX, NSCOL, NSPGRP, + NSYM, NSYMP, NUMCOL CHARACTER CTYPS*1, CTYPS_OUT*1, LATTYP*1, + NAMSPG*10, PGNAME*10, CLABS*30, + CLABS_OUT*30, TITIN*70, HISTIN*80, + HISTOUT*80 C .. C .. local scalars .. INTEGER IREJ,IREJ1,IREJ2,MTZAPN,NCOMN,NTOTAL REAL RESOL LOGICAL MTZEOF,CLEAN,OK C .. C .. local arrays .. REAL RECIN_1(MCOLS), RECIN_2(MCOLS), RECOUT(MCOLS) INTEGER MTZLOK(MCOLS,2) LOGICAL LOGMSS_1(MCOLS), LOGMSS_2(MCOLS) C .. C .. external subroutines .. EXTERNAL LRASSN,LRREFL,LRREFM,LWCLAB,LWREFL,SETOUT,CHKRES C .. C .. intrinsic functions .. INTRINSIC ABS,NINT C .. C .. Common blocks .. COMMON /CHR_MTZIN/ TITIN(MFILES_IN), + HISTIN(MAXHIS,MFILES_IN), + LATTYP(MFILES_IN), + PGNAME(MFILES_IN), + NAMSPG(MFILES_IN), + CLABS(MCOLS,MFILES_IN), + CTYPS(MCOLS,MFILES_IN) COMMON /CHR_MTZOUT/TITOUT, + HISTOUT(MAXHIS), + LATTYP_OUT, + PGNAME_OUT, + NAMSPG_OUT, + CLABS_OUT(MCOLS), + CTYPS_OUT(MCOLS) COMMON /EXTRA_BITS/ + NSCOL(2), NCOLOUT, + NCOL_ONE, NCOL_TWO, + NHKLCOL(3,2), LOOKOUT(MCOLS,2) COMMON /INT_MTZIN/ + LENTIT(MFILES_IN), NUMCOL(MFILES_IN), + NREFLX(MFILES_IN), NHISIN(MFILES_IN), + NBATX(MFILES_IN), NLAUE(MFILES_IN), + NSYM(MFILES_IN), NSYMP(MFILES_IN), + NSPGRP(MFILES_IN), MTZBLS(MAXBAT,MFILES_IN), + MSORTX(5,MFILES_IN) COMMON /INT_MTZOUT/ + LENTIT_OUT, NUMCOL_OUT, + NHISOUT, NLAUE_OUT, + NSYM_OUT, NSYMP_OUT, + NSPGRP_OUT, MSORTX_OUT(5) COMMON /U_INOUT/ + LUNIN, LUNOUT, MTZIN1, MTZIN2, MTZOUT, + MTZPRT, MTZERR COMMON /RESCOM/ + LOGRES INTEGER MAXZON PARAMETER (MAXZON=20) LOGICAL LOGZON,OKZONE INTEGER IRZONE,KEYZON,NZON,IFOUND,KZSCR,NRECZO CHARACTER ZONCHR*30 COMMON /CHRZON/ ZONCHR(MAXZON) COMMON /ZONCOM/ + IRZONE(MAXZON,5),KEYZON(MAXZON),NZON(MAXZON), + IFOUND,LOGZON,KZSCR(MAXZON), + NRECZO(MAXZON) INTEGER NDATASETS(MFILES_IN),ISETS(MSETS,MFILES_IN), + CSETID_NFILE(MCOLS,MFILES_IN) REAL DCELL(6,MSETS,MFILES_IN),DWAVEL(MSETS,MFILES_IN) CHARACTER*64 PNAME(MSETS,MFILES_IN),DNAME(MSETS,MFILES_IN), + PNAME_OUT(MCOLS),DNAME_OUT(MCOLS) COMMON /SETS_IO/ NDATASETS,ISETS,CSETID_NFILE,DCELL,DWAVEL, + PNAME,DNAME,PNAME_OUT,DNAME_OUT C .. C .. Save statement .. SAVE C .. C .. data statements .. DATA MTZLOK/MCOLS2*-1/ C .. C NCOMN = 0 NTOTAL = 0 C CLEAN = .TRUE. C MTZAPN = 0 C C ***************************************************** CALL LRASSN(1,CLABS(1,1),NUMCOL(1),MTZLOK(1,1),CTYPS(1,1)) CALL LRASSN(2,CLABS(1,2),NUMCOL(2),MTZLOK(1,2),CTYPS(1,2)) CALL LWCLAB(MTZOUT,CLABS_OUT,NCOLOUT,CTYPS_OUT,MTZAPN) CALL LWIDAS(MTZOUT,NCOLOUT,PNAME_OUT,DNAME_OUT,MTZAPN) C ***************************************************** C IREJ = 0 IREJ1 = 0 IREJ2 = 0 C 10 CONTINUE C C ****************************** CALL LRREFL(1,RESOL,RECIN_1,MTZEOF) C ****************************** C IF (MTZEOF) GO TO 100 C C ****************** CALL LRREFM(1,LOGMSS_1) C ****************** C 20 CONTINUE C C ****************************** CALL LRREFL(2,RESOL,RECIN_2,MTZEOF) C ****************************** C IF (MTZEOF) GO TO 110 C C ****************** CALL LRREFM(2,LOGMSS_2) C ****************** C 30 CONTINUE IF (NINT(RECIN_1(1)-RECIN_2(1))) 70,40,80 40 IF (NINT(RECIN_1(2)-RECIN_2(2))) 70,50,80 50 IF (NINT(RECIN_1(3)-RECIN_2(3))) 70,60,80 60 CONTINUE C C....................................................................... C---- both hkl the same C NCOMN = NCOMN + 1 IF (LOGRES) THEN C C **************** CALL CHKRES(RESOL,OK) C **************** C IF (.NOT.OK) THEN IREJ1 = IREJ1 + 1 GO TO 65 END IF END IF C C *************************************** CALL SETOUT(1,RECOUT,RECIN_1,LOGMSS_1,CLEAN) C *************************************** C OKZONE = .TRUE. C C ********************* IF (LOGZON) CALL CHKZON(RECOUT,OKZONE) C ********************* IF (OKZONE) THEN NTOTAL = NTOTAL + 1 C C ********************* CALL LWREFL(MTZOUT,RECOUT) C ********************* C ENDIF C 65 CONTINUE C IF (LOGRES) THEN C C **************** CALL CHKRES(RESOL,OK) C **************** C IF (.NOT.OK) THEN IREJ2 = IREJ2 + 1 GO TO 10 END IF END IF C C *************************************** CALL SETOUT(2,RECOUT,RECIN_2,LOGMSS_2,CLEAN) C *************************************** C OKZONE = .TRUE. C C ********************* IF (LOGZON) CALL CHKZON(RECOUT,OKZONE) C ********************* IF (OKZONE) THEN NTOTAL = NTOTAL + 1 C C ********************* CALL LWREFL(MTZOUT,RECOUT) C ********************* C ENDIF C GO TO 10 70 CONTINUE C C....................................................................... C---- first one is small C IF (LOGRES) THEN C C **************** CALL CHKRES(RESOL,OK) C **************** C IF (.NOT.OK) THEN IREJ1 = IREJ1 + 1 GO TO 75 END IF END IF C C *************************************** CALL SETOUT(1,RECOUT,RECIN_1,LOGMSS_1,CLEAN) C *************************************** C OKZONE = .TRUE. C C ********************* IF (LOGZON) CALL CHKZON(RECOUT,OKZONE) C ********************* IF (OKZONE) THEN NTOTAL = NTOTAL + 1 C C ********************* CALL LWREFL(MTZOUT,RECOUT) C ********************* C ENDIF C 75 CONTINUE C C ****************************** CALL LRREFL(1,RESOL,RECIN_1,MTZEOF) C ****************************** C IF (MTZEOF) GO TO 90 C C ****************** CALL LRREFM(1,LOGMSS_1) C ****************** C GO TO 30 C....................................................................... 80 CONTINUE C C---- second one small C IF (LOGRES) THEN C C **************** CALL CHKRES(RESOL,OK) C **************** C IF (.NOT.OK) THEN IREJ2 = IREJ2 + 1 GO TO 85 END IF END IF C C *************************************** CALL SETOUT(2,RECOUT,RECIN_2,LOGMSS_2,CLEAN) C *************************************** C OKZONE = .TRUE. C C ********************* IF (LOGZON) CALL CHKZON(RECOUT,OKZONE) C ********************* IF (OKZONE) THEN NTOTAL = NTOTAL + 1 C C ********************* CALL LWREFL(MTZOUT,RECOUT) C ********************* C ENDIF C 85 CONTINUE C C ****************************** CALL LRREFL(2,RESOL,RECIN_2,MTZEOF) C ****************************** C IF (MTZEOF) GO TO 110 C ! was 120 ! C ****************** CALL LRREFM(2,LOGMSS_2) C ****************** C GO TO 30 C....................................................................... C File 1 finished, finish off file 2 90 CONTINUE C IF (LOGRES) THEN C C **************** CALL CHKRES(RESOL,OK) C **************** C IF (.NOT.OK) THEN IREJ2 = IREJ2 + 1 GO TO 95 END IF END IF C C *************************************** CALL SETOUT(2,RECOUT,RECIN_2,LOGMSS_2,CLEAN) C *************************************** C OKZONE = .TRUE. C C ********************* IF (LOGZON) CALL CHKZON(RECOUT,OKZONE) C ********************* IF (OKZONE) THEN NTOTAL = NTOTAL + 1 C C ********************* CALL LWREFL(MTZOUT,RECOUT) C ********************* C ENDIF C 95 CONTINUE C C ****************************** 100 CALL LRREFL(2,RESOL,RECIN_2,MTZEOF) C ****************************** C IF (MTZEOF) GO TO 120 C C ****************** CALL LRREFM(2,LOGMSS_2) C ****************** C GO TO 90 C....................................................................... C File 2 finished, finish off file 1 110 CONTINUE C IF (LOGRES) THEN C C **************** CALL CHKRES(RESOL,OK) C **************** C IF (.NOT.OK) THEN IREJ1 = IREJ1 + 1 GO TO 115 END IF END IF C C *************************************** CALL SETOUT(1,RECOUT,RECIN_1,LOGMSS_1,CLEAN) C *************************************** C OKZONE = .TRUE. C C ********************* IF (LOGZON) CALL CHKZON(RECOUT,OKZONE) C ********************* IF (OKZONE) THEN NTOTAL = NTOTAL + 1 C C ********************* CALL LWREFL(MTZOUT,RECOUT) C ********************* C ENDIF C 115 CONTINUE C C ****************************** CALL LRREFL(1,RESOL,RECIN_1,MTZEOF) C ****************************** C IF (MTZEOF) GO TO 120 GO TO 110 C....................................................................... C All finished 120 CONTINUE C WRITE (LUNOUT,FMT=6000) NCOMN,NTOTAL 6000 FORMAT (/, +' Interleaved Reflections in Output File:',I10,/, +' Total Number of Reflections in Output File:',I10) C IF (LOGRES) THEN IREJ = IREJ1 + IREJ2 WRITE (LUNOUT,FMT=6002) IREJ,IREJ1,IREJ2 6002 FORMAT( +' Total No. of Reflections Rejected during Merge: ',I10,/, +' Including ',I8,' From File 1 ',/, +' and ',I8,' From File 2 ',/, +' ( All Outside Resolution Limits)') END IF C RETURN END C C ================= SUBROUTINE PROOPT C ================= C C .. parameters .. INTEGER MAXSYM PARAMETER (MAXSYM=192) INTEGER MCOLS PARAMETER (MCOLS=500) INTEGER MFILES_IN PARAMETER (MFILES_IN=2) C .. C .. scalars in common .. REAL RESMAX, RESMIN, SMAX, SMIN INTEGER LUNIN, LUNOUT, MTZERR, MTZIN1, MTZIN2, + MTZOUT, MTZPRT, NCOLOUT, NCOL_ONE, NCOL_TWO LOGICAL DO_CONCAT, DO_MERGE, DO_NEW_CELL, + DO_NEW_HIST, DO_NEW_SORT, DO_NEW_SYMM, + DO_ONE_FILE, DO_S_NEW, DO_TWO_FILES, + DO_UNIQUE C .. C .. arrays in common .. INTEGER LOOKOUT, NHKLCOL, NSCOL LOGICAL DO_EDT_COL_NAMES, DO_EDT_TITLE, + DO_EXCLUDE, DO_INCLUDE, + DO_INC_ALL, FOUND_SYM, + SFOUND C .. C .. external subroutines .. EXTERNAL PCOCAT,PRMERG,ONEDSN,PRUNIQ C .. C .. common blocks .. COMMON /EXTRA_BITS/ + NSCOL(2), NCOLOUT, + NCOL_ONE, NCOL_TWO, + NHKLCOL(3,2), LOOKOUT(MCOLS,2) COMMON /LOG_UTILS/ + DO_INCLUDE(MFILES_IN), + DO_INC_ALL(MFILES_IN), + DO_EXCLUDE(MFILES_IN), + DO_EDT_TITLE(MFILES_IN), + DO_EDT_COL_NAMES(MFILES_IN), + FOUND_SYM(MFILES_IN), + SFOUND(2), + DO_MERGE, DO_NEW_SORT, DO_CONCAT, + DO_UNIQUE, DO_NEW_CELL, DO_S_NEW, + DO_NEW_HIST, DO_TWO_FILES, DO_NEW_SYMM, + DO_ONE_FILE COMMON /U_INOUT/ + LUNIN, LUNOUT, MTZIN1, MTZIN2, MTZOUT, + MTZPRT, MTZERR COMMON /RESOLN/ + RESMIN, RESMAX, SMIN, SMAX C .. C .. save statement .. SAVE C .. C C ************************* IF (DO_UNIQUE) THEN CALL PRUNIQ RETURN ELSE IF (DO_MERGE) THEN CALL PRMERG RETURN ELSE IF (DO_CONCAT) THEN CALL PCOCAT RETURN ELSE IF (DO_ONE_FILE) THEN CALL ONEDSN RETURN ELSE IF (DO_TWO_FILES) THEN C C---- for exclude/include options use the unique subroutine C CALL PRUNIQ RETURN Ccccccccccc call twodsn ELSE CALL CCPERR(1,' How the hell did you get here ?') END IF C ************************* C RETURN END C C ================= SUBROUTINE PRUNIQ C ================= C C Read two datasets and adds the second to the first dataset using C the lookup table in setout C C---- Read two datasets and adds the second to the first dataset using C the lookup table in icols2. ncols2 is the number of columns from C the second dataset C C D) File control option UNIQUE C C This file control option speficies that each column of the two C input files with a unique label is to be copied to the output C file and that, whenever a particular reflection appears in both C the input files, the data should be merged into a single record C of the output file. note that unique columns are recognised from C the unedited labels of the input files. if a column label is C found in both the input files then the data value from the first C file is copied to the output record. both the input files should C have identical labels for h, k and l or otherwise the output file C will contain three extra columns containing the values of h, k C and l derived from the second input file. the output file from C this option is of the single record/reflection type (i.e. a C standard mtz file) though, if the input data sets are not C properly sorted on h, k and l (the first three columns), the C output file may become of mixed type with both types of record C present. C C .. parameters .. INTEGER MAXHIS PARAMETER (MAXHIS=30) INTEGER MCOLS PARAMETER (MCOLS=500) INTEGER MSETS PARAMETER (MSETS=MCOLS) INTEGER MFILES_IN PARAMETER (MFILES_IN=2) INTEGER MAXBAT PARAMETER (MAXBAT=5000) INTEGER MCOLS2 PARAMETER (MCOLS2=MCOLS*2) C .. C .. scalars in common .. INTEGER LENTIT_OUT, LUNIN, LUNOUT, MTZERR, MTZIN1, + MTZIN2, MTZOUT, MTZPRT, NCOLOUT, NCOL_ONE, + NCOL_TWO, NHISOUT, NLAUE_OUT, NSPGRP_OUT, NSYMP_OUT, + NSYM_OUT, NUMCOL_OUT LOGICAL LOGRES CHARACTER LATTYP_OUT*1, NAMSPG_OUT*10, + PGNAME_OUT*10, TITOUT*70 C .. C .. arrays in common .. INTEGER LENTIT, LOOKOUT, MSORTX, MSORTX_OUT, + MTZBLS, NBATX, NHISIN, NHKLCOL, + NLAUE, NREFLX, NSCOL, NSPGRP, + NSYM, NSYMP, NUMCOL CHARACTER CTYPS*1, CTYPS_OUT*1, LATTYP*1, + NAMSPG*10, PGNAME*10, CLABS*30, + CLABS_OUT*30, TITIN*70, HISTIN*80, + HISTOUT*80 C .. C .. local scalars .. INTEGER IREJ, JDO20, KWORK, MTZAPN, NCOMN, NTOTAL, NHC1, NKC1, + NLC1, NHC2, NKC2, NLC2 REAL RESOL LOGICAL MTZEOF, CLEAN, OK C .. C .. local arrays .. REAL RECIN_1(MCOLS), RECIN_2(MCOLS), RECOUT(MCOLS) INTEGER MTZLOK(MCOLS,2) LOGICAL LOGMSS_1(MCOLS), LOGMSS_2(MCOLS) C .. C .. external subroutines/functions .. REAL LSTLSQ EXTERNAL EQUAL_MAGIC,LRASSN,LRREFL,LRREFM,LWCLAB,LWREFL,SETOUT, + CHKRES,LSTLSQ C .. C .. intrinsic functions .. INTRINSIC NINT C .. C .. common blocks .. COMMON /CHR_MTZIN/ TITIN(MFILES_IN), + HISTIN(MAXHIS,MFILES_IN), + LATTYP(MFILES_IN), + PGNAME(MFILES_IN), + NAMSPG(MFILES_IN), + CLABS(MCOLS,MFILES_IN), + CTYPS(MCOLS,MFILES_IN) COMMON /CHR_MTZOUT/TITOUT, + HISTOUT(MAXHIS), + LATTYP_OUT, + PGNAME_OUT, + NAMSPG_OUT, + CLABS_OUT(MCOLS), + CTYPS_OUT(MCOLS) COMMON /EXTRA_BITS/ + NSCOL(2), NCOLOUT, + NCOL_ONE, NCOL_TWO, + NHKLCOL(3,2), LOOKOUT(MCOLS,2) COMMON /INT_MTZIN/ + LENTIT(MFILES_IN), NUMCOL(MFILES_IN), + NREFLX(MFILES_IN), NHISIN(MFILES_IN), + NBATX(MFILES_IN), NLAUE(MFILES_IN), + NSYM(MFILES_IN), NSYMP(MFILES_IN), + NSPGRP(MFILES_IN), MTZBLS(MAXBAT,MFILES_IN), + MSORTX(5,MFILES_IN) COMMON /INT_MTZOUT/ + LENTIT_OUT, NUMCOL_OUT, + NHISOUT, NLAUE_OUT, + NSYM_OUT, NSYMP_OUT, + NSPGRP_OUT, MSORTX_OUT(5) COMMON /U_INOUT/ + LUNIN, LUNOUT, MTZIN1, MTZIN2, MTZOUT, + MTZPRT, MTZERR COMMON /RESCOM/ + LOGRES INTEGER MAXZON PARAMETER (MAXZON=20) LOGICAL LOGZON,OKZONE INTEGER IRZONE,KEYZON,NZON,IFOUND,KZSCR,NRECZO CHARACTER ZONCHR*30 COMMON /CHRZON/ ZONCHR(MAXZON) COMMON /ZONCOM/ + IRZONE(MAXZON,5),KEYZON(MAXZON),NZON(MAXZON), + IFOUND,LOGZON,KZSCR(MAXZON), + NRECZO(MAXZON) INTEGER NDATASETS(MFILES_IN),ISETS(MSETS,MFILES_IN), + CSETID_NFILE(MCOLS,MFILES_IN) REAL DCELL(6,MSETS,MFILES_IN),DWAVEL(MSETS,MFILES_IN) CHARACTER*64 PNAME(MSETS,MFILES_IN),DNAME(MSETS,MFILES_IN), + PNAME_OUT(MCOLS),DNAME_OUT(MCOLS) COMMON /SETS_IO/ NDATASETS,ISETS,CSETID_NFILE,DCELL,DWAVEL, + PNAME,DNAME,PNAME_OUT,DNAME_OUT C .. C .. save statement .. SAVE C .. C .. data statements .. DATA MTZLOK/MCOLS2*-1/ C .. C WRITE(LUNOUT,6001) NUMCOL(1) 6001 FORMAT(' Number of columns in 1st input file 1 = ',I5) WRITE(LUNOUT,6002) NUMCOL(2) 6002 FORMAT(' Number of columns in 2nd input file 2 = ',I5) C C---- find column numbers for hkl C NHC1 = NHKLCOL(1,1) NKC1 = NHKLCOL(2,1) NLC1 = NHKLCOL(3,1) NHC2 = NHKLCOL(1,2) NKC2 = NHKLCOL(2,2) NLC2 = NHKLCOL(3,2) C NCOMN = 0 NTOTAL = 0 MTZAPN = 0 C C ***************************************************** CALL LRASSN(1,CLABS(1,1),NUMCOL(1),MTZLOK(1,1),CTYPS(1,1)) CALL LRASSN(2,CLABS(1,2),NUMCOL(2),MTZLOK(1,2),CTYPS(1,2)) CALL LWCLAB(MTZOUT,CLABS_OUT,NCOLOUT,CTYPS_OUT,MTZAPN) CALL LWIDAS(MTZOUT,NCOLOUT,PNAME_OUT,DNAME_OUT,MTZAPN) C ***************************************************** C IREJ = 0 C 30 CONTINUE C C ****************************** CALL LRREFL(1,RESOL,RECIN_1,MTZEOF) C ****************************** C IF (MTZEOF) GO TO 200 C C ****************** CALL LRREFM(1,LOGMSS_1) C ****************** C C ****************************** CALL LRREFL(2,RESOL,RECIN_2,MTZEOF) C ****************************** C IF (MTZEOF) GO TO 250 C C ****************** CALL LRREFM(2,LOGMSS_2) C ****************** C 104 IF(NINT(RECIN_1(NHC1)-RECIN_2(NHC2))) 101,102,103 102 IF(NINT(RECIN_1(NKC1)-RECIN_2(NKC2))) 101,105,103 105 IF(NINT(RECIN_1(NLC1)-RECIN_2(NLC2))) 101,106,103 C C---- both are same, hence merge them C 106 CONTINUE C C ********************************** CALL EQUAL_MAGIC(MTZOUT,RECOUT,NCOLOUT) C ********************************** C NCOMN = NCOMN + 1 C C---- make certain get hkl C RECOUT(1) = RECIN_1(1) RECOUT(2) = RECIN_1(2) RECOUT(3) = RECIN_1(3) C IF (LOGRES) THEN C C **************** CALL CHKRES(RESOL,OK) C **************** C IF (.NOT.OK) THEN IREJ = IREJ + 1 GO TO 35 END IF END IF C C---- File 2 needs to be done first as file 1 takes precedence. C DO 207 JDO20 = 1,NUMCOL(2) KWORK = LOOKOUT(JDO20,2) IF (KWORK.EQ.-99 ) GO TO 207 C C---- Transfer from recin to recout only those values C requested into saved column position C IF (.NOT. LOGMSS_2(JDO20)) RECOUT(KWORK) = RECIN_2(JDO20) 207 CONTINUE C DO 208 JDO20 = 1,NUMCOL(1) KWORK = LOOKOUT(JDO20,1) IF (KWORK.EQ.-99 ) GO TO 208 C C---- Transfer from recin to recout only those values C requested into saved column position C IF (.NOT. LOGMSS_1(JDO20)) RECOUT(KWORK) = RECIN_1(JDO20) 208 CONTINUE C OKZONE = .TRUE. C C ********************* IF (LOGZON) CALL CHKZON(RECOUT,OKZONE) C ********************* C IF (OKZONE) THEN NTOTAL = NTOTAL + 1 C C ********************* CALL LWREFL(MTZOUT,RECOUT) C ********************* C ENDIF 35 CONTINUE GO TO 30 C C---- Recin_1 is small, write recin_1 and read recin_1 C 101 CONTINUE C IF (LOGRES) THEN RESOL = 4.0 * LSTLSQ(1,NINT(RECIN_1(1)), + NINT(RECIN_1(2)),NINT(RECIN_1(3))) C C **************** CALL CHKRES(RESOL,OK) C **************** C IF (.NOT.OK) THEN IREJ = IREJ + 1 GO TO 45 END IF END IF C CLEAN = .TRUE. C C *************************************** CALL SETOUT(1,RECOUT,RECIN_1,LOGMSS_1,CLEAN) C *************************************** C C---- make certain get hkl C RECOUT(1) = RECIN_1(1) RECOUT(2) = RECIN_1(2) RECOUT(3) = RECIN_1(3) OKZONE = .TRUE. C C ********************* IF (LOGZON) CALL CHKZON(RECOUT,OKZONE) C ********************* C IF (OKZONE) THEN NTOTAL = NTOTAL + 1 C C ********************* CALL LWREFL(MTZOUT,RECOUT) C ********************* C ENDIF 45 CONTINUE C C ****************************** CALL LRREFL(1,RESOL,RECIN_1,MTZEOF) C ****************************** C IF (MTZEOF) GO TO 210 C C ****************** CALL LRREFM(1,LOGMSS_1) C ****************** C GO TO 104 C C---- recin_1 is higher, write recin_2 and read recin_2 C 103 CONTINUE C IF (LOGRES) THEN RESOL = 4.0 * LSTLSQ(1,NINT(RECIN_2(1)), + NINT(RECIN_2(2)),NINT(RECIN_2(3))) C C **************** CALL CHKRES(RESOL,OK) C **************** C IF (.NOT.OK) THEN IREJ = IREJ + 1 GO TO 180 END IF END IF C CLEAN = .TRUE. C C *************************************** CALL SETOUT(2,RECOUT,RECIN_2,LOGMSS_2,CLEAN) C *************************************** C C---- make certain get hkl C RECOUT(1) = RECIN_2(1) RECOUT(2) = RECIN_2(2) RECOUT(3) = RECIN_2(3) OKZONE = .TRUE. C C ********************* IF (LOGZON) CALL CHKZON(RECOUT,OKZONE) C ********************* C IF (OKZONE) THEN NTOTAL = NTOTAL + 1 C C ********************* CALL LWREFL(MTZOUT,RECOUT) C ********************* C ENDIF 180 CONTINUE C C ****************************** CALL LRREFL(2,RESOL,RECIN_2,MTZEOF) C ****************************** C IF (MTZEOF) GO TO 250 C C ****************** CALL LRREFM(2,LOGMSS_2) C ****************** C GO TO 104 C C---- file 1 is exhausted C 200 CONTINUE C C ****************************** CALL LRREFL(2,RESOL,RECIN_2,MTZEOF) C ****************************** C IF (MTZEOF) GO TO 300 C C ****************** CALL LRREFM(2,LOGMSS_2) C ****************** C 210 CONTINUE C C IF (LOGRES) THEN RESOL = 4.0 * LSTLSQ(1,NINT(RECIN_2(1)), + NINT(RECIN_2(2)),NINT(RECIN_2(3))) C C **************** CALL CHKRES(RESOL,OK) C **************** C IF (.NOT.OK) THEN IREJ = IREJ + 1 GO TO 245 END IF END IF C CLEAN = .TRUE. C C *************************************** CALL SETOUT(2,RECOUT,RECIN_2,LOGMSS_2,CLEAN) C *************************************** C RECOUT(1) = RECIN_2(1) RECOUT(2) = RECIN_2(2) RECOUT(3) = RECIN_2(3) OKZONE = .TRUE. C C ********************* IF (LOGZON) CALL CHKZON(RECOUT,OKZONE) C ********************* C IF (OKZONE) THEN NTOTAL = NTOTAL + 1 C C ********************* CALL LWREFL(MTZOUT,RECOUT) C ********************* C ENDIF 245 CONTINUE GO TO 200 C C---- file 2 is exhausted C 250 CONTINUE C IF (LOGRES) THEN RESOL = 4.0 * LSTLSQ(1,NINT(RECIN_1(1)), + NINT(RECIN_1(2)),NINT(RECIN_1(3))) C C **************** CALL CHKRES(RESOL,OK) C **************** C IF (.NOT.OK) THEN IREJ = IREJ + 1 GO TO 290 END IF END IF C CLEAN = .TRUE. C C *************************************** CALL SETOUT(1,RECOUT,RECIN_1,LOGMSS_1,CLEAN) C *************************************** C RECOUT(1) = RECIN_1(1) RECOUT(2) = RECIN_1(2) RECOUT(3) = RECIN_1(3) OKZONE = .TRUE. C C ********************* IF (LOGZON) CALL CHKZON(RECOUT,OKZONE) C ********************* C IF (OKZONE) THEN NTOTAL = NTOTAL + 1 C C ********************* CALL LWREFL(MTZOUT,RECOUT) C ********************* C ENDIF 290 CONTINUE C C ****************************** CALL LRREFL(1,RESOL,RECIN_1,MTZEOF) C ****************************** C IF (MTZEOF) GO TO 300 C C ****************** CALL LRREFM(1,LOGMSS_1) C ****************** C GO TO 250 C 300 WRITE(LUNOUT,6003) NCOMN,NTOTAL 6003 FORMAT( +' Number of Reflections common to Both Files:',I10,/, +' Total Number of Reflections forwarded to Output File:', + I10) C RETURN END C C ============================================= SUBROUTINE RDAXIS(ISTART,NTOK,LINE,IBEG,IEND) C ============================================= C INTEGER NPARM PARAMETER (NPARM=200) INTEGER BIGPOS PARAMETER (BIGPOS=998) INTEGER BIGNEG PARAMETER (BIGNEG=-998) INTEGER MAXZON PARAMETER (MAXZON=20) C INTEGER IC,IFOUND_OLD,ISTART,IBEG(NPARM),IEND(NPARM), + JDO10,JDO20,JDO30,JDO50,NTOK,NWORK INTEGER IAXIS(10) CHARACTER MAXIS_PROJ(10)*4,LINE*400,CWORK*4 C LOGICAL LOGZON INTEGER IRZONE,KEYZON,NZON,IFOUND,KZSCR,NRECZO CHARACTER ZONCHR*30 COMMON /CHRZON/ ZONCHR(MAXZON) COMMON /ZONCOM/ + IRZONE(MAXZON,5),KEYZON(MAXZON),NZON(MAXZON), + IFOUND,LOGZON,KZSCR(MAXZON), + NRECZO(MAXZON) C SAVE C DATA MAXIS_PROJ /'H00 ','0K0 ','00L ','HH0 ','-HH0','HHH ', + 'HK0 ','0KL ','H0L ','HHL '/ C IFOUND_OLD = IFOUND + 1 IC = 0 C DO 10 JDO10 = 1,10 IAXIS(JDO10) = 0 10 CONTINUE C C ************ CALL CCPUPC(LINE) C ************ C DO 30 JDO30 = ISTART,NTOK CWORK = LINE(IBEG(JDO30):IEND(JDO30)) C DO 20 JDO20 = 1,10 IF (CWORK(1:4).EQ.MAXIS_PROJ(JDO20)) THEN IFOUND = IFOUND + 1 C C---- test on number of zones/axis C IF (IFOUND.GT.MAXZON) THEN CALL CCPERR(1,' Stop TOO many zones/axis requested') END IF C IC = IC + 1 IAXIS(IC) = JDO20 ZONCHR(IFOUND) = MAXIS_PROJ(JDO20) C C---- IFOUND not the same as ic in case more than one AXIS card i/p C KEYZON(IFOUND) = JDO20 ENDIF 20 CONTINUE 30 CONTINUE C IC = 0 C DO 50 JDO50 = IFOUND_OLD,IFOUND IC = IC + 1 NWORK = IAXIS(IC) C IF (NWORK.NE.0) THEN IF (NWORK.EQ.1) THEN C C---- Axis H00 C IRZONE(JDO50,2) = BIGNEG + 200 IRZONE(JDO50,3) = BIGPOS C ELSE IF (NWORK.EQ.2) THEN C C---- Axis 0K0 C IRZONE(JDO50,1) = BIGNEG + 200 IRZONE(JDO50,3) = BIGPOS C ELSE IF (NWORK.EQ.3) THEN C C---- Axis 00L C IRZONE(JDO50,1) = BIGPOS + 200 IRZONE(JDO50,2) = BIGNEG C ELSE IF (NWORK.EQ.4) THEN C C---- Axis HH0 C IRZONE(JDO50,1) = BIGPOS IRZONE(JDO50,2) = BIGNEG IRZONE(JDO50,3) = BIGPOS * 2 C ELSE IF (NWORK.EQ.5) THEN C C---- Axis -HH0 C IRZONE(JDO50,1) = BIGNEG IRZONE(JDO50,2) = BIGNEG IRZONE(JDO50,3) = BIGPOS * 2 C C---- If it's a 6 (Axis HHH) the irzone is zero C ELSE IF (NWORK.EQ.7) THEN C C---- Projection HK0 C IRZONE(JDO50,3) = 1 C ELSE IF (NWORK.EQ.8) THEN C C---- Projection 0KL C IRZONE(JDO50,1) = 1 C ELSE IF (NWORK.EQ.9) THEN C C---- Projection H0L C IRZONE(JDO50,2) = 1 C ELSE IF (NWORK.EQ.10) THEN C C---- Projection HHL C IRZONE(JDO50,1) = BIGPOS IRZONE(JDO50,2) = BIGNEG C ENDIF ENDIF C C 50 CONTINUE C RETURN END C C =========================================================== SUBROUTINE RDZONE(ISTART,IFOUND,NTOK,IERR,IRZONE,IBEG,IEND, + LINE) C =========================================================== C INTEGER MAXZON PARAMETER (MAXZON=20) INTEGER ISTART,IFOUND,IERR,IGSIGN,IMULT,J,JI,JL,JK,JSAVE,NTOK INTEGER IRZONE(MAXZON,5),IBEG(*), IEND(*) CHARACTER*(*) LINE EXTERNAL LENSTR INTEGER LENSTR C INTEGER ICHECK(5) CHARACTER CWORK*30,HKLN(6)*1,TEMP*30 DATA HKLN/ 'H', 'K', 'L', 'N', '+', '-'/ C IERR = 0 C DO 10 J=1,5 ICHECK(J) = 0 10 CONTINUE C IF( ISTART.GT.NTOK) THEN IERR = -1 WRITE(6,6000) 6000 FORMAT(' Error in subroutine RDZONE, start position', + ' greater than number of tokens parsed from line') RETURN END IF C IMULT = +1 IGSIGN = 0 C DO 100 J=ISTART,NTOK CWORK = LINE(IBEG(J) : IEND(J)) CALL CCPUPC(CWORK) JL = LENSTR(CWORK) C cc do 80 jk=1,6 DO 80 JK=1,5 JI = 0 JI = INDEX (CWORK,HKLN(JK)) JSAVE = JK IF (JI.EQ.0) GO TO 80 C IF (JK.LE.4) THEN GO TO 90 ELSE IF (JK.EQ.5) THEN IMULT = +1 IGSIGN = 1 GO TO 100 ELSE IF (JK.EQ.6) THEN IMULT = -1 IGSIGN = 1 GO TO 100 END IF C 80 CONTINUE C C---- Assume this is the single number C of +-m1H +-m2K +-m3L = +-m4N +-m5 C TEMP = CWORK(1:JL) READ (TEMP,'(BN,I30)') IRZONE(IFOUND,5) C IF (IGSIGN.EQ.1) THEN IRZONE(IFOUND,5) = IRZONE(IFOUND,5) * IMULT IMULT = +1 IGSIGN = 0 END IF C ICHECK(5) = 1 C GO TO 100 C C---- Found H K L or N C jsave= 1 2 3 4 C 90 CONTINUE C C---- First check if just h k l or n given C IF (JL.EQ.1) THEN IRZONE(IFOUND,JSAVE) = 1 ICHECK(JSAVE) = 1 C C---- check if just e.g. -h given C ELSE IF (JL.EQ.2 .AND. + CWORK(1:1).EQ.'-') THEN IRZONE(IFOUND,JSAVE) = -1 ICHECK(JSAVE) = 1 ELSE TEMP = CWORK(1:(JI-1)) READ (TEMP,'(BN,I30)') IRZONE(IFOUND,JSAVE) ICHECK(JSAVE) = 1 END IF C IF (IGSIGN.EQ.1) THEN IRZONE(IFOUND,JSAVE) = IRZONE(IFOUND,JSAVE) * IMULT IMULT = +1 IGSIGN = 0 END IF C 100 CONTINUE C C---- Check at least one of h,k,l must be given C IF (ICHECK(1).EQ.0 .AND. + ICHECK(2).EQ.0 .AND. + ICHECK(3).EQ.0 ) IERR = -1 C C---- Value for n must be given C IF (ICHECK(4).EQ.0) IERR = -1 write(6,*) (irzone(ifound,j),j=1,5) RETURN END C C ================================================== SUBROUTINE SETOUT(NFILE,RECOUT,RECIN,LOGMSS,CLEAN) C ================================================== C C---- They have now. C C .. parameters .. INTEGER MAXBAT PARAMETER (MAXBAT=5000) INTEGER MCOLS PARAMETER (MCOLS=500) INTEGER MFILES_IN PARAMETER (MFILES_IN=2) C .. C .. scalar arguments .. INTEGER NFILE C .. C .. array arguments .. REAL RECIN(*),RECOUT(*) C .. C .. logical arguments LOGICAL LOGMSS(*),CLEAN C .. C .. scalars in common .. INTEGER LUNIN, LUNOUT, MTZERR, MTZIN1, MTZIN2, + MTZOUT, MTZPRT, NCOLOUT, NCOL_ONE, NCOL_TWO, + NHISIN LOGICAL DO_CONCAT, DO_MERGE, DO_NEW_CELL, + DO_NEW_HIST, DO_NEW_SORT, DO_NEW_SYMM, + DO_ONE_FILE, DO_S_NEW, DO_TWO_FILES, + DO_UNIQUE C .. C .. arrays in common .. INTEGER LENTIT, LOOKOUT, MSORTX, MTZBLS, NBATX, + NHKLCOL, NLAUE, NREFLX, NSCOL, NSPGRP, + NSYM, NSYMP, NUMCOL LOGICAL DO_EDT_COL_NAMES, DO_EDT_TITLE, + DO_EXCLUDE, DO_INCLUDE, + DO_INC_ALL, FOUND_SYM, + SFOUND C .. C .. local scalars .. INTEGER JDO20,KWORK C .. C .. External Routines .. EXTERNAL EQUAL_MAGIC C .. C .. intrinsic functions .. INTRINSIC ABS,NINT C .. C .. common blocks .. COMMON /EXTRA_BITS/ + NSCOL(2), NCOLOUT, + NCOL_ONE, NCOL_TWO, + NHKLCOL(3,2), LOOKOUT(MCOLS,2) COMMON /INT_MTZIN/ + LENTIT(MFILES_IN), NUMCOL(MFILES_IN), + NREFLX(MFILES_IN), NHISIN(MFILES_IN), + NBATX(MFILES_IN), NLAUE(MFILES_IN), + NSYM(MFILES_IN), NSYMP(MFILES_IN), + NSPGRP(MFILES_IN), MTZBLS(MAXBAT,MFILES_IN), + MSORTX(5,MFILES_IN) COMMON /LOG_UTILS/ + DO_INCLUDE(MFILES_IN), + DO_INC_ALL(MFILES_IN), + DO_EXCLUDE(MFILES_IN), + DO_EDT_TITLE(MFILES_IN), + DO_EDT_COL_NAMES(MFILES_IN), + FOUND_SYM(MFILES_IN), + SFOUND(2), + DO_MERGE, DO_NEW_SORT, DO_CONCAT, + DO_UNIQUE, DO_NEW_CELL, DO_S_NEW, + DO_NEW_HIST, DO_TWO_FILES, DO_NEW_SYMM, + DO_ONE_FILE COMMON /U_INOUT/ + LUNIN, LUNOUT, MTZIN1, MTZIN2, MTZOUT, + MTZPRT, MTZERR C .. C .. save statement .. SAVE C .. C C---- Set all output values to what ever C except if you're merging in cols from 2 files C directly after each other (from pruniq) C IF (CLEAN) THEN C C ********************************** CALL EQUAL_MAGIC(MTZOUT,RECOUT,NCOLOUT) C ********************************** C ENDIF C DO 20 JDO20 = 1,NUMCOL(NFILE) KWORK = LOOKOUT(JDO20,NFILE) IF (KWORK.EQ.-99) GO TO 20 C C---- Transfer from recin to recout only those values C requested into saved column position C IF(.NOT. LOGMSS(JDO20)) RECOUT(KWORK) = RECIN(JDO20) 20 CONTINUE C RETURN END C C ================================================== SUBROUTINE SORTINI(MSORTX_OUT,NUM_COLS_OUT,LUNOUT) C ================================================== C C---- sort type is real C INTEGER SORTYP PARAMETER (SORTYP=7) C INTEGER MAXSORT_KEY PARAMETER (MAXSORT_KEY=5) INTEGER ENDSRT PARAMETER (ENDSRT=-1) C INTEGER NUM_COLS_OUT,LUNOUT INTEGER SORTKEYS(MAXSORT_KEY) INTEGER LASCND,LRECL_SORT,KEYSIZ,NSORTKEYS,J,JDO10,ISTAT INTEGER KEYBUF(50),MSORTX_OUT(MAXSORT_KEY) C INTEGER SRTBEG EXTERNAL SRTBEG C C---- initialise sorting o/p C LASCND = 0 LRECL_SORT = NUM_COLS_OUT*4 KEYSIZ = 4 C C---- sort on the first 3 columns depending on the sort_order keyword C NSORTKEYS = 3 C C---- sortkeys are columns 1 2 3 C SORTKEYS(1) = MSORTX_OUT(1) SORTKEYS(2) = MSORTX_OUT(2) SORTKEYS(3) = MSORTX_OUT(3) C C---- Set up key buffer for number of keys. A descriptor consists of: C 2-byte length (in bytes) C 2-byte class & type (probably not used) C 4-byte address of array C DO 10 JDO10 = 1,NSORTKEYS J = (JDO10-1)*5 + 1 C C---- Sort Type is REAL (SORTYP set up in PARAMETER statement) C KEYBUF(J) = SORTYP C C---- Sort Order ascending/descending C KEYBUF(J+1) = LASCND C C---- position of 1st byte in key C KEYBUF(J+2) = (SORTKEYS(JDO10)-1)*KEYSIZ C C---- keylength in BYTES (2) C KEYBUF(J+3) = 1 KEYBUF(J+4) = 0 10 CONTINUE C WRITE (LUNOUT,FMT=6000) NSORTKEYS, + (SORTKEYS(J),J=1,NSORTKEYS) 6000 FORMAT (1X,I8,' sort keys, in columns ',30I4,/) C C---- Initialise sort, set parameters, etC C ************************************* ISTAT = SRTBEG(NSORTKEYS,KEYBUF,LRECL_SORT,0) C ************************************* C IF (ISTAT.NE.0) THEN WRITE (LUNOUT,FMT=6002) ISTAT 6002 FORMAT (' SORTINI failed to initialise sort, status = ',I8,/) C C ************************* CALL CCPERR(1,' STOP in sort') C ************************* C END IF C RETURN END C C ================= SUBROUTINE TWODSN C ================= C C---- Opens output file for case where includes/excludes from two C input files and initiates the processing of the reflection data C C ..... Is this ever going to be used now ????? C C .. Scalars in Common .. INTEGER LUNIN,LUNOUT,MTZERR,MTZIN1,MTZIN2,MTZOUT,MTZPRT C .. C .. Common blocks .. COMMON /U_INOUT/ + LUNIN, LUNOUT, MTZIN1, MTZIN2, MTZOUT, + MTZPRT, MTZERR C .. C .. Save statement .. SAVE C .. RETURN END C C ================== SUBROUTINE UTILINI C ================== C C C .. Parameters .. INTEGER MAXSYM PARAMETER (MAXSYM=192) INTEGER MAXHIS PARAMETER (MAXHIS=30) INTEGER MCOLS PARAMETER (MCOLS=500) INTEGER MFILES_IN PARAMETER (MFILES_IN=2) INTEGER MAXZON PARAMETER (MAXZON=20) C .. C .. Scalars in Common .. INTEGER LUNIN, LUNOUT, MTZERR, MTZIN1, MTZIN2, + MTZOUT, MTZPRT, NISYM_NEW, NLAUE_NEW, NMAT_NEW, + NSPGRP_NEW, NSYMP_NEW, NSYM_NEW, NUM_NEW_HIST, + NCOL_ONE, NCOL_TWO LOGICAL DO_CONCAT, DO_MERGE, DO_NEW_CELL, + DO_NEW_HIST, DO_NEW_SORT, DO_NEW_SYMM, + DO_ONE_FILE, DO_S_NEW, DO_TWO_FILES, + DO_UNIQUE,LOGRES, DO_SCAL CHARACTER LATTYP_NEW*1, LAUNAM_NEW*10, + NAMSPG_NEW*10, PGNAME_NEW*10 C .. C .. Arrays in Common .. REAL CELL_NEW, RSYMT_NEW, RSYM_NEW INTEGER ISYMM_NEW, ISYMST_NEW, ISYM_NEW, LMSYM_NEW, + MSORTX_NEW, NSYMOP_NEW, NUM_EDIT_COLS, NUM_EXC_COLS, + NUM_INC_COLS, NSCOL,NCOLOUT, NHKLCOL, LOOKOUT LOGICAL DO_EDT_COL_NAMES, DO_EDT_TITLE, + DO_EXCLUDE, DO_INCLUDE, + DO_INC_ALL, FOUND_SYM, + SFOUND CHARACTER EDT_TITLE_MODE*4, EXC_COL_LABELS*30, + INC_COL_LABELS*30, NEW_COL_NAMES*30, + OLD_COL_NAMES*30, NEW_TITLE*70, + NEW_HIST*80 C .. C .. Local Scalars .. INTEGER J,K C .. C .. Common blocks .. COMMON /CHR_UTILS/ + INC_COL_LABELS(MCOLS,MFILES_IN), + EXC_COL_LABELS(MCOLS,MFILES_IN), + EDT_TITLE_MODE(MFILES_IN), + NEW_HIST(MAXHIS),NEW_TITLE(MFILES_IN), + OLD_COL_NAMES(MCOLS,MFILES_IN), + NEW_COL_NAMES(MCOLS,MFILES_IN) COMMON /CNEW_SYMM/ + PGNAME_NEW, NAMSPG_NEW, LAUNAM_NEW, LATTYP_NEW COMMON /INT_UTILS/ + NUM_INC_COLS(MFILES_IN), + NUM_EXC_COLS(MFILES_IN), + NUM_EDIT_COLS(MFILES_IN), + NUM_NEW_HIST, + MSORTX_NEW(5) COMMON /LOG_UTILS/ + DO_INCLUDE(MFILES_IN), + DO_INC_ALL(MFILES_IN), + DO_EXCLUDE(MFILES_IN), + DO_EDT_TITLE(MFILES_IN), + DO_EDT_COL_NAMES(MFILES_IN), + FOUND_SYM(MFILES_IN), + SFOUND(2), + DO_MERGE, DO_NEW_SORT, DO_CONCAT, + DO_UNIQUE, DO_NEW_CELL, DO_S_NEW, + DO_NEW_HIST, DO_TWO_FILES, DO_NEW_SYMM, + DO_ONE_FILE COMMON /REL_UTILS/ CELL_NEW(6) COMMON /UNEW_SYMM/ + NSPGRP_NEW, NSYM_NEW, NSYMP_NEW, + NLAUE_NEW, NISYM_NEW, NMAT_NEW, + ISYMST_NEW(MAXSYM), + LMSYM_NEW(MAXSYM), + NSYMOP_NEW(MAXSYM), + ISYMM_NEW(9,MAXSYM), + ISYM_NEW(9,MAXSYM), + RSYM_NEW(4,4,MAXSYM), + RSYMT_NEW(4,4,MAXSYM) COMMON /U_INOUT/ + LUNIN, LUNOUT, MTZIN1, MTZIN2, MTZOUT, + MTZPRT, MTZERR COMMON /EXTRA_BITS/ + NSCOL(2), NCOLOUT, + NCOL_ONE, NCOL_TWO, + NHKLCOL(3,2), LOOKOUT(MCOLS,2) COMMON /RESCOM/ + LOGRES LOGICAL LOGZON INTEGER IRZONE,KEYZON,NZON,IFOUND,KZSCR,NRECZO CHARACTER ZONCHR*30 COMMON /CHRZON/ ZONCHR(MAXZON) COMMON /ZONCOM/ + IRZONE(MAXZON,5),KEYZON(MAXZON),NZON(MAXZON), + IFOUND,LOGZON,KZSCR(MAXZON), + NRECZO(MAXZON) C .. C .. Save statement .. SAVE C .. C LUNIN = 5 LUNOUT = 6 MTZIN1 = 1 MTZIN2 = 2 MTZOUT = 1 MTZPRT = 1 IFOUND = 0 C NHKLCOL(1,1) = 1 NHKLCOL(2,1) = 2 NHKLCOL(3,1) = 3 NHKLCOL(1,2) = 1 NHKLCOL(2,2) = 2 NHKLCOL(3,2) = 3 C DO 10 J = 1,2 NUM_INC_COLS(J) = 0 NUM_EXC_COLS(J) = 0 NUM_EDIT_COLS(J) = 0 DO_INCLUDE(J) = .FALSE. DO_INC_ALL(J) = .TRUE. DO_EXCLUDE(J) = .FALSE. DO_EDT_TITLE(J) = .FALSE. DO_EDT_COL_NAMES(J) = .FALSE. FOUND_SYM(J) = .FALSE. SFOUND(J) = .FALSE. EDT_TITLE_MODE(J) = 'NOCH' NEW_TITLE(J) = ' ' 10 CONTINUE C NUM_NEW_HIST = 0 C DO 20 J = 1,3 MSORTX_NEW(J) = J 20 CONTINUE C DO_MERGE = .FALSE. DO_NEW_SORT = .FALSE. DO_CONCAT = .FALSE. DO_UNIQUE = .FALSE. DO_NEW_CELL = .FALSE. DO_NEW_HIST = .FALSE. DO_NEW_SYMM = .FALSE. DO_TWO_FILES = .TRUE. DO_ONE_FILE = .FALSE. DO_S_NEW = .FALSE. LOGRES = .FALSE. LOGZON = .FALSE. do_scal = .FALSE. C DO 40 J = 1,MCOLS DO 30 K = 1,MFILES_IN INC_COL_LABELS(J,K) = ' ' EXC_COL_LABELS(J,K) = ' ' OLD_COL_NAMES(J,K) = ' ' NEW_COL_NAMES(J,K) = ' ' 30 CONTINUE 40 CONTINUE C DO 50 J = 1,MAXHIS NEW_HIST(J) = ' ' 50 CONTINUE C DO 70 J = 1,MAXZON KEYZON(J) = 0 NZON(J) = 0 NRECZO(J) = 0 ZONCHR(J) = ' ' C DO 60 K = 1,5 IRZONE(J,K) = 0 60 CONTINUE 70 CONTINUE C RETURN END C C ================= SUBROUTINE WRBATS C ================= C C Orientation block data C C .. Parameters .. INTEGER MBLENG PARAMETER (MBLENG=185) INTEGER MFILES_IN PARAMETER (MFILES_IN=2) INTEGER MAXBAT PARAMETER (MAXBAT=5000) INTEGER MCOLS PARAMETER (MCOLS=500) INTEGER MSETS PARAMETER (MSETS=MCOLS) C .. C .. Scalars in Common .. INTEGER LUNIN, LUNOUT, MTZERR, MTZIN1, MTZIN2, + MTZOUT, MTZPRT LOGICAL DO_CONCAT, DO_MERGE, DO_NEW_CELL, + DO_NEW_HIST, DO_NEW_SORT, DO_NEW_SYMM, + DO_ONE_FILE, DO_S_NEW, DO_TWO_FILES, + DO_UNIQUE C .. C .. Arrays in Common .. INTEGER LENTIT, MSORTX, MTZBLS, NBATX, NHISIN, + NLAUE, NREFLX, NSPGRP, NSYM, NSYMP, + NUMCOL LOGICAL DO_EDT_COL_NAMES, DO_EDT_TITLE, + DO_EXCLUDE, DO_INCLUDE, + DO_INC_ALL, FOUND_SYM, + SFOUND C .. C .. Local Scalars .. INTEGER IPRINT,MLOOP,MTZBNM,MTZIN,NBATCH CHARACTER CBATCH*94 C .. C .. Local Arrays .. REAL RBATCH(MBLENG) C .. C .. External Subroutines .. EXTERNAL LRBAT,LWBAT C .. C .. Common blocks .. COMMON /INT_MTZIN/ + LENTIT(MFILES_IN), NUMCOL(MFILES_IN), + NREFLX(MFILES_IN), NHISIN(MFILES_IN), + NBATX(MFILES_IN), NLAUE(MFILES_IN), + NSYM(MFILES_IN), NSYMP(MFILES_IN), + NSPGRP(MFILES_IN), MTZBLS(MAXBAT,MFILES_IN), + MSORTX(5,MFILES_IN) COMMON /LOG_UTILS/ + DO_INCLUDE(MFILES_IN), + DO_INC_ALL(MFILES_IN), + DO_EXCLUDE(MFILES_IN), + DO_EDT_TITLE(MFILES_IN), + DO_EDT_COL_NAMES(MFILES_IN), + FOUND_SYM(MFILES_IN), + SFOUND(2), + DO_MERGE, DO_NEW_SORT, DO_CONCAT, + DO_UNIQUE, DO_NEW_CELL, DO_S_NEW, + DO_NEW_HIST, DO_TWO_FILES, DO_NEW_SYMM, + DO_ONE_FILE COMMON /U_INOUT/ + LUNIN, LUNOUT, MTZIN1, MTZIN2, MTZOUT, + MTZPRT, MTZERR INTEGER BSETID CHARACTER*64 PROJECTNAME,DATASETNAME INTEGER NDATASETS(MFILES_IN),ISETS(MSETS,MFILES_IN), + CSETID_NFILE(MCOLS,MFILES_IN) REAL DCELL(6,MSETS,MFILES_IN),DWAVEL(MSETS,MFILES_IN) CHARACTER*64 PNAME(MSETS,MFILES_IN),DNAME(MSETS,MFILES_IN), + PNAME_OUT(MCOLS),DNAME_OUT(MCOLS) COMMON /SETS_IO/ NDATASETS,ISETS,CSETID_NFILE,DCELL,DWAVEL, + PNAME,DNAME,PNAME_OUT,DNAME_OUT C .. C .. Save statement .. SAVE C .. C IPRINT = 0 MLOOP = 1 IF (DO_TWO_FILES) MLOOP = 2 C DO 20 MTZIN = 1,MLOOP IF (NBATX(MTZIN).GT.0) THEN DO 10 MTZBNM = 1,NBATX(MTZIN) C C **************************************** CALL LRBAT(MTZIN,NBATCH,RBATCH,CBATCH,IPRINT) C **************************************** C C---- Batch header that is transferred to HKLOUT contains old dataset ID C which might be out-of-date when merging several datasets C together. For each dataset, identify PROJECTNAME,DATASETNAME C and pass these to LWBSETID which will write the correct ID. PROJECTNAME = ' ' DATASETNAME = ' ' C---- Called before LWBAT so BSETID read from input header. CALL LRBSETID (MTZIN,NBATCH,BSETID) DO I = 1,NDATASETS(MTZIN) IF (ISETS(I,MTZIN).EQ.BSETID) THEN PROJECTNAME = PNAME(I,MTZIN) DATASETNAME = DNAME(I,MTZIN) GOTO 4993 ENDIF ENDDO 4993 CONTINUE C **************************************** CALL LWBAT(MTZOUT,NBATCH,RBATCH,CBATCH) C **************************************** C---- Called after LWBAT so written to output header. IF (PROJECTNAME.NE.' ') + CALL LWBSETID(MTZOUT,NBATCH,PROJECTNAME,DATASETNAME) C 10 CONTINUE C END IF C 20 CONTINUE C RETURN END C C*************************************************************** C subroutine get_scal_cols(clabs,ctyps,numcol) integer MCOLS parameter (MCOLS=500) integer mfiles_in parameter (mfiles_in=2) integer maxsc parameter (maxsc=12) C integer ix,jdo20 integer numcol(mfiles_in) C character clabs(MCOLS,mfiles_in)*30, + ctyps(MCOLS,mfiles_in)*1, + actype*1 C logical do_scal,scale_all_f,scale_all_i,reverse_anom common /log_scal/ + do_scal,scale_all_f,scale_all_i,reverse_anom C character scal_col_label(maxsc)*30,scal_col_type(maxsc)*1 common /chr_scal/ + scal_col_label,scal_col_type C integer n_scal_col,iscol(maxsc) real scal_val(maxsc),scal_all common /num_scal/ + scal_val,scal_all,n_scal_col,iscol save /num_scal/, /chr_scal/, /log_scal/ C if ( scale_all_f ) then actype = 'F' else if ( scale_all_i ) then actype = 'J' else if ( reverse_anom ) then actype = 'D' endif C c This loop extracts all the column information for either all the c J's or all the F's in the input MTZfile c ix = 0 do 20 jdo20 = 1,numcol(1) C if (ctyps(jdo20,1) .eq. actype) then ix = ix + 1 if (ix .gt. maxsc) call ccperr(1, + 'Too many labels found for scale') C scal_col_label(ix) = clabs(jdo20,1) scal_col_type(ix) = ctyps(jdo20,1) scal_val(ix) = scal_all write (6,*) 'extracting label ',scal_col_label(ix) C endif C 20 continue C if (ix .eq. 0) then call ccperr(1,' Sorry: No columns found for scaling') endif n_scal_col = ix return end C C*********************************************************************** C subroutine check_scal_cols(clabs,ctyps,mtzlok) C C*********************************************************************** C integer MCOLS parameter (MCOLS=500) integer mfiles_in parameter (mfiles_in=2) integer maxsc parameter (maxsc=12) C character clabs(MCOLS,mfiles_in)*30, + ctyps(MCOLS,mfiles_in)*1 C integer mtzlok(MCOLS) C logical do_scal,scale_all_f,scale_all_i,reverse_anom common /log_scal/ + do_scal,scale_all_f,scale_all_i,reverse_anom C character scal_col_label(maxsc)*30,scal_col_type(maxsc)*1 common /chr_scal/ + scal_col_label,scal_col_type save /num_scal/, /chr_scal/, /log_scal/ C integer n_scal_col,iscol(maxsc) real scal_val(maxsc),scal_all common /num_scal/ + scal_val,scal_all,n_scal_col,iscol C c Since, if we've input SCALE ALL, we don't yet have all possible c column labels then we have to pass thru' the array MTZLOK to c the subroutine check_all. c if (scale_all_i .or. scale_all_f) then call check_all(clabs,ctyps,mtzlok) else call check_spec endif C return end C C*********************************************************************** C subroutine check_all(clabs,ctyps,mtzlok) C C*********************************************************************** C integer MCOLS parameter (MCOLS=500) integer mfiles_in parameter (mfiles_in=2) integer maxsc parameter (maxsc=12) C character clabs(MCOLS,mfiles_in)*30, + ctyps(MCOLS,mfiles_in)*1 C integer ix,jdo40,jdo50 integer mtzlok(MCOLS) C logical do_scal,scale_all_f,scale_all_i,reverse_anom common /log_scal/ + do_scal,scale_all_f,scale_all_i,reverse_anom C character scal_col_label(maxsc)*30,scal_col_type(maxsc)*1 common /chr_scal/ + scal_col_label,scal_col_type C integer n_scal_col,iscol(maxsc) real scal_val(maxsc),scal_all common /num_scal/ + scal_val,scal_all,n_scal_col,iscol save /num_scal/, /chr_scal/, /log_scal/ C integer currcol,icheck character actype(3)*1 data actype /'Q','D','Q'/ C C This subroutine checks for associated column labels with F's or c J's if the input is SCALE ALL c c for scaling I's and F's we may also need to check if there c are also anomalous difference associated with the I or F C hence the column types D and its sigma in actype C ix = n_scal_col write (6,*)' ' do 50 jdo50 = 1,n_scal_col C c currcol is the column number of the required I or F C currcol = iscol(jdo50) write (6,6010)scal_val(jdo50),scal_col_label(jdo50) C do 40 jdo40 = 1,3 icheck = currcol + jdo40 if (ctyps(icheck,1) .eq. actype(jdo40)) then ix = ix + 1 C if (ix .gt. maxsc) call ccperr(1, + 'Too many labels associated with scale input !') C write (6,6000)clabs(icheck,1),clabs(currcol,1) 6000 format (' Associating column ',a/, + ' with label ',a) C c Get information for this column C scal_col_label(ix) = clabs(icheck,1) scal_col_type(ix) = ctyps(icheck,1) scal_val(ix) = scal_all iscol(ix) = mtzlok(icheck) write (6,6010)scal_val(ix),scal_col_label(ix) 6010 format (' ** Applying scale of ',f5.2,' to column ',a) C endif C 40 continue C 50 continue C c Update the total number of columns used C if (ix .eq. n_scal_col) then write(6,6005) 6005 format (' *** WARNING *** No associated columns found: '/, + 'If there are no sigmas found you may well be screwing ', + 'up here') endif n_scal_col = ix C return end C C*********************************************************************** C subroutine check_spec C C*********************************************************************** C integer MCOLS parameter (MCOLS=500) integer mfiles_in parameter (mfiles_in=2) integer maxsc parameter (maxsc=12) C logical do_scal,scale_all_f,scale_all_i,reverse_anom common /log_scal/ + do_scal,scale_all_f,scale_all_i,reverse_anom C character scal_col_label(maxsc)*30,scal_col_type(maxsc)*1 common /chr_scal/ + scal_col_label,scal_col_type C integer itype,isigs,n_scal_col,iscol(maxsc) real scal_val(maxsc),scal_all common /num_scal/ + scal_val,scal_all,n_scal_col,iscol save /num_scal/, /chr_scal/, /log_scal/ C C This subroutine makes a basic check of the labels you have input c on the SCALE label value..... input. It could be made much more c complicated if that is your thang. It will print a warning if you c are scaling a different number of F's,J's D's than the number of c sigmas. It will stop with an error if an input column label is not c of the above 4 types. C itype = 0 isigs = 0 write(6,*)' ' do 50 jdo50 = 1,n_scal_col if (scal_col_type(jdo50) .eq. 'F' .or. + scal_col_type(jdo50) .eq. 'J' .or. + scal_col_type(jdo50) .eq. 'D') then itype = itype + 1 else if (scal_col_type(jdo50) .eq. 'Q') then isigs = isigs + 1 else write (6,6000)scal_col_type(jdo50),scal_col_label(jdo50) 6000 format (//' Hang on - You are scaling a column of type ' + ,a/,' The column label is ',a//) call ccperr(1,' Cannot let you do this !') endif write (6,6010)scal_val(jdo50),scal_col_label(jdo50) 6010 format (' * Applying scale of ',f5.2,' to column ',a) C 50 continue C if (itype .ne. isigs) then if ( .not. reverse_anom ) + write (6,6020)itype,isigs 6020 format (/' ***WARNING *** You are scaling ',i2, + ' columns of type [F|J|D]',/ + ' but only ',i2, + ' columns of type Q (sigma)',// + ' -----> This may well produce rubbish <-----'//) endif C return end C C*********************************************************************** C subroutine scaleop(recout,logmss,nr) C C*********************************************************************** C integer MCOLS parameter (MCOLS=500) integer maxsc parameter (maxsc=12) C real recout(MCOLS) integer nr,icol logical logmss(MCOLS) C integer n_scal_col,iscol(maxsc) real scal_val(maxsc),scal_all common /num_scal/ + scal_val,scal_all,n_scal_col,iscol save /num_scal/ C c Apply the scales to the necessary columns. Uncomment the lines c below if you want to monitor what's going on ! C C itest = mod(500,nr) C do 50 jdo50 = 1,n_scal_col icol = iscol(jdo50) C r_old = recout(icol) if (.not. logmss(icol)) + recout(icol) = recout(icol)*scal_val(jdo50) c if (itest.eq.0) write(6,10)icol,scal_val(jdo50), c + r_old,recout(icol) c 10 format (' Scaling column no. ',i2,' by ',f6.3, c + ' Old value: ',f10.3,' New value: ',f10.3) 50 continue c return end