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 Trying to fix fft SETGRD SETLIM stuff. C Have changed FFT and SFALL to use same subroutines. C C Mods to sfall and overlap map to allow more C than 1000 residues per protein. C C************************************************************* C C Program Converted to MTZ from LCF data file format C C Date:Mon Nov 18 14:57:07 GMT 1991 C C by: Eleanor Dodson (York University) 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 PROGRAM SFALL C ============= C C SF_Space_Group_Independent_Routines C ==================================== C C WARNING THIS CODE CALLS PGDEFN with Phil evans version C in the new symlib.for with C print logical arguement C C C This file contains the following routines C C ahvsor.f atsort.f closeit.f datred.f C divi.f fftgr1.f fftgr145.f fftgr146.f C fftgr152.f fftgr169.f fftgr18.f fftgr19.f C fftgr4.f fftgr92.f fileo.f genden.f C genhx.f grscrm.f hex.f hinr3.f C hout1.f hout2.f houtr3.f in144.f C in152.f in169.f in91.f inv21sc.f C keyin.f mltbl152.f mltbl92.f multbk.f C multbl.f multblr3.f multfs.f multi.f C newlin.f out144.f out147.f out152.f C out169.f phiwt.f psi.f psi2.f C r3pi.f readh1.f readh2.f readh3.f C readtl.f recipwt.f redmap.f refctl.f C rotperm.f sf.f sfall.f sfctl1.f C sfctl145.f sfctl146.f sfctl152.f sfctl169.f C sfctl18.f sfctl19.f sfctl4.f sfctl92.f C sfipn2.f sfipr3.f sfipy.f sfipz.f C sgtest.f soutfc.f soutn22.f C soutr3.f souty.f soutz.f subtut.f trans1.f C trnsp2.f trnsp3.f watom.f wrint.f C writemap.f writez.f yin2.f yin5.f C yout2.f yout92.f zin.f zin4.f C zout2.f C C C 10-1-1989 Transfer MULTBL and MULTKL s/rs from sg specific programs C into this; they are the same for all sgs which section up b or c. C C Add sr inv21sc to correct for the half scale you always C get after Inv21 calls 22-8-88 ejd C C******************************************************************* C C ELEANOR DODSON'S VERSION OF THE ISAACS-AGARWAL FAST FOURIER C LEAST SQUARES REFINEMENT PROGRAM C C DEC DIMENSIONING BEING REPLACED BY MIKE ELDER,S ROUTINE 10-10-79 C C X Appears to be used in the following ways: C C (1) 7 Words per atom refined. C The ARRAYS GRADN(3,..), SDXB, SDY, SDZ ,HESS are dimensioned to C NATREF = MAXCOR/8 . C C (2) 8 words per total atoms stored. the arrays XB(,2), BB, MB, C IA(,2), AtomicNumOccup, IRESB are dimensioned to NATST = MAXCOR/8 . C C (3) The array GAUSS(4001) in GENHX shares the space of SDXB to SDZ. C C (4) X is split into 2 parts, one of Size, one of Size/2, where C Size = 2*MAXCOR/3. The First part is used in the fourier C transform as the array FOFCPH. C C (5) FOFCPH is also used by FOBS and FCAL whose dimensioning C depends upon the space group. FOBS comes First while FCAL C is arranged to occupy the last words of FOFCPH since in C subroutine COEFIN FOBS and FOFCPH are used together - elements C are moved from FCAL to FOFCPH. C C (6) The second part of X is occupied by PHI (same dimension as FOBS C and FCAL) and is also used for GAUSS(4001) in GENDEN and as an C input buffer for channel 60 (space group specific). C C The conditional limits imposed upon the Size of the Work array C by the above are: C C (1) MAXCOR must exceed 8*Natoms (The refined atoms). default of C MAXCOR=12000 allows 800 atoms to be refined. C C (2) MAXCOR must exceed 8*TOTAL ATOMS (used in GENDEN). default C allows 1200 atoms to be stored. C C (3) Natoms (refined atoms) must be at least 2000/3 imposing a C lower limit of 1000 upon MAXCOR. C C (4) This imposes no real limit upon MAXCOR except for the obvious C fact that the larger MAXCOR and hence the dimension of FOFCPH, C the fewer the number of passes that will be needed and the C faster the program will execute. C C (5) as in (4), if MAXCOR is sufficiently large to give realistic C dimensioning to FOFCPH then the two arrays FOBS and FCAL will C fit into it. C C (6) These impose two conditions upon MAXCOR: it should exceed 10503 C so that GAUSS(4001) will fit into PHI (MAXCOR/3); it should also C exceed 3 times the record Size for channel 60 in certain space C groups. C C C PROGRAM_STRUCTURE C ======================= C C The basic structure of the program is the same for the several C versions of the program required to deal with different space groups. C The diagram below indicates the basic structure and names some of the C more important subroutines. The program function and a description of C the data control cards can be found in the User Documentation and this C should be read in conjunction with the documentation given here. C C DATRED -REFCTL -SFCTL -ATSORT C Input Controls Controls Prepare a list of atoms C Control Data Refinement s.f. calcn. C C -GENDEN C Generate electron density C map from the model C C -FFT and intermediate input C and output routines and C transformation routines C (Details are space group C dependent) C C -SOUTxx C Output of results from the C structure factor calcula- C tion and scaling of the C data C C -R3PI C Re-scaling of the data, C calculation of diff- C erence coefficients C and calculation of the C R-factor C C -FFTGR -COEFIN C Gradients Input of difference C Calculation coefficients C C -FFT routines, routines to C modify the coefficients, C input and output routines C for intermediate results C and transformation results C and transformation C routines (These are C space group dependent) C C -GENDEN C Convolute modified differ- C ence density function with C the atom electron C densities C C -GRSCRM -GENHX C Calculate and Calculate the diagonal C Apply Shifts terms of the normal C matrix of least C squares C C The various parts of the program are described in more detail below. C The order of the description basically follows that of the above C diagram, though with other routines being described where applicable. C C The following nomenclature is used in the description of the C program to refer to the axes and indices in general terms as different C orders of axes are used in the versions for the different space C groups. C C axes: X1, X2, X3 C indices: H1, H2, H3 C number of divisions C along each axis: = NX1, NX2, NX3 C C MAIN - A small main program Sets up the Work array which is then C passed to the remainder of the program. The subroutine DATRED is C called to read in the control data and initiate the calculations. C C DATRED - This subroutine reads in the items of the control data or C calls subroutines to read these in. After a number of items have been C read in and the C items associated with the MTZ reflection data files, a space group C dependent subroutine SGTEST is called to check that there is C sufficient array space available for the required refinement and to C set the limits of x, y and z required for the calculation. C The subroutine ROTPERM is called to calculate a transformation C matrix for the coordinates. If a refinement C is being carried out, the program copies the input coodinate file (on C unit 14) to the output coordinate file (on unit 22). The Work array C 'X' is partitioned into a number of parts for various arrays used in C the program (see the section on Data Formats for details). The C offsets, for the starts of the various arrays required, are calculated C and passed on to the remainder of the program by a call to the C subroutine REFCTL which controls the course of the refinement. C C SGTEST - This space group dependent subroutine sets the order of the C axes to be used in the calculation (JX, JY, JZ), sets the required C values of Hmin, Kmin and Lmin and set the limits for the calculation C on each of the axes IXmax, IYmax etc. (see table below for details for C the individual space groups). Checks are also made to ensure that the C array Size set aside for 'X' is adequate to hold the sections or C 'slabs' used in calculating the transform and that there is sufficient C space to hold the table of exponentials for use by the subroutine C GENDEN. C C Limits for Indices and Axes for the various space groups C Hmin Kmin Lmin IXmax IYmax IZmax C P1 -Hmax -Kmax 0 NX-1 NY-1 NZ-1 C P21 -Hmax 0 0 NX-1 NY/2-1 NZ-1 C P21212 0 0 0 NX-1 NY/4 NZ-1 C P212121 0 0 0 NX-1 NY-1 NZ/4 C P41212 0 0 0 NX-1 NY-1 NZ/8 C P31 0 0 -Lmax NX-1 NY-1 NZ/3 C R3 0 0 -Lmax NX-1 NY-1 NZ/3-1 C P3121 0 0 0 NX-1 NY-1 NZ/6 C C IXmin, IYmin and IZmin are zero in all cases. C C REFCTL - This subroutine controls the refinement procedure. The C subroutine SFCTL is called to control the calculation of a set of C structure factors based on a modeled electron density map. This C completes the requirements for a structure factor calculation. For a C refinement, the next step is to call the subroutine FFTGR for each of C the sets of parameters being refined, (x, y, z or B), to calculate the C gradients. The subroutine GRSCRM is then called to calculate and apply C the shifts. The subroutine SFCTL is called again to calculate a new C set of structure factors based on the shifted coordinates. The optimum C step Size for calculating the shifts is determined, with a repeat of C the structure factor calculation via SFCTL if required, as described C in the 'PROGRAM FUNCTION' section of the User Documentation. The C shifts (written by GRSCRM to files on units 17 and 18 on alternate re- C finement cycles) are then multiplied by the step Size and applied to C the coordinates read from the coordinate file on unit 22 and the C shifted coordinates are output to a file on unit 16. When the optimum C step Size has been determined, the shifted coordinates, held in the C file on unit 16 are used to overwrite the output coordinate file on C unit 22. A table of standard deviations, in ranges of temperature C factor, is then output to the line printer. The refinement process is C repeated for each requested refinement cycle. If required, the matrix C and gradient terms may be output at the end of the subroutine to a C file which can be used as the matrix input for the Hendrickson Konnert C restrained least squares protein structure refinement program. C C SFCTL - This subroutine controls the calculation of the structure C factors. The detailed requirements are space group dependent but the C general pattern is the same in each case. The procedure adopted in C described below in general terms. The space group dependent details C are given later. The subroutine ATSORT is called to prepare a list of C atoms, sorted on the X3 coordinate, to be included in the modeling of C the electron density map. The density map is calculated using the C subroutine GENDEN. (Alternatively a previously generated electron C density map may be read in from MAPIN via the sub-routine REDMAP). The C generated density map is normally used for the calculation of C structure factors but, if required, it may be output to a map file on C MAPOUT or to the line printer via the subroutine PRINTZ. The C calculation of the density is done in 'slabs' NX1 * NX2 * P1 with the C value of P1 being calculated to be as large as possible for the array C space available. When a slab of density has been calculated, a FFT is C calculated along the axis X2 (using the subroutine REALFT with half C the number of points along X2 as the electron density is a real C quantity) and a second transform is done along X1 (using CMPLFT over C all points along X1). This gives rise to a set of intermediate C coefficients, T(H1, H2, X3), for the points in the slab. These are C then written out to a direct access file DISKIO6 (The details of the C records written are space group dependent. As it may not always be C necessary to calculate the intermediate coefficients for the whole of C X3 because of space group symmetry, the coefficients may be C manipulated to form coefficients for other parts of the X3 axis at C this stage with the transposed coefficients also being stored on C DISKIO6. Also, if X3 is a 21 screw axis, only one half of X3 need be C calculated as special routines are available for calculating fast C fourier transforms along a 21 screw axis). When the calculation has C been completed for all the required slabs along X3, the third C transform is calculated by reading in, from the records on DISKIO6, C slabs perpendicular to H1 (X1) of dimensions NX2 * NH3 * P2. (NH3 is C calculated from the maximum index required for H3 and need not extend C to the full range of points NX3). For each slab read in the third C fourier transform, along X3, is calculated to give the structure C factors. (The subroutine used is CMPLFT or, if X3 is a 21 screw axis, C INV21) C C For space groups P41212 and P3121, a slightly different procedure C is adopted for selecting the data for the third transform. Instead of C taking rectangular slabs of data , triangular slabs are taken so that C only H >= K data are included. The number of points included in each C slab is determined by the array Size available and the limits of the C indices to be included in a slab are calculated by subtracting the C areas of triangles. C C After calculating the third transform for a slab, the space group C dependent subroutine SOUTxx (the exact name depends on the C spacegroup) is called to scale the data and output the structure C factors. The subroutine R3PI is called, if a refinement is being done, C to calculate the weighted difference coefficients used in the C gradients calculation and to output a summary of the structure factor C data. C C The table below gives the axes corresponding to X1, X2 and X3 for C the various space groups and the fraction of X3 along which the unique C part of the calculation is carried out for the First two transforms. C C X1 X2 X3 Range of X3 C P1 X Z Y 0 to Y C P21 X Z Y 0 to Y/2 C P21212 X Z Y 0 to Y/4 C P212121 X Y Z 0 to Z/4 C P41212 X Y Z 0 to Z/8 C P31 X Y Z 0 to Z/3 C R3 X Y Z 0 to Z/3 C P3121 X Y Z 0 to Z/6 C C ATSORT - This subroutine calculates the limits of a box, round the C asymmetric unit for calculating the electron density, to include any C atoms which would make a contribution to the electron density within C the asymmetric unit. The subroutine takes acKcount of the equivalent C positions and the requested atomic radius. The atom coordinates are C read from unit 22 and, for each atom read, the symmetry equivalent C positions are calculated. For each atom, all translations are added or C subtracted as required to bring the atom within the limits of the box. C Details of the atoms within the limits are held in a number of arrays C (see section on Data Formats) with eight words of storage required per C atom. Atoms which are included more than IPrintFlag times in the list C are listed on the line printer. The subroutine AHVSOR (which forms a C type of partitioned quicksort) is called to sort the coordinates along C axis X3. A list of the sorted atoms is output to the direct access C file on DISKIO1. Statistics on the number of atoms used and on the C atom temperature factors are collected during the course of the C subroutine. C C GENDEN - This subroutine uses the list of sorted atoms from the direct C access file on DISKIO1 to model the electron density. It is called C both from SFCTL to form an electron density map and from FFTGR (see C below) for the gradients calculation. For the structure factor C calculation a slab of data (NX1 * NX2 * P1) is generated on each call C to the subroutine. The contributions of each atom, to the electron C density at all grid points within the atom, are added in to the total C electron density at these points. The calculation of the electron C density is performed using the Gaussian approximations to the form C factors tabulated in the library atomsf.lib together with a table of C exponentials set up in the array GAUSS. If used, the additional C artificial temperature factor Bsmear is added to the temperature C factors of each of the atoms at this stage. C C For a gradients calculation, the gradient for an atom is calculated by C summing the product of the electron density at each point within the C atom and the value of the modified difference map (already calculated C and held in the array DEN before GENDEN is called from FFTGR) at that C point. The gradient contributions for the axis under consideration are C written back to the direct access file containing the details of the C atoms on DISKIO1. C C In both cases, the sum of the electron density (or modified C difference density) and the sum of the atomic scattering factors C squared are output, for the slab, to the line printer. It may be C noted, in passing, that the subroutine GENDEN is space group C independent. C C FOURIER TRANSFORM CALCULATIONS - As mentioned previously, the output C of intermediate transform calculations and their re-ordered input C before the third transform is calculated are space group dependent C operations. The generation of extra slabs of intermediate transform C results, using the space group symmetry uses different subroutines for C different space groups and may be done either at the output stage of C the intermediate results or at the input stage just prior to C calculating the third transform. The subroutine used for the third C transform is also space group dependent, being INV21 if the space C group has a 21 screw axis along X3 or otherwise CMPLFT. For space C group P212121 the subroutine MULTFS is also called to multiply the h C odd terms by i as the 21 screw axis does not pass through the origin. C C The table below summarises the subroutines used for the output C and input of the intermediate results and for the transpositions to C generate symmetry related data. C C Output Input Transform 3 Symmetry gen. data C P1 HOUT1(O) READH1(I) CMPLFT - C P21 HOUT1(O) READH2(I) INV21 - C P21212 HOUT2(O) READH3(I) INV21 NY/4 - NY/2 C TRANS1(S) C HOUT1(O) C P212121 WRINT(O,S) READTL(I) INV21 NZ/4 - NZ/2 C MULTFS C P41212 WRITEZ(O) IN91(I,S) INV21 NZ/8 - NZ/2 C P31 WRITEZ(O) IN144(I,S) CMPLFT NZ/3 - NZ C R3 HOUTR3(O) HINR3(I) CMPLFT - C P3121 WRITEZ(O) IN152(I,S) CMPLFT NZ/6 - NZ C C Key: O = output results, I = input results, C S = generate symmetry related data. C C SOUTxx - The exact name of the subroutine used depends on the space C group. The details of the subroutines are also space group dependent C but all versions follow essentially the same pattern. The subroutine C is called for each 'slab' after the transform along the third axis has C been calculated in SFCTL. On the First cycle of refinement or for a C structure factor calculation, the subroutine will read the Fobs data C from the input reflection data file, calculate a scale factor and an R C factor for the data and, if required, add in previously calculated C partial contributions to the structure factors, from heavy atoms, held C in the input reflection data file. C C If a structure factor calculation is being done, then a new C output reflection data file is created containing the calculated C structure factors, scaled with the old scale factor, together with C other information as specified by the program's control data. C C If a refinement is being done, three files are written with Fobs C being written to DISKIO2, Fcalc (scaled with the old scaled factor) to C DISKIO3 (direct access) and Phi to DISKIO4. C C R3PI - This subroutine reads the Fobs file on DISKIO2 and the Fcalc C file on DISKIO4 and calculates a new scale factor for the data with an C option to re-scale the data based on the distribution of the Fobs and C Fcalc data over a range of sin theta. If an artificial temperature C factor, Bsmear, was added to the atom temperature factors for the C structure factor calculation, then the calculated structure factors C are back corrected for this in this subroutine. The files are then C read again and weighted differences between Fobs and Fcalc are C calculated. These are written back to the direct access file on C DISKIO3, overwriting the Fcalc data. At the same time data are C collected for preparing a structure factor summary table and for C calculating the R factor and the value of the least squares C minimisation function. At the end of the subroutine, the structure C factor table, R factor and value of the minimisation function are C output to the line printer. C C FFTGR - This subroutine is used to control the calculation of the C gradients. Like SFCTL it is a space group dependent subroutine. The C process adopted by the subroutine is essentially a reversal of the C procedure used in the structure factor calculation but starting from C weighted difference coefficients and finishing with a modified C difference density function. C C The First transform is carried out on slabs of data (read in via C COEFIN) perpendicular to H1 and of thickness P1. The transform along C H3 is calculated for the slab and the results are written out to a C file on unit 3. Slabs of data perpendicular to H3 are then read and C the remaining two transforms are calculated along H1 and H2. For a C gradient calculation on axis Xi the coefficients are modified by C calling a subroutine, in general MULTH for X, MULTK for Y or MULTL for C Z, prior to calculating the transform. For a gradient calculation for C temperature factor refinement, the coefficients are modified prior to C calculating the First transform. A composite subroutine for modifying C the coefficients either of the axis corresponding to X3 or of B is C used, being MULTBK if X3 is Y or MULTBL if X3 is Z. The First C transform is calculated using CMPLFT or, if X3 is a 21 screw axis, C SDIAD. The second transform is calculated using CMPLFT and the final C transform is calculated using HERMFT (as the density function is C real). After the three dimensional transform has been calculated to C give the modified difference density map, the redundant points of the C map are set equal to zero if required and the atom electron densities C are convoluted with the modified difference density by the subroutine C GENDEN to give the gradients. C C As is SFCTL, the input and output of the intermediate results of C the transform is a space group dependent operation and results are C also transposed in some space groups using the space group symmetry. C The routines used are shown in the table below. Also, for space groups C P41212 and P3121, triangular slabs are taken for the First transform C (see SFCTL for more details). C C Transform 1 Output Input Symmetry generated data C P1 CMPLFT YOUT2(O) YIN2(I) - C P21 SDIAD YOUT2(O) YIN2(I) - C P21212 SDIAD YOUT2B(O) YIN5(I) data for - h C TRNSP3(S) C YOUT2B(O) C P212121 SDIAD ZOUT2(O) ZIN4(I) C DIV I TRNSPR(S) data for - h C ZOUT2(O) C P41212 SDIAD YOUT92(O,S) ZIN(I) all hk data for 0-Z/8 C from h >= k data for 0-Z C P31 CMPLFT OUT144(O,S) ZIN(I) i h l and -k -i l data C R3 CMPLFT OUT147(O,S) ZIN(I) i h l and -k-il data C P3121 CMPLFT OUT152(O,S) ZIN(I) All hk data for 0-Z/6 C from h >= k data for 0-Z C C Key: O = output results, I = input results, C S = generate symmetry related data C C COEFIN - This subroutine is used to read in a slab of data with C difference coefficients at the start of calculating the modified C difference density map for the gradient calculation in FFTGR. C C GRSCRM - This subroutine combines the gradient contributions for atoms C which are near the edge of the asymmetric unit. The subroutine GENHX C is then called to calculate the diagonal terms of the normal matrix C and then calculate the shifts. The average and maximum values of the C gradients and shifts are calculated and any shifts greater than RATIO C * r.m.s. shift are truncated. If required, the conjugate gradient C method will be used to calculate the shifts, reading in the shifts C from the previous cycle on unit 17 or 18 on alternate cycles. The C shifts are written out to a file on unit 18 or 17 on alternate cycles C and the shifted coordinates are written to unit 16. C C GENHX - This subroutine calculates the diagonal terms of the normal C matrix. The function A'xx(bi) (see Agarwal's paper) is tabulated for C each value of bi from 1 to 150. The subroutine then calculates and C sums the contributions of the terms to the diagonal elements of the C normal matrix for each atom. C C PRINTZ, PRINTY - One of these subroutines is used to output the C electron density map, modeled from the atomic coordinates, if C required. The output may either be to a direct access file in the C standard map format (on MAPOUT) or to the line printer. C C FFT ROUTINES - The program uses subroutines written by Ten Eyck for C calculating the fast fourier transforms. The following routines are C used where appropriate as described above. C C CMPLFT complex - complex transform C REALFT real - complex transform C HERMFT complex - real transform C INV21 inverse transform along a screw diad C SDIAD transform along a screw diad C C These subroutines call further subroutines within the FFT subroutines C package. C C Important_Variables C C The most complex aspect of the data formats is the use of the C different parts of the Work array 'X' at different stages of the C refinement. The starting points of the various arrays using this space C are calculated in DATRED and passed on to the rest of the program via C the parameters of the subroutine REFCTL. In some cases the array may C be used in its entirety and in other cases it is split into two parts C with the First part being 2/3 of the total length and the second part C being the remaining 1/3. The First element of the array X which is C actually used is the First element of the dynamically allocated space. C C Uses of part 1: 1) Array to hold 'slabs' of data usually called FOFCPH C for intermediate transform data or DEN for electron C density. In some subroutines the name X is used. or C C 2) Arrays FOBS (or FF) and FCALC at the start and end C of part 1 to hold Fobs and Fcalc values. C C Uses of part 2: 1) Array PHI to hold the calculated phases (of Fobs C values in SFCTL) C C or C C 2) Array GAUSS to hold a table of exponentials (3501 C words long setting an overall minimum length for C the Work array of 3 * 3501 words) C C Uses of whole: 1) Arrays holding details of the atoms used for the C structure factor calculation. The total array space C required is 8 * the number of atoms used in the C structure factor calculation. The arrays used are C as follows with NAT being the maximum number of C atoms to be used in the structure factor C calculation. A number of the arrays contain packed C items of information. C C BB(NAT) Temperature factor together with the C atomic sequence number. C XB(2,NAT) coordinate 1 + symmetry position C number coordinate 2 + no. of times C that atom is included (ICH) C MB(NAT) Atom name and residue type. C IA(2*NAT) 100000 * coordinate 3 for each atom C followed by the atom number (position C in the input file) for each atom C AtomicNumOccup(NAT) 20 * atomic number + Occupancy + 10 C IRESB(NAT) Residue number C C or 2) Arrays holding details of each of the atoms being C refined. Each array is dimensioned to the maximum C number of atoms which may be refined, NATREF, or to a C multiple of this. The arrays used are as follows: C C GRADN(3,NATREF) Gradients on x, y, z or B C SDXB(NATREF) Shifts in x, y, z or B C HESS(NATREF) The terms of the diagonal elements of C the normal matrix for least squares. C C The uses of the Work array space are summarised in the following C diagram. C C X ---------------------------------------------------------------> C Part 1 (2/3 of total) Part 2 (1/3 of total) C FOFCPH (or DEN or X) -----------> GAUSS -----------> C FOBS --------> <--------FCALC PHI (FF)----> C GRADN,SDXB etc. for each atom refined (8 words/atom - 7 used) ---> C C BB,XB etc. for each atom in structure factor calculation C (8 words/atom) -------> C C Two other variables are worth mentioning. These are P1 and P2 whih are C used to be the thicknesses of the 'slabs' used for the calculation of C the transforms. Their use is described in more detail in the C descriptions of the subroutines SFCTL and FFTGR. C C---- MAIN sets MaxCoreSize only C INTEGER MaxCoreSize PARAMETER (MaxCoreSize = 5000000) C .. C .. Local Arrays .. CHARACTER TYPE (1), LENGTH (1)*7 INTEGER LENDEF (1) C .. C .. External Subroutines .. EXTERNAL CCPALE,CCPFYP,CCPRCS,DATRED,MTZINI,XYZINIT C .. DATA TYPE /'R'/, LENGTH /'MEMSIZE'/, LENDEF /MaxCoreSize/ C CALL CCPFYP CALL MTZINI CALL XYZINIT CALL CCPRCS(6,'SFALL','$Date: 2002/04/05 16:12:35 $') C since the array is used as complex, we should allocate it as such, C although ccpalc should use a suitable alignment anyhow CALL CCPALE (DATRED, 1, TYPE, LENGTH, LENDEF, .TRUE.) END C C ===================================== SUBROUTINE DATRED(MaxCoreSize,X) C ===================================== C C .. Parameters .. INTEGER MaxSymmetry PARAMETER (MaxSymmetry=192) INTEGER MaxFormFactors PARAMETER (MaxFormFactors=20) INTEGER MaxNumChains PARAMETER (MaxNumChains=20) C .. C .. Scalar Arguments .. INTEGER IDUM,MaxCoreSize C .. C .. Array Arguments .. REAL X(MaxCoreSize) C .. C .. Scalars in Common .. REAL A6NAP2,A6NAP3,AA1,AverageBfactor,BfactFpart,BfactorMax, + BfactorMin,BfactOverall,BfactReset,BfactStartStepSize,Bsmear, + BulkWaterSF,GR1,GR3NA2,RatioShiftTrunc,RHmax,RHmean,RHmin, + RmsBfactor,RmsDelta,RmsXyz,ScaleFcalc,ScaleFpart, + SFrepeatValue,SigmaExclude,Smax,Smin,SquAtmRadLimit, + SSbinSize,TH,TruncMapMax,TruncMapMin,TruncNewMax,TruncNewMin, + TSmax,TSmin,VolMtz,W,WangSphereRadi,XyzStartStepSize INTEGER Hmax,Hmin,IOatomop,IOgradmat,IOhessian,IOmap, + IOscratch,IOshifts,IOxyzin,IOxyzoutunq,IXmax, + IXmin,IYmax,IYmin,IZmax,IZmin,Jsec,JU1,JU2,JV1,JV2,Kmax, + Kmin,Ksec,KU1,KU2,KV1,KV2,LatomMapFlag,LBfactRefFlag, + LcheckSFspaceGrpFlag,LFpartFlag,LFreeRexcludeVal, + LSFrefFlag,LhklInputFlag,LMapInFlag,Lmax,Lmin, + LPhiPartFlag,LSFcalcFlag,LSFmodeFlag,LSolvMaskFlag, + LWghtModeFlag,LxyzInputFlag,LXyzOutputFlag,Msec,NLPRGO, + LrefineCycFlag,Nslab,NtotalRefsUsed, + NumAtmRefined,NumChains,NumFormFactors,NumMultiplicity, + NumPlanes,NumSections,NumSFspaceGroup,NumSFsymm, + NumSpaceGroup,NumSymmetry,NumZeroOccAtms,NX,NY,NZ LOGICAL LNoScaleFlag,LverboseFlag CHARACTER Title*80 C .. C .. Arrays in Common .. REAL AtmBoxLowLim,AtmBoxUpLim,CellMtz,ExtBoxLowLim,ExtBoxUpLim, + ExtraPlanes,FormFactAcoeff,FormFactBcoeff,PermutRecipSymm, + PlanesLimits,RealSymmMatrx,SpecialPlaneLimit, + RecipSymmMatrx,FormFactAcoeffSum INTEGER Iuvw,IuvwMP,KatmWghts,LSymmFlags,NumFirstResChn, + NumGaussPerAtmTyp,NumLastResChn,NumResPerChn,Nxyz CHARACTER ChainLabels*1,ElementNames*4 C .. C .. Local Scalars .. REAL DINV,Dmax,Dmin,DSmax,DSmin,XALPH,XBET,XCONV,XGAMM,XSUM,XV INTEGER ICH,Ifail,IOsymm,ISSLL,J,MapMode, + MBB,MFOF,MGRADN,MHESS,MIA,MIRESB,MMB,MPHI,MSDXB,MXB, + MZZOCB,N,NATREF,NATST,NATST2,NPassTwoSave,NumBytesItem, + Size,Size32 C .. C .. External Functions .. INTEGER LENSTR EXTERNAL LENSTR C .. C .. External Subroutines .. EXTERNAL CCPERR,KEYIN,MSYPUT,MWRHDR,QMODE,QOPEN,REFCTL, + ROTPERM,SGTEST C .. C .. Intrinsic Functions .. INTRINSIC ABS,NINT,SIN,SQRT C .. C .. Common blocks .. COMMON /ATMLIM/ + ExtBoxLowLim(3),ExtBoxUpLim(3), + SquAtmRadLimit,NumPlanes, + ExtraPlanes(3,6),PlanesLimits(6), + SpecialPlaneLimit(6), + AtmBoxLowLim(3),AtmBoxUpLim(3), + NumAtmRefined,NumZeroOccAtms COMMON /ATSYM/ + NumSymmetry,NumSpaceGroup, + RealSymmMatrx(4,4,MaxSymmetry), + RecipSymmMatrx(4,4,MaxSymmetry), + PermutRecipSymm(4,4), + LSymmFlags(MaxSymmetry) COMMON /BFACTS/ + AverageBfactor, + BfactorMin, + BfactorMax, + Bsmear, + BfactReset COMMON /CHAIN/ + NumChains, + NumFirstResChn(MaxNumChains), + NumLastResChn(MaxNumChains), + NumResPerChn(MaxNumChains) COMMON /CHNCH/ + ChainLabels(MaxNumChains) COMMON /FORM1/ + BulkWaterSF,NumFormFactors, + NumGaussPerAtmTyp(MaxFormFactors), + KatmWghts(MaxFormFactors), + FormFactAcoeff(5,MaxFormFactors), + FormFactBcoeff(5,MaxFormFactors), + FormFactAcoeffSum(MaxFormFactors) COMMON /FORM2/ + ElementNames(MaxFormFactors) COMMON /HKLLIM/ + Hmax,Kmax,Lmax,Hmin,Kmin,Lmin,Nslab COMMON /IOSF/ + IOscratch,IOgradmat,IOhessian,IOshifts, + IOatomop,IOmap,IOxyzin,IOxyzoutunq COMMON /KH/ + RmsDelta,AA1,A6NAP2,A6NAP3,GR1,GR3NA2 COMMON /MAPCHK/ + IuvwMP(3),Nxyz(3), + KU1,KU2,KV1,KV2, + Ksec,Msec COMMON /MPHDR/ + NX,NY,NZ, + IXmin,IXmax,IYmin,IYmax,IZmin,IZmax, + Jsec,JU1,JU2,JV1,JV2,Iuvw(3), + NumSFspaceGroup,NumSections, + RHmin,RHmax,RHmean,NumSFsymm, + CellMtz(6),VolMtz,Volfft,F000 COMMON /MPHDRR/ + Title COMMON /SFOUT/ + Smin,Smax,TSmin,TSmax,SSbinSize, + LFpartFlag,LPhiPartFlag,LWghtModeFlag, + ScaleFcalc,ScaleFpart, + SigmaExclude,WangSphereRadi, + BfactOverall,BfactFpart, + NumMultiplicity,NLPRGO COMMON /SRFCTL/ + NtotalRefsUsed, + RatioShiftTrunc,W,TH, + LSFmodeFlag,LrefineCycFlag,LBfactRefFlag, + LcheckSFspaceGrpFlag,LFreeRexcludeVal, + XyzStartStepSize,BfactStartStepSize, + SFrepeatValue, + RmsXyz,RmsBfactor COMMON /SRFCTL1/ + LSFcalcFlag,LSFrefFlag, + LatomMapFlag,LxyzInputFlag, + LhklInputFlag,LMapInFlag, + LSolvMaskFlag,LXyzOutputFlag COMMON /TERSE/ + LverboseFlag,LNoScaleFlag COMMON /TRUNC/ + TruncMapMin,TruncMapMax, + TruncNewMin,TruncNewMax C .. DATA IDUM /0/ C .. C Ifail = 0 IOatomop = 0 IOgradmat = 0 IOhessian = 0 IOmap = 0 IOscratch = 0 IOshifts = 0 C C NumPlanes = 0 C C---- Message flags - set to zero for normal running. C set some defaults for k-h Matrix C AA1 = 0 A6NAP2 = 0 GR1 = 0 GR3NA2 = 0 C C---- program space C Size32 = MaxCoreSize Size = Size32*2/3 NATST = Size32/8 NATREF = Size32/8 NATST2 = 2*NATST C C---- Read input parameters C C ***** CALL KEYIN C ***** C IF (NumSymmetry.EQ.0) 1 CALL CCPERR(1,'You MUST input SYMM for this calculation') C IF (BulkWaterSF.GT.0.0001)WRITE (6,FMT=6000) BulkWaterSF 6000 FORMAT (/, +' - bulk water scattering is assumed to be ',F10.3, +' Electrons/A**3 ',/, +' If ATMMAP set Program outputs MAP containing ', +'only BULK SOLVENT') C WRITE (6,FMT=6002) 6002 FORMAT (///, +' Form factors used are ',/, +' AtomName - formfac number - (AI BI),I=1,NGauss - sum(AI)',/, +' Default value is 2 term gaussian') C DO 10 N = 1,NumFormFactors WRITE (6,FMT=6004) ElementNames(N), + KatmWghts(N), + (FormFactAcoeff(J,N), + FormFactBcoeff(J,N), + J=1,NumGaussPerAtmTyp(N)), + FormFactAcoeffSum(N) 6004 FORMAT (2X,A4,I5,2X,2 (2F10.5,2X),/,13X,5 (2F10.5,2X)) 10 CONTINUE C WRITE (6,FMT=6006) Title(1:LENSTR(Title)) 6006 FORMAT (/' Title: ',A,/) IF (LverboseFlag)WRITE (6,FMT=6008) MaxCoreSize 6008 FORMAT (/' Work array dimensioned to ',I6,' Words') C C---- April 1986 Use LSFmodeFlag to decide on path for the Program C Set LrefineCycFlag as it used to be to reduce C IF (LSFcalcFlag.EQ.1)THEN LrefineCycFlag = 0 WRITE (6,'(a)')' Structure Factor Calculation ' IF (LhklInputFlag.EQ.1) WRITE (6,'(a)') +' Structure Factor Calculation to match existing FOBS file ' IF (LxyzInputFlag.EQ.1) + WRITE (6,'(a)')' - Atom file Read ***' IF (LSolvMaskFlag.EQ.1)write(6,'(a,/,a)') + ' Atom file used to define solvent mask *** ', + ' Fcalcs derived from back transform of the SOLVENT map' C IF (LMapInFlag.EQ.1) + WRITE (6,'(a)') + ' - Map file Read for back transformation***' IF (TruncMapMax.GT.0.0) WRITE (6,FMT=6016) + TruncMapMin, + TruncMapMax, + TruncNewMin, + TruncNewMax 6016 FORMAT ( +' Map truncated to values between ',F10.3,' and ',F10.3, /, +' Replaced by values ',F10.3,' and',F10.3) C IF (LWghtModeFlag.GT.0) WRITE (6,FMT=6020) + LWghtModeFlag, + WangSphereRadi 6020 FORMAT ( +' Writes an Output file H K L S FC ALPHAC wangwt ',/, +' for all Reflns within SINTHETA Limits - No FOBS ',/, +' LWghtModeFlag WangSphereRadi ',I5,F10.3) C IF (LhklInputFlag.EQ.0) WRITE (6,FMT=6022) 6022 FORMAT ( +' Writes an output file H K L S FC ALPHAC ',/, +' For all Reflns within SINTHETA Limits ***') END IF C IF (LatomMapFlag.EQ.1)THEN LrefineCycFlag = 0 WRITE (6,'(a/,a)') +' Program outputs an Electron density map ', +' Generated from Atomic Co-ordinates -' IF (LSolvMaskFlag.EQ.1) WRITE(6,'(A)') + ' Atom file used to define solvent mask *** ' C IF (LSFmodeFlag.EQ.-5) WRITE(6,'(a,a,/,a)') +' Electron density map Generated ', +' from Atomic CORDINATES with 100*ires+1000000*mchflg', +' *** only useful for correlation by residue no.**' C IF (LSFmodeFlag.EQ.-6) WRITE(6,'(a,a,/,a)') +' Electron density map ', +' Generated from Atomic Co-ordinates with 100*iatnum', +' *** only useful for correlation by atom no.** ' END IF C IF (LFreeRexcludeVal.GE.0) THEN WRITE (6,'(A,A,I5)')' Reflections excluded if Free R ', + ' factor = ',LFreeRexcludeVal END IF C C C---- Set these parameters as they used to be C IF (LSFmodeFlag.EQ.1) THEN WRITE (6,FMT=6032) 6032 FORMAT (/, +' Refinement of X Y Z Parameters - Gradients output For K-H') LrefineCycFlag = 1 LBfactRefFlag = 0 END IF C IF (LSFmodeFlag.EQ.2) THEN WRITE (6,FMT=6034) 6034 FORMAT (/, +' Refinement of X Y Z and B Values ***',/, +' - Gradients output For K-H ',//) LrefineCycFlag = 2 LBfactRefFlag = 0 END IF C IF (LSFmodeFlag.EQ.3) THEN WRITE (6,FMT=6036) 6036 FORMAT (/, +' Refinement of X Y Z Parameters only',/, +' - Structure Factors Recalculated and New Atom Posns output') LrefineCycFlag = 1 LBfactRefFlag = 0 END IF C IF (LSFmodeFlag.EQ.4) THEN WRITE (6,FMT=6038) 6038 FORMAT (/, +' Refinement of B Values only ***',/, +' - Structure Factors Recalculated and New Atom Posns output') LrefineCycFlag = 1 LBfactRefFlag = 1 END IF C IF (LSFmodeFlag.EQ.5) THEN WRITE (6,FMT=6035) 6035 FORMAT (/, +' Refinement of X Y Z and B Values ***',/, +' - Structure Factors Recalculated and New Atom Posns output') LrefineCycFlag = 2 LBfactRefFlag = 0 END IF C C---- Chain names and lengths C IF (LxyzInputFlag.NE.0) THEN WRITE (6,FMT=6040) (ChainLabels(ICH), + NumFirstResChn(ICH), + NumLastResChn(ICH), + NumResPerChn(ICH), + ICH=1,NumChains) 6040 FORMAT (//, +' Chain Names - First Residue - Last Residue -', +' serial Kcount',20 (/8X,A1,9X,I4,9X,I4,9X,I5)) END IF C C---- Reset Hmax Kmax Lmax - C only if LSFmodeFlag gt -4 - not nec for map output C IF (LSFcalcFlag.EQ.1 .OR. LSFrefFlag.EQ.1) THEN DINV = SQRT(Smax) Hmax = NINT(CellMtz(1)*DINV) Kmax = NINT(CellMtz(2)*DINV) Lmax = NINT(CellMtz(3)*DINV) IF (LrefineCycFlag.GT.0) BfactOverall = 0.0 END IF C C---- Check grid limits here. C IF (NX.LT.2*Hmax+1) WRITE(6,*)' NX Hmax',NX,Hmax IF (NY.LT.2*Kmax+1) WRITE(6,*)' NY Kmax',NY,Kmax IF (NZ.LT.2*Lmax+1) WRITE(6,*)' NZ Lmax',NZ,Lmax IF (NX.LT.2*Hmax+1) CALL CCPERR (1, + ' Grid too small- NX must be > 2*Hmax+1') IF (NY.LT.2*Kmax+1) CALL CCPERR (1, + ' Grid too small- NY must be > 2*Kmax+1') IF (NZ.LT.2*Lmax+2) CALL CCPERR (1, + ' Grid too small- NZ must be > 2*Lmax+1') C IF (ScaleFpart.EQ.0.0) ScaleFpart = 1.0 C C ************************* CALL SGTEST(Size,NPassTwoSave) C ************************* C C---- Dont forget to permute symmetry now C C **************************** CALL ROTPERM(NumSymmetry, + PermutRecipSymm, + RealSymmMatrx) C **************************** C IF (SSbinSize.EQ.0.0) SSbinSize = 20.0 IF (XyzStartStepSize.EQ.0.0) XyzStartStepSize = 1.0 IF (BfactStartStepSize.EQ.0.0) BfactStartStepSize = 1.0 IF (SFrepeatValue.LE.0.3) SFrepeatValue = 0.3 AA1 = 0 A6NAP2 = 0 GR1 = 0 GR3NA2 = 0 C C---- For refinement set boverall = 0. C C Option to read cell and rotation matric from brookhaven file C C Mirror input parameters C WRITE (6,FMT=6042) Title(1:LENSTR(Title)) 6042 FORMAT (' Title ',/4X,A) WRITE (6,FMT=6044) CellMtz,NumSFspaceGroup 6044 FORMAT (/, +' Unit CELL Parameters are = ',6F10.4,/, +' Space Group Number = ',I5,/) C IF (LSFcalcFlag.EQ.1 .OR. LSFrefFlag.EQ.1) + WRITE (6,FMT=6046) Hmin,Kmin,Lmin,Hmax,Kmax,Lmax 6046 FORMAT (//' Hmin, Kmin, Lmin, Hmax, Kmax, Lmax are ',6I5,//) WRITE (6,FMT=6048) NX,NY,NZ 6048 FORMAT (' Sampling Intervals NX,NY,NZ are ',3I5,//) WRITE (6,FMT=6050) IXmin,IXmax,IYmin,IYmax,IZmin,IZmax 6050 FORMAT (' Map dimensions are X = ',I5,' to ',I5,' Y = ',I5, + ' to ',I5,' Z = ',I5,' to ',I5,//) C ISSLL = NINT(SSbinSize) IF (LSFcalcFlag.EQ.1 .OR. LSFrefFlag.EQ.1) + WRITE (6,FMT=6052) Smin,Smax,ISSLL 6052 FORMAT ( +' Minimum,Maximum 4(SNTH/L)**2 are ',F7.4,' and ',F7.4,/, +' intervals of s for rfactor analysis are 1./',I5,//) C Dmin = SQRT(1.0/Smax) Dmax = 1000.0 IF (Smin.NE.0.0) Dmax = SQRT(1.0/Smin) IF (LSFcalcFlag.EQ.1 .OR. LSFrefFlag.EQ.1) + WRITE (6,FMT=6054) Dmax,Dmin 6054 FORMAT ( +' ie Resolution Limits ',F6.1,' to ',F6.1,' Angstroms',//) WRITE (6,FMT=6056) Bsmear 6056 FORMAT (' BADD = ',F6.2,//) WRITE (6,FMT=6058) SquAtmRadLimit 6058 FORMAT (' Square of Atom radius in "fc" MAP ',F10.2,//) IF (LSFcalcFlag.EQ.1 .OR. LSFrefFlag.EQ.1) + WRITE (6,FMT=6060) W,TH 6060 FORMAT (' Weight Omit ',2F10.2,//) IF (LSFcalcFlag.EQ.1 .OR. LSFrefFlag.EQ.1) + WRITE (6,FMT=6062) ScaleFcalc,BfactOverall 6062 FORMAT (' Scale BfactOverall ',2F10.2,/, +' FCALC is scaled by SCALE*exp(-BfactOverall*S/4)',/) C IF (ABS(TSmax) .GT. 0.0001) THEN DSmin = SQRT(1/TSmax) IF (ABS(TSmin) .LT. 0.0001) TSmin = 0.0001 DSmax = SQRT(1/TSmin) IF (LSFcalcFlag.EQ.1 .OR. LSFrefFlag.EQ.1) + WRITE (6,FMT=6064) DSmin,DSmax 6064 FORMAT (/, +' DSmin DSmax ',2F10.2,/, +' in refinement overall Scale and B are refined using ',/, +' reflections with DSMN< = D< = DSmax ',//) END IF C IF (LSFcalcFlag.EQ.1 .OR. LSFrefFlag.EQ.1) + WRITE (6,FMT=6066) SigmaExclude 6066 FORMAT (//, +' Reflections for which FOBS <',F5.1,' SIGMA Omitted',//) C IF ( LSFrefFlag.EQ.1) THEN WRITE (6,FMT=6068) 6068 FORMAT (/, + ' Matrix for Konnert-Hendrickson output ',/, + ' Gradient Terms multiplied by STEPSize') IF (XyzStartStepSize.GT.0.001) + WRITE (6,FMT=6070) XyzStartStepSize 6070 FORMAT (/' XYZ Initial StepSize = ',F5.2) IF (LBfactRefFlag.EQ.1 .AND. + BfactStartStepSize.GT.0.0001) + WRITE (6,FMT=6072) BfactStartStepSize 6072 FORMAT (/' B Initial StepSize = ',F5.2) END IF C IF (( ABS(RmsXyz).LT.0.001 .AND. + ABS(RmsBfactor).LT.0.001) .AND. + LSFmodeFlag.GT.2) + WRITE (6,FMT=6074) SFrepeatValue, + RatioShiftTrunc 6074 FORMAT (/, +' Structure Factor calculation repeated if ',/, +' ABS(Initial step -Optimum step)/Initial step > ',F8.3,//, +' Shifts scaled to be less than ',F6.2,' Rms shift.',//) C IF (( ABS(RmsXyz).GT.0.001 .OR. + ABS(RmsBfactor).GT.0.001) .AND. + LSFmodeFlag.GT.2) + WRITE (6,FMT=6078) RmsXyz,RmsBfactor 6078 FORMAT (/, + ' No search for best step Size',/, + ' Shifts on XYZ restricted to ',F8.4,/, + ' Shifts on B restricted to ',F8.4) C IF (LBfactRefFlag.EQ.1) WRITE (6,FMT=6076) 6076 FORMAT (' Temperature Factor refinement',//) WRITE (6,FMT='(a,F5.2)')' Breset is ',BfactReset C C---- For refinement set boverall = 0. C IF (ScaleFpart.EQ.0.0) ScaleFpart = 1.0 C IF (NumMultiplicity.GT.1) WRITE (6,FMT=6082) + NumMultiplicity,NumMultiplicity 6082 FORMAT (//, + ' Non Primitive Spacegroup of order ',I3,/, + ' FCS Multiplied by ',I3) C C----Original coords read from channel 22. C C After ATSORT the expanded and sorted set are on random access 23. C during refinement various temporary sets with different step Sizes C are written to 16, and at the end of the cycle aone is copied back C onto 22.( beware - keep another copy of input set.) C IF (LxyzInputFlag.NE.0) THEN CALL QOPEN(IOatomop,'ATOMOP','SCRATCH') CALL QMODE(IOatomop,2,NumBytesItem) END IF C Nxyz(1) = NX Nxyz(2) = NY Nxyz(3) = NZ MapMode = 2 IOmap = 1 C IF (LatomMapFlag.EQ.1) THEN C C ********************************** CALL MWRHDR(IOmap, + Title, + NumSections, + Iuvw, + Nxyz, + Jsec, + JU1, + JU2, + JV1, + JV2, + CellMtz, + NumSpaceGroup, + MapMode) C ********************************** C XCONV = 3.14159/180. XALPH = XCONV*CellMtz(4) XBET = XCONV*CellMtz(5) XGAMM = XCONV*CellMtz(6) XSUM = 0.5*(XALPH + XBET + XGAMM) XV = SQRT( SIN(XSUM - XALPH) * + SIN(XSUM - XBET) * + SIN(XSUM - XGAMM) * + SIN(XSUM) ) VolMtz = 2.0*CellMtz(1)*CellMtz(2)*CellMtz(3)*XV IOsymm = 0 C C ************************** CALL MSYPUT(IOsymm, + NumSFspaceGroup, + IOmap) C ************************** C ELSE C IF (LMapInFlag.EQ.1) THEN IF (Volfft .EQ. 0.0 ) Volfft = VolMtz C C---- Check map information agrees with that set C in sgtest for this spacegroup. C WRITE (6,FMT='(/,a,a,/a,3x,3i4,3x,3i4)') + ' Check map header agrees with fixed requirements for SFcalc', + ' for this spacegroup.', + ' Check Nxyz ',Nxyz, NX,NY,NZ C IF (Nxyz(1).EQ.NX .AND. Nxyz(2).EQ.NY .AND. + Nxyz(3).EQ.NZ) THEN WRITE (6,FMT='(/,a,a,/a,3x,3i4,3x,3i4)') + ' Check map header agrees with fixed requirements for SFcalc', + ' for this spacegroup.', + ' Check Iuvw ', IuvwMP,Iuvw C IF (IuvwMP(1).EQ.Iuvw(1) .AND. + IuvwMP(2).EQ.Iuvw(2) .AND. + IuvwMP(3).EQ.Iuvw(3)) THEN C IF (Iuvw(3).EQ.3) THEN WRITE(6,FMT='(/,a,a,/,a,/,2(3x,3(2x,2i4)))') +' Check map header agrees with fixed requirements for SFcalc', +' for this spacegroup.', +' Check KV1 KV2 KU1 KU2 Ksec,Msec - IXmin IXmax.. ', + KV1,KV2,KU1,KU2,Ksec,Msec, + IXmin,IXmax,IYmin,IYmax,IZmin,IZmax C IF (KU1.EQ.IYmin .AND. KU2.GE.IYmax) THEN IF (KV1.EQ.IXmin .AND. KV2.GE.IXmax) THEN IF (Ksec.EQ.IZmin .AND. + Msec.GE. (IZmax-IZmin+1)) GO TO 60 END IF END IF C ELSE IF (Iuvw(3).EQ.2) THEN WRITE(6,FMT='(/,a,a,/a,/,2(3x,3(2x,2i4)))') +' Check map header agrees with fixed requirements for SFcalc', +' for this spacegroup.', +' Check KV1 KV2 KU1 KU2 Ksec,Msec - IXmin IXmax.. ', + KV1,KV2,KU1,KU2,Ksec,Msec, + IXmin,IXmax,IZmin,IZmax,IYmin,IYmax C IF (KU1.EQ.IZmin .AND. KU2.GE.IZmax) THEN IF (KV1.EQ.IXmin .AND. KV2.GE.IXmax) THEN IF (Ksec.EQ.IYmin .AND. + Msec.GE. (IYmax-IYmin+1)) GO TO 60 END IF END IF END IF END IF END IF C CALL CCPERR(1, + ' **** Fatal disagreement between input info and map header') END IF C 60 CONTINUE END IF C MFOF = IDUM + 1 MPHI = IDUM + Size + 1 MGRADN = IDUM + 1 MSDXB = 3*NATREF + MGRADN MHESS = 3*NATREF + MSDXB C C---- ATSORT dimensions now C MBB = IDUM + 1 MMB = MBB + NATST MXB = MMB + NATST MIA = 2*NATST + MXB MZZOCB = 2*NATST + MIA MIRESB = MZZOCB + NATST C C---- if LrefineCycFlag ge.0 ie refinement C open fobs fcal and phi files to channels 19 20 2 C IF (LSFcalcFlag.EQ.1 .OR.LSFrefFlag.EQ.1) THEN C C---- Write hessian onto channel 15 during First cycle C IF (LSFrefFlag.EQ.1) THEN CALL QOPEN(IOhessian,'HESS','SCRATCH') CALL QMODE(IOhessian,2,NumBytesItem) CALL QOPEN(IOshifts,'SHIFTS','SCRATCH') CALL QMODE(IOshifts,2,NumBytesItem) END IF C IF (LSFmodeFlag.EQ.1 .OR. LSFmodeFlag.EQ.2) THEN CALL QOPEN(IOgradmat,'GRADMAT','UNKNOWN') CALL QMODE(IOgradmat,2,NumBytesItem) END IF END IF C C ******************************* CALL REFCTL(X(MFOF), + X(MPHI), + Size, + NATST, + NATREF, + X(MGRADN), + X(MSDXB), + X(MHESS), + NATST2, + X(MBB), + X(MMB), + X(MXB), + X(MIA), + X(MZZOCB), + X(MIRESB)) C ******************************* C RETURN C END C C ================ SUBROUTINE KEYIN C ================ C C---- Read in the control data C C---- E map density modification parameters - C set up for Cecil Tate common /eden/Escale,cmp,cmn C C---- Truncate input map - used for "Wanging" C common /trunc/ TruncMapMin,TruncMapMax C C .. Parameters .. INTEGER MaxSymmetry PARAMETER (MaxSymmetry=192) INTEGER MaxFormFactors PARAMETER (MaxFormFactors=20) INTEGER MaxNumChains PARAMETER (MaxNumChains=20) INTEGER NPARS PARAMETER (NPARS=200) INTEGER NKEYS PARAMETER (NKEYS=31) INTEGER MCOLS PARAMETER (MCOLS=200) INTEGER MSETS PARAMETER (MSETS=MCOLS) INTEGER NSFSG PARAMETER (NSFSG=16) C .. C .. Scalars in Common .. REAL A6NAP2,A6NAP3,AA1,AverageBfactor,BfactFpart,BfactorMax, + BfactorMin,BfactOverall,BfactReset,BfactStartStepSize,Bsmear, + BulkWaterSF,CMN,CMP,Escale,GR1,GR3NA2,RatioShiftTrunc, + RHmax,RHmean,RHmin,RmsBfactor,RmsDelta,RmsXyz,ScaleFcalc, + ScaleFpart,SFrepeatValue,SigmaExclude,Smax,Smin, + SquAtmRadLimit,SSbinSize,TH,TruncMapMax,TruncMapMin, + TruncNewMax,TruncNewMin,TSmax,TSmin,VolMtz,W,WangSphereRadi, + XyzStartStepSize INTEGER IOatomop,IOgradmat,IOhessian,IOmap,IOscratch, + IOshifts,IOxyzin,IOxyzoutunq,IXmax,IXmin,IYmax, + IYmin,IZmax,IZmin,Jsec,JU1,JU2,JV1,JV2,Ksec,KU1,KU2,KV1, + KV2,LatomMapFlag,LBfactRefFlag,LcheckSFspaceGrpFlag, + LFpartFlag,LFreeRexcludeVal,LSFrefFlag,LhklInputFlag, + LMapInFlag,LPhiPartFlag,LSFcalcFlag,LSFmodeFlag, + LSolvMaskFlag,LWghtModeFlag,LxyzInputFlag,LXyzOutputFlag, + Msec,NLPRGO,LrefineCycFlag,NtotalRefsUsed, + NumAtmRefined,NumChains,NumFormFactors,NumMultiplicity, + NumPlanes,NumSections,NumSFspaceGroup,NumSFsymm, + NumSpaceGroup,NumSymmetry,NumZeroOccAtms,NX,NY,NZ LOGICAL LNoScaleFlag,LverboseFlag CHARACTER Title*80 C .. C .. Arrays in Common .. REAL AtmBoxLowLim,AtmBoxUpLim,CellMtz,ExtBoxLowLim,ExtBoxUpLim, + ExtraPlanes,FormFactAcoeff,FormFactBcoeff,PermutRecipSymm, + PlanesLimits,RealSymmMatrx,SpecialPlaneLimit, + RecipSymmMatrx,FormFactAcoeffSum INTEGER Iuvw,IuvwMP,KatmWghts,LookUp,LSymmFlags,NumFirstResChn, + NumGaussPerAtmTyp,NumLastResChn,NumResPerChn,Nxyz CHARACTER ChainLabels*1,ElementNames*4 C .. C .. Local Scalars .. REAL ACHK,BB,CF,DLM,GridSize,ResMax,ResMin,SCAL, + SMN,SMX,VAL_MAGIC,VolumePdb INTEGER I,IALL,LAppnd,IATM,IB,ICOL,IELEC,Ifail,IFMFC,II, + IKEY0,IKEY1,ILmax,ILPRGI,ILPRGO,IPrintFlag,IRES, + IRESTR,ISMTZ,ISSF,Isum,ITOK,ITOK0,IWT,IXYZ, + IXYZB,J,JCOL,JSSF,LorthogCode,MapMode, + MapSpaceGroup,IDO635,JDO635,ISTOP, + MTZIN,MTZOUT,NCHAR,NCOL,NREF,NGauss,NLPRGI,NTOK,ILOK, + NumLaueSymm,NumPrimSymm,NumSFlaueSymm,NumSFprimSymm,NXMIN, + NYmin,NZmin LOGICAL IFILFF,Lend,LPrintFlag,SETVAL,Lsort CHARACTER Ltype*1,ATID*4,KEY*4,LaueGroupName*10, + SFpointGroupName*10,PointGroupName*10, + SFspaceGrpName*10,SpaceGroupName*10, + SaveLabels*600,LINE*600,VERSNX*10 C .. C .. Local Arrays .. REAL AF(4),BF(4),CEL(6),CellMap(6),CellPdb(6),CU(2), + FVALUE(NPARS),MO(2),RRR(3,3,6),SFsymmMatrx(4,4,MaxSymmetry), + XyzLimits(2,3),RANGES(2,MCOLS) INTEGER IBEG(NPARS),IDEC(NPARS),IEND(NPARS),ITYPE(NPARS), + SFSGFLG(NSFSG),SFSGS(NSFSG),ISORT(5) CHARACTER CTPRGI(MCOLS)*1,CTPRGO(MCOLS)*1,CTYPS(MCOLS)*1, + CVALUE(NPARS)*4,KEYWRD(NKEYS)*4,CLABS(MCOLS)*30, + LSPRGI(MCOLS)*30,LSPRGO(MCOLS)*30,LSUSRJ(MCOLS)*30 C C----Harvesting stuff C INTEGER NDATASETS,ISETS(MSETS),ISET,CSETID(MCOLS),CSETOUT(MCOLS), + SETID REAL DATCELL(6,MSETS),DATWAVE(MSETS) CHARACTER*20 PNAME(MSETS),DNAME(MSETS), + PNAME_OUT(MCOLS),DNAME_OUT(MCOLS) C .. C .. External Functions .. INTEGER LENSTR EXTERNAL LENSTR C .. C .. External Subroutines .. EXTERNAL CCPERR,CCPUPC,CENTRIC,EPSLN,GTPINT,GTPREA,LKYIN, + LKYOUT,LKYSET,LRASSN,LRCELL,LRCLAB,LROPEN,LRRSOL,LRSYMI, + LRSYMM,LWASSN,LWCELL,LWOPEN,LWSYMM,MRDHDR,PARSER,PGDEFN, + PGNLAU,RBFRAC2,RBFRO1,RDCELL,RDRESO,RDSCAL,RDSYMM, + SETGRD,SETLIM,SET_MAGIC,SFREAD2,LWHSTL,XYZOPEN C .. C .. Intrinsic Functions .. INTRINSIC ABS,NINT,SQRT C .. C .. Common blocks .. COMMON /ATMLIM/ + ExtBoxLowLim(3),ExtBoxUpLim(3), + SquAtmRadLimit,NumPlanes, + ExtraPlanes(3,6),PlanesLimits(6), + SpecialPlaneLimit(6), + AtmBoxLowLim(3),AtmBoxUpLim(3), + NumAtmRefined,NumZeroOccAtms COMMON /ATSYM/ + NumSymmetry,NumSpaceGroup, + RealSymmMatrx(4,4,MaxSymmetry), + RecipSymmMatrx(4,4,MaxSymmetry), + PermutRecipSymm(4,4), + LSymmFlags(MaxSymmetry) COMMON /BFACTS/ + AverageBfactor, + BfactorMin, + BfactorMax, + Bsmear, + BfactReset COMMON /CHAIN/ + NumChains, + NumFirstResChn(MaxNumChains), + NumLastResChn(MaxNumChains), + NumResPerChn(MaxNumChains) COMMON /CHNCH/ + ChainLabels(MaxNumChains) COMMON /EDEN/ + Escale,CMP,CMN COMMON /FORM1/ + BulkWaterSF,NumFormFactors, + NumGaussPerAtmTyp(MaxFormFactors), + KatmWghts(MaxFormFactors), + FormFactAcoeff(5,MaxFormFactors), + FormFactBcoeff(5,MaxFormFactors), + FormFactAcoeffSum(MaxFormFactors) COMMON /FORM2/ + ElementNames(MaxFormFactors) COMMON /IOSF/ + IOscratch,IOgradmat,IOhessian,IOshifts, + IOatomop,IOmap,IOxyzin,IOxyzoutunq COMMON /KH/ + RmsDelta,AA1,A6NAP2,A6NAP3,GR1,GR3NA2 COMMON /MAPCHK/ + IuvwMP(3),Nxyz(3), + KU1,KU2,KV1,KV2, + Ksec,Msec COMMON /MPHDR/ + NX,NY,NZ, + IXmin,IXmax,IYmin,IYmax,IZmin,IZmax, + Jsec,JU1,JU2,JV1,JV2,Iuvw(3), + NumSFspaceGroup,NumSections, + RHmin,RHmax,RHmean,NumSFsymm, + CellMtz(6),VolMtz,Volfft,F000 COMMON /MPHDRR/ + Title COMMON /MTZOP/ + Mlook,LookUp(MCOLS) COMMON /SFOUT/ + Smin,Smax,TSmin,TSmax,SSbinSize, + LFpartFlag,LPhiPartFlag,LWghtModeFlag, + ScaleFcalc,ScaleFpart, + SigmaExclude,WangSphereRadi, + BfactOverall,BfactFpart, + NumMultiplicity,NLPRGO COMMON /SRFCTL/ + NtotalRefsUsed, + RatioShiftTrunc,W,TH, + LSFmodeFlag,LrefineCycFlag,LBfactRefFlag, + LcheckSFspaceGrpFlag,LFreeRexcludeVal, + XyzStartStepSize,BfactStartStepSize, + SFrepeatValue, + RmsXyz,RmsBfactor COMMON /SRFCTL1/ + LSFcalcFlag,LSFrefFlag, + LatomMapFlag,LxyzInputFlag, + LhklInputFlag,LMapInFlag, + LSolvMaskFlag,LXyzOutputFlag COMMON /TERSE/ + LverboseFlag,LNoScaleFlag COMMON /TRUNC/ + TruncMapMin,TruncMapMax, + TruncNewMin,TruncNewMax C .. C .. Data statements .. DATA NLPRGI,LSPRGI/29,'H','K','L','FP','SIGFP','FREE', + 'FPART','PHIP','F0','F1','F2','F3','F4','F5','F6','F7','F8', + 'F9','F10','F11','F12','F13','F14','F15','F16','F17','F18', + 'F19','FC',171*' '/ DATA CTPRGI/'H','H','H','F','Q','I','F','P',192*' '/ DATA LSPRGO/'H','K','L','FP','SIGFP','FREE','FPART','PHIP', + 'F0','F1','F2','F3','F4','F5','F6','F7','F8','F9','F10', + 'F11','F12','F13','F14','F15','F16','F17','F18','F19','FC', + 'PHIC','WANGWT',169*' '/ DATA CTPRGO/'H','H','H','F','Q','I','F','P',' ',' ',' ',' ',' ', + ' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ', + 'F','P','W',169*' '/ DATA KEYWRD/'TITL','GRID','CELL','RESO','VDWR','SCAL','WEIG', + 'OMIT','BADD','RSCB','MODE','STEP','SIGM','SYMM', + 'H2OB','END ','FORM','RATI','FREE','TRUN','AVMO', + 'NOSC','EDEN','CHAI','LABI','LABO','SFSG','RMSS', + 'BRES','BINS','VERB'/ DATA RANGES/MCOLS*0.0,MCOLS*0.0/ DATA SFSGS/1,4,1018,19,91,92,95,96,143,144,145,146,152,154, + 169,170/ DATA SFSGFLG/1,2,3,4,5,5,5,5,7,6,6,7,8,8,9,9/ C .. C C LPrintFlag = .FALSE. LNoScaleFlag = .FALSE. LverboseFlag = .FALSE. Title = ' A run of SFALL ' SaveLabels = ' ' IFILFF = .TRUE. NumSymmetry = 0 NumPrimSymm = 0 NumMultiplicity = 1 NumSpaceGroup = 0 NX = 0 GridSize = 0.45 NumPlanes = 0 XyzStartStepSize = 0.0 BfactStartStepSize = 0.0 SFrepeatValue = 0.0 C C---- Message flags - set to zero for normal running. C set some defaults C for k-h Matrix C AA1 = 0 A6NAP2 = 0 GR1 = 0 GR3NA2 = 0 C C---- for rwbrook C LorthogCode = 1 C C---- general defaults C Volfft = 0.0 F000 = 0.0 BulkWaterSF = 0 SquAtmRadLimit = 6.25 Smin = 0.00000001 Smn = 0.00000001 Smax = 1.0 ResMax = 1.0/SQRT(Smin) ResMin = 1.0/SQRT(Smax) LWghtModeFlag = 0 C C---- Default scaling to 4.5A out... C TSmin = 0.05 TSmax = 1 SigmaExclude = -1 W = 0 TH = 1000 ScaleFcalc = 1 BfactOverall = 0 ScaleFpart = 1 BfactFpart = 0 NumMultiplicity = 1 SSbinSize = 20 RatioShiftTrunc = 3 RmsXyz = 0.0 RmsBfactor = 0.0 IOunique = 0 C C---- Set formfactors to default to 2 gaussian limit for H C N O S C may be altered with keyword FORM C NGauss = 2 C DO 5 IFMFC = 1,5 NumGaussPerAtmTyp(IFMFC) = 2 IF (IFMFC.EQ.1) ATID = 'H ' IF (IFMFC.EQ.2) ATID = 'C ' IF (IFMFC.EQ.3) ATID = 'N ' IF (IFMFC.EQ.4) ATID = 'O ' IF (IFMFC.EQ.5) ATID = 'S ' C C ************************* CALL SFREAD2(ATID, + 2, + AF, + BF, + CF, + IWT, + IELEC, + CU, + MO, + Ifail) C ************************* C C ***************************************** IF (Ifail.EQ.-1) + CALL CCPERR(1,' No match for atom label(KEYIN1)') C ***************************************** C C KatmWghts(IFMFC) = IWT KatmWghts(IFMFC) = IFMFC FormFactAcoeff(1,IFMFC) = AF(1) FormFactAcoeff(2,IFMFC) = AF(2) FormFactAcoeff(3,IFMFC) = AF(3) FormFactAcoeff(4,IFMFC) = AF(4) FormFactBcoeff(1,IFMFC) = BF(1) FormFactBcoeff(2,IFMFC) = BF(2) FormFactBcoeff(3,IFMFC) = BF(3) FormFactBcoeff(4,IFMFC) = BF(4) FormFactAcoeff(5,IFMFC) = CF FormFactAcoeffSum(IFMFC)= + AF(1) + AF(2) + AF(3) + AF(4) + CF ElementNames(IFMFC) = ATID(1:4) 5 CONTINUE C NumFormFactors = 5 C C---- You must set the SF space group. C LFreeRexcludeVal = -999 NumSFspaceGroup = 0 NumChains = 0 Isum = 0 CEL(1) = 0 C 10 CONTINUE LINE = ' ' KEY = ' ' NTOK = NPARS C C ************************************************************* CALL PARSER(KEY,LINE,IBEG,IEND,ITYPE,FVALUE,CVALUE,IDEC,NTOK,Lend, + .TRUE.) C ************************************************************* C C---- End of file? C IF (Lend) GO TO 480 C C---- Loop over possible key-words C DO 20 I = 1,NKEYS IF (KEY.EQ.KEYWRD(I)) GO TO 30 20 CONTINUE C GO TO 440 C 30 CONTINUE C C 'TITL','GRID','CELL','RESO','VDWR','SCAL','WEIG', C 'OMIT','BADD','RSCB','MODE','STEP','SIGM','SYMM', C 'H2OB','END ','FORM','RATI','FREE','TRUN','AVMO', C 'NOSC','EDEN','CHAI','LABI','LABO','SFSG','RMSS', C 'BRES','BINS','VERB'/ C GO TO ( 50, 250, 60, 70, 90, 100, 110, + 120, 130, 150, 160, 230, 240, 260, + 280, 480, 300, 330, 340, 350, 360, + 370, 380, 390, 410, 430, 270, 400, + 140, 80, 40) I C C---- LverboseFlag C ======= C 40 CONTINUE LverboseFlag = .TRUE. GO TO 10 C C---- Title C ===== C 50 CONTINUE ITOK = IEND(NTOK) IF (ITOK.GT.80)ITOK = 80 IF (ITOK.GT.IEND(2)) Title = LINE(IBEG(2) :IEND(NTOK)) GO TO 10 C C---- CELL C ===== C 60 CONTINUE ITOK = 2 C C ********************************** CALL RDCELL(ITOK,ITYPE,FVALUE,NTOK,CEL) C ********************************** C CellMtz(1) = CEL(1) CellMtz(2) = CEL(2) CellMtz(3) = CEL(3) CellMtz(4) = CEL(4) CellMtz(5) = CEL(5) CellMtz(6) = CEL(6) C C ************************************************************* CALL RBFRAC2(CEL(1),CEL(2),CEL(3),CEL(4),CEL(5),CEL(6), + LorthogCode) CALL RBFRO1(CellMtz,VolMtz,RRR) C ************************************************************* C GO TO 10 C C---- RESOLUTION C ========== C 70 CONTINUE C C---- read resolution limits in A, if only one treat as high C resolution limit C ITOK = 2 C C ******************* CALL RDRESO(ITOK, + ITYPE, + FVALUE, + NTOK, + ResMin, + ResMax, + Smin, + Smax) C ******************* C SMN = Smin GO TO 10 C C---- BINS C ==== C 80 CONTINUE C C---- read number of bins for resolution - C width v 4si**2/l**2 = 1/nbin resolution limit C C ************************************* CALL GTPREA(2,SSbinSize,NTOK,ITYPE,FVALUE) C ************************************* C GO TO 10 C C---- VDWR - The maximum (vdw radius) of atoms C ====== C 90 CONTINUE C C ****************************************** CALL GTPREA(2,SquAtmRadLimit,NTOK,ITYPE,FVALUE) C ****************************************** C IF (SquAtmRadLimit.GT.3.0) THEN WRITE(6,'(a)') + ' Van der Waal radii of atoms must be less than 3A' SquAtmRadLimit = 3.0 END IF C SquAtmRadLimit = SquAtmRadLimit*SquAtmRadLimit GO TO 10 C C---- SCALE FC or FPART or MAP C ========================= C 100 CONTINUE KEY = LINE(IBEG(2):IBEG(2)+3) CALL CCPUPC(KEY) C IF (KEY(1:3) .EQ. 'MAP' ) THEN CALL GTPREA(3,Volfft,NTOK,ITYPE,FVALUE) IF (NTOK.GT.3)CALL GTPREA(4,F000,NTOK,ITYPE,FVALUE) GO TO 10 END IF C ITOK = 2 C C *********************** CALL RDSCAL(ITOK, + LINE, + IBEG, + IEND, + ITYPE, + FVALUE, + NTOK, + NLPRGI, + LSPRGI, + ILPRGI, + SCAL, + BB) C *********************** C IF (LSPRGI(ILPRGI).EQ.'FC') THEN ScaleFcalc = SCAL BfactOverall = BB END IF C IF (LSPRGI(ILPRGI).EQ.'FPART') THEN ScaleFpart = SCAL BfactFpart = BB END IF C IF (LSPRGI(ILPRGI).EQ.'MAP') THEN ScaleFcalc = SCAL BfactOverall = BB END IF C GO TO 10 C C---- WEIGHT C ====== C 110 CONTINUE C C ***************************** CALL GTPREA(2,W,NTOK,ITYPE,FVALUE) C ***************************** C GO TO 10 C C---- OMIT C ==== C 120 CONTINUE C C ****************************** CALL GTPREA(2,TH,NTOK,ITYPE,FVALUE) C ****************************** C GO TO 10 C C---- BADD C ==== C 130 CONTINUE C C ******************************** CALL GTPREA(2,Bsmear,NTOK,ITYPE,FVALUE) C ******************************** C GO TO 10 C C---- BRESET C ==== C 140 CONTINUE C C ********************************** CALL GTPREA(2,BfactReset,NTOK,ITYPE,FVALUE) C ********************************** C GO TO 10 C C---- RSCB - Resolution limits for initial scale C ==== and b-overall refinement C 150 CONTINUE C C---- read resolution limits in A, if only one treat as high C resolution limit C ITOK = 2 C C ******************** CALL RDRESO(ITOK, + ITYPE, + FVALUE, + NTOK, + ResMin, + ResMax, + TSmin, + TSmax) C ******************** C GO TO 10 C C---- MODE - (0,1 OR 2,3+ for unrestrained refinement, C ==== -1 for mapinput, -2..) C 160 CONTINUE C C set various flags C LSFcalcFlag - Structure factor calculation C LSFrefFlag - Structure factor refinement C LatomMapFlag - Atom map generated C LSolvMaskFlag - Solvent map generated C LXyzOutputFlag - cordinates used for SFCALC output C in fft asymmetric unit. C Assign XYZOUT. C LSFmodeFlag = -999 LSFcalcFlag = 0 LSFrefFlag = 0 LatomMapFlag = 0 LSolvMaskFlag = 0 LXyzOutputFlag = 0 C C---- Possible inputs C LxyzInputFlag = 0 LMapInFlag = 0 LhklInputFlag = 0 C C---- number defining mode C IF (ITYPE(2).EQ.2) THEN C C *************************************** CALL GTPINT(2,LSFmodeFlag,NTOK,ITYPE,FVALUE) C *************************************** C GO TO 10 END IF C C Subsibuary key word sfcalc or sfref or atmmap C Subsibuary key words sfcalc xyzin hklin = mode = 0 C Subsibuary key words sfcalc mapin hklin = mode = -1 C Subsibuary key words sfcalc xyzin = mode = -2 C Subsibuary key words sfcalc mapin = mode = -3 C C ************ CALL CCPUPC(LINE) C ************ C KEY = LINE(IBEG(2) :IBEG(2)+3) IF (KEY.EQ.'SFCA') GO TO 170 IF (KEY.EQ.'SFRE') GO TO 190 IF (KEY.EQ.'ATMM') GO TO 210 C C ****************************************** CALL CCPERR(1,' Wrong key word after mode '// KEY) C ****************************************** C 170 CONTINUE C LSFcalcFlag = 1 C DO 180 ITOK = 3,NTOK IKEY0 = IBEG(ITOK) IKEY1 = IBEG(ITOK) + 3 IF (IEND(ITOK).LT.IKEY1) IKEY1 = IEND(ITOK) KEY = LINE(IKEY0:IKEY1) C IF (KEY.EQ.'XYZI') THEN LxyzInputFlag = 1 GO TO 180 END IF C IF (KEY.EQ.'MAPI')THEN LMapInFlag = 1 GO TO 180 END IF C IF (KEY.EQ.'HKLI')THEN LhklInputFlag = 1 GO TO 180 END IF C IF (KEY.EQ.'ATMM') THEN LxyzInputFlag = 1 LatomMapFlag = 1 GO TO 180 END IF C IF (KEY.EQ.'SOLV')THEN LSolvMaskFlag = 1 LxyzInputFlag = 1 GO TO 180 END IF C C---- Output coordinates within fft asymmetric unit. C IF (KEY.EQ.'XYZU')THEN LXyzOutputFlag = 1 GO TO 180 END IF C C ****************************************** CALL CCPERR(1,'Wrong key word after SFCALC: '//KEY) C ****************************************** C 180 CONTINUE C C Key words sfcalc xyzin hklin = mode = 0 C Key words sfcalc mapin hklin = mode = -1 C Key words sfcalc xyzin = mode = -2 C Key words sfcalc mapin = mode = -3 C IF (LSolvMaskFlag.EQ.1) BulkWaterSF = 0.03 IF (LxyzInputFlag.EQ.1 .AND. LMapInFlag.EQ.1) + CALL CCPERR(1,' You cannot have XYZIN and MAPIN together!!') IF (LxyzInputFlag.EQ.1 .AND. + LhklInputFlag.EQ.1) LSFmodeFlag = 0 IF (LMapInFlag.EQ.1 .AND. + LhklInputFlag.EQ.1) LSFmodeFlag = -1 IF (LxyzInputFlag.EQ.1 .AND. + LhklInputFlag.EQ.0) LSFmodeFlag = -2 IF (LMapInFlag.EQ.1 .AND. + LhklInputFlag.EQ.0) LSFmodeFlag = -3 GO TO 10 C C Key words sfref xyz restrained = mode = 1 C Key words sfref xyzb restrained = mode = 2 C Key words sfref xyz unrestrained = mode = 3 C Key words sfref b unrestrained = mode = 4 C Key words sfref xyzb unrestrained = mode = 5 C 190 CONTINUE C C ************ CALL CCPUPC(LINE) C ************ C LSFrefFlag = 1 LhklInputFlag = 1 LxyzInputFlag = 1 IXYZ = 0 IXYZB = 0 IB = 0 IRESTR = 0 C DO 200 ITOK = 3,NTOK IKEY0 = IBEG(ITOK) IKEY1 = IBEG(ITOK) + 3 IF (IEND(ITOK).LT.IKEY1) IKEY1 = IEND(ITOK) KEY = LINE(IKEY0:IKEY1) C IF (KEY.EQ.'XYZ') THEN IXYZ = 1 GO TO 200 END IF C IF (KEY.EQ.'XYZB') THEN IXYZB = 1 GO TO 200 END IF C IF (KEY.EQ.'B') THEN IB = 1 GO TO 200 END IF C IF (KEY.EQ.'REST')THEN IRESTR = 1 GO TO 200 END IF C IF (KEY.EQ.'UNRE')THEN IRESTR = 0 GO TO 200 END IF C IF (KEY .EQ. 'MAPI') THEN LMapInFlag = 1 GO TO 200 END IF C C ****************************************** CALL CCPERR(1,'Wrong key word after SFREF: '//KEY) C ****************************************** C 200 CONTINUE C C Key words sfref xyz restrained(MAPIN) = mode = 1 C Key words sfref xyzb restrained(MAPIN) = mode = 2 C Key words sfref xyz unrestrained = mode = 3 C Key words sfref b unrestrained = mode = 4 C Key words sfref xyzb unrestrained = mode = 5 C IF (IXYZ.EQ.1 .AND. IRESTR.EQ.1) LSFmodeFlag = 1 IF (IXYZB.EQ.1 .AND. IRESTR.EQ.1) LSFmodeFlag = 2 IF (IXYZ.EQ.1 .AND. IRESTR.EQ.0) LSFmodeFlag = 3 IF (IB.EQ.1 .AND. IRESTR.EQ.0) LSFmodeFlag = 4 IF (IXYZB.EQ.1 .AND. IRESTR.EQ.0) LSFmodeFlag = 5 GO TO 10 C C Key words atmmap = mode = -4 C Key words atmmap resmod = mode = -5 C Key words atmmap atmmod = mode = -6 C 210 CONTINUE C C ************ CALL CCPUPC(LINE) C ************ C LatomMapFlag = 1 LxyzInputFlag = 1 IRES = 0 IATM = 0 LSFmodeFlag = -4 C IF (NTOK.GE.2) THEN DO 220 ITOK = 3,NTOK IKEY0 = IBEG(ITOK) IKEY1 = IBEG(ITOK) + 3 IF (IEND(ITOK).LT.IKEY1) IKEY1 = IEND(ITOK) KEY = LINE(IKEY0:IKEY1) C IF (KEY.EQ.'RESM') THEN IRES = 1 GO TO 220 END IF C IF (KEY.EQ.'ATMM') THEN IATM = 1 GO TO 220 END IF C IF (KEY.EQ.'SOLV') THEN LSolvMaskFlag = 1 GO TO 220 END IF C C ****************************************** CALL CCPERR(1,'Wrong key word after ATMMAP: '//KEY) C ****************************************** C 220 CONTINUE END IF C IF (LSolvMaskFlag.EQ.1) BulkWaterSF = 0.03 IF (IRES.EQ.1) LSFmodeFlag = -5 IF (IATM.EQ.1) LSFmodeFlag = -6 GO TO 10 C C---- STEP C ==== C C StepSize for xyz- and b-refinement C Fraction to recalculate shifts C 230 CONTINUE C C *********************************************** CALL GTPREA(2,XyzStartStepSize,NTOK,ITYPE,FVALUE) CALL GTPREA(3,BfactStartStepSize,NTOK,ITYPE,FVALUE) CALL GTPREA(4,SFrepeatValue,NTOK,ITYPE,FVALUE) C *********************************************** C GO TO 10 C C---- SIGMA C ===== C 240 CONTINUE C C **************************************** CALL GTPREA(2,SigmaExclude,NTOK,ITYPE,FVALUE) C **************************************** C GO TO 10 C C---- GRID - Number of divisions along each whole unit CELL edge C ==== C 250 CONTINUE C C ****************************** CALL GTPINT(2,NX,NTOK,ITYPE,FVALUE) CALL GTPINT(3,NY,NTOK,ITYPE,FVALUE) CALL GTPINT(4,NZ,NTOK,ITYPE,FVALUE) C ****************************** C GO TO 10 C C---- SYMM C ==== C 260 CONTINUE ITOK = 2 C C ********************************* CALL RDSYMM(ITOK, + LINE, + IBEG, + IEND, + ITYPE, + FVALUE, + NTOK, + SpaceGroupName, + NumSpaceGroup, + PointGroupName, + NumSymmetry, + NumPrimSymm, + RealSymmMatrx) CALL PGDEFN(PointGroupName, + NumPrimSymm, + NumSymmetry, + RealSymmMatrx, + LPrintFlag) CALL PGNLAU(PointGroupName, + NumLaueSymm, + LaueGroupName) C ********************************* C NumMultiplicity = NumSymmetry/NumPrimSymm C C---- KDC Now set up the extinction check for soutfC C *********************** CALL EPSLN(NumSymmetry, + NumPrimSymm, + RealSymmMatrx, + .TRUE.) CALL CENTRIC(NumSymmetry, + RealSymmMatrx, + .TRUE.) C *********************** C C---- KDC Done setup C NumMultiplicity = NumSymmetry/NumPrimSymm GO TO 10 C C---- NumSFspaceGroup -number of the space group to run SFS in C 270 CONTINUE ITOK = 2 C C ******************************** CALL RDSYMM(ITOK, + LINE, + IBEG, + IEND, + ITYPE, + FVALUE, + NTOK, + SFspaceGrpName, + NumSFspaceGroup, + SFpointGroupName, + NumSFsymm, + NumSFprimSymm, + SFsymmMatrx) CALL PGDEFN(SFpointGroupName, + NumSFprimSymm, + NumSFsymm, + SFsymmMatrx, + LPrintFlag) CALL PGNLAU(SFpointGroupName, + NumSFlaueSymm, + LaueGroupName) C ******************************** C C---- check sg is available - C LcheckSFspaceGrpFlag is Kcounter... C LcheckSFspaceGrpFlag = 0 DO 275 I=1,NSFSG IF (NumSFspaceGroup .EQ. SFSGS(I)) + LcheckSFspaceGrpFlag = SFSGFLG(I) 275 CONTINUE C IF (LcheckSFspaceGrpFlag.EQ.0) THEN WRITE (6,*) 'SFSG is ', NumSFspaceGroup CALL CCPERR(1, ' *** You can''t use this spacegroup ***') END IF C GO TO 10 C C---- BulkWaterSF C ===== C 280 CONTINUE C C *************************************** CALL GTPREA(2,BulkWaterSF,NTOK,ITYPE,FVALUE) C *************************************** C GO TO 10 C C---- FORM - Additional form factors C ==== C 300 CONTINUE C C---- NGauss not set - default to 2 and set default formfactors C ITOK0 = 2 KEY = LINE(IBEG(2):(IBEG(2)+3)) CALL CCPUPC(KEY) C IF (KEY.EQ.'NEUT') THEN NGauss = 1 ITOK0 = ITOK0 + 1 END IF C C---- or is it NGauss. C IF (KEY.EQ.'NGAU') THEN ITOK0 = ITOK0 + 1 C C ************************************** CALL GTPINT(ITOK0,NGauss,NTOK,ITYPE,FVALUE) C ************************************** C ITOK0 = ITOK0 + 1 C C---- Only NGauss = 2 or 5 is valid C IF (NGauss .NE. 2 .AND. NGauss .NE. 5) THEN WRITE (6, FMT='(A)') $ ' **** Invalid NGauss - reset to 5 ****' NGauss = 5 ENDIF END IF C C---- First read ATOMSF C ( either atomsf.lib or atomsf_neutron.lib) to get C formfactors for basic list H C N O S . NGauss = 2 default C IF (NGauss.NE.2) THEN C DO 315 ITOK = 1,5 NumFormFactors = ITOK NumGaussPerAtmTyp(NumFormFactors) = NGauss IF (ITOK.EQ.1) ATID = 'H ' IF (ITOK.EQ.2) ATID = 'C ' IF (ITOK.EQ.3) ATID = 'N ' IF (ITOK.EQ.4) ATID = 'O ' IF (ITOK.EQ.5) ATID = 'S ' C C ************************* CALL SFREAD2(ATID, + NGauss, + AF, + BF, + CF, + IWT, + IELEC, + CU, + MO, + Ifail) C ************************* C C ***************************************** IF (Ifail.EQ.-1) + CALL CCPERR(1,' No match for atom label(KEYIN2)') C ***************************************** C C KatmWghts(NumFormFactors) = IWT KatmWghts(NumFormFactors) = NumFormFactors FormFactAcoeff(1,NumFormFactors) = AF(1) FormFactAcoeff(2,NumFormFactors) = AF(2) FormFactAcoeff(3,NumFormFactors) = AF(3) FormFactAcoeff(4,NumFormFactors) = AF(4) FormFactBcoeff(1,NumFormFactors) = BF(1) FormFactBcoeff(2,NumFormFactors) = BF(2) FormFactBcoeff(3,NumFormFactors) = BF(3) FormFactBcoeff(4,NumFormFactors) = BF(4) FormFactAcoeff(5,NumFormFactors) = CF FormFactAcoeffSum(NumFormFactors)= + AF(1) + AF(2) + AF(3) + AF(4) + CF ElementNames(NumFormFactors) = ATID(1:4) 315 CONTINUE END IF C IF (ITOK0.GT.NTOK ) GO TO 10 C C---- assume it is followed by a list of atom types C DO 320 ITOK = ITOK0,NTOK NumFormFactors = NumFormFactors + 1 IF (NumFormFactors.GT.MaxFormFactors) GO TO 460 NCHAR = IEND(ITOK) - IBEG(ITOK) + 1 IF (NCHAR.GE.4) ATID = LINE(IBEG(ITOK) :IBEG(ITOK)+3) IF (NCHAR.LT.4) ATID = LINE(IBEG(ITOK) :IEND(ITOK))//' ' C C ************************* CALL SFREAD2(ATID, + 5, + AF, + BF, + CF, + IWT, + IELEC, + CU, + MO, + Ifail) C ************************* C C ***************************************** IF (Ifail.EQ.-1) + CALL CCPERR(1,' No match for atom label(KEYIN3)') C ***************************************** C C KatmWghts(NumFormFactors) = IWT KatmWghts(NumFormFactors) = NumFormFactors NumGaussPerAtmTyp(NumFormFactors) = 5 FormFactAcoeff(1,NumFormFactors) = AF(1) FormFactAcoeff(2,NumFormFactors) = AF(2) FormFactAcoeff(3,NumFormFactors) = AF(3) FormFactAcoeff(4,NumFormFactors) = AF(4) FormFactBcoeff(1,NumFormFactors) = BF(1) FormFactBcoeff(2,NumFormFactors) = BF(2) FormFactBcoeff(3,NumFormFactors) = BF(3) FormFactBcoeff(4,NumFormFactors) = BF(4) FormFactAcoeff(5,NumFormFactors) = CF FormFactAcoeffSum(NumFormFactors) = + AF(1) + AF(2) + AF(3) + AF(4) + CF ElementNames(NumFormFactors) = ATID(1:4) 320 CONTINUE C GO TO 10 C C---- RATIO Card - shifts truncated to < ratio*rms shift C ===== C 330 CONTINUE C C ******************************************* CALL GTPREA(2,RatioShiftTrunc,NTOK,ITYPE,FVALUE) C ******************************************* C GO TO 10 C C---- Free R factor - Value in table to exclude. C ===== C 340 CONTINUE C CALL GTPREA(2,ACHK,NTOK,ITYPE,FVALUE) IF(ACHK.LT. 0.99 .AND. ACHK .GT. 0.001) CALL CCPERR + (1,' *** This FreeR option withdrawn - See documentation ***') CALL GTPINT(2,LFreeRexcludeVal,NTOK,ITYPE,FVALUE) GO TO 10 C C---- TRUNCATE Card - C ======== C C input map truncated to values bettween C TruncMapMin and TruncMapMax C Used instead of TRUNCATE for WANG / ANDREW Leslie C solvent flattening. C 350 CONTINUE C C *************************************** CALL GTPREA(2,TruncMapMin,NTOK,ITYPE,FVALUE) CALL GTPREA(3,TruncMapMax,NTOK,ITYPE,FVALUE) C *************************************** C TruncNewMin = TruncMapMin TruncNewMax = TruncMapMax C C *************************************** IF (NTOK.GT.3 ) CALL GTPREA(4,TruncNewMin,NTOK,ITYPE,FVALUE) IF (NTOK.GT.4 ) CALL GTPREA(5,TruncNewMax,NTOK,ITYPE,FVALUE) C *************************************** C GO TO 10 C C---- AVMOde Card - C ========= C C Fc weighted as in HKLWEIGHT.for C Used instead of HKLWEIGHT for WANG / ANDREW Leslie C solvent flattening. C 360 CONTINUE ITOK = 2 361 CONTINUE IF (ITOK .GE. NTOK ) GO TO 10 KEY = LINE(IBEG(ITOK):(IBEG(ITOK)+3)) CALL CCPUPC(KEY) C IF (KEY.EQ.'WEIG') THEN CALL GTPINT(ITOK+1,LWghtModeFlag,NTOK,ITYPE,FVALUE) ITOK = ITOK + 2 IF (LWghtModeFlag.EQ.1) WRITE (6,FMT=6008) 6008 FORMAT (/,' Using 1-r/R Weighting function') IF (LWghtModeFlag.EQ.2) WRITE (6,FMT=6010) 6010 FORMAT (/,' Using 1-(r/R)**2 Weighting function') GO TO 361 END IF C IF (KEY.EQ.'RADI') THEN CALL GTPREA(ITOK+1,WangSphereRadi,NTOK,ITYPE,FVALUE) ITOK = ITOK + 2 WRITE (6,FMT=6006) WangSphereRadi 6006 FORMAT (//,' Sphere Radius =',F5.1,' Angstroms') GO TO 361 END IF C C---- LNoScaleFlagE - C ==== C C set LNoScaleFlagE flag. C 370 CONTINUE LNoScaleFlag = .TRUE. WRITE(6,*) ' Outputting uNscaled file - assigned to FFTHKLSCR' GO TO 10 C C---- E DENSITY MODIFICATION - read Escale cmp cmn C ====================== C 380 CONTINUE C C ******************************** CALL GTPREA(2,Escale,NTOK,ITYPE,FVALUE) CALL GTPREA(3,CMP,NTOK,ITYPE,FVALUE) CALL GTPREA(4,CMN,NTOK,ITYPE,FVALUE) C ******************************** C GO TO 10 C C---- CHAIN definition cards C ====================== C C Read chain label - First residue number and last residue number C C Check chain label is next on line ie alphanumeric type(1) C 390 CONTINUE NumChains = NumChains + 1 IF (NumChains.GT.MaxNumChains) GO TO 462 ChainLabels(NumChains) = LINE(IBEG(2) :IEND(2)) C C ***************************************************** CALL GTPINT(3,NumFirstResChn(NumChains),NTOK,ITYPE,FVALUE) CALL GTPINT(4,NumLastResChn(NumChains),NTOK,ITYPE,FVALUE) C ***************************************************** C NumResPerChn(NumChains) = Isum Isum = Isum - NumFirstResChn(NumChains) + 1 + + NumLastResChn(NumChains) GO TO 10 C C---- RMSShift C ===== C C Read RMS shift for XYZ and B - C useful to define sensible step Size for UNRESTRAINED refinemnt. C Default is RmsXyz = 0 RmsBfactor = 0 - C used as flag to prevent this option. C Form of line RMSSHIFT XYZ 0.3 B 10.0 C 400 CONTINUE C C ************ CALL CCPUPC(LINE) C ************ C KEY = LINE(IBEG(2) :IBEG(2)) CALL GTPREA(3,ACHK,NTOK,ITYPE,FVALUE) IF (KEY(1:1).EQ.'X') RmsXyz = ACHK IF (KEY(1:1).EQ.'B') RmsBfactor = ACHK C IF (NTOK.GT.3) THEN KEY = LINE(IBEG(4) :IBEG(4)) CALL GTPREA(5,ACHK,NTOK,ITYPE,FVALUE) IF (KEY(1:1).EQ.'X') RmsXyz = ACHK IF (KEY(1:1).EQ.'B') RmsBfactor = ACHK END IF C C---- Set SFrepeatValue large enough to avoid a second sf calculation.. C SFrepeatValue = 1000 GO TO 10 C C---- "LABI" i.e. set input labels C 410 CONTINUE C C---- How many assigned? C Must have First labels h k l FP SIGP C C ***************************************** CALL LKYIN(1,LSPRGI,NLPRGI,NTOK,LINE,IBEG,IEND) C ***************************************** C ITOK = 2 C C ******************** CALL LKYSET(LSPRGI, + NLPRGI, + LSUSRJ, + LookUp, + ITOK, + NTOK, + LINE, + IBEG, + IEND) C ******************** C ILmax = 5 ILPRGO = 5 LFpartFlag = 0 LPhiPartFlag = 0 C C---- Is FreeRFlag set C IF (LookUp(6).NE.0) THEN C---- Is LFreeRexcludeVal set, if not set it = 0 C IF (LFreeRexcludeVal .eq.-999) LFreeRexcludeVal = 0 ILPRGO = ILPRGO + 1 ILmax = ILmax + 1 END IF C C---- Are FPART PHIPART set C IF (LookUp(7).NE.0) THEN LFpartFlag = ILPRGO +1 LPhiPartFlag = ILPRGO +2 ILPRGO = ILPRGO + 2 ILmax = ILmax + 2 END IF C C---- Are F0 F1 .. set C DO 420 ILPRGI = 9,NLPRGI IF (LookUp(ILPRGI).NE.0) THEN ILmax = ILPRGI ILPRGO = ILPRGO + 1 END IF 420 CONTINUE GO TO 10 C C---- LABO - C 430 CONTINUE C C---- see whether second argument = 'ALLIN' C IALL = 0 KEY = LINE(IBEG(2):(IBEG(2)+2)) CALL CCPUPC(KEY) C IF (KEY(1:3) .EQ.'ALL') THEN IALL = 1 C C---- Clear keyword ALL... C LINE(IBEG(2):IEND(2)) = ' ' C END IF C SaveLabels = LINE GO TO 10 C 440 CONTINUE C C ******************************************************* CALL CCPERR(1, 'Unrecognised keyword: '//LINE(IBEG(1):IEND(1))) C ******************************************************* C C---- Too many formfactors requested C 460 WRITE (6,FMT=6004) MaxFormFactors 6004 FORMAT ( +' Program only dimensioned for ',I4,' Formfactors ',/, +' Change dimensions of PARAMETER MaxFormFactors') 462 WRITE (6,FMT=6014) MaxNumChains 6014 FORMAT ( +' Program only dimensioned for ',I4,' Chains ',/, +' Change dimensions of PARAMETER MaxNumChains ') C C ************************ CALL CCPERR(1,'Hard failure') C ************************ C C----END C ======== C 480 CONTINUE C C---- Close ATOMSF - if it has been opened.. C IF (.NOT.IFILFF) CLOSE(UNIT=45) IF (LMapInFlag.EQ.1 .AND. LSFcalcFlag .EQ. 1) + LNoScaleFlag = .TRUE. IF (LMapInFlag.EQ.1 .AND. LSFcalcFlag .EQ.1 ) WRITE(6,*) + ' Outputting uNscaled HKL file - standard for Map input.' C MTZIN = 1 MTZOUT = 2 C C If mode equals -1 0 1 2 3 4 hklin opened. C If mode equals -3 -2 -1 0 hklout opened. C Check FILES C C---- open the input reflection file C IF (LSFmodeFlag.EQ.-999) + CALL CCPERR(1,' What are you doing!! Check MODE line') C IF (LhklInputFlag.EQ.1) THEN IPrintFlag = 1 C C ********************************** CALL LROPEN(MTZIN,'HKLIN',IPrintFlag,Ifail) IF (Ifail.EQ.1) CALL CCPERR(1,' No input file???????') CALL LRASSN(MTZIN,LSPRGI,NLPRGI,LookUp,CTPRGI) CALL LRIDC(MTZIN,PNAME,DNAME,ISETS,DATCELL,DATWAVE,NDATASETS) C---- Get dataset ID for column and match to dataset header info. IF (NDATASETS.GT.0) + CALL LRCLID(MTZIN,CSETID,NCOL) C ***************************************** C--- Count number of assignments and store in NLPRGO - not used for C--- refinement but a useful counter. It will be overwritten in many cases Mlook = 0 DO 485 II = 1,MCOLS IF(LOOKUP(II).NE.0) THEN Mlook = Mlook + 1 ILPRGI = II END IF 485 CONTINUE NLPRGI = ILPRGI C C Check H K L limits are compatible with SFSG CALL LRINFO(MTZIN,VERSNX,NCOL,NREF,RANGES) C C C---- Then call lrcell etc... C C ********************* CALL LRCELL(MTZIN,CellMtz) CALL LRSORT(MTZIN,ISORT) C ********************* C---- Find Real crystal volume. C C ************************** CALL RBFRO1(CellMtz,VolMtz,RRR) C ************************** C C---- check cell C IF (CEL(1).NE.0.0) THEN ACHK=0.0 C DO 490 II = 1,6 ACHK = ABS(CellMtz(II)-CEL(II))/ + (CellMtz(II)+CEL(II)) + ACHK IF (ACHK.GT.0.02) CALL CCPERR(1, + ' Large Difference in CELL DIMENSIONS') IF (ACHK.GT.0.01) WRITE (6, + FMT=*) ' Small Difference in CELL DIMENSION' 490 CONTINUE END IF C C---- check sort order: should be H K L C Lsort = .FALSE. DO 491 II = 1,3 IF (ISORT(II).NE.II) Lsort = .TRUE. 491 CONTINUE IF (Lsort) THEN CALL CCPERR (2, + 'Reflections not sorted as H slow, K medium, L fast') WRITE(6,FMT=*) ' SFALL may fail or give unreliable output', + ' later on.' WRITE(6,FMT=*) END IF C C---- Read symmetry and check C C ********************************************** CALL LRSYMI(MTZIN, + NumPrimSymm, + Ltype, + NumSpaceGroup, + SpaceGroupName, + PointGroupName) CALL LRSYMM(MTZIN, + NumSymmetry, + RealSymmMatrx) CALL PGDEFN(PointGroupName, + NumPrimSymm, + NumSymmetry, + RealSymmMatrx, + LPrintFlag) CALL PGNLAU(PointGroupName, + NumLaueSymm, + LaueGroupName) C NumMultiplicity = NumSymmetry/NumPrimSymm C C---- KDC Now set up the extinction check for soutfC CALL EPSLN(NumSymmetry, + NumPrimSymm, + RealSymmMatrx, + .TRUE.) C C---- KDC Done setup C CALL CENTRIC(NumSymmetry, + RealSymmMatrx, + .TRUE.) C C---- Read resolution limits if not set previously C CALL LRRSOL(MTZIN,SMN,SMX) C IF (Smn.LE.0.000001) Smn = 0.000001 IF (Smin.LE.0.000001) Smin = SMN IF (Smax.GE.SMX) Smax = SMX ResMax = 1.0/SQRT(Smin) ResMin = 1.0/SQRT(Smax) C C---- Set scaling maximum back to data maximum resolution. C IF (Smax.LE.TSmax) TSmax = Smax C C---- Make sure there is some data to scale!! C IF (TSmin.GE.TSmax) TSmin = Smin END IF C IF (LSFmodeFlag.EQ.-5) THEN write(6,*) ' resolution limits cannot be got from map/brk files' IF (Smin .LE. 0.0001) Smin = 0.05 write(6,*) ' Using current Smin/Smax of ',Smin,Smax ENDIF C C---- Check symmetry consistent for NumSFspaceGroup and MTZSPG C IF (NumSFspaceGroup.EQ.0) THEN C---- Find NumSFspaceGroup -- number of the space group to run SFS in C CALL CHKSYM(NumSpaceGroup,NumPrimSymm,NumSFspaceGroup, + RealSymmMatrx,NSFSG,SFSGS) CALL MSYGET(49,NumSFspaceGroup,NumSFsymm,SFsymmMatrx) CALL PGDEFN(SFpointGroupName, NumSFprimSymm, NumSFsymm, + SFsymmMatrx, LPrintFlag) CALL PGNLAU(SFpointGroupName, NumSFlaueSymm, LaueGroupName) C C---- check sg is available - C LcheckSFspaceGrpFlag is Kcounter... C LcheckSFspaceGrpFlag = 0 DO 495 I=1,NSFSG IF (NumSFspaceGroup .EQ. SFSGS(I)) + LcheckSFspaceGrpFlag = SFSGFLG(I) 495 CONTINUE C IF (LcheckSFspaceGrpFlag.EQ.0) THEN WRITE (6,*) 'SFSG is ', NumSFspaceGroup CALL CCPERR(1, ' *** You can''t use this spacegroup ***') END IF END IF C Check HKL range ( L usually > 0) for low symmetry spacegroups. IF ( LcheckSFspaceGrpFlag .LE.5 ) THEN IF(RANGES(1,3) .LT.0 ) WRITE(6,'(a,3(4x,2F4.0))') + ' Input file has H K L ranges',(RANGES(1,I),RANGES(2,I),I=1,3) IF(RANGES(1,3) .LT.0 ) THEN LINE = ' ** Your hkl data must be resorted with l>= 0' LINE = LINE(1:LENSTR(LINE))// + ' to fit this spacegroup - See documentation***' CALL CCPERR(1,LINE) ENDIF END IF C C---- Set default resolution limits if not done already C IF ( (LSFcalcFlag.EQ.1 .OR. + LSFrefFlag.EQ.1) .AND. + Smax.GE.0.99) THEN ResMax = 1.0/SQRT(Smin) ResMin = 1.0/SQRT(Smax) END IF C C---- If you are calculating sfs - C do it for ALL data to upper limit. C IF (LSFcalcFlag.EQ.1) Smin=SMN IF (LSFcalcFlag.EQ.1) ResMax = 1.0/SQRT(Smin) IF (LSFcalcFlag.EQ.1) ResMin = 1.0/SQRT(Smax) c--- C GridSize default is 0.45; reduce this for very high resolution. IF(GRIDSIZE.GT.RESMIN/3.0) GRIDSIZE = RESMIN/3.0 C IF (NumSpaceGroup.NE.0) THEN DO 530 ISSF = 1,NumSFsymm JSSF = 0 DO 520 ISMTZ = 1,NumSymmetry IF (LSymmFlags(ISMTZ).NE.0) GO TO 520 LSymmFlags(ISMTZ) = 0 DO 510 J = 1,4 DO 500 I = 1,4 ACHK = ABS(SFsymmMatrx(I,J,ISSF) - + RealSymmMatrx(I,J,ISMTZ)) IF (ACHK.GT.0.01) GO TO 520 500 CONTINUE 510 CONTINUE C JSSF = 1 LSymmFlags(ISMTZ) = 1 520 CONTINUE C IF (JSSF.EQ.0) THEN WRITE (6, FMT= + '(''*** No match to sf sym op '', I3,'' in MTZ file'')') ISSF CALL CCPERR(1, + 'SFSG is inappropriate for your data''s spacegroup') ENDIF 530 CONTINUE END IF C C---- Find grid etc if it has not been given for XYZIN C IF (LxyzInputFlag .NE. 0) THEN C C---- First open input coordinate file C Ifail = 0 IOxyzin = 0 C C ****************************************** CALL XYZOPEN('XYZIN','INPUT',' ',IOxyzin,IFAIL) C ****************************************** C C---- find Matrix CELL etC C IF (LXyzOutputFlag.NE.0)THEN Ifail = 0 IXYZOUTUNQ = 0 CALL XYZOPEN('XYZOUTUNQ','OUTPUT',' ',IXYZOUTUNQ,IFAIL) END IF VolumePdb = 0.0 CellPdb(1) = 0.0 C C ***************************** CALL RBFRO1(CellPdb,VolumePdb,RRR) C ***************************** C C C---- check cell C IF (CellMtz(1).GE.0.00001) THEN ACHK = 0.00 DO 540 II = 1,6 ACHK = ABS(CellMtz(II)-CellPdb(II))/ + (CellMtz(II)+CellPdb(II)) + ACHK IF (ACHK.GT.0.03) CALL CCPERR(1, + ' Large Difference in CELL DIMENSIONS') IF (ACHK.GT.0.01) WRITE (6, + FMT=*) ' Small Difference in CELL DIMENSION' 540 CONTINUE ELSE DO 545 I = 1,6 CellMtz(I) = CellPdb(I) 545 CONTINUE C C ************************** CALL RBFRO1(CellMtz,VolMtz,RRR) C ************************** C END IF C IF (NX .EQ. 0) THEN NXmin = NINT(CellMtz(1)/GridSize ) NYmin = NINT(CellMtz(2)/GridSize ) NZmin = NINT(CellMtz(3)/GridSize ) C C **************************************************** CALL SETGRD(NumSFlaueSymm,1.0,NXmin,NYmin,NZmin,NX,NY,NZ) C **************************************************** C END IF END IF C C---- MAPIN. Only possible if LxyzInputFlag = 0 C IF (LMapInFlag .NE. 0) THEN IOmap = 1 C C ******************************** CALL MRDHDR(IOmap, + 'MAPIN', + Title, + NumSections, + IuvwMP, + Nxyz, + Jsec, + JU1, + JU2, + JV1, + JV2, + CellMap, + MapSpaceGroup, + MapMode, + RHmin, + RHmax, + RHmean, + RmsDelta) C ******************************** C KU1 = JU1 KU2 = JU2 KV1 = JV1 KV2 = JV2 Ksec = Jsec Msec = NumSections RmsDelta = 0.0 C C---- check cell C IF (CellMtz(1).GE.0.00001) THEN ACHK = 0.00 DO 550 II = 1,6 ACHK = ABS(CellMtz(II)-CellMap(II))/ + (CellMtz(II)+CellMap(II)) + ACHK IF (ACHK.GT.0.03) CALL CCPERR(1, + ' Large Difference in CELL DIMENSIONS') IF (ACHK.GT.0.01) WRITE (6, + FMT=*) ' Small Difference in CELL DIMENSION' 550 CONTINUE C ELSE C DO 555 I = 1,6 CellMtz(I) = CellMap(I) 555 CONTINUE C C ************************** CALL RBFRO1(CellMtz,VolMtz,RRR) C ************************** C END IF C C---- Check map information agrees with that set C in sgtest for this spacegroup. C If no symmetry set - try to pick up MAP symmetry. C ( No hklin either..) C IF (NumSpaceGroup .EQ.0) THEN NumSpaceGroup = MapSpaceGroup C C---- Set up dummy line containing SYMM MapSpaceGroup C WRITE(LINE,'(A,3x,I5)')'SYMM' ,MapSpaceGroup C C ************************************************************* CALL PARSER(KEY,LINE,IBEG,IEND,ITYPE,FVALUE,CVALUE,IDEC,NTOK,Lend, + .TRUE.) C ************************************************************* C ITOK = 2 C CALL RDSYMM(ITOK, + LINE, + IBEG, + IEND, + ITYPE, + FVALUE, + NTOK, + SpaceGroupName, + NumSpaceGroup, + PointGroupName, + NumSymmetry, + NumPrimSymm, + RealSymmMatrx) CALL PGDEFN(PointGroupName, + NumPrimSymm, + NumSymmetry, + RealSymmMatrx, + LPrintFlag) CALL PGNLAU(PointGroupName, + NumLaueSymm, + LaueGroupName) C NumMultiplicity = NumSymmetry/NumPrimSymm C C---- KDC Now set up the extinction check for soutfC CALL EPSLN(NumSymmetry, + NumPrimSymm, + RealSymmMatrx, + .TRUE.) CALL CENTRIC(NumSymmetry, + RealSymmMatrx, + .TRUE.) C C---- KDC Done setup C NumMultiplicity = NumSymmetry/NumPrimSymm END IF C C---- If no sfspgrp set - try to pick up MAP spacegroup. C ( No hklin either..) C IF (NumSFspaceGroup .EQ.0) THEN NumSFspaceGroup = MapSpaceGroup C C---- Set up dummy line containing SFSG MapSpaceGroup C WRITE(LINE,'(A,3x,I5)')'SFSG' ,MapSpaceGroup C C ************************************************************* CALL PARSER(KEY,LINE,IBEG,IEND,ITYPE,FVALUE,CVALUE,IDEC,NTOK,Lend, + .TRUE.) C ************************************************************* C ITOK = 2 C CALL RDSYMM(ITOK, + LINE, + IBEG, + IEND, + ITYPE, + FVALUE, + NTOK, + SpaceGroupName, + NumSFspaceGroup, + SFpointGroupName, + NumSFsymm, + NumSFprimSymm, + SFsymmMatrx) C ********************************************************** C C---- check sg has refinement available - C LcheckSFspaceGrpFlag is Kcounter... C LcheckSFspaceGrpFlag = 0 DO 560 I=1,NSFSG IF (NumSFspaceGroup .EQ. SFSGS(I)) + LcheckSFspaceGrpFlag = SFSGFLG(I) 560 CONTINUE C C ********************************** IF (LcheckSFspaceGrpFlag.EQ.0) CALL CCPERR(1, + ' *** You are unable to refine this Spacegroup!! ***') C ********************************** C END IF C IF (MapSpaceGroup .NE. NumSFspaceGroup) + WRITE (6,FMT='(///,A,A)') + ' *** WARNING - your map spacegroup is ', + 'different to the program default one ***' IF (NX.EQ.0) NX = Nxyz(1) IF (NY.EQ.0) NY = Nxyz(2) IF (NZ.EQ.0) NZ = Nxyz(3) END IF C IF (NX .EQ. 0) THEN NXmin = NINT(CellMtz(1)/GridSize ) NYmin = NINT(CellMtz(2)/GridSize ) NZmin = NINT(CellMtz(3)/GridSize ) C C ******************** CALL SETGRD(NumSFlaueSymm, + 1.0, + NXmin, + NYmin, + NZmin, + NX, + NY, + NZ) C ******************** C END IF C C ********************** CALL SETLIM(NumSFspaceGroup, + XyzLimits) C ********************** C IXmin = NX*XyzLimits(1,1) IXmax = NX*XyzLimits(2,1) IYmin = NY*XyzLimits(1,2) IYmax = NY*XyzLimits(2,2) IZmin = NZ*XyzLimits(1,3) IZmax = NZ*XyzLimits(2,3) C C---- Set atom limits C DLM = SQRT(SquAtmRadLimit) ExtBoxLowLim(1) = 0.0 AtmBoxLowLim(1) = DLM/CellMtz(1) ExtBoxLowLim(2) = 0.0 AtmBoxLowLim(2) = DLM/CellMtz(2) ExtBoxLowLim(3) = 0.0 AtmBoxLowLim(3) = DLM/CellMtz(3) C IF (IXmax+1 .EQ. NX) XyzLimits(2,1) = 1.0 ExtBoxLowLim(1) = XyzLimits(1,1) - DLM/CellMtz(1) AtmBoxLowLim(1) = XyzLimits(1,1) + DLM/CellMtz(1) ExtBoxUpLim(1) = XyzLimits(2,1) + DLM/CellMtz(1) AtmBoxUpLim(1) = XyzLimits(2,1) - DLM/CellMtz(1) C IF (IYmax+1 .EQ. NY) XyzLimits(2,2) = 1.0 ExtBoxLowLim(2) = XyzLimits(1,2) - DLM/CellMtz(2) AtmBoxLowLim(2) = XyzLimits(1,2) + DLM/CellMtz(2) ExtBoxUpLim(2) = XyzLimits(2,2) + DLM/CellMtz(2) AtmBoxUpLim(2) = XyzLimits(2,2) - DLM/CellMtz(2) C IF (IZmax+1 .EQ. NZ) XyzLimits(2,3) = 1.0 ExtBoxLowLim(3) = XyzLimits(1,3) - DLM/CellMtz(3) AtmBoxLowLim(3) = XyzLimits(1,3) + DLM/CellMtz(3) ExtBoxUpLim(3) = XyzLimits(2,3) + DLM/CellMtz(3) AtmBoxUpLim(3) = XyzLimits(2,3) - DLM/CellMtz(3) C IF (LSFcalcFlag.EQ.1) THEN C C Open output file here and fill in LSPRG . C C---- The output file maybe should contain columns C from the input file, and some extra ones C C Possible outputs C h k l FP SIGP (FreeRFlag) F0 F1 .. FC PHIC C or h k l FP SIGP (FreeRFlag) FPART APART F0 F1 ... FC PHIC C or h k l FP SIGP (FreeRFlag) FPART APART F0 F1 ... FC PHIC WANGWT C or h k l FC PHIC C or h k l FC PHIC WANGWT C LAppnd = 0 C IF (LhklInputFlag.EQ.0) THEN C C---- You want to output h k l s fc ac or h k l s fc ac wangwt C ILPRGO = 3 C C---- NLPRGO = number of output labels C Some of these will be needed- find out correct number. C LSPRGO(4) = LSPRGO(29) LSPRGO(5) = LSPRGO(30) CTPRGO(4) = CTPRGO(29) CTPRGO(5) = CTPRGO(30) ILPRGO = ILPRGO + 2 C IF (LWghtModeFlag.GT.0) THEN LSPRGO(6) = LSPRGO(31) CTPRGO(6) = CTPRGO(31) ILPRGO = ILPRGO + 1 END IF C NLPRGO = ILPRGO END IF C C---- If HKLIN assigned, write a FFTHKLSCR which will C be scaled in R3PI and transcribed to HKLOUT after C scales applied. C IF (LhklInputFlag .NE.0) THEN C C ****************************** CALL LRCLAB(MTZIN,CLABS,CTYPS,NCOL) C ****************************** C C---- Copy over FP SIGFP information C LSPRGO(4) = CLABS(LookUp(4)) LSPRGO(5) = CLABS(LookUp(5)) CTPRGO(4) = CTYPS(LookUp(4)) CTPRGO(5) = CTYPS(LookUp(5)) IF (NDATASETS.GT.0) THEN CSETOUT(1) = CSETID(LookUp(1)) CSETOUT(2) = CSETID(LookUp(2)) CSETOUT(3) = CSETID(LookUp(3)) CSETOUT(4) = CSETID(LookUp(4)) CSETOUT(5) = CSETID(LookUp(5)) ENDIF C ILPRGO = 5 LFpartFlag = 0 LPhiPartFlag = 0 C C---- Are FreeRFlag set C IF (LookUp(6).NE.0) THEN LSPRGO(6) = CLABS(LookUp(6)) CTPRGO(6) = CTYPS(LookUp(6)) IF (NDATASETS.GT.0) THEN CSETOUT(6) = CSETID(LookUp(6)) ENDIF ILPRGO = ILPRGO + 1 END IF C C---- Are FPART PHIPART set C IF (LookUp(7).NE.0) THEN LSPRGO(ILPRGO+1) = CLABS(LookUp(7)) LSPRGO(ILPRGO+2) = CLABS(LookUp(8)) CTPRGO(ILPRGO+1) = CTYPS(LookUp(7)) CTPRGO(ILPRGO+2) = CTYPS(LookUp(8)) IF (NDATASETS.GT.0) THEN CSETOUT(ILPRGO+1) = CSETID(LookUp(7)) CSETOUT(ILPRGO+2) = CSETID(LookUp(8)) ENDIF LFpartFlag = ILPRGO + 1 LPhiPartFlag = ILPRGO + 2 ILPRGO = ILPRGO + 2 END IF C C---- Are F0 F1 .. set C IF (NLPRGI .GE.9) THEN DO 620 ILPRGI = 9,NLPRGI IF (LookUp(ILPRGI).NE.0) THEN ILPRGO = ILPRGO + 1 LSPRGO(ILPRGO) = CLABS(LookUp(ILPRGI)) CTPRGO(ILPRGO) = CTYPS(LookUp(ILPRGI)) IF (NDATASETS.GT.0) THEN CSETOUT(ILPRGO) = CSETID(LookUp(ILPRGI)) ENDIF END IF 620 CONTINUE END IF C IF (IALL.NE.1) THEN C C---- Add on FC PHIC labels C LSPRGO(ILPRGO+1) = LSPRGO(29) LSPRGO(ILPRGO+2) = LSPRGO(30) CTPRGO(ILPRGO+1) = CTPRGO(29) CTPRGO(ILPRGO+2) = CTPRGO(30) IF (NDATASETS.GT.0) THEN CSETOUT(ILPRGO+1) = CSETID(LookUp(4)) CSETOUT(ILPRGO+2) = CSETID(LookUp(4)) ENDIF ILPRGO = ILPRGO + 2 C IF (LWghtModeFlag.GT.0) THEN LSPRGO(ILPRGO+1) = LSPRGO(31) CTPRGO(ILPRGO+1) = CTPRGO(31) IF (NDATASETS.GT.0) THEN CSETOUT(ILPRGO+1) = CSETID(LookUp(4)) ENDIF ILPRGO = ILPRGO + 1 END IF C NLPRGO = ILPRGO GO TO 640 END IF C C---- Is IALL set - ie all input to output? C IF (IALL.EQ.1) THEN C C---- Add on FC PHIC labels to NCOL + .. C oops - a problem when there are 29+ columns. C Use CLABS 1-3 and LSUSRJ 1-3 for temporary storage. C CLABS(1) = LSPRGO(29) CLABS(2) = LSPRGO(30) C LSUSRJ(1) = CTPRGO(29) LSUSRJ(2) = CTPRGO(30) C NLPRGO = NCOL + 2 C C IF (LWghtModeFlag.GT.0) THEN CLABS(3) = LSPRGO(31) LSUSRJ(3) = CTPRGO(31) NLPRGO = NLPRGO + 1 END IF LSPRGO(NCOL+1) = CLABS(1) LSPRGO(NCOL+2) = CLABS(2) LSPRGO(NCOL+3) = CLABS(3) CTPRGO(NCOL+1) = LSUSRJ(1)(1:1) CTPRGO(NCOL+2) = LSUSRJ(2)(1:1) CTPRGO(NCOL+3) = LSUSRJ(3)(1:1) IF (NDATASETS.GT.0) THEN CSETOUT(NCOL+1) = CSETID(LookUp(4)) CSETOUT(NCOL+2) = CSETID(LookUp(4)) CSETOUT(NCOL+3) = CSETID(LookUp(4)) ENDIF C C---- Copy all unassigned columns to OUTPUT. C ILOK = NLPRGI IF (ILOK.LE.8) ILOK = 9 DO 630 ICOL = 4,NCOL IOUT = 0 DO 631 JCOL = 4,NLPRGI IF (LookUp(JCOL) .EQ.ICOL) IOUT = 1 631 CONTINUE C IF (IOUT .EQ.1) GO TO 630 ILOK = ILOK + 1 ILPRGO = ILPRGO + 1 LookUp(ILOK) = ICOL LSPRGO(ILPRGO) = CLABS(ICOL) CTPRGO(ILPRGO) = CTYPS(ICOL) IF (NDATASETS.GT.0) THEN CSETOUT(ILPRGO) = CSETID(ICOL) ENDIF 630 CONTINUE C IF (ILPRGO .NE. NCOL) + CALL CCPERR(1,' Something wrong in the column assignments') Mlook = ILPRGO NLPRGI = ILPRGO C C---- Have another go at LRASSN to pick up all other columns. C Maybe not necessary? C END IF C C 640 CONTINUE ISTOP=0 DO 635 IDO635=1,NLPRGO DO 635 JDO635=IDO635+1,NLPRGO IF(LSPRGO(IDO635).EQ.LSPRGO(JDO635))THEN WRITE(6,1001)' Warning: this may fail!', + LSPRGO(JDO635)(1:10) ISTOP=1 ENDIF 635 CONTINUE 1001 FORMAT(/,A, + /,' This column label ',A10,' is also a program label') C IF(ISTOP.EQ.1) C + CALL CCPERR(0,' Warning: this may fail!') C C---- You want to output h k l s fc ac or h k l s fc ac wangwt C END IF C IF (SaveLabels.NE.' ') THEN LINE = SaveLabels NTOK = NPARS C C ************************ CALL PARSER(KEY, + LINE, + IBEG, + IEND, + ITYPE, + FVALUE, + CVALUE, + IDEC, + NTOK, + Lend, + .TRUE.) CALL LKYOUT(MTZOUT, + LSPRGO, + NLPRGO, + NTOK, + LINE, + IBEG, + IEND) C ************************ C END IF C C---- If no HKLIN, output HKLOUT directly C IF (LhklInputFlag .EQ.0) THEN CALL LWOPEN(MTZOUT,'HKLOUT') CALL LWASSN(MTZOUT,LSPRGO,NLPRGO,CTPRGO,LAppnd) CALL LWCELL(MTZOUT,CellMtz) CALL LWHSTL (MTZOUT, ' ') CALL LWTITL (MTZOUT, TITLE, 0) ISORT(1) = 1 ISORT(2) = 2 ISORT(3) = 3 ISORT(4) = 0 ISORT(5) = 0 CALL LWSORT(MTZOUT,ISORT) C IF (NumSpaceGroup.GT.0) THEN Ltype = SpaceGroupName(1:1) C CALL LWSYMM(MTZOUT, + NumSymmetry, + NumPrimSymm, + RealSymmMatrx, + Ltype, + NumSpaceGroup, + SpaceGroupName, + PointGroupName) ELSE Ltype = SFspaceGrpName(1:1) CALL LWSYMM(MTZOUT, + NumSFsymm, + NumSFprimSymm, + SFsymmMatrx, + Ltype, + NumSFspaceGroup, + SFspaceGrpName, + PointGroupName) END IF C C---- For non primitive spacegroups we only need to consider C primitive symmetry operators for Stucture factor calculation. C NumMultiplicity has already been set. C C This is not true for"special" R3.. C IF (LSFcalcFlag.EQ.1 + .AND. NumSFspaceGroup.NE.146) NumSymmetry = NumPrimSymm IF (NumSFspaceGroup.EQ.146) NumMultiplicity = 1 C RETURN END IF C C---- HKLIN present... C CALL LWOPEN(MTZOUT,'FFTHKLSCR') C C---- Must write out cell and symm etc since MTZOUT Ne MTZIN C CALL LWCELL(MTZOUT,CellMtz) CALL LWSORT(MTZOUT,ISORT) Ltype = SpaceGroupName(1:1) C C ****************************** CALL LWSYMM(MTZOUT, + NumSymmetry, + NumPrimSymm, + RealSymmMatrx, + Ltype, + NumSpaceGroup, + SpaceGroupName, + PointGroupName) CALL LWASSN(MTZOUT, + LSPRGO, + NLPRGO, + CTPRGO, + LAppnd) C Store the project name and dataset name in the mtz header: DO 286 ISET = 1,NDATASETS CALL LWIDC(MTZOUT,PNAME(ISET),DNAME(ISET), + DATCELL(1,ISET),DATWAVE(ISET)) 286 CONTINUE IF (NDATASETS.GT.0) THEN DO 115 JDO115 = 1,NLPRGO SETID = CSETOUT(JDO115) DO ISET = 1,NDATASETS IF (ISETS(ISET).EQ.SETID) THEN PNAME_OUT(JDO115) = PNAME(ISET) DNAME_OUT(JDO115) = DNAME(ISET) END IF ENDDO 115 CONTINUE CALL LWIDAS(MTZOUT,NLPRGO,PNAME_OUT,DNAME_OUT,LAppnd) ENDIF C ****************************** C C---- Also must ensure that the missing number flag is consistant C IF (LhklInputFlag .EQ. 1) THEN SETVAL = .FALSE. C C ********************************** CALL SET_MAGIC(MTZIN,VAL_MAGIC,SETVAL) CALL SET_MAGIC(MTZOUT,VAL_MAGIC,SETVAL) C ********************************** C ENDIF END IF C C---- For non primitive spacegroups we only need to consider C primitive symmetry operators for Stucture factor calculation. C NumMultiplicity has already been set. C C This is not true for"special" R3.. C IF ((LSFcalcFlag.EQ.1 .OR.LSFrefFlag.EQ.1) + .AND. NumSFspaceGroup.NE.146) NumSymmetry = NumPrimSymm IF (NumSFspaceGroup.EQ.146) NumMultiplicity = 1 C RETURN C 9999 CALL CCPERR(1,' Problem with XYZIN') C C---- EOF (Lend = .true.) C END C C ========================================= SUBROUTINE AHVSOR(IA,KEYS,ITEM,ILIM,IDIM) C ========================================= C C .. Scalar Arguments .. INTEGER IDIM,ILIM,ITEM,KEYS C .. C .. Array Arguments .. INTEGER IA(IDIM) C .. C .. Local Scalars .. INTEGER BOTTOM,CHUNK,CUT,CUTOFF,DOWN,HIGH, + I,IHM1,IP1,ITEMP,KKmin, + LOW,M,MIDDLE,MPL1,N,STACK,TOP,UP C .. C .. Local Arrays .. INTEGER IP(10),SAVEIT(2,16) C .. C .. External Subroutines .. EXTERNAL CCPERR C .. C .. Data statements .. DATA CUTOFF/20/ C .. C IF (ITEM.GT.10) WRITE (6,FMT=6000) ITEM 6000 FORMAT ( + ' Problem in AHVSOR - sorts <=10 items - here item= ',I5) IF (ITEM.GT.10) CALL CCPERR(1,' Too many items for sort') C DO 10 I = 1,ITEM IP(I) = (I-1)*ILIM 10 CONTINUE C STACK = 0 LOW = 1 HIGH = KEYS 20 CONTINUE CHUNK = HIGH - LOW C IF (CHUNK.GT.CUTOFF) THEN MIDDLE = (LOW+HIGH)/2 C IF (IA(LOW).GT.IA(MIDDLE)) THEN DO 30 I = 1,ITEM IP1 = IP(I) ITEMP = IA(LOW+IP1) IA(LOW+IP1) = IA(MIDDLE+IP1) IA(MIDDLE+IP1) = ITEMP 30 CONTINUE END IF C IF (IA(MIDDLE).GT.IA(HIGH)) THEN DO 40 I = 1,ITEM IP1 = IP(I) ITEMP = IA(MIDDLE+IP1) IA(MIDDLE+IP1) = IA(HIGH+IP1) IA(HIGH+IP1) = ITEMP 40 CONTINUE IF (IA(LOW).GT.IA(MIDDLE)) THEN DO 50 I = 1,ITEM IP1 = IP(I) ITEMP = IA(LOW+IP1) IA(LOW+IP1) = IA(MIDDLE+IP1) IA(MIDDLE+IP1) = ITEMP 50 CONTINUE END IF END IF CUT = IA(MIDDLE) UP = LOW DOWN = HIGH 60 CONTINUE DOWN = DOWN - 1 IF (CUT.LT.IA(DOWN)) THEN GO TO 60 ELSE 70 CONTINUE UP = UP + 1 IF (CUT.GT.IA(UP)) GO TO 70 IF ((UP-DOWN).NE.0) THEN IF ((UP-DOWN).GT.0) THEN GO TO 90 ELSE DO 80 I = 1,ITEM IP1 = IP(I) ITEMP = IA(UP+IP1) IA(UP+IP1) = IA(DOWN+IP1) IA(DOWN+IP1) = ITEMP 80 CONTINUE GO TO 60 END IF END IF END IF DOWN = DOWN - 1 UP = UP + 1 90 STACK = STACK + 1 BOTTOM = DOWN - LOW TOP = HIGH - UP IF (BOTTOM.GT.TOP) THEN SAVEIT(1,STACK) = LOW SAVEIT(2,STACK) = DOWN LOW = UP ELSE SAVEIT(1,STACK) = UP SAVEIT(2,STACK) = HIGH HIGH = DOWN END IF GO TO 20 ELSE IF (CHUNK.GE.2) THEN IHM1 = HIGH - 1 DO 120 M = LOW,IHM1 KKmin = M MPL1 = M + 1 DO 100 N = MPL1,HIGH IF (IA(KKmin).GT.IA(N)) KKmin = N 100 CONTINUE IF (KKmin.NE.M) THEN DO 110 I = 1,ITEM IP1 = IP(I) ITEMP = IA(M+IP1) IA(M+IP1) = IA(KKmin+IP1) IA(KKmin+IP1) = ITEMP 110 CONTINUE END IF 120 CONTINUE END IF IF (STACK.NE.0) THEN LOW = SAVEIT(1,STACK) HIGH = SAVEIT(2,STACK) STACK = STACK - 1 GO TO 20 END IF END IF C END C C ===================================================== SUBROUTINE ATSORT(NAT,NAT2,BB,MB,XB,IA,AtomicNumOccup, + IRESB,SZA,BfactOverall) C ===================================================== C C .. Parameters .. INTEGER MaxFormFactors PARAMETER (MaxFormFactors=20) INTEGER MaxNumChains PARAMETER (MaxNumChains=20) INTEGER MaxSymmetry PARAMETER (MaxSymmetry=192) C .. C .. Scalar Arguments .. REAL BfactOverall,SZA INTEGER NAT,NAT2 C .. C .. Array Arguments .. REAL ATOMICNUMOCCUP(NAT),BB(NAT),XB(2,NAT) INTEGER IA(NAT2),IRESB(NAT),MB(NAT) C .. C .. Scalars in Common .. REAL AverageBfactor,BfactorMax,BfactorMin,BfactReset, + BfactStartStepSize,Bsmear,RatioShiftTrunc,RHmax,RHmean, + RHmin,RmsBfactor,RmsXyz,SFrepeatValue,SquAtmRadLimit,TH, + VolMtz,W,XyzStartStepSize, + BulkWaterSF INTEGER IOatomop,IOgradmat,IOhessian,IOmap,IOscratch, + IOshifts,IOxyzin,IOxyzoutunq,IXmax,IXmin,IYmax, + IYmin,IZmax,IZmin,Jsec,JU1,JU2,JV1,JV2,LatomMapFlag, + LBfactRefFlag,LcheckSFspaceGrpFlag,LFreeRexcludeVal, + LSFrefFlag,LhklInputFlag,LMapInFlag,LSFcalcFlag, + LSFmodeFlag,LSolvMaskFlag,LxyzInputFlag,LXyzOutputFlag, + NAACID,NATMTP,LrefineCycFlag,NtotalRefsUsed, + NumAtmRefined,NumChains,NumPlanes,NumSections, + NumSFspaceGroup,NumSFsymm,NumSpaceGroup,NumSymmetry, + NumZeroOccAtms,NX,NY,NZ,NumFormFactors LOGICAL LNoScaleFlag,LverboseFlag,IFILFF C .. C .. Arrays in Common .. REAL AtmBoxLowLim,AtmBoxUpLim,CellMtz,ExtBoxLowLim,ExtBoxUpLim, + ExtraPlanes,PermutRecipSymm,PlanesLimits, + FormFactAcoeff,FormFactBcoeff, + RealSymmMatrx,SpecialPlaneLimit,RecipSymmMatrx, + FormFactAcoeffSum INTEGER Iuvw,LSymmFlags,NumFirstResChn,NumLastResChn,NumResPerChn, + KatmWghts,NumGaussPerAtmTyp,Ifail,iwt,ielec CHARACTER ChainLabels*1,ElementNames*4,MAACD1*1,MAACID*4,MATMTP*4 C .. C .. Local Scalars .. REAL BISO,CHK,OCCB1,Occupancy,SDB0,SDX0,SDY0,SDZ0,X,X0,X1,XB3, + XB3IAT,CF,XFF,XSF,Y0,Y1,YFF,YSF,YY,Z,Z0,Z1,ZCH,ZFF,ZFFF,ZFG, + ZSF,ZZOV2 INTEGER I,I1,IAA,IAT,IATMTP,IAXX,IBIGB,ICH,ICHN,IDIM,IER,IFM,ILIM, + IMINB,INALL,IRECN,IRES,ISMLST,ISYM,ITER,IZZ,IZZB1,J, + JAA,JATMTP,JRESB,JSYM,LRECN,MAMAC,MAT1,MAT2,MFM,NATCHK, + Natoms,NINALL,NITEM,NSYMOK CHARACTER ATID*4,ID*4,MCH*1,MA*4,MA0*4,MAC*4,MAC0*4,RSN*4, + INSCOD*1,ALTCOD*1,SEGID*4 C .. C .. Local Arrays .. REAL B(6),BUF(12),SDBUF(5),USELIMITS(3,2),XA(3),Y(3), + AF(4),BF(4),CU(2),MO(2),RF(4,4),RO(4,4) INTEGER ITRANS(3),ITRLST(3) C .. C .. External Subroutines .. EXTERNAL AHVSOR,NEWLIN,QREAD,QSEEK,QWRITE,RBRORF,XYZADVANCE, + XYZATOM,XYZCOORD,XYZREWD C .. C .. Intrinsic Functions .. INTRINSIC INT,REAL C .. C .. Common blocks .. COMMON /ATMLIM/ + ExtBoxLowLim(3),ExtBoxUpLim(3), + SquAtmRadLimit,NumPlanes, + ExtraPlanes(3,6),PlanesLimits(6), + SpecialPlaneLimit(6), + AtmBoxLowLim(3),AtmBoxUpLim(3), + NumAtmRefined,NumZeroOccAtms COMMON /ATSYM/ + NumSymmetry,NumSpaceGroup, + RealSymmMatrx(4,4,MaxSymmetry), + RecipSymmMatrx(4,4,MaxSymmetry), + PermutRecipSymm(4,4), + LSymmFlags(MaxSymmetry) COMMON /BFACTS/ + AverageBfactor, + BfactorMin, + BfactorMax, + Bsmear, + BfactReset COMMON /CHAIN/ + NumChains, + NumFirstResChn(MaxNumChains), + NumLastResChn(MaxNumChains), + NumResPerChn(MaxNumChains) COMMON /CHNCH/ + ChainLabels(MaxNumChains) COMMON /FORM1/ + BulkWaterSF,NumFormFactors, + NumGaussPerAtmTyp(MaxFormFactors), + KatmWghts(MaxFormFactors), + FormFactAcoeff(5,MaxFormFactors), + FormFactBcoeff(5,MaxFormFactors), + FormFactAcoeffSum(MaxFormFactors) COMMON /FORM2/ + ElementNames(MaxFormFactors) COMMON /IOSF/ + IOscratch,IOgradmat,IOhessian,IOshifts, + IOatomop,IOmap,IOxyzin,IOxyzoutunq COMMON /LABEL1/ + NATMTP,NAACID COMMON /LABLS2/ + MATMTP(50),MAACID(27),MAACD1(26) COMMON /MPHDR/ + NX,NY,NZ, + IXmin,IXmax,IYmin,IYmax,IZmin,IZmax, + Jsec,JU1,JU2,JV1,JV2,Iuvw(3), + NumSFspaceGroup,NumSections, + RHmin,RHmax,RHmean,NumSFsymm, + CellMtz(6),VolMtz,Volfft,F000 COMMON /SRFCTL/ + NtotalRefsUsed, + RatioShiftTrunc,W,TH, + LSFmodeFlag,LrefineCycFlag,LBfactRefFlag, + LcheckSFspaceGrpFlag,LFreeRexcludeVal, + XyzStartStepSize,BfactStartStepSize, + SFrepeatValue, + RmsXyz,RmsBfactor COMMON /SRFCTL1/ + LSFcalcFlag,LSFrefFlag, + LatomMapFlag,LxyzInputFlag, + LhklInputFlag,LMapInFlag, + LSolvMaskFlag,LXyzOutputFlag COMMON /TERSE/LverboseFlag,LNoScaleFlag C .. C NATCHK = NumSymmetry/NumSFsymm IMINB = 0 IBIGB = 0 RO(1,1) = 0.0 RF(1,1) = 0.0 C C ************* CALL RBRORF(RO,RF) C ************* C C May have to open ATOMSF again. IFILFF = .TRUE. C C---- Set Kcounter for number of messages about C unknown residue and atom names C UseLimits(1,1) = REAL(IXmin/NX) UseLimits(2,1) = REAL(IYmin/NY) UseLimits(3,1) = REAL(IZmin/NZ) UseLimits(1,2) = REAL(IXmax/NX) C IF ( (IXmax+1) .EQ.NX) UseLimits(1,2)= 0.999999 UseLimits(2,2) = REAL(IYmax/NY) IF ( (IYmax+1) .EQ.NY) UseLimits(2,2)= 0.999999 UseLimits(3,2) = REAL(IZmax/NZ) IF ( (IZmax+1) .EQ.NZ) UseLimits(3,2)= 0.999999 C C---- Permute these limits: C XSF = PermutRecipSymm(1,1)*UseLimits(1,1) + + PermutRecipSymm(1,2)*UseLimits(2,1) + + PermutRecipSymm(1,3)*UseLimits(3,1) YSF = PermutRecipSymm(2,1)*UseLimits(1,1) + + PermutRecipSymm(2,2)*UseLimits(2,1) + + PermutRecipSymm(2,3)*UseLimits(3,1) ZSF = PermutRecipSymm(3,1)*UseLimits(1,1) + + PermutRecipSymm(3,2)*UseLimits(2,1) + + PermutRecipSymm(3,3)*UseLimits(3,1) C UseLimits(1,1) = XSF UseLimits(2,1) = YSF UseLimits(3,1) = ZSF C XSF = PermutRecipSymm(1,1)*UseLimits(1,2) + + PermutRecipSymm(1,2)*UseLimits(2,2) + + PermutRecipSymm(1,3)*UseLimits(3,2) YSF = PermutRecipSymm(2,1)*UseLimits(1,2) + + PermutRecipSymm(2,2)*UseLimits(2,2) + + PermutRecipSymm(2,3)*UseLimits(3,2) ZSF = PermutRecipSymm(3,1)*UseLimits(1,2) + + PermutRecipSymm(3,2)*UseLimits(2,2) + + PermutRecipSymm(3,3)*UseLimits(3,2) C UseLimits(1,2) = XSF UseLimits(2,2) = YSF UseLimits(3,2) = ZSF C IF (BfactReset.EQ.0.0) BfactReset = 5.0 C XSF = ExtBoxLowLim(1) YSF = ExtBoxLowLim(2) ZSF = ExtBoxLowLim(3) XFF = ExtBoxUpLim(1) YFF = ExtBoxUpLim(2) ZFF = ExtBoxUpLim(3) C LRECN = 0 IRECN = 0 ITER = 0 C DO 10 I = 1,12 BUF(I) = 0.0 10 CONTINUE C C---- Start IOshifts if LSFrefFlag NE 0 - C either write 2 dummy numbers ( SZA = 0) C or read 2 dummy numbers ( SZA Gt0) C IF (LSFrefFlag .NE.0) THEN CALL QSEEK(IOshifts,1,1,2) IF (SZA.EQ.0.0) CALL QWRITE(IOshifts,SDBUF,2) IF (SZA.NE.0.0) CALL QREAD(IOshifts,SDBUF,2,IER) SDBUF(1) = 0.0 SDBUF(2) = 0.0 SDBUF(3) = 0.0 SDBUF(4) = 0.0 SDBUF(5) = 0.0 END IF C ZFG = ZFF ZFFF = ZFF ZCH = ZFF - ZSF C IF (ZCH.GE.1.0) ZFG = ZSF + 1.0 C C---- Set this to help in checking unit cell transformations... C Don't forget to put it back to ZFFF later!! C ExtBoxUpLim(3) = ZFG ILIM = NAT C C---- ATSORT now judges whether an atom will only appear C once in the sorted list, and scans the symmetry C cards a little more intelligently. C C But if you are using more symmetry cards than the C spacegroup minimum this facility is useless. C ISMLST = 1 ITRLST(1) = 0 ITRLST(2) = 0 ITRLST(3) = 0 C WRITE (6,FMT=6000) 6000 FORMAT (/' Limits for atoms: AXIS MIN MAX') IAXX = 1 WRITE (6,FMT=6002) IAXX,XSF,XFF 6002 FORMAT (21X,I5,2F9.3) IAXX = 2 WRITE (6,FMT=6002) IAXX,YSF,YFF IAXX = 3 WRITE (6,FMT=6002) IAXX,ZSF,ZFF C C *********** CALL NEWLIN(6,2) C *********** C WRITE (6,FMT=6004) 6004 FORMAT (/' Upper limits are: AXIS MIN MAX') IAXX = 1 WRITE (6,FMT=6002) IAXX,AtmBoxLowLim(1),AtmBoxUpLim(1) IAXX = 2 WRITE (6,FMT=6002) IAXX,AtmBoxLowLim(2),AtmBoxUpLim(2) IAXX = 3 WRITE (6,FMT=6002) IAXX,AtmBoxLowLim(3),AtmBoxUpLim(3) C C *********** CALL NEWLIN(6,2) C *********** C AverageBfactor = 0.0 BfactorMin = 1000.0 BfactorMax = 0.0 NINALL = 0 IAT = 0 I = 0 C C **************** CALL XYZREWD(IOxyzin) C **************** C 20 CONTINUE C C---- NSYMOK - flag whether atom output to unique set. C NSYMOK = 0 C C ********************************************************** CALL XYZADVANCE(IOxyzin,0,ITER,*180,*180) CALL XYZATOM(IOxyzin,I1,MA,MAC,MCH,IRES,RSN,INSCOD,ALTCOD, + SEGID,IZZ,ID) CALL XYZCOORD(IOxyzin,'O','B',X0,Y0,Z0,Occupancy,BISO,B) C ********************************************************** C IF (B(2).NE.0.0 .OR. B(3).NE.0.0) THEN IF (X0.EQ.0.0 .AND. Y0.EQ.0.0 .AND. Z0.EQ.0.0) GOTO 20 ENDIF C IF (Occupancy.NE.0.0) THEN C X1 = X0 Y1 = Y0 Z1 = Z0 C C----- Set up missing formfactors here for SFCALC or first pass of refinement: C----- You may need to left-justify the ATID IF (ID(1:1) .EQ. ' ') THEN ATID = ID(2:4)//' ' ELSE ATID = ID ENDIF C C July 1999 - This is a disaster for refinement; comment out. c IF (LxyzInputFlag.EQ.1 .AND. SZA.EQ.0.0) THEN DO 25 IFM = 1,NumFormFactors c IF (IZZ.EQ.KatmWghts(IFM)) GO TO 26 IZZ = KatmWghts(IFM) IF (ATID.EQ.ElementNames(IFM)) GO TO 26 25 CONTINUE C Add formfactor to list: NumFormFactors = NumFormFactors + 1 IF (NumFormFactors.GT.MaxFormFactors) THEN WRITE(6,'(a,I4,a,/,a)') +' Program only dimensioned for ',MaxFormFactors,' Formfactors ', +' Change dimensions of PARAMETER MaxFormFactors' CALL CCPERR(1,' Fatal Error') END IF C ************************* CALL SFREAD2(ATID, + 5, + AF, + BF, + CF, + IWT, + IELEC, + CU, + MO, + Ifail) C ************************* C C ***************************************** IF (Ifail.EQ.-1) + CALL CCPERR(1,' No match for atom label(ATSORT)') C ***************************************** C c KatmWghts(NumFormFactors) = IWT KatmWghts(NumFormFactors) = NumFormFactors IZZ = KatmWghts(NumFormFactors) NumGaussPerAtmTyp(NumFormFactors) = 5 FormFactAcoeff(1,NumFormFactors) = AF(1) FormFactAcoeff(2,NumFormFactors) = AF(2) FormFactAcoeff(3,NumFormFactors) = AF(3) FormFactAcoeff(4,NumFormFactors) = AF(4) FormFactBcoeff(1,NumFormFactors) = BF(1) FormFactBcoeff(2,NumFormFactors) = BF(2) FormFactBcoeff(3,NumFormFactors) = BF(3) FormFactBcoeff(4,NumFormFactors) = BF(4) FormFactAcoeff(5,NumFormFactors) = CF FormFactAcoeffSum(NumFormFactors) = + AF(1) + AF(2) + AF(3) + AF(4) + CF ElementNames(NumFormFactors) = ATID WRITE (6,'(/,I4,a,/,a)') +NumFormFactors,'th Form factor added: ', +' AtomName - atomic number - (AI BI),I=1,5 - sum(AI) ' C WRITE (6,6005) ElementNames(NumFormFactors), + KatmWghts(NumFormFactors), + (FormFactAcoeff(J,NumFormFactors), + FormFactBcoeff(J,NumFormFactors), + J=1,5), + FormFactAcoeffSum(NumFormFactors) 6005 FORMAT(2X,A4,I15,2X,2 (2F10.5,2X),/,23X,3(2F10.5,2X),F10.5,/) 26 CONTINUE c END IF C---- need to write dummy records for NumAtmRefined to IOshifts - C here is as good a place as any. C SZA = 0 on First pass. C IF (LSFrefFlag.NE.0 .AND. SZA.EQ.0.0) + CALL QWRITE(IOshifts,SDBUF,5) C IF (LSFrefFlag.NE.0 .AND. SZA.NE.0.0) THEN C C *************************** CALL QREAD(IOshifts,SDBUF,5,IER) C *************************** C IF (IER.NE.0) GO TO 180 SDX0 = SDBUF(1) SDY0 = SDBUF(2) SDZ0 = SDBUF(3) SDB0 = SDBUF(5) C IF (LBfactRefFlag.EQ.0 .OR. LSFmodeFlag.EQ.5) THEN X1 = X0 - SZA*SDX0 Y1 = Y0 - SZA*SDY0 Z1 = Z0 - SZA*SDZ0 END IF C IF (LBfactRefFlag.EQ.1 .OR. LSFmodeFlag.EQ.5) THEN BISO = BISO - SZA*SDB0 + BfactOverall END IF END IF C XA(1) = RF(1,1)*X1 + RF(1,2)*Y1 + RF(1,3)*Z1 + RF(1,4) XA(2) = RF(2,1)*X1 + RF(2,2)*Y1 + RF(2,3)*Z1 + RF(2,4) XA(3) = RF(3,1)*X1 + RF(3,2)*Y1 + RF(3,3)*Z1 + RF(3,4) C IF (IAT.LE.1) WRITE (6,FMT=6006) 6006 FORMAT (//' First 10 atoms of atsort - orthog coordinates') IF (IAT.LE.10) WRITE (6,FMT=6008) + I1,MA,MAC,IRES,X1,Y1,Z1, + Occupancy,BISO,IZZ,XA(1),XA(2),XA(3) 6008 FORMAT ( + 5X,I5,A4,1X,A4,1X,I8,3F8.4,F5.2,F8.2,I5,/, +' fractional coordinates ',3F8.5) C IF (BISO.LT.BfactReset.and.LverboseFlag) + WRITE (6,FMT=6010) BfactReset,I1,MA,MAC, + IRES,X1,Y1,Z1,Occupancy,BISO,IZZ 6010 FORMAT (/, + ' bvalue reset eq ',f4.1,' - ORTHOG COORDINATES', + I5,1X,A4,1X,A4,1X,I8,3F8.4,F5.2,F8.2,I5) C IF (BISO.LT.BfactReset) THEN IMINB = IMINB + 1 BISO = BfactReset END IF C C---- Set up code no to record AtomName and residue type C DO 30 IAA = 1,NAACID JAA = IAA IF (MAC.EQ.MAACID(JAA)) GO TO 40 30 CONTINUE C JAA = 25 IF (LverboseFlag) WRITE (6,FMT=6012) IRES,MA,MAC 6012 FORMAT ( + ' Amino acid name not recognised - set to DUM',I5,1X,A4, + 1X,A4,/, + ' It does not have a standard protein ID, e.g. part of a', + ' ligand or a water? THIS DOES NOT MATTER') IRECN = IRECN + 1 C 40 CONTINUE C DO 50 IATMTP = 1,NATMTP JATMTP = IATMTP IF (MA.EQ.MATMTP(JATMTP)) GO TO 60 50 CONTINUE C JATMTP = 50 IF (LverboseFlag) WRITE (6,FMT=6014) IRES,MA,MAC 6014 FORMAT (/,1X, + '*** Atom name not recognised - set to ZZZ:',I5,1X,A4,1X,A4,/, + ' It does not have a standard protein ID, e.g. part of a', + ' ligand or a water? THIS DOES NOT MATTER') IRECN = IRECN + 1 60 MAMAC = 100*JATMTP + JAA AverageBfactor = AverageBfactor + BISO IF (BfactorMin.GT.B(1)) BfactorMin = BISO IF (BfactorMax.LT.B(1)) BfactorMax = BISO C C---- If this is initial coord file,add Bsmear (ref ten eyck) C IF (BISO.GT.99.9) THEN IF ( LverboseFlag) + WRITE (6,FMT=6016) I1,MA,MAC,IRES, + X1,Y1,Z1,Occupancy,BISO,IZZ 6016 FORMAT (/, + ' bvalue reset eq 99.89 - Orthog coordinates',I5, + A4,1X,A4,1X,I8,3F8.4,F5.2,F8.2,I5) IBIGB = IBIGB + 1 BISO = 99.89 END IF C I = I + 1 ICH = 0 C C---- Generate symmetry-related positions and check whether C they fall within the range which contributes to the C density of the asymmetric unit C C---- Most likely that this atom will need the same symmetry ops as C its predecessor - test that First. C DO 150 JSYM = 1,NumSymmetry MFM = 1 ISYM = JSYM + ISMLST - 1 IF (ISYM.GT.NumSymmetry) ISYM = ISYM - NumSymmetry C X = RealSymmMatrx(1,1,ISYM)*XA(1) + + RealSymmMatrx(1,2,ISYM)*XA(2) + + RealSymmMatrx(1,3,ISYM)*XA(3) + + RealSymmMatrx(1,4,ISYM) YY = RealSymmMatrx(2,1,ISYM)*XA(1) + + RealSymmMatrx(2,2,ISYM)*XA(2) + + RealSymmMatrx(2,3,ISYM)*XA(3) + + RealSymmMatrx(2,4,ISYM) Z = RealSymmMatrx(3,1,ISYM)*XA(1) + + RealSymmMatrx(3,2,ISYM)*XA(2) + + RealSymmMatrx(3,3,ISYM)*XA(3) + + RealSymmMatrx(3,4,ISYM) C Y(1) = X Y(2) = YY Y(3) = Z C DO 90 J = 1,3 ITRANS(J) = ITRLST(J) 70 CONTINUE C IF (Y(J).LT.ExtBoxLowLim(J)) THEN Y(J) = Y(J) + 1.0 ITRANS(J) = ITRANS(J) + 1 GO TO 70 END IF C 80 CONTINUE C IF (Y(J).GE.ExtBoxUpLim(J)) THEN Y(J) = Y(J) - 1.0 ITRANS(J) = ITRANS(J) - 1 GO TO 80 END IF C C---- Check 1) Coordinate outside extended box - go to 140 C IF (Y(J).LT.ExtBoxLowLim(J) .OR. + Y(J).GT.ExtBoxUpLim(J)) GO TO 140 C C---- Check 2) Coordinate outside inner box - set inall = 0 C INALL = 1 IF (Y(J).LE.AtmBoxLowLim(J) .OR. + Y(J).GE.AtmBoxUpLim(J)) INALL = 0 C C---- Check 3) Does coordinate fit in UNIQUE set - only need one C occurrence? C IF (LXyzOutputFlag.NE.0 .AND. + NSYMOK.EQ.0 .AND. + MFM.EQ.1) THEN IF (Y(J).LT.UseLimits(J,1) .OR. + Y(J).GT.UseLimits(J,2)) MFM= 0 END IF 90 CONTINUE C C---- Check if there are other limits on atoms C IF (NumPlanes.NE.0) THEN INALL = 0 C DO 100 J = 1,NumPlanes CHK = ExtraPlanes(1,J)*Y(1) + + ExtraPlanes(2,J)*Y(2) + + ExtraPlanes(3,J)*Y(3) IF (CHK.GT.PlanesLimits(J)) GO TO 140 100 CONTINUE C END IF C C---- Pack atom sequence no. and b in b C Pack translation code and formfactor in zzb C Pack x and symmetry transformation no. in x C Pack ich(no. of times atom contributes) and y in y C IAT = IAT + 1 IF (IAT.GT.NAT) + CALL CCPERR (1, 'Too many positions generated: '// + 'increase MEMSIZE (see doc)') MB(IAT) = MAMAC BB(IAT) = 100.0*I + BISO C C---- april 1981 - oh dear - no negative occupancies allowed C AtomicNumOccup(IAT) = 20*IZZ + Occupancy + 10 C C---- alter residue numbers to cope with multiple chains C IRESB(IAT) = IRES C IF (NumChains.GT.0) THEN ICHN = 1 C DO 110 ICHN = 1,NumChains IF (MCH.EQ.ChainLabels(ICHN)) GO TO 120 110 CONTINUE C GO TO 130 120 IRESB(IAT) = NumResPerChn(ICHN) + IRES - + NumFirstResChn(ICHN) + 1 C C---- add in atom number as well to this C 130 CONTINUE END IF C C---- IF LXyzOutputFlagique requested write out atom. C IF (LXyzOutputFlag.NE.0 .AND. + NSYMOK.EQ.0 .AND. + MFM.EQ.1) THEN C C---- Brookhaven C NSYMOK = JSYM C C---- Permute Y(1) Y(2) y(3) C X1 = PermutRecipSymm(1,1)*Y(1) + + PermutRecipSymm(1,2)*Y(2) + + PermutRecipSymm(1,3)*Y(3) Y1 = PermutRecipSymm(2,1)*Y(1) + + PermutRecipSymm(2,2)*Y(2) + + PermutRecipSymm(2,3)*Y(3) Z1 = PermutRecipSymm(3,1)*Y(1) + + PermutRecipSymm(3,2)*Y(2) + + PermutRecipSymm(3,3)*Y(3) C C---- Orthogonalise: C X0 = RO(1,1)*X1 + RO(1,2)*Y1 + RO(1,3)*Z1 + RO(1,4) Y0 = RO(2,1)*X1 + RO(2,2)*Y1 + RO(2,3)*Z1 + RO(2,4) Z0 = RO(3,1)*X1 + RO(3,2)*Y1 + RO(3,3)*Z1 + RO(3,4) C B(1) = BISO DO 135 I = 2,6 B(I) = 0.0 135 CONTINUE C C---- write atom.. C CALL XYZATOM(IOXYZOUTUNQ,I1,MA,MAC,MCH,IRES,RSN,INSCOD, + ALTCOD,SEGID,IZZ,ID) CALL XYZCOORD(IOXYZOUTUNQ,'O','B',X0,Y0,Z0,Occupancy, + BISO,B) CALL XYZADVANCE(IOXYZOUTUNQ,0,0,*160,*160) END IF C XB(1,IAT) = 10*ISYM + Y(1) XB(2,IAT) = 10*ICH + Y(2) IA(IAT) = INT(Y(3)*100000.0+0.5) IA(ILIM+IAT) = IAT ICH = ICH + 1 IF (NumSFsymm.LT.NumSymmetry) INALL = 0 IF (INALL.NE.0) GO TO 160 C 140 CONTINUE 150 CONTINUE GO TO 170 160 ISMLST = ISYM ITRLST(1) = ITRANS(1) ITRLST(2) = ITRANS(2) ITRLST(3) = ITRANS(3) C 170 IF (ICH.EQ.1) NINALL = NINALL + 1 C IF (ICH.LE.0 .OR. ICH.GT.4) THEN IF (ICH.EQ.0) WRITE (6,FMT=6020) + XA(1),XA(2),XA(3),IRES,MA,MAC 6020 FORMAT ( + ' No place to put this atom ',3F10.5,I3,A4,1X,A4) IF (ICH.GT.NATCHK + 2) + WRITE (6,FMT=6022) ICH,XA(1),XA(2), + XA(3),IRES,MA,MAC 6022 FORMAT ( + ' This atom in ',I3,' times ',3F10.5,I3,A4,1X,A4) C END IF END IF C GO TO 20 C C---- Finished with generating atoms. C 180 CONTINUE C C---- Reset ExtBoxUpLim(3) C ExtBoxUpLim(3) = ZFFF NumAtmRefined = I Natoms = IAT NITEM = 2 IDIM = ILIM*NITEM C C---- Go to sort coordinates on z C C ********************************* CALL AHVSOR(IA,Natoms,NITEM,ILIM,IDIM) C ********************************* C C---- Nov1981 replace random access file 23 with a buffered one C I1 = 1 C C ****************** CALL QSEEK(IOatomop,1,1,12) C ****************** C WRITE (6,FMT=6024) 6024 FORMAT ( + ' First 10 atoms of sorted file in assym unit - ') DO 190 I = 1,Natoms IAT = IA(ILIM+I) XB3 = IA(I)*0.00001 BUF(3) = XB3 BUF(1) = XB(1,IAT) BUF(2) = XB(2,IAT) BUF(4) = BB(IAT) BUF(5) = AtomicNumOccup(IAT) BUF(6) = IRESB(IAT) BUF(7) = IAT BUF(8) = MB(IAT) C C ******************* CALL QWRITE(IOatomop,BUF,12) C ******************* C IF (IAT.LE.10) THEN C C---- unpack acidname and residue code C MAT1 = MB(IAT)/100 MAT2 = MB(IAT) - 100*MAT1 MA0 = MATMTP(MAT1) MAC0 = MAACID(MAT2) ZZOV2 = AtomicNumOccup(IAT)/20.0 IZZB1 = INT(ZZOV2) OCCB1 = AtomicNumOccup(IAT) - 20*IZZB1 - 10 JRESB = IRESB(IAT) C WRITE (6,FMT=6026) XB(1,IAT),XB(2,IAT), + XB3,BB(IAT),OCCB1, + IZZB1,JRESB,MA0,MAC0 6026 FORMAT (5X,3F10.5,F10.2,F5.2,I10,2X,I3,A4,1X,A4) END IF 190 CONTINUE C IAT = IA(ILIM+1) XB3IAT = IA(1)*0.00001 MAT1 = MB(IAT)/100 MAT2 = MB(IAT) - 100*MAT1 MA0 = MATMTP(MAT1) MAC0 = MAACID(MAT2) JRESB = IRESB(IAT) C WRITE (6,FMT=6028) XB(1,IAT),XB(2,IAT),XB3IAT,BB(IAT), + AtomicNumOccup(IAT),JRESB,MA0,MAC0 6028 FORMAT (/, +' First atom of sorted file in atsort ',/, +5X,3F10.5,F10.2,F10.2,2X,I3,A4,1X,A4) NumZeroOccAtms = Natoms C IF (ZCH.GE.1.0) THEN I = 1 200 CONTINUE IAT = IA(ILIM+I) XB3IAT = IA(I)*0.00001 + 1.0 C IF (XB3IAT.LT.ZFFF) THEN IF(IAT.LE.NATOMS .AND. IAT.GE.1) THEN NumZeroOccAtms = NumZeroOccAtms + 1 BUF(1) = XB(1,IAT) BUF(2) = XB(2,IAT) BUF(3) = XB3IAT BUF(4) = BB(IAT) BUF(5) = AtomicNumOccup(IAT) BUF(6) = IRESB(IAT) BUF(7) = IAT BUF(8) = MB(IAT) C C ******************* CALL QWRITE(IOatomop,BUF,12) C ******************* C I = I + 1 GO TO 200 END IF END IF END IF C AverageBfactor = AverageBfactor/NumAtmRefined C WRITE (6,FMT=6030) NumAtmRefined, + Natoms, + NumZeroOccAtms, + NINALL, + BfactorMin, + BfactorMax, + AverageBfactor, + IMINB, + IBIGB 6030 FORMAT ( +' Number of atoms input = ',I13,/, +' Number of atoms in sort = ',I11,/, +' Number in density generation = ',I6,/, +' Number completely within fft box = ',I6,/, +' Minimum B = ',F8.2,/, +' Maximum B = ',F8.2,/, +' Average B = ',F8.2,/, +' Number of Bs < BfactReset = ',I8,/, +' Number of Bs > 99.99 = ',I8) C END C C C C C C ================================================================= SUBROUTINE CHKSYM(SPGRP,NumSymmetry,CalcSpaceGroup,RealSymmMatrx, + NSFSG,SFSGS) C ================================================================= C C This subroutine choses which space group specific routines to use C in SFALL given any particular space group. C C .. C .. Parameters .. INTEGER MaxSymmetry PARAMETER (MaxSymmetry=192) C .. C .. Scalar Arguments .. INTEGER CalcSpaceGroup,NumSymmetry,NSFSG,SPGRP C .. C .. Array Arguments .. REAL RealSymmMatrx(4,4,MaxSymmetry) INTEGER SFSGS(NSFSG) C .. C .. Local Scalars .. REAL DCHK INTEGER I,IDCHK,IGOOD,ISGS,IST,ITMP,J,N,NSM,NSMP CHARACTER PGNFFT*10 C .. C .. Local Arrays .. REAL RSM(4,4,MaxSymmetry) C .. C .. External Subroutines .. EXTERNAL CCPERR,MSYGET,PGDEFN C .. C .. Intrinsic Functions .. INTRINSIC ABS,MOD,NINT C .. C IF (SPGRP .EQ. 0) CALL + CCPERR(1,' *** No symmetry given need SYMM card ***') DO 70 ISGS = NSFSG,1,-1 ITMP = MOD(SFSGS(ISGS),1000) IF(ITMP.GT.MOD(SPGRP,1000)) GOTO 70 IST = 49 C C ******************************* CALL MSYGET(IST,SFSGS(ISGS),NSM,RSM) C ******************************* C C---- Get NLAU ready for grid assignment. C C *********************************** CALL PGDEFN(PGNFFT,NSMP,NSM,RSM,.FALSE.) C *********************************** C C---- Now check MTZ symm against possibles. C---- GOOD flag reset for this possible spacegroup. C C DO 80 ISM = 1,NSM IGOOD = 0 C C---- Now loop over all MTZ symm ops. C DO 90 N = 1,NumSymmetry C C---- Check This RSM matrix for rotation and translation C DO 20 I = 1,3 DO 30 J = 1,4 DCHK = ABS(RSM(I,J,ISM) - RealSymmMatrx(I,J,N)) C C---- This may be needed for translation components; no harm for others. C IDCHK = 0 IF(J.EQ.4)IDCHK = NINT(DCHK) DCHK = ABS(DCHK-IDCHK) IF (DCHK.LT.0.01) GO TO 30 C C--- This MTZ symm op no good - off to check the next.. C GO TO 90 30 CONTINUE 20 CONTINUE C C---- Found a good match - now check next ISM C IGOOD = 1 GO to 80 90 CONTINUE C C---- If this symmetry operator is missing no point going on. Try next SG C IF(IGOOD.EQ.0) GO TO 70 80 CONTINUE C C---- OK - every RSM was matched. C---- If test satisfied return C GO to 100 C C---- Otherwise test next possible space group. C 70 CONTINUE C C---- I guess this will never happen - always satisfy P1 C CALL CCPERR(1, + ' ** No Calculation symmetry incompatible with space-group **') C 100 CONTINUE CalcSpaceGroup = SFSGS(ISGS) WRITE(6,'(A,I5,A)') + ' *** Calculation symmetry using space-group CalcSpaceGroup', + CalcSpaceGroup,' ***' C RETURN END C C C ================== SUBROUTINE CLOSEIT C ================== C C .. Scalars in Common .. INTEGER IOatomop,IOgradmat,IOhessian,IOmap,IOscratch,IOshifts, + IOxyzin,IOxyzoutunq,LatomMapFlag,LhklInputFlag, + LMapInFlag,LSFcalcFlag,LSFrefFlag,LSolvMaskFlag, + LxyzInputFlag,LXyzOutputFlag C .. C .. Local Scalars .. CHARACTER WorkFile*255, TITLE*80 INTEGER IUVW(3),MXYZ(3),NSEC,NW1,NU1,NU2,NV1,NV2,LSPGRP,LMODE REAL CELL(6),RHMIN,RHMAX,RHMEAN,RHRMS C .. C .. External Functions .. INTEGER LENSTR EXTERNAL LENSTR C .. C .. External Subroutines .. EXTERNAL MRDHDR, QCLOSE,UGTENV,XYZCLOSE C .. C .. Common Blocks .. COMMON /SRFCTL1/ + LSFcalcFlag,LSFrefFlag, + LatomMapFlag,LxyzInputFlag, + LhklInputFlag,LMapInFlag, + LSolvMaskFlag,LXyzOutputFlag COMMON /IOSF/ + IOscratch,IOgradmat,IOhessian,IOshifts, + IOatomop,IOmap,IOxyzin,IOxyzoutunq C .. C IF (LxyzInputFlag .GT. 0) CALL XYZCLOSE(IOxyzin) IF (LXyzOutputFlag .GT. 0) CALL XYZCLOSE(IOxyzoutunq) C C IF (IOscratch .GT. 0) CALL QCLOSE(IOscratch) IF (IOhessian .GT. 0) CALL QCLOSE(IOhessian) IF (IOshifts .GT. 0) CALL QCLOSE(IOshifts) IF (IOatomop .GT. 0) CALL QCLOSE(IOatomop) C ********************************************* IF (LatomMapFlag.EQ.1) CALL MRDHDR(IOmap,'MAPOUT',TITLE,NSEC,IUVW, + MXYZ,NW1, + NU1,NU2,NV1,NV2,CELL,LSPGRP,LMODE, + RHMIN,RHMAX,RHMEAN,RHRMS) C ********************************************* C C WorkFile = ' ' C C **************************** CALL UGTENV('FFTHKLSCR',WorkFile) C **************************** C IF (WorkFile(1:1) .NE. ' ') THEN OPEN (UNIT=66, + FILE=WorkFile(1:LENSTR(WorkFile)), + STATUS='OLD', + ERR=10) C CLOSE (UNIT=66,STATUS='DELETE') ENDIF C 10 RETURN END C C ================================ SUBROUTINE DIVI(X,NZ,NY,NX,EVEN) C ================================ C C---- divides h = 2n + 1 results by i C C .. Scalar Arguments .. INTEGER EVEN,NX,NY,NZ C .. C .. Array Arguments .. REAL X(NZ,NY,NX) C .. C .. Local Scalars .. REAL A INTEGER H,HL,K,L C .. C .. Intrinsic Functions .. INTRINSIC MOD C .. C HL = MOD(EVEN+1,2) + 1 IF (HL.GT.NX) RETURN C DO 30 H = HL,NX,2 DO 20 K = 1,NY DO 10 L = 1,NZ,2 A = X(L,K,H) X(L,K,H) = X(L+1,K,H) X(L+1,K,H) = -A 10 CONTINUE 20 CONTINUE 30 CONTINUE C END C C =================================== SUBROUTINE FFTGR1(X,Size,NPAR,LCYC) C =================================== C C .. Scalar Arguments .. INTEGER LCYC,NPAR,Size C .. C .. Array Arguments .. REAL X(Size) C .. C .. Scalars in Common .. REAL RHmax,RHmean,RHmin,VolMtz INTEGER Hmax,Hmin,IOatomop,IOgradmat,IOhessian,IOmap,IOscratch, + IOshifts,IOxyzin,IOxyzoutunq,IXmax,IXmin,IYmax, + IYmin,IZmax,IZmin,Jsec,JU1,JU2,JV1,JV2,Kmax,Kmin,Lmax, + Lmin,Nslab,NumSections,NumSFspaceGroup,NumSFsymm,NX,NY,NZ LOGICAL LNoScaleFlag,LverboseFlag C .. C .. Arrays in Common .. REAL CellMtz INTEGER Iuvw C .. C .. Local Scalars .. REAL DUMMY INTEGER I,IQ,Jrec,LM1,NPassOneSave,NSizePassOne,NSizePassTwo, + NumCurrentRecord,NumMaxRecord,NumSkipRecords,NumWords,R, + RECS C .. C .. Local Arrays .. INTEGER D(5) C .. C .. External Subroutines .. EXTERNAL CMPLFT,GENDEN,HERMFT,MULTBK,QSEEK,SFIPY,YIN2,YOUT2 C .. C .. Common blocks .. COMMON /HKLLIM/ + Hmax,Kmax,Lmax,Hmin,Kmin,Lmin,Nslab COMMON /IOSF/ + IOscratch,IOgradmat,IOhessian,IOshifts, + IOatomop,IOmap,IOxyzin,IOxyzoutunq COMMON /MPHDR/ + NX,NY,NZ, + IXmin,IXmax,IYmin,IYmax,IZmin,IZmax, + Jsec,JU1,JU2,JV1,JV2,Iuvw(3), + NumSFspaceGroup,NumSections, + RHmin,RHmax,RHmean,NumSFsymm, + CellMtz(6),VolMtz,Volfft,F000 COMMON /TERSE/LverboseFlag,LNoScaleFlag COMMON /SRFCTL1/ + LSFcalcFlag,LSFrefFlag, + LatomMapFlag,LxyzInputFlag, + LhklInputFlag,LMapInFlag, + LSolvMaskFlag,LXyzOutputFlag C .. C LM1 = Lmax + 1 C C---- calculate dimensioning parameters C NSizePassOne = Size/ (NY*2*LM1) IF (NSizePassOne .GT. (Hmax-Hmin+1)) + NSizePassOne = Hmax - Hmin + 1 NPassOneSave = NSizePassOne NSizePassTwo = Size/ (NX*NZ) C C---- transform on k and write results on t2 C NumWords = 2*NSizePassOne*NSizePassTwo*LM1 IF (LMapInFlag .EQ. 1) GO TO 15 C C ********************** CALL QSEEK(IOscratch,1,1,1) C ********************** C NumCurrentRecord = 0 Jrec = 0 R = Hmin 10 CONTINUE IF (R+NSizePassOne.GT.Hmax) + NSizePassOne = Hmax + 1 - R Jrec = Jrec + 1 C C---- read in data- option to read precalculated difference map C C ************************* CALL SFIPY(X, + NY, + LM1, + NSizePassOne, + R, + LCYC) C ************************* C IQ = R + NSizePassOne - 1 IF (LverboseFlag) WRITE (6,FMT=6000) R,IQ 6000 FORMAT (' Data read for H =',I4,' to ',I4) C C---- temperature factor gradient C C *********************** IF (NPAR.EQ.4) CALL MULTBK(X, + NY*2, + LM1, + NSizePassOne, + Kmax, + Kmin, + R) C *********************** C C---- pass one. transform on k and write intermediate results on t2. C IF (R+NSizePassOne.GT.Hmax) NSizePassOne = Hmax + 1 - R D(1) = NY*2* (Lmax+1)*NSizePassOne D(2) = 2 D(3) = D(1) D(4) = D(1) D(5) = NY*2 C C ********************** CALL CMPLFT(X(1), + X(2), + NY, + D) CALL YOUT2(X, + NY, + Lmax+1, + NSizePassOne, + NSizePassTwo, + IYmin, + IYmax, + IOscratch, + NumCurrentRecord, + NumWords) C *********************** C R = R + NSizePassOne IF (R.LE.Hmax .AND. Jrec.LT.Nslab) GO TO 10 C C---- end of pass 1. pass 2 reads back the intermediate results, C calculates the transforms on h and l, and writes out the final C y sections. C 15 CONTINUE C NSizePassOne = NPassOneSave NumSkipRecords = 0 NumMaxRecord = NumCurrentRecord RECS = (IYmax-IYmin)/NSizePassTwo R = IYmin 20 CONTINUE NumCurrentRecord = 1 IF (R+NSizePassTwo.GT.IYmax) NSizePassTwo = IYmax - R + 1 C IF (LMapInFlag .EQ. 1) THEN SumDummy = 0.0 CALL REDMP2(X,NZ,NX,NSizePassTwo,R,SumDummy) GO TO 35 END IF C C ************************ CALL YIN2(X, + NZ/2, + NX, + NSizePassTwo, + Hmax, + Lmax, + NSizePassOne, + NumSkipRecords, + RECS, + IOscratch, + NumCurrentRecord, + NumMaxRecord, + NumWords) C ************************ C NumSkipRecords = NumSkipRecords + 1 C C---- x now contains intermediate results stored with l down the C columns and h across the rows. C D(1) = NX*NZ*NSizePassTwo D(2) = NZ D(3) = NX*NZ D(4) = (Lmax+1)*2 D(5) = 2 C C---- gradient on x C C ************************ CALL CMPLFT(X(1),X(2),NX,D) C ************************ C D(2) = 2 D(4) = (IXmax-IXmin+1)*NZ D(5) = NZ I = IXmin*NZ + 1 C C *************************** CALL HERMFT(X(I),X(I+1),NZ/2,D) C *************************** C 35 CONTINUE C C---- calculate map from coordinates and use to produce gradients C C *********************** CALL GENDEN(X, + NZ, + NX, + NSizePassTwo, + R, + NPAR, + DUMMY) C *********************** C R = R + NSizePassTwo IF (R.LE.IYmax) GO TO 20 C C---- gradients calculated C END C C ========================================= SUBROUTINE FFTGR145(X,PHI,Size,NPAR,LCYC) C ========================================= C C---- Fourier synthesis for space group P31 OR P32 C modified to calculate gradient maps C C .. Scalar Arguments .. INTEGER LCYC,NPAR,Size C .. C .. Array Arguments .. REAL PHI(Size/2),X(Size) C .. C .. Scalars in Common .. REAL RHmax,RHmean,RHmin,VolMtz INTEGER Hmax,Hmin,IOatomop,IOgradmat,IOhessian,IOmap,IOscratch, + IOshifts,IOxyzin,IOxyzoutunq,IXmax,IXmin,IYmax, + IYmin,IZmax,IZmin,Jsec,JU1,JU2,JV1,JV2,Kmax,Kmin,Lmax, + Lmin,Nslab,NumSections,NumSFspaceGroup,NumSFsymm,NX,NY,NZ LOGICAL LNoScaleFlag,LverboseFlag C .. C .. Arrays in Common .. REAL CellMtz INTEGER Iuvw C .. C .. Local Scalars .. REAL DUMMY INTEGER I,IQ,Jrec,KM1,KMX1,NSizePassOne,NSizePassTwo, + NumCurrentRecord,NumWords,NY2,NZOV3,R C .. C .. Local Arrays .. INTEGER D(5) C .. C .. External Subroutines .. EXTERNAL CMPLFT,GENDEN,HERMFT,MULTBL,OUT144,QSEEK,SFIPZ,ZIN C .. C .. Common blocks .. COMMON /HKLLIM/ + Hmax,Kmax,Lmax,Hmin,Kmin,Lmin,Nslab COMMON /IOSF/ + IOscratch,IOgradmat,IOhessian,IOshifts, + IOatomop,IOmap,IOxyzin,IOxyzoutunq COMMON /MPHDR/ + NX,NY,NZ, + IXmin,IXmax,IYmin,IYmax,IZmin,IZmax, + Jsec,JU1,JU2,JV1,JV2,Iuvw(3), + NumSFspaceGroup,NumSections, + RHmin,RHmax,RHmean,NumSFsymm, + CellMtz(6),VolMtz,Volfft,F000 COMMON /TERSE/LverboseFlag,LNoScaleFlag COMMON /SRFCTL1/ + LSFcalcFlag,LSFrefFlag, + LatomMapFlag,LxyzInputFlag, + LhklInputFlag,LMapInFlag, + LSolvMaskFlag,LXyzOutputFlag C .. C KM1 = Kmax + 1 NZOV3 = NZ/3 C C---- Calculate dimensioning parameters C NSizePassOne = Size/ (2*NZ*KM1) IF (NSizePassOne .GT. (Hmax-Hmin+1)) + NSizePassOne = Hmax - Hmin + 1 NSizePassTwo = Size/ (NX*NY) C C---- Transform on k and write results on t2 C NumWords = 2*NX*KM1 C C ********************** CALL QSEEK(IOscratch,1,1,1) C ********************** C NumCurrentRecord = 0 Jrec = 0 R = Hmin 10 CONTINUE IF (R+NSizePassOne .GT.Hmax) + NSizePassOne = Hmax + 1 - R Jrec = Jrec + 1 C C----- Read in data option to read precalculated difference map C IF (LMapInFlag .EQ. 1) GO TO 15 C C ********************** CALL SFIPZ(X, + NZ, + KM1, + NSizePassOne, + R, + LCYC) C ********************** C IQ = R + NSizePassOne - 1 IF (LverboseFlag) WRITE (6,FMT=6000) R,IQ 6000 FORMAT (' Data read for H =',I4,' to ',I4) C C---- Temperature factor gradient C C *********************** IF (NPAR.EQ.4) CALL MULTBL(X, + 2*NZ, + KM1, + NSizePassOne, + Lmax, + Lmin, + R) C *********************** C D(1) = 2*NZ*KM1*NSizePassOne D(2) = 2 D(3) = D(1) D(4) = D(1) D(5) = 2*NZ C C ********************** CALL CMPLFT(X(1),X(2),NZ,D) C ********************** C KMX1 = KM1 C C ******************************** CALL OUT144(X, + NZ, + KMX1, + NSizePassOne, + PHI, + NX, + R, + IOscratch, + NumSFspaceGroup, + NumWords) C ******************************** C R = R + NSizePassOne IF (R.LE.Hmax .AND. Jrec.LT.Nslab) GO TO 10 IF (LverboseFlag) WRITE (6,FMT=6002) NumCurrentRecord 6002 FORMAT (' No of records on unit 63',I5) 15 CONTINUE NY2 = NY/2 C C---- zmin = 0, zmax = nz/3 -1 for First pass at map C NumCurrentRecord = 0 R = 0 20 CONTINUE IF (R+NSizePassTwo.GT.NZOV3-1) NSizePassTwo = NZOV3 - R C IF (LMapInFlag .EQ. 1) THEN SumDummy = 0.0 CALL REDMP2(X,NY,NX,NSizePassTwo,R,SumDummy) GO TO 35 END IF C C **************************** CALL ZIN(X, + NY2, + NX, + NSizePassTwo, + Kmax, + IOscratch, + NumCurrentRecord, + NumWords) C **************************** C D(1) = NX*NY*NSizePassTwo D(2) = NY D(3) = NY*NX D(4) = (Kmax+1)*2 D(5) = 2 C C ********************** CALL CMPLFT(X(1),X(2),NX,D) C ********************** C D(2) = 2 I = 1 D(4) = NX*NY D(5) = NY C C ************************* CALL HERMFT(X(I),X(I+1),NY2,D) C ************************* C 35 CONTINUE C C---- Calculate map from coordinates and use to produce gradients C C *********************** CALL GENDEN(X, + NY, + NX, + NSizePassTwo, + R, + NPAR, + DUMMY) C *********************** C R = R + NSizePassTwo IF (R.LE.NZOV3-1) GO TO 20 C C---- Gradients calculated C END C C ========================================= SUBROUTINE FFTGR146(X,PHI,Size,NPAR,LCYC) C ========================================= C C---- fourier synthesis for space group r3 C modified to calculate gradient maps C C .. Scalar Arguments .. INTEGER LCYC,NPAR,Size C .. C .. Array Arguments .. REAL PHI(Size/2),X(Size) C .. C .. Scalars in Common .. REAL RHmax,RHmean,RHmin,VolMtz INTEGER Hmax,Hmin,IOatomop,IOgradmat,IOhessian,IOmap,IOscratch, + IOshifts,IOxyzin,IOxyzoutunq,IXmax,IXmin,IYmax, + IYmin,IZmax,IZmin,Jsec,JU1,JU2,JV1,JV2,Kmax,Kmin,Lmax, + Lmin,Nslab,NumSections,NumSFspaceGroup,NumSFsymm,NX,NY,NZ LOGICAL LNoScaleFlag,LverboseFlag C .. C .. Arrays in Common .. REAL CellMtz INTEGER Iuvw C .. C .. Local Scalars .. REAL DUMMY INTEGER I,IQ,IX,IX1,IY,IY1,IZ,JARRY,JARRYX,JARRZ,Jrec,KM1,KMX1, + NSizePassOne,NSizePassTwo,NumCurrentRecord,NumWords, + NX2OV3,NXOV3,NY2,R C .. C .. Local Arrays .. INTEGER D(5) C .. C .. External Subroutines .. EXTERNAL CMPLFT,GENDEN,HERMFT,MULTBLR3,QSEEK,SFIPR3,ZIN C .. C .. Common blocks .. COMMON /HKLLIM/ + Hmax,Kmax,Lmax,Hmin,Kmin,Lmin,Nslab COMMON /IOSF/ + IOscratch,IOgradmat,IOhessian,IOshifts, + IOatomop,IOmap,IOxyzin,IOxyzoutunq COMMON /MPHDR/ + NX,NY,NZ, + IXmin,IXmax,IYmin,IYmax,IZmin,IZmax, + Jsec,JU1,JU2,JV1,JV2,Iuvw(3), + NumSFspaceGroup,NumSections, + RHmin,RHmax,RHmean,NumSFsymm, + CellMtz(6),VolMtz,Volfft,F000 COMMON /TERSE/LverboseFlag,LNoScaleFlag COMMON /SRFCTL1/ + LSFcalcFlag,LSFrefFlag, + LatomMapFlag,LxyzInputFlag, + LhklInputFlag,LMapInFlag, + LSolvMaskFlag,LXyzOutputFlag C .. C KM1 = Kmax + 1 NZVAL = NZ If(NumSFspaceGroup .Eq.146) NZVAL = NZ/3 C C---- calculate dimensioning parameters C NSizePassOne = Size/ (2*NZVAL*KM1) IF (NSizePassOne .GT. (Hmax-Hmin+1)) + NSizePassOne = Hmax - Hmin + 1 NSizePassTwo = Size/ (NX*NY) C C---- transform on k and write results on t2 C NumWords = 2*NX*KM1 IF (LMapInFlag .EQ. 1) GO TO 15 C C ********************** CALL QSEEK(IOscratch,1,1,1) C ********************** C NumCurrentRecord = 0 Jrec = 0 R = Hmin 20 CONTINUE IF (R+NSizePassOne .GT.Hmax) + NSizePassOne = Hmax + 1 - R Jrec = Jrec + 1 C C---- read in data C C *********************** If(NumSFspaceGroup .Eq.143) +CALL SFIPZ (X, + NZVAL, + KM1, + NSizePassOne, + R, + LCYC) If(NumSFspaceGroup .Eq.146) +CALL SFIPR3(X, + NZVAL, + KM1, + NSizePassOne, + R, + LCYC) C *********************** C IQ = R + NSizePassOne - 1 IF (LverboseFlag) WRITE (6,FMT=6002) R,IQ 6002 FORMAT (' Data read for H =',I4,' to ',I4) C C---- temperature factor gradient C C ************************* IF (NPAR.EQ.4.and.NumSFspaceGroup .Eq.143) + CALL MULTBL (X, + 2*NZVAL, + KM1, + NSizePassOne, + Lmax, + Lmin, + R) IF (NPAR.EQ.4.and.NumSFspaceGroup .Eq.146) + CALL MULTBLR3(X, + 2*NZVAL, + KM1, + NSizePassOne, + Lmax, + Lmin, + R) C ************************* C D(1) = 2*NZVAL*KM1*NSizePassOne D(2) = 2 D(3) = D(1) D(4) = D(1) D(5) = 2*NZVAL C C ************************* CALL CMPLFT(X(1),X(2),NZVAL,D) C ************************* C KMX1 = KM1 C C ************************* If(NumSFspaceGroup .Eq.143) +CALL OUT143(X, + NZVAL, + KMX1, + NSizePassOne, + PHI, + NX, + R, + IOscratch) If(NumSFspaceGroup .Eq.146) +CALL OUT146(X, + NZVAL, + KMX1, + NSizePassOne, + PHI, + NX, + R, + IOscratch) C ************************* C R = R + NSizePassOne IF (R.LE.Hmax .AND. Jrec.LT.Nslab) GO TO 20 15 CONTINUE NY2 = NY/2 C C---- zmin = 0, zmax = nz/3 -1 for R3 (or nz-1 for P3)for First pass at map C NumCurrentRecord = 0 R = 0 30 CONTINUE IF (R+NSizePassTwo.GT.NZVAL-1) NSizePassTwo = NZVAL - R C IF (LMapInFlag .EQ. 1) THEN SumDummy = 0.0 CALL REDMP2(X,NY,NX,NSizePassTwo,R,SumDummy) GO TO 35 END IF C C **************************** CALL ZIN(X, + NY2, + NX, + NSizePassTwo, + Kmax, + IOscratch, + NumCurrentRecord, + NumWords) C **************************** C D(1) = NX*NY*NSizePassTwo D(2) = NY D(3) = NY*NX D(4) = (Kmax+1)*2 D(5) = 2 C C ********************** CALL CMPLFT(X(1),X(2),NX,D) C ********************** C D(2) = 2 I = 1 D(4) = NX*NY D(5) = NY C C ************************ CALL HERMFT(X(I),X(I+1),NY2,D) C ************************ C C---- now put redundant points = 0 C for p3 and r3 simpler to do it here C NXOV3 = NX/3 NX2OV3 = 2*NXOV3 C DO 70 IZ = 1,NSizePassTwo JARRZ = (IZ-1)*NX*NY C DO 60 IX1 = 1,NX C C---- set one edge = 0 - x = 0.0 C IX = IX1 - 1 JARRYX = IX*NY + JARRZ C DO 50 IY1 = 1,NX IF (IX1.EQ.1) GO TO 40 IY = IY1 - 1 IF (IY.GE.NX2OV3 .OR. IX.GE.NX2OV3) GO TO 40 C C---- Sep 1990 - keep in these 2 edges of hexagon C IF (IY.LT.IX-NXOV3 .OR. IY.GT.IX+NXOV3) GO TO 40 GO TO 50 40 JARRY = JARRYX + IY1 X(JARRY) = 0.0 50 CONTINUE 60 CONTINUE 70 CONTINUE C C---- calculate map from coordinates and use to produce gradients C 35 CONTINUE DUMMY = 0.0 C C *********************** CALL GENDEN(X, + NY, + NX, + NSizePassTwo, + R, + NPAR, + DUMMY) C *********************** C R = R + NSizePassTwo IF (R.LE.NZVAL-1) GO TO 30 C C---- gradients calculated C END C C ========================================= SUBROUTINE FFTGR152(X,PHI,Size,NPAR,LCYC) C ========================================= C C---- Fourier synthesis for space group p41212 C modified to calculate gradient maps C C .. Scalar Arguments .. INTEGER LCYC,NPAR,Size C .. C .. Array Arguments .. REAL PHI(Size/2),X(Size) C .. C .. Scalars in Common .. REAL RHmax,RHmean,RHmin,VolMtz INTEGER Hmax,HmaxA,Hmin,HminA,IBLKNO,IOatomop,IOgradmat,IOhessian, + IOmap,IOscratch,IOshifts,IOxyzin,IOxyzoutunq,IXmax, + IXmin,IYmax,IYmin,IZmax,IZmin,Jsec,JU1,JU2,JV1,JV2,KHmin, + Kmax,Kmin,Lmax,Lmin,Nslab,NumSections,NumSFspaceGroup, + NumSFsymm,NX,NY,NZ LOGICAL LNoScaleFlag,LverboseFlag C .. C .. Arrays in Common .. REAL CellMtz INTEGER Iuvw C .. C .. Local Scalars .. REAL DUMMY INTEGER IHKA,IND,IX,IY,Jrec,KM1,KM2,NSizePassOne,NSizePassTwo, + NumCurrentRecord,NumWords,NZBY2,R C .. C .. Local Arrays .. INTEGER D(5) C .. C .. External Subroutines .. EXTERNAL CMPLFT,GENDEN,HERMFT,MLTBL152,OUT152,QSEEK,SFIPN2,ZIN C .. C .. Intrinsic Functions .. INTRINSIC INT,SQRT C .. C .. Common blocks .. COMMON /BLKNUM/ + IBLKNO COMMON /HKLLIM/ + Hmax,Kmax,Lmax,Hmin,Kmin,Lmin,Nslab COMMON /IOSF/ + IOscratch,IOgradmat,IOhessian,IOshifts, + IOatomop,IOmap,IOxyzin,IOxyzoutunq COMMON /MPHDR/ + NX,NY,NZ, + IXmin,IXmax,IYmin,IYmax,IZmin,IZmax, + Jsec,JU1,JU2,JV1,JV2,Iuvw(3), + NumSFspaceGroup,NumSections, + RHmin,RHmax,RHmean,NumSFsymm, + CellMtz(6),VolMtz,Volfft,F000 COMMON /P41212/ + HminA,HmaxA,KHmin COMMON /TERSE/ + LverboseFlag,LNoScaleFlag COMMON /SRFCTL1/ + LSFcalcFlag,LSFrefFlag, + LatomMapFlag,LxyzInputFlag, + LhklInputFlag,LMapInFlag, + LSolvMaskFlag,LXyzOutputFlag C .. C IBLKNO = 0 KM1 = Kmax + 1 KM2 = 2*Kmax + 2 NZBY2 = NZ*2 C C----- Calculate dimensioning parameters C NSizePassOne = Size/NZBY2 NSizePassTwo = Size/ (NX*NY) IF (LMapInFlag .EQ. 1) GO TO 15 C C---- Transform on l and write results on t2 C NumWords = 2*NX*KM1 C C ********************** CALL QSEEK(IOscratch,1,1,1) C ********************** C Jrec = 0 KHmin = 0 HminA = 0 20 CONTINUE C C---- want Hmaxa+1)*(Hmaxa+2)/2 .le. NSizePassOne + kHmin C HmaxA = INT(SQRT(9.0- (1-NSizePassOne-KHmin)*8.0) + + (-3.0))/2 IF (HmaxA.GT.Hmax) HmaxA = Hmax IHKA = (HmaxA+1)* (HmaxA+2)/2 - KHmin IHKA = ((IHKA+1)/2)*2 Jrec = Jrec + 1 C C---- Read in data Cccx ???? 5th arg was R should be HminA ????? C R = HminA C C ***************** CALL SFIPN2(X, + NZ, + IHKA, + 1, + R, + LCYC) C ***************** C IF (LverboseFlag) WRITE (6,FMT=6000) HminA,HmaxA 6000 FORMAT (' Data read for H =',I4,' to ',I4) C C---- Temperature factor gradient C C ************************ IF (NPAR.EQ.4) CALL MLTBL152(X,NZBY2,IHKA,1) C ************************ C C---- Z gradient C C p21 symmetry survives in gradient map C D(1) = NZBY2*IHKA D(2) = 2 D(3) = D(1) D(4) = D(1) D(5) = NZBY2 C C ********************** CALL CMPLFT(X(1),X(2),NZ,D) C ********************** C C ****************************** CALL OUT152(X, + NZ, + IHKA, + PHI, + KM1, + NX, + IOscratch, + NumSFspaceGroup, + NumWords) C ***************************** C HminA = HmaxA + 1 KHmin = (HmaxA+1)* (HmaxA+2)/2 IF (HminA.LE.Hmax .AND. Jrec.LT.Nslab) GO TO 20 15 CONTINUE NumCurrentRecord = IZmin R = IZmin C C---- write hkz results C calculate transforms on h and k, and write output C 30 CONTINUE IF (R+NSizePassTwo.GT.IZmax) + NSizePassTwo = IZmax - R + 1 C IF (LMapInFlag .EQ. 1) THEN SumDummy = 0.0 CALL REDMP2(X,NY,NX,NSizePassTwo,R,SumDummy) GO TO 35 END IF C C **************************** CALL ZIN(X, + NY/2, + NX, + NSizePassTwo, + Kmax, + IOscratch, + NumCurrentRecord, + NumWords) C **************************** C C---- transform on h C D(1) = NY*NX*NSizePassTwo D(2) = NY D(3) = NY*NX D(4) = KM2 D(5) = 2 C C---- gradient on x C C ********************** CALL CMPLFT(X(1),X(2),NX,D) C ********************** C D(2) = 2 D(4) = NX*NY D(5) = NY C C---- gradient on y C C *********************** CALL HERMFT(X(1),X(2),NY/2,D) C *********************** C C---- map calculated for NSizePassTwo sections C now put redundant points = 0 C IF (R.GT.0) GO TO 60 C C---- section z=0 C DO 50 IX = 1,NX - 1 IND = (IX-1)*NY DO 40 IY = IX,NY X(IND+IY) = 0.0 40 CONTINUE 50 CONTINUE C 60 IF (R+NSizePassTwo.LT.IZmax+1) GO TO 140 IF (NumSFspaceGroup.NE.152) GO TO 100 C C---- SECTION P3121 Z=1/6 use symmetries x,y,z -x,y-x,1/3-z C there is a two fold axis along y at z=1/6 C set all Y X=1/2+ -1 =0 C for x=1/2 put y 1/2-1 =0 C DO 80 IX = NX/2 + 2,NX IND = NX*NY* (NSizePassTwo-1) + (IX-1)*NY DO 70 IY = 1,NY X(IND+IY) = 0.0 70 CONTINUE 80 CONTINUE C IND = NX*NY* (NSizePassTwo-1) + (NX/2)*NY C DO 90 IY = NY/2 + 2,NY X(IND+IY) = 0.0 90 CONTINUE C GO TO 140 C C---- SECTION P3221 Z=1/6 use symmetries x,y,z x-y,-y,1/3-z C there is a two fold axis along x at z=1/6 C set all X Y=1/2+ -1 =0 C for y=1/2 put x 1/2-1 =0 C 100 CONTINUE C DO 120 IX = 1,NX IND = NX*NY* (NSizePassTwo-1) + (IX-1)*NY DO 110 IY = NY/2 + 2,NY X(IND+IY) = 0.0 110 CONTINUE 120 CONTINUE C DO 130 IX = NX/2 + 2,NX IND = NY*NX* (NSizePassTwo-1) + (IX-1)*NY X(IND+NY/2+1) = 0 130 CONTINUE 140 CONTINUE C 35 CONTINUE C C---- calculate map from coordinates and use to produce gradients C C *********************** CALL GENDEN(X, + NY, + NX, + NSizePassTwo, + R, + NPAR, + DUMMY) C *********************** C R = R + NSizePassTwo IF (R.LE.IZmax) GO TO 30 C C---- gradients calculated C END C C ========================================= SUBROUTINE FFTGR169(X,PHI,Size,NPAR,LCYC) C ========================================= C C--- fourier synthesis for space group P31 OR P32 C modified to calculate gradient maps C C test array Size,index limits etc. for space group p31/p32 C C .. Scalar Arguments .. INTEGER LCYC,NPAR,Size C .. C .. Array Arguments .. REAL PHI(Size/2),X(Size) C .. C .. Scalars in Common .. REAL RHmax,RHmean,RHmin,VolMtz INTEGER Hmax,Hmin,IOatomop,IOgradmat,IOhessian,IOmap,IOscratch, + IOshifts,IOxyzin,IOxyzoutunq,IXmax,IXmin,IYmax, + IYmin,IZmax,IZmin,Jsec,JU1,JU2,JV1,JV2,Kmax,Kmin,Lmax, + Lmin,Nslab,NumSections,NumSFspaceGroup,NumSFsymm,NX,NY,NZ LOGICAL LNoScaleFlag,LverboseFlag C .. C .. Arrays in Common .. REAL CellMtz INTEGER Iuvw C .. C .. Local Scalars .. REAL DUMMY INTEGER I,IQ,Jrec,KM1,NSizePassOne,NSizePassTwo, + NumCurrentRecord,NumWords,NY2,NZ21,NZOV6,NZP2,R C .. C .. Local Arrays .. INTEGER D(5) C .. C .. External Subroutines .. EXTERNAL CMPLFT,GENDEN,HERMFT,MULTBL,OUT169,QSEEK,SDIAD,SFIPZ,ZIN C .. C .. Common blocks .. COMMON /HKLLIM/ + Hmax,Kmax,Lmax,Hmin,Kmin,Lmin,Nslab COMMON /IOSF/ + IOscratch,IOgradmat,IOhessian,IOshifts, + IOatomop,IOmap,IOxyzin,IOxyzoutunq COMMON /MPHDR/ + NX,NY,NZ, + IXmin,IXmax,IYmin,IYmax,IZmin,IZmax, + Jsec,JU1,JU2,JV1,JV2,Iuvw(3), + NumSFspaceGroup,NumSections, + RHmin,RHmax,RHmean,NumSFsymm, + CellMtz(6),VolMtz,Volfft,F000 COMMON /TERSE/ + LverboseFlag,LNoScaleFlag COMMON /SRFCTL1/ + LSFcalcFlag,LSFrefFlag, + LatomMapFlag,LxyzInputFlag, + LhklInputFlag,LMapInFlag, + LSolvMaskFlag,LXyzOutputFlag C .. C IF (LverboseFlag) WRITE (6,FMT=6000) NX,NY,NZ 6000 FORMAT (' Check fftgr NX NY NZ ',3I5) C KM1 = Kmax + 1 NZ21 = NZ/2 + 1 NZP2 = NZ + 2 NZOV6 = NZ/6 C C---- calculate dimensioning parameters C NSizePassOne = Size/ ((2+NZ)*KM1) IF (NSizePassOne.GT. (Hmax-Hmin+1)) + NSizePassOne = Hmax - Hmin + 1 NSizePassTwo = Size/ (NX*NY) IF (LMapInFlag .EQ. 1) GO TO 15 C C---- transform on k and write results on t2 C NumWords = 2*NX*KM1 C C ********************** CALL QSEEK(IOscratch,1,1,1) C ********************** C NumCurrentRecord = 0 Jrec = 0 R = Hmin 10 CONTINUE IF (R+NSizePassOne.GT.Hmax) + NSizePassOne = Hmax + 1 - R Jrec = Jrec + 1 C C---- read in data C C ********************** CALL SFIPZ(X, + NZ21, + KM1, + NSizePassOne, + R, + LCYC) C ********************** C IF (LverboseFlag) WRITE (6,FMT=6000) NX,NY,NZ IQ = R + NSizePassOne - 1 IF (LverboseFlag) WRITE (6,FMT=6002) R,IQ 6002 FORMAT (' Data read for H =',I4,' to ',I4) C C---- temperature factor gradient C C *********************** IF (NPAR.EQ.4) CALL MULTBL(X, + NZP2, + KM1, + NSizePassOne, + Lmax, + Lmin, + R) C *********************** C IF (LverboseFlag) WRITE (6,FMT=6000) NX,NY,NZ D(1) = (NZ+2)*KM1*NSizePassOne D(2) = 2 D(3) = D(1) D(4) = D(1) D(5) = NZ + 2 C C *********************** CALL SDIAD(X(1),X(2),NZ/2,D) CALL OUT169(X, + NZ21, + KM1, + NSizePassOne, + PHI, + NX, + R, + IOscratch, + NumSFspaceGroup) C ******************************** C R = R + NSizePassOne IF (R.LE.Hmax .AND. Jrec.LT.Nslab) GO TO 10 IF (LverboseFlag) WRITE (6,FMT=6004) NumCurrentRecord 6004 FORMAT (' No of records on unit 63',I5) 15 CONTINUE NY2 = NY/2 C C---- zmin = 0, zmax = nz/3 -1 for First pass at map C NumCurrentRecord = 0 R = 0 20 CONTINUE IF (R+NSizePassTwo.GT.NZOV6-1) NSizePassTwo = NZOV6 - R C IF (LMapInFlag .EQ. 1) THEN SumDummy = 0.0 CALL REDMP2(X,NY,NX,NSizePassTwo,R,SumDummy) GO TO 35 END IF C C **************************** CALL ZIN(X, + NY2, + NX, + NSizePassTwo, + Kmax, + IOscratch, + NumCurrentRecord, + NumWords) C **************************** C D(1) = NX*NY*NSizePassTwo D(2) = NY D(3) = NY*NX D(4) = (Kmax+1)*2 D(5) = 2 C C ********************** CALL CMPLFT(X(1),X(2),NX,D) C ********************** C D(2) = 2 I = 1 D(4) = NX*NY D(5) = NY C C ************************* CALL HERMFT(X(I),X(I+1),NY2,D) C ************************* C 35 CONTINUE C C---- calculate map from coordinates and use to produce gradients C C *********************** CALL GENDEN(X, + NY, + NX, + NSizePassTwo, + R, + NPAR, + DUMMY) C *********************** C R = R + NSizePassTwo IF (R.LE.NZOV6-1) GO TO 20 C C---- gradients calculated C END C C ==================================== SUBROUTINE FFTGR18(X,Size,NPAR,LCYC) C ==================================== C C---- fourier synthesis for space group p212121 C modified to calculate gradient maps for p21 C C .. Scalar Arguments .. INTEGER LCYC,NPAR,Size C .. C .. Array Arguments .. REAL X(Size) C .. C .. Scalars in Common .. REAL RHmax,RHmean,RHmin,VolMtz INTEGER Hmax,Hmin,IOatomop,IOgradmat,IOhessian,IOmap,IOscratch, + IOshifts,IOxyzin,IOxyzoutunq,IXmax,IXmin,IYmax, + IYmin,IZmax,IZmin,Jsec,JU1,JU2,JV1,JV2,Kmax,Kmin,Lmax, + Lmin,Nslab,NumSections,NumSFspaceGroup,NumSFsymm,NX,NY,NZ LOGICAL LNoScaleFlag,LverboseFlag C .. C .. Arrays in Common .. REAL CellMtz INTEGER Iuvw C .. C .. Local Scalars .. REAL DUMMY INTEGER I,IND,IQ,IX,IZ,Jrec,LM1,NSizePassOne,NSizePassTwo, + NumCurrentRecord,NumMaxRecord,NumSkipRecords,NumWords,R, + RECS C .. C .. Local Arrays .. INTEGER D(5) C .. C .. External Subroutines .. EXTERNAL CMPLFT,GENDEN,HERMFT,MULTBK,QSEEK,SDIAD,SFIPY,TRNSP3, + YIN5,YOUT2 C .. C .. Common blocks .. COMMON /HKLLIM/ + Hmax,Kmax,Lmax,Hmin,Kmin,Lmin,Nslab COMMON /IOSF/ + IOscratch,IOgradmat,IOhessian,IOshifts, + IOatomop,IOmap,IOxyzin,IOxyzoutunq COMMON /MPHDR/ + NX,NY,NZ, + IXmin,IXmax,IYmin,IYmax,IZmin,IZmax, + Jsec,JU1,JU2,JV1,JV2,Iuvw(3), + NumSFspaceGroup,NumSections, + RHmin,RHmax,RHmean,NumSFsymm, + CellMtz(6),VolMtz,Volfft,F000 COMMON /TERSE/ + LverboseFlag,LNoScaleFlag COMMON /SRFCTL1/ + LSFcalcFlag,LSFrefFlag, + LatomMapFlag,LxyzInputFlag, + LhklInputFlag,LMapInFlag, + LSolvMaskFlag,LXyzOutputFlag C .. C LM1 = Lmax + 1 C C---- calculate dimensioning parameters C NSizePassOne = Size/ ((NY+2)*LM1) NSizePassTwo = Size/ (NX*NZ) IF (LMapInFlag .EQ. 1) GO TO 15 C C---- transform on k and write results on t2 C NumWords = 2*NSizePassOne*NSizePassTwo*LM1 C C ********************** CALL QSEEK(IOscratch,1,1,1) C ********************** C NumCurrentRecord = 0 Jrec = 0 R = Hmin 10 CONTINUE IF (R+NSizePassOne.GT.Hmax) + NSizePassOne = Hmax + 1 - R Jrec = Jrec + 1 C C---- read in data C C ********************** CALL SFIPY(X, + NY/2+1, + LM1, + NSizePassOne, + R, + LCYC) C ********************** C IQ = R + NSizePassOne - 1 IF (LverboseFlag) WRITE (6,FMT=6000) R,IQ 6000 FORMAT (' Data read for H =',I4,' to ',I4) C C---- temperature factor gradient C C *********************** IF (NPAR.EQ.4) CALL MULTBK(X, + NY+2, + LM1, + NSizePassOne, + Kmax, + Kmin, + R) C *********************** C C---- Y gradient C PASS ONE. transform on k and write intermediate results on t2. C IF (R+NSizePassOne.GT.Hmax) NSizePassOne = Hmax + 1 - R D(1) = (NY+2)* (Lmax+1)*NSizePassOne D(2) = 2 D(3) = D(1) D(4) = D(1) D(5) = NY + 2 C C ******************************* CALL SDIAD(X(1), + X(2), + NY/2, + D) CALL YOUT2(X, + NY/2+1, + Lmax+1, + NSizePassOne, + NSizePassTwo, + IYmin, + IYmax, + IOscratch, + NumCurrentRecord, + NumWords) CALL TRNSP3(X, + NY/2+1, + LM1, + NSizePassOne, + R) CALL YOUT2(X, + NY/2+1, + Lmax+1, + NSizePassOne, + NSizePassTwo, + IYmin, + IYmax, + IOscratch, + NumCurrentRecord, + NumWords) C ******************************* C R = R + NSizePassOne IF (R.LE.Hmax .AND. Jrec.LT.Nslab) GO TO 10 C C---- END OF PASS 1. pass 2 reads back the intermediate results, C calculates the transforms on h and l,and writes out the final C y sections. C 15 CONTINUE NSizePassOne = Size/ ((NY+2)* (Lmax+1)) NumSkipRecords = 0 NumMaxRecord = NumCurrentRecord RECS = (IYmax-IYmin)/NSizePassTwo R = IYmin 20 CONTINUE NumCurrentRecord = 1 IF (R+NSizePassTwo.GT.IYmax) + NSizePassTwo = IYmax - R + 1 C IF (LMapInFlag .EQ. 1) THEN SumDummy = 0.0 CALL REDMP2(X,NZ,NX,NSizePassTwo,R,SumDummy) GO TO 35 END IF C C ******************************** CALL YIN5(X, + NZ/2, + NX, + NSizePassTwo, + Hmax, + Lmax, + NSizePassOne, + NumSkipRecords, + RECS, + IOscratch, + NumCurrentRecord, + NumMaxRecord, + NumWords) C ******************************** C NumSkipRecords = NumSkipRecords + 1 C C---- X now contains intermediate results stored with l down the C columns and h across the rows. C D(1) = NX*NZ*NSizePassTwo D(2) = NZ D(3) = NX*NZ D(4) = (Lmax+1)*2 D(5) = 2 C C---- gradient on x C C ********************* CALL CMPLFT(X(1),X(2),NX,D) C ********************* C D(2) = 2 D(4) = (IXmax-IXmin+1)*NZ D(5) = NZ I = IXmin*NZ + 1 C C---- gradient on z C C ************************** CALL HERMFT(X(I),X(I+1),NZ/2,D) C ************************** C C---- map calculated for p2 sections C now put redundant points = 0 C IF (R.GT.0) GO TO 50 C C---- section y=0 use symmetries x,y,z 1/2+x,-y,-z C set all z and x=1/2 - 1 =0 C DO 40 IX = NX/2 + 1,NX IND = (IX-1)*NZ DO 30 IZ = 1,NZ X(IND+IZ) = 0.0 30 CONTINUE 40 CONTINUE C 50 IF (R+NSizePassTwo.LT.IYmax+1) GO TO 80 C C---- section y=1/4 use symmetries x,y,z 1/2-x,1/2-y,z C set all z and x=1/4+ - 3/4- =0 C DO 70 IX = NX/4 + 2,3*NX/4 IND = NZ*NX* (NSizePassTwo-1) + (IX-1)*NZ DO 60 IZ = 1,NZ X(IND+IZ) = 0.0 60 CONTINUE 70 CONTINUE 80 CONTINUE 35 CONTINUE C C---- calculate map from coordinates and use to produce gradients C C *********************** CALL GENDEN(X, + NZ, + NX, + NSizePassTwo, + R, + NPAR, + DUMMY) C *********************** C R = R + NSizePassTwo IF (R.LE.IYmax) GO TO 20 C C---- gradients calculated C END C C ==================================== SUBROUTINE FFTGR19(X,Size,NPAR,LCYC) C ==================================== C C---- fourier synthesis for space group p212121 C modified to calculate gradient maps C C .. Scalar Arguments .. INTEGER LCYC,NPAR,Size C .. C .. Array Arguments .. REAL X(Size) C .. C .. Scalars in Common .. REAL RHmax,RHmean,RHmin,VolMtz INTEGER Hmax,Hmin,IBLKNO,IOatomop,IOgradmat,IOhessian,IOmap, + IOscratch,IOshifts,IOxyzin,IOxyzoutunq,IXmax,IXmin, + IYmax,IYmin,IZmax,IZmin,Jsec,JU1,JU2,JV1,JV2,Kmax,Kmin, + Lmax,Lmin,Nslab,NumSections,NumSFspaceGroup,NumSFsymm,NX, + NY,NZ LOGICAL LNoScaleFlag,LverboseFlag C .. C .. Arrays in Common .. REAL CellMtz INTEGER Iuvw C .. C .. Local Scalars .. REAL DUMMY INTEGER IND,IQ,IX,IY,Jrec,KM1,KM2,NPassOneSave,NSizePassOne, + NSizePassTwo,NumCurrentRecord,NumSkipRecords,NumWords, + NZ21,NZP2,R,RECS C .. C .. Local Arrays .. INTEGER D(5) C .. C .. External Subroutines .. EXTERNAL CMPLFT,DIVI,GENDEN,HERMFT,MULTBL,MULTI,QSEEK,SDIAD,SFIPZ, + TRNSP2,ZIN4,ZOUT2 C .. C .. Common blocks .. COMMON /BLKNUM/ + IBLKNO COMMON /HKLLIM/ + Hmax,Kmax,Lmax,Hmin,Kmin,Lmin,Nslab COMMON /IOSF/ + IOscratch,IOgradmat,IOhessian,IOshifts, + IOatomop,IOmap,IOxyzin,IOxyzoutunq COMMON /MPHDR/ + NX,NY,NZ, + IXmin,IXmax,IYmin,IYmax,IZmin,IZmax, + Jsec,JU1,JU2,JV1,JV2,Iuvw(3), + NumSFspaceGroup,NumSections, + RHmin,RHmax,RHmean,NumSFsymm, + CellMtz(6),VolMtz,Volfft,F000 COMMON /TERSE/ + LverboseFlag,LNoScaleFlag COMMON /SRFCTL1/ + LSFcalcFlag,LSFrefFlag, + LatomMapFlag,LxyzInputFlag, + LhklInputFlag,LMapInFlag, + LSolvMaskFlag,LXyzOutputFlag C .. C IBLKNO = 0 KM1 = Kmax + 1 KM2 = 2*Kmax + 2 NZ21 = NZ/2 + 1 NZP2 = NZ + 2 C C---- calculate dimensioning parameters C NSizePassOne = Size/ (NZP2*KM1) IF (NSizePassOne.GT. (Hmax-Hmin+1)) + NSizePassOne = Hmax - Hmin + 1 NPassOneSave = NSizePassOne NSizePassTwo = Size/ (NX*NY) IF (LMapInFlag .EQ. 1) GO TO 15 C C---- transform on l and write results on t2 C NumWords = 2*NSizePassOne*NSizePassTwo*KM1 C C ********************** CALL QSEEK(IOscratch,1,1,1) C ********************** C NumCurrentRecord = 0 Jrec = 0 R = 0 10 CONTINUE IF (R+NSizePassOne.GT.Hmax) + NSizePassOne = Hmax + 1 - R Jrec = Jrec + 1 C C---- read in data C C ********************** CALL SFIPZ(X, + NZ21, + KM1, + NSizePassOne, + R, + LCYC) C ********************** C IQ = R + NSizePassOne - 1 IF (LverboseFlag) WRITE (6,FMT=6000) R,IQ 6000 FORMAT (' Data read for H =',I4,' to ',I4) C C---- temperature factor gradient C C *********************** IF (NPAR.EQ.4) CALL MULTBL(X, + NZP2, + KM1, + NSizePassOne, + Lmax, + Lmin, + R) C *********************** C C ********************** CALL MULTI(X, + NZP2, + KM1, + NSizePassOne, + Lmax, + R) C ********************** C D(1) = NZP2*KM1*NSizePassOne D(2) = 2 D(3) = D(1) D(4) = D(1) D(5) = NZP2 C C ********************* CALL SDIAD(X(1), + X(2), + NZ/2, + D) CALL DIVI(X, + NZP2, + KM1, + NSizePassOne, + R) C ********************* C C---- write hkz results C C ******************************* CALL ZOUT2(X, + NZ21, + KM1, + NSizePassOne, + NSizePassTwo, + IZmin, + IZmax, + IOscratch, + NumCurrentRecord, + NumWords) CALL TRNSP2(X, + NZ21, + KM1, + NSizePassOne) C ******************************* C C---- write -hkz results C C ******************************* CALL ZOUT2(X, + NZ21, + KM1, + NSizePassOne, + NSizePassTwo, + IZmin, + IZmax, + IOscratch, + NumCurrentRecord, = NumWords) C ******************************* C R = R + NSizePassOne IF (R.LE.Hmax .AND. Jrec.LT.Nslab) GO TO 10 C C---- calculate transforms on h and k, and write output C 15 CONTINUE NSizePassOne = NPassOneSave RECS = (IZmax-IZmin)/NSizePassTwo NumSkipRecords = 0 R = IZmin 20 CONTINUE NumCurrentRecord = 1 IF (R+NSizePassTwo.GT.IZmax) + NSizePassTwo = IZmax - R + 1 C IF (LMapInFlag .EQ. 1) THEN SumDummy = 0.0 CALL REDMP2(X,NY,NX,NSizePassTwo,R,SumDummy) GO TO 35 END IF C C ******************************** CALL ZIN4(X, + NY/2, + NX, + NSizePassTwo, + Hmax, + Kmax, + NSizePassOne, + NumSkipRecords, + RECS, + IOscratch, + NumCurrentRecord, + NumWords) C ******************************** C NumSkipRecords = NumSkipRecords + 1 C C---- transform on h C D(1) = NY*NX*NSizePassTwo D(2) = NY D(3) = NY*NX D(4) = KM2 D(5) = 2 C C---- gradient on x C C ********************** CALL CMPLFT(X(1),X(2),NX,D) C ********************** C D(2) = 2 D(3) = D(1) D(4) = D(1) D(5) = NY C C---- gradient on y C C ************************ CALL HERMFT(X(1),X(2),NY/2,D) C ************************ C C---- map calculated for NSizePassTwo sections C now put redundant points = 0 C IF (R.GT.0) GO TO 50 C C---- section z=0 use symmetries x,y,z 1/2+x,1/2-y,-z C set all y and x=1/2 - 1 =0 C DO 40 IX = NX/2 + 1,NX IND = (IX-1)*NY DO 30 IY = 1,NY X(IND+IY) = 0.0 30 CONTINUE 40 CONTINUE C 50 IF (R+NSizePassTwo.LT.IZmax+1) GO TO 80 C C---- section z=1/4 use symmetries x,y,z -x,1/2+y,1/2-z C set all x and y=1/2 - 1 =0 C DO 70 IX = 1,NX IND = NX*NY* (NSizePassTwo-1) + (IX-1)*NY DO 60 IY = NY/2 + 1,NY X(IND+IY) = 0.0 60 CONTINUE 70 CONTINUE 80 CONTINUE 35 CONTINUE C C---- calculate map from coordinates and use to produce gradients C C *********************** CALL GENDEN(X, + NY, + NX, + NSizePassTwo, + R, + NPAR, + DUMMY) C *********************** C R = R + NSizePassTwo IF (R.LE.IZmax) GO TO 20 C C---- gradients calculated C END C C =================================== SUBROUTINE FFTGR4(X,Size,NPAR,LCYC) C =================================== C C---- Fourier synthesis for space group p212121 C modified to calculate gradient maps for p21 C C .. Scalar Arguments .. INTEGER LCYC,NPAR,Size C .. C .. Array Arguments .. REAL X(Size) C .. C .. Scalars in Common .. REAL RHmax,RHmean,RHmin,VolMtz INTEGER Hmax,Hmin,IOatomop,IOgradmat,IOhessian,IOmap,IOscratch, + IOshifts,IOxyzin,IOxyzoutunq,IXmax,IXmin,IYmax, + IYmin,IZmax,IZmin,Jsec,JU1,JU2,JV1,JV2,Kmax,Kmin,Lmax, + Lmin,Nslab,NumSections,NumSFspaceGroup,NumSFsymm,NX,NY,NZ LOGICAL LNoScaleFlag,LverboseFlag C .. C .. Arrays in Common .. REAL CellMtz INTEGER Iuvw C .. C .. Local Scalars .. REAL DUMMY INTEGER I,IQ,Jrec,LM1,NPassOneSave,NSizePassOne,NSizePassTwo, + NumCurrentRecord,NumMaxRecord,NumSkipRecords,NumWords,R, + RECS C .. C .. Local Arrays .. INTEGER D(5) C .. C .. External Subroutines .. EXTERNAL CMPLFT,GENDEN,HERMFT,MULTBK,QSEEK,SDIAD,SFIPY,YIN2,YOUT2 C .. C .. Common blocks .. COMMON /HKLLIM/ + Hmax,Kmax,Lmax,Hmin,Kmin,Lmin,Nslab COMMON /IOSF/ + IOscratch,IOgradmat,IOhessian,IOshifts, + IOatomop,IOmap,IOxyzin,IOxyzoutunq COMMON /MPHDR/ + NX,NY,NZ, + IXmin,IXmax,IYmin,IYmax,IZmin,IZmax, + Jsec,JU1,JU2,JV1,JV2,Iuvw(3), + NumSFspaceGroup,NumSections, + RHmin,RHmax,RHmean,NumSFsymm, + CellMtz(6),VolMtz,Volfft,F000 COMMON /TERSE/ + LverboseFlag,LNoScaleFlag COMMON /SRFCTL1/ + LSFcalcFlag,LSFrefFlag, + LatomMapFlag,LxyzInputFlag, + LhklInputFlag,LMapInFlag, + LSolvMaskFlag,LXyzOutputFlag C .. C LM1 = Lmax + 1 C C---- calculate dimensioning parameters C NSizePassOne = Size/ ((NY+2)*LM1) IF (NSizePassOne.GT. (Hmax-Hmin+1)) + NSizePassOne = Hmax - Hmin + 1 NPassOneSave = NSizePassOne NSizePassTwo = Size/ (NX*NZ) IF (LMapInFlag .EQ. 1) GO TO 15 C C---- transform on k and write results on t2 C NumWords = 2*NSizePassOne*NSizePassTwo*LM1 C C ********************** CALL QSEEK(IOscratch,1,1,1) C ********************** C NumCurrentRecord = 0 Jrec = 0 R = Hmin 10 CONTINUE IF (R+NSizePassOne.GT.Hmax) + NSizePassOne = Hmax + 1 - R Jrec = Jrec + 1 C C---- read in data C C ********************** CALL SFIPY(X, + NY/2+1, + LM1, + NSizePassOne, + R, + LCYC) C ********************** C IQ = R + NSizePassOne - 1 IF (LverboseFlag) WRITE (6,FMT=6000) R,IQ 6000 FORMAT (' Data read for H =',I4,' to ',I4) C C---- temperature factor gradient C C *********************** IF (NPAR.EQ.4) CALL MULTBK(X, + NY+2, + LM1, + NSizePassOne, + Kmax, + Kmin, + R) C *********************** C C---- Pass one. transform on k and write intermediate results on t2. C IF (R+NSizePassOne.GT.Hmax) + NSizePassOne = Hmax + 1 - R D(1) = (NY+2)* (Lmax+1)*NSizePassOne D(2) = 2 D(3) = D(1) D(4) = D(1) D(5) = NY + 2 C C ******************************* CALL SDIAD(X(1), + X(2), + NY/2, + D) CALL YOUT2(X, + NY/2+1, + Lmax+1, + NSizePassOne, + NSizePassTwo, + IYmin, + IYmax, + IOscratch, + NumCurrentRecord, + NumWords) C ******************************* C R = R + NSizePassOne IF (R.LE.Hmax .AND. Jrec.LT.Nslab) GO TO 10 C C----- end of pass 1. pass 2 reads back the intermediate results, C calculates the transforms on h and l, and writes out the final C y sections. C 15 CONTINUE NSizePassOne = NPassOneSave NumSkipRecords = 0 NumMaxRecord = NumCurrentRecord RECS = (IYmax-IYmin)/NSizePassTwo R = IYmin 20 CONTINUE NumCurrentRecord = 1 IF (R+NSizePassTwo.GT.IYmax) + NSizePassTwo = IYmax - R + 1 C IF (LMapInFlag .EQ. 1) THEN SumDummy = 0.0 CALL REDMP2(X,NZ,NX,NSizePassTwo,R,SumDummy) GO TO 35 END IF C C ******************************** CALL YIN2(X, + NZ/2, + NX, + NSizePassTwo, + Hmax, + Lmax, + NSizePassOne, + NumSkipRecords, + RECS, + IOscratch, + NumCurrentRecord, + NumMaxRecord, + NumWords) C ******************************** C NumSkipRecords = NumSkipRecords + 1 C C---- x now contains intermediate results stored with l down the C columns and h across the rows. C D(1) = NX*NZ*NSizePassTwo D(2) = NZ D(3) = NX*NZ D(4) = (Lmax+1)*2 D(5) = 2 C C---- gradient on x C C ********************** CALL CMPLFT(X(1),X(2),NX,D) C ********************** C D(2) = 2 D(4) = (IXmax-IXmin+1)*NZ D(5) = NZ I = IXmin*NZ + 1 C C ************************** CALL HERMFT(X(I),X(I+1),NZ/2,D) C ************************** C 35 CONTINUE C C---- calculate map from coordinates and use to produce gradients C C *********************** CALL GENDEN(X, + NZ, + NX, + NSizePassTwo, + R, + NPAR, + DUMMY) C *********************** C R = R + NSizePassTwo IF (R.LE.IYmax) GO TO 20 C C---- gradients calculated C END C C ======================================== SUBROUTINE FFTGR92(X,PHI,Size,NPAR,LCYC) C ======================================== C C---- fourier synthesis for space group p41212 C modified to calculate gradient maps C C .. Scalar Arguments .. INTEGER LCYC,NPAR,Size C .. C .. Array Arguments .. REAL PHI(Size/2),X(Size) C .. C .. Scalars in Common .. REAL RHmax,RHmean,RHmin,VolMtz INTEGER Hmax,HmaxA,Hmin,HminA,IOatomop,IOgradmat,IOhessian,IOmap, + IOscratch,IOshifts,IOxyzin,IOxyzoutunq,IXmax,IXmin, + IYmax,IYmin,IZmax,IZmin,Jsec,JU1,JU2,JV1,JV2,KHmin,Kmax, + Kmin,Lmax,Lmin,Nslab,NumSections,NumSFspaceGroup, + NumSFsymm,NX,NY,NZ LOGICAL LNoScaleFlag,LverboseFlag C .. C .. Arrays in Common .. REAL CellMtz INTEGER Iuvw C .. C .. Local Scalars .. REAL DUMMY INTEGER IHKA,IND,IX,IY,Jrec,KM1,KM2,NSizePassOne,NSizePassTwo, + NumCurrentRecord,NumWords,NZ21,NZP2,R C .. C .. Local Arrays .. INTEGER D(5) C .. C .. External Subroutines .. EXTERNAL CMPLFT,GENDEN,HERMFT,MLTBL92,QSEEK,SDIAD,SFIPN2,YOUT92, + ZIN C .. C .. Intrinsic Functions .. INTRINSIC INT,SQRT C .. C .. Common blocks .. COMMON /HKLLIM/ + Hmax,Kmax,Lmax,Hmin,Kmin,Lmin,Nslab COMMON /IOSF/ + IOscratch,IOgradmat,IOhessian,IOshifts, + IOatomop,IOmap,IOxyzin,IOxyzoutunq COMMON /MPHDR/ + NX,NY,NZ, + IXmin,IXmax,IYmin,IYmax,IZmin,IZmax, + Jsec,JU1,JU2,JV1,JV2,Iuvw(3), + NumSFspaceGroup,NumSections, + RHmin,RHmax,RHmean,NumSFsymm, + CellMtz(6),VolMtz,Volfft,F000 COMMON /P41212/ + HminA,HmaxA,KHmin COMMON /TERSE/ + LverboseFlag,LNoScaleFlag COMMON /SRFCTL1/ + LSFcalcFlag,LSFrefFlag, + LatomMapFlag,LxyzInputFlag, + LhklInputFlag,LMapInFlag, + LSolvMaskFlag,LXyzOutputFlag C .. C C ********************** CALL QSEEK(IOscratch,1,1,1) C ********************** C KM1 = Kmax + 1 KM2 = 2*Kmax + 2 NZ21 = NZ/2 + 1 NZP2 = NZ + 2 C C---- calculate dimensioning parameters C NSizePassOne = Size/NZP2 NSizePassTwo = Size/ (NX*NY) IF (LMapInFlag .EQ. 1) GO TO 15 C C---- transform on l and write results on t2 C NumWords = 2*NX*KM1 Jrec = 0 KHmin = 0 HminA = 0 10 CONTINUE C C---- want Hmaxa+1)*(Hmaxa+2)/2 .le. NSizePassOne + kHmin C HmaxA = INT(SQRT(9.0- (1-NSizePassOne-KHmin)*8.0) + + (-3.0))/2 IF (HmaxA.GT.Hmax) HmaxA = Hmax IHKA = (HmaxA+1)* (HmaxA+2)/2 - KHmin IHKA = ((IHKA+1)/2)*2 Jrec = Jrec + 1 C C---- read in data C C ***************** CALL SFIPN2(X, + NZ21, + IHKA, + 1, + HminA, + LCYC) C ***************** C IF (LverboseFlag) WRITE (6,FMT=6000) HminA,HmaxA 6000 FORMAT (' Data read for H =',I4,' to ',I4) C C---- temperature factor gradient C C ****************** IF (NPAR.EQ.4) CALL MLTBL92(X, + NZP2, + IHKA, + 1) C ****************** C C---- p21 symmetry survives in gradient map C D(1) = NZP2*IHKA D(2) = 2 D(3) = D(1) D(4) = D(1) D(5) = NZP2 C C ******************************* CALL SDIAD(X(1), + X(2), + NZ/2, + D) CALL YOUT92(X, + NZ21, + IHKA, + PHI, + KM1, + NX, + NZ, + IOscratch, + NumSFspaceGroup, + NumWords) C ******************************* C HminA = HmaxA + 1 KHmin = (HmaxA+1)* (HmaxA+2)/2 IF (HminA.LE.Hmax .AND. Jrec.LT.Nslab) GO TO 10 C C---- calculate transforms on h and k, and write output C 15 CONTINUE NumCurrentRecord = IZmin R = IZmin 20 CONTINUE IF (R+NSizePassTwo.GT.IZmax) + NSizePassTwo = IZmax - R + 1 C IF (LMapInFlag .EQ. 1) THEN SumDummy = 0.0 CALL REDMP2(X,NY,NX,NSizePassTwo,R,SumDummy) GO TO 35 END IF C C **************************** CALL ZIN(X, + NY/2, + NX, + NSizePassTwo, + Kmax, + IOscratch, + NumCurrentRecord, + NumWords) C **************************** C C---- transform on h C D(1) = NY*NX*NSizePassTwo D(2) = NY D(3) = NY*NX D(4) = KM2 D(5) = 2 C C ********************* CALL CMPLFT(X(1),X(2),NX,D) C ********************* C D(2) = 2 D(4) = NX*NY D(5) = NY C C ************************ CALL HERMFT(X(1),X(2),NY/2,D) C ************************ C C---- map calculated for NSizePassTwo sections C IF (R.GT.0) GO TO 50 C C---- section z=0 C DO 40 IX = 1,NX - 1 IND = (IX-1)*NY DO 30 IY = IX,NY X(IND+IY) = 0.0 30 CONTINUE 40 CONTINUE C 50 IF (R+NSizePassTwo.LT.IZmax+1) GO TO 110 IF (NumSFspaceGroup.NE.92) GO TO 80 C C---- section p41212 z=1/8 set all x y=1/2-1 =0 C section p4122 P4322 z=1/8 set all x y=1/2-1 =0 also. C DO 70 IX = 1,NX IND = NX*NY* (NSizePassTwo-1) + (IX-1)*NY DO 60 IY = NY/2 + 1,NY X(IND+IY) = 0.0 60 CONTINUE 70 CONTINUE C GO TO 110 C C---- z=1/8 p43212 set x=1/2-1 all y =0 C 80 CONTINUE DO 100 IX = NX/2 + 1,NX IND = NX*NY* (NSizePassTwo-1) + (IX-1)*NY DO 90 IY = 1,NY X(IND+IY) = 0.0 90 CONTINUE 100 CONTINUE 110 CONTINUE 35 CONTINUE C C---- calculate map from coordinates and use to produce gradients C C *********************** CALL GENDEN(X, + NY, + NX, + NSizePassTwo, + R, + NPAR, + DUMMY) C *********************** C R = R + NSizePassTwo IF (R.LE.IZmax) GO TO 20 C C---- gradients calculated C END C C ================================================= SUBROUTINE FILEO(ISize,NSizePassOne,NSizePassTwo, + Nwords,NrecS) C ================================================= C C Print information about Size of intermediate passes in C Fourier calculation and open dNumCurrentRecordt access scratch file C C .. Scalar Arguments .. INTEGER ISize,NrecS,NSizePassOne,NSizePassTwo,Nwords C .. C .. Scalars in Common .. LOGICAL LNoScaleFlag,LverboseFlag C .. C .. Local Scalars .. INTEGER Nbytes C .. C .. External Subroutines .. EXTERNAL CCPERR C .. C .. Common blocks .. COMMON /TERSE/ + LverboseFlag,LNoScaleFlag C .. C Nbytes = Nwords*4 C IF (LverboseFlag) WRITE (6,FMT=6000) + ISize, + NSizePassOne, + NSizePassTwo, + NrecS, + Nwords, + Nbytes 6000 FORMAT (/, +' Size of Working array (words) ..................',I8,/, +' Number of layers in each pass (P1) .............',I8,/, +' Number of map sections in each pass (P2) .......',I8,/, +' Number of records in scratch file ..............',I8,/, +' Length of records in scratch file (words) ......',I8,/, +' (bytes) ......',I8,/) C C---- Check if array is big enough C IF (NSizePassOne.GT.0 .AND. NSizePassTwo.GT.0) THEN RETURN ELSE CALL CCPERR(1, ' !!!!!! Array too small !!!!!!') END IF C END C C ========================================== SUBROUTINE GENDEN(DEN,N1,N2,N3,R,NPAR,SUM) C ========================================== C C 11-8-91 C extend this to produce modified fcalc map containing only bulk c solvent if LSFmodeFlag = -4 and BulkWaterSF > 0 C C 15-10-86 C extend this to produce modified fcalc map for zghang's overlap C add 100*ires + mchflg to den(...) if LSFmodeFlag = -5 C C 13-4-88 C extend this again to produce modified fcalc map for daw C add 100*atnumber to den(...) if LSFmodeFlag = -6 C C ---- If NPAR eq 0 this subroutine sets up a density map from atomic cds. C If NPAR gt 0 this generates grads = sigma(den*grad) ref ramesh. C It then rewrites the atom file with the new C grad contribution included. C C---- This now reorders the cell dimensions to fit with the atom C order used in genden. ie genden wants to stack up z. C C .. Parameters .. INTEGER MaxSymmetry PARAMETER (MaxSymmetry=192) INTEGER MaxFormFactors PARAMETER (MaxFormFactors=20) C .. C .. Scalar Arguments .. REAL SUM INTEGER N1,N2,N3,NPAR,R C .. C .. Array Arguments .. REAL DEN(N1,N2,N3) C .. C .. Scalars in Common .. REAL AverageBfactor,BfactorMax,BfactorMin,BfactReset, + BfactStartStepSize,Bsmear,BulkWaterSF,RatioShiftTrunc, + RHmax,RHmean,RHmin,RmsBfactor,RmsXyz,SFrepeatValue, + SquAtmRadLimit,TH,VolMtz,W,XyzStartStepSize INTEGER IOatomop,IOgradmat,IOhessian,IOmap,IOscratch,IOshifts, + IOxyzin,IOxyzoutunq,IXmax,IXmin,IYmax,IYmin,IZmax, + IZmin,Jsec,JU1,JU2,JV1,JV2,LatomMapFlag,LBfactRefFlag, + LcheckSFspaceGrpFlag,LFreeRexcludeVal,LSFrefFlag, + LhklInputFlag,LMapInFlag,LSFcalcFlag,LSFmodeFlag, + LSolvMaskFlag,LxyzInputFlag,LXyzOutputFlag,LrefineCycFlag, + NtotalRefsUsed,NumAtmRefined,NumFormFactors,NumPlanes, + NumSections,NumSFspaceGroup,NumSFsymm,NumSpaceGroup, + NumSymmetry,NumZeroOccAtms,NX,NY,NZ LOGICAL LNoScaleFlag,LverboseFlag C .. C .. Arrays in Common .. REAL AtmBoxLowLim,AtmBoxUpLim,CellMtz,ExtBoxLowLim,ExtBoxUpLim, + ExtraPlanes,FormFactAcoeff,FormFactBcoeff,PermutRecipSymm, + PlanesLimits,RealSymmMatrx,SpecialPlaneLimit,RecipSymmMatrx, + FormFactAcoeffSum INTEGER Iuvw,KatmWghts,LSymmFlags,NumGaussPerAtmTyp CHARACTER MAACD1*1,MAACID*4,MATMTP*4 C .. C .. Local Scalars .. REAL A1G,ALPHAG,ANGSUM,B,B1G,BETAG,BIN,BL,C1G,COSA,COSB,COSG,COSZ, + CSA2,CSB2,CSG2,D2,D3,D4,DELX,DELY,DELY1,DELZ,DELZ1,DELZ2, + DENCHK,DFACT2,DJUNK,DLM,DmaxSQ,DSQ,DSQ1,DSQMIN,DV,DVOCC,DX, + DXMIN,DY,DYZ,DZ,DZCOSB,DZCSA2,FAC,FACDEN,GAMMAG,Occupancy,PI, + PISQ4,RhoMax,RhoMin,RRADX,RRADY,RRADZ,SINA,SING, COSASTOVSY, + SquAtmRadLimitIT,SUM1,SX,SXL,SXSING,SXU,SY,SYL,SYSING,SYU,SZ, + SZL,SZU,X,X1,XC,XDELTA,XIN,Y,Y1,YC,YIN,Z,Z1,ZC,ZCOSA,ZFFG, + ZSFG,ZSFNXT,ZZOCC,ZZOV2 INTEGER I,I1,I2,I3,I9,IATRC1,IATREC,IB,ICHK,ID31,IER,IM,IMON,IRES, + ISXL,ISXU,ISYL,ISYM,ISYU,ISZL,ISZU,ITETR,IX,IX1,IX2, + IXmaxG,IXminG,IY,IY1,IY2,IYmaxG,IYminG,IZ,IZ1,IZ2,IZminG, + IZZ,MA,MAT1,MAT2,MCHFLG,NGIM,NPTS,NSOLVPT,NXG,NYG,NZG LOGICAL FIRSTG CHARACTER MA0*4,MAC0*4 C .. C .. Local Arrays .. REAL ANG(3),AXIS(3),BLL(5),BUF(12),CLL(5),GAUSS(4501),GRAD(4) INTEGER JXMAX(3),JXMIN(3),NGRID(3) C .. C .. External Subroutines .. EXTERNAL CCPERR,PRMVCI,PRMVCR,QBACK,QREAD,QSEEK,QWRITE C .. C .. Intrinsic Functions .. INTRINSIC ABS,COS,EXP,INT,MIN1,MOD,NINT,REAL,SIN,SQRT C .. C .. Common blocks .. COMMON /ATMLIM/ + ExtBoxLowLim(3),ExtBoxUpLim(3), + SquAtmRadLimit,NumPlanes, + ExtraPlanes(3,6),PlanesLimits(6), + SpecialPlaneLimit(6), + AtmBoxLowLim(3),AtmBoxUpLim(3), + NumAtmRefined,NumZeroOccAtms COMMON /ATSYM/ + NumSymmetry,NumSpaceGroup, + RealSymmMatrx(4,4,MaxSymmetry), + RecipSymmMatrx(4,4,MaxSymmetry), + PermutRecipSymm(4,4), + LSymmFlags(MaxSymmetry) COMMON /BFACTS/ + AverageBfactor, + BfactorMin, + BfactorMax, + Bsmear, + BfactReset COMMON /FORM1/ + BulkWaterSF,NumFormFactors, + NumGaussPerAtmTyp(MaxFormFactors), + KatmWghts(MaxFormFactors), + FormFactAcoeff(5,MaxFormFactors), + FormFactBcoeff(5,MaxFormFactors), + FormFactAcoeffSum(MaxFormFactors) COMMON /IOSF/ + IOscratch,IOgradmat,IOhessian,IOshifts, + IOatomop,IOmap,IOxyzin,IOxyzoutunq COMMON /LABLS2/ + MATMTP(50),MAACID(27),MAACD1(26) COMMON /MPHDR/ + NX,NY,NZ, + IXmin,IXmax,IYmin,IYmax,IZmin,IZmax, + Jsec,JU1,JU2,JV1,JV2,Iuvw(3), + NumSFspaceGroup,NumSections, + RHmin,RHmax,RHmean,NumSFsymm, + CellMtz(6),VolMtz,Volfft,F000 COMMON /SRFCTL/ + NtotalRefsUsed, + RatioShiftTrunc,W,TH, + LSFmodeFlag,LrefineCycFlag,LBfactRefFlag, + LcheckSFspaceGrpFlag,LFreeRexcludeVal, + XyzStartStepSize,BfactStartStepSize, + SFrepeatValue, + RmsXyz,RmsBfactor COMMON /SRFCTL1/ + LSFcalcFlag,LSFrefFlag, + LatomMapFlag,LxyzInputFlag, + LhklInputFlag,LMapInFlag, + LSolvMaskFlag,LXyzOutputFlag COMMON /TERSE/ + LverboseFlag,LNoScaleFlag C .. C .. Save statement .. SAVE FIRSTG, IATRC1 C .. C .. Data statements .. DATA FIRSTG/.TRUE./ C .. C IF (LverboseFlag) WRITE (6,FMT=*) + ' GENDEN DEN,GAUSS,N1,N2,N3,R,NPAR LSymmFlags', + N1,N2,N3,R,NPAR,(LSymmFlags(I),I=1,4) C AXIS(1) = CellMtz(1) AXIS(2) = CellMtz(2) AXIS(3) = CellMtz(3) ANG(1) = CellMtz(4) ANG(2) = CellMtz(5) ANG(3) = CellMtz(6) NGRID(1) = NX NGRID(2) = NY NGRID(3) = NZ JXMIN(1) = IXmin JXMIN(2) = IYmin JXMIN(3) = IZmin JXMAX(1) = IXmax JXMAX(2) = IYmax JXMAX(3) = IZmax C IF (LverboseFlag) WRITE (6,FMT=*) + ' ngrid jxmin jxmax before perm', + NGRID,JXMIN,JXMAX C C ********************************* CALL PRMVCI(PermutRecipSymm,JXMIN,1,1) CALL PRMVCI(PermutRecipSymm,JXMAX,1,1) CALL PRMVCI(PermutRecipSymm,NGRID,1,1) CALL PRMVCR(PermutRecipSymm,ANG,1,1) CALL PRMVCR(PermutRecipSymm,AXIS,1,1) C ********************************* C A1G = AXIS(1) B1G = AXIS(2) C1G = AXIS(3) ALPHAG = ANG(1) BETAG = ANG(2) GAMMAG = ANG(3) NXG = NGRID(1) NYG = NGRID(2) NZG = NGRID(3) IXminG = JXMIN(1) IYminG = JXMIN(2) IZminG = JXMIN(3) IXmaxG = JXMAX(1) IYmaxG = JXMAX(2) C IF (R.EQ.IZminG) IATRC1 = 0 C SquAtmRadLimitIT = SquAtmRadLimit IF (NPAR.GT.0) SquAtmRadLimitIT = SquAtmRadLimit SX = A1G/NXG SY = B1G/NYG SZ = C1G/NZG C IF (SquAtmRadLimitIT.GT.9.0001) CALL CCPERR(1, + ' Atom radius must be less than 3.0') C DO 10 I = 1,4501 GAUSS(I) = 0.0 10 CONTINUE C I1 = INT(SquAtmRadLimitIT*500.0) C DO 20 I = 1,4500 GAUSS(I) = EXP(-0.002*I+0.002) 20 CONTINUE C PI = 3.14159 PISQ4 = 4.0*PI*PI COSA = COS(ALPHAG*PI/180.0) SINA = SIN(ALPHAG*PI/180.0) COSG = COS(GAMMAG*PI/180.0) SING = SIN(GAMMAG*PI/180.0) COSB = COS(BETAG*PI/180.0) CSA2 = COSA*2.0 CSB2 = COSB*2.0 CSG2 = COSG*2 C C---- COSZ defines the angle between c and cstar C SXSING = SX*SING SYSING = SY*SING COSASTOVSY = (COSA-COSB*COSG)/(SING*SING*SY) C COSZ = SQRT(1.0 - + COSA**2-COSB**2 - + COSG**2 + + 2.0*COSA*COSB*COSG)/SING DV = 8.0*SX*SY*SZ*COSZ*SING* (EXP(1.0 - + SquAtmRadLimitIT)+1)*PI**1.5 C IF (FirstG) THEN IF (LverboseFlag)WRITE (6,FMT=6002) DV 6002 FORMAT (/, +' Correction factor to atom density for this grid ',F10.4,/, +' This is used to achieve Absolute (?) scale for FC ',/, +' REf: Agarwal Acta Cryst (A34) 1987 791-809.') FirstG = .FALSE. END IF C IF (NPAR.LE.0) THEN DO 50 I3 = 1,N3 DO 40 I2 = 1,N2 DO 30 I1 = 1,N1 DEN(I1,I2,I3) = 0.0 30 CONTINUE 40 CONTINUE 50 CONTINUE END IF C DO 60 I = 1,4 GRAD(I) = 0.0 60 CONTINUE C SUM1 = 0.0 ITETR = 0 ANGSUM = ABS(ALPHAG+BETAG+GAMMAG-270.0) IF (ANGSUM.GT.0.01) ITETR = 1 IMON = 0 C C---- Beware - C monoclinic space groups must be treated as having c unique. C ANGSUM = ABS(BETAG+ALPHAG-180.0) IF (ANGSUM.GT.0.01) IMON = 1 DLM = SQRT(SquAtmRadLimitIT)*5.0/6.28318 IF (IMON.EQ.1) DLM = DLM + 0.5 ZSFG = REAL(R)/NZG - DLM/C1G ZFFG = REAL(R+N3-1)/NZG + DLM/C1G ZSFNXT = ZFFG - 2.0*DLM/C1G C COSZ = SQRT(1.0 - + COSA**2-COSB**2 - + COSG**2 + + 2.0*COSA*COSB*COSG)/SING IATREC = IATRC1 C C ***************************** CALL QSEEK(IOatomop,IATRC1+1,1,12) C ***************************** C 70 CONTINUE IATREC = IATREC + 1 C IF (IATREC.GT.NumZeroOccAtms) GO TO 180 C C---- Read atom coordinates and unpack C C ************************** CALL QREAD(IOatomop,BUF,12,IER) C ************************** C XIN = BUF(1) YIN = BUF(2) Z = BUF(3) BIN = BUF(4) ZZOCC = BUF(5) IRES = NINT(BUF(6)) MA = NINT(BUF(8)) GRAD(1) = BUF(9) GRAD(2) = BUF(10) GRAD(3) = BUF(11) GRAD(4) = BUF(12) C C---- Nov1981 read buffered unIOatomop C IF (Z.LT.ZSFNXT) IATRC1 = IATREC IF (Z.LT.ZSFG) GO TO 70 IF (Z.GT.ZFFG) GO TO 180 ISYM = NINT(XIN/10.0) X = XIN - 10*ISYM IF (ISYM.LT.1) WRITE(6,*)' ISYM etc',XIN,YIN,Z,BIN,ZZOCC C---- Is the program being used in a lower symmetry version C than the problem? C C Is this atom generated by one of the C extra symmetry ops - if so do not calculate its gradient. C C oct 90 change check for symmetry to include C IF (LSymmFlags(ISYM).EQ.0 .AND. NPAR.GT.0) GO TO 70 IY = NINT(YIN/10.0) Y = YIN - 10*IY IB = INT(BIN/100.0) B = BIN - 100*IB C Jan 95 - check for large IB (> 20000) C problems with rounding errors adds 1 to IB and leaves B very small. IF(B.LT.Bfactreset )THEN IB = IB -1 B = BIN - 100*IB END IF ZZOV2 = ZZOCC/20.0 IZZ = INT(ZZOV2+0.000001) Occupancy = ZZOCC - 20.0*IZZ - 10.0 IF (ABS(Occupancy).LT.0.001) GO TO 70 X1 = X*A1G Y1 = Y*B1G Z1 = Z*C1G DVOCC = Occupancy*DV IF (NPAR.EQ.0) B = B + Bsmear IF (B.LT.0.0) GO TO 170 C IF (LSFmodeFlag.EQ.-5) THEN C C---- Unpack acidname and residue code C MAT1 = MA/100 MA0 = MATMTP(MAT1) MCHFLG = 0 IF (MA0.EQ.'CA ' .OR. + MA0.EQ.'N ' .OR. + MA0.EQ.'C ' .OR. + MA0.EQ.'O ') MCHFLG = 1 END IF C C---- Identify formfactors C C match form factor to atomic no. C DO 80 I9 = 1,NumFormFactors IM = I9 IF (IZZ.EQ.KatmWghts(I9)) GO TO 90 80 CONTINUE C GO TO 160 90 SUM1 = (FormFactAcoeff(1,IM) + + FormFactAcoeff(3,IM) + + FormFactAcoeff(2,IM) + + FormFactAcoeff(4,IM) + + FormFactAcoeff(5,IM))*Occupancy + + SUM1 BL = PISQ4/ (25.0+B) IF (IM.EQ.1) BL = PISQ4/ (15.0+B) DmaxSq = SquAtmRadLimitIT/BL NGIM = NumGaussPerAtmTyp(IM) C DO 100 I9 = 1,NGIM BLL(I9) = PISQ4/ (FormFactBcoeff(I9,IM)+B) CLL(I9) = FormFactAcoeff(I9,IM)*DVOCC* + (FormFactBcoeff(I9,IM)+B)** (-1.5) IF (NPAR.EQ.1) CLL(I9) = CLL(I9)*BLL(I9) 100 CONTINUE C XC = X1/SX YC = Y1/SY ZC = Z1/SZ RRADZ = SQRT(DmaxSq)/ (SZ*COSZ) SZL = ZC - RRADZ SZU = ZC + RRADZ ISZL = INT(SZL+501.0) ISZU = INT(SZU+500.0) C C---- Calculate the density at all points to which atom contributes C (ie in sphere of radius rradz) C If npar.gt.0 also sum gradient contributions C DO 150 IZ1 = ISZL,ISZU IZ = IZ1 - 500 C C---- Test whether this atom lies in required block of fourier sections C IZ2 = IZ + 1 - R C IF (IZ2.LE.N3 .AND. IZ2.GT.0) THEN DZ = IZ*SZ - Z1 D2 = DZ*DZ C IF (D2.LE.DmaxSq .OR. ITETR.NE.1) THEN D3 = DmaxSq - DZ*DZ*COSZ*COSZ C D3 = DmaxSq - DZ*DZ*SINA*SINA C IF (D3.GT.0.0) THEN RRADY = SQRT(D3)/SYSING ZCOSA = DZ*COSASTOVSY C ZCOSA = DZ*(COSA-COSB*COSG)/(SING*SING*SY) C ZCOSA = DZ*COSA/SY SYL = YC - RRADY - ZCOSA SYU = YC + RRADY - ZCOSA ISYL = INT(SYL+501.0) ISYU = INT(SYU+500.0) DelZ1 = 2.0*DZ DZCSA2 = DZ*CSA2 DZCOSB = DZ*COSB C DO 140 IY1 = ISYL,ISYU IY = IY1 - 500 IY2 = MOD(IY+NYG+NYG,NYG) + 1 C IF (IY2.LE.IYmaxG+1 .AND. IY2.GE.IYminG+1) THEN DY = IY*SY - Y1 DYZ = (DZCSA2+DY)*DY + D2 C IF (DYZ.LE.DmaxSq .OR. IMON.NE.1) THEN C C---- For given x and y the minimum dsq is given C for dx=-dy*cosg-dzcosb C DXmin = -DY*COSG - DZCOSB DSQmin = DYZ - DXmin**2 C IF (DSQmin.LT.DmaxSq) THEN DFact2 = -2.0*DXmin D4 = DmaxSq - DSQmin DelZ2 = DY*CSA2 + DelZ1 DelY1 = 2.0*DY + DZCSA2 DelY = 2.0*DY RRADX = SQRT(D4)/SXSING XDELTA = DXmin/SX SXL = XC - RRADX + XDELTA SXU = XC + RRADX + XDELTA ISXL = INT(SXL+501.0) ISXU = INT(SXU+500.0) C DO 130 IX1 = ISXL,ISXU IX = IX1 - 500 IX2 = MOD(IX+NXG+NXG,NXG) + 1 C IF (IX2.LE.IXmaxG+1 .AND. + IX2.GE.IXminG+1) THEN DX = IX*SX - X1 DSQ = (DX+DFact2)*DX + DYZ C IF (DSQ.LE.DmaxSq) THEN FAC = 0.0 NGIM = NumGaussPerAtmTyp(IM) C DO 110 I9 = 1,NGIM DSQ1 = DSQ*500.0*BLL(I9) + 1.0 ID31 = MIN1(DSQ1,4001.1) FAC = CLL(I9)*GAUSS(ID31) + FAC 110 CONTINUE C IF (NPAR.LE.0) THEN C C---- If NPAR .LE.0 we may want to output map? C 15-10-86 add stuff for LSFmodeFlag = -5 - see top of s/r C Various output FC maps with flags for resdue or atom number C IF (LSFmodeFlag.LE.-5) THEN C C---- If another atom has already contributed to this den(...) C unpack den(...) and check which contribution is larger and C keep that labelled density. C C allow for atom 1 negative density C check gt 95... C IF (DEN(IY2,IX2,IZ2).GE.95.0) THEN ICHK = NINT(DEN(IY2,IX2,IZ2)/100.0) DENCHK = DEN(IY2,IX2,IZ2) - 100*ICHK C IF (ABS(DENCHK).GT. + ABS(FAC)) GO TO 120 DEN(IY2,IX2,IZ2) = FAC END IF C C---- reset label now C IF (LSFmodeFlag.EQ.-5) DEN(IY2,IX2, + IZ2) = DEN(IY2,IX2,IZ2) + 100*IRES + + MCHFLG*1000000 IF (LSFmodeFlag.EQ.-6) DEN(IY2,IX2, + IZ2) = DEN(IY2,IX2,IZ2) + 100*IB 120 CONTINUE END IF C DEN(IY2,IX2,IZ2) = DEN(IY2,IX2,IZ2) + FAC ELSE IF ((NPAR-1).GT.0) THEN GRAD(4) = DEN(IY2,IX2,IZ2)*FAC + GRAD(4) ELSE DelX = 2.0*DX + DFact2 DelY = DX*CSG2 + DelY1 DelZ = DX*CSB2 + DelZ2 FacDen = DEN(IY2,IX2,IZ2)*FAC GRAD(1) = GRAD(1) + FacDen*DelX GRAD(2) = GRAD(2) + FacDen*DelY GRAD(3) = GRAD(3) + FacDen*DelZ END IF END IF END IF 130 CONTINUE END IF END IF END IF 140 CONTINUE END IF END IF END IF 150 CONTINUE C IF (NPAR.NE.0) THEN C C---- If npar gt 0 ie refinement run C write atom file with grads C BUF(9) = GRAD(1) BUF(10) = GRAD(2) BUF(11) = GRAD(3) BUF(12) = GRAD(4) C C *********************** CALL QBACK(IOatomop,12) CALL QWRITE(IOatomop,BUF,12) C *********************** C END IF C C---- Back to look at next atom C GO TO 70 C C---- Unpack acidname and residue code C 160 MAT1 = MA/100 MAT2 = MA - 100*MAT1 MA0 = MATMTP(MAT1) MAC0 = MAACID(MAT2) WRITE (6,FMT=6004) IRES,MA0,MAC0 6004 FORMAT (' *** Unexpected atomic number.'/ + ' You need to add the atom type to your list of formfactors.' + /' The offending atom has residue number: ',I6, + ' and atom, residue identifier: ',A4,', ',A4) 170 CALL CCPERR(1,' Check form factor list or input coordinates') C C---- end of this pass - get information about density C 180 SUM = 0.0 NSOLVPT = 0 C DO 210 I3 = 1,N3 RhoMin = 1000.0 RhoMax = -10000.0 C DO 200 I2 = 1,N2 DO 190 I1 = 1,N1 C C---- Set Bulk solvent: C Option to set all protein density = 0 C IF LSolvMaskFlag = 1 and BulkWaterSF ne 0. C IF (LSolvMaskFlag.EQ.1) THEN IF ( DEN(I1,I2,I3).EQ.0.0) THEN DJUNK = DV*BulkWaterSF NSOLVPT = NSOLVPT + 1 END IF C IF ( DEN(I1,I2,I3).NE.0.0) DJUNK = 0.0 DEN(I1,I2,I3) = DJUNK END IF C IF (DEN(I1,I2,I3).LT.RhoMin) RhoMin = DEN(I1,I2,I3) IF (DEN(I1,I2,I3).GT.RhoMax) RhoMax = DEN(I1,I2,I3) SUM = DEN(I1,I2,I3) + SUM 190 CONTINUE 200 CONTINUE C IF (RHmin.GT.RhoMin) RHmin = RhoMin IF (RHmax.LT.RhoMax) RHmax = RhoMax 210 CONTINUE C IF (LverboseFlag)WRITE (6,FMT=6006) SUM,SUM1 6006 FORMAT (' Sums of ',/, +' 1. Density in this block ',F15.4,/, +' 2. Atomic scattering SQD ',F15.4) C IF (LSolvMaskFlag.EQ.1) THEN NPTS = N1*N2*N3 NPTS = NPTS -NSOLVPT WRITE (6,FMT=6007) NPTS,NSOLVPT 6007 FORMAT(' Number of points in "protein"',I6,/, + ' Number of points in "solvent"',I6) END IF C END C C ============================ SUBROUTINE GENHX(HESS,GAUSS) C ============================ C C---- Calculates values of h (diagonal terms of Matrix) C C .. Parameters .. INTEGER MaxFormFactors PARAMETER (MaxFormFactors=20) C .. C .. Array Arguments .. REAL GAUSS(4501),HESS(*) C .. C .. Scalars in Common .. REAL BfactFpart,BfactOverall,BfactStartStepSize,BulkWaterSF, + RatioShiftTrunc,RHmax,RHmean,RHmin,RmsBfactor,RmsXyz, + ScaleFcalc,ScaleFpart,SFrepeatValue,SigmaExclude,Smax,Smin, + SSbinSize,TH,TSmax,TSmin,VolMtz,W,WangSphereRadi, + XyzStartStepSize INTEGER Hmax,Hmin,IOatomop,IOgradmat,IOhessian,IOmap,IOscratch, + IOshifts,IOxyzin,IOxyzoutunq,IXmax,IXmin, + IYmax,IYmin,IZmax,IZmin,Jsec,JU1,JU2,JV1,JV2,Kmax,Kmin, + LBfactRefFlag,LcheckSFspaceGrpFlag,LFpartFlag, + LFreeRexcludeVal,Lmax,Lmin,LPhiPartFlag,LSFmodeFlag, + LWghtModeFlag,NLPRGO,LrefineCycFlag,Nslab, + NtotalRefsUsed,NumFormFactors,NumMultiplicity,NumSections, + NumSFspaceGroup,NumSFsymm,NX,NY,NZ CHARACTER ElementNames*4 LOGICAL LNoScaleFlag,LverboseFlag C .. C .. Arrays in Common .. REAL CellMtz,FormFactAcoeff,FormFactBcoeff,FormFactAcoeffSum INTEGER Iuvw,KatmWghts,NumGaussPerAtmTyp C .. C .. Local Scalars .. REAL AKO,AKO1,AKO2,ALO,ALO1,ALO2,AMULT,B2AT,BD1,BD2,BDmax, + BfactorMax2,BISO,BSTEP,CD1,CD2,D2,D4,DD4,DEL,H,HO, + HO1,HO2,Occupancy,PISQ2,SSQ,SSQ2,STEP,WK,WKK,X0,Y0,Z0 INTEGER HminG,I,I1,I3,I4,I9,IBDmax,IH1,IK1,IL1,IM,IRES,ITER, + IZN,J,J1,JBDmax,K,KminG,L,LminG,N,NGIM,NH,NK,NL CHARACTER ATID*4,ID*4,MCH*1,MA*4,MAC*4,RSN*4,ALTCOD*1,INSCOD*1, + SEGID*4 C .. C .. Local Arrays .. REAL BN(6),FACT(6,6),HYD(150),RF(4,4),RO(4,4) C .. C .. External Subroutines .. EXTERNAL CCPERR,RBRORF,XYZADVANCE,XYZATOM,XYZCOORD, + XYZREWD C .. C .. Intrinsic Functions .. INTRINSIC EXP,INT,MIN C .. C .. Common blocks .. COMMON /FORM1/ + BulkWaterSF,NumFormFactors, + NumGaussPerAtmTyp(MaxFormFactors), + KatmWghts(MaxFormFactors), + FormFactAcoeff(5,MaxFormFactors), + FormFactBcoeff(5,MaxFormFactors), + FormFactAcoeffSum(MaxFormFactors) COMMON /FORM2/ + ElementNames(MaxFormFactors) COMMON /HKLLIM/ + Hmax,Kmax,Lmax,Hmin,Kmin,Lmin,Nslab COMMON /IOSF/ + IOscratch,IOgradmat,IOhessian,IOshifts, + IOatomop,IOmap,IOxyzin,IOxyzoutunq COMMON /MPHDR/ + NX,NY,NZ, + IXmin,IXmax,IYmin,IYmax,IZmin,IZmax, + Jsec,JU1,JU2,JV1,JV2,Iuvw(3), + NumSFspaceGroup,NumSections, + RHmin,RHmax,RHmean,NumSFsymm, + CellMtz(6),VolMtz,Volfft,F000 COMMON /SFOUT/ + Smin,Smax,TSmin,TSmax,SSbinSize, + LFpartFlag,LPhiPartFlag,LWghtModeFlag, + ScaleFcalc,ScaleFpart, + SigmaExclude,WangSphereRadi, + BfactOverall,BfactFpart, + NumMultiplicity,NLPRGO COMMON /SRFCTL/ + NtotalRefsUsed, + RatioShiftTrunc,W,TH, + LSFmodeFlag,LrefineCycFlag,LBfactRefFlag, + LcheckSFspaceGrpFlag,LFreeRexcludeVal, + XyzStartStepSize,BfactStartStepSize, + SFrepeatValue, + RmsXyz,RmsBfactor COMMON /TERSE/ + LverboseFlag,LNoScaleFlag C C IBDmax = 150 BDmax = IBDmax - 0.0001 BfactorMax2 = 150.0 ITER = 0 C C---- For orthorhombic spacegroup Hmin,Kmin,Lmin=0 C STEP = 5.0 IF (LverboseFlag)WRITE (6,FMT=6000) JBDmax = INT(IBDmax/STEP) C DO 10 I = 1,4500 GAUSS(I) = EXP(-0.01*I+0.005) 10 CONTINUE C IF (LverboseFlag) WRITE (6,FMT=6002) C DO 20 I = 1,JBDmax HYD(I) = 0.0 20 CONTINUE C DO 40 I = 1,5 FACT(I,I) = 1.0 I1 = I + 1 DO 30 J = I1,6 FACT(I,J) = 2.0 30 CONTINUE 40 CONTINUE C RF(1,1) = 0.0 RO(1,1) = 0.0 C C ************* CALL RBRORF(RO,RF) C ************* C C---- Orthogonalisation now C HminG = Hmin KminG = Kmin LminG = Lmin IF (Hmin.EQ.0 .AND. Kmin.EQ.0 .AND. + CellMtz(6).NE.90.0) HminG = -Hmax IF (Hmin.EQ.0 .AND. Lmin.EQ.0 .AND. + CellMtz(5).NE.90.0) HminG = -Hmax IF (Lmin.EQ.0 .AND. Kmin.EQ.0 .AND. + CellMtz(4).NE.90.0) KminG = -Kmax C IH1 = Hmax - HminG + 1 IK1 = Kmax - KminG + 1 IL1 = Lmax - LminG + 1 C C---- Calculate multiplicity C AMULT = 1.0 IF (HminG.EQ.0) AMULT = AMULT*2.0 IF (KminG.EQ.0) AMULT = AMULT*2.0 IF (LminG.EQ.0) AMULT = AMULT*2.0 C C---- What is multiplicity C IF (LverboseFlag) WRITE (6,FMT=6004) + HminG,KminG,LminG,AMULT,RF C DO 80 NH = 1,IH1 H = NH + HminG - 1 HO1 = RF(1,1)*H AKO1 = RF(1,2)*H ALO1 = RF(1,3)*H C DO 70 NK = 1,IK1 K = NK + KminG - 1 HO2 = RF(2,1)*K + HO1 AKO2 = RF(2,2)*K + AKO1 ALO2 = RF(2,3)*K + ALO1 C DO 60 NL = 1,IL1 L = NL + Lmin - 1 HO = RF(3,1)*L + HO2 AKO = RF(3,2)*L + AKO2 ALO = RF(3,3)*L + ALO2 SSQ = HO*HO + AKO*AKO + ALO*ALO C IF (SSQ.LE.Smax .AND. SSQ.GE.Smin) THEN WKK = 0.5*W WK = 1.0 IF (W.GT.0.0) WK = SSQ**(WKK) C C---- To allow for resolution can use h*h,k*k or l*l (ramesh) C D2 = WK*AKO*AKO IF (LBfactRefFlag.EQ.1) D2 = WK*SSQ*SSQ SSQ2 = 25.0*SSQ C DO 50 I = 1,JBDmax BSTEP = I*STEP I3 = INT(SSQ2*BSTEP) + 1 IF (I3.GT.4000) I3 = 4000 HYD(I) = GAUSS(I3)*D2 + HYD(I) 50 CONTINUE END IF 60 CONTINUE 70 CONTINUE 80 CONTINUE C IF (LverboseFlag) WRITE (6,FMT=6006) PISQ2 = 3.14159**2*2.0 D2 = AMULT*PISQ2 IF (LBfactRefFlag.EQ.1) D2 = AMULT/32.0 C DO 90 I = 1,JBDmax HYD(I) = HYD(I)*D2 90 CONTINUE C C **************** CALL XYZREWD(IOxyzin) C **************** C N = 0 100 CONTINUE C C ************************************************************ 1 CALL XYZADVANCE(IOxyzin,0,ITER,*150,*150) CALL XYZATOM(IOxyzin,J1,MA,MAC,MCH,IRES,RSN,INSCOD,ALTCOD, + SEGID,IZN,ID) CALL XYZCOORD(IOxyzin,'O','B',X0,Y0,Z0,Occupancy,BISO,BN) C ************************************************************ C IF (BN(2).NE.0.0 .OR. BN(3).NE.0.0) THEN IF (X0.EQ.0.0 .AND. Y0.EQ.0.0 .AND. Z0.EQ.0.0) GOTO 100 ENDIF C IF (Occupancy.EQ.0.0) THEN GO TO 100 ELSE N = N + 1 HESS(N) = 0.0 C IF (ID(1:1) .EQ. ' ') THEN ATID = ID(2:4)//' ' ELSE ATID = ID ENDIF DO 110 I9 = 1,NumFormFactors IM = I9 C IF (IZN.EQ.KatmWghts(I9)) GO TO 120 IZN = KatmWghts(I9) IF (ATID.EQ.ElementNames(I9)) GO TO 120 110 CONTINUE C GO TO 160 120 B2AT = 2.0*BISO IF (B2AT.GT.BfactorMax2) B2AT = BfactorMax2 NGIM = NumGaussPerAtmTyp(IM) C DO 140 I = 1,NGIM BD1 = FormFactBcoeff(I,IM) + B2AT CD1 = FormFactAcoeff(I,IM) C DO 130 J = I,NGIM CD2 = FormFactAcoeff(J,IM)*CD1*FACT(I,J) BD2 = FormFactBcoeff(J,IM) + BD1 D4 = MIN(BDmax,BD2) DD4 = D4/STEP I4 = INT(DD4) DEL = DD4 - I4 C IF (I4.LT.1) THEN I4 = 1 DEL = 0 END IF C HESS(N) = ((1.0-DEL)*HYD(I4)+HYD(I4+1)*DEL)*CD2 + + HESS(N) 130 CONTINUE 140 CONTINUE GO TO 100 END IF C C---- transferred to grscrm 7-5-86 C 150 IF (LverboseFlag) WRITE (6,FMT=6008) IOhessian, + (HESS(I),I=1,8) RETURN C 160 CALL CCPERR(1,' No match for atomic formfactor') C C---- Format statements C 6000 FORMAT (' GENHX - GAUSS CALLED ') 6002 FORMAT (' GENHX - GAUSS CALCULATED ') 6004 FORMAT (' GENHX HminG .. .. AMULT',3I5,f10.5,/' rf ', + 4 (/4f8.3)) 6006 FORMAT (' GENHX - AFTER 50 40 30 ') 6008 FORMAT (' GENHX IOhessian HESS..',I5,12 (/1X,9E12.4)) C END C C ======================================================== SUBROUTINE GRSCRM(SDNORM,Slope,NPAR,NAT,GRADN,SDXB,HESS) C ======================================================== C C---- ejd - july 86 lcyc is a bad flag for recalling genhx - use mode C C Subroutine combines gradient contributions for atoms appearing C more than once (ie atoms near an asymmetric unit edge) C unscrambles packed information C and rewrites channel 16 with (shifted) C coordinates in original order C C Calculate inverted Matrix to unscramble equivalent positions C C .. Parameters .. INTEGER MaxSymmetry PARAMETER (MaxSymmetry=192) C .. C .. Scalar Arguments .. REAL SDNORM,SLOPE INTEGER NAT,NPAR C .. C .. Array Arguments .. REAL GRADN(3,NAT),HESS(NAT),SDXB(3,NAT) C .. C .. Scalars in Common .. REAL + AverageBfactor,BfactorMin,BfactorMax,Bsmear,BfactReset, + BfactFpart,BfactOverall,BfactStartStepSize,RatioShiftTrunc, + RHmax,RHmean,RHmin,RmsBfactor,RmsXyz,ScaleFcalc,ScaleFpart, + SFrepeatValue,SigmaExclude,Smax,Smin,SquAtmRadLimit, + SSbinSize,TH,TSmax,TSmin,VolMtz,W,WangSphereRadi, + XyzStartStepSize INTEGER IOatomop,IOgradmat,IOhessian,IOmap,IOscratch, + IOshifts,IOxyzin,IOxyzoutunq,IXmax,IXmin,IYmax, + IYmin,IZmax,IZmin,Jsec,JU1,JU2,JV1,JV2,LBfactRefFlag, + LcheckSFspaceGrpFlag,LFpartFlag,LFreeRexcludeVal, + LPhiPartFlag,LSFmodeFlag,LWghtModeFlag,NLPRGO, + LrefineCycFlag,NtotalRefsUsed,NumAtmRefined, + NumMultiplicity,NumPlanes,NumSections,NumSFspaceGroup, + NumSFsymm,NumSpaceGroup,NumSymmetry,NumZeroOccAtms,NX,NY, + NZ LOGICAL LNoScaleFlag,LverboseFlag C .. C .. Arrays in Common .. REAL AtmBoxLowLim,AtmBoxUpLim,CellMtz,ExtBoxLowLim,ExtBoxUpLim, + ExtraPlanes,PermutRecipSymm,PlanesLimits, + RealSymmMatrx,SpecialPlaneLimit,RecipSymmMatrx INTEGER Iuvw,LSymmFlags C .. C .. Local Scalars .. REAL BB,B,D1,D2,D3,FACT,GNORM,GPEAK,H1,SDD,SDD2,SDPEAK,SIG,SZ INTEGER I,IATREC,IER,IGR,INUM,ISYM,J C .. C .. Local Arrays .. REAL BUF(12),GR0(4),GRAD(4),RF(4,4),RO(4,4),SDBUF(5),X1(3) C .. C .. External Subroutines .. EXTERNAL GENHX,QBACK,QREAD,QSEEK,QWRITE,RBRORF C .. C .. Intrinsic Functions .. INTRINSIC INT,NINT,SQRT C .. C .. Common blocks .. COMMON /ATMLIM/ + ExtBoxLowLim(3),ExtBoxUpLim(3), + SquAtmRadLimit,NumPlanes, + ExtraPlanes(3,6),PlanesLimits(6), + SpecialPlaneLimit(6), + AtmBoxLowLim(3),AtmBoxUpLim(3), + NumAtmRefined,NumZeroOccAtms COMMON /ATSYM/ + NumSymmetry,NumSpaceGroup, + RealSymmMatrx(4,4,MaxSymmetry), + RecipSymmMatrx(4,4,MaxSymmetry), + PermutRecipSymm(4,4), + LSymmFlags(MaxSymmetry) COMMON /BFACTS/ + AverageBfactor, + BfactorMin, + BfactorMax, + Bsmear, + BfactReset COMMON /IOSF/ + IOscratch,IOgradmat,IOhessian,IOshifts, + IOatomop,IOmap,IOxyzin,IOxyzoutunq COMMON /MPHDR/ + NX,NY,NZ, + IXmin,IXmax,IYmin,IYmax,IZmin,IZmax, + Jsec,JU1,JU2,JV1,JV2,Iuvw(3), + NumSFspaceGroup,NumSections, + RHmin,RHmax,RHmean,NumSFsymm, + CellMtz(6),VolMtz,Volfft,F000 COMMON /SFOUT/ + Smin,Smax,TSmin,TSmax,SSbinSize, + LFpartFlag,LPhiPartFlag,LWghtModeFlag, + ScaleFcalc,ScaleFpart, + SigmaExclude,WangSphereRadi, + BfactOverall,BfactFpart, + NumMultiplicity,NLPRGO COMMON /SRFCTL/ + NtotalRefsUsed, + RatioShiftTrunc,W,TH, + LSFmodeFlag,LrefineCycFlag,LBfactRefFlag, + LcheckSFspaceGrpFlag,LFreeRexcludeVal, + XyzStartStepSize,BfactStartStepSize, + SFrepeatValue, + RmsXyz,RmsBfactor COMMON /TERSE/ + LverboseFlag,LNoScaleFlag C .. C IF (LverboseFlag) WRITE (6,FMT=*) ' grscrm LSymmFlags ', + LSymmFlags(1),LSymmFlags(2) C DO 20 I = 1,NAT DO 10 J = 1,3 GRADN(J,I) = 0.0 10 CONTINUE 20 CONTINUE C IATREC = 0 IER = 0 C C ********************** CALL QSEEK(IOatomop,1,1,12) C ********************** C 30 CONTINUE IATREC = IATREC + 1 C IF (IATREC.LE.NumZeroOccAtms) THEN C C---- Read atom coordinates (expanded,sorted set) C C ************************** CALL QREAD(IOatomop,BUF,12,IER) C ************************** C DO 40 I = 1,3 X1(I) = BUF(I) GRAD(I) = BUF(I+8) BUF(I+8) = 0.0 40 CONTINUE C GRAD(4) = BUF(12) BUF(12) = 0.0 C C---- reset buf(..) = 0 C for possible second cycle of shifts (eg LSFmodeFlag = 2) C B = BUF(4) C C---- Packed information in coordinate file: C C ICH - number of times this atom is included at diff symm posns C ISYM - symmetry element used to generate this position from input. C INUM - position in input file (sequence no.) C TRNCD - complicated code to give number of unit cell shifts C along x y and z . see atsort. C MA - code for atom name and residue name. C GRAD(1)..(4) - gradx grady gradz grad b - some may be zero. C ISYM = NINT(X1(1)/10.0) C C---- change check for symmetry to include C IF (LSymmFlags(ISYM).EQ.1) THEN INUM = INT(B/100.0) C Jan 95 - check for large INUM (> 20000) C problems with rounding errors adds 1 to INUM and leaves BB very small. BB = B - 100*INUM IF(BB.LT.Bfactreset) INUM = INUM - 1 C C----Multiply grads by symmetry transformations,thus allowing C for changes of sign in some grads for symmetry-related sites C IGR = 1 IF (NPAR.EQ.4) THEN GRADN(1,INUM) = GRAD(4) + GRADN(1,INUM) ELSE IGR = 3 GR0(1) = RealSymmMatrx(1,1,ISYM)*GRAD(1) + + RealSymmMatrx(2,1,ISYM)*GRAD(2) + + RealSymmMatrx(3,1,ISYM)*GRAD(3) GR0(2) = RealSymmMatrx(1,2,ISYM)*GRAD(1) + + RealSymmMatrx(2,2,ISYM)*GRAD(2) + + RealSymmMatrx(3,2,ISYM)*GRAD(3) GR0(3) = RealSymmMatrx(1,3,ISYM)*GRAD(1) + + RealSymmMatrx(2,3,ISYM)*GRAD(2) + + RealSymmMatrx(3,3,ISYM)*GRAD(3) C GRADN(1,INUM) = GR0(1) + GRADN(1,INUM) GRADN(2,INUM) = GR0(2) + GRADN(2,INUM) GRADN(3,INUM) = GR0(3) + GRADN(3,INUM) END IF END IF GO TO 30 END IF C C---- ejd C july 86 - we always want to recalculate hess if LSFmodeFlag =1 or 2 C values different for LBfactRefFlag=0 and LBfactRefFlag=1 C C ********************** CALL QSEEK(IOhessian,1,1,1) CALL GENHX(HESS,SDXB) CALL QWRITE(IOhessian,HESS(1),NumAtmRefined) C **************************** C IF (NPAR.NE.4) THEN RO(1,1) = 0.0 RF(1,1) = 0.0 C C ************* CALL RBRORF(RO,RF) C ************* C C---- Orthogonalise complete gradient terms C DO 60 I = 1,NumAtmRefined DO 50 J = 1,3 GRAD(J) = RF(1,J)*CellMtz(1)*GRADN(1,I) + + RF(2,J)*CellMtz(2)*GRADN(2,I) + + RF(3,J)*CellMtz(3)*GRADN(3,I) 50 CONTINUE C GRADN(1,I) = GRAD(1) GRADN(2,I) = GRAD(2) GRADN(3,I) = GRAD(3) 60 CONTINUE C ELSE FACT = 0.25 C DO 70 I = 1,NumAtmRefined GRADN(1,I) = GRADN(1,I)*FACT 70 CONTINUE C END IF C C---- tab grads onto end of hess file C C ******************************************** CALL QWRITE(IOhessian,GRADN(1,1),3*NumAtmRefined) C ******************************************** C GNORM = 0.0 GPEAK = 0.0 SDNORM = 0.0 SDPEAK = 0.0 C C---- Calculate shifts (=grad/hess) C Slope = 0.0 C DO 90 I = 1,NumAtmRefined H1 = 1.0/HESS(I) C C---- find average and maximum grads and shifts C D1 = 0.0 C DO 80 J = 1,IGR D1 = GRADN(J,I)**2 + D1 SDXB(J,I) = GRADN(J,I)*H1 80 CONTINUE C Slope = Slope - H1*D1 D2 = H1*H1*D1 IF (H1.GT.1.0 .AND. LverboseFlag) + WRITE (6,FMT=6000) I,HESS(I),H1,IGR,D1 IF (D2.GT.D1 .AND. LverboseFlag) + WRITE (6,FMT=6000) I,HESS(I),H1,IGR,D1 IF (D1.GT.GPEAK) GPEAK = D1 GNORM = GNORM + D1 IF (D2.GT.SDPEAK) SDPEAK = D2 SDNORM = SDNORM + D2 90 CONTINUE C C---- Correct for symmetry if using a program with lower symmetry C than your structure. C CEJD June 1991 - "NumSymmetry" = NumPrimSymm actually C Slope = Slope*NumSymmetry*NumMultiplicity/NumSFsymm GNORM = SQRT(GNORM/NumAtmRefined) SDNORM = SQRT(SDNORM/NumAtmRefined) GPEAK = SQRT(GPEAK) SDPEAK = SQRT(SDPEAK) WRITE (6,FMT=6004) GNORM,GPEAK,SDNORM,SDPEAK D2 = RatioShiftTrunc*SDNORM C IF (SDPEAK.GT.D2) THEN C C---- truncate shifts if greater than RatioShiftTrunc*(rms shift) C SDNORM = 0.0 SDPEAK = 0.0 D2 = 0.9*D2 C DO 110 I = 1,NumAtmRefined D3 = 1.0 SDD = 0.0 DO 100 J = 1,IGR SDD = SDXB(J,I)**2 + SDD 100 CONTINUE C SDD2 = SQRT(SDD) IF (SDD2.GT.D2) D3 = D2/SDD2 IF (LverboseFlag .AND. (SDD2.GT.D2)) + WRITE (6,FMT=6002) I, + (GRADN(J,I),SDXB(J,I),J=1,3) SDXB(3,I) = SDXB(3,I)*D3 SDXB(2,I) = SDXB(2,I)*D3 SDXB(1,I) = SDXB(1,I)*D3 SDNORM = SDD*D3*D3 + SDNORM SDD2 = D3*SDD2 IF (SDPEAK.LE.SDD2) SDPEAK = SDD2 110 CONTINUE C SDNORM = SQRT(SDNORM/NumAtmRefined) END IF C WRITE (6,FMT=6004) GNORM,GPEAK,SDNORM,SDPEAK C C---- Write out shifts on file 16 C C ********************* CALL QSEEK(IOshifts,1,1,2) C ********************* C IF (NPAR.NE.4) THEN SDBUF(1) = SDNORM SDBUF(2) = SDNORM CALL QWRITE (IOshifts,SDBUF,2) END IF C IF (NPAR.EQ.4) THEN CALL QREAD (IOshifts,SDBUF,2,IER) CALL QBACK (IOshifts,2) SDBUF(2) = SDNORM CALL QWRITE (IOshifts,SDBUF,2) END IF C SDD = 0.0 C DO 120 I = 1,NumAtmRefined SIG = 1.0/SQRT(HESS(I)) C IF (NPAR.NE.4) THEN SIG = 1.7328*SIG SDBUF(1) = SDXB(1,I) SDBUF(2) = SDXB(2,I) SDBUF(3) = SDXB(3,I) SDBUF(4) = SIG SDBUF(5) = SIG CALL QWRITE (IOshifts,SDBUF,5) END IF C IF (NPAR.EQ.4) THEN CALL QREAD (IOshifts,SDBUF,5,IER) CALL QBACK (IOshifts,5) SDBUF(5) = SDXB(1,I) CALL QWRITE (IOshifts,SDBUF,5) END IF C 120 CONTINUE C SZ = 1.0 IF (LverboseFlag)WRITE (6,FMT=6008) Slope,SZ C C---- Calculate shifts by conjugate gradient method if desired C (usually only if more than cycle is being run) C C---- Format statements C 6000 FORMAT (' PROBLEMS I HESSI H1 IGR D1',I3,2E12.4,I3,E12.4) 6002 FORMAT (' Large shift ',I4,6E12.4) 6004 FORMAT (/, +' Norm of the (ie rms )xray GRADIENT ',E15.5,/, +' Peak of the xray GRADIENT ',E15.5,/, +' Norm of the (ie rms )xray SHIFT ',E15.5,/, +' Peak of the xray SHIFT ',E15.5) 6008 FORMAT (//, +' Slope of search Direction is',E15.4,/, +' Step Size used for quadratic approximation ',F10.3) C END C C ========================== SUBROUTINE HEX(X,N1,N2,N3) C ========================== C C---- n1=ny+2 n2=nx n3=NSizePassOne (z sections) C C .. Scalar Arguments .. INTEGER N1,N2,N3 C .. C .. Array Arguments .. REAL X(N1,N2,N3) C .. C .. Scalars in Common .. REAL RHmax,RHmean,RHmin,VolMtz INTEGER IXmax,IXmin,IYmax,IYmin,IZmax,IZmin,Jsec,JU1,JU2,JV1,JV2, + NumSections,NumSFspaceGroup,NumSFsymm,NX,NY,NZ C .. C .. Arrays in Common .. REAL CellMtz INTEGER Iuvw C .. C .. Local Scalars .. INTEGER IX,IX1,IXX,IXXX,IY,IY1,IYY,IYYY,IZ,NX2OV3,NXOV3 C .. C .. Common blocks .. COMMON /MPHDR/ + NX,NY,NZ, + IXmin,IXmax,IYmin,IYmax,IZmin,IZmax, + Jsec,JU1,JU2,JV1,JV2,Iuvw(3), + NumSFspaceGroup,NumSections, + RHmin,RHmax,RHmean,NumSFsymm, + CellMtz(6),VolMtz,Volfft,F000 C .. C NXOV3 = NX/3 NX2OV3 = 2*NXOV3 C DO 30 IZ = 1,N3 DO 20 IX1 = 1,NX2OV3 + 1 IX = IX1 - 1 IYYY = NY - IX IF (IYYY.EQ.NY) IYYY = 0 C DO 10 IY1 = 1,NX2OV3 + 1 IY = IY1 - 1 C C---- equivalent -y,x-y,z now. C IF (IY.LT.IX-NXOV3 .OR. IY.GT.NXOV3+IX) GO TO 10 IXX = NX - IY IF (IXX.EQ.NX) IXX = 0 IYY = IX - IY IF (IYY.LT.0) IYY = NY + IYY X(IYY+1,IXX+1,IZ) = X(IY1,IX1,IZ) C C---- equivalent y-x,-x,z now C IXXX = IY - IX IF (IXXX.LT.0) IXXX = NX + IXXX X(IYYY+1,IXXX+1,IZ) = X(IY1,IX1,IZ) 10 CONTINUE 20 CONTINUE 30 CONTINUE C END C C ====================================================== SUBROUTINE HINR3(X,NZVAL,KM1,NSizePassTwo,NSizePassOne, + NumSkipRecords,RECS,IOscratch, + NumCurrentRecord,NRCSC) C ======================================================= C C---- reads back complex intermediate results of xz transform as h - C planes, when there has been no transposition and interleaving. C it allows no scratch location on y. C Works for P3 or R3 C C .. Scalar Arguments .. INTEGER IOscratch,KM1,NRCSC,NSizePassOne,NSizePassTwo, + NumCurrentRecord,NumSkipRecords,NZVAL,RECS C .. C .. Array Arguments .. COMPLEX X(NZVAL,KM1,NSizePassTwo) C .. C .. Local Scalars .. INTEGER IER,IH,IK,P,Q C .. C .. External Subroutines .. EXTERNAL QREAD,QSEEK C .. C NumCurrentRecord = NumCurrentRecord + NumSkipRecords Q = 0 10 CONTINUE P = Q + 1 Q = Q + NSizePassOne IF (Q.GT.NZVAL) Q = NZVAL C C ***************************************** CALL QSEEK(IOscratch,NumCurrentRecord,1,NRCSC) C ***************************************** C DO 30 IH = 1,NSizePassTwo DO 20 IK = 1,KM1 C C ********************************************** CALL QREAD(IOscratch,X(P,IK,IH),2* (Q-P+1),IER) C ********************************************** C 20 CONTINUE 30 CONTINUE C IF (Q.GE.NZVAL) GO TO 40 NumCurrentRecord = NumCurrentRecord + RECS + 1 GO TO 10 40 CONTINUE END C C ================================================== SUBROUTINE HOUT1(X,NZ,NX,NY,Lmax,Hmax,NSizePassTwo, + IOscratch,NumCurrentRecord,NRCSC) C =================================================== C C---- This routine , previously called writeh, writes out complex C intermediate results of xz transform for space groups having uniqu C C .. Scalar Arguments .. INTEGER Hmax,IOscratch,Lmax,NRCSC,NSizePassTwo,NumCurrentRecord, + NX,NY,NZ C .. C .. Array Arguments .. COMPLEX X(NZ,NX,NY) C .. C .. Scalars in Common .. LOGICAL LNoScaleFlag,LverboseFlag C .. C .. Local Scalars .. INTEGER H,K,L,LM,Ndiff,P,Q C .. C .. External Subroutines .. EXTERNAL QWRITE C .. C .. Common blocks .. COMMON /TERSE/ + LverboseFlag,LNoScaleFlag C .. C C IF (LverboseFlag) WRITE (6,FMT=6000) NZ,NX,NY, + Lmax,Hmax,NSizePassTwo, + IOscratch,NumCurrentRecord, + NRCSC 6000 FORMAT ( +' hout1 nz nx ny Lmax Hmax NSizePassTwo ', +' IOscratch NumCurrentRecord Nrecsc',/9i5) C LM = Lmax + 1 C C---- this section reads records containing negative h only. C Q = NX - Hmax 10 CONTINUE NumCurrentRecord = NumCurrentRecord + 1 P = Q + 1 Q = Q + NSizePassTwo IF (Q.GT.NX) GO TO 90 C DO 40 L = 1,LM DO 30 K = 1,NY DO 20 H = P,Q C C **************************** CALL QWRITE(IOscratch,X(L,H,K),2) C **************************** C 20 CONTINUE 30 CONTINUE 40 CONTINUE C C---- pad record to nrcsc words C Ndiff = NRCSC - 2*LM*NY* (Q-P+1) C C ******************************** IF (Ndiff.GT.0) CALL QWRITE(IOscratch,X(1,1,1),Ndiff) C ******************************** C IF (Q.LT.NX) GO TO 10 C C---- This section reads records for h positive or zero. C Q = 0 50 CONTINUE NumCurrentRecord = NumCurrentRecord + 1 P = Q + 1 Q = Q + NSizePassTwo IF (Q.GT.Hmax) Q = Hmax + 1 C DO 80 L = 1,LM DO 70 K = 1,NY DO 60 H = P,Q C C **************************** CALL QWRITE(IOscratch,X(L,H,K),2) C **************************** C 60 CONTINUE 70 CONTINUE 80 CONTINUE C C---- pad record to nrcsc words C Ndiff = NRCSC - 2*LM*NY* (Q-P+1) C C ******************************** IF (Ndiff.GT.0) CALL QWRITE(IOscratch,X(1,1,1),Ndiff) C ******************************** C IF (Q.LE.Hmax) GO TO 50 RETURN C C---- this section handles records spanning h=0 . C 90 CONTINUE Q = Q - NX IF (Q.GT.Hmax) Q = Hmax + 1 C DO 130 L = 1,LM DO 120 K = 1,NY DO 100 H = P,NX C C **************************** CALL QWRITE(IOscratch,X(L,H,K),2) C **************************** C 100 CONTINUE C DO 110 H = 1,Q C C **************************** CALL QWRITE(IOscratch,X(L,H,K),2) C **************************** C 110 CONTINUE 120 CONTINUE 130 CONTINUE C C---- pad record to nrcsc words C Ndiff = NRCSC - 2*LM*NY* (NX+Q-P+1) C C ******************************** IF (Ndiff.GT.0) CALL QWRITE(IOscratch,X(1,1,1),Ndiff) C ******************************** C IF (Q.LE.Hmax) GO TO 50 END C C ==================================================== SUBROUTINE HOUT2(X,NZ,NX,NY,Lmax,Hmax,Size,IOscratch, + NumCurrentRecord,NRCSC) C ===================================================== C C---- this routine writes out complex intermediate results of xz C transforms for space groups having unique reflexions with C h positive or zero only. C C scratch file is in direct access. C C G. BRICOGNE, MAY 1976 C C .. Scalar Arguments .. INTEGER Hmax,IOscratch,Lmax,NRCSC,NumCurrentRecord,NX,NY,NZ,Size C .. C .. Array Arguments .. COMPLEX X(NZ,NX,NY) C .. C .. Local Scalars .. INTEGER H,K,L,LM,Ndiff,P,Q C .. C .. External Subroutines .. EXTERNAL QWRITE C .. C LM = Lmax + 1 Q = 0 10 CONTINUE NumCurrentRecord = NumCurrentRecord + 1 P = Q + 1 Q = Q + Size IF (Q.GT.Hmax) Q = Hmax + 1 C DO 40 L = 1,LM DO 30 K = 1,NY DO 20 H = P,Q C C **************************** CALL QWRITE(IOscratch,X(L,H,K),2) C **************************** C 20 CONTINUE 30 CONTINUE 40 CONTINUE C C---- pad record to nrcsc words C Ndiff = NRCSC - 2*LM*NY* (Q-P+1) C C ******************************** IF (Ndiff.GT.0) CALL QWRITE(IOscratch,X(1,1,1),Ndiff) C ******************************** C IF (Q.LE.Hmax) GO TO 10 C END C C =================================================== SUBROUTINE HOUTP3(X,NY2OV2,NX,NSizePassOne,Kmax, + NSizePassTwo,R,NZ,IOscratch, + NumCurrentRecord,NRCSC) C =================================================== C C---- check C C .. Scalar Arguments .. INTEGER IOscratch,Kmax,NRCSC,NSizePassOne,NSizePassTwo, + NumCurrentRecord,NX,NY2OV2,NZ,R C .. C .. Array Arguments .. COMPLEX X(NY2OV2,NX,NSizePassOne) C .. C .. Local Scalars .. INTEGER HM1,Hmax,IX,IY,IZ,KM1,Ndiff,P,Q C .. C .. External Subroutines .. EXTERNAL QWRITE C .. C .. Intrinsic Functions .. INTRINSIC CMPLX,COS,MOD,SIN C .. C KM1 = Kmax + 1 HM1 = KM1 Hmax = Kmax C 30 CONTINUE C Q = 0 40 P = Q + 1 NumCurrentRecord = NumCurrentRecord + 1 Q = Q + NSizePassTwo IF (Q.GT.HM1) Q = HM1 C DO 70 IX = P,Q DO 60 IY = 1,KM1 DO 50 IZ = 1,NSizePassOne C C ******************************* CALL QWRITE(IOscratch,X(IY,IX,IZ),2) C ******************************* C 50 CONTINUE 60 CONTINUE 70 CONTINUE C C---- pad record to nrcsc words C Ndiff = NRCSC - 2*NSizePassOne*KM1* (Q-P+1) C C ****************************** IF (Ndiff.GT.0) CALL QWRITE(IOscratch,X(1,1,1),Ndiff) C ****************************** C IF (Q.LE.Hmax) GO TO 40 END C C =================================================== SUBROUTINE HOUTR3(X,NY2OV2,NX,NSizePassOne,Kmax, + NSizePassTwo,R,NZ,IOscratch, + NumCurrentRecord,NRCSC) C =================================================== C C---- check C C .. Scalar Arguments .. INTEGER IOscratch,Kmax,NRCSC,NSizePassOne,NSizePassTwo, + NumCurrentRecord,NX,NY2OV2,NZ,R C .. C .. Array Arguments .. COMPLEX X(NY2OV2,NX,NSizePassOne) C .. C .. Local Scalars .. REAL C1,C2,PIBY2,S1,S2,ZZ INTEGER HM1,Hmax,IH,IH1,IK,IK1,IX,IY,IZ,KM1,Lmod3,Ndiff,P,Q C .. C .. Local Arrays .. COMPLEX ARR(2) C .. C .. External Subroutines .. EXTERNAL QWRITE C .. C .. Intrinsic Functions .. INTRINSIC CMPLX,COS,MOD,SIN C .. C PIBY2 = 6.28318 KM1 = Kmax + 1 HM1 = KM1 Hmax = Kmax C DO 30 IZ = 1,NSizePassOne ZZ = (IZ+R-1.0)/NZ C1 = COS(PIBY2*ZZ) S1 = SIN(PIBY2*ZZ) C2 = COS(2.0*PIBY2*ZZ) S2 = SIN(2.0*PIBY2*ZZ) ARR(1) = CMPLX(C1,-S1) ARR(2) = CMPLX(C2,-S2) C DO 20 IH1 = 1,HM1 IH = IH1 - 1 C DO 10 IK1 = 1,KM1 IK = IK1 - 1 Lmod3 = MOD(IH-IK+3000,3) X(IK1,IH1,IZ) = X(IK1,IH1,IZ)*3.0 IF (Lmod3.EQ.0) GO TO 10 X(IK1,IH1,IZ) = X(IK1,IH1,IZ)*ARR(Lmod3) 10 CONTINUE 20 CONTINUE 30 CONTINUE C Q = 0 40 P = Q + 1 NumCurrentRecord = NumCurrentRecord + 1 Q = Q + NSizePassTwo IF (Q.GT.HM1) Q = HM1 C DO 70 IX = P,Q DO 60 IY = 1,KM1 DO 50 IZ = 1,NSizePassOne C C ******************************* CALL QWRITE(IOscratch,X(IY,IX,IZ),2) C ******************************* C 50 CONTINUE 60 CONTINUE 70 CONTINUE C C---- pad record to nrcsc words C Ndiff = NRCSC - 2*NSizePassOne*KM1* (Q-P+1) C C ****************************** IF (Ndiff.GT.0) CALL QWRITE(IOscratch,X(1,1,1),Ndiff) C ****************************** C IF (Q.LE.Hmax) GO TO 40 END C C ================================================ SUBROUTINE IN144(X,NZ,KM1,NSizePassTwo,R,Y,Kmax1, + NX1,IOscratch,NumSFspaceGroup) C =============================================== C C .. Scalar Arguments .. INTEGER IOscratch,KM1,Kmax1,NSizePassTwo,NumSFspaceGroup,NX1,NZ,R C .. C .. Array Arguments .. COMPLEX X(NZ,KM1,NSizePassTwo),Y(Kmax1,NX1) C .. C .. Scalars in Common .. LOGICAL LNoScaleFlag,LverboseFlag C .. C .. Local Scalars .. REAL ABSY INTEGER IER,IH,IH1,IH3,IH4,IHR1,II,IK,IK1,IK3,IK4,IZ,IZ3,IZ4,Nrec, + NX,NZ23,NZ3 C .. C .. External Subroutines .. EXTERNAL QREAD,QSEEK C .. C .. Intrinsic Functions .. INTRINSIC ABS,CMPLX,CONJG C .. C .. Common blocks .. COMMON /TERSE/ + LverboseFlag,LNoScaleFlag C .. C NX = NX1 - 1 NZ3 = NZ/3 NZ23 = 2*NZ3 Nrec = 2*Kmax1*NX IF (LverboseFlag) WRITE (6,FMT=6000) NZ,KM1,NSizePassTwo, + R,Kmax1,NX1,NX,NZ3,NZ23 6000 FORMAT (' IN144 nz km1 NSizePassTwo r Kmax1 nx1 nx nz3 nz23 ', + 9I5) C DO 30 IH = 1,NSizePassTwo DO 20 IK = 1,Kmax1 DO 10 IZ = 1,NZ X(IZ,IK,IH) = CMPLX(0.0,0.0) 10 CONTINUE 20 CONTINUE 30 CONTINUE C C ************************* CALL QSEEK(IOscratch,1,1,Nrec) C ************************* C DO 70 IZ = 1,NZ3 C C ******************************** CALL QREAD(IOscratch,Y(1,1),Nrec,IER) C ******************************** C DO 40 IK1 = 1,Kmax1 Y(IK1,NX1) = Y(IK1,1) 40 CONTINUE C DO 60 IHR1 = 1,NSizePassTwo IH1 = IHR1 + R IH = IH1 - 1 DO 50 IK1 = 1,KM1 IK = IK1 - 1 II = -IH - IK IF (ABS(II).GE.Kmax1) GO TO 50 C C---- No point generating equivalents for absy=0 C ABSY = ABS(Y(IK1,IH1)) IF (ABSY.EQ.0.0) GO TO 50 X(IZ,IK1,IHR1) = Y(IK1,IH1) C C---- p31 t(i h z)= t(h k z+2/3) take z 2/3-1 C p32 t(i h z)= t(h k z+1/3) take z 2/3-1 C IF (NumSFspaceGroup.EQ.144) IZ3 = NZ23 + IZ IF (NumSFspaceGroup.EQ.145) IZ3 = NZ3 + IZ IK3 = IH + 1 IH3 = NX + II + 1 IF (IH3.GT.NX) IH3 = 1 X(IZ3,IK1,IHR1) = Y(IK3,IH3) C C---- p31 t(k i z)=t(h k z+1/3) take z 1/3-2/3 C p32 t(k i z)=t(h k z+2/3) take z 1/3-2/3 C use t(-k -i z)=t (h k z+1/3) transpose C IF (NumSFspaceGroup.EQ.144) IZ4 = IZ + NZ3 IF (NumSFspaceGroup.EQ.145) IZ4 = IZ + NZ23 IK4 = -II + 1 IH4 = NX - IK + 1 IF (IK.EQ.0) IH4 = 1 X(IZ4,IK1,IHR1) = CONJG(Y(IK4,IH4)) 50 CONTINUE 60 CONTINUE 70 CONTINUE C END C C ================================================== SUBROUTINE IN152(X,NZ,IHKA,Y,Kmax1,NX1,IOscratch, + NumSFspaceGroup) C ================================================= C C .. Scalar Arguments .. INTEGER IHKA,IOscratch,Kmax1,NumSFspaceGroup,NX1,NZ C .. C .. Array Arguments .. COMPLEX X(NZ,IHKA),Y(Kmax1,NX1) C .. C .. Scalars in Common .. INTEGER HmaxA,HminA,KHmin LOGICAL LNoScaleFlag,LverboseFlag C .. C .. Local Scalars .. REAL ABSY INTEGER IER,IH,IH1,IH2,IH3,IH4,IH5,IH6,IHmax1,IHmin1,II,IK,IK1, + IK2,IK3,IK4,IK5,IK6,IZ,IZ2,IZ3,IZ4,IZ5,IZ6,KH,Nrec,NX, + NZ23,NZ3,NZ61 C .. C .. External Subroutines .. EXTERNAL QREAD,QSEEK C .. C .. Intrinsic Functions .. INTRINSIC ABS,CMPLX,CONJG C .. C .. Common blocks .. COMMON /P41212/ + HminA,HmaxA,KHmin COMMON /TERSE/ + LverboseFlag,LNoScaleFlag C .. C IF (LverboseFlag) WRITE (6,FMT=6000) + IHKA,HminA,HmaxA,NumSFspaceGroup 6000 FORMAT (' IN152 ihka Hmina Hmaxa NumSFspaceGroup ',5I5) C NX = NX1 - 1 NZ61 = NZ/6 + 1 NZ3 = NZ/3 NZ23 = 2*NZ3 Nrec = 2*Kmax1*NX C DO 20 KH = 1,IHKA DO 10 IZ = 1,NZ X(IZ,KH) = CMPLX(0.0,0.0) 10 CONTINUE 20 CONTINUE C C ************************* CALL QSEEK(IOscratch,1,1,Nrec) C ************************* C DO 60 IZ = 1,NZ61 C C ******************************** CALL QREAD(IOscratch,Y(1,1),Nrec,IER) C ******************************** C DO 30 IK1 = 1,Kmax1 Y(IK1,NX1) = Y(IK1,1) 30 CONTINUE C IHmin1 = HminA + 1 IHmax1 = HmaxA + 1 C DO 50 IH1 = IHmin1,IHmax1 DO 40 IK1 = 1,IH1 IH = IH1 - 1 IK = IK1 - 1 II = -IH - IK IF (ABS(II).GE.Kmax1) GO TO 40 C C---- No point generating equivalents for absy=0 C ABSY = ABS(Y(IK1,IH1)) IF (ABSY.EQ.0.0) GO TO 40 KH = IH*IH1/2 + IK1 - KHmin X(IZ,KH) = Y(IK1,IH1) C IF (LverboseFlag) WRITE (65,FMT=6002) + IK1,IH1,IZ,KH,Y(IK,IH), + X(IZ,KH) 6002 FORMAT (2I5,5X,2I5,5X,2F5.0,5X,2F5.0) C C---- p3121 or p3221 - t((k h z)=t (h k -z) take z 5/6 - 1 C IH2 = IK + 1 IK2 = IH + 1 IZ2 = NZ - IZ + 2 IF (IZ2.GT.NZ) IZ2 = 1 X(IZ2,KH) = Y(IK2,IH2) C C---- p3121 t(i h z)= t(h k z+2/3) take z 2/3-5/6 C p3221 t(i h z)= t(h k z+1/3) take z 1/3 - 1/2 C IF (NumSFspaceGroup.EQ.152) IZ3 = NZ23 + IZ IF (NumSFspaceGroup.EQ.154) IZ3 = NZ3 + IZ II = -IH - IK IK3 = IH + 1 IH3 = NX + II + 1 IF (IH3.GT.NX) IH3 = 1 X(IZ3,KH) = Y(IK3,IH3) C C---- p3121 t(k i z)=t(h k z+1/3) take z 1/3-1/2 C p3221 t(k i z)=t(h k z+2/3) take z 2/3-5/6 C C---- p3121 use t(-k -i z)=t (h k z+2/3) transpose C p3221 use t(-k -i z)=t (h k z+1/3) transpose C IF (NumSFspaceGroup.EQ.152) IZ4 = IZ + NZ3 IF (NumSFspaceGroup.EQ.154) IZ4 = IZ + NZ23 IK4 = -II + 1 IH4 = NX - IK + 1 IF (IK.EQ.0) IH4 = 1 X(IZ4,KH) = CONJG(Y(IK4,IH4)) C C---- p3121 t(h i z)= t(h k -z-1/3) take z =2/3 _ 1/2 C p3221 t(h i z)= t(h k -z+1/3) take z =1/3 _ 1/6 C IF (NumSFspaceGroup.EQ.152) IZ5 = NZ23 - IZ + 2 IF (NumSFspaceGroup.EQ.154) IZ5 = NZ3 - IZ + 2 IK5 = -II + 1 IH5 = NX - IH + 1 IF (IH.EQ.0) IH5 = 1 X(IZ5,KH) = CONJG(Y(IK5,IH5)) C C---- p3121 t(i k z) = t(h k -z+1/3) take z 1/6 - 1/3 C p3221 t(i k z) = t(h k -z-1/3) take z 1/2 - 2/3 C IF (NumSFspaceGroup.EQ.152) IZ6 = NZ3 - IZ + 2 IF (NumSFspaceGroup.EQ.154) IZ6 = NZ23 - IZ + 2 IK6 = IK + 1 IH6 = NX + II + 1 IF (IH6.GT.NX) IH6 = 1 X(IZ6,KH) = Y(IK6,IH6) 40 CONTINUE 50 CONTINUE 60 CONTINUE END C C ================================================== SUBROUTINE IN169(X,NZ21,KM1,NSizePassTwo,R,Y,Kmax1, + NX1,IOscratch,NumSFspaceGroup) C ================================================= C C SYMM P61 C X,Y,Z C -Y,X-Y,1/3+Z C Y-X,-X,2/3+Z C C 2 fold screw C -X,-Y,1/2+Z C Y,Y-X,5/6+Z C X-Y,X,1/6+Z C C SYMM P65 C X,Y,Z C -Y,X-Y,2/3+Z C Y-X,-X,1/3+Z C 2 fold screw C -X,-Y,1/2+Z C Y,Y-X,1/6+Z C X-Y,X,5/6+Z C C---- we have transsforms t(h k z) z =0-1/6- C h takes all values; k >=0 C C we want t (h k z) z=0-1/2- for h>=0, k>=0 C use symmetry ops x y z ; .... z+1/3; ..... z+2/3 C Use 2 fold screw for following opns C If z+.. ge 1/2, C Use t(h k z+) = t(-h -k z+ -1/2) = t(h k z+ -1/2)*TRANSPOSE C C .. Scalar Arguments .. INTEGER IOscratch,KM1,Kmax1,NSizePassTwo,NumSFspaceGroup,NX1,NZ21, + R C .. C .. Array Arguments .. COMPLEX X(NZ21,KM1,NSizePassTwo),Y(Kmax1,NX1) C .. C .. Scalars in Common .. LOGICAL LNoScaleFlag,LverboseFlag C .. C .. Local Scalars .. INTEGER IER,IH,IH1,IH3,IH4,IHR1,II,IK,IK1,IK3,IK4,IZ,IZ3,IZ4,Nrec, + NX,NZ,NZ23,NZ3,NZ6,NZOV2 C .. C .. External Subroutines .. EXTERNAL QREAD,QSEEK C .. C .. Intrinsic Functions .. INTRINSIC ABS,CMPLX,CONJG C .. C .. Common blocks .. COMMON /TERSE/ + LverboseFlag,LNoScaleFlag C .. C NX = NX1 - 1 NZ = (NZ21-1)*2 NZOV2 = NZ/2 NZ6 = NZ/6 NZ3 = 2*NZ6 NZ23 = 2*NZ3 Nrec = 2*Kmax1*NX IF (LverboseFlag) WRITE (6,FMT=6000) NZ,KM1, + NSizePassTwo,R,Kmax1,NX1,NX,NZ3,NZ23 6000 FORMAT ( +' IN144 NZ KM1 NSizePassTwo R Kmax1 NX1 NX NZ3 NZ23',9I5) C DO 30 IH = 1,NSizePassTwo DO 20 IK = 1,Kmax1 DO 10 IZ = 1,NZ21 X(IZ,IK,IH) = CMPLX(0.0,0.0) 10 CONTINUE 20 CONTINUE 30 CONTINUE C C ************************* CALL QSEEK(IOscratch,1,1,Nrec) C ************************* C DO 70 IZ = 1,NZ6 C C ******************************** CALL QREAD(IOscratch,Y(1,1),Nrec,IER) C ******************************** C DO 40 IK1 = 1,Kmax1 Y(IK1,NX1) = Y(IK1,1) 40 CONTINUE C DO 60 IHR1 = 1,NSizePassTwo IH1 = IHR1 + R IH = IH1 - 1 C DO 50 IK1 = 1,KM1 IK = IK1 - 1 II = -IH - IK IF (ABS(II).GE.Kmax1) GO TO 50 C C---- p61/p65 t(h k z) = t(h k z) C X(IZ,IK1,IHR1) = Y(IK1,IH1) C C---- p61 t(i h z) = t(h k z+2/3) C = T(-h -k z+1/6) C = T(h k z+1/6)* TRANSPOSE C C---- p65 t(i h z) = t(h k z+1/3) C IF (NumSFspaceGroup.EQ.169) IZ3 = NZ23 + IZ IF (NumSFspaceGroup.EQ.170) IZ3 = NZ3 + IZ IK3 = IH + 1 IH3 = NX + II + 1 IF (IH3.GT.NX) IH3 = 1 IF (IZ3.LE.NZOV2) X(IZ3,IK1,IHR1) = Y(IK3,IH3) IF (IZ3.GT.NZOV2) + X(IZ3-NZOV2,IK1,IHR1) = CONJG(Y(IK3,IH3)) C C---- p61 t(k i z) = t(h k z+1/3) C C---- p65 t(k i z) = t(h k z+2/3) C = T(-h -k z+1/6) C = T(h k z+1/6)* TRANSPOSE C---- use t(-k -i z)=t (k i z) transpose C We need 2nd index ("I") positive... C IF (NumSFspaceGroup.EQ.169) IZ4 = IZ + NZ3 IF (NumSFspaceGroup.EQ.170) IZ4 = IZ + NZ23 IK4 = -II + 1 IH4 = NX - IK + 1 IF (IK.EQ.0) IH4 = 1 IF (IZ4.LE.NZOV2) X(IZ4,IK1,IHR1) = CONJG(Y(IK4,IH4)) IF (IZ4.GT.NZOV2) X(IZ4-NZOV2,IK1,IHR1) = Y(IK4,IH4) 50 CONTINUE 60 CONTINUE 70 CONTINUE END C C ==================================================== SUBROUTINE IN91(X,NZ21,IHKA,Y,Kmax1,NX1,NZ,IOscratch, + NumSFspaceGroup) C ==================================================== C C .. Scalar Arguments .. INTEGER IHKA,IOscratch,Kmax1,NumSFspaceGroup,NX1,NZ,NZ21 C .. C .. Array Arguments .. COMPLEX X(NZ21,IHKA),Y(Kmax1,NX1) C .. C .. Scalars in Common .. REAL RHmax,RHmean,RHmin,VolMtz INTEGER HmaxA,HminA,IXmax,IXmin,IYmax,IYmin,IZmax,IZmin,Jsec,JU1, + JU2,JV1,JV2,KHmin,NumSections,NumSFsymm,NX,NY C .. C .. Arrays in Common .. REAL CellMtz INTEGER Iuvw C .. C .. Local Scalars .. COMPLEX F REAL ABSY INTEGER IER,IH,IH1,IH3,IH4,IHmax1,IHmin1,IK,IK1,ISIGN,IZ,IZ2,IZ3, + IZ4,IZmax1,IZmin1,KH,Nrec,NZ41 C .. C .. Local Arrays .. REAL G(2) C .. C .. External Subroutines .. EXTERNAL QREAD,QSEEK C .. C .. Intrinsic Functions .. INTRINSIC ABS,CMPLX,CONJG,MOD C .. C .. Common blocks .. COMMON /MPHDR/ + NX,NY,MZ, + IXmin,IXmax,IYmin,IYmax,IZmin,IZmax, + Jsec,JU1,JU2,JV1,JV2,Iuvw(3), + NSFSpacGrpDum,NumSections, + RHmin,RHmax,RHmean,NumSFsymm, + CellMtz(6),VolMtz,Volfft,F000 COMMON /P41212/ + HminA,HmaxA,KHmin C .. C .. Equivalences .. EQUIVALENCE (F,G(1)) C .. C IZmin1 = IZmin + 1 IZmax1 = IZmax + 1 NX = NX1 - 1 NZ41 = NZ/4 + 1 Nrec = 2*Kmax1*NX C DO 20 IZ = 1,NZ21 DO 10 KH = 1,IHKA X(IZ,KH) = CMPLX(0.0,0.0) 10 CONTINUE 20 CONTINUE C C ********************** CALL QSEEK(IOscratch,1,1,1) C ********************** C DO 80 IZ = IZmin1,IZmax1 C C ******************************** CALL QREAD(IOscratch,Y(1,1),Nrec,IER) C ******************************** C DO 30 IK = 1,Kmax1 Y(IK,NX1) = Y(IK,1) 30 CONTINUE C IHmin1 = HminA + 1 IHmax1 = HmaxA + 1 C DO 70 IH = IHmin1,IHmax1 DO 60 IK = 1,IH IH1 = IH - 1 IK1 = IK - 1 KH = IH1*IH/2 + IK - KHmin Isign = MOD(IH+IK,2) C C---- No point generating equivalents for absy=0 C ABSY = ABS(Y(IK,IH)) IF (ABSY.EQ.0.0) GO TO 60 X(IZ,KH) = Y(IK,IH) C C Use following symmetry to generate t(k h z) C P4122 -Y,-X,1/4-Z C t(-k -h z)= t(h k 1/4-z) - t(k h z )=t(h k 1/4-z) transpose C P41212 -Y,-X,1/2-Z C t(-k -h z)= t(h k 1/2-z) - t(k h z )=t(h k 1/2-z) transpose C P4322 Y, X,1/4-Z C t( k h z)= t(h k 1/4-z) C P43212 -Y,-X,1/2-Z C t(-k -h z)= t(h k 1/2-z) - t(k h z )=t(h k 1/2-z) transpose C C for p41212 and p43212 use t(-k -h z)= t(h k 1/2-z) C t(k h z )=t(h k 1/2-z) transpose C IF (NumSFspaceGroup.EQ.91 )IZ2 = NZ41 - IZ + 1 IF (NumSFspaceGroup.EQ.92 )IZ2 = NZ21 - IZ + 1 IF (NumSFspaceGroup.EQ.95 )IZ2 = NZ41 - IZ + 1 IF (NumSFspaceGroup.EQ.96 )IZ2 = NZ21 - IZ + 1 IF (IZ2.LT.NZ21) X(IZ2,KH) = CONJG(Y(IH,IK)) IF (NumSFspaceGroup.EQ.95) X(IZ2,KH) = Y(IH,IK) C C Use following symmetry to generate t(-h k z) C P4122 X, -Y,1/2-Z C t(h -k z) = t(h k 1/2-z) - t(-h k z)=t(h -k z)transpose C P41212 1/2-X,1/2+Y,1/4-Z C t(-h k z) = t(h k 1/4-z)*(-1)**(h+k) C P4322 X, -Y,1/2-Z C t(h -k z) = t(h k 1/2-z) - t(-h k z)=t(h -k z)transpose C P43212 1/2+X,1/2-Y,1/4-Z C t(h -k z) = t(h k 1/4-z)*(-1)**(h+k) - t(-h k z)=t(h -k z)transpose C C---- p41212 t(-h k z) = t(h k 1/4-z)*(-1)**(h+k) C p43212 t(h -k z) = t(h k 1/4-z)*(-1)**(h+k) C p43212 t(-h k z)=t(h -k z)transpose C IH3 = NX - IH1 + 1 IF (NumSFspaceGroup.EQ.91 )IZ3 = NZ21 - IZ + 1 IF (NumSFspaceGroup.EQ.92 )IZ3 = NZ41 - IZ + 1 IF (NumSFspaceGroup.EQ.95 )IZ3 = NZ21 - IZ + 1 IF (NumSFspaceGroup.EQ.96 )IZ3 = NZ41 - IZ + 1 F = Y(IK,IH3) IF (NumSFspaceGroup.NE.92) F = CONJG(F) IF (Isign.EQ.0 .OR. + NumSFspaceGroup.EQ.91 .OR. + NumSFspaceGroup.EQ.95) GO TO 40 G(1) = -G(1) G(2) = -G(2) 40 IF (IZ3.LT.NZ21)X(IZ3,KH) = F C C Use following symmetry to generate t(-k h z) C P4122 Y,-X,-1/4+Z C t( k -h z)= t(h k 1/4+z) - t(-k h z)=t(k -h z)transpose C P41212 1/2+Y,1/2-X.-1/4+Z C t( k -h z)= t(h k 1/4+z)*(-1)**(h+k) - t(-k h z)=t(k -h z)transpose C P4322 -Y, X,-1/4+Z C t(-k h z)= t(h k 1/4+z) C P43212 1/2-Y,1/2+X.-1/4+Z C t(-k h z)= t(h k 1/4+z)*(-1)**(h+k) C C p41212 t(k -h z)=t(h k 1/4+z)*(-1)**(h+k) C p43212 t(-k h z)=t(h k 1/4+z)*(-1)**(h+k) C t(k -h z)=conjg(t(-k h z)) C IH4 = NX - IK1 + 1 IF (NumSFspaceGroup.EQ.91 )IZ4 = NZ41 + IZ - 1 IF (NumSFspaceGroup.EQ.92 )IZ4 = NZ41 + IZ - 1 IF (NumSFspaceGroup.EQ.95 )IZ4 = NZ41 + IZ - 1 IF (NumSFspaceGroup.EQ.96 )IZ4 = NZ41 + IZ - 1 F = Y(IH,IH4) IF (NumSFspaceGroup.EQ.91 .OR. + NumSFspaceGroup.EQ.92) F = CONJG(F) IF (Isign.EQ.0 .OR. + NumSFspaceGroup.EQ.91 .OR. + NumSFspaceGroup.EQ.95) GO TO 50 G(1) = -G(1) G(2) = -G(2) 50 X(IZ4,KH) = F 60 CONTINUE 70 CONTINUE 80 CONTINUE END C C ============================== SUBROUTINE INV21SC(X,N1,N2,N3) C ============================== C C Add this subroutine to correct for C 2 fold screw half scale... 24-8-88 C always called before calling inv21 C C .. Scalar Arguments .. INTEGER N1,N2,N3 C .. C .. Array Arguments .. COMPLEX X(N1,N2,N3) C .. C .. Local Scalars .. INTEGER I1,I2,I3 C .. C DO 30 I3 = 1,N3 DO 20 I2 = 1,N2 DO 10 I1 = 1,N1 X(I1,I2,I3) = X(I1,I2,I3)*2.0 10 CONTINUE 20 CONTINUE 30 CONTINUE C END C C =============================== SUBROUTINE MLTBL152(X,N1,N2,N3) C =============================== C C---- prepare to calculate 4sin2/landa2 C p3121 n1=2*nz n2=ihka n3=1 C C .. Scalar Arguments .. INTEGER N1,N2,N3 C .. C .. Array Arguments .. REAL X(N1,N2,N3) C .. C .. Scalars in Common .. REAL RHmax,RHmean,RHmin,VolMtz INTEGER Hmax,Hmin,IHmaxA,IHminA,IXmax,IXmin,IYmax,IYmin,IZmax, + IZmin,Jsec,JU1,JU2,JV1,JV2,KHmin,Kmax,Kmin,Lmax,Lmin, + Nslab,NumSections,NumSFspaceGroup,NumSFsymm,NX,NY,NZ C .. C .. Arrays in Common .. REAL CellMtz INTEGER Iuvw C .. C .. Local Scalars .. REAL A1,A2,A3,ALPH,ALPHA,AS,B1,B2,B3,BET,BETA,BS,C1,C2,C3,CONV, + COSA,COSAS,COSB,COSBS,COSC,COSCS,CS,FACT,GAMM,GAMMA,S,SH, + SINA,SINB,SINC,SK,SL,V INTEGER IH,IH1,IHmax1,IHmin1,IK,IK1,IL,KH,L C .. C .. Intrinsic Functions .. INTRINSIC COS,NINT,SIN,SQRT C .. C .. Common blocks .. COMMON /HKLLIM/ + Hmax,Kmax,Lmax,Hmin,Kmin,Lmin,Nslab COMMON /MPHDR/ + NX,NY,NZ, + IXmin,IXmax,IYmin,IYmax,IZmin,IZmax, + Jsec,JU1,JU2,JV1,JV2,Iuvw(3), + NumSFspaceGroup,NumSections, + RHmin,RHmax,RHmean,NumSFsymm, + CellMtz(6),VolMtz,Volfft,F000 COMMON /P41212/ + IHminA,IHmaxA,KHmin C .. C A1 = CellMtz(1) B1 = CellMtz(2) C1 = CellMtz(3) ALPHA = CellMtz(4) BETA = CellMtz(5) GAMMA = CellMtz(6) CONV = 3.14159/180.0 ALPH = ALPHA*CONV BET = BETA*CONV GAMM = GAMMA*CONV S = (ALPH+BET+GAMM)/2.0 V = 2.0*A1*B1*C1* + SQRT(SIN(S-ALPH)*SIN(S)*SIN(S-BET)*SIN(S-GAMM)) C COSA = COS(ALPH) COSB = COS(BET) COSC = COS(GAMM) SINA = SIN(ALPH) SINB = SIN(BET) SINC = SIN(GAMM) AS = B1*C1*SINA/V BS = C1*A1*SINB/V CS = A1*B1*SINC/V C COSAS = COSB*COSC - COSA/ (SINB*SINC) COSBS = COSC*COSA - COSB/ (SINC*SINA) COSCS = COSA*COSB - COSC/ (SINC*SINA) C A2 = AS*AS B2 = BS*BS C2 = CS*CS A3 = 2.0*BS*CS*COSAS B3 = 2.0*CS*AS*COSBS C3 = 2.0*AS*BS*COSCS IHmin1 = IHminA + 1 IHmax1 = IHmaxA + 1 C DO 30 IH1 = IHmin1,IHmax1 SH = IH1 - 1 IH = NINT(SH) DO 20 IK1 = 1,IH1 IK = IK1 - 1 SK = IK KH = IH*IH1/2 + IK1 - KHmin DO 10 IL = 1,N1,2 L = IL/2 IF (L.GT.Lmax) L = L - NZ IF (L.LT.Lmin) GO TO 10 SL = L C C---- for b gradient multiply differences by -s**2/4 C FACT = SH*SH*A2 + + SK*SK*B2 + + SL*SL*C2 + + SK*SL*A3 + + SL*SH*B3 + + SH*SK*C3 X(IL,KH,1) = -X(IL,KH,1)*FACT X(IL+1,KH,1) = -X(IL+1,KH,1)*FACT C C---- for z gradient multiply by -il/C 10 CONTINUE 20 CONTINUE 30 CONTINUE END C C ============================== SUBROUTINE MLTBL92(X,N1,N2,N3) C ============================== C C---- prepare to calculate 4sin2/landa2 C p3121 n1=2*nz n2=ihka n3=1 C C .. Scalar Arguments .. INTEGER N1,N2,N3 C .. C .. Array Arguments .. REAL X(N1,N2,N3) C .. C .. Scalars in Common .. REAL RHmax,RHmean,RHmin,VolMtz INTEGER IHmaxA,IHminA,IXmax,IXmin,IYmax,IYmin,IZmax,IZmin,Jsec, + JU1,JU2,JV1,JV2,KHmin,Kmax,Kmin,Lmax,Lmin,Nslab, + NumSections,NumSFspaceGroup,NumSFsymm,NX,NY,NZ, + Hmax,Hmin C .. C .. Arrays in Common .. REAL CellMtz INTEGER Iuvw C .. C .. Local Scalars .. REAL A1,A2,A3,ALPH,ALPHA,AS,B1,B2,B3,BET,BETA,BS,C1,C2,C3,CONV, + COSA,COSAS,COSB,COSBS,COSC,COSCS,CS,FACT,GAMM,GAMMA,S,SH, + SINA,SINB,SINC,SK,SL,V INTEGER IH,IH1,IHmax1,IHmin1,IK,IK1,IL,KH,L,M C .. C .. Intrinsic Functions .. INTRINSIC COS,NINT,SIN,SQRT C .. C .. Common blocks .. COMMON /HKLLIM/ + Hmax,Kmax,Lmax,Hmin,Kmin,Lmin,Nslab COMMON /MPHDR/ + NX,NY,NZ, + IXmin,IXmax,IYmin,IYmax,IZmin,IZmax, + Jsec,JU1,JU2,JV1,JV2,Iuvw(3), + NumSFspaceGroup,NumSections, + RHmin,RHmax,RHmean,NumSFsymm, + CellMtz(6),VolMtz,Volfft,F000 COMMON /P41212/ + IHminA,IHmaxA,KHmin C .. C A1 = CellMtz(1) B1 = CellMtz(2) C1 = CellMtz(3) ALPHA = CellMtz(4) BETA = CellMtz(5) GAMMA = CellMtz(6) CONV = 3.14159/180.0 ALPH = ALPHA*CONV BET = BETA*CONV GAMM = GAMMA*CONV S = (ALPH+BET+GAMM)/2.0 V = 2.0*A1*B1*C1* + SQRT(SIN(S-ALPH)*SIN(S)*SIN(S-BET)*SIN(S-GAMM)) C COSA = COS(ALPH) COSB = COS(BET) COSC = COS(GAMM) SINA = SIN(ALPH) SINB = SIN(BET) SINC = SIN(GAMM) AS = B1*C1*SINA/V BS = C1*A1*SINB/V CS = A1*B1*SINC/V C COSAS = COSB*COSC - COSA/ (SINB*SINC) COSBS = COSC*COSA - COSB/ (SINC*SINA) COSCS = COSA*COSB - COSC/ (SINC*SINA) C A2 = AS*AS B2 = BS*BS C2 = CS*CS A3 = 2.0*BS*CS*COSAS B3 = 2.0*CS*AS*COSBS C3 = 2.0*AS*BS*COSCS M = 2*Lmax + 1 IHmin1 = IHminA + 1 IHmax1 = IHmaxA + 1 C DO 30 IH1 = IHmin1,IHmax1 SH = IH1 - 1 IH = NINT(SH) DO 20 IK1 = 1,IH1 IK = IK1 - 1 SK = IK KH = IH*IH1/2 + IK1 - KHmin DO 10 IL = 1,M,2 L = IL/2 SL = L C C---- for b gradient multiply differences by -s**2/4 C FACT = SH*SH*A2 + + SK*SK*B2 + + SL*SL*C2 + + SK*SL*A3 + + SL*SH*B3 + + SH*SK*C3 X(IL,KH,1) = -X(IL,KH,1)*FACT X(IL+1,KH,1) = -X(IL+1,KH,1)*FACT GO TO 10 10 CONTINUE 20 CONTINUE 30 CONTINUE END C C ========================================= SUBROUTINE MULTBK(X,MY,MZ,MX,Kmax,Kmin,R) C ========================================= C C .. Scalar Arguments .. INTEGER Kmax,Kmin,MX,MY,MZ,R C .. C .. Array Arguments .. REAL X(MY,MZ,MX) C .. C .. Scalars in Common .. REAL RHmax,RHmean,RHmin,VolMtz INTEGER IXmax,IXmin,IYmax,IYmin,IZmax,IZmin,Jsec,JU1,JU2,JV1,JV2, + NumSections,NumSFspaceGroup,NumSFsymm,NX,NY,NZ C .. C .. Arrays in Common .. REAL CellMtz INTEGER Iuvw C .. C .. Local Scalars .. REAL A1,A2,A3,ALPH,ALPHA,AS,B1,B2,B3,BET,BETA,BS,C1,C2,C3,CONV, + COSA,COSAS,COSB,COSBS,COSC,COSCS,CS,FACT,GAMM,GAMMA,S,SH, + SINA,SINB,SINC,SK,SL,V INTEGER IH,IK,IL,K C .. C .. Intrinsic Functions .. INTRINSIC COS,SIN,SQRT C .. C .. Common blocks .. COMMON /MPHDR/ + NX,NY,NZ, + IXmin,IXmax,IYmin,IYmax,IZmin,IZmax, + Jsec,JU1,JU2,JV1,JV2,Iuvw(3), + NumSFspaceGroup,NumSections, + RHmin,RHmax,RHmean,NumSFsymm, + CellMtz(6),VolMtz,Volfft,F000 C .. C A1 = CellMtz(1) B1 = CellMtz(2) C1 = CellMtz(3) ALPHA = CellMtz(4) BETA = CellMtz(5) GAMMA = CellMtz(6) CONV = 3.14159/180.0 ALPH = ALPHA*CONV BET = BETA*CONV GAMM = GAMMA*CONV S = (ALPH+BET+GAMM)/2.0 V = 2.0*A1*B1*C1* + SQRT(SIN(S-ALPH)*SIN(S)*SIN(S-BET)*SIN(S-GAMM)) C COSA = COS(ALPH) COSB = COS(BET) COSC = COS(GAMM) SINA = SIN(ALPH) SINB = SIN(BET) SINC = SIN(GAMM) AS = B1*C1*SINA/V BS = C1*A1*SINB/V CS = A1*B1*SINC/V C COSAS = COSB*COSC - COSA/ (SINB*SINC) COSBS = COSC*COSA - COSB/ (SINC*SINA) COSCS = COSA*COSB - COSC/ (SINC*SINA) C A2 = AS*AS B2 = BS*BS C2 = CS*CS A3 = 2.0*BS*CS*COSAS B3 = 2.0*CS*AS*COSBS C3 = 2.0*AS*BS*COSCS C DO 30 IH = 1,MX SH = IH + R - 1 DO 20 IL = 1,MZ SL = IL - 1 DO 10 IK = 1,MY,2 K = IK/2 IF (K.GT.Kmax) K = K - MY/2 IF (K.GE.Kmin) THEN SK = K C C---- For b gradient multiply differences by -s**2/4 C FACT = SH*SH*A2 + + SK*SK*B2 + + SL*SL*C2 + + SK*SL*A3 + + SL*SH*B3 + + SH*SK*C3 X(IK,IL,IH) = -X(IK,IL,IH)*FACT X(IK+1,IL,IH) = -X(IK+1,IL,IH)*FACT END IF 10 CONTINUE 20 CONTINUE 30 CONTINUE C END C C ========================================= SUBROUTINE MULTBL(X,MZ,MY,MX,Lmax,Lmin,R) C ========================================= C C---- mz my mx NOT the actual grid limits C C .. Scalar Arguments .. INTEGER Lmax,Lmin,MX,MY,MZ,R C .. C .. Array Arguments .. REAL X(MZ,MY,MX) C .. C .. Scalars in Common .. REAL RHmax,RHmean,RHmin,VolMtz INTEGER IXmax,IXmin,IYmax,IYmin,IZmax,IZmin,Jsec,JU1,JU2,JV1,JV2, + NumSections,NumSFspaceGroup,NumSFsymm,NX,NY,NZ C .. C .. Arrays in Common .. REAL CellMtz INTEGER Iuvw C .. C .. Local Scalars .. REAL A1,A2,A3,ALPH,ALPHA,AS,B1,B2,B3,BET,BETA,BS,C1,C2,C3,CONV, + COSA,COSAS,COSB,COSBS,COSC,COSCS,CS,FACT,GAMM,GAMMA,S,SH, + SINA,SINB,SINC,SK,SL,V INTEGER IH,IK,IL,L C .. C .. Intrinsic Functions .. INTRINSIC COS,SIN,SQRT C .. C .. Common blocks .. COMMON /MPHDR/ + NX,NY,NZ, + IXmin,IXmax,IYmin,IYmax,IZmin,IZmax, + Jsec,JU1,JU2,JV1,JV2,Iuvw(3), + NumSFspaceGroup,NumSections, + RHmin,RHmax,RHmean,NumSFsymm, + CellMtz(6),VolMtz,Volfft,F000 C .. C A1 = CellMtz(1) B1 = CellMtz(2) C1 = CellMtz(3) ALPHA = CellMtz(4) BETA = CellMtz(5) GAMMA = CellMtz(6) CONV = 3.14159/180.0 ALPH = ALPHA*CONV BET = BETA*CONV GAMM = GAMMA*CONV S = (ALPH+BET+GAMM)/2.0 V = 2.0*A1*B1*C1* + SQRT(SIN(S-ALPH)*SIN(S)*SIN(S-BET)*SIN(S-GAMM)) C COSA = COS(ALPH) COSB = COS(BET) COSC = COS(GAMM) SINA = SIN(ALPH) SINB = SIN(BET) SINC = SIN(GAMM) AS = B1*C1*SINA/V BS = C1*A1*SINB/V CS = A1*B1*SINC/V C COSAS = COSB*COSC - COSA/ (SINB*SINC) COSBS = COSC*COSA - COSB/ (SINC*SINA) COSCS = COSA*COSB - COSC/ (SINC*SINA) C A2 = AS*AS B2 = BS*BS C2 = CS*CS A3 = 2.0*BS*CS*COSAS B3 = 2.0*CS*AS*COSBS C3 = 2.0*AS*BS*COSCS C DO 30 IH = 1,MX SH = IH + R - 1 DO 20 IK = 1,MY SK = IK - 1 DO 10 IL = 1,MZ,2 L = IL/2 IF (L.GT.Lmax) L = L - MZ/2 IF (L.GE.Lmin) THEN SL = L C C---- for b gradient multiply differences by -s**2/4 C FACT = SH*SH*A2 + + SK*SK*B2 + + SL*SL*C2 + + SK*SL*A3 + + SL*SH*B3 + + SH*SK*C3 X(IL,IK,IH) = -X(IL,IK,IH)*FACT X(IL+1,IK,IH) = -X(IL+1,IK,IH)*FACT END IF 10 CONTINUE 20 CONTINUE 30 CONTINUE C END C C =========================================== SUBROUTINE MULTBLR3(X,MZ,MY,MX,Lmax,Lmin,R) C =========================================== C C---- mz my mx NOT the actual grid limits C C .. Scalar Arguments .. INTEGER Lmax,Lmin,MX,MY,MZ,R C .. C .. Array Arguments .. REAL X(MZ,MY,MX) C .. C .. Scalars in Common .. REAL RHmax,RHmean,RHmin,VolMtz INTEGER IXmax,IXmin,IYmax,IYmin,IZmax,IZmin,Jsec,JU1,JU2,JV1,JV2, + NumSections,NumSFspaceGroup,NumSFsymm,NX,NY,NZ C .. C .. Arrays in Common .. REAL CellMtz INTEGER Iuvw C .. C .. Local Scalars .. REAL A1,A2,A3,ALPH,ALPHA,AS,B1,B2,B3,BET,BETA,BS,C1,C2,C3,CONV, + COSA,COSAS,COSB,COSBS,COSC,COSCS,CS,FACT,GAMM,GAMMA,S,SH, + SINA,SINB,SINC,SK,SL,V INTEGER IH,IK,IL,JH,JK,L,LDASH,Lmax3 C .. C .. Intrinsic Functions .. INTRINSIC COS,MOD,NINT,SIN,SQRT C .. C .. Common blocks .. COMMON /MPHDR/ + NX,NY,NZ, + IXmin,IXmax,IYmin,IYmax,IZmin,IZmax, + Jsec,JU1,JU2,JV1,JV2,Iuvw(3), + NumSFspaceGroup,NumSections, + RHmin,RHmax,RHmean,NumSFsymm, + CellMtz(6),VolMtz,Volfft,F000 C .. C A1 = CellMtz(1) B1 = CellMtz(2) C1 = CellMtz(3) ALPHA = CellMtz(4) BETA = CellMtz(5) GAMMA = CellMtz(6) CONV = 3.14159/180.0 ALPH = ALPHA*CONV BET = BETA*CONV GAMM = GAMMA*CONV S = (ALPH+BET+GAMM)/2.0 V = 2.0*A1*B1*C1* + SQRT(SIN(S-ALPH)*SIN(S)*SIN(S-BET)*SIN(S-GAMM)) C COSA = COS(ALPH) COSB = COS(BET) COSC = COS(GAMM) SINA = SIN(ALPH) SINB = SIN(BET) SINC = SIN(GAMM) AS = B1*C1*SINA/V BS = C1*A1*SINB/V CS = A1*B1*SINC/V C COSAS = COSB*COSC - COSA/ (SINB*SINC) COSBS = COSC*COSA - COSB/ (SINC*SINA) COSCS = COSA*COSB - COSC/ (SINC*SINA) C A2 = AS*AS B2 = BS*BS C2 = CS*CS A3 = 2.0*BS*CS*COSAS B3 = 2.0*CS*AS*COSBS C3 = 2.0*AS*BS*COSCS C Lmax3 = Lmax/3 + 1 C DO 30 IH = 1,MX SH = IH + R - 1 DO 20 IK = 1,MY SK = IK - 1 DO 10 IL = 1,MZ,2 LDASH = IL/2 IF (LDASH.GT.Lmax3) LDASH = MZ/2 - LDASH IF (LDASH.LT.Lmin) GO TO 10 JH = NINT(SH) JK = NINT(SK) L = MOD((JH-JK+3000),3) + 3*LDASH SL = L C C---- for b gradient multiply differences by -s**2/4 C FACT = SH*SH*A2 + + SK*SK*B2 + + SL*SL*C2 + + SK*SL*A3 + + SL*SH*B3 + + SH*SK*C3 X(IL,IK,IH) = -X(IL,IK,IH)*FACT X(IL+1,IK,IH) = -X(IL+1,IK,IH)*FACT 10 CONTINUE 20 CONTINUE 30 CONTINUE END C C ======================================= SUBROUTINE MULTFS(X,NZ,NK,NH,Lmax,Hmin) C ======================================= C C .. Scalar Arguments .. INTEGER Hmin,Lmax,NH,NK,NZ C .. C .. Array Arguments .. COMPLEX X(NZ,NK,NH) C .. C .. Local Scalars .. COMPLEX C INTEGER H,I,K,L,LM1 C .. C .. Intrinsic Functions .. INTRINSIC AIMAG,CMPLX,REAL C .. C LM1 = Lmax + 1 I = 1 IF ((Hmin/2)*2.EQ.Hmin) I = 2 IF (I.GT.NH) GO TO 40 C DO 30 H = I,NH,2 DO 20 K = 1,NK DO 10 L = 1,LM1 C = X(L,K,H) X(L,K,H) = CMPLX(AIMAG(C),-REAL(C)) 10 CONTINUE 20 CONTINUE 30 CONTINUE 40 RETURN END C C ====================================== SUBROUTINE MULTI(X,NZ,NY,NX,Lmax,EVEN) C ====================================== C C---- multiplies h = 2n + 1 structure factors by i C C .. Scalar Arguments .. INTEGER EVEN,Lmax,NX,NY,NZ C .. C .. Array Arguments .. REAL X(NZ,NY,NX) C .. C .. Local Scalars .. REAL A INTEGER H,HL,K,L,M C .. C .. Intrinsic Functions .. INTRINSIC MOD C .. C HL = MOD(EVEN+1,2) + 1 IF (HL.GT.NX) RETURN M = 2*Lmax + 1 C DO 30 H = HL,NX,2 DO 20 K = 1,NY DO 10 L = 1,M,2 A = X(L,K,H) X(L,K,H) = -X(L+1,K,H) X(L+1,K,H) = A 10 CONTINUE 20 CONTINUE 30 CONTINUE C END C C ======================== SUBROUTINE NEWLIN(LUN,N) C ======================== C C This subroutine is used to output a number of new lines C C Subroutine call C C CALL NEWLIN(LUN,N) C C Parameters C LUN (I) Logical unit number of output device C (no new lines output if lun=0) C N (I) Number of new lines to be output C C---- Check parameters and output new lines C C .. Scalar Arguments .. INTEGER LUN,N C .. C .. Local Scalars .. INTEGER I C .. C IF (LUN.NE.0) THEN IF (N.GT.0) THEN DO 10 I = 1,N WRITE (LUN,FMT=6000) 10 CONTINUE END IF END IF C C---- Format statements C 6000 FORMAT (' ') C END C C ==================================================== SUBROUTINE OUT144(X,NZ,Kmax1,NSizePassOne,Y,NX,R, + IOscratch,NumSFspaceGroup,Nrec) C ==================================================== C C .. Scalar Arguments .. INTEGER IOscratch,Kmax1,Nrec,NSizePassOne,NumSFspaceGroup,NX,NZ,R C .. C .. Array Arguments .. COMPLEX X(NZ,Kmax1,NSizePassOne),Y(Kmax1,NX) C .. C .. Scalars in Common .. LOGICAL LNoScaleFlag,LverboseFlag C .. C .. Local Scalars .. COMPLEX F REAL ABSF INTEGER I,IER,IH,IH1,IH3,IH4,IHmax1,IHmin1,IHS,II,IK,IK1,IK3,IK4, + IZ,IZ3,IZ4,K,NZ2OV3,NZOV3 C .. C .. External Subroutines .. EXTERNAL QSEEK,QWRITE C .. C .. Intrinsic Functions .. INTRINSIC ABS,CMPLX,CONJG C .. C .. Common blocks .. COMMON /TERSE/ + LverboseFlag,LNoScaleFlag C .. C NZOV3 = NZ/3 NZ2OV3 = 2*NZOV3 IHmin1 = R + 1 IHmax1 = R + NSizePassOne C IF (LverboseFlag) WRITE (6,FMT=6000) + NZOV3,Kmax1,NSizePassOne,Kmax1,NX,R,IOscratch 6000 FORMAT ( + ' NZOV3 Kmax1 NSizePassOne Kmax1 NX R IOscratch ',7I5) C IF (R.GT.0) GO TO 40 C DO 20 I = 1,NX DO 10 K = 1,Kmax1 Y(K,I) = CMPLX(0.0,0.0) 10 CONTINUE 20 CONTINUE C C ************************* CALL QSEEK(IOscratch,1,1,Nrec) C ************************* C DO 30 IZ = 1,NZOV3 C C ***************************** CALL QWRITE(IOscratch,Y(1,1),Nrec) C ***************************** C 30 CONTINUE C 40 CONTINUE C C ************************* CALL QSEEK(IOscratch,1,1,Nrec) C ************************* C DO 70 IZ = 1,NZOV3 C C ******************************** CALL QREAD(IOscratch,Y(1,1),Nrec,IER) C ******************************** C DO 60 IH1 = IHmin1,IHmax1 IHS = IH1 - IHmin1 + 1 IF (IHmin1.EQ.1) Y(1,1) = X(IZ,1,1) C DO 50 IK1 = 1,Kmax1 IH = IH1 - 1 IK = IK1 - 1 F = X(IZ,IK1,IHS) C C---- No point generating equivalents for absf=0 C ABSF = ABS(F) IF (ABSF.EQ.0.0) GO TO 50 II = -IH - IK IF (ABS(II).GE.Kmax1) GO TO 50 Y(IK1,IH1) = X(IZ,IK1,IHS) IF (IK1.EQ.1 .AND. IH1.GT.1) + Y(1,NX+2-IH1) = CONJG(Y(1,IH1)) C C---- p31 t(i h z)= t(h k z+2/3) take z C p32 t(i h z)= t(h k z+1/3) take z C IF (NumSFspaceGroup.EQ.144) IZ3 = NZ2OV3 + IZ IF (NumSFspaceGroup.EQ.145) IZ3 = NZOV3 + IZ IK3 = IH + 1 IH3 = NX + II + 1 IF (IH3.GT.NX) IH3 = 1 Y(IK3,IH3) = X(IZ3,IK1,IHS) IF (IK3.EQ.1 .AND. IH3.GT.1) + Y(1,NX+2-IH3) = CONJG(Y(1,IH3)) C C---- p31 t(k i z)=t(h k z+1/3 ) take z C p32 t(k i z)=t(h k z+2/3 ) take z C C---- use t(-k -i z)=t (h k z+1/3) transpose C IF (NumSFspaceGroup.EQ.144) IZ4 = NZOV3 + IZ IF (NumSFspaceGroup.EQ.145) IZ4 = NZ2OV3 + IZ IK4 = -II + 1 IH4 = NX - IK + 1 IF (IK.EQ.0) IH4 = 1 Y(IK4,IH4) = CONJG(X(IZ4,IK1,IHS)) IF (IK4.EQ.1 .AND. IH4.GT.1) + Y(1,NX+2-IH4) = CONJG(Y(1,IH4)) C 50 CONTINUE 60 CONTINUE C C ***************************** CALL QSEEK(IOscratch,IZ,1,Nrec) CALL QWRITE(IOscratch,Y(1,1),Nrec) C ***************************** C 70 CONTINUE END C =================================================== SUBROUTINE OUT143(X,NZ,Kmax1,NSizePassOne,Y, + NX,R,IOscratch) C ============================================== C C .. Scalar Arguments .. INTEGER IOscratch,Kmax1,NSizePassOne,NX,NZ,R C .. C .. Array Arguments .. COMPLEX X(NZ,Kmax1,NSizePassOne),Y(Kmax1,NX) C .. C .. Local Scalars .. COMPLEX F REAL ABSF INTEGER I,IER,IH,IH1,IH3,IH4,IHmax1,IHmin1,IHS,II,IK,IK1,IK3,IK4, + IZ,K,Nrec C .. C .. External Subroutines .. EXTERNAL QREAD,QSEEK,QWRITE C .. C .. Intrinsic Functions .. INTRINSIC ABS,CMPLX,CONJG,COS,MOD,REAL,SIN C .. C Nrec = 2*Kmax1*NX IHmin1 = R + 1 IHmax1 = R + NSizePassOne IF (R.GT.0) GO TO 40 C DO 20 I = 1,NX DO 10 K = 1,Kmax1 Y(K,I) = CMPLX(0.0,0.0) 10 CONTINUE 20 CONTINUE C C ************************* CALL QSEEK(IOscratch,1,1,Nrec) C ************************* C DO 30 IZ = 1,NZ C C ***************************** CALL QWRITE(IOscratch,Y(1,1),Nrec) C ***************************** C 30 CONTINUE 40 CONTINUE C C ************************* CALL QSEEK(IOscratch,1,1,Nrec) C ************************* C DO 80 IZ = 1,NZ C C ******************************** CALL QREAD(IOscratch,Y(1,1),Nrec,IER) C ******************************** C DO 70 IH1 = IHmin1,IHmax1 IHS = IH1 - IHmin1 + 1 IF (IH1.EQ.1) Y(1,1) = X(IZ,1,1) DO 60 IK1 = 2,Kmax1 IH = IH1 - 1 IK = IK1 - 1 C F = X(IZ,IK1,IHS) C C---- No point generating equivalents for absf=0 C ABSF = ABS(F) IF (ABSF.EQ.0.0) GO TO 60 50 II = -IH - IK IF (ABS(II).GE.Kmax1) GO TO 60 Y(IK1,IH1) = X(IZ,IK1,IHS) C C---- t(i h z)= t(h k z) take z C IK3 = IH + 1 IH3 = NX + II + 1 IF (IH3.GT.NX) IH3 = 1 Y(IK3,IH3) = X(IZ,IK1,IHS) IF (IK3.EQ.1) Y(1,-II+1) = CONJG(X(IZ,IK1,IHS)) C C---- t(k i z)=t(h k z ) take z C C---- use t(-k -i z)=t (h k z) transpose C IK4 = -II + 1 IH4 = NX - IK + 1 IF (IK.EQ.0) IH4 = 1 Y(IK4,IH4) = CONJG(X(IZ,IK1,IHS)) 60 CONTINUE 70 CONTINUE C C ***************************** CALL QSEEK(IOscratch,IZ,1,Nrec) CALL QWRITE(IOscratch,Y(1,1),Nrec) C ***************************** C 80 CONTINUE END C C ============================================== SUBROUTINE OUT146(X,NZOV3,Kmax1,NSizePassOne,Y, + NX,R,IOscratch) C ============================================== C C .. Scalar Arguments .. INTEGER IOscratch,Kmax1,NSizePassOne,NX,NZOV3,R C .. C .. Array Arguments .. COMPLEX X(NZOV3,Kmax1,NSizePassOne),Y(Kmax1,NX) C .. C .. Local Scalars .. COMPLEX F REAL ABSF,AZ,GM,RL,TWOPI INTEGER I,IER,IH,IH1,IH3,IH4,IHmax1,IHmin1,IHS,II,IK,IK1,IK3,IK4, + IZ,K,Lmod3,Nrec,NZ C .. C .. Local Arrays .. REAL ACORR(2),BCORR(2),G(2) C .. C .. External Subroutines .. EXTERNAL QREAD,QSEEK,QWRITE C .. C .. Intrinsic Functions .. INTRINSIC ABS,CMPLX,CONJG,COS,MOD,REAL,SIN C .. C .. Equivalences .. EQUIVALENCE (F,G(1)) C .. C NZ = NZOV3*3 Nrec = 2*Kmax1*NX TWOPI = 6.28318 IHmin1 = R + 1 IHmax1 = R + NSizePassOne IF (R.GT.0) GO TO 40 C DO 20 I = 1,NX DO 10 K = 1,Kmax1 Y(K,I) = CMPLX(0.0,0.0) 10 CONTINUE 20 CONTINUE C C ************************* CALL QSEEK(IOscratch,1,1,Nrec) C ************************* C DO 30 IZ = 1,NZOV3 C C ***************************** CALL QWRITE(IOscratch,Y(1,1),Nrec) C ***************************** C 30 CONTINUE 40 CONTINUE C C ************************* CALL QSEEK(IOscratch,1,1,Nrec) C ************************* C DO 80 IZ = 1,NZOV3 AZ = -REAL(IZ-1)*TWOPI/NZ ACORR(1) = COS(AZ) BCORR(1) = SIN(AZ) AZ = 2.0*AZ ACORR(2) = COS(AZ) BCORR(2) = SIN(AZ) C C ******************************** CALL QREAD(IOscratch,Y(1,1),Nrec,IER) C ******************************** C DO 70 IH1 = IHmin1,IHmax1 IHS = IH1 - IHmin1 + 1 IF (IH1.EQ.1) Y(1,1) = X(IZ,1,1) DO 60 IK1 = 2,Kmax1 IH = IH1 - 1 IK = IK1 - 1 C C---- correction factor for dividing l by 3. C Lmod3 = MOD(IH-IK+300,3) F = X(IZ,IK1,IHS) C C---- No point generating equivalents for absf=0 C ABSF = ABS(F) IF (ABSF.EQ.0.0) GO TO 60 IF (Lmod3.EQ.0) GO TO 50 RL = G(1)*ACORR(Lmod3) - G(2)*BCORR(Lmod3) GM = G(1)*BCORR(Lmod3) + G(2)*ACORR(Lmod3) G(1) = RL G(2) = GM X(IZ,IK1,IHS) = F 50 II = -IH - IK IF (ABS(II).GE.Kmax1) GO TO 60 Y(IK1,IH1) = X(IZ,IK1,IHS) C C---- t(i h z)= t(h k z) take z C IK3 = IH + 1 IH3 = NX + II + 1 IF (IH3.GT.NX) IH3 = 1 Y(IK3,IH3) = X(IZ,IK1,IHS) IF (IK3.EQ.1) Y(1,-II+1) = CONJG(X(IZ,IK1,IHS)) C C---- t(k i z)=t(h k z ) take z C C---- use t(-k -i z)=t (h k z) transpose C IK4 = -II + 1 IH4 = NX - IK + 1 IF (IK.EQ.0) IH4 = 1 Y(IK4,IH4) = CONJG(X(IZ,IK1,IHS)) 60 CONTINUE 70 CONTINUE C C ***************************** CALL QSEEK(IOscratch,IZ,1,Nrec) CALL QWRITE(IOscratch,Y(1,1),Nrec) C ***************************** C 80 CONTINUE END C C ================================================ SUBROUTINE OUT152(X,NZ,IHKA,Y,Kmax1,NX,IOscratch, + NumSFspaceGroup,Nrec) C =============================================== C C .. Scalar Arguments .. INTEGER IHKA,IOscratch,Kmax1,Nrec,NumSFspaceGroup,NX,NZ C .. C .. Array Arguments .. COMPLEX X(NZ,IHKA),Y(Kmax1,NX) C .. C .. Scalars in Common .. INTEGER HmaxA,HminA,KHmin LOGICAL LNoScaleFlag,LverboseFlag C .. C .. Local Scalars .. REAL ABSX INTEGER IER,IH,IH1,IH2,IH3,IH4,IH5,IH6,IHmax1,IHmin1,II,IK,IK1, + IK2,IK3,IK4,IK5,IK6,IX,IY,IZ,IZ2,IZ3,IZ4,IZ5,IZ6,KH,NZ23, + NZ3,NZ61 C .. C .. External Subroutines .. EXTERNAL QREAD,QSEEK,QWRITE C .. C .. Intrinsic Functions .. INTRINSIC ABS,CMPLX,CONJG C .. C .. Common blocks .. COMMON /P41212/ + HminA,HmaxA,KHmin COMMON /TERSE/ + LverboseFlag,LNoScaleFlag C .. C NZ61 = NZ/6 + 1 NZ3 = NZ/3 NZ23 = 2*NZ3 IF (HminA.GT.0) GO TO 40 C DO 20 IX = 1,NX DO 10 IY = 1,Kmax1 Y(IY,IX) = CMPLX(0.0,0.0) 10 CONTINUE 20 CONTINUE C C ************************* CALL QSEEK(IOscratch,1,1,Nrec) C ************************* C DO 30 IZ = 1,NZ61 C C ***************************** CALL QWRITE(IOscratch,Y(1,1),Nrec) C ***************************** C 30 CONTINUE 40 CONTINUE C C ************************* CALL QSEEK(IOscratch,1,1,Nrec) C ************************* C DO 70 IZ = 1,NZ61 C C ******************************** CALL QREAD(IOscratch,Y(1,1),Nrec,IER) C ******************************** C IHmin1 = HminA + 1 IHmax1 = HmaxA + 1 C DO 60 IH1 = IHmin1,IHmax1 DO 50 IK1 = 1,IH1 IH = IH1 - 1 IK = IK1 - 1 II = -IH - IK IF (ABS(II).GE.Kmax1) GO TO 50 KH = IH*IH1/2 + IK1 - KHmin C C---- No point generating equivalents for absx=0 C ABSX = ABS(X(IZ,KH)) IF (ABSX.EQ.0.0) GO TO 50 Y(IK1,IH1) = X(IZ,KH) IF (LverboseFlag) WRITE (6,FMT=6000) + IK1,IH1,IZ,KH,Y(IK,IH), + X(IZ,KH) 6000 FORMAT (2I5,5X,2I5,5X,2F5.0,5X,2F5.0) C C---- p3121 or p3221 - t((k h z)=t (h k -z) take z 5/6 - 1 C IH2 = IK + 1 IK2 = IH + 1 IZ2 = NZ - IZ + 2 IF (IZ2.GT.NZ) IZ2 = 1 Y(IK2,IH2) = X(IZ2,KH) C C---- p3121 t(i h z)= t(h k z+2/3) take z 2/3-5/6 C p3221 t(i h z)= t(h k z+1/3) take z 1/3-1/2 C IF (NumSFspaceGroup.EQ.152) IZ3 = NZ23 + IZ IF (NumSFspaceGroup.EQ.154) IZ3 = NZ3 + IZ II = -IH - IK IK3 = IH + 1 IH3 = NX + II + 1 IF (IH3.GT.NX) IH3 = 1 Y(IK3,IH3) = X(IZ3,KH) C C---- p3121 t(k i z)=t(h k z+1/3) take z 1/3-1/2 C p3221 t(k i z)=t(h k z+2/3) take z 2/3-5/6 C C---- use t(-k -i z)=t (h k z+1/3) transpose C IF (NumSFspaceGroup.EQ.152) IZ4 = IZ + NZ3 IF (NumSFspaceGroup.EQ.154) IZ4 = IZ + NZ23 IK4 = -II + 1 IH4 = NX - IK + 1 IF (IK.EQ.0) IH4 = 1 Y(IK4,IH4) = CONJG(X(IZ4,KH)) C C---- p3121 t(h i z)= t(h k -z-1/3) take z =2/3 _ 1/2 C p3221 t(h i z)= t(h k -z+1/3) take z =1/3 _ 1/6 C IF (NumSFspaceGroup.EQ.152) IZ5 = NZ23 - IZ + 2 IF (NumSFspaceGroup.EQ.154) IZ5 = NZ3 - IZ + 2 IK5 = -II + 1 IH5 = NX - IH + 1 IF (IH.EQ.0) IH5 = 1 Y(IK5,IH5) = CONJG(X(IZ5,KH)) C C---- p3121 t(i k z) = t(h k -z+1/3) take z 1/6 - 1/3 C p3221 t(i k z) = t(h k -z-1/3) take z 1/2 - 2/3 C IF (NumSFspaceGroup.EQ.152) IZ6 = NZ3 - IZ + 2 IF (NumSFspaceGroup.EQ.154) IZ6 = NZ23 - IZ + 2 IK6 = IK + 1 IH6 = NX + II + 1 IF (IH6.GT.NX) IH6 = 1 Y(IK6,IH6) = X(IZ6,KH) 50 CONTINUE 60 CONTINUE C C ***************************** CALL QSEEK(IOscratch,IZ,1,Nrec) CALL QWRITE(IOscratch,Y(1,1),Nrec) C ***************************** C 70 CONTINUE END C C ======================================================= SUBROUTINE OUT169(X,NZ21,Kmax1,NSizePassOne,Y,NX,R, + IOscratch,NumSFspaceGroup) C ======================================================= C C .. Scalar Arguments .. INTEGER IOscratch,Kmax1,NSizePassOne,NumSFspaceGroup,NX,NZ21,R C .. C .. Array Arguments .. COMPLEX X(NZ21,Kmax1,NSizePassOne),Y(Kmax1,NX) C .. C .. Scalars in Common .. REAL RHmax,RHmean,RHmin,VolMtz INTEGER IJ1,IJ2,IJ3,IXmax,IXmin,IYmax,IYmin,IZmax,IZmin,Jsec,JU1, + JU2,JV1,JV2,NumSections,NumSFsymm LOGICAL LNoScaleFlag,LverboseFlag C .. C .. Arrays in Common .. REAL CellMtz C .. C .. Local Scalars .. COMPLEX F REAL ABSF INTEGER I,IER,IH,IH1,IH3,IH4,IHmax1,IHmin1,IHS,II,IK,IK1,IK3,IK4, + IZ,IZ3A,IZ3B,IZ4A,IZ4B,IZsec,IZZ,K,Nrec,NZ,NZ2OV3,NZ5OV6, + NZOV2,NZOV3,NZOV6 C .. C .. External Subroutines .. EXTERNAL QREAD,QSEEK,QWRITE C .. C .. Intrinsic Functions .. INTRINSIC ABS,CMPLX,CONJG,MOD C .. C .. Common blocks .. COMMON /MPHDR/ + IJ1,IJ2,IJ3, + IXmin,IXmax,IYmin,IYmax,IZmin,IZmax, + Jsec,JU1,JU2,JV1,JV2,Iuvw(3), + NSFSpaGrpDum,NumSections, + RHmin,RHmax,RHmean,NumSFsymm, + CellMtz(6),VolMtz,Volfft,F000 COMMON /TERSE/ + LverboseFlag,LNoScaleFlag C .. C IF (NumSFspaceGroup.LT.169) NumSFspaceGroup = 169 C NZ = NZ21*2 - 2 NZOV2 = NZ/2 NZOV3 = NZ/3 NZ2OV3 = 2*NZOV3 NZOV6 = NZ/6 NZ5OV6 = 5*NZOV6 C IF (LverboseFlag) WRITE (6,FMT=6000) + NZOV3,Kmax1,NSizePassOne,Kmax1,NX,R,IOscratch 6000 FORMAT ( + ' NZOV3 Kmax1 NSizePassOne Kmax1 NX R IOscratch ',7I5) C C---- for P61/P65 IZsec equals nz/12 C IZsec = IZmax - IZmin + 1 Nrec = 2*Kmax1*NX IHmin1 = R + 1 IHmax1 = R + NSizePassOne IF (R.GT.0) GO TO 40 C DO 20 I = 1,NX DO 10 K = 1,Kmax1 Y(K,I) = CMPLX(0.0,0.0) 10 CONTINUE 20 CONTINUE C C ************************* CALL QSEEK(IOscratch,1,1,Nrec) C ************************* C DO 30 IZ = 1,IZseC C ***************************** CALL QWRITE(IOscratch,Y(1,1),Nrec) C ***************************** C 30 CONTINUE 40 CONTINUE C C ************************* CALL QSEEK(IOscratch,1,1,Nrec) C ************************* C DO 70 IZZ = 1,IZseC C ******************************** CALL QREAD(IOscratch,Y(1,1),Nrec,IER) C ******************************** C IZ = IZZ + IZmin C DO 60 IH1 = IHmin1,IHmax1 IHS = IH1 - IHmin1 + 1 IF (IHmin1.EQ.1) Y(1,1) = X(IZ,1,1) C DO 50 IK1 = 1,Kmax1 IH = IH1 - 1 IK = IK1 - 1 C C----ejd Do not generate equivalents for T(h k z) if absf=0. C F = X(IZ,IK1,IHS) ABSF = ABS(F) IF (ABSF.EQ.0.0) GO TO 50 II = -IH - IK IF (ABS(II).GE.Kmax1) GO TO 50 Y(IK1,IH1) = X(IZ,IK1,IHS) IF (IK1.EQ.1 .AND. IH1.GT.1) + Y(1,NX+2-IH1) = CONJG(Y(1,IH1)) C C P61 T( H K Z) = T( -K -I Z+1/6) = T( I H Z+1/3) C = T( -H -K Z+1/2) = T( K I Z+2/3) = T ( -I -H Z+5/6) C C P65 T( H K Z) = T( -K -I Z+5/6) = T( I H Z+2/3) C = T( -H -K Z+1/2) = T( K I Z+1/3) = T ( -I -H Z+1/6) C C---- P61 T( I H Z)= T(H K Z+2/3) TAKE Z C P65 T( I H Z)= T(H K Z+1/3) TAKE Z C C-or- P61 T(-I -H Z)= ( T( I H Z) transpose ) = T(H K Z+1/6) TAKE Z C P65 T(-I -H Z)= ( T( I H Z) transpose ) = T(H K Z+5/6) TAKE Z C IF (NumSFspaceGroup.EQ.169) IZ3A = NZ2OV3 + IZ IF (NumSFspaceGroup.EQ.170) IZ3A = NZOV3 + IZ IZ3A = MOD(10*NZ+IZ3A,NZ) IF (IZ3A.EQ.0) IZ3A = NZ IF (NumSFspaceGroup.EQ.169) IZ3B = NZOV6 + IZ IF (NumSFspaceGroup.EQ.170) IZ3B = NZ5OV6 + IZ IZ3B = MOD(10*NZ+IZ3B,NZ) IF (IZ3B.EQ.0) IZ3B = NZ IK3 = IH + 1 IH3 = NX + II + 1 IF (IH3.GT.NX) IH3 = 1 IF (IZ3A.LE.NZOV2) Y(IK3,IH3) = X(IZ3A,IK1,IHS) IF (IZ3B.LE.NZOV2) Y(IK3,IH3) = CONJG(X(IZ3B,IK1, + IHS)) IF (IK3.EQ.1 .AND. IH3.GT.1) Y(1, + NX+2-IH3) = CONJG(Y(1,IH3)) C C---- P61 T(-K -I Z)= T(H K Z+5/6 ) C---- P65 T(-K -I Z)= T(H K Z+1/6 ) C C-or- P61 T( -K -I Z)(= T(K I Z)transpose) = T(H K Z+1/3 )transpose C---- P65 T( -K -I Z)(= T(K I Z)transpose) = T(H K Z+2/3 )transpose C IF (NumSFspaceGroup.EQ.169) IZ4A = NZ5OV6 + IZ IF (NumSFspaceGroup.EQ.170) IZ4A = NZOV6 + IZ IZ4A = MOD(10*NZ+IZ4A,NZ) IF (IZ4A.EQ.0) IZ4A = NZ IF (NumSFspaceGroup.EQ.169) IZ4B = NZOV3 + IZ IF (NumSFspaceGroup.EQ.170) IZ4B = NZ2OV3 + IZ IZ4B = MOD(10*NZ+IZ4B,NZ) IF (IZ4B.EQ.0) IZ4B = NZ IK4 = -II + 1 IH4 = NX - IK + 1 IF (IH4.GT.NX) IH4 = 1 IF (IZ4A.LE.NZOV2) Y(IK4,IH4) = X(IZ4A,IK1,IHS) IF (IZ4B.LE.NZOV2) Y(IK4,IH4) = CONJG(X(IZ4B,IK1, + IHS)) IF (IK4.EQ.1 .AND. IH4.GT.1) Y(1, + NX+2-IH4) = CONJG(Y(1,IH4)) 50 CONTINUE 60 CONTINUE C C ***************************** CALL QSEEK(IOscratch,IZZ,1,Nrec) CALL QWRITE(IOscratch,Y(1,1),Nrec) C ***************************** C 70 CONTINUE END C C ====================== REAL FUNCTION PHIWT(X) C ====================== C C .. Scalar Arguments .. REAL X C .. C .. Intrinsic Functions .. INTRINSIC COS,SIN C .. C PHIWT = (SIN(X)-COS(X)*X)*3.0/X**3 C END C C ==================== REAL FUNCTION PSI(X) C ==================== C C .. Scalar Arguments .. REAL X C .. C .. Intrinsic Functions .. INTRINSIC COS,SIN C .. C PSI = (2.0*X*SIN(X)- (X**2-2.0)*COS(X)-2)*3.0/X**4 C END C C ===================== REAL FUNCTION PSI2(X) C ===================== C C .. Scalar Arguments .. REAL X C .. C .. Intrinsic Functions .. INTRINSIC COS,SIN C .. C PSI2 = ((X**2*3.0-6.0)*SIN(X) - + (X**3-6.0*X)*COS(X))*3.0/X**5 C END C C ========================= SUBROUTINE R3PI(PII,LCYC) C ========================= C C---- Copied from n isaacs r3 ref beware for p212121 sh=Lmax+1 C sl=Hmax+1. C C FOR P41212 SH = Lmax+1 C SK =NPassTwoSave = Size/(NZ+2) NPassTwoSave = 1. C FOR P3121 SH=NZ. C .. Parameters .. REAL PI PARAMETER (PI=3.1415926) INTEGER MCOLS PARAMETER (MCOLS=200) C .. C .. Scalar Arguments .. REAL PII INTEGER LCYC C .. C .. Scalars in Common .. REAL A6NAP2,A6NAP3,AA1,AverageBfactor,BfactFpart,BfactorMax, + BfactorMin,BfactOverall,BfactReset,BfactStartStepSize,Bsmear, + GR1,GR3NA2,RatioShiftTrunc,RHmax,RHmean,RHmin,RmsBfactor, + RmsDelta,RmsXyz,ScaleFcalc,ScaleFpart,SFrepeatValue, + SigmaExclude,Smax,Smin,SSbinSize,TH,TSmax,TSmin,VolMtz,W, + WangSphereRadi,XyzStartStepSize INTEGER IXmax,IXmin,IYmax,IYmin,IZmax,IZmin,Jsec,JU1,JU2,JV1,JV2, + LatomMapFlag,LBfactRefFlag,LcheckSFspaceGrpFlag, + LFpartFlag,LFreeRexcludeVal,LSFrefFlag,LhklInputFlag, + LMapInFlag,LPhiPartFlag,LSFcalcFlag,LSFmodeFlag, + LSolvMaskFlag,LWghtModeFlag,LxyzInputFlag,LXyzOutputFlag, + NLPRGO,LrefineCycFlag,NtotalRefsUsed,NumMultiplicity, + NumSections,NumSFspaceGroup,NumSFsymm,NX,NY,NZ LOGICAL LNoScaleFlag,LverboseFlag CHARACTER Title*80 C .. C .. Arrays in Common .. REAL CellMtz INTEGER Iuvw C .. C .. Local Scalars .. REAL A1,A2,AFOFC,AHESS,B1,B2,BoverallWork,C1,C2,CORR,D3,D4,D5,DFC, + DFDB,DFDK,ERROR,FC,FP,FreeRFlag,S,S0,SCnew,SERR,SIGFP,Smag, + SmagFC,Smean,SR2,SSQ,SSQOV4,TH1,WK INTEGER I,I3,Ifail,Ifree,IKcount,IPrintFlag,MTZIN2,N1,NOPT,Nscale, + NTH1 LOGICAL EOF C .. C .. Local Arrays .. REAL Bdata(MCOLS),ERR(100,2),Fmag(100,2),FmagFC(100,2),WERR(100,2) INTEGER NUMB(100,2),NUNQ(100) LOGICAL LOGMSS(MCOLS) C .. C .. External Subroutines .. EXTERNAL LRCLOS,LROPEN,LRREFL,LRREFM,LRREWD, + LWCLOS,LWOPEN,LWREFL C .. C .. Intrinsic Functions .. INTRINSIC ABS,EXP,INT,LOG,MAX,MOD,NINT C .. C .. Common blocks .. COMMON /BFACTS/ + AverageBfactor, + BfactorMin, + BfactorMax, + Bsmear, + BfactReset COMMON /KH/ + RmsDelta,AA1,A6NAP2,A6NAP3,GR1,GR3NA2 COMMON /MPHDR/ + NX,NY,NZ, + IXmin,IXmax,IYmin,IYmax,IZmin,IZmax, + Jsec,JU1,JU2,JV1,JV2,Iuvw(3), + NumSFspaceGroup,NumSections, + RHmin,RHmax,RHmean,NumSFsymm, + CellMtz(6),VolMtz,Volfft,F000 COMMON /MPHDRR/ + Title COMMON /SFOUT/ + Smin,Smax,TSmin,TSmax,SSbinSize, + LFpartFlag,LPhiPartFlag,LWghtModeFlag, + ScaleFcalc,ScaleFpart, + SigmaExclude,WangSphereRadi, + BfactOverall,BfactFpart, + NumMultiplicity,NLPRGO COMMON /SRFCTL/ + NtotalRefsUsed, + RatioShiftTrunc,W,TH, + LSFmodeFlag,LrefineCycFlag,LBfactRefFlag, + LcheckSFspaceGrpFlag,LFreeRexcludeVal, + XyzStartStepSize,BfactStartStepSize, + SFrepeatValue, + RmsXyz,RmsBfactor COMMON /SRFCTL1/ + LSFcalcFlag,LSFrefFlag, + LatomMapFlag,LxyzInputFlag, + LhklInputFlag,LMapInFlag, + LSolvMaskFlag,LXyzOutputFlag COMMON /TERSE/ + LverboseFlag,LNoScaleFlag C .. C .. Data statements .. ccx?? Variables may be used before set in module R3PI: D4 ???? DATA D4/0.0/ C .. C C IF (LverboseFlag)WRITE (6,FMT=6000) C MTZIN2 = 2 IPrintFlag = 0 Ifail = -1 C C---- First close FFTHKLSCR for writing and open it for reading. C C ******************************************** CALL LWCLOS(MTZIN2,IPrintFlag) CALL LROPEN(MTZIN2,'FFTHKLSCR',IPrintFlag,Ifail) C ******************************************** C C---- If LSFcalcFlag set write out HKLOUT - C same as FFTHKLSCR with scales applied. C C *********************** IF (LSFcalcFlag.EQ.1) CALL LWOPEN(MTZIN2,'HKLOUT') C *********************** C Nscale = 0 A1 = 0 A2 = 0 C1 = 0 B1 = 0 B2 = 0 C2 = 0 C DO 10 I = 1,100 WERR(I,1) = 0.0 ERR(I,1) = 0.0 FmagFC(I,1) = 0.0 Fmag(I,1) = 0.0 NUMB(I,1) = 0 WERR(I,2) = 0.0 ERR(I,2) = 0.0 FmagFC(I,2) = 0.0 Fmag(I,2) = 0.0 NUMB(I,2) = 0 10 CONTINUE C PII = 0.0 AFOFC = 0.0 AHESS = 0.0 C C---- Read fobs and fcal files in order to C determine new scale factor C C---- If First refinemement cycle calculate scale. C If b refinement then we will have already applied overal B C Reset BfactOverall = 0 C BoverallWork = BfactOverall IF (LBfactRefFlag .NE. 0 .AND. + LCYC .GE. 100) BoverallWork = 0 WRITE (6,FMT=6004) ScaleFcalc,BoverallWork C IF (LCYC.LE.100) THEN 50 CONTINUE C C **************************** CALL LRREFL(MTZIN2,SSQ,Bdata,EOF) C **************************** C IF (EOF) GO TO 60 CALL LRREFM(MTZIN2,LOGMSS) IF (LOGMSS(5) .OR. LOGMSS(4)) GO TO 50 IF (ABS(Bdata(5)).LE.0.0) GO TO 50 FP = Bdata(4) SIGFP = Bdata(5) FC = Bdata(NLPRGO-1) IF (LWghtModeFlag.GT.0) FC = Bdata(NLPRGO-2) C IF (FP .GE. 0.01) THEN IF (FC .GE. 0.01) THEN FC = FC*ScaleFcalc*EXP(Bsmear*SSQ/4.0) C C---- If fc/fo or fo/fc . gt . th put = 0 (ie to be ignored) C TH1 = FC/FP TH1 = MAX(TH1,1.0/TH1) C IF (TH1.LE.TH) THEN C ERROR = FC - FP AFOFC = FP*FC + AFOFC AHESS = FC*FC + AHESS IF (ABS(TSmax).GT.0.0001 .AND. + SSQ.LE.TSmax .AND. + SSQ.GE.TSmin) THEN SR2 = SSQ/4.0 Nscale = Nscale + 1 A1 = LOG(FC)*SR2 + A1 A2 = LOG(FC) + A2 B1 = LOG(FP)*SR2 + B1 B2 = LOG(FP) + B2 C1 = C1 + SR2 C2 = SR2**2 + C2 END IF END IF END IF END IF GO TO 50 60 CONTINUE C SCnew = AFOFC/AHESS C IF ( Nscale.NE.0 .AND. ABS(TSmax).GT.0.0001) THEN ScaleFcalc = SCnew*ScaleFcalc BfactOverall = ((A2-B2)*C1+ (B1-A1)*Nscale)/ + (C1**2-Nscale*C2) ScaleFcalc = EXP((BfactOverall*C1-A2+B2)/Nscale)* + ScaleFcalc/SCnew WRITE (6,FMT=6002) ScaleFcalc, + BfactOverall,Nscale,TSmin,TSmax END IF C BoverallWork = BfactOverall END IF C WRITE (6,FMT=6006) ScaleFcalc,BoverallWork C C---- Read fobs and fcal files again C calculate R factors. C If Refining, calculate modified differences C and rewrite in output file C C ************** CALL LRREWD(MTZIN2) C ************** C IKcount = 0 90 CONTINUE C CALL LRREFL(MTZIN2,SSQ,Bdata,EOF) C IF (EOF) GO TO 80 CALL LRREFM(MTZIN2,LOGMSS) C C---- apply inverse scale to FP and SIGFP C FP = 0.0 SIGFP = 0.0 FC = 0.0 IF(.NOT.(LOGMSS(4) .OR. LOGMSS(5))) THEN FP = Bdata(4)/ScaleFcalc SIGFP = Bdata(5)/ScaleFcalc IF (.NOT.LNoScaleFlag) THEN Bdata(4) = FP Bdata(5) = SIGFP END IF END IF C Set FreeRFlag to something impossible FreeRFlag = 9999999 IF (LFreeRexcludeVal.NE.-999 .AND. .NOT.LOGMSS(6)) + FreeRFlag = Bdata(6) SSQOV4 = SSQ/4.0 CORR = EXP((Bsmear-BoverallWork)*SSQOV4) IF (LWghtModeFlag.GT.0) THEN FC = Bdata(NLPRGO-2) ELSE FC = Bdata(NLPRGO-1) ENDIF FC = CORR*FC IF (.NOT.LNoScaleFlag) THEN IF (LWghtModeFlag.EQ.0) Bdata(NLPRGO - 1) = FC IF (LWghtModeFlag.GT.0) Bdata(NLPRGO - 2) = FC END IF C C---- if fo . eq . 0 leave fcal as is ( =0 ) C IF (LSFcalcFlag.EQ.1)CALL LWREFL(MTZIN2,Bdata) C C---- Select reflections for Rfactor and refinement. Skip missing refl. C IF (FP.LT.0.00001 .AND. SIGFP.LT.0.00001) GO TO 90 IF (ABS(SigmaExclude).GE.0.000001 .AND. + FP.LT.SigmaExclude*SIGFP ) GO TO 90 IKcount = IKcount + 1 Ifree = 1 C Replace flag = 1 for exclde/0 to C include to 1 to include/o to exclude.. C IF (LFreeRexcludeVal.GE.0 .AND. + ABS(LFreeRexcludeVal - FreeRFlag).LT.0.5) Ifree = 2 C C---- Work out R factor C ERROR = FC - FP I3 = INT(SSQ*SSbinSize) + 1 IF (I3.GT.100) I3 = 100 ERR(I3,Ifree) = ERR(I3,Ifree) + ABS(ERROR) WERR(I3,Ifree) = WERR(I3,Ifree) + ABS(D4) FmagFC(I3,Ifree) = FmagFC(I3,Ifree) + FC Fmag(I3,Ifree) = Fmag(I3,Ifree) + FP NUMB(I3,Ifree) = NUMB(I3,Ifree) + 1 C C---- Prepare for refinement C IF (Ifree.NE.2) THEN TH1 = 100000000000.0 IF (ABS(FP).GE.0.00001)TH1 = FC/FP + 0.00001 TH1 = MAX(TH1,1.0/TH1) C IF (TH1.LE.TH) THEN WK = 1 IF (SSQ.GT.0.0) WK = SSQ** (0.5*W) D4 = ERROR*WK PII = D4*ERROR + PII C IF (LCYC.LE.100) THEN DFDK = FC DFDB = -SSQOV4*FC*ScaleFcalc AA1 = DFDK*DFDK + AA1 A6NAP2 = DFDB*DFDB + A6NAP2 A6NAP3 = DFDK*DFDB + A6NAP3 GR1 = GR1 - ScaleFcalc*D4*DFDK GR3NA2 = GR3NA2 - ScaleFcalc*D4*DFDB END IF END IF END IF GO TO 90 80 CONTINUE C C---- Write out r factors etc. C DO 101 I3 = 1,2 NtotalRefsUsed = 0 SERR = 0.0 SmagFC = 0.0 Smag = 0.0 IF (I3.EQ.1) WRITE (6,FMT=6008) + Title(1:40),Title(1:40),Title(1:40) IF (I3.EQ.2 .AND. LFreeRexcludeVal.EQ.-999) GO TO 101 IF (I3.EQ.2) WRITE (6,FMT=6018) + Title(1:40),Title(1:40),Title(1:40) S0 = 0.0 C DO 100 I = 1,100 C C---- Completenesss C S = I/SSbinSize NUNQ(I) = NINT(0.6667*PI*VolMtz*S**1.5 /NumSFsymm) IF (I.EQ.1)NOPT = NUNQ(I) IF (I.GT.1)NOPT = NUNQ(I) -NUNQ(I-1) N1 = NUMB(I,I3) IF (N1.NE.0) THEN DFC = FmagFC(I,I3)/N1 FC = Fmag(I,I3)/N1 IF ( ABS(Fmag(I,I3)).GE.0.001) + D4 = ERR(I,I3)/Fmag(I,I3) D4 = ERR(I,I3)/Fmag(I,I3) D3 = WERR(I,I3)/N1 IF (LBfactRefFlag.NE.1) D3 = D3*S**0.5 IF (LBfactRefFlag.EQ.1) D3 = D3*S SERR = ERR(I,I3) + SERR SmagFC = FmagFC(I,I3) + SmagFC Smag = Fmag(I,I3) + Smag NtotalRefsUsed = NtotalRefsUsed + N1 Smean = (S0 + S) /2.0 WRITE (6,FMT=6010) Smean,N1,NOPT,FC,DFC,D4,D3 S0 = S END IF 100 CONTINUE C WRITE(6,'(A)')' $$' WRITE (6,FMT=6014) NtotalRefsUsed 6014 FORMAT (' Total no. of reflections used ',I10) IF (I3.EQ.1 .AND. NtotalRefsUsed .EQ. 0) CALL CCPERR + (1,' Something SERIOUSLY wrong! - no reflections used') D5 = 0.0 IF (NtotalRefsUsed .GT. 0) D5 = SERR/Smag IF (I3.EQ.1)WRITE (6,FMT=6012) D5,PII IF (I3.EQ.2 .AND. NtotalRefsUsed .GT. 0)WRITE (6,FMT=6022) D5,PII C Remember number of reflns used for refinement IF(I3.EQ.1) NTH1 = NtotalRefsUsed 101 CONTINUE NtotalRefsUsed = NTH1 C IF (LSFcalcFlag.EQ.1) CALL LRCLOS(MTZIN2) C C---- Close HKLOUT C IPrintFlag = 1 IF (LSFcalcFlag.EQ.1) CALL LWCLOS(MTZIN2,IPrintFlag) C C---- Format statements C 6000 FORMAT (//,' Agreement Analysis ',/) 6002 FORMAT (//, +' New values of SCALE and BfactOverall',2E12.3, +' Based on ',I6,' reflections with s**2 between',F10.3, +' and',F10.3) 6004 FORMAT (//, +' to match FOBS , ', +'FC = Scale*Exp(-BfactOverall*SSQ/LL)*FCALC.',/, +' Old values of SCALE and B overall are',2E15.4) 6006 FORMAT (//, +' Used values of SCALE and B overall are',/, +' SCALE ',E15.4,' B Value ',E15.4,//, +' NB: Number of "possible" reflections is ', +'an underestimation -', + ' Centrics Kcounted at reduced multiplicity') 6008 FORMAT (/1X, $' $TABLE: Rfactor analysis v resln :'/ $' $GRAPHS: v. resln ',A,':N:1,6:',/, $': and v. resln ',A,':N:1,2,3:',/, $': and v. resln ',A,':N:1,4,5:'/' $$',/, + ' 1/resol^2 NO_OF_REF N_POSS Rfactor', + ' Wdelta**2(Fobs_Scale) $$'/' $$') 6018 FORMAT (/1X, $' $TABLE: Free Rfactor analysis v resln :'/ $' $GRAPHS: v. resln ',A,':N:1,6:',/, $': and v. resln ',A,':N:1,2,3:',/, $': and v. resln ',A,':N:1,4,5:'/' $$',/, + ' 1/resol^2 NO_OF_REF N_POSS Rfactor', + ' Wdelta**2(Fobs_Scale) $$'/' $$') 6010 FORMAT (3X,F5.3,I8,I8,5F10.2,F15.2) 6012 FORMAT (/,' Overall Reliability index is',F10.4,//, +' SIGMA W DELTA SQUARED (PII) ABSOLUTE SCALE ',E15.4) 6022 FORMAT (/,' Free Reliability index is',F10.4,//, +' SIGMA W DELTA SQUARED (PII) ABSOLUTE SCALE ',E15.4) C END C C ======================================================== SUBROUTINE READH1(X,NY,NZ,NX,NSizePassOne,NumSkipRecords, + RECS,IOscratch,NumCurrentRecord,NRCSC) C ======================================================== C C---- reads back complex intermediate results of xz transform as h - C planes, when there has been no transposition and interleaving. C it allows no scratch location on y. C C .. Scalar Arguments .. INTEGER IOscratch,NRCSC,NSizePassOne,NumCurrentRecord, + NumSkipRecords,NX,NY,NZ,RECS C .. C .. Array Arguments .. COMPLEX X(NY,NZ,NX) C .. C .. Scalars in Common .. LOGICAL LNoScaleFlag,LverboseFlag C .. C .. Local Scalars .. INTEGER H,IER,K,L,P,Q C .. C .. External Subroutines .. EXTERNAL QREAD,QSEEK C .. C .. Common blocks .. COMMON /TERSE/ + LverboseFlag,LNoScaleFlag C .. C IF (LverboseFlag) WRITE (6,FMT=6000) + NZ,NX,NY,NSizePassOne,NumSkipRecords, + RECS,IOscratch,NumCurrentRecord,NRCSC 6000 FORMAT ( +' readh2 nz nx ny NSizePassOne NumSkipRecords ',/, +' recs IOscratch NumCurrentRecord nrcsc',/9i5) C NumCurrentRecord = NumCurrentRecord + NumSkipRecords Q = 0 10 CONTINUE P = Q + 1 Q = Q + NSizePassOne IF (Q.GT.NY) Q = NY C C ***************************************** CALL QSEEK(IOscratch,NumCurrentRecord,1,NRCSC) C ***************************************** C DO 40 L = 1,NZ DO 30 K = P,Q DO 20 H = 1,NX C C ******************************* CALL QREAD(IOscratch,X(K,L,H),2,IER) C ******************************* C 20 CONTINUE 30 CONTINUE 40 CONTINUE C IF (Q.EQ.NY) GO TO 50 NumCurrentRecord = NumCurrentRecord + RECS + 1 GO TO 10 50 CONTINUE C END C C ========================================================== SUBROUTINE READH2(X,N,NZ,NX,NY,NSizePassOne,NumSkipRecords, + RECS,IOscratch,NumCurrentRecord,NRCSC) C ========================================================== C C---- reads back complex intermediate results of xz transform as h - C planes, when there has been no transposition and interleaving. C it allows no scratch location on y. C C .. Scalar Arguments .. INTEGER IOscratch,N,NRCSC,NSizePassOne,NumCurrentRecord, + NumSkipRecords,NX,NY,NZ,RECS C .. C .. Array Arguments .. COMPLEX X(N,NZ,NX) C .. C .. Scalars in Common .. LOGICAL LNoScaleFlag,LverboseFlag C .. C .. Local Scalars .. INTEGER H,IER,K,L,P,Q C .. C .. External Subroutines .. EXTERNAL QREAD,QSEEK C .. C .. Common blocks .. COMMON /TERSE/ + LverboseFlag,LNoScaleFlag C .. C IF (LverboseFlag) WRITE (6,FMT=6000) N,NZ,NX,NY, + NSizePassOne, + NumSkipRecords, + RECS,IOscratch, + NumCurrentRecord, + NRCSC 6000 FORMAT ( +' readh2 n nz nx ny NSizePassOne NumSkipRecords recs ', +'IOscratch NumCurrentRecord nrcsc',/10i5) C NumCurrentRecord = NumCurrentRecord + NumSkipRecords Q = 0 10 CONTINUE P = Q + 1 Q = Q + NSizePassOne IF (Q.GT.NY) Q = NY C C ***************************************** CALL QSEEK(IOscratch,NumCurrentRecord,1,NRCSC) C ***************************************** C DO 40 L = 1,NZ DO 30 K = P,Q DO 20 H = 1,NX C C ******************************* CALL QREAD(IOscratch,X(K,L,H),2,IER) C ******************************* C 20 CONTINUE 30 CONTINUE 40 CONTINUE C IF (Q.EQ.NY) GO TO 50 NumCurrentRecord = NumCurrentRecord + RECS + 1 GO TO 10 50 CONTINUE C IF (NY.GE.N) GO TO 90 P = NY + 1 C DO 80 K = P,N DO 70 L = 1,NZ DO 60 H = 1,NX X(K,L,H) = (0.0,0.0) 60 CONTINUE 70 CONTINUE 80 CONTINUE C 90 CONTINUE END C C ======================================================= SUBROUTINE READH3(X,N,NZ,NX,NY,Size,NumSkipRecords,RECS, + IOscratch,NumCurrentRecord,NRCSC) C ======================================================= C C---- reads back intermediate xz - transform results for all y and l C for a block of nx h-values. the input is stored with y down the C columns and l on the rows. C C this version of the readh routine is for use with those ortho- C rhombic space groups in which the xz-transform gives complex C results, and the values for h, 1/2 - y, l have been obtained C by transposition from those for -h, y, l ( 0.le.y.le.1/4) C in subroutine trans1. C C scratch file is in direct access. C C WRITTEN BY G. BRICOGNE, MAY 1976. C C .. Scalar Arguments .. INTEGER IOscratch,N,NRCSC,NumCurrentRecord,NumSkipRecords,NX,NY, + NZ,RECS,Size C .. C .. Array Arguments .. COMPLEX X(N,NZ,NX) C .. C .. Local Scalars .. INTEGER H,IERR,K,KL1,KL2,KU1,KU2,L C .. C .. External Subroutines .. EXTERNAL CCPERR,QREAD,QSEEK C .. C NumCurrentRecord = NumCurrentRecord + NumSkipRecords KU1 = 0 KL2 = N + 1 C C---- read pairs of records, one for 0 .le. y .le. (1/4) , C one for (1/4) .le. y .le. (1/2) . C 10 CONTINUE KL1 = KU1 + 1 KU1 = KU1 + Size IF (KU1.GT.NY) KU1 = NY C C ***************************************** CALL QSEEK(IOscratch,NumCurrentRecord,1,NRCSC) C ***************************************** C DO 40 L = 1,NZ DO 30 K = KL1,KU1 DO 20 H = 1,NX C C ******************************** CALL QREAD(IOscratch,X(K,L,H),2,IERR) C ******************************** C 20 CONTINUE 30 CONTINUE 40 CONTINUE C NumCurrentRecord = NumCurrentRecord + RECS + 1 KU2 = KL2 - 1 KL2 = KL2 - Size IF (KL2.LT.NY) KL2 = NY C C ***************************************** CALL QSEEK(IOscratch,NumCurrentRecord,1,NRCSC) C ***************************************** C DO 70 L = 1,NZ DO 60 K = KL2,KU2 DO 50 H = 1,NX C C ******************************** CALL QREAD(IOscratch,X(K,L,H),2,IERR) C ******************************** C 50 CONTINUE 60 CONTINUE 70 CONTINUE C IF (KU1.EQ.NY) GO TO 80 NumCurrentRecord = NumCurrentRecord + RECS + 1 GO TO 10 C C---- check that original and transposed results have been read C correctly. C 80 CONTINUE IF (KL2.EQ.NY) GO TO 90 WRITE (6,FMT=6000) KU1,KL2 6000 FORMAT ( +' ERROR : BAD JUSTIFICATION OF SCRATCH RECORDS IN ', +'READH3 .',/10X,'KU1 =',I5,' , KL2 =',I5) CALL CCPERR(1,' FATAL ERROR') C C---- end of input C 90 CONTINUE END C C ======================================================== SUBROUTINE READTL(X,NZ,NK,NH,Size,NumSkipRecords,RECS, + IOscratch,EVEN,NumCurrentRecord,NRCSC) C ======================================================== C C---- reads intermediate results for space group p212121 C structure factor calculations C C .. Scalar Arguments .. INTEGER IOscratch,NH,NK,NRCSC,NumCurrentRecord,NumSkipRecords,NZ, + RECS,Size LOGICAL EVEN C .. C .. Array Arguments .. COMPLEX X(NZ,NK,NH) C .. C .. Local Scalars .. COMPLEX A INTEGER H,IER,K,L,LL,LU,NZ21,P,Q C .. C .. External Subroutines .. EXTERNAL QREAD,QSEEK C .. C .. Intrinsic Functions .. INTRINSIC AIMAG,CMPLX,REAL C .. C NumCurrentRecord = NumCurrentRecord + NumSkipRecords NZ21 = (NZ+1)/2 Q = 0 C 10 P = Q + 1 Q = Q + Size IF (Q.GT.NZ21) Q = NZ21 C C ***************************************** CALL QSEEK(IOscratch,NumCurrentRecord,1,NRCSC) C ***************************************** C DO 30 H = 1,NH DO 20 K = 1,NK C C **************************************** CALL QREAD(IOscratch,X(P,K,H),2* (Q-P+1),IER) C **************************************** C 20 CONTINUE 30 CONTINUE C NumCurrentRecord = NumCurrentRecord + RECS + 1 LL = NZ + 1 - Q LU = NZ + 1 - P C C ***************************************** CALL QSEEK(IOscratch,NumCurrentRecord,1,NRCSC) C ***************************************** C DO 50 H = 1,NH DO 40 K = 1,NK C C ******************************************* CALL QREAD(IOscratch,X(LL,K,H),2* (LU-LL+1),IER) C ******************************************* C 40 CONTINUE 50 CONTINUE C IF (Q.EQ.NZ21) GO TO 60 NumCurrentRecord = NumCurrentRecord + RECS + 1 GO TO 10 C 60 CONTINUE P = 1 IF (EVEN) P = 2 C DO 90 H = P,NH,2 DO 80 K = 1,NK DO 70 L = 1,NZ A = X(L,K,H) X(L,K,H) = CMPLX(-AIMAG(A),REAL(A)) 70 CONTINUE 80 CONTINUE 90 CONTINUE C END C C ======================================== REAL FUNCTION RECIPWT(S,R,LWghtModeFlag) C ======================================== C C Fourier transform of function 1-R/r C S is 2.0*sin(theta)/lambda C R is radius of the sphere C C .. Scalar Arguments .. REAL R,S INTEGER LWghtModeFlag C .. C .. Local Scalars .. REAL X C .. C .. External Functions .. REAL PHIWT,PSI,PSI2 EXTERNAL PHIWT,PSI,PSI2 C .. C X = 2.0*S*3.14159*R IF (LWghtModeFlag.EQ.1) RECIPWT = PHIWT(X) - PSI(X) IF (LWghtModeFlag.EQ.2) RECIPWT = PHIWT(X) - PSI2(X) C END C C =================================== SUBROUTINE REDMAP(X,N1,N2,N3,R,SUM) C =================================== C C set rlin dimension = 300 C should be n2 C C---- decide whether map is written z x y or y x z C C .. Parameters .. INTEGER MaxMapLineSize PARAMETER (MaxMapLineSize=1000) C .. C .. Scalar Arguments .. REAL SUM INTEGER N1,N2,N3,R C .. C .. Array Arguments .. REAL X(N1,N2,N3) C .. C .. Scalars in Common .. REAL CMN,CMP,Escale,RHmax,RHmean,RHmin,TruncMapMax,TruncMapMin, + TruncNewMax,TruncNewMin,VolMtz INTEGER IOatomop,IOgradmat,IOhessian,IOmap,IOscratch,IOshifts, + IOxyzin,IOxyzoutunq,IXmax,IXmin,IYmax,IYmin,IZmax, + IZmin,Jsec,JU1,JU2,JV1,JV2,NumSections,NumSFspaceGroup, + NumSFsymm,NX,NY,NZ C .. C .. Arrays in Common .. REAL CellMtz INTEGER Iuvw C .. C .. Local Scalars .. REAL RhoMax,RhoMin,ScaleMap,Xscal INTEGER I1,I2,I3,IER,IOR C .. C .. Local Arrays .. REAL RLIN(MaxMapLineSize) C .. C .. External Subroutines .. EXTERNAL CCPERR,MPOSN,MRDLIN C .. C .. Intrinsic Functions .. INTRINSIC TANH C .. C .. Common blocks .. COMMON /EDEN/ + Escale,CMP,CMN COMMON /IOSF/ + IOscratch,IOgradmat,IOhessian,IOshifts, + IOatomop,IOmap,IOxyzin,IOxyzoutunq COMMON /MPHDR/ + NX,NY,NZ, + IXmin,IXmax,IYmin,IYmax,IZmin,IZmax, + Jsec,JU1,JU2,JV1,JV2,Iuvw(3), + NumSFspaceGroup,NumSections, + RHmin,RHmax,RHmean,NumSFsymm, + CellMtz(6),VolMtz,Volfft,F000 COMMON /TRUNC/ + TruncMapMin,TruncMapMax, + TruncNewMin,TruncNewMax C .. C C---- Map should ve corrected for GRID VOL C ScaleMap = VolMtz/(NX*NY*NZ) IOR = 1 IF (Iuvw(3).EQ.2 .AND. Iuvw(1).EQ.3) IOR = 0 IF (Iuvw(3).EQ.3 .AND. Iuvw(1).EQ.2) IOR = 0 C C---- Read atom density map C IF (N2.GT.MaxMapLineSize) THEN CALL CCPERR(1,' rlin dimension too small -increase in redmap') ELSE C DO 60 I3 = 1,N3 Jsec = R + I3 - 1 C C **************** CALL MPOSN(IOmap,Jsec) C **************** C IF (IOR.EQ.0) THEN DO 10 I2 = 1,N2 C C ********************** CALL MRDLIN(IOmap,RLIN,IER) C ********************** C DO 15 I1 = 1,N1 X(I1,I2,I3) = RLIN(I1) 15 CONTINUE 10 CONTINUE ELSE DO 30 I1 = 1,N1 - 2 C C ********************* CALL MRDLIN(IOmap,RLIN,IER) C ********************* C DO 20 I2 = 1,N2 X(I1,I2,I3) = RLIN(I2) 20 CONTINUE 30 CONTINUE END IF C C---- Sum electron density C RhoMax = -10000000000.0 RhoMin = 10000000000.0 C DO 50 I2 = 1,N2 X(N1,I2,I3) = 0.0 X(N1-1,I2,I3) = 0.0 C DO 40 I1 = 1,N1 - 2 IF (TruncMapMax.GT.0.0) THEN IF (X(I1,I2,I3).LT.TruncMapMin) + X(I1,I2,I3) = TruncNewMin IF (X(I1,I2,I3).GT.TruncMapMax) + X(I1,I2,I3) = TruncNewMax END IF C IF (Escale.GT.0.0) THEN Xscal = Escale/NX*NY*NZ IF (X(I1,I2,I3).LT.0.0 .AND. + CMN.NE.0.0) + X(I1,I2,I3) = Xscal*CMN*TANH(X(I1,I2,I3)/CMN) IF (X(I1,I2,I3).GT.0.0 .AND. + CMP.NE.0.0) + X(I1,I2,I3) = Xscal*CMP*TANH(X(I1,I2,I3)/CMP) END IF C SUM = X(I1,I2,I3) + SUM IF (X(I1,I2,I3).GT.RhoMax) RhoMax = X(I1,I2,I3) IF (X(I1,I2,I3).LT.RhoMin) RhoMin = X(I1,I2,I3) X(I1,I2,I3) = ScaleMap*X(I1,I2,I3) 40 CONTINUE 50 CONTINUE C WRITE (6,FMT=6000) Jsec,RhoMin,RhoMax 6000 FORMAT (' Section = ',I3,' Min and Max density are ',2E12.4) IF (RHmax.LT.RhoMax) RHmax = RhoMax IF (RHmin.GT.RhoMin) RHmin = RhoMin 60 CONTINUE RHmean = RHmean + SUM WRITE (6,FMT=6002) SUM 6002 FORMAT (' Sum of density in this block is ',E14.4) END IF C END C C =================================== SUBROUTINE REDMP2(X,N1,N2,N3,R,SUM) C =================================== C C set rlin dimension = 300 C should be n2 C C---- decide whether map is written z x y or y x z C C .. Parameters .. INTEGER MaxMapLineSize PARAMETER (MaxMapLineSize=1000) C .. C .. Scalar Arguments .. REAL SUM INTEGER N1,N2,N3,R C .. C .. Array Arguments .. REAL X(N1,N2,N3) C .. C .. Scalars in Common .. REAL F000,RHmax,RHmean,RHmin,Volfft,VolMtz INTEGER IOatomop,IOgradmat,IOhessian,IOmap,IOscratch,IOshifts, + IOxyzin,IOxyzoutunq,IXmax,IXmin,IYmax,IYmin,IZmax, + IZmin,Jsec,JU1,JU2,JV1,JV2,NumSections,NumSFspaceGroup, + NumSFsymm,NX,NY,NZ C .. C .. Arrays in Common .. REAL CellMtz INTEGER Iuvw C .. C .. Local Scalars .. REAL RhoMax,RhoMin INTEGER I1,I2,I3,IER,IOR C .. C .. Local Arrays .. REAL RLIN(MaxMapLineSize) C .. C .. External Subroutines .. EXTERNAL CCPERR,MPOSN,MRDLIN C .. C .. Common blocks .. COMMON /IOSF/ + IOscratch,IOgradmat,IOhessian,IOshifts, + IOatomop,IOmap,IOxyzin,IOxyzoutunq COMMON /MPHDR/ + NX,NY,NZ, + IXmin,IXmax,IYmin,IYmax,IZmin,IZmax, + Jsec,JU1,JU2,JV1,JV2,Iuvw(3), + NumSFspaceGroup,NumSections, + RHmin,RHmax,RHmean,NumSFsymm, + CellMtz(6),VolMtz,Volfft,F000 C .. C C---- Map should be reverse scaled - C need to know fft "V" and "F000" C IOR = 1 IF (Iuvw(3).EQ.2 .AND. Iuvw(1).EQ.3) IOR = 0 IF (Iuvw(3).EQ.3 .AND. Iuvw(1).EQ.2) IOR = 0 C C---- Read atom density map C IF (N2.GT.MaxMapLineSize) THEN CALL CCPERR(1,' rlin dimension too small -increase in redmap') ELSE C DO 70 I3 = 1,N3 Jsec = R + I3 - 1 C C **************** CALL MPOSN(IOmap,Jsec) C **************** C IF (IOR.EQ.0) THEN DO 20 I2 = 1,N2 C C ******************** CALL MRDLIN(IOmap,RLIN,IER) C ******************** C DO 10 I1 = 1,N1 X(I1,I2,I3) = RLIN(I1) 10 CONTINUE C 20 CONTINUE ELSE DO 40 I1 = 1,N1 C C ********************* CALL MRDLIN(IOmap,RLIN,IER) C ********************* C DO 30 I2 = 1,N2 X(I1,I2,I3) = RLIN(I2) 30 CONTINUE 40 CONTINUE END IF C C---- Sum electron density C RhoMax = -10000000000.0 RhoMin = 10000000000.0 C DO 60 I2 = 1,N2 X(N1,I2,I3) = 0.0 X(N1-1,I2,I3) = 0.0 DO 50 I1 = 1,N1 SUM = X(I1,I2,I3) + SUM IF (X(I1,I2,I3).GT.RhoMax) RhoMax = X(I1,I2,I3) IF (X(I1,I2,I3).LT.RhoMin) RhoMin = X(I1,I2,I3) X(I1,I2,I3) = X(I1,I2,I3)*Volfft + F000 50 CONTINUE 60 CONTINUE C WRITE (6,FMT=6000) Jsec,RhoMin,RhoMax IF (RHmax.LT.RhoMax) RHmax = RhoMax IF (RHmin.GT.RhoMin) RHmin = RhoMin 70 CONTINUE RHmean = RHmean + SUM WRITE (6,FMT=6002) SUM END IF C C---- Format statemenyts C 6000 FORMAT (' SECTION =',I3,' MIN AND MAX DENSITY ARE ',2E12.4) 6002 FORMAT (' SUM OF DENSITY IN THIS BLOCK IS ',E14.4) C END C C ========================================================== SUBROUTINE REFCTL(X,PHI,Size,NATST,NATREF,GRADN,SDXB,HESS, + NATST2,BB,MB,XB,IA,AtomicNumOccup,IRESB) C ========================================================== C C .. Parameters .. INTEGER MaxSymmetry PARAMETER (MaxSymmetry=192) C .. C .. Scalar Arguments .. INTEGER NATREF,NATST,NATST2,Size C .. C .. Array Arguments .. REAL ATOMICNUMOCCUP(NATST),BB(NATST),GRADN(3,NATREF),HESS(NATREF), + PHI(Size/2),SDXB(3,NATREF),X(Size),XB(2,NATST) INTEGER IA(NATST2),IRESB(NATST),MB(NATST) C .. C .. Scalars in Common .. REAL A6NAP2,A6NAP3,BfactFpart,BfactStartStepSize, + RatioShiftTrunc,RHmax,RHmean,RHmin,RmsBfactor, + RmsDelta,RmsXyz,ScaleFcalc,ScaleFpart,SFrepeatValue, + SigmaExclude,Smax,Smin,SquAtmRadLimit,SSbinSize,TH,TSmax, + TSmin,VolMtz,W,WangSphereRadi,XyzStartStepSize INTEGER IOatomop,IOgradmat,IOhessian,IOmap,IOscratch,IOshifts, + IXmax,IXmin,IYmax,IYmin,IZmax, + IZmin,Jsec,JU1,JU2,JV1,JV2,LatomMapFlag,LBfactRefFlag, + LcheckSFspaceGrpFlag,LFpartFlag,LFreeRexcludeVal, + LSFrefFlag,LhklInputFlag,LMapInFlag,LPhiPartFlag, + LSFcalcFlag,LSFmodeFlag,LSolvMaskFlag,LWghtModeFlag, + LxyzInputFlag,LXyzOutputFlag,NLPRGO,LrefineCycFlag, + NtotalRefsUsed,NumAtmRefined,NumMultiplicity,NumPlanes, + NumSections,NumSFspaceGroup,NumSFsymm,NumSpaceGroup, + NumSymmetry,NumZeroOccAtms,NX,NY,NZ LOGICAL LNoScaleFlag,LverboseFlag C .. C .. Arrays in Common .. REAL AtmBoxLowLim,AtmBoxUpLim,CellMtz,ExtBoxLowLim,ExtBoxUpLim, + ExtraPlanes,PermutRecipSymm,PlanesLimits,RealSymmMatrx, + SpecialPlaneLimit,RecipSymmMatrx,GR1,GR3NA2,AA1, + BfactOverall INTEGER Iuvw,LSymmFlags C .. C .. Local Scalars .. REAL ABCG,ASQ,AVERAGEDIAGONAL,BBCCA,BBSQ,CACB,CORR,CSQ,D53,DELCOR, + GRADIENTRMS,PI0,PI1,PIN,SDNORM,SIGWT,SLOPE,SLOPE1,SZ,SZA INTEGER I,LAppnd,ICALC,IER,LCYC,MLESSN,MTZOUT,NOEL,NPAR C .. C .. Local Arrays .. REAL WORK(4) CHARACTER CTPRGO(8)*1,LSPRGO(8)*30 C .. C .. External Subroutines .. EXTERNAL CCPERR,CLOSEIT,FFTGR1,FFTGR145,FFTGR146,FFTGR152, + FFTGR169,FFTGR18,FFTGR19,FFTGR4,FFTGR92,GRSCRM,LRCLOS, + LRREWD,LWASSN,LWCELL,LWOPEN,QCLOSE,QREAD,QSEEK,QWRITE, + SFCTL1,SFCTL145,SFCTL146,SFCTL152,SFCTL169,SFCTL18, + SFCTL19,SFCTL4,SFCTL92,WATOM C .. C .. Intrinsic Functions .. INTRINSIC ABS,COS,SQRT C .. C .. Common blocks .. COMMON /ATMLIM/ + ExtBoxLowLim(3),ExtBoxUpLim(3), + SquAtmRadLimit,NumPlanes, + ExtraPlanes(3,6),PlanesLimits(6), + SpecialPlaneLimit(6), + AtmBoxLowLim(3),AtmBoxUpLim(3), + NumAtmRefined,NumZeroOccAtms COMMON /ATSYM/ + NumSymmetry,NumSpaceGroup, + RealSymmMatrx(4,4,MaxSymmetry), + RecipSymmMatrx(4,4,MaxSymmetry), + PermutRecipSymm(4,4), + LSymmFlags(MaxSymmetry) COMMON /IOSF/ + IOscratch,IOgradmat,IOhessian,IOshifts, + IOatomop,IOmap,IOxyzin,IOxyzoutunq COMMON /KH/ + RmsDelta,AA1,A6NAP2,A6NAP3,GR1,GR3NA2 COMMON /MPHDR/ + NX,NY,NZ, + IXmin,IXmax,IYmin,IYmax,IZmin,IZmax, + Jsec,JU1,JU2,JV1,JV2,Iuvw(3), + NumSFspaceGroup,NumSections, + RHmin,RHmax,RHmean,NumSFsymm, + CellMtz(6),VolMtz,Volfft,F000 COMMON /SFOUT/ + Smin,Smax,TSmin,TSmax,SSbinSize, + LFpartFlag,LPhiPartFlag,LWghtModeFlag, + ScaleFcalc,ScaleFpart, + SigmaExclude,WangSphereRadi, + BfactOverall,BfactFpart, + NumMultiplicity,NLPRGO COMMON /SRFCTL/ + NtotalRefsUsed, + RatioShiftTrunc,W,TH, + LSFmodeFlag,LrefineCycFlag,LBfactRefFlag, + LcheckSFspaceGrpFlag,LFreeRexcludeVal, + XyzStartStepSize,BfactStartStepSize, + SFrepeatValue, + RmsXyz,RmsBfactor COMMON /SRFCTL1/ + LSFcalcFlag,LSFrefFlag, + LatomMapFlag,LxyzInputFlag, + LhklInputFlag,LMapInFlag, + LSolvMaskFlag,LXyzOutputFlag COMMON /TERSE/ + LverboseFlag,LNoScaleFlag C .. C .. Data statements .. DATA CTPRGO/'H','H','H','F','Q','R','F','P'/ DATA LSPRGO/'H','K','L','FP','SIGFP','FREE','FC','PHIC'/ C .. C LCYC = LrefineCycFlag IF (LSFmodeFlag.GE.1) LCYC = 1 C C---- Step Size for shifts - First cycle no shifts C SZA = 0.0 C C---- go to calculate str before SFCTL ucture factors C Open FFTHKLSCR for writing before calling C SFCTLi if LSFrefFlag assigned C IF LSFcalcFlag - then FFTHKLSCR will C have been opened in KEYIN C with a complete set of LSPRG for output. C IF (LSFrefFlag.NE.0) THEN MTZOUT = 2 LAppnd = 0 NLPRGO = 8 CALL LWOPEN(MTZOUT,'FFTHKLSCR') CALL LWCELL(MTZOUT,CellMtz) CALL LWASSN(MTZOUT,LSPRGO,NLPRGO,CTPRGO,LAppnd) END IF C C---- During SFCTL - h k l fp Fc Phic will be written to FFTHKLSCR C During R3PI (called from SFCTL) C FFTHKLSCR will be closed for writing and opened for reading. C GO TO (20,30,40,50,60,70,80,90, + 100) LcheckSFspaceGrpFlag 20 CONTINUE C CALL SFCTL1(X,Size,LCYC,PI0,NATST, + NATST2,BB,MB, + XB,IA,AtomicNumOccup,IRESB,SZA) GO TO 110 30 CONTINUE CALL SFCTL4(X,Size,LCYC,PI0,NATST, + NATST2,BB,MB,XB,IA, + AtomicNumOccup,IRESB,SZA) GO TO 110 40 CONTINUE CALL SFCTL18(X,Size,LCYC,PI0, + NATST,NATST2,BB,MB, + XB,IA,AtomicNumOccup,IRESB,SZA) GO TO 110 50 CONTINUE CALL SFCTL19(X,Size,LCYC,PI0, + NATST,NATST2,BB,MB, + XB,IA,AtomicNumOccup,IRESB,SZA) GO TO 110 60 CONTINUE CALL SFCTL92(X,PHI,Size,LCYC,PI0, + NATST,NATST2,BB,MB, + XB,IA,AtomicNumOccup,IRESB,SZA) GO TO 110 70 CONTINUE CALL SFCTL145(X,PHI,Size,LCYC,PI0, + NATST,NATST2,BB,MB, + XB,IA,AtomicNumOccup,IRESB,SZA) GO TO 110 80 CONTINUE CALL SFCTL146(X,Size,LCYC,PI0,NATST,NATST2,BB,MB, + XB,IA,AtomicNumOccup,IRESB,SZA) GO TO 110 90 CONTINUE CALL SFCTL152(X,PHI,Size,LCYC,PI0, + NATST,NATST2,BB,MB, + XB,IA,AtomicNumOccup,IRESB,SZA) GO TO 110 100 CONTINUE CALL SFCTL169(X,PHI,Size,LCYC,PI0, + NATST,NATST2,BB,MB, + XB,IA,AtomicNumOccup,IRESB,SZA) GO TO 110 110 CONTINUE C IF (LSFcalcFlag.EQ.1) THEN CALL CLOSEIT CALL CCPERR(0,' Normal Termination of structure factor calc.') ENDIF C C---- Continue if you are doing refinement C MLESSN = NtotalRefsUsed - 3*NumAtmRefined IF (LBfactRefFlag.EQ.1) + MLESSN = NtotalRefsUsed - NumAtmRefined SIGWT = PI0/MLESSN C C---- npar=1 for x y z grad C for b grad C NPAR = 1 IF (LBfactRefFlag.EQ.1) NPAR = 4 130 CONTINUE C C---- Rewind FFTHKLSCR ( now opened for READING!) C CALL LRREWD(MTZOUT) C C---- FFT19R now takes over control. C it calculates a modified grad map, C and calls genden to calculate atom gradients. C GO TO (140,150,160,170,180,190,200,210, + 220) LcheckSFspaceGrpFlag 140 CONTINUE CALL FFTGR1(X,Size,NPAR,LCYC) GO TO 230 150 CONTINUE C CALL FFTGR4(X,FCAL,PHI,Size,NFCDIM,NPAR,LCYC) CALL FFTGR4(X,Size,NPAR,LCYC) GO TO 230 160 CONTINUE CALL FFTGR18(X,Size,NPAR,LCYC) GO TO 230 170 CONTINUE CALL FFTGR19(X,Size,NPAR,LCYC) GO TO 230 180 CONTINUE CALL FFTGR92(X,PHI,Size,NPAR,LCYC) GO TO 230 190 CONTINUE CALL FFTGR145(X,PHI,Size,NPAR,LCYC) GO TO 230 200 CONTINUE CALL FFTGR146(X,PHI,Size,NPAR,LCYC) GO TO 230 210 CONTINUE CALL FFTGR152(X,PHI,Size,NPAR,LCYC) GO TO 230 220 CONTINUE CALL FFTGR169(X,PHI,Size,NPAR,LCYC) GO TO 230 230 CONTINUE C WRITE (6,FMT=6000) NPAR 6000 FORMAT (' GRAD ',I4,' COMPLETED.') C C---- Go to read gradients and apply shifts to coordinates C C ****************** CALL GRSCRM(SDNORM, + Slope, + NPAR, + NATREF, + GRADN, + SDXB, + HESS) C ****************** C C---- check LSFmodeFlag for further action C if LSFmodeFlag le 2 gradients output for prolsq - C no more sf calculations. C SZ = XyzStartStepSize IF (NPAR.EQ.4)SZ = BfactStartStepSize C C---- restrained refinement - must write out GRADMAT terms. C IF (LSFmodeFlag.EQ.1 .OR. LSFmodeFlag.EQ.2) GO TO 470 C C---- Unrestrained refinement of xyz C (LSFmodeFlag 3) or b (LSFmodeFlag 4) C LSFmodeFlag = 2 - x y z b - go back and recalculate fftgr C IF (LSFmodeFlag.EQ.5) THEN IF (NPAR.LT.4) THEN NPAR = 4 LBfactRefFlag = 1 GO TO 130 ENDIF ENDIF C C---- Dont bother to recalculate structure factors.??? C IF (SFrepeatValue .GT.1.0) GO TO 380 ICALC = 1 C C---- section for recycling structure factor calculation. C First pass: XyzStartStepSize = input step Size. 250 CONTINUE SZA = SZ C C---- Recalculate sfs with shifted atoms C if this is not the First time through apply C new step Size to shifts C WRITE (6,FMT=6002) SZA WRITE (6,FMT=6004) 6002 FORMAT (//, +' Another S.F. Calcn to test optimum step Size ',F10.5) 6004 FORMAT (/' This is the First atom position now.') C C---- Before calculating structure factors again C advance cycle number by 100 . C LCYC = LCYC + 100 C C---- Close FFTHKLSCR for reading and open it for writing again C Remember: FFTHKLSCR was closed for writing and opened for C reading in R3PI. C MTZOUT = 2 LAppnd = 0 C C ****************************************** CALL LRCLOS(MTZOUT) CALL LWOPEN(MTZOUT,'FFTHKLSCR') CALL LWCELL(MTZOUT,CellMtz) CALL LWASSN(MTZOUT,LSPRGO,NLPRGO,CTPRGO,LAppnd) C ****************************************** C GO TO (280,290,300,310,320,330,340,350, + 360) LcheckSFspaceGrpFlag 280 CONTINUE CALL SFCTL1(X,Size,LCYC,PI1, + NATST,NATST2,BB,MB, + XB,IA,AtomicNumOccup,IRESB,SZA) GO TO 370 290 CONTINUE CALL SFCTL4(X,Size,LCYC,PI1, + NATST,NATST2,BB,MB, + XB,IA,AtomicNumOccup,IRESB,SZA) GO TO 370 300 CONTINUE CALL SFCTL18(X,Size,LCYC,PI1, + NATST,NATST2,BB, + MB,XB,IA,AtomicNumOccup,IRESB,SZA) GO TO 370 310 CONTINUE CALL SFCTL19(X,Size,LCYC,PI1, + NATST,NATST2,BB,MB, + XB,IA,AtomicNumOccup,IRESB,SZA) GO TO 370 320 CONTINUE CALL SFCTL92(X,PHI,Size,LCYC,PI1, + NATST,NATST2,BB,MB, + XB,IA,AtomicNumOccup,IRESB,SZA) GO TO 370 330 CONTINUE CALL SFCTL145(X,PHI,Size,LCYC,PI1, + NATST,NATST2,BB,MB, + XB,IA,AtomicNumOccup,IRESB,SZA) GO TO 370 340 CONTINUE CALL SFCTL146(X,Size,LCYC,PI1,NATST,NATST2,BB,MB, + XB,IA,AtomicNumOccup,IRESB,SZA) GO TO 370 350 CONTINUE CALL SFCTL152(X,PHI,Size,LCYC,PI1, + NATST,NATST2,BB,MB, + XB,IA,AtomicNumOccup,IRESB,SZA) GO TO 370 360 CONTINUE CALL SFCTL169(X,PHI,Size,LCYC,PI1, + NATST,NATST2,BB,MB, + XB,IA,AtomicNumOccup,IRESB,SZA) GO TO 370 370 CONTINUE C C---- Try to estimate optimal step Size for this problem from C PI0 and PI1 ( = sigma(w*delta**2) C Make corrections for extra symmetry - C I am not sure what is necessary C Probably MLESSN is wrong - C NtotalRefsUsed * NumSymmetry ...But does it matter.. C MLESSN = NtotalRefsUsed - 3*NumAtmRefined IF (LBfactRefFlag.EQ.1) + MLESSN = NtotalRefsUsed - NumAtmRefined IF (ICALC.EQ.1) SIGWT = PI1/MLESSN ICALC = ICALC + 1 LCYC = LCYC - 100 WRITE (6,FMT=6010) PI1 6010 FORMAT (' Corresponding P.I is ',E9.3) C C---- No point in this if LSFmodeFlag = 5 and C both B and XYZ refinement attempted. C IF (LSFmodeFlag.EQ.5) GO TO 380 Slope1 = (PI1-PI0)/ (SZA*Slope) C C---- EJD thinks PI1 and PI0 C should be multiplied by C NumPrimSymm*NumMultiplicity / NumSFsymm C Slope has been multiplied by this in GRSCRM ... C Everything could easily be out by a factor of NumMultiplicity! C EJD June 1991 - "NumSymmetry" = NumPrimSymm actually C Slope = Slope*NumSymmetry*NumMultiplicity/NumSFsymm C Slope1 = Slope1*NumSymmetry*NumMultiplicity/NumSFsymm IF (LverboseFlag)WRITE (6,FMT=6012) Slope1 6012 FORMAT (' Corresponding Relative Slope is',5X,E9.3) C IF (Slope1.GE.0.95) THEN Slope1 = 0.95 IF (LverboseFlag)WRITE (6,FMT=6014) Slope1 6014 FORMAT (//, +' HORRIBLE Result-relative Slope SHOULD BE < 1 RESET TO ',E8.3) END IF C CORR = 1.0/ ((1.0-Slope1)*2.0) IF (CORR.LT.0.5) CORR = 0.5 IF (CORR.GT.2.0) CORR = 2.0 SZ = CORR*XyzStartStepSize IF (NPAR.EQ.4)SZ = CORR*BfactStartStepSize DELCOR = ABS(CORR-1.0) IF (DELCOR.GT.SFrepeatValue) WRITE (6,FMT=6016) 6016 FORMAT (////' ** NB ** Change in stepSize gt program limit') WRITE (6,FMT=6018) SZ 6018 FORMAT (' Optimum step Size is',6X,E9.3) D53 = SDNORM*SZ WRITE (6,FMT=6020) D53 6020 FORMAT (' Corresponding relative displacement is',5X,E9.3) PIN = 0.5*Slope* (SZA-SZ)**2/SZA + PI1 WRITE (6,FMT=6022) PIN 6022 FORMAT (' Estimated new PI is',6X,E9.3) C C---- if step Size change less than 30% or two trial sfs done already C do not recalculate sfs C IF (DELCOR.GT.SFrepeatValue .AND. ICALC.LT.3) GO TO 250 IF (LverboseFlag)WRITE (6,FMT=6024) SZA,SZ 6024 FORMAT (/, +' Step Size actually used = ',F10.3,/, +' - Optimum step Size = ',F8.3) D53 = SDNORM*SZ WRITE (6,FMT=6020) D53 C IF (NPAR.NE.4)THEN XyzStartStepSize = SZ BfactStartStepSize = 0.0 END IF C IF (NPAR.EQ.4)THEN BfactStartStepSize = SZ XyzStartStepSize = 0.0 END IF C IF (LSFmodeFlag.EQ.3) BfactStartStepSize = 0.0 IF (LSFmodeFlag.EQ.4) XyzStartStepSize = 0.0 380 CONTINUE C C---- Output new coordinates to XYZOUT C CALL WATOM(XyzStartStepSize, + BfactStartStepSize, + SIGWT, + BfactOverall, + RmsXyz, + RmsBfactor) CALL CLOSEIT CALL CCPERR(0,' Normal Termination of unrestrained ref.') C C---- Matrix for PROLSQ C 470 CONTINUE IF (NPAR.EQ.4) GO TO 440 C C---- Rewrite hess and common/KH in form C ready for input to konnert-hendrickson C C---- Take care over space C we need to build an array for konnert Matrix =6*NumAtmRefined C then we need an array of length 3*NumAtmRefined C so use sdxb space for this and read our grads into gradn . C isn't it fantastic that they fit!! C AverageDiagonal = 0.0 GradientRms = 0.0 C C ****************************************** CALL QSEEK(IOhessian,1,1,1) CALL QREAD(IOhessian,HESS(1),NumAtmRefined,IER) C ****************************************** C ASQ = CellMtz(1)*CellMtz(1) BBSQ = CellMtz(2)*CellMtz(2) CSQ = CellMtz(3)*CellMtz(3) ABCG = CellMtz(1)*CellMtz(2)*COS(CellMtz(6)/57.295) BBCCA = CellMtz(2)*CellMtz(3)*COS(CellMtz(4)/57.295) CACB = CellMtz(3)*CellMtz(1)*COS(CellMtz(5)/57.295) C DO 390 I = 1,NumAtmRefined X(6*I-5) = HESS(I)*ASQ X(6*I-4) = HESS(I)*ABCG X(6*I-3) = HESS(I)*CACB X(6*I-2) = HESS(I)*BBSQ X(6*I-1) = HESS(I)*BBCCA X(6*I) = HESS(I)*CSQ AverageDiagonal = AverageDiagonal + + X(6*I-5) + + X(6*I-2) + + X(6*I) 390 CONTINUE C AverageDiagonal = AverageDiagonal/ (3*NumAtmRefined) C C---- Write some important numbers at head of file C Work(1) = AverageDiagonal Work(2) = NumAtmRefined Work(3) = NtotalRefsUsed Work(4) = LSFmodeFlag C C ************************ CALL QWRITE(IOgradmat,Work,4) C ************************ C C---- Write Scale element C C *********************** CALL QWRITE(IOgradmat,AA1,1) C *********************** C C---- Write atom blocks C NOEL = 6*NumAtmRefined C C ************************ CALL QWRITE(IOgradmat,X,NOEL) C ************************ C IF (LverboseFlag)WRITE (6,FMT=6032) (X(I),I=1,48) 6032 FORMAT (/, +' Xray Matrix check ',/, +' Hessian xray Matrix - First 8 ENTRYS',8 (/3X,6E12.4)) C C---- Write BfactOverall and BfactOverall/SC correlation C Work(1) = A6NAP2 Work(2) = A6NAP3 C C ***************************************** CALL QWRITE(IOgradmat,Work,2) CALL QREAD(IOhessian,X(1),3*NumAtmRefined,IER) C ***************************************** C DO 400 I = 1,NumAtmRefined X(3*I-2) = -CellMtz(1)*SZ*X(3*I-2) X(3*I-1) = -CellMtz(2)*SZ*X(3*I-1) X(3*I) = -CellMtz(3)*SZ*X(3*I) GradientRms = GradientRms + + X(3*I-2)**2 + + X(3*I-1)**2 + + X(3*I)**2 400 CONTINUE C GradientRms = SQRT(GradientRms/ (3*NumAtmRefined)) WRITE (6,FMT=6036) NumAtmRefined, + AverageDiagonal, + GradientRms, + AA1,A6NAP3,GR1, + A6NAP3,A6NAP2,GR3NA2 6036 FORMAT (///, +' Number of atoms included in refinement ',i5,/, +' Average XYZ-Matrix diagonal is ',E12.3,/, +' Rms Gradient term is ',E12.3,/, +' Scale B value correction from this',/, +' 2*2 Matrix and Vector',/, +2 (/5X,2E12.3,10X,E12.3)) C C---- Now for the RHS vector C NOEL = 3*NumAtmRefined C C ******************** CALL QWRITE(IOgradmat,GR1,1) CALL QWRITE(IOgradmat,X,NOEL) CALL QWRITE(IOgradmat,GR3NA2,1) C ********************* C IF (LverboseFlag) WRITE (6,FMT=6034) (X(I),I=1,24) 6034 FORMAT (///' Gradient diagnostic ',8 (/3E12.4)) LCYC = LCYC + 1 C C---- if LSFmodeFlag=1 xyz only - stop now C IF (LSFmodeFlag.EQ.1) THEN CALL QWRITE(IOgradmat,BfactOverall,1) CALL QCLOSE(IOgradmat) CALL CLOSEIT CALL CCPERR(0,' Normal Termination of xyz restrained ref.') END IF C C---- LSFmodeFlag = 2 - x y z b - go back and recalculate fftgr C NPAR = 4 LBfactRefFlag = 1 GO TO 130 C C---- come here if LBfactRefFlag = 1 C Write Matrix elements needed for atomic temperature C factor refinement C 440 CONTINUE C C ****************************************** CALL QSEEK(IOhessian,1,1,NumAtmRefined) CALL QREAD(IOhessian,HESS(1),NumAtmRefined,IER) C ****************************************** C AverageDiagonal = 0.0 C DO 450 I = 1,NumAtmRefined X(I) = HESS(I) AverageDiagonal = X(I) + AverageDiagonal 450 CONTINUE C AverageDiagonal = AverageDiagonal/NumAtmRefined C C ********************************* CALL QWRITE(IOgradmat,X,NumAtmRefined) C ********************************* C C---- Now for the RHS vector gradient terms C GradientRms = 0.0 C C ***************************************** CALL QREAD(IOhessian,X(1),3*NumAtmRefined,IER) C ***************************************** C DO 460 I = 1,NumAtmRefined X(I) = -X(3*I-2)*SZ GradientRms = X(I)*X(I) + GradientRms 460 CONTINUE C GradientRms = SQRT(GradientRms/NumAtmRefined) C C ********************************* CALL QWRITE(IOgradmat,X,NumAtmRefined) CALL QWRITE(IOgradmat,BfactOverall,1) CALL QCLOSE(IOgradmat) C ********************************* C WRITE (6,FMT=6038) AverageDiagonal,GradientRms 6038 FORMAT (/, +' Average B-Matrix diagonal is ',E12.3,/, +' Average rms gradient term is ',E12.3) C CALL CLOSEIT CALL CCPERR(0,' Normal Termination of xyz and b restrained ref.') C END C C ============================================================= SUBROUTINE ROTPERM(NumSymmetry,PermutRecipSymm,RealSymmMatrx) C ============================================================= C C .. Scalar Arguments .. INTEGER NumSymmetry C .. C .. Array Arguments .. REAL PermutRecipSymm(4,4),RealSymmMatrx(4,4,*) C .. C .. Scalars in Common .. LOGICAL LNoScaleFlag,LverboseFlag C .. C .. Local Scalars .. INTEGER I,ISYM,J,JX,JY,JZ C .. C .. Local Arrays .. REAL R1(4,4) CHARACTER NAME(3)*1 C .. C .. Common blocks .. COMMON /TERSE/ + LverboseFlag,LNoScaleFlag C .. C .. Data statements .. DATA NAME/'X','Y','Z'/ C .. C DO 10 I = 1,3 IF (PermutRecipSymm(1,I).EQ.1.0) JX = I IF (PermutRecipSymm(2,I).EQ.1.0) JY = I IF (PermutRecipSymm(3,I).EQ.1.0) JZ = I 10 CONTINUE C WRITE (6,FMT=6000) NAME(JX),NAME(JY),NAME(JZ) 6000 FORMAT ( +' INPUT X USED AS ',A2,/, +' INPUT Y USED AS ',A2,/, +' INPUT Z USED AS ',A2) C DO 60 ISYM = 1,NumSymmetry IF (LverboseFlag) + WRITE (6,FMT=6002) ISYM, + ((RealSymmMatrx(I,J,ISYM),J=1,3),I=1,3), + (RealSymmMatrx(J,4,ISYM),J=1,3) 6002 FORMAT (' INT TAB SYMMETRY ',I3,4 (5X,3F6.2)) C IF (JX.NE.1 .OR. JY.NE.2) THEN C DO 30 I = 1,4 DO 20 J = 1,4 R1(J,I) = PermutRecipSymm(J,1)* + RealSymmMatrx(1,I,ISYM) + + PermutRecipSymm(J,2)* + RealSymmMatrx(2,I,ISYM) + + PermutRecipSymm(J,3)* + RealSymmMatrx(3,I,ISYM) + + PermutRecipSymm(J,4)* + RealSymmMatrx(4,I,ISYM) 20 CONTINUE 30 CONTINUE C DO 50 J = 1,4 DO 40 I = 1,4 RealSymmMatrx(J,I,ISYM) = R1(J,I) 40 CONTINUE 50 CONTINUE C IF (LverboseFlag) + WRITE (6,FMT=6004) ISYM, + ((RealSymmMatrx(I,J,ISYM),J=1,3),I=1,3), + (RealSymmMatrx(J,4,ISYM),J=1,3) 6004 FORMAT (' TRANSFORMED SYMMETRY ',I3,4 (5X,3F6.2)) END IF 60 CONTINUE C END C C ============== BLOCK DATA SF C ============== C INTEGER MCOLS PARAMETER (MCOLS=200) INTEGER NAACID,NATMTP CHARACTER MAACD1*1,MAACID*4,MATMTP*4 INTEGER LookUp COMMON /LABEL1/ + NATMTP,NAACID COMMON /LABLS2/ + MATMTP(50),MAACID(27),MAACD1(26) COMMON /MTZOP/ + Mlook,LookUp(MCOLS) COMMON /SFOUT/ + Smin,Smax,TSmin,TSmax,SSbinSize, + LFpartFlag,LPhiPartFlag,LWghtModeFlag, + ScaleFcalc,ScaleFpart, + SigmaExclude,WangSphereRadi, + BfactOverall,BfactFpart, + NumMultiplicity,NLPRGO DATA NATMTP/41/ DATA NAACID/27/ DATA MATMTP/'C ','CA ','CA2 ','CB ','CB2 ','CG ','CG1 ', + 'CG2 ','CD ','CD1 ','CD2 ','CE ','CE1 ','CE2 ','CE3 ', + 'CZ ','CZ2 ','CZ3 ','CH2 ','N ','ND1 ','ND2 ','NE ', + 'NE1 ','NE2 ','NZ ','NH1 ','NH2 ','O ','OG ','OG1 ', + 'OD1 ','OD2 ','OE1 ','OE2 ','OE ','OH ','OW ','SD ', + 'SG ','SG2 ',' ',' ',' ',' ',' ',' ', + ' ',' ','ZZZ '/ DATA MAACID/'ALA ','ARG ','ASN ','ASP ','CYS ','CYH ','GLN ', + 'GLU ','GLY ','HIS ','ILE ','LEU ','LYS ','MET ','PHE ', + 'PRO ','SER ','THR ','TRP ','TYR ','VAL ','HEM ','WAT ', + 'SUL ','END ','HOH ','DUM '/ DATA MAACD1/'A','R','N','D','C','C','Q','E','G','H','I','L','K', + 'M','F','P','S','T','W','Y','V','X','O','U','Z','Z'/ DATA LookUp/-1,-1,-1,-1,-1,195*0/ DATA NLPRGO /30/ C END C C ======================================================== SUBROUTINE SFCTL1(X,Size,LCYC,PII,NATST,NATST2,BB,MB,XB, + IA,AtomicNumOccup,IRESB,SZA) C ======================================================== C C .. Scalar Arguments .. REAL PII,SZA INTEGER LCYC,NATST,NATST2,Size C .. C .. Array Arguments .. REAL ATOMICNUMOCCUP(NATST),BB(NATST),X(Size),XB(2,NATST) INTEGER IA(NATST2),IRESB(NATST),MB(NATST) C .. C .. Scalars in Common .. REAL BfactFpart,BfactOverall,RHmax,RHmean,RHmin,ScaleFcalc, + ScaleFpart,SigmaExclude,Smax,Smin,SSbinSize,TSmax,TSmin, + VolMtz,WangSphereRadi INTEGER Hmax,Hmin,IOatomop,IOgradmat,IOhessian,IOmap,IOscratch, + IOshifts,IOxyzin,IOxyzoutunq,IXmax,IXmin,IYmax, + IYmin,IZmax,IZmin,Jsec,JU1,JU2,JV1,JV2,Kmax,Kmin, + LatomMapFlag,LFpartFlag,LSFrefFlag,LhklInputFlag, + LMapInFlag,Lmax,Lmin,LPhiPartFlag,LSFcalcFlag, + LSolvMaskFlag,LWghtModeFlag,LxyzInputFlag,LXyzOutputFlag, + NLPRGO,Nslab,NumMultiplicity,NumSections,NumSFspaceGroup, + NumSFsymm,NX,NY,NZ LOGICAL LNoScaleFlag,LverboseFlag C .. C .. Arrays in Common .. REAL CellMtz INTEGER Iuvw C .. C .. Local Scalars .. REAL SUM INTEGER I,IEND,ISLAB,LM1,N1,N2,N3,NPAR,NPassOneSave,NPassTwoSave, + NRCSC,NSizePassOne,NSizePassTwo,NumCurrentRecord, + NumSkipRecords,R,RECS,REND C .. C .. Local Arrays .. INTEGER D(5) C .. C .. External Subroutines .. EXTERNAL ATSORT,CCPERR,CMPLFT,GENDEN,HOUT1,MWCLOSE,QSEEK,R3PI, + READH1,REALFT,REDMAP,SOUTFC,SOUTY,WRITEMAP,XYZREWD C .. C .. Common blocks .. COMMON /HKLLIM/ + Hmax,Kmax,Lmax,Hmin,Kmin,Lmin,Nslab COMMON /IOSF/ + IOscratch,IOgradmat,IOhessian,IOshifts, + IOatomop,IOmap,IOxyzin,IOxyzoutunq COMMON /MPHDR/ + NX,NY,NZ, + IXmin,IXmax,IYmin,IYmax,IZmin,IZmax, + Jsec,JU1,JU2,JV1,JV2,Iuvw(3), + NumSFspaceGroup,NumSections, + RHmin,RHmax,RHmean,NumSFsymm, + CellMtz(6),VolMtz,Volfft,F000 COMMON /SFOUT/ + Smin,Smax,TSmin,TSmax,SSbinSize, + LFpartFlag,LPhiPartFlag,LWghtModeFlag, + ScaleFcalc,ScaleFpart, + SigmaExclude,WangSphereRadi, + BfactOverall,BfactFpart, + NumMultiplicity,NLPRGO COMMON /SRFCTL1/ + LSFcalcFlag,LSFrefFlag, + LatomMapFlag,LxyzInputFlag, + LhklInputFlag,LMapInFlag, + LSolvMaskFlag,LXyzOutputFlag COMMON /TERSE/ + LverboseFlag,LNoScaleFlag C .. C IF (LverboseFlag) WRITE (6,FMT=*) ' in sfctl1' LM1 = Lmax + 1 NSizePassOne = Size/ ((NZ+2)*NX) NPassOneSave = NSizePassOne NSizePassTwo = Size/ (NY*2*LM1) IF (NSizePassTwo .GT. (Hmax-Hmin+1)) + NSizePassTwo = Hmax - Hmin + 1 NPassTwoSave = NSizePassTwo R = IYmin REND = IYmax C DO 10 I = 1,Size X(I) = 0.0 10 CONTINUE C NRCSC = 2*NSizePassOne*NSizePassTwo*LM1 C C ********************** CALL QSEEK(IOscratch,1,1,1) C ********************** C NumCurrentRecord = 0 IF (LxyzInputFlag.EQ.0) GO TO 20 C C---- sort atoms on 3rd coordinate - now y. C C ***************************** CALL ATSORT(NATST, + NATST2, + BB, + MB, + XB, + IA, + AtomicNumOccup, + IRESB, + SZA, + BfactOverall) CALL XYZREWD(IOxyzin) C ***************************** C NumCurrentRecord = 0 20 CONTINUE IF (R+NSizePassOne.GT.REND) NSizePassOne = REND - R + 1 N1 = NZ + 2 N2 = NX N3 = NSizePassOne NPAR = 0 C C---- read previously obtained density map . C IF (LMapInFlag.EQ.1 .AND. LxyzInputFlag.EQ.0) THEN SUM = 0.0 CALL REDMAP(X,N1,N2,N3,R,SUM) GO TO 40 END IF C C ***************************** CALL GENDEN(X,N1,N2,N3,R,NPAR,SUM) C ***************************** C IF (LatomMapFlag.EQ.0) GO TO 40 C C---- check density map C CALL WRITEMAP(IOmap,X,N1,N2,N3) C IF (LSFcalcFlag.EQ.0) GO TO 60 C C---- density generated for NSizePassOne sections. C now calculate z and x transforms. C 40 IF (SUM.EQ.0.0) GO TO 50 D(1) = (NZ+2)*NX*NSizePassOne D(2) = 2 D(3) = D(1) D(4) = D(1) D(5) = NZ + 2 C C ************************* CALL REALFT(X(1),X(2),NZ/2,D) C ************************* C D(2) = NZ + 2 D(3) = (NZ+2)*NX D(4) = LM1*2 D(5) = 2 C C ****************************** CALL CMPLFT(X(1), + X(2), + NX, + D) 50 CALL HOUT1(X, + (NZ+2)/2, + NX, + NSizePassOne, + Lmax, + Hmax, + NSizePassTwo, + IOscratch, + NumCurrentRecord, + NRCSC) C ****************************** C 60 R = R + NSizePassOne IF (R.LE.REND) GO TO 20 C IF (LatomMapFlag.EQ.1)THEN CALL MWCLOSE(IOmap) IF (LSFcalcFlag.EQ.0) THEN CALL CLOSEIT CALL CCPERR(0,' Normal Termination of fc map output') ENDIF END IF C C---- Pass 2 reads intermediate results and calculates fourier C transforms on y. C NSizePassOne = NPassOneSave NumSkipRecords = 0 RECS = (2*Hmax)/NSizePassTwo R = Hmin IEND = 0 70 CONTINUE NumCurrentRecord = 1 IF (R+NSizePassTwo.GT.Hmax) NSizePassTwo = Hmax + 1 - R C C ******************************** CALL READH1(X, + NY, + Lmax+1, + NSizePassTwo, + NSizePassOne, + NumSkipRecords, + RECS, + IOscratch, + NumCurrentRecord, + NRCSC) C ******************************** C NumSkipRecords = NumSkipRecords + 1 D(1) = 2*NY*LM1*NSizePassTwo D(2) = 2 D(3) = D(1) D(4) = D(1) D(5) = 2*NY C C ********************** CALL CMPLFT(X(1),X(2),NY,D) C ********************** C C *********************** IF (LhklInputFlag.EQ.1) CALL SOUTY(X, + NY, + LM1, + NPassTwoSave, + NSizePassTwo, + R, + ISLAB, + LCYC, + IEND) C *********************** C IF (LSFcalcFlag.EQ.1 .AND. LhklInputFlag.EQ.0) + CALL SOUTFC(X, + NY, + LM1, + NPassTwoSave, + NSizePassTwo, + R, + ISLAB, + LCYC, + IEND) C R = R + NSizePassTwo IF (R.LE.Hmax .AND. IEND.EQ.0) GO TO 70 Nslab = ISLAB IF (LverboseFlag) WRITE (6,FMT=6000) Nslab 6000 FORMAT (' NUMBER OF SLABS =',I5,/) IF (LSFcalcFlag.EQ.1 .AND. LhklInputFlag.EQ.0) RETURN C C---- calculate weighted differences C C ************** CALL R3PI(PII,LCYC) C ************** C END C C ======================================================== SUBROUTINE SFCTL145(X,PHI,Size,LCYC,PII,NATST,NATST2,BB, + MB,XB,IA,AtomicNumOccup,IRESB,SZA) C ======================================================== C C .. Scalar Arguments .. REAL PII,SZA INTEGER LCYC,NATST,NATST2,Size C .. C .. Array Arguments .. REAL ATOMICNUMOCCUP(NATST),BB(NATST),PHI(Size/2),X(Size), + XB(2,NATST) INTEGER IA(NATST2),IRESB(NATST),MB(NATST) C .. C .. Scalars in Common .. REAL BfactFpart,BfactOverall,RHmax,RHmean,RHmin,ScaleFcalc, + ScaleFpart,SigmaExclude,Smax,Smin,SSbinSize,TSmax,TSmin, + VolMtz,WangSphereRadi INTEGER Hmax,Hmin,IOatomop,IOgradmat,IOhessian,IOmap,IOscratch, + IOshifts,IXmax,IOxyzin,IOxyzoutunq,IXmin,IYmax, + IYmin,IZmax,IZmin,Jsec,JU1,JU2,JV1,JV2,Kmax,Kmin, + LatomMapFlag,LFpartFlag,LSFrefFlag,LhklInputFlag, + LMapInFlag,Lmax,Lmin,LPhiPartFlag,LSFcalcFlag, + LSolvMaskFlag,LWghtModeFlag,LxyzInputFlag,LXyzOutputFlag, + NLPRGO,Nslab,NumMultiplicity,NumSections,NumSFspaceGroup, + NumSFsymm,NX,NY,NZ LOGICAL LNoScaleFlag,LverboseFlag C .. C .. Arrays in Common .. REAL CellMtz INTEGER Iuvw C .. C .. Local Scalars .. REAL SUM INTEGER I,ICHK,IEND,ISLAB,KM1,N1,N2,N3,NPAR,NPassOneSave, + NPassTwoSave,NSizePassOne,NSizePassTwo,NumCurrentRecord,R, + REND C .. C .. Local Arrays .. INTEGER D(5) C .. C .. External Subroutines .. EXTERNAL ATSORT,CCPERR,CMPLFT,GENDEN,IN144,MWCLOSE,QSEEK,R3PI, + REALFT,REDMAP,SOUTFC,SOUTZ,WRITEMAP,WRITEZ,XYZREWD C .. C .. Common blocks .. COMMON /HKLLIM/ + Hmax,Kmax,Lmax,Hmin,Kmin,Lmin,Nslab COMMON /IOSF/ + IOscratch,IOgradmat,IOhessian,IOshifts, + IOatomop,IOmap,IOxyzin,IOxyzoutunq COMMON /MPHDR/ + NX,NY,NZ, + IXmin,IXmax,IYmin,IYmax,IZmin,IZmax, + Jsec,JU1,JU2,JV1,JV2,Iuvw(3), + NumSFspaceGroup,NumSections, + RHmin,RHmax,RHmean,NumSFsymm, + CellMtz(6),VolMtz,Volfft,F000 COMMON /SFOUT/ + Smin,Smax,TSmin,TSmax,SSbinSize, + LFpartFlag,LPhiPartFlag,LWghtModeFlag, + ScaleFcalc,ScaleFpart, + SigmaExclude,WangSphereRadi, + BfactOverall,BfactFpart, + NumMultiplicity,NLPRGO COMMON /SRFCTL1/ + LSFcalcFlag,LSFrefFlag, + LatomMapFlag,LxyzInputFlag, + LhklInputFlag,LMapInFlag, + LSolvMaskFlag,LXyzOutputFlag COMMON /TERSE/ + LverboseFlag,LNoScaleFlag C .. C C ********************** CALL QSEEK(IOscratch,1,1,1) C ********************** C KM1 = Kmax + 1 NSizePassOne = Size/ ((NY+2)*NX) NPassOneSave = NSizePassOne NSizePassTwo = Size/ (2*NZ*KM1) IF (NSizePassTwo.GT. (Hmax-Hmin+1)) + NSizePassTwo = Hmax - Hmin + 1 NPassTwoSave = NSizePassTwo R = IZmin REND = IZmax C DO 10 I = 1,Size X(I) = 0.0 10 CONTINUE C C---- sort atoms on 3rd coordinate - now z. C NumCurrentRecord = 0 IF (LxyzInputFlag.EQ.0) GO TO 20 C C ****************************** CALL ATSORT(NATST, + NATST2, + BB, + MB, + XB, + IA, + AtomicNumOccup, + IRESB, + SZA, + BfactOverall) CALL XYZREWD(IOxyzin) C ****************************** C NumCurrentRecord = 0 20 CONTINUE C IF (R+NSizePassOne.GT.REND) NSizePassOne = REND - R + 1 N1 = NY + 2 N2 = NX N3 = NSizePassOne NPAR = 0 C C IF (LMapInFlag.EQ.1 .AND. LxyzInputFlag.EQ.0) THEN SUM = 0.0 CALL REDMAP(X,N1,N2,N3,R,SUM) GO TO 40 END IF C C ***************************** CALL GENDEN(X,N1,N2,N3,R,NPAR,SUM) C ***************************** C C---- density generated for NSizePassOne sections. now calculate C y and x transforms C IF (LatomMapFlag.EQ.1) THEN C C ************************** CALL WRITEMAP(IOmap,X,N1,N2,N3) C ************************** C IF (LSFcalcFlag.EQ.0) GO TO 60 END IF C 40 IF (SUM.EQ.0.0) GO TO 50 D(1) = (NY+2)*NX*NSizePassOne D(2) = 2 D(3) = D(1) D(4) = D(1) D(5) = NY + 2 C C ************************* CALL REALFT(X(1),X(2),NY/2,D) C ************************* C D(2) = NY + 2 D(3) = (NY+2)*NX D(4) = KM1*2 D(5) = 2 C C ********************* CALL CMPLFT(X(1),X(2),NX,D) C ********************* C C ***************************** 50 CALL WRITEZ(X, + (NY+2)/2, + NX, + NSizePassOne, + Kmax+1, + IOscratch, + NumCurrentRecord) C ***************************** C 60 CONTINUE R = R + NSizePassOne IF (R.LE.REND) GO TO 20 C IF (LatomMapFlag.EQ.1)THEN CALL MWCLOSE(IOmap) IF (LSFcalcFlag.EQ.0) THEN CALL CLOSEIT CALL CCPERR(0,' Normal Termination of fc map output') ENDIF END IF C C---- pass 2 reads intermediate results and calculates fourier C transforms on z/3. C C---- complex transform for(+ - h,+k,nz/3)calculated,now generate C (some h +k, all z) . use phi space for scratch C check 4*(nx+1)*(Kmax+!) le Size C ICHK = (NX+1)*4* (Kmax+1) IF (ICHK.GT.Size) CALL CCPERR(1, + ' DISASTER - SCRATCH AREA FOR IN144 TOO SMALL') NSizePassOne = NPassOneSave R = Hmin IEND = 0 70 CONTINUE NumCurrentRecord = 1 IF (R+NSizePassTwo.GT.Hmax) NSizePassTwo = Hmax + 1 - R C C ******************************* CALL IN144(X, + NZ, + Kmax+1, + NSizePassTwo, + R, + PHI, + KM1, + NX+1, + IOscratch, + NumSFspaceGroup) C ******************************* C D(1) = 2*NZ*KM1*NSizePassTwo D(2) = 2 D(3) = D(1) D(4) = D(1) D(5) = 2*NZ C C ********************** CALL CMPLFT(X(1),X(2),NZ,D) C ********************** C C *********************** IF (LhklInputFlag.EQ.1) CALL SOUTZ(X, + NZ, + KM1, + NPassTwoSave, + NSizePassTwo, + R, + ISLAB, + LCYC, + IEND) C *********************** C IF (LSFcalcFlag.EQ.1 .AND. LhklInputFlag.EQ.0) + CALL SOUTFC(X, + NZ, + KM1, + NPassTwoSave, + NSizePassTwo, + R, + ISLAB, + LCYC, + IEND) C R = R + NSizePassTwo IF (R.LE.Hmax .AND. IEND.EQ.0) GO TO 70 Nslab = ISLAB IF (LverboseFlag)WRITE (6,FMT=6002) Nslab 6002 FORMAT (' NUMBER OF SLABS =',I5,/) IF (LSFcalcFlag.EQ.1 .AND. LhklInputFlag.EQ.0) RETURN C C---- calculate weighted differences C C ************** CALL R3PI(PII,LCYC) C ************** C END C C ========================================================= SUBROUTINE SFCTL146(X,Size,LCYC,PII,NATST,NATST2, + BB,MB,XB,IA,AtomicNumOccup,IRESB,SZA) C ========================================================= C C .. Scalar Arguments .. REAL PII,SZA INTEGER LCYC,NATST,NATST2,Size C .. C .. Array Arguments .. REAL ATOMICNUMOCCUP(NATST),BB(NATST),X(Size),XB(2,NATST) INTEGER IA(NATST2),IRESB(NATST),MB(NATST) C .. C .. Scalars in Common .. REAL BfactFpart,BfactOverall,RHmax,RHmean,RHmin,ScaleFcalc, + ScaleFpart,SigmaExclude,Smax,Smin,SSbinSize,TSmax,TSmin, + VolMtz,WangSphereRadi INTEGER Hmax,Hmin,IOatomop,IOgradmat,IOhessian,IOmap,IOscratch, + IOshifts,Ioxyzin,IOxyzoutunq,IXmax,IXmin,IYmax, + IYmin,IZmax,IZmin,Jsec,JU1,JU2,JV1,JV2,Kmax,Kmin, + LatomMapFlag,LFpartFlag,LSFrefFlag,LhklInputFlag, + LMapInFlag,Lmax,Lmin,LPhiPartFlag,LSFcalcFlag, + LSolvMaskFlag,LWghtModeFlag,LxyzInputFlag,LXyzOutputFlag, + NLPRGO,Nslab,NumMultiplicity,NumSections,NumSFspaceGroup, + NumSFsymm,NX,NY,NZ LOGICAL LNoScaleFlag,LverboseFlag C .. C .. Arrays in Common .. REAL CellMtz INTEGER Iuvw C .. C .. Local Scalars .. REAL SUM INTEGER I,IEND,ISLAB,KM1,N1,N2,N3,NPAR,NPassOneSave,NPassTwoSave, + NRCSC,NSizePassOne,NSizePassTwo,NumCurrentRecord, + NumSkipRecords,NZVAL,R,RECS,REND C .. C .. Local Arrays .. INTEGER D(5) C .. C .. External Subroutines .. EXTERNAL ATSORT,CCPERR,CMPLFT,GENDEN,HEX,HINR3,HOUTR3,MWCLOSE, + QSEEK,R3PI,REALFT,REDMAP,SOUTFC,SOUTR3,WRITEMAP C .. C .. Common blocks .. COMMON /HKLLIM/ + Hmax,Kmax,Lmax,Hmin,Kmin,Lmin,Nslab COMMON /IOSF/ + IOscratch,IOgradmat,IOhessian,IOshifts, + IOatomop,IOmap,IOxyzin,IOxyzoutunq COMMON /MPHDR/ + NX,NY,NZ, + IXmin,IXmax,IYmin,IYmax,IZmin,IZmax, + Jsec,JU1,JU2,JV1,JV2,Iuvw(3), + NumSFspaceGroup,NumSections, + RHmin,RHmax,RHmean,NumSFsymm, + CellMtz(6),VolMtz,Volfft,F000 COMMON /SFOUT/ + Smin,Smax,TSmin,TSmax,SSbinSize, + LFpartFlag,LPhiPartFlag,LWghtModeFlag, + ScaleFcalc,ScaleFpart, + SigmaExclude,WangSphereRadi, + BfactOverall,BfactFpart, + NumMultiplicity,NLPRGO COMMON /SRFCTL1/ + LSFcalcFlag,LSFrefFlag, + LatomMapFlag,LxyzInputFlag, + LhklInputFlag,LMapInFlag, + LSolvMaskFlag,LXyzOutputFlag COMMON /TERSE/ + LverboseFlag,LNoScaleFlag C .. C C ********************** CALL QSEEK(IOscratch,1,1,1) C ********************** C KM1 = Kmax + 1 NZVAL = NZ/3 If(NumSFspaceGroup.eq.143) NZVAL = NZ NSizePassOne = Size/ ((NY+2)*NX) NPassOneSave = NSizePassOne NSizePassTwo = Size/ (2*NZVAL*KM1) IF (NSizePassTwo .GT. (Hmax-Hmin+1)) + NSizePassTwo = Hmax - Hmin + 1 NPassTwoSave = NSizePassTwo R = IZmin REND = IZmax C DO 10 I = 1,Size X(I) = 0.0 10 CONTINUE C NRCSC = 2*NSizePassOne*NSizePassTwo*KM1 C C---- sort atoms on 3rd coordinate - now z. C NumCurrentRecord = 0 IF (LxyzInputFlag.EQ.0) GO TO 20 C C ***************************** CALL ATSORT(NATST, + NATST2, + BB, + MB, + XB, + IA, + AtomicNumOccup, + IRESB, + SZA, + BfactOverall) CALL XYZREWD(IOxyzin) C ***************************** C NumCurrentRecord = 0 20 CONTINUE IF (R+NSizePassOne.GT.REND) NSizePassOne = REND - R + 1 N1 = NY + 2 N2 = NX N3 = NSizePassOne NPAR = 0 C C IF (LMapInFlag.EQ.1 .AND. LxyzInputFlag.EQ.0) THEN SUM = 0.0 CALL REDMAP(X,N1,N2,N3,R,SUM) GO TO 40 END IF C C ***************************** CALL GENDEN(X,N1,N2,N3,R,NPAR,SUM) C ***************************** C C---- density generated for NSizePassOne sections. now calculate C y and x transforms C C density generated for hexagons in NSizePassOne sections. C now extend density by threefold axis to fill whole section before C calculating y and x transforms. C C *************** CALL HEX(X,N1,N2,N3) C *************** C IF (LatomMapFlag.EQ.1) THEN C CALL WRITEMAP(IOmap,X,N1,N2,N3) C IF (LSFcalcFlag.EQ.0) GO TO 60 END IF C 40 IF (SUM.EQ.0.0) GO TO 50 D(1) = (NY+2)*NX*NSizePassOne D(2) = 2 D(3) = D(1) D(4) = D(1) D(5) = NY + 2 C C ************************* CALL REALFT(X(1),X(2),NY/2,D) C ************************* C D(2) = NY + 2 D(3) = (NY+2)*NX D(4) = KM1*2 D(5) = 2 C C ********************** CALL CMPLFT(X(1),X(2),NX,D) C ********************** C C---- modify output to allow for packingf 3 l layer C to use non-primitiveness C C *********************************** 50 CONTINUE If(NumSFspaceGroup.EQ.143) + CALL HOUTP3(X, + (NY+2)/2, + NX, + NSizePassOne, + Kmax, + NSizePassTwo, + R, + NZ, + IOscratch, + NumCurrentRecord, + NRCSC) If(NumSFspaceGroup.EQ.146) + CALL HOUTR3(X, + (NY+2)/2, + NX, + NSizePassOne, + Kmax, + NSizePassTwo, + R, + NZ, + IOscratch, + NumCurrentRecord, + NRCSC) C *********************************** C 60 CONTINUE R = R + NSizePassOne IF (R.LE.REND) GO TO 20 C IF (LatomMapFlag.EQ.1)THEN CALL MWCLOSE(IOmap) IF (LSFcalcFlag.EQ.0) THEN CALL CLOSEIT CALL CCPERR(0,' Normal Termination of fc map output') ENDIF END IF C C---- pass 2 reads intermediate results and calculates fourier C transforms on z/3. C NumSkipRecords = 0 NSizePassOne = NPassOneSave RECS = Hmax/NSizePassTwo R = Hmin IEND = 0 70 CONTINUE NumCurrentRecord = 1 IF (R+NSizePassTwo.GT.Hmax) + NSizePassTwo = Hmax + 1 - R C C ******************************* CALL HINR3(X, + NZVAL, + Kmax+1, + NSizePassTwo, + NSizePassOne, + NumSkipRecords, + RECS, + IOscratch, + NumCurrentRecord, + NRCSC) C ******************************* C NumSkipRecords = NumSkipRecords + 1 D(1) = 2*NZVAL*KM1*NSizePassTwo D(2) = 2 D(3) = D(1) D(4) = D(1) D(5) = 2*NZVAL C C ************************* CALL CMPLFT(X(1),X(2),NZVAL,D) C ************************* C C ********************** IF (LhklInputFlag.EQ.1 .AND. NumSFspaceGroup.EQ.143) + CALL SOUTZ (X, + NZVAL, + KM1, + NPassTwoSave, + NSizePassTwo, + R, + ISLAB, + LCYC, + IEND) IF (LhklInputFlag.EQ.1 .AND. NumSFspaceGroup.EQ.146) + CALL SOUTR3(X, + NZVAL, + KM1, + NPassTwoSave, + NSizePassTwo, + R, + ISLAB, + LCYC, + IEND) C ********************** C IF (LSFcalcFlag.EQ.1 .AND. LhklInputFlag.EQ.0) + CALL SOUTFC(X, + NZVAL, + KM1, + NPassTwoSave, + NSizePassTwo, + R, + ISLAB, + LCYC, + IEND) C R = R + NSizePassTwo IF (R.LE.Hmax .AND. IEND.EQ.0) GO TO 70 Nslab = ISLAB WRITE (6,FMT=6000) Nslab 6000 FORMAT (' NUMBER OF SLABS =',I5,/) IF (LSFcalcFlag.EQ.1 .AND. LhklInputFlag.EQ.0) RETURN C C---- calculate weighted differences C C ************** CALL R3PI(PII,LCYC) C ************** C END C C ========================================================= SUBROUTINE SFCTL152(X,PHI,Size,LCYC,PII,NATST,NATST2, + BB,MB,XB,IA,AtomicNumOccup,IRESB,SZA) C ========================================================= C C .. Scalar Arguments .. REAL PII,SZA INTEGER LCYC,NATST,NATST2,Size C .. C .. Array Arguments .. REAL ATOMICNUMOCCUP(NATST),BB(NATST),PHI(Size/2),X(Size), + XB(2,NATST) INTEGER IA(NATST2),IRESB(NATST),MB(NATST) C .. C .. Scalars in Common .. REAL BfactFpart,BfactOverall,RHmax,RHmean,RHmin,ScaleFcalc, + ScaleFpart,SigmaExclude,Smax,Smin,SSbinSize,TSmax,TSmin, + VolMtz,WangSphereRadi INTEGER Hmax,HmaxA,Hmin,HminA,IBLKNO,IOatomop,IOgradmat,IOhessian, + IOmap,IOscratch,IOshifts,IOxyzin,IOxyzoutunq, + IXmax,IXmin,IYmax,IYmin,IZmax,IZmin,Jsec,JU1,JU2,JV1,JV2, + KHmin,Kmax,Kmin,LatomMapFlag,LFpartFlag,LSFrefFlag, + LhklInputFlag,LMapInFlag,Lmax,Lmin,LPhiPartFlag, + LSFcalcFlag,LSolvMaskFlag,LWghtModeFlag,LxyzInputFlag, + LXyzOutputFlag,NLPRGO,Nslab,NumMultiplicity,NumSections, + NumSFspaceGroup,NumSFsymm,NX,NY,NZ LOGICAL LNoScaleFlag,LverboseFlag C .. C .. Arrays in Common .. REAL CellMtz INTEGER Iuvw C .. C .. Local Scalars .. REAL SUM INTEGER I,IEND,IHKA,ISLAB,Kmax1,N1,N2,N3,NHLAY,NPAR,NPassTwoSave, + NSizePassOne,NSizePassTwo,NumCurrentRecord,NX1,NY21,NYP2, + NZBY2,R,REND C .. C .. Local Arrays .. INTEGER D(5) C .. C .. External Subroutines .. EXTERNAL ATSORT,CCPERR,CMPLFT,GENDEN,IN152,MWCLOSE,QSEEK,R3PI, + REALFT,REDMAP,SOUTFC,SOUTN22,WRITEMAP,WRITEZ,XYZREWD C .. C .. Intrinsic Functions .. INTRINSIC INT,SQRT C .. C .. Common blocks .. COMMON /BLKNUM/ + IBLKNO COMMON /HKLLIM/ + Hmax,Kmax,Lmax,Hmin,Kmin,Lmin,Nslab COMMON /IOSF/ + IOscratch,IOgradmat,IOhessian,IOshifts, + IOatomop,IOmap,IOxyzin,IOxyzoutunq COMMON /MPHDR/ + NX,NY,NZ, + IXmin,IXmax,IYmin,IYmax,IZmin,IZmax, + Jsec,JU1,JU2,JV1,JV2,Iuvw(3), + NumSFspaceGroup,NumSections, + RHmin,RHmax,RHmean,NumSFsymm, + CellMtz(6),VolMtz,Volfft,F000 COMMON /P41212/ + HminA,HmaxA,KHmin COMMON /SFOUT/ + Smin,Smax,TSmin,TSmax,SSbinSize, + LFpartFlag,LPhiPartFlag,LWghtModeFlag, + ScaleFcalc,ScaleFpart, + SigmaExclude,WangSphereRadi, + BfactOverall,BfactFpart, + NumMultiplicity,NLPRGO COMMON /SRFCTL1/ + LSFcalcFlag,LSFrefFlag, + LatomMapFlag,LxyzInputFlag, + LhklInputFlag,LMapInFlag, + LSolvMaskFlag,LXyzOutputFlag COMMON /TERSE/ + LverboseFlag,LNoScaleFlag C .. C IBLKNO = 0 NYP2 = NY + 2 NZBY2 = NZ*2 NSizePassOne = Size/ (NX*NYP2) NSizePassTwo = Size/NZBY2 NPassTwoSave = NSizePassTwo R = IZmin REND = IZmax C C ********************** CALL QSEEK(IOscratch,1,1,1) C ********************** C DO 10 I = 1,Size X(I) = 0.0 10 CONTINUE C NumCurrentRecord = 0 IF (LxyzInputFlag.EQ.0) GO TO 20 C C---- sort atoms in order of z coordinates C and calculate density contributed from zsf to zff C C ********************************** CALL ATSORT(NATST, + NATST2, + BB, + MB, + XB, + IA, + AtomicNumOccup, + IRESB, + SZA, + BfactOverall) CALL XYZREWD(IOxyzin) C ********************************** C NumCurrentRecord = 0 20 CONTINUE IF (R+NSizePassOne.GT.REND) NSizePassOne = REND - R + 1 N1 = NY + 2 N2 = NX N3 = NSizePassOne IF (LverboseFlag) WRITE (6,FMT=6000) + N1,N2,N3,R,NumSFspaceGroup 6000 FORMAT (' GENCTL N1 N2 N3 R NumSFspaceGroup ',5I5) NPAR = 0 C C---- read previously obtained density map . C C IF (LMapInFlag.EQ.1 .AND. LxyzInputFlag.EQ.0) THEN SUM = 0.0 CALL REDMAP(X,N1,N2,N3,R,SUM) GO TO 40 END IF C C ***************************** CALL GENDEN(X,N1,N2,N3,R,NPAR,SUM) C ***************************** C IF (LatomMapFlag.EQ.0) GO TO 40 C CALL WRITEMAP(IOmap,X,N1,N2,N3) C IF (LSFcalcFlag.EQ.0) GO TO 60 C C---- density generated for NSizePassOne sections. now calculate C y and x transforms C 40 CONTINUE NY21 = NY/2 + 1 Kmax1 = Kmax + 1 IF (SUM.EQ.0.0) GO TO 50 C C---- replace with p31 summation limits - will this find error?? C D(1) = (NY+2)*NX*NSizePassOne D(2) = 2 D(3) = (NY+2)*NX D(4) = (NY+2)*NX D(5) = NY + 2 C C ************************ CALL REALFT(X(1),X(2),NY/2,D) C ************************ C D(1) = D(1) D(2) = NY + 2 D(3) = D(3) D(4) = (Kmax+1)*2 D(5) = 2 C C ********************** CALL CMPLFT(X(1),X(2),NX,D) C ********************** C C ****************************** 50 CALL WRITEZ(X, + NY21, + NX, + NSizePassOne, + Kmax1, + IOscratch, + NumCurrentRecord) C ****************************** C 60 R = R + NSizePassOne IF (R.LE.REND) GO TO 20 C IF (LatomMapFlag.EQ.1)THEN CALL MWCLOSE(IOmap) IF (LSFcalcFlag.EQ.0) THEN CALL CLOSEIT CALL CCPERR(0,' Normal Termination of fc map output') ENDIF END IF C C---- complex transform(k,h,nz8) is now all calculatec C read sections back in to set up arrays x(nz21,ihka) C IEND = 0 KHmin = 0 HminA = 0 70 CONTINUE C C---- want (Hmaxa+1)*(Hmaxa+2)/2 .le. NSizePassTwo+kHmin C HmaxA = INT(SQRT(9.0- (1-NSizePassTwo-KHmin)*8.0) + + (-3.0))/2 IF (HmaxA.GT.Hmax) HmaxA = Hmax IHKA = (HmaxA+1)* (HmaxA+2)/2 - KHmin IHKA = ((IHKA+1)/2)*2 NX1 = NX + 1 C C ****************************** CALL IN152(X, + NZ, + IHKA, + PHI, + Kmax1, + NX1, + IOscratch, + NumSFspaceGroup) C ****************************** C D(1) = 2*NZ*IHKA D(2) = 2 D(3) = D(1) D(4) = D(1) D(5) = 2*NZ C C ********************** CALL CMPLFT(X(1),X(2),NZ,D) C ********************** C C *********************** IF (LhklInputFlag.EQ.1) CALL SOUTN22(X, + NZ, + NPassTwoSave, + 1, + IHKA, + ISLAB, + LCYC, + IEND) C *********************** C NHLAY = HmaxA - HminA + 1 IF (LSFcalcFlag.EQ.1 .AND. LhklInputFlag.EQ.0) + CALL SOUTFC(X, + NZ, + NPassTwoSave, + 1, + NHLAY, + HminA, + ISLAB, + LCYC, + IEND) HminA = HmaxA + 1 KHmin = (HmaxA+1)* (HmaxA+2)/2 IF (HminA.LE.Hmax .AND. IEND.EQ.0) GO TO 70 C Nslab = ISLAB IF (LverboseFlag) WRITE (6,FMT=6002) Nslab 6002 FORMAT (' Number of slabs =',I5,/) IF (LSFcalcFlag.EQ.1 .AND. LhklInputFlag.EQ.0) RETURN C C---- calculate weighted differences C C ************** CALL R3PI(PII,LCYC) C ************** C END C C ======================================================== SUBROUTINE SFCTL169(X,PHI,Size,LCYC,PII,NATST,NATST2,BB, + MB,XB,IA,AtomicNumOccup,IRESB,SZA) C ======================================================== C C---- Test array Size,index limits etc. for space group p31/p32 C C .. Scalar Arguments .. REAL PII,SZA INTEGER LCYC,NATST,NATST2,Size C .. C .. Array Arguments .. REAL ATOMICNUMOCCUP(NATST),BB(NATST),PHI(Size/2),X(Size), + XB(2,NATST) INTEGER IA(NATST2),IRESB(NATST),MB(NATST) C .. C .. Scalars in Common .. REAL BfactFpart,BfactOverall,RHmax,RHmean,RHmin,ScaleFcalc, + ScaleFpart,SigmaExclude,Smax,Smin,SSbinSize,TSmax,TSmin, + VolMtz,WangSphereRadi INTEGER Hmax,Hmin,IOatomop,IOgradmat,IOhessian,IOmap,IOscratch, + IOshifts,IOxyzin,IOxyzoutunq,IXmax,IXmin,IYmax, + IYmin,IZmax,IZmin,Jsec,JU1,JU2,JV1,JV2,Kmax,Kmin, + LatomMapFlag,LFpartFlag,LSFrefFlag,LhklInputFlag, + LMapInFlag,Lmax,Lmin,LPhiPartFlag,LSFcalcFlag, + LSolvMaskFlag,LWghtModeFlag,LxyzInputFlag,LXyzOutputFlag, + NLPRGO,Nslab,NumMultiplicity,NumSections,NumSFspaceGroup, + NumSFsymm,NX,NY,NZ LOGICAL LNoScaleFlag,LverboseFlag C .. C .. Arrays in Common .. REAL CellMtz INTEGER Iuvw C .. C .. Local Scalars .. REAL SUM INTEGER I,ICHK,IEND,ISLAB,KM1,N1,N2,N3,NPAR,NPassOneSave, + NPassTwoSave,NSizePassOne,NSizePassTwo,NumCurrentRecord,R, + REND C .. C .. Local Arrays .. INTEGER D(5) C .. C .. External Subroutines .. EXTERNAL ATSORT,CCPERR,CMPLFT,GENDEN,IN169,INV21,INV21SC,MWCLOSE, + QSEEK,R3PI,REALFT,REDMAP,SOUTFC,SOUTZ,WRITEMAP,WRITEZ, + XYZREWD C .. C .. Common blocks .. COMMON /HKLLIM/ + Hmax,Kmax,Lmax,Hmin,Kmin,Lmin,Nslab COMMON /IOSF/ + IOscratch,IOgradmat,IOhessian,IOshifts, + IOatomop,IOmap,IOxyzin,IOxyzoutunq COMMON /MPHDR/ + NX,NY,NZ, + IXmin,IXmax,IYmin,IYmax,IZmin,IZmax, + Jsec,JU1,JU2,JV1,JV2,Iuvw(3), + NumSFspaceGroup,NumSections, + RHmin,RHmax,RHmean,NumSFsymm, + CellMtz(6),VolMtz,Volfft,F000 COMMON /SFOUT/ + Smin,Smax,TSmin,TSmax,SSbinSize, + LFpartFlag,LPhiPartFlag,LWghtModeFlag, + ScaleFcalc,ScaleFpart, + SigmaExclude,WangSphereRadi, + BfactOverall,BfactFpart, + NumMultiplicity,NLPRGO COMMON /SRFCTL1/ + LSFcalcFlag,LSFrefFlag, + LatomMapFlag,LxyzInputFlag, + LhklInputFlag,LMapInFlag, + LSolvMaskFlag,LXyzOutputFlag COMMON /TERSE/ + LverboseFlag,LNoScaleFlag C .. C C ********************** CALL QSEEK(IOscratch,1,1,1) C ********************** C KM1 = Kmax + 1 NSizePassOne = Size/ ((NY+2)*NX) NPassOneSave = NSizePassOne NSizePassTwo = Size/ ((NZ+2)*KM1) IF (NSizePassTwo .GT. (Hmax-Hmin+1)) + NSizePassTwo = Hmax - Hmin + 1 NPassTwoSave = NSizePassTwo R = IZmin REND = IZmax C DO 10 I = 1,Size X(I) = 0.0 10 CONTINUE C C---- sort atoms on 3rd coordinate - now z. C NumCurrentRecord = 0 IF (LxyzInputFlag.EQ.0) GO TO 20 C C ***************************** CALL ATSORT(NATST, + NATST2, + BB, + MB, + XB, + IA, + AtomicNumOccup, + IRESB, + SZA, + BfactOverall) CALL XYZREWD(IOxyzin) C ***************************** C NumCurrentRecord = 0 20 CONTINUE IF (R+NSizePassOne.GT.REND) NSizePassOne = REND - R + 1 N1 = NY + 2 N2 = NX N3 = NSizePassOne NPAR = 0 C C IF (LMapInFlag.EQ.1 .AND. LxyzInputFlag.EQ.0) THEN SUM = 0.0 CALL REDMAP(X,N1,N2,N3,R,SUM) GO TO 30 END IF C C ***************************** CALL GENDEN(X,N1,N2,N3,R,NPAR,SUM) C ***************************** C C---- density generated for NSizePassOne sections. now calculate C y and x transforms C 30 IF (SUM.EQ.0.0) GO TO 50 C C---- if LatomMapFlag.EQ.1 write out fc map C IF (LatomMapFlag.EQ.1) THEN CALL WRITEMAP(IOmap,X,N1,N2,N3) IF (LSFcalcFlag.EQ.0) GO TO 60 END IF C D(1) = (NY+2)*NX*NSizePassOne D(2) = 2 D(3) = D(1) D(4) = D(1) D(5) = NY + 2 C C ************************* CALL REALFT(X(1),X(2),NY/2,D) C ************************* C D(2) = NY + 2 D(3) = (NY+2)*NX D(4) = KM1*2 D(5) = 2 C C ****************************** CALL CMPLFT(X(1), + X(2), + NX, + D) 50 CALL WRITEZ(X, + (NY+2)/2, + NX, + NSizePassOne, + Kmax+1, + IOscratch, + NumCurrentRecord) C ****************************** C 60 CONTINUE C R = R + NSizePassOne IF (R.LE.REND) GO TO 20 C IF (LatomMapFlag.EQ.1)THEN CALL MWCLOSE(IOmap) IF (LSFcalcFlag.EQ.0) THEN CALL CLOSEIT CALL CCPERR(0,' Normal Termination of fc map output') ENDIF END IF C C---- pass 2 reads intermediate results and calculates fourier C transforms on z/6. C p61/p65 have 21 screw along (0,0,Z)C C complex transform for(+ - h,+k,nz/6-)calculated,now generate C (some h +k, z 0 TO 1/2) . use phi space for scratch C check 4*(nx+1)*(Kmax+1) le Size C ICHK = (NX+1)*4* (Kmax+1) IF (ICHK.GT.Size) CALL CCPERR(1, + ' DISASTER - SCRATCH AREA FOR IN144 TOO SMALL') NSizePassOne = NPassOneSave R = Hmin IEND = 0 70 CONTINUE NumCurrentRecord = 1 IF (R+NSizePassTwo.GT.Hmax) NSizePassTwo = Hmax + 1 - R C C ******************************* CALL IN169(X, + NZ/2+1, + Kmax+1, + NSizePassTwo, + R, + PHI, + KM1, + NX+1, + IOscratch, + NumSFspaceGroup) C ******************************* C D(1) = (NZ+2)*KM1*NSizePassTwo D(2) = 2 D(3) = D(1) D(4) = D(1) D(5) = NZ + 2 C C---- Correct for the scaling error C in INV21 by multiplying x array by 2. C C *************************** CALL INV21SC(X, + NZ/2+1, + Kmax+1, + NSizePassTwo) CALL INV21(X(1), + X(2), + NZ/2, + D) C *************************** C C ******************** IF (LhklInputFlag.EQ.1) CALL SOUTZ(X, + NZ/2+1, + KM1, + NPassTwoSave, + NSizePassTwo, + R, + ISLAB, + LCYC, + IEND) C ******************** C IF (LSFcalcFlag.EQ.1 .AND. LhklInputFlag.EQ.0) + CALL SOUTFC(X, + NZ/2+1, + KM1, + NPassTwoSave, + NSizePassTwo, + R, + ISLAB, + LCYC, + IEND) C R = R + NSizePassTwo IF (R.LE.Hmax .AND. IEND.EQ.0) GO TO 70 Nslab = ISLAB IF (LverboseFlag) WRITE (6,FMT=6004) Nslab 6004 FORMAT (' NUMBER OF SLABS =',I5,/) IF (LSFcalcFlag.EQ.1 .AND. LhklInputFlag.EQ.0) RETURN C C---- calculate weighted differences C C ************** CALL R3PI(PII,LCYC) C ************** C END C C ======================================================== SUBROUTINE SFCTL18(X,Size,LCYC,PII,NATST,NATST2,BB,MB,XB, + IA,AtomicNumOccup,IRESB,SZA) C ========================================================= C C .. Scalar Arguments .. REAL PII,SZA INTEGER LCYC,NATST,NATST2,Size C .. C .. Array Arguments .. REAL ATOMICNUMOCCUP(NATST),BB(NATST),X(Size),XB(2,NATST) INTEGER IA(NATST2),IRESB(NATST),MB(NATST) C .. C .. Scalars in Common .. REAL BfactFpart,BfactOverall,RHmax,RHmean,RHmin,ScaleFcalc, + ScaleFpart,SigmaExclude,Smax,Smin,SSbinSize,TSmax,TSmin, + VolMtz,WangSphereRadi INTEGER Hmax,Hmin,IOatomop,IOgradmat,IOhessian,IOmap,IOscratch, + IOshifts,IOxyzin,IOxyzoutunq,IXmax,IXmin,IYmax, + IYmin,IZmax,IZmin,Jsec,JU1,JU2,JV1,JV2,Kmax,Kmin, + LatomMapFlag,LFpartFlag,LSFrefFlag,LhklInputFlag, + LMapInFlag,Lmax,Lmin,LPhiPartFlag,LSFcalcFlag, + LSolvMaskFlag,LWghtModeFlag,LxyzInputFlag,LXyzOutputFlag, + NLPRGO,Nslab,NumMultiplicity,NumSections,NumSFspaceGroup, + NumSFsymm,NX,NY,NZ LOGICAL LNoScaleFlag,LverboseFlag C .. C .. Arrays in Common .. REAL CellMtz INTEGER Iuvw C .. C .. Local Scalars .. REAL SUM INTEGER I,IEND,ISLAB,LM1,N1,N2,N3,NPAR,NPassTwoSave,NRCSC, + NSizePassOne,NSizePassTwo,NumCurrentRecord,NumSkipRecords, + R,RECS,REND C .. C .. Local Arrays .. INTEGER D(5) C .. C .. External Subroutines .. EXTERNAL ATSORT,CCPERR,CMPLFT,GENDEN,HOUT2,INV21,INV21SC,MWCLOSE, + QSEEK,R3PI,READH3,REALFT,REDMAP,SOUTFC,SOUTY,TRANS1, + WRITEMAP,XYZREWD C .. C .. Common blocks .. COMMON /HKLLIM/ + Hmax,Kmax,Lmax,Hmin,Kmin,Lmin,Nslab COMMON /IOSF/ + IOscratch,IOgradmat,IOhessian,IOshifts, + IOatomop,IOmap,IOxyzin,IOxyzoutunq COMMON /MPHDR/ + NX,NY,NZ, + IXmin,IXmax,IYmin,IYmax,IZmin,IZmax, + Jsec,JU1,JU2,JV1,JV2,Iuvw(3), + NumSFspaceGroup,NumSections, + RHmin,RHmax,RHmean,NumSFsymm, + CellMtz(6),VolMtz,Volfft,F000 COMMON /SFOUT/ + Smin,Smax,TSmin,TSmax,SSbinSize, + LFpartFlag,LPhiPartFlag,LWghtModeFlag, + ScaleFcalc,ScaleFpart, + SigmaExclude,WangSphereRadi, + BfactOverall,BfactFpart, + NumMultiplicity,NLPRGO COMMON /SRFCTL1/ + LSFcalcFlag,LSFrefFlag, + LatomMapFlag,LxyzInputFlag, + LhklInputFlag,LMapInFlag, + LSolvMaskFlag,LXyzOutputFlag COMMON /TERSE/ + LverboseFlag,LNoScaleFlag C .. C LM1 = Lmax + 1 NSizePassOne = Size/ ((NZ+2)*NX) NSizePassTwo = Size/ ((NY+2)*LM1) NPassTwoSave = NSizePassTwo R = IYmin REND = IYmax C DO 10 I = 1,Size X(I) = 0.0 10 CONTINUE C C ********************** CALL QSEEK(IOscratch,1,1,1) C ********************** C NRCSC = 2*NSizePassOne*NSizePassTwo*LM1 NumCurrentRecord = 0 IF (LxyzInputFlag.EQ.0) GO TO 20 C C---- sort atoms on 3rd coordinate - now y. C ***************************** CALL ATSORT(NATST, + NATST2, + BB, + MB, + XB, + IA, + AtomicNumOccup, + IRESB, + SZA, + BfactOverall) CALL XYZREWD(IOxyzin) C ***************************** C NumCurrentRecord = 0 20 CONTINUE IF (R+NSizePassOne.GT.REND) NSizePassOne = REND - R + 1 N1 = NZ + 2 N2 = NX N3 = NSizePassOne NPAR = 0 C C---- read previously obtained density map . C IF (LMapInFlag.EQ.1 .AND. LxyzInputFlag.EQ.0) THEN SUM = 0.0 CALL REDMAP(X,N1,N2,N3,R,SUM) GO TO 40 END IF C C ***************************** CALL GENDEN(X,N1,N2,N3,R,NPAR,SUM) C ***************************** C IF (LatomMapFlag.EQ.0) GO TO 40 C C---- check density map C CALL WRITEMAP(IOmap,X,N1,N2,N3) IF (LSFcalcFlag.EQ.0) GO TO 60 C C---- density generated for NSizePassOne sections. C now calculate y and x transforms. C C density generated for NSizePassOne sections. C now calculate z and x transforms. C 40 IF (SUM.EQ.0.0) GO TO 50 D(1) = (NZ+2)*NX*NSizePassOne D(2) = 2 D(3) = D(1) D(4) = D(1) D(5) = NZ + 2 C C ************************* CALL REALFT(X(1),X(2),NZ/2,D) C ************************* C D(2) = NZ + 2 D(3) = (NZ+2)*NX D(4) = LM1*2 D(5) = 2 C C ****************************** CALL CMPLFT(X(1), + X(2), + NX, + D) 50 CALL HOUT2(X, + (NZ+2)/2, + NX, + NSizePassOne, + Lmax, + Hmax, + NSizePassTwo, + IOscratch, + NumCurrentRecord, + NRCSC) CALL TRANS1(X, + (NZ+2)/2, + NX, + NSizePassOne, + Lmax, + Hmax) CALL HOUT2(X, + (NZ+2)/2, + NX, + NSizePassOne, + Lmax, + Hmax, + NSizePassTwo, + IOscratch, + NumCurrentRecord, + NRCSC) C ****************************** C 60 R = R + NSizePassOne IF (R.LE.REND) GO TO 20 C IF (LatomMapFlag.EQ.1)THEN CALL MWCLOSE(IOmap) IF (LSFcalcFlag.EQ.0) THEN CALL CLOSEIT CALL CCPERR(0,' Normal Termination of fc map output') ENDIF END IF C C---- pass 2 reads intermediate results and calculates fourier C transforms on y. C NumSkipRecords = 0 NSizePassOne = Size/ ((NZ+2)*NX) RECS = Hmax/NSizePassTwo R = Hmin IEND = 0 70 CONTINUE NumCurrentRecord = 1 IF (R+NSizePassTwo.GT.Hmax) NSizePassTwo = Hmax + 1 - R C C ********************************* CALL READH3(X, + NY/2+1, + LM1, + NSizePassTwo, + NY/4+1, + NSizePassOne, + NumSkipRecords, + RECS, + IOscratch, + NumCurrentRecord, + NRCSC) C ********************************* C NumSkipRecords = NumSkipRecords + 1 D(1) = (NY+2)*LM1*NSizePassTwo D(2) = 2 D(3) = D(1) D(4) = D(1) D(5) = NY + 2 C C ********************************** CALL INV21SC(X,NY/2+1,LM1,NSizePassTwo) CALL INV21(X(1),X(2),NY/2,D) C ********************************** C C---- go to read fobs file etc. C C ******************** IF (LhklInputFlag.EQ.1) CALL SOUTY(X, + NY/2+1, + LM1, + NPassTwoSave, + NSizePassTwo, + R, + ISLAB, + LCYC, + IEND) C ******************** C IF (LSFcalcFlag.EQ.1 .AND. LhklInputFlag.EQ.0) + CALL SOUTFC(X, + NY/2+1, + LM1, + NPassTwoSave, + NSizePassTwo, + R, + ISLAB, + LCYC, + IEND) C R = R + NSizePassTwo IF (R.LE.Hmax .AND. IEND.EQ.0) GO TO 70 C C---- calculate r factors C Nslab = ISLAB IF (LverboseFlag) WRITE (6,FMT=6000) Nslab 6000 FORMAT (' NUMBER OF SLABS =',I5,/) IF (LSFcalcFlag.EQ.1 .AND. LhklInputFlag.EQ.0) RETURN C C---- calculate weighted differences C C ************** CALL R3PI(PII,LCYC) C ************** C END C C ===================================================== SUBROUTINE SFCTL19(X,Size,LCYC,PII,NATST,NATST2,BB,MB, + XB,IA,AtomicNumOccup,IRESB,SZA) C ====================================================== C C .. Scalar Arguments .. REAL PII,SZA INTEGER LCYC,NATST,NATST2,Size C .. C .. Array Arguments .. REAL ATOMICNUMOCCUP(NATST),BB(NATST),X(Size),XB(2,NATST) INTEGER IA(NATST2),IRESB(NATST),MB(NATST) C .. C .. Scalars in Common .. REAL BfactFpart,BfactOverall,RHmax,RHmean,RHmin,ScaleFcalc, + ScaleFpart,SigmaExclude,Smax,Smin,SSbinSize,TSmax,TSmin, + VolMtz,WangSphereRadi INTEGER Hmax,Hmin,IOatomop,IOgradmat,IOhessian,IOmap,IOscratch, + IOshifts,IOxyzin,IOxyzoutunq,IXmax,IXmin,IYmax, + IYmin,IZmax,IZmin,Jsec,JU1,JU2,JV1,JV2,Kmax,Kmin, + LatomMapFlag,LFpartFlag,LSFrefFlag,LhklInputFlag, + LMapInFlag,Lmax,Lmin,LPhiPartFlag,LSFcalcFlag, + LSolvMaskFlag,LWghtModeFlag,LxyzInputFlag,LXyzOutputFlag, + NLPRGO,Nslab,NumMultiplicity,NumSections,NumSFspaceGroup, + NumSFsymm,NX,NY,NZ LOGICAL LNoScaleFlag,LverboseFlag C .. C .. Arrays in Common .. REAL CellMtz INTEGER Iuvw C .. C .. Local Scalars .. REAL SUM INTEGER I,IEND,ISLAB,KM1,N1,N2,N3,NPAR,NPassTwoSave,NRCSC, + NSizePassOne,NSizePassTwo,NumCurrentRecord,NumSkipRecords, + NYP2,NZ21,NZP2,R,RECS,REND C .. C .. Local Arrays .. INTEGER D(5) C .. C .. External Subroutines .. EXTERNAL ATSORT,CCPERR,CMPLFT,GENDEN,INV21,INV21SC,MULTFS,MWCLOSE, + QSEEK,R3PI,READTL,REALFT,REDMAP,SOUTFC,SOUTZ,WRINT, + WRITEMAP,XYZREWD C .. C .. Common blocks .. COMMON /HKLLIM/ + Hmax,Kmax,Lmax,Hmin,Kmin,Lmin,Nslab COMMON /IOSF/ + IOscratch,IOgradmat,IOhessian,IOshifts, + IOatomop,IOmap,IOxyzin,IOxyzoutunq COMMON /MPHDR/ + NX,NY,NZ, + IXmin,IXmax,IYmin,IYmax,IZmin,IZmax, + Jsec,JU1,JU2,JV1,JV2,Iuvw(3), + NumSFspaceGroup,NumSections, + RHmin,RHmax,RHmean,NumSFsymm, + CellMtz(6),VolMtz,Volfft,F000 COMMON /SFOUT/ + Smin,Smax,TSmin,TSmax,SSbinSize, + LFpartFlag,LPhiPartFlag,LWghtModeFlag, + ScaleFcalc,ScaleFpart, + SigmaExclude,WangSphereRadi, + BfactOverall,BfactFpart, + NumMultiplicity,NLPRGO COMMON /SRFCTL1/ + LSFcalcFlag,LSFrefFlag, + LatomMapFlag,LxyzInputFlag, + LhklInputFlag,LMapInFlag, + LSolvMaskFlag,LXyzOutputFlag COMMON /TERSE/ + LverboseFlag,LNoScaleFlag C .. C NYP2 = NY + 2 NZP2 = NZ + 2 NZ21 = NZ/2 + 1 KM1 = Kmax + 1 NSizePassOne = Size/ ((NY+2)*NX) NSizePassTwo = Size/ ((NZ+2)*KM1) IF (NSizePassTwo .GT. (Hmax-Hmin+1)) + NSizePassTwo = Hmax - Hmin + 1 NPassTwoSave = NSizePassTwo R = IZmin REND = IZmax C DO 10 I = 1,Size X(I) = 0.0 10 CONTINUE C C ********************** CALL QSEEK(IOscratch,1,1,1) C ********************** C NRCSC = 2*NSizePassOne*NSizePassTwo*KM1 NumCurrentRecord = 0 IF (LxyzInputFlag.EQ.0) GO TO 20 C C---- sort atoms on 3rd coordinate - now y. C ***************************** CALL ATSORT(NATST, + NATST2, + BB, + MB, + XB, + IA, + AtomicNumOccup, + IRESB, + SZA, + BfactOverall) CALL XYZREWD(IOxyzin) C ***************************** C NumCurrentRecord = 0 20 CONTINUE IF (R+NSizePassOne.GT.REND) NSizePassOne = REND - R + 1 N1 = NY + 2 N2 = NX N3 = NSizePassOne NPAR = 0 C C---- Read previously obtained density map . C IF (LMapInFlag.EQ.1 .AND. LxyzInputFlag.EQ.0) THEN SUM = 0.0 CALL REDMAP(X,N1,N2,N3,R,SUM) GO TO 40 END IF C C ****************************** CALL GENDEN(X, N1,N2,N3,R,NPAR,SUM) C ****************************** C IF (LatomMapFlag.EQ.0) GO TO 40 C C---- check density map C CALL WRITEMAP(IOmap,X,N1,N2,N3) IF (LSFcalcFlag.EQ.0) GO TO 60 C C---- density generated for NSizePassOne sections. C now calculate y and x transforms. C 40 IF (SUM.EQ.0.0) GO TO 50 D(1) = NYP2*NX*NSizePassOne D(2) = 2 D(3) = D(1) D(4) = D(1) D(5) = NYP2 C C ************************ CALL REALFT(X(1),X(2),NY/2,D) C ************************ C D(2) = NYP2 D(3) = NYP2*NX D(4) = 2*Kmax + 2 D(5) = 2 C C ********************** CALL CMPLFT(X(1),X(2),NX,D) C ********************** C C---- write intermediate results then go back to C calculate next NSizePassOne sections C C ******************************* 50 CALL WRINT(X, + NY/2+1, + NX, + NSizePassOne, + Kmax, + Hmax, + NSizePassTwo, + IOscratch, + NumCurrentRecord, + NRCSC) C ******************************* C 60 R = R + NSizePassOne IF (R.LE.REND) GO TO 20 C IF (LatomMapFlag.EQ.1)THEN CALL MWCLOSE(IOmap) IF (LSFcalcFlag.EQ.0) THEN CALL CLOSEIT CALL CCPERR(0,' Normal Termination of fc map output') ENDIF END IF C NSizePassOne = Size/ (NX*NYP2) RECS = Hmax/NSizePassTwo NumSkipRecords = 0 R = 0 IEND = 0 70 CONTINUE NumCurrentRecord = 1 IF (R+NSizePassTwo.GT.Hmax) NSizePassTwo = Hmax + 1 - R C C---- read intermediate results for NSizePassTwo sections on h C then do z transform C C ********************************* CALL READTL(X, + NZ21, + KM1, + NSizePassTwo, + NSizePassOne, + NumSkipRecords, + RECS, + IOscratch, + 2*(R/2).EQ.R, + NumCurrentRecord, + NRCSC) C ********************************* C NumSkipRecords = NumSkipRecords + 1 D(1) = NZP2*KM1*NSizePassTwo D(2) = 2 D(3) = D(1) D(4) = D(1) D(5) = NZP2 C C ************************************** CALL INV21SC(X,NZ21,KM1,NSizePassTwo) CALL INV21(X(1),X(2),NZ/2,D) CALL MULTFS(X,NZ21,KM1,NSizePassTwo,Lmax,R) C ************************************** C C---- go to read fobs file etc. C C ***************** IF (LhklInputFlag.EQ.1) CALL SOUTZ(X, + NZ21, + KM1, + NPassTwoSave, + NSizePassTwo, + R, + ISLAB, + LCYC, + IEND) C ***************** C IF (LSFcalcFlag.EQ.1 .AND. LhklInputFlag.EQ.0) + CALL SOUTFC(X, + NZ21, + KM1, + NPassTwoSave, + NSizePassTwo, + R, + ISLAB, + LCYC, + IEND) C R = R + NSizePassTwo IF (R.LE.Hmax .AND. IEND.EQ.0) GO TO 70 Nslab = ISLAB IF (LverboseFlag) WRITE (6,FMT=6000) Nslab 6000 FORMAT (' NUMBER OF SLABS =',I5,/) IF (LSFcalcFlag.EQ.1 .AND. LhklInputFlag.EQ.0) RETURN C C---- calculate weighted differences C C ************** CALL R3PI(PII,LCYC) C ************** C END C C ===================================================== SUBROUTINE SFCTL4(X,Size,LCYC,PII,NATST,NATST2,BB,MB, + XB,IA,AtomicNumOccup,IRESB,SZA) C ===================================================== C C .. Scalar Arguments .. REAL PII,SZA INTEGER LCYC,NATST,NATST2,Size C .. C .. Array Arguments .. REAL ATOMICNUMOCCUP(NATST),BB(NATST),X(Size),XB(2,NATST) INTEGER IA(NATST2),IRESB(NATST),MB(NATST) C .. C .. Scalars in Common .. REAL BfactFpart,BfactOverall,RHmax,RHmean,RHmin,ScaleFcalc, + ScaleFpart,SigmaExclude,Smax,Smin,SSbinSize,TSmax,TSmin, + VolMtz,WangSphereRadi INTEGER Hmax,Hmin,IOatomop,IOgradmat,IOhessian,IOmap,IOscratch, + IOshifts,IXmax,IXmin,IYmax, + IYmin,IZmax,IZmin,Jsec,JU1,JU2,JV1,JV2,Kmax,Kmin, + LatomMapFlag,LFpartFlag,LSFrefFlag,LhklInputFlag, + LMapInFlag,Lmax,Lmin,LPhiPartFlag,LSFcalcFlag, + LSolvMaskFlag,LWghtModeFlag,LxyzInputFlag,LXyzOutputFlag, + NLPRGO,Nslab,NumMultiplicity,NumSections,NumSFspaceGroup, + NumSFsymm,NX,NY,NZ LOGICAL LNoScaleFlag,LverboseFlag C .. C .. Arrays in Common .. REAL CellMtz INTEGER Iuvw C .. C .. Local Scalars .. REAL SUM INTEGER I,IEND,ISLAB,LM1,N1,N2,N3,NPAR,NPassOneSave,NPassTwoSave, + NRCSC,NSizePassOne,NSizePassTwo,NumCurrentRecord, + NumSkipRecords,R,RECS,REND C .. C .. Local Arrays .. INTEGER D(5) C .. C .. External Subroutines .. EXTERNAL ATSORT,CCPERR,CMPLFT,GENDEN,HOUT1,INV21,INV21SC,MWCLOSE, + QSEEK,R3PI,READH2,REALFT,REDMAP,SOUTFC,SOUTY,WRITEMAP C .. C .. Common blocks .. COMMON /HKLLIM/ + Hmax,Kmax,Lmax,Hmin,Kmin,Lmin,Nslab COMMON /IOSF/ + IOscratch,IOgradmat,IOhessian,IOshifts, + IOatomop,IOmap,IOxyzin,IOxyzoutunq COMMON /MPHDR/ + NX,NY,NZ, + IXmin,IXmax,IYmin,IYmax,IZmin,IZmax, + Jsec,JU1,JU2,JV1,JV2,Iuvw(3), + NumSFspaceGroup,NumSections, + RHmin,RHmax,RHmean,NumSFsymm, + CellMtz(6),VolMtz,Volfft,F000 COMMON /SFOUT/ + Smin,Smax,TSmin,TSmax,SSbinSize, + LFpartFlag,LPhiPartFlag,LWghtModeFlag, + ScaleFcalc,ScaleFpart, + SigmaExclude,WangSphereRadi, + BfactOverall,BfactFpart, + NumMultiplicity,NLPRGO COMMON /SRFCTL1/ + LSFcalcFlag,LSFrefFlag, + LatomMapFlag,LxyzInputFlag, + LhklInputFlag,LMapInFlag, + LSolvMaskFlag,LXyzOutputFlag COMMON /TERSE/ + LverboseFlag,LNoScaleFlag C .. C LM1 = Lmax + 1 NSizePassOne = Size/ ((NZ+2)*NX) NPassOneSave = NSizePassOne NSizePassTwo = Size/ ((NY+2)*LM1) IF (NSizePassTwo.GT. (Hmax-Hmin+1)) + NSizePassTwo = Hmax - Hmin + 1 NPassTwoSave = NSizePassTwo R = IYmin REND = IYmax C DO 10 I = 1,Size X(I) = 0.0 10 CONTINUE C C ********************** CALL QSEEK(IOscratch,1,1,1) C ********************** C NRCSC = 2*NSizePassOne*NSizePassTwo*LM1 NumCurrentRecord = 0 IF (LxyzInputFlag.EQ.0) GO TO 20 C C---- sort atoms on 3rd coordinate - now y. C ***************************** CALL ATSORT(NATST, + NATST2, + BB, + MB, + XB, + IA, + AtomicNumOccup, + IRESB, + SZA, + BfactOverall) CALL XYZREWD(IOxyzin) C ***************************** C NumCurrentRecord = 0 20 CONTINUE IF (R+NSizePassOne.GT.REND) NSizePassOne = REND - R + 1 N1 = NZ + 2 N2 = NX N3 = NSizePassOne NPAR = 0 C C---- read previously obtained density map . C IF (LMapInFlag.EQ.1 .AND. LxyzInputFlag.EQ.0) THEN SUM = 0.0 CALL REDMAP(X,N1,N2,N3,R,SUM) GO TO 40 END IF C C ***************************** CALL GENDEN(X,N1,N2,N3,R,NPAR,SUM) C ***************************** C IF (LatomMapFlag.EQ.0) GO TO 40 C C---- Check density map C CALL WRITEMAP(IOmap,X,N1,N2,N3) IF (LSFcalcFlag.EQ.0) GO TO 60 C C---- density generated for NSizePassOne sections. C now calculate z and x transforms. C 40 IF (SUM.EQ.0.0) GO TO 50 D(1) = (NZ+2)*NX*NSizePassOne D(2) = 2 D(3) = D(1) D(4) = D(1) D(5) = NZ + 2 C C ************************* CALL REALFT(X(1),X(2),NZ/2,D) C ************************* C D(2) = NZ + 2 D(3) = (NZ+2)*NX D(4) = (LM1)*2 D(5) = 2 C C ******************************* CALL CMPLFT(X(1), + X(2), + NX, + D) 50 CALL HOUT1(X, + (NZ+2)/2, + NX, + NSizePassOne, + Lmax, + Hmax, + NSizePassTwo, + IOscratch, + NumCurrentRecord, + NRCSC) C ******************************* C 60 R = R + NSizePassOne IF (R.LE.REND) GO TO 20 C IF (LatomMapFlag.EQ.1)THEN CALL MWCLOSE(IOmap) IF (LSFcalcFlag.EQ.0) THEN CALL CLOSEIT CALL CCPERR(0,' Normal Termination of fc map output') ENDIF END IF C C---- pass 2 reads intermediate results and calculates fourier C transforms on y. C NSizePassOne = NPassOneSave NumSkipRecords = 0 RECS = (2*Hmax)/NSizePassTwo R = Hmin IEND = 0 70 CONTINUE NumCurrentRecord = 1 IF (R+NSizePassTwo.GT.Hmax) NSizePassTwo = Hmax + 1 - R C C ********************************* CALL READH2(X, + NY/2+1, + Lmax+1, + NSizePassTwo, + NY/2, + NSizePassOne, + NumSkipRecords, + RECS, + IOscratch, + NumCurrentRecord, + NRCSC) C ********************************* C NumSkipRecords = NumSkipRecords + 1 D(1) = (NY+2)*LM1*NSizePassTwo D(2) = 2 D(3) = D(1) D(4) = D(1) D(5) = NY + 2 C C ************************************* CALL INV21SC(X,NY/2+1,Lmax+1,NSizePassTwo) CALL INV21(X(1),X(2),NY/2,D) C ************************************* C C ***************** IF (LhklInputFlag.EQ.1) CALL SOUTY(X, + NY/2+1, + LM1, + NPassTwoSave, + NSizePassTwo, + R, + ISLAB, + LCYC, + IEND) C ***************** C IF (LSFcalcFlag.EQ.1 .AND. LhklInputFlag.EQ.0) + CALL SOUTFC(X, + NY/2+1, + LM1, + NPassTwoSave, + NSizePassTwo, + R, + ISLAB, + LCYC, + IEND) C R = R + NSizePassTwo IF (R.LE.Hmax .AND. IEND.EQ.0) GO TO 70 C Nslab = ISLAB IF (LverboseFlag) WRITE (6,FMT=6000) Nslab 6000 FORMAT (' NUMBER OF SLABS =',I5,/) IF (LSFcalcFlag.EQ.1 .AND. LhklInputFlag.EQ.0) RETURN C C---- calculate weighted differences C CALL R3PI(PII,LCYC) C END C C ======================================================= SUBROUTINE SFCTL92(X,PHI,Size,LCYC,PII,NATST,NATST2,BB, + MB,XB,IA,AtomicNumOccup,IRESB,SZA) C ======================================================= C C .. Scalar Arguments .. REAL PII,SZA INTEGER LCYC,NATST,NATST2,Size C .. C .. Array Arguments .. REAL ATOMICNUMOCCUP(NATST),BB(NATST),PHI(Size/2),X(Size), + XB(2,NATST) INTEGER IA(NATST2),IRESB(NATST),MB(NATST) C .. C .. Scalars in Common .. REAL BfactFpart,BfactOverall,RHmax,RHmean,RHmin,ScaleFcalc, + ScaleFpart,SigmaExclude,Smax,Smin,SSbinSize,TSmax,TSmin, + VolMtz,WangSphereRadi INTEGER Hmax,HmaxA,Hmin,HminA,IOatomop,IOgradmat,IOhessian,IOmap, + IOscratch,IOshifts,IOxyzin,IOxyzoutunq,IXmax, + IXmin,IYmax,IYmin,IZmax,IZmin,Jsec,JU1,JU2,JV1,JV2,KHmin, + Kmax,Kmin,LatomMapFlag,LFpartFlag,LSFrefFlag, + LhklInputFlag,LMapInFlag,Lmax,Lmin,LPhiPartFlag, + LSFcalcFlag,LSolvMaskFlag,LWghtModeFlag,LxyzInputFlag, + LXyzOutputFlag,NLPRGO,Nslab,NumMultiplicity,NumSections, + NumSFspaceGroup,NumSFsymm,NX,NY,NZ LOGICAL LNoScaleFlag,LverboseFlag C .. C .. Arrays in Common .. REAL CellMtz INTEGER Iuvw C .. C .. Local Scalars .. REAL SUM INTEGER I,IEND,IHKA,ISLAB,Kmax1,N1,N2,N3,NHLAY,NPAR,NPassTwoSave, + NSizePassOne,NSizePassTwo,NumCurrentRecord,NX1,NY21,NYP2, + NZ21,NZP2,R,REND C .. C .. Local Arrays .. INTEGER D(5) C .. C .. External Subroutines .. EXTERNAL ATSORT,CCPERR,CMPLFT,GENDEN,IN91,INV21,INV21SC,MWCLOSE, + QSEEK,R3PI,REALFT,REDMAP,SOUTFC,SOUTN22,WRITEMAP,WRITEZ C .. C .. Intrinsic Functions .. INTRINSIC INT,SQRT C .. C .. Common blocks .. COMMON /HKLLIM/ + Hmax,Kmax,Lmax,Hmin,Kmin,Lmin,Nslab COMMON /IOSF/ + IOscratch,IOgradmat,IOhessian,IOshifts, + IOatomop,IOmap,IOxyzin,IOxyzoutunq COMMON /MPHDR/ + NX,NY,NZ, + IXmin,IXmax,IYmin,IYmax,IZmin,IZmax, + Jsec,JU1,JU2,JV1,JV2,Iuvw(3), + NumSFspaceGroup,NumSections, + RHmin,RHmax,RHmean,NumSFsymm, + CellMtz(6),VolMtz,Volfft,F000 COMMON /P41212/ + HminA,HmaxA,KHmin COMMON /SFOUT/ + Smin,Smax,TSmin,TSmax,SSbinSize, + LFpartFlag,LPhiPartFlag,LWghtModeFlag, + ScaleFcalc,ScaleFpart, + SigmaExclude,WangSphereRadi, + BfactOverall,BfactFpart, + NumMultiplicity,NLPRGO COMMON /SRFCTL1/ + LSFcalcFlag,LSFrefFlag, + LatomMapFlag,LxyzInputFlag, + LhklInputFlag,LMapInFlag, + LSolvMaskFlag,LXyzOutputFlag COMMON /TERSE/ + LverboseFlag,LNoScaleFlag C .. C C ********************** CALL QSEEK(IOscratch,1,1,1) C ********************** C NYP2 = NY + 2 NZP2 = NZ + 2 NZ21 = NZ/2 + 1 NSizePassOne = Size/ (NX*NYP2) NSizePassTwo = Size/NZP2 NPassTwoSave = NSizePassTwo R = IZmin REND = IZmax C DO 10 I = 1,Size X(I) = 0.0 10 CONTINUE C NumCurrentRecord = 0 IF (LxyzInputFlag.EQ.0) GO TO 20 C C---- sort atoms in order of z coordinates C and calculate density contributed from zsf to zff C ***************************** CALL ATSORT(NATST, + NATST2, + BB, + MB, + XB, + IA, + AtomicNumOccup, + IRESB, + SZA, + BfactOverall) CALL XYZREWD(IOxyzin) C ***************************** C NumCurrentRecord = 0 20 CONTINUE C IF (R+NSizePassOne.GT.REND) NSizePassOne = REND - R + 1 N1 = NY + 2 N2 = NX N3 = NSizePassOne NPAR = 0 C C IF (LMapInFlag.EQ.1 .AND. LxyzInputFlag.EQ.0) THEN SUM = 0.0 CALL REDMAP(X,N1,N2,N3,R,SUM) GO TO 40 END IF C C ***************************** CALL GENDEN(X,N1,N2,N3,R,NPAR,SUM) C ***************************** C IF (LatomMapFlag.EQ.0) GO TO 40 CALL WRITEMAP(IOmap,X,N1,N2,N3) IF (LSFcalcFlag.EQ.0) GO TO 60 C C---- density generated for NSizePassOne sections. now calculate C y and x transforms C 40 CONTINUE NY21 = NY/2 + 1 Kmax1 = Kmax + 1 IF (SUM.EQ.0.0) GO TO 50 D(1) = (NY+2)*NX*NSizePassOne D(2) = 2 D(3) = (NY+2)*NX D(4) = (NY+2)*NX D(5) = NY + 2 C C ************************ CALL REALFT(X(1),X(2),NY/2,D) C ************************ C D(1) = D(1) D(2) = NY + 2 D(3) = D(3) D(4) = (Kmax+1)*2 D(5) = 2 C C ****************************** CALL CMPLFT(X(1), + X(2), + NX, + D) 50 CALL WRITEZ(X, + NY21, + NX, + NSizePassOne, + Kmax1, + IOscratch, + NumCurrentRecord) C ****************************** C 60 R = R + NSizePassOne IF (R.LE.REND) GO TO 20 C IF (LatomMapFlag.EQ.1)THEN CALL MWCLOSE(IOmap) IF (LSFcalcFlag.EQ.0) THEN CALL CLOSEIT CALL CCPERR(0,' Normal Termination of fc map output') ENDIF END IF C NSizePassOne = Size/ (NX*NYP2) C C---- complex transform(k,h,nz8) is now all calculatec C read sections back in to set up arrays x(nz21,ihka) C IEND = 0 KHmin = 0 HminA = 0 70 CONTINUE C C---- want (Hmaxa+1)*(Hmaxa+2)/2 .le. NSizePassTwo+kHmin C HmaxA = INT(SQRT(9.0- (1-NSizePassTwo-KHmin)*8.0) + + (-3.0))/2 IF (HmaxA.GT.Hmax) HmaxA = Hmax IHKA = (HmaxA+1)* (HmaxA+2)/2 - KHmin IHKA = ((IHKA+1)/2)*2 NX1 = NX + 1 C C ****************************** CALL IN91(X, + NZ21, + IHKA, + PHI, + Kmax1, + NX1, + NZ, + IOscratch, + NumSFspaceGroup) C ****************************** C D(1) = 2*NZ21*IHKA D(2) = 2 D(3) = D(1) D(4) = D(1) D(5) = 2*NZ21 C C *********************** CALL INV21SC(X,NZ21,IHKA,1) CALL INV21(X(1),X(2),NZ/2,D) C *********************** C C *********************** IF (LhklInputFlag.EQ.1) CALL SOUTN22(X, + NZ21, + NPassTwoSave, + 1, + IHKA, + ISLAB, + LCYC, + IEND) C *********************** C C---- in soutfc NSizePassTwo gives C the no of h layers, r = Hmin for this pass C for this spacegroup this info is given by Hmina,Hmaxa C NSizePassTwo = nhlay ; r= Hmina C NHLAY = HmaxA - HminA + 1 C C IF (LSFcalcFlag.EQ.1 .AND. LhklInputFlag.EQ.0) + CALL SOUTFC(X, + NZ21, + NPassTwoSave, + 1, + NHLAY, + HminA, + ISLAB, + LCYC, + IEND) C HminA = HmaxA + 1 KHmin = (HmaxA+1)* (HmaxA+2)/2 IF (HminA.LE.Hmax .AND. IEND.EQ.0) GO TO 70 Nslab = ISLAB IF (LverboseFlag) WRITE (6,FMT=6000) Nslab 6000 FORMAT (' NUMBER OF SLABS =',I5,/) IF (LSFcalcFlag.EQ.1 .AND. LhklInputFlag.EQ.0) RETURN C C---- calculate weighted differences C C ************** CALL R3PI(PII,LCYC) C ************** C END C C ==================================== SUBROUTINE SFIPN2(X,N1,N2,N3,R,LCYC) C ==================================== C C Input routine for complex data, for fft programs which C section along z C The data is stored in the array X as lkh C C N1 =NZ/2 + 1 for P212121, C N2 =Kmax+1 C N3 =NSizePassOne C R is minimum h for this pass C C .. Parameters .. REAL PI PARAMETER (PI=3.1415926) INTEGER MCOLS PARAMETER (MCOLS=200) C .. C .. Scalar Arguments .. INTEGER LCYC,N1,N2,N3,R C .. C .. Array Arguments .. COMPLEX X(N1,N2,N3) C .. C .. Scalars in Common .. REAL AverageBfactor,BfactFpart,BfactorMax,BfactorMin,BfactOverall, + BfactReset,BfactStartStepSize,Bsmear,RatioShiftTrunc, + RmsBfactor,RmsXyz,ScaleFcalc,ScaleFpart,SFrepeatValue, + SigmaExclude,Smax,Smin,SSbinSize,TH,TSmax,TSmin,W, + WangSphereRadi,XyzStartStepSize INTEGER Hmax,HmaxA,Hmin,HminA,KHmin,Kmax,Kmin,LBfactRefFlag, + LcheckSFspaceGrpFlag,LFpartFlag,LFreeRexcludeVal,Lmax, + Lmin,LPhiPartFlag,LSFmodeFlag,LWghtModeFlag,NLPRGO, + LrefineCycFlag,Nslab,NtotalRefsUsed,NumMultiplicity C .. C .. Local Scalars .. COMPLEX F REAL A,B,BoverallWork,CONV,CORR,ERROR,FC,FP,FreeRFlag,PHI,SSQ, + SSQOV4,TH1,WK INTEGER H,Ifree,IH,IK,IL,K,KCOUNT,KH,L LOGICAL EOF,LNAN C .. C .. Local Arrays .. REAL ADATA(MCOLS) LOGICAL LOGMSS(MCOLS) C .. C .. External Subroutines .. EXTERNAL LRREFL,LRREFM C .. C .. Intrinsic Functions .. INTRINSIC ABS,CMPLX,CONJG,COS,EXP,MAX,MOD,NINT,SIN C .. C .. Common blocks .. COMMON /BFACTS/ + AverageBfactor, + BfactorMin, + BfactorMax, + Bsmear, + BfactReset COMMON /HKLLIM/ + Hmax,Kmax,Lmax,Hmin,Kmin,Lmin,Nslab COMMON /P41212/ + HminA,HmaxA,KHmin COMMON /SFOUT/ + Smin,Smax,TSmin,TSmax,SSbinSize, + LFpartFlag,LPhiPartFlag,LWghtModeFlag, + ScaleFcalc,ScaleFpart, + SigmaExclude,WangSphereRadi, + BfactOverall,BfactFpart, + NumMultiplicity,NLPRGO COMMON /SRFCTL/ + NtotalRefsUsed, + RatioShiftTrunc,W,TH, + LSFmodeFlag,LrefineCycFlag,LBfactRefFlag, + LcheckSFspaceGrpFlag,LFreeRexcludeVal, + XyzStartStepSize,BfactStartStepSize, + SFrepeatValue, + RmsXyz,RmsBfactor C .. SAVE Kcount, Adata, H, K, L C .. C LNAN = .TRUE. CONV = PI/180.0 BoverallWork = BfactOverall IF (LBfactRefFlag.NE.0 .AND.LCYC.GE.100) BoverallWork = 0 C DO 30 IH = 1,N3 DO 20 IK = 1,N2 DO 10 IL = 1,N1 X(IL,IK,IH) = CMPLX(0.0,0.0) 10 CONTINUE 20 CONTINUE 30 CONTINUE C IF (R.NE.Hmin) GO TO 60 Kcount = 0 C 40 CONTINUE CALL LRREFL(2,SSQ,Adata,EOF) IF (EOF) GO TO 90 CALL LRREFM(2,LOGMSS) 60 CONTINUE H = NINT(Adata(1)) K = NINT(Adata(2)) L = NINT(Adata(3)) IF (H.LT.HminA ) CALL CCPERR + (1,' ** Fatal error -HKL Data needs sorting - Run CAD **') IF (H.GT.HmaxA ) GO TO 90 C C---- exclude SIGFP = 0 data C IF (LOGMSS(4) .OR. LOGMSS(5)) THEN IF (LNAN) THEN IF (LOGMSS(4) .NEQV. LOGMSS(5)) WRITE(6,'(/,A,/,A,/)') + ' *** Warning; either FP/SIGFP=MNF but other is not.', + ' This must mean the column pair is inconsistent ***' LNAN = .FALSE. ENDIF GOTO 40 ENDIF IF (ABS(Adata(5)).LE.0.00001) GO TO 40 C C---- and F< SIG cut off stuff C IF (ABS(SigmaExclude).GE.0.000001 .AND. + Adata(4).LT.SigmaExclude*Adata(5) ) GO TO 40 C C---- Is FreeRFlag set? C IF (LFreeRexcludeVal.GE.0 )THEN FreeRFlag = 9999999 IF (.NOT. LOGMSS(6)) + FreeRFlag = Adata(6) IF (ABS(LFreeRexcludeVal - FreeRFlag).LT.0.5) Go to 40 END IF C C---- apply inverse scale to FP and SIGFP C C Adata(4) = Adata(4)/ScaleFcalc Adata(5) = Adata(5)/ScaleFcalc FP = Adata(4) SSQOV4 = SSQ/4.0 CORR = EXP((Bsmear-BoverallWork)*SSQOV4) Adata(NLPRGO - 1) = CORR*Adata(NLPRGO-1) FC = Adata(NLPRGO-1) Kcount = Kcount + 1 Ifree = 1 C C C---- if fo . eq . 0 leave fcal as is ( =0 ) C TH1 = 1000000000.0 IF (FP.GT.0.00001)TH1 = FC/FP + 0.00001 TH1 = MAX(TH1,1.0/TH1) IF (TH1.GT.TH) GO TO 40 ERROR = FC - FP WK = 1 IF (W.GT.0.0) WK = SSQ** (0.5*W) ERROR = ERROR*WK PHI = CONV*Adata(NLPRGO) A = ERROR*COS(PHI) B = ERROR*SIN(PHI) F = CMPLX(A,B) KH = (H+1)*H/2 + K + 1 - KHmin IK = K + 1 IL = L + 1 IF (IL.LE.0) IL = IL + N1 X(IL,KH,1) = F C C---- For some space groups, fill in 0 0 -l C IF (Lmin.GE.0) GO TO 40 IF (H.EQ.0 .AND. + K.EQ.0 .AND. + L.GT.0) X(N1+1-L,1,1) = CONJG(F) IF (H.EQ.0 .AND. + K.EQ.0 .AND. + L.LT.0) X(1-L,1,1 )= CONJG(F) GO TO 40 90 CONTINUE END C C ==================================== SUBROUTINE SFIPR3(X,N1,N2,N3,R,LCYC) C ==================================== C C Input routine for complex data, for fft programs which C section along z C The data is stored in the array X as lkh C C N1 =NZ/2 + 1 for P212121, C N2 =Kmax+1 C N3 =NSizePassOne C R is minimum h for this pass C C .. Parameters .. REAL PI PARAMETER (PI=3.1415926) INTEGER MCOLS PARAMETER (MCOLS=200) C .. C .. Scalar Arguments .. INTEGER LCYC,N1,N2,N3,R C .. C .. Array Arguments .. COMPLEX X(N1,N2,N3) C .. C .. Scalars in Common .. REAL AverageBfactor,BfactFpart,BfactorMax,BfactorMin,BfactOverall, + BfactReset,BfactStartStepSize,Bsmear,RatioShiftTrunc, + RmsBfactor,RmsXyz,ScaleFcalc,ScaleFpart,SFrepeatValue, + SigmaExclude,Smax,Smin,SSbinSize,TH,TSmax,TSmin,W, + WangSphereRadi,XyzStartStepSize INTEGER Hmax,Hmin,Kmax,Kmin,LBfactRefFlag,LcheckSFspaceGrpFlag, + LFpartFlag,LFreeRexcludeVal,Lmax,Lmin,LPhiPartFlag, + LSFmodeFlag,LWghtModeFlag,NLPRGO,LrefineCycFlag,Nslab, + NtotalRefsUsed,NumMultiplicity C .. C .. Local Scalars .. COMPLEX F REAL A,B,BoverallWork,CONV,CORR,ERROR,FC,FP,FreeRFlag,PHI,SSQ, + SSQOV4,TH1,WK INTEGER H,HM,Ifree,IH,IK,IL,K,KCOUNT,L,LDASH LOGICAL EOF,LNAN C .. C .. Local Arrays .. REAL ADATA(MCOLS) LOGICAL LOGMSS(MCOLS) C .. C .. External Subroutines .. EXTERNAL LRREFL,LRREFM C .. C .. Intrinsic Functions .. INTRINSIC ABS,CMPLX,CONJG,COS,EXP,MAX,MOD,NINT,SIN C .. C .. Common blocks .. COMMON /BFACTS/ + AverageBfactor, + BfactorMin, + BfactorMax, + Bsmear, + BfactReset COMMON /HKLLIM/ + Hmax,Kmax,Lmax,Hmin,Kmin,Lmin,Nslab COMMON /SFOUT/ + Smin,Smax,TSmin,TSmax,SSbinSize, + LFpartFlag,LPhiPartFlag,LWghtModeFlag, + ScaleFcalc,ScaleFpart, + SigmaExclude,WangSphereRadi, + BfactOverall,BfactFpart, + NumMultiplicity,NLPRGO COMMON /SRFCTL/ + NtotalRefsUsed, + RatioShiftTrunc,W,TH, + LSFmodeFlag,LrefineCycFlag,LBfactRefFlag, + LcheckSFspaceGrpFlag,LFreeRexcludeVal, + XyzStartStepSize,BfactStartStepSize, + SFrepeatValue, + RmsXyz,RmsBfactor C .. SAVE Kcount, Adata, H, K, L, LDASH C .. C LNAN = .TRUE. CONV = PI/180.0 BoverallWork = BfactOverall IF (LBfactRefFlag.NE.0 .AND.LCYC.GE.100) BoverallWork = 0 HM = R + N3 - 1 C DO 30 IH = 1,N3 DO 20 IK = 1,N2 DO 10 IL = 1,N1 X(IL,IK,IH) = CMPLX(0.0,0.0) 10 CONTINUE 20 CONTINUE 30 CONTINUE C IF (R.NE.Hmin) GO TO 60 Kcount = 0 40 CONTINUE CALL LRREFL(2,SSQ,Adata,EOF) IF (EOF) GO TO 90 CALL LRREFM(2,LOGMSS) 60 CONTINUE H = NINT(Adata(1)) K = NINT(Adata(2)) L = NINT(Adata(3)) LDASH = (L+3000)/3 - 1000 IF (H.LT.Hmin ) CALL CCPERR + (1,' ** Fatal error -HKL Data needs sorting - Run CAD **') IF (H.GT.HM ) GO TO 90 C C---- exclude SIGFP = 0 data C IF (LOGMSS(4) .OR. LOGMSS(5)) THEN IF (LNAN) THEN IF (LOGMSS(4) .NEQV. LOGMSS(5)) WRITE(6,'(/,A,/,A,/)') + ' *** Warning; either FP/SIGFP=MNF but other is not.', + ' This must mean the column pair is inconsistent ***' LNAN = .FALSE. ENDIF GOTO 40 ENDIF IF (ABS(Adata(5)).LE.0.0) GO TO 40 C C---- and F< SIG cut off stuff C IF (ABS(SigmaExclude).GE.0.000001 .AND. + Adata(4).LT.SigmaExclude*Adata(5) ) GO TO 40 C C---- Is FreeRFlag set? C IF (LFreeRexcludeVal.GE.0 )THEN FreeRFlag = 9999999 IF (.NOT. LOGMSS(6)) + FreeRFlag = Adata(6) IF (ABS(LFreeRexcludeVal - FreeRFlag).LT.0.5) Go to 40 END IF C C---- apply inverse scale to FP and SIGFP C Adata(4) = Adata(4)/ScaleFcalc Adata(5) = Adata(5)/ScaleFcalc FP = Adata(4) SSQOV4 = SSQ/4.0 CORR = EXP((Bsmear-BoverallWork)*SSQOV4) Adata(NLPRGO - 1) = CORR*Adata(NLPRGO-1) FC = Adata(NLPRGO-1) Kcount = Kcount + 1 Ifree = 1 C C C---- if fo . eq . 0 leave fcal as is ( =0 ) C TH1 = 1000000000.0 IF (FP.GT.0.00001)TH1 = FC/FP + 0.00001 TH1 = MAX(TH1,1.0/TH1) IF (TH1.GT.TH) GO TO 40 ERROR = FC - FP WK = 1 IF (W.GT.0.0) WK = SSQ** (0.5*W) ERROR = ERROR*WK PHI = CONV*Adata(NLPRGO) A = ERROR*COS(PHI) B = ERROR*SIN(PHI) F = CMPLX(A,B) IH = H - R + 1 IK = K + 1 IL = LDASH + 1 IF (LDASH.LT.0) IL = LDASH + 1 + N1 X(IL,IK,IH) = F C C---- For some space groups, fill in 0 0 -l C IF (Lmin.GE.0) GO TO 40 IF (H.EQ.0 .AND. K.EQ.0 .AND. LDASH.GT.0) + X(N1+1-LDASH,1,IH) = CONJG(F) IF (H.EQ.0 .AND. K.EQ.0 .AND. LDASH.LT.0) + X(1-LDASH,1,IH) = CONJG(F) GO TO 40 90 CONTINUE END C C =================================== SUBROUTINE SFIPY(X,N1,N2,N3,R,LCYC) C =================================== C C Input routine for complex data, for fft programs which C section along y C The data is stored in the array X as klh C If ISORT=0, the data is assumed to be sorted on h, but C need not be sorted on k or l C C N1 =NY for P1, NY/2+1 for P21, P21212 C N2 =Lmax+1 C N3 =NSizePassOne C R is minimum h for this pass C C .. Parameters .. REAL PI PARAMETER (PI=3.1415926) INTEGER MCOLS PARAMETER (MCOLS=200) C .. C .. Scalar Arguments .. INTEGER LCYC,N1,N2,N3,R C .. C .. Array Arguments .. COMPLEX X(N1,N2,N3) C .. C .. Scalars in Common .. REAL AverageBfactor,BfactFpart,BfactorMax,BfactorMin,BfactOverall, + BfactReset,BfactStartStepSize,Bsmear,RatioShiftTrunc, + RmsBfactor,RmsXyz,ScaleFcalc,ScaleFpart,SFrepeatValue, + SigmaExclude,Smax,Smin,SSbinSize,TH,TSmax,TSmin,W, + WangSphereRadi,XyzStartStepSize INTEGER Hmax,Hmin,Kmax,Kmin,LBfactRefFlag,LcheckSFspaceGrpFlag, + LFpartFlag,LFreeRexcludeVal,Lmax,Lmin,LPhiPartFlag, + LSFmodeFlag,LWghtModeFlag,NLPRGO,LrefineCycFlag,Nslab, + NtotalRefsUsed,NumMultiplicity C .. C .. Local Scalars .. COMPLEX F REAL A,B,BoverallWork,CONV,CORR,ERROR,FC,FP,FreeRFlag,PHI,SSQ, + SSQOV4,TH1,WK INTEGER H,HM,IH,IK,IL,K,KCOUNT,L LOGICAL EOF,LNAN C .. C .. Local Arrays .. REAL ADATA(MCOLS) LOGICAL LOGMSS(MCOLS) C .. C .. External Subroutines .. EXTERNAL LRREFL,LRREFM C .. C .. Intrinsic Functions .. INTRINSIC ABS,CMPLX,CONJG,COS,EXP,MAX,MOD,NINT,SIN C .. C .. Common blocks .. COMMON /BFACTS/ + AverageBfactor, + BfactorMin, + BfactorMax, + Bsmear, + BfactReset COMMON /HKLLIM/ + Hmax,Kmax,Lmax,Hmin,Kmin,Lmin,Nslab COMMON /SFOUT/ + Smin,Smax,TSmin,TSmax,SSbinSize, + LFpartFlag,LPhiPartFlag,LWghtModeFlag, + ScaleFcalc,ScaleFpart, + SigmaExclude,WangSphereRadi, + BfactOverall,BfactFpart, + NumMultiplicity,NLPRGO COMMON /SRFCTL/ + NtotalRefsUsed, + RatioShiftTrunc,W,TH, + LSFmodeFlag,LrefineCycFlag,LBfactRefFlag, + LcheckSFspaceGrpFlag,LFreeRexcludeVal, + XyzStartStepSize,BfactStartStepSize, + SFrepeatValue, + RmsXyz,RmsBfactor C .. SAVE Kcount, Adata, H, K, L C .. C LNAN = .TRUE. CONV = PI/180.0 BoverallWork = BfactOverall IF (LBfactRefFlag.NE.0 .AND.LCYC.GE.100) BoverallWork = 0 HM = R + N3 - 1 C DO 30 IH = 1,N3 DO 20 IL = 1,N2 DO 10 IK = 1,N1 X(IK,IL,IH) = CMPLX(0.0,0.0) 10 CONTINUE 20 CONTINUE 30 CONTINUE C IF (R.NE.Hmin) GO TO 60 Kcount = 0 40 CONTINUE CALL LRREFL(2,SSQ,Adata,EOF) IF (EOF) GO TO 90 CALL LRREFM(2,LOGMSS) 60 CONTINUE H = NINT(Adata(1)) K = NINT(Adata(2)) L = NINT(Adata(3)) IF (H.LT.Hmin ) CALL CCPERR + (1,' ** Fatal error -HKL Data needs sorting - Run CAD **') IF (H.GT.HM ) GO TO 90 C C---- exclude SIGFP = 0 data C IF (LOGMSS(4) .OR. LOGMSS(5)) THEN IF (LNAN) THEN IF (LOGMSS(4) .NEQV. LOGMSS(5)) WRITE(6,'(/,A,/,A,/)') + ' *** Warning; either FP/SIGFP=MNF but other is not', + ' This must mean the column pair is inconsistent ***' LNAN = .FALSE. ENDIF GOTO 40 ENDIF IF ( ABS(Adata(5)).LE.0.0) GO TO 40 C C---- and F< SIG cut off stuff C IF (ABS(SigmaExclude).GE.0.000001 .AND. + Adata(4).LT.SigmaExclude*Adata(5) ) GO TO 40 C C---- Is FreeRFlag set? C IF (LFreeRexcludeVal.GE.0 )THEN FreeRFlag = 9999999 IF (.NOT. LOGMSS(6)) + FreeRFlag = Adata(6) IF (ABS(LFreeRexcludeVal - FreeRFlag).LT.0.5) Go to 40 END IF C C---- apply inverse scale to FP and SIGFP C Adata(4) = Adata(4)/ScaleFcalc Adata(5) = Adata(5)/ScaleFcalc FreeRFlag = 9999999 IF (LFreeRexcludeVal.GE.0 .AND. .NOT. LOGMSS(6)) + FreeRFlag = Adata(6) IF (LFreeRexcludeVal.EQ.-999) FreeRFlag = Adata(6) FP = Adata(4) SSQOV4 = SSQ/4.0 CORR = EXP((Bsmear-BoverallWork)*SSQOV4) Adata(NLPRGO - 1) = CORR*Adata(NLPRGO-1) FC = Adata(NLPRGO-1) Kcount = Kcount + 1 Ifree = 1 C C C---- if fo . eq . 0 leave fcal as is ( =0 ) C TH1 = 1000000000.0 IF (FP.GT.0.00001) TH1 = FC/FP + 0.00001 TH1 = MAX(TH1,1.0/TH1) IF (TH1.GT.TH) GO TO 40 ERROR = FC - FP WK = 1 IF (W.GT.0.0) WK = SSQ** (0.5*W) ERROR = ERROR*WK PHI = CONV*Adata(NLPRGO) A = ERROR*COS(PHI) B = ERROR*SIN(PHI) F = CMPLX(A,B) IH = H - R + 1 IK = K + 1 IF (IK.LE.0) IK = IK + N1 IL = L + 1 X(IK,IL,IH) = F C C---- For space group P1, fill in 0 -k 0 C IF (Kmin.GE.0) GO TO 40 IF (H.EQ.0 .AND. + L.EQ.0 .AND. + K.GT.0) X(N1+1-K,1,IH) = CONJG(F) IF (H.EQ.0 .AND. + L.EQ.0 .AND. + K.LT.0) X(1-K,1,IH) = CONJG(F) GO TO 40 90 CONTINUE END C C =================================== SUBROUTINE SFIPZ(X,N1,N2,N3,R,LCYC) C =================================== C C Input routine for complex data, for fft programs which C section along z C The data is stored in the array X as lkh C C N1 =NZ/2 + 1 for P212121, C N2 =Kmax+1 C N3 =NSizePassOne C R is minimum h for this pass C C .. Parameters .. REAL PI PARAMETER (PI=3.1415926) INTEGER MCOLS PARAMETER (MCOLS=200) C .. C .. Scalar Arguments .. INTEGER LCYC,N1,N2,N3,R C .. C .. Array Arguments .. COMPLEX X(N1,N2,N3) C .. C .. Scalars in Common .. REAL AverageBfactor,BfactFpart,BfactorMax,BfactorMin,BfactOverall, + BfactReset,BfactStartStepSize,Bsmear,RatioShiftTrunc, + RmsBfactor,RmsXyz,ScaleFcalc,ScaleFpart,SFrepeatValue, + SigmaExclude,Smax,Smin,SSbinSize,TH,TSmax,TSmin,W, + WangSphereRadi,XyzStartStepSize INTEGER Hmax,Hmin,Kmax,Kmin,LBfactRefFlag,LcheckSFspaceGrpFlag, + LFpartFlag,LFreeRexcludeVal,Lmax,Lmin,LPhiPartFlag, + LSFmodeFlag,LWghtModeFlag,NLPRGO,LrefineCycFlag,Nslab, + NtotalRefsUsed,NumMultiplicity C .. C .. Local Scalars .. COMPLEX F REAL A,B,BoverallWork,CONV,CORR,ERROR,FC,FP,FreeRFlag,PHI,SSQ, + SSQOV4,TH1,WK INTEGER H,HM,Ifree,IH,IK,IL,K,KCOUNT,L LOGICAL EOF,LNAN C .. C .. Local Arrays .. REAL ADATA(MCOLS) LOGICAL LOGMSS(MCOLS) C .. C .. External Subroutines .. EXTERNAL LRREFL,LRREFM C .. C .. Intrinsic Functions .. INTRINSIC ABS,CMPLX,CONJG,COS,EXP,MAX,MOD,NINT,SIN C .. C .. Common blocks .. COMMON /BFACTS/ + AverageBfactor, + BfactorMin, + BfactorMax, + Bsmear, + BfactReset COMMON /HKLLIM/ + Hmax,Kmax,Lmax,Hmin,Kmin,Lmin,Nslab COMMON /SFOUT/ + Smin,Smax,TSmin,TSmax,SSbinSize, + LFpartFlag,LPhiPartFlag,LWghtModeFlag, + ScaleFcalc,ScaleFpart, + SigmaExclude,WangSphereRadi, + BfactOverall,BfactFpart, + NumMultiplicity,NLPRGO COMMON /SRFCTL/ + NtotalRefsUsed, + RatioShiftTrunc,W,TH, + LSFmodeFlag,LrefineCycFlag,LBfactRefFlag, + LcheckSFspaceGrpFlag,LFreeRexcludeVal, + XyzStartStepSize,BfactStartStepSize, + SFrepeatValue, + RmsXyz,RmsBfactor C .. SAVE Kcount, Adata, H, K, L C .. C LNAN = .TRUE. CONV = PI/180.0 BoverallWork = BfactOverall IF (LBfactRefFlag.NE.0 .AND.LCYC.GE.100) BoverallWork = 0 HM = R + N3 - 1 C DO 30 IH = 1,N3 DO 20 IK = 1,N2 DO 10 IL = 1,N1 X(IL,IK,IH) = CMPLX(0.0,0.0) 10 CONTINUE 20 CONTINUE 30 CONTINUE C IF (R.NE.Hmin) GO TO 60 Kcount = 0 C 40 CONTINUE CALL LRREFL(2,SSQ,Adata,EOF) IF (EOF) GO TO 90 CALL LRREFM(2,LOGMSS) 60 CONTINUE H = NINT(Adata(1)) K = NINT(Adata(2)) L = NINT(Adata(3)) IF (H.LT.Hmin ) CALL CCPERR + (1,' ** Fatal error -HKL Data needs sorting - Run CAD **') IF (H.GT.HM ) GO TO 90 C C---- exclude SIGFP = 0 data C IF (LOGMSS(4) .OR. LOGMSS(5)) THEN IF (LNAN) THEN IF (LOGMSS(4) .NEQV. LOGMSS(5)) WRITE(6,'(/,A,/,A,/)') + ' *** Warning; either FP/SIGFP=MNF but other is not.', + ' This must mean the column pair is inconsistent ***' LNAN = .FALSE. ENDIF GOTO 40 ENDIF IF (ABS(Adata(5)).LE.0.0) GO TO 40 C C---- and F< SIG cut off stuff C IF (ABS(SigmaExclude).GE.0.000001 .AND. + Adata(4).LT.SigmaExclude*Adata(5) ) GO TO 40 C C---- Is FreeRFlag set? C IF (LFreeRexcludeVal.GE.0 )THEN FreeRFlag = 9999999 IF (.NOT. LOGMSS(6)) + FreeRFlag = Adata(6) IF (ABS(LFreeRexcludeVal - FreeRFlag).LT.0.5) Go to 40 END IF C C---- apply inverse scale to FP and SIGFP C Adata(4) = Adata(4)/ScaleFcalc Adata(5) = Adata(5)/ScaleFcalc FP = Adata(4) SSQOV4 = SSQ/4.0 CORR = EXP((Bsmear-BoverallWork)*SSQOV4) Adata(NLPRGO - 1) = CORR*Adata(NLPRGO-1) FC = Adata(NLPRGO-1) Kcount = Kcount + 1 Ifree = 1 C C---- if fo . eq . 0 leave fcal as is ( =0 ) C TH1 = 1000000000.0 IF (FP.GT.0.00001) TH1 = FC/FP + 0.00001 TH1 = MAX(TH1,1.0/TH1) IF (TH1.GT.TH) GO TO 40 ERROR = FC - FP WK = 1 IF (W.GT.0.0) WK = SSQ** (0.5*W) ERROR = ERROR*WK PHI = CONV*Adata(NLPRGO) A = ERROR*COS(PHI) B = ERROR*SIN(PHI) F = CMPLX(A,B) IH = H - R + 1 IK = K + 1 IL = L + 1 IF (IL.LE.0) IL = IL + N1 X(IL,IK,IH) = F C C---- For some space groups, fill in 0 0 -l C IF (Lmin.GE.0) GO TO 40 IF (H.EQ.0 .AND. + K.EQ.0 .AND. + L.GT.0) X(N1+1-L,1,IH) = CONJG(F) IF (H.EQ.0 .AND. + K.EQ.0 .AND. + L.LT.0) X(1-L,1,IH) = CONJG(F) GO TO 40 90 CONTINUE C END C C ============================== SUBROUTINE SGTEST(Size,NP1FFT) C ============================== C C---- test array Size,index limits etc. C C .. Parameters .. INTEGER MaxSymmetry PARAMETER (MaxSymmetry=192) C .. C .. Scalar Arguments .. INTEGER NP1FFT,Size C .. C .. Scalars in Common .. REAL BfactStartStepSize,RatioShiftTrunc,RHmax,RHmean,RHmin, + RmsBfactor,RmsXyz,SFrepeatValue,SquAtmRadLimit,TH,VolMtz,W, + XyzStartStepSize INTEGER Hmax,Hmin,IOatomop,IOgradmat,IOhessian,IOmap,IOscratch, + IOshifts,IOxyzin,IOxyzoutunq,IXmax,IXmin,IYmax, + IYmin,IZmax,IZmin,Jsec,JU1,JU2,JV1,JV2,Kmax,Kmin, + LBfactRefFlag,LcheckSFspaceGrpFlag,LFreeRexcludeVal, + Lmax,Lmin,LSFmodeFlag,LrefineCycFlag,Nslab,NtotalRefsUsed, + NumAtmRefined,NumPlanes,NumSections,NumSFspaceGroup, + NumSFsymm,NumSpaceGroup,NumSymmetry,NumZeroOccAtms,NX,NY, + NZ LOGICAL LNoScaleFlag,LverboseFlag C .. C .. Arrays in Common .. REAL AtmBoxLowLim,AtmBoxUpLim,CellMtz,ExtBoxLowLim,ExtBoxUpLim, + ExtraPlanes,PermutRecipSymm,PlanesLimits,RealSymmMatrx, + SpecialPlaneLimit,RecipSymmMatrx INTEGER Iuvw,LSymmFlags C .. C .. Local Scalars .. REAL DLM,XFTMP INTEGER I,IN3,ISize2,J,JX,JY,JZ,NAT1,NAT2,NP1SF,NP2FFT,NP2SF, + NRC60,NRC63,NRCSC,NumBytesItem,NumWords,NX0,NY0,NZ0,NZOV3 C .. C .. External Subroutines .. EXTERNAL CCPERR,FILEO,QMODE,QOPEN C .. C .. Intrinsic Functions .. INTRINSIC NINT,REAL,SQRT C .. C .. Common blocks .. COMMON /ATMLIM/ + ExtBoxLowLim(3),ExtBoxUpLim(3), + SquAtmRadLimit,NumPlanes, + ExtraPlanes(3,6),PlanesLimits(6), + SpecialPlaneLimit(6), + AtmBoxLowLim(3),AtmBoxUpLim(3), + NumAtmRefined,NumZeroOccAtms COMMON /ATSYM/ + NumSymmetry,NumSpaceGroup, + RealSymmMatrx(4,4,MaxSymmetry), + RecipSymmMatrx(4,4,MaxSymmetry), + PermutRecipSymm(4,4), + LSymmFlags(MaxSymmetry) COMMON /HKLLIM/ + Hmax,Kmax,Lmax,Hmin,Kmin,Lmin,Nslab COMMON /IOSF/ + IOscratch,IOgradmat,IOhessian,IOshifts, + IOatomop,IOmap,IOxyzin,IOxyzoutunq COMMON /MPHDR/ + NX,NY,NZ, + IXmin,IXmax,IYmin,IYmax,IZmin,IZmax, + Jsec,JU1,JU2,JV1,JV2,Iuvw(3), + NumSFspaceGroup,NumSections, + RHmin,RHmax,RHmean,NumSFsymm, + CellMtz(6),VolMtz,Volfft,F000 COMMON /SRFCTL/ + NtotalRefsUsed, + RatioShiftTrunc,W,TH, + LSFmodeFlag,LrefineCycFlag,LBfactRefFlag, + LcheckSFspaceGrpFlag,LFreeRexcludeVal, + XyzStartStepSize,BfactStartStepSize, + SFrepeatValue, + RmsXyz,RmsBfactor COMMON /TERSE/ + LverboseFlag,LNoScaleFlag C .. C NumPlanes = 0 C C---- Set limits for assymmetric unit C DLM = SQRT(SquAtmRadLimit) C C---- Limits for P1 - modify as required - C AtmBoxLowLim AtmBoxUpLim are C limits where atom can only occur once. C NX0 = NX NY0 = NY NZ0 = NZ GO TO (10,20,30,40,50,60,70,80, + 90) LcheckSFspaceGrpFlag C 10 CONTINUE IF (LverboseFlag) WRITE (6,FMT=*) ' SFRK1V' C C---- set perm P1 C JX = 1 JY = 3 JZ = 2 Iuvw(1) = 3 Iuvw(2) = 1 Iuvw(3) = 2 C C---- set hkl limits nx ny nz limits - p1 C Hmin = -Hmax Kmin = -Kmax Lmin = 0 C C---- Check factors of grid are correct. C JU1 = ((NY+1)/2)*2 IF ( JU1.NE. NY) GO TO 9999 JU1 = ((NZ+1)/2)*2 IF ( JU1.NE. NZ) GO TO 9999 JU1 = IZmin JU2 = IZmax JV1 = IXmin JV2 = IXmax Jsec = IYmin NumSections = IYmax - IYmin + 1 C C---- set atsort limits - p1 C XFTMP = AtmBoxLowLim(2) AtmBoxLowLim(2) = AtmBoxLowLim(3) AtmBoxLowLim(3) = XFTMP XFTMP = ExtBoxUpLim(2) ExtBoxUpLim(2) = ExtBoxUpLim(3) ExtBoxUpLim(3) = XFTMP XFTMP = AtmBoxUpLim(2) AtmBoxUpLim(2) = AtmBoxUpLim(3) AtmBoxUpLim(3) = XFTMP C C---- set "p1 p2" limits - p1 C NP1FFT = Size/ (NY*2* (Lmax+1)) IF (NP1FFT.LT. 1) THEN WRITE(6,'(//,A,I8,A)')'MEMSIZE too small - increase to ', + INT(NY*2* (Lmax+1)* 3/2),' or greater' CALL CCPERR(1, 'INCREASE MEMSIZE') END IF IF (NP1FFT.GT. (Hmax-Hmin+1)) NP1FFT = Hmax - Hmin + 1 NP2SF = NP1FFT NP1SF = Size/ ((NZ+2)*NX) IF (NP1SF.LT. 1) THEN WRITE(6,'(//,A,I8,A)')'MEMSIZE too small - increase to ', + INT((NZ+2)*NX* 3/2),' or greater' CALL CCPERR(1, 'INCREASE MEMSIZE') END IF NP2FFT = Size/ (NX*NZ) IF (NP2FFT.LT. 1) THEN WRITE(6,'(//,A,I8,A)')'MEMSIZE too small - increase to ', + INT(NX*NZ* 3/2),' or greater' CALL CCPERR(1, 'INCREASE MEMSIZE') END IF NRCSC = 2*NP1SF*NP2SF* (Lmax+1) NRC60 = (IYmax-IYmin+NP1SF)/ + NP1SF* ((Hmax-Hmin+NP2SF)/NP2SF) NumWords = 2*NP1FFT*NP2FFT* (Lmax+1) NRC63 = (IYmax-IYmin+NP2FFT)/ + NP2FFT* ((Hmax-Hmin+NP1FFT)/NP1FFT) GO TO 100 20 CONTINUE C C---- set perm P21 C NumSFsymm = 2 JX = 1 JY = 3 JZ = 2 Iuvw(1) = 3 Iuvw(2) = 1 Iuvw(3) = 2 C C---- set hkl limits nx ny nz limits - p21 C Hmin = -Hmax Kmin = 0 Lmin = 0 C C---- Check factors of grid are correct. C JU1 = ((NX+1)/2)*2 IF ( JU1.NE. NX) GO TO 9999 JU1 = ((NY+1)/4)*4 IF ( JU1.NE. NY) GO TO 9999 JU1 = ((NZ+1)/2)*2 IF ( JU1.NE. NZ) GO TO 9999 JU1 = IZmin JU2 = IZmax JV1 = IXmin JV2 = IXmax Jsec = IYmin NumSections = IYmax - IYmin + 1 C C---- set atsort limits - p21 C XFTMP = AtmBoxLowLim(2) AtmBoxLowLim(2) = AtmBoxLowLim(3) AtmBoxLowLim(3) = XFTMP XFTMP = ExtBoxUpLim(2) ExtBoxUpLim(2) = ExtBoxUpLim(3) ExtBoxUpLim(3) = XFTMP XFTMP = AtmBoxUpLim(2) AtmBoxUpLim(2) = AtmBoxUpLim(3) AtmBoxUpLim(3) = XFTMP XFTMP = AtmBoxLowLim(2) AtmBoxLowLim(2) = AtmBoxLowLim(3) AtmBoxLowLim(3) = XFTMP XFTMP = AtmBoxUpLim(2) AtmBoxUpLim(2) = AtmBoxUpLim(3) AtmBoxUpLim(3) = XFTMP ExtBoxLowLim(3) = - (DLM)/CellMtz(2) ExtBoxUpLim(3) = REAL(IYmax)/NY + DLM/CellMtz(2) AtmBoxUpLim(3) = REAL(IYmax)/NY - DLM/CellMtz(2) C C---- set "p1 p2" limits - p21 C NP1FFT = Size/ ((NY+2)* (Lmax+1)) IF (NP1FFT.LT. 1) THEN WRITE(6,'(//,A,I8,A)')'MEMSIZE too small - increase to ', + INT((NY+2)* (Lmax+1)* 3/2),' or greater' CALL CCPERR(1, 'INCREASE MEMSIZE') END IF IF (NP1FFT.GT. (Hmax-Hmin+1)) NP1FFT = Hmax - Hmin + 1 NP2SF = NP1FFT NP1SF = Size/ ((NZ+2)*NX) IF (NP1SF.LT. 1) THEN WRITE(6,'(//,A,I8,A)')'MEMSIZE too small - increase to ', + INT((NZ+2)*NX* 3/2),' or greater' CALL CCPERR(1, 'INCREASE MEMSIZE') END IF NP2FFT = Size/ (NX*NZ) IF (NP2FFT.LT. 1) THEN WRITE(6,'(//,A,I8,A)')'MEMSIZE too small - increase to ', + INT(NX*NZ* 3/2),' or greater' CALL CCPERR(1, 'INCREASE MEMSIZE') END IF NRCSC = 2*NP1SF*NP2SF* (Lmax+1) NRC60 = (IYmax-IYmin+NP1SF)/ + NP1SF* ((Hmax-Hmin+NP2SF)/NP2SF) NumWords = 2*NP1FFT*NP2FFT* (Lmax+1) NRC63 = (IYmax-IYmin+NP2FFT)/ + NP2FFT* ((Hmax-Hmin+NP1FFT)/NP1FFT) GO TO 100 30 CONTINUE C IF (LverboseFlag) WRITE (6,FMT=*) ' SFRK18V' C C---- set perm P21212a C NumSFsymm = 4 JX = 1 JY = 3 JZ = 2 Iuvw(1) = 3 Iuvw(2) = 1 Iuvw(3) = 2 C C---- set hkl limits nx ny nz limits - P21212a C Hmin = 0 Kmin = 0 Lmin = 0 C C---- Check factors of grid are correct. C JU1 = ((NX+1)/4)*4 IF ( JU1.NE. NX) GO TO 9999 JU1 = ((NY+1)/4)*4 IF ( JU1.NE. NY) GO TO 9999 JU1 = ((NZ+1)/4)*4 IF ( JU1.NE. NZ) GO TO 9999 JU1 = IZmin JU2 = IZmax JV1 = IXmin JV2 = IXmax Jsec = IYmin NumSections = IYmax - IYmin + 1 C C---- set atsort limits - P21212a C XFTMP = AtmBoxLowLim(2) AtmBoxLowLim(2) = AtmBoxLowLim(3) AtmBoxLowLim(3) = XFTMP XFTMP = ExtBoxUpLim(2) ExtBoxUpLim(2) = ExtBoxUpLim(3) ExtBoxUpLim(3) = XFTMP XFTMP = AtmBoxUpLim(2) AtmBoxUpLim(2) = AtmBoxUpLim(3) AtmBoxUpLim(3) = XFTMP C C---- set "p1 p2" limits - P21212a C NP1FFT = Size/ ((NY+2)* (Lmax+1)) IF (NP1FFT.LT. 1) THEN WRITE(6,'(//,A,I8,A)')'MEMSIZE too small - increase to ', + INT((NY+2)* (Lmax+1)* 3/2),' or greater' CALL CCPERR(1, 'INCREASE MEMSIZE') END IF IF (NP1FFT.GT. (Hmax-Hmin+1)) NP1FFT = Hmax - Hmin + 1 NP2SF = NP1FFT NP1SF = Size/ ((NZ+2)*NX) IF (NP1SF.LT. 1) THEN WRITE(6,'(//,A,I8,A)')'MEMSIZE too small - increase to ', + INT((NZ+2)*NX* 3/2),' or greater' CALL CCPERR(1, 'INCREASE MEMSIZE') END IF NP2FFT = Size/ (NX*NZ) IF (NP2FFT.LT. 1) THEN WRITE(6,'(//,A,I8,A)')'MEMSIZE too small - increase to ', + INT(NX*NZ* 3/2),' or greater' CALL CCPERR(1, 'INCREASE MEMSIZE') END IF NRCSC = 2*NP1SF*NP2SF* (Lmax+1) NRC60 = (IYmax-IYmin+NP1SF)/ + NP1SF* ((Hmax-Hmin+NP2SF)/NP2SF) NumWords = 2*NP1FFT*NP2FFT* (Lmax+1) NRC63 = (IYmax-IYmin+NP2FFT)/ + NP2FFT* ((Hmax-Hmin+NP1FFT)/NP1FFT) GO TO 100 40 CONTINUE C C---- set perm P212121 C NumSFsymm = 4 NumPlanes = 0 JX = 1 JY = 2 JZ = 3 Iuvw(1) = 2 Iuvw(2) = 1 Iuvw(3) = 3 C C---- set hkl limits nx ny nz limits - p212121 C Hmin = 0 Kmin = 0 Lmin = 0 C C---- Check factors of grid are correct. C JU1 = ((NX+1)/4)*4 IF ( JU1.NE. NX) GO TO 9999 JU1 = ((NY+1)/4)*4 IF ( JU1.NE. NY) GO TO 9999 JU1 = ((NZ+1)/4)*4 IF ( JU1.NE. NZ) GO TO 9999 JU1 = IYmin JU2 = IYmax JV1 = IXmin JV2 = IXmax Jsec = IZmin NumSections = IZmax - IZmin + 1 C C---- set "p1 p2" limits - p212121 C check program dimensions C NP1FFT = Size/ ((NZ+2)* (Kmax+1)) IF (NP1FFT.LT. 1) THEN WRITE(6,'(//,A,I8,A)')'MEMSIZE too small - increase to ', + INT((NZ+2)* (Kmax+1)* 3/2),' or greater' CALL CCPERR(1, 'INCREASE MEMSIZE') END IF IF (NP1FFT.GT. (Hmax-Hmin+1)) NP1FFT = Hmax - Hmin + 1 NP2SF = NP1FFT NP1SF = Size/ ((NY+2)*NX) IF (NP1SF.LT. 1) THEN WRITE(6,'(//,A,I8,A)')'MEMSIZE too small - increase to ', + INT((NY+2)* NX* 3/2),' or greater' CALL CCPERR(1, 'INCREASE MEMSIZE') END IF NP2FFT = Size/ (NX*NY) IF (NP2FFT.LT. 1) THEN WRITE(6,'(//,A,I8,A)')'MEMSIZE too small - increase to ', + INT(NX*NY* 3/2),' or greater' CALL CCPERR(1, 'INCREASE MEMSIZE') END IF NRCSC = 2*NP1SF*NP2SF* (Kmax+1) NRC60 = (IZmax-IZmin+NP1SF)/ + NP1SF* ((Hmax-Hmin+NP2SF)/NP2SF) NumWords = 2*NP1FFT*NP2FFT* (Kmax+1) NRC63 = (IZmax-IZmin+NP2FFT)/ + NP2FFT* ((Hmax-Hmin+NP1FFT)/NP1FFT) GO TO 100 50 CONTINUE C C---- set perm P41212 C NumSFsymm = 8 NumPlanes = 0 JX = 1 JY = 2 JZ = 3 Iuvw(1) = 2 Iuvw(2) = 1 Iuvw(3) = 3 C C---- set hkl limits nx ny nz limits - P41212 C Hmin = 0 Kmin = 0 Lmin = 0 C C---- Check factors of grid are correct. C JU1 = ((NX+1)/4)*4 IF ( JU1.NE. NX) GO TO 9999 JU1 = ((NY+1)/4)*4 IF ( JU1.NE. NY) GO TO 9999 JU1 = ((NZ+1)/8)*8 IF ( JU1.NE. NZ) GO TO 9999 JU1 = IYmin JU2 = IYmax JV1 = IXmin JV2 = IXmax Jsec = IZmin NumSections = IZmax - IZmin + 1 C C---- set "p1 p2" limits - P41212 C NP1FFT = Size/ (2+NZ) IF (NP1FFT.LT. 1) THEN WRITE(6,'(//,A,I8,A)')'MEMSIZE too small - increase to ', + INT((2+NZ)* 3/2),' or greater' CALL CCPERR(1, 'INCREASE MEMSIZE') END IF NP2SF = NP1FFT NP2FFT = Size/ (NX*NY) IF (NP2FFT.LT. 1) THEN WRITE(6,'(//,A,I8,A)')'MEMSIZE too small - increase to ', + INT(NX*NY* 3/2),' or greater' CALL CCPERR(1, 'INCREASE MEMSIZE') END IF NP1SF = Size/ ((NY+2)*NX) IF (NP1SF.LT. 1) THEN WRITE(6,'(//,A,I8,A)')'MEMSIZE too small - increase to ', + INT((NY+2)*NX* 3/2),' or greater' CALL CCPERR(1, 'INCREASE MEMSIZE') END IF NRCSC = (Kmax+1)*2* (NX+1) NRC60 = (IZmax-IZmin+NP1SF)/NP1SF NumWords = 2*NX* (Kmax+1) NRC63 = IZmax - IZmin + 1 GO TO 100 60 CONTINUE C C---- set perm P31/P32 C NumSFsymm = 3 NumPlanes = 0 JX = 1 JY = 2 JZ = 3 Iuvw(1) = 2 Iuvw(2) = 1 Iuvw(3) = 3 C C---- set hkl limits nx ny nz limits - P31/P32 C Hmin = 0 Kmin = 0 Lmin = -Lmax C C---- Check factors of grid are correct. C JU1 = ((NX+1)/6)*6 IF ( JU1.NE. NX) GO TO 9999 JU1 = ((NY+1)/6)*6 IF ( JU1.NE. NY) GO TO 9999 JU1 = ((NZ+1)/6)*6 IF ( JU1.NE. NZ) GO TO 9999 IXmin = 0 IYmin = 0 IZmin = 0 JU1 = IYmin JU2 = IYmax JV1 = IXmin JV2 = IXmax Jsec = IZmin NumSections = IZmax - IZmin + 1 C C---- set "p1 p2" limits - P31/P32 C NP1FFT = Size/ ((2*NZ)* (Kmax+1)) IF (NP1FFT.LT. 1) THEN WRITE(6,'(//,A,I8,A)')'MEMSIZE too small - increase to ', + INT((2*NZ)* (Kmax+1)* 3/2),' or greater' CALL CCPERR(1, 'INCREASE MEMSIZE') END IF IF (NP1FFT.GT. (Hmax-Hmin+1)) NP1FFT = Hmax - Hmin + 1 NP2SF = NP1FFT NP1SF = Size/ ((NY+2)*NX) IF (NP1SF.LT. 1) THEN WRITE(6,'(//,A,I8,A)')'MEMSIZE too small - increase to ', + INT((NY+2)*NX* 3/2),' or greater' CALL CCPERR(1, 'INCREASE MEMSIZE') END IF NP2FFT = Size/ (NX*NY) IF (NP2FFT.LT. 1) THEN WRITE(6,'(//,A,I8,A)')'MEMSIZE too small - increase to ', + INT(NX*NY* 3/2),' or greater' CALL CCPERR(1, 'INCREASE MEMSIZE') END IF NRCSC = 2*NX* (Kmax+1) NRC60 = (IZmax-IZmin+1) NumWords = 2*NX* (Kmax+1) NRC63 = IZmax - IZmin + 1 GO TO 100 70 CONTINUE IF (LverboseFlag) WRITE (6,FMT=*) ' SFK146V' C C---- set perm R3 C NumPlanes = 0 JX = 1 JY = 2 JZ = 3 Iuvw(1) = 2 Iuvw(2) = 1 Iuvw(3) = 3 C C---- set hkl limits nx ny nz limits - R3 or P3 C Hmin = 0 Kmin = 0 Lmin = -Lmax C C---- Check factors of grid are correct. C JU1 = ((NX+1)/6)*6 IF ( JU1.NE. NX) GO TO 9999 JU1 = ((NY+1)/6)*6 IF ( JU1.NE. NY) GO TO 9999 JU1 = ((NZ+1)/6)*6 IF ( JU1.NE. NZ) GO TO 9999 IXmax = NX - 1 IYmax = NY - 1 NZOV3 = NZ/3 IZmax = NZOV3 - 1 If(NumSFspaceGroup.Eq.143)IZmax = NZ - 1 IXmin = 0 IYmin = 0 IZmin = 0 JU1 = IYmin JU2 = IYmax JV1 = IXmin JV2 = IXmax Jsec = IZmin NumSections = IZmax - IZmin + 1 C C---- set atsort limits - R3 C ExtBoxLowLim(1) = -DLM/CellMtz(1) ExtBoxLowLim(2) = ExtBoxLowLim(1) ExtBoxUpLim(1) = DLM/CellMtz(1) + 0.66667 ExtBoxUpLim(2) = ExtBoxUpLim(1) ExtBoxLowLim(3) = -DLM/CellMtz(3) ExtBoxUpLim(3) = REAL(IZmax)/NZ + DLM/CellMtz(3) C C---- set up two extra planes to C limit r3 reciprocal unit to a hexagon. C z range 0 to 1/3. C C x-y.lt. 1/3 C NumPlanes = 2 ExtraPlanes(JX,1) = 1 ExtraPlanes(JY,1) = -1.0 ExtraPlanes(JZ,1) = 0.0 SpecialPlaneLimit(1) = 0.3333333333333 PlanesLimits(1) = DLM/CellMtz(1) + SpecialPlaneLimit(1) C C---- y-x lt 1/3 C ExtraPlanes(1,2) = -1 ExtraPlanes(JY,2) = 1.0 ExtraPlanes(JZ,2) = 0.0 SpecialPlaneLimit(2) = SpecialPlaneLimit(1) PlanesLimits(2) = DLM/CellMtz(2) + SpecialPlaneLimit(2) C C---- set "p1 p2" limits - R3 or P3 C NP1FFT = Size/ (2*(IZmax+1)* (Kmax+1)) IF (NP1FFT.LT. 1) THEN WRITE(6,'(//,A,I8,A)')'MEMSIZE too small - increase to ', + INT(2*(IZmax+1)* (Kmax+1)* 3/2),' or greater' CALL CCPERR(1, 'INCREASE MEMSIZE') END IF IF (NP1FFT.GT. (Hmax-Hmin+1)) NP1FFT = Hmax - Hmin + 1 NP2SF = NP1FFT NP1SF = Size/ ((NY+2)*NX) IF (NP1SF.LT. 1) THEN WRITE(6,'(//,A,I8,A)')'MEMSIZE too small - increase to ', + INT((NY+2)*NX* 3/2),' or greater' CALL CCPERR(1, 'INCREASE MEMSIZE') END IF NP2FFT = Size/ (NX*NY) IF (NP2FFT.LT. 1) THEN WRITE(6,'(//,A,I8,A)')'MEMSIZE too small - increase to ', + INT(NX*NY* 3/2),' or greater' CALL CCPERR(1, 'INCREASE MEMSIZE') END IF NRCSC = 2*NP1SF*NP2SF* (Kmax+1) NRC60 = (IZmax-IZmin+NP1SF)/ + NP1SF* ((Hmax-Hmin+NP2SF)/NP2SF) NumWords = 2*NX* (Kmax+1) NRC63 = IZmax - IZmin + 1 GO TO 100 80 CONTINUE C C---- set perm P3121/P3221 C NumSFsymm = 6 NumPlanes = 0 JX = 1 JY = 2 JZ = 3 Iuvw(1) = 2 Iuvw(2) = 1 Iuvw(3) = 3 C C---- set hkl limits nx ny nz limits - P3121/P3221 C Hmin = 0 Kmin = 0 Lmin = -Lmax C C---- Check factors of grid are correct. C JU1 = ((NX+1)/6)*6 IF ( JU1.NE. NX) GO TO 9999 JU1 = ((NY+1)/6)*6 IF ( JU1.NE. NY) GO TO 9999 JU1 = ((NZ+1)/6)*6 IF ( JU1.NE. NZ) GO TO 9999 JU1 = IYmin JU2 = IYmax JV1 = IXmin JV2 = IXmax Jsec = IZmin NumSections = IZmax - IZmin + 1 C C---- set "p1 p2" limits - P3121/P3221 C NP1FFT = Size/ (2*NZ) IF (NP1FFT.LT. 1) THEN WRITE(6,'(//,A,I8,A)')'MEMSIZE too small - increase to ', + INT(2*NZ* 3/2),' or greater' CALL CCPERR(1, 'INCREASE MEMSIZE') END IF NP2SF = NP1FFT NP2FFT = Size/ (NX*NY) IF (NP2FFT.LT. 1) THEN WRITE(6,'(//,A,I8,A)')'MEMSIZE too small - increase to ', + INT(NX*NY* 3/2),' or greater' CALL CCPERR(1, 'INCREASE MEMSIZE') END IF NP1SF = Size/ ((NY+2)*NX) IF (NP1SF.LT. 1) THEN WRITE(6,'(//,A,I8,A)')'MEMSIZE too small - increase to ', + INT((NY+2)*NX* 3/2),' or greater' CALL CCPERR(1, 'INCREASE MEMSIZE') END IF NRCSC = (Kmax+1)*2* (NX+1) NRC60 = (IZmax-IZmin+NP1SF)/NP1SF NumWords = 2*NX* (Kmax+1) NRC63 = IZmax - IZmin + 1 GO TO 100 90 CONTINUE C C---- set perm P61/P65 C NumSFsymm = 6 NumPlanes = 0 JX = 1 JY = 2 JZ = 3 Iuvw(1) = 2 Iuvw(2) = 1 Iuvw(3) = 3 C C---- set hkl limits nx ny nz limits - P61/P65 C Hmin = 0 Kmin = 0 Lmin = 0 C C---- Check factors of grid are correct. C JU1 = ((NX+1)/6)*6 IF ( JU1.NE. NX) GO TO 9999 JU1 = ((NY+1)/6)*6 IF ( JU1.NE. NY) GO TO 9999 JU1 = ((NZ+1)/12)*12 IF ( JU1.NE. NZ) GO TO 9999 JU1 = IYmin JU2 = IYmax JV1 = IXmin JV2 = IXmax Jsec = IZmin NumSections = IZmax - IZmin + 1 C C---- set "p1 p2" limits - P61/P65 C NP1FFT = Size/ ((NZ+2)* (Kmax+1)) IF (NP1FFT.LT. 1) THEN WRITE(6,'(//,A,I8,A)')'MEMSIZE too small - increase to ', + INT((NZ+2)* (Kmax+1)* 3/2),' or greater' CALL CCPERR(1, 'INCREASE MEMSIZE') END IF IF (NP1FFT.GT. (Hmax-Hmin+1)) NP1FFT = Hmax - Hmin + 1 NP2SF = NP1FFT NP1SF = Size/ ((NY+2)*NX) IF (NP1SF.LT. 1) THEN WRITE(6,'(//,A,I8,A)')'MEMSIZE too small - increase to ', + INT((NY+2)*NX* 3/2),' or greater' CALL CCPERR(1, 'INCREASE MEMSIZE') END IF NP2FFT = Size/ (NX*NY) IF (NP2FFT.LT. 1) THEN WRITE(6,'(//,A,I8,A)')'MEMSIZE too small - increase to ', + INT(NX*NY* 3/2),' or greater' CALL CCPERR(1, 'INCREASE MEMSIZE') END IF NRCSC = 2*NX* (Kmax+1) NRC60 = (IZmax-IZmin+1) NumWords = 2*NX* (Kmax+1) NRC63 = IZmax - IZmin + 1 GO TO 100 100 CONTINUE C C---- Check if NX NY NZ have been reset C IF (NX.NE.NX0 .OR. NY.NE.NY0 .OR. NZ.NE.NZ0 ) THEN WRITE(6,'(///,a,3x,3i4,/,a,3x,3i4)') + ' INPUT GRID: ',NX0,NY0 ,NZ0, + ' RESET GRID: ',NX ,NY ,NZ CALL CCPERR(1, + ' GRID RESET - Check fast fourier requirements') END IF C C---- Check if ExtBoxLowLim(i) less than 0.0 and C ExtBoxUpLim(i) greater than 1.0 C IF ( ExtBoxLowLim(1).LT.0.0 .AND. + ExtBoxUpLim(1) .GT.1.0) THEN ExtBoxLowLim(1) = 0.0 ExtBoxUpLim(1) = 1.0 END IF C IF ( ExtBoxLowLim(2).LT.0.0 .AND. + ExtBoxUpLim(2) .GT.1.0) THEN ExtBoxLowLim(2) = 0.0 ExtBoxUpLim(2) = 1.0 END IF C C---- Check if AtmBoxUpLim(i) less than AtmBoxLowLim(i) C IF (AtmBoxUpLim(1).LT.AtmBoxLowLim(1)) + AtmBoxUpLim(1)=AtmBoxLowLim(1) IF (AtmBoxUpLim(2).LT.AtmBoxLowLim(2)) + AtmBoxUpLim(2)=AtmBoxLowLim(2) IF (AtmBoxUpLim(3).LT.AtmBoxLowLim(3)) + AtmBoxUpLim(3)=AtmBoxLowLim(3) C DO 120 I = 1,4 DO 110 J = 1,4 PermutRecipSymm(J,I) = 0.0 110 CONTINUE 120 CONTINUE C PermutRecipSymm(1,JX) = 1.0 PermutRecipSymm(2,JY) = 1.0 PermutRecipSymm(3,JZ) = 1.0 PermutRecipSymm(4,4) = 1.0 NAT1 = NINT( 1.5* REAL(Size/8 )) NAT2 = NINT( 1.5* REAL(Size/8 )) C IF (LverboseFlag)WRITE (6,FMT=6000) + Size,NAT2,NAT1,NP1SF,NP2FFT,NP1FFT 6000 FORMAT (///, +' Size for fourier arrays is',I10,/, +' For this Size maximum number of atoms to refine is', + I5,/, +' Maximum number of atoms for genden is ',I5,/, +' Maximum no of electron density sections for ', +'each pass of sfs',I5,/, +' For Fourier ', I5,//, +' Number of H layers per pass ',I5) C ISize2 = Size/2 IF (LverboseFlag) WRITE (6,FMT=6002) NRCSC,NRC60 6002 FORMAT (' IOscratch, RECORD LENGTH ',I5,'NO OF RECORDS ',I5) IF (LverboseFlag) WRITE (6,FMT=6004) NumWords,NRC63 6004 FORMAT (' IOscratch, RECORD LENGTH ',I5,'NO OF RECORDS ',I5) C C ************************************************** CALL QOPEN(IOscratch,'INTP1 ','SCRATCH') CALL QMODE(IOscratch,2,NumBytesItem) CALL FILEO(Size,NP1SF,NP2SF,NRC60,NRCSC) CALL FILEO(Size,NP1FFT,NP2FFT,NRC63,NumWords) C ************************************************** C IF (ISize2.LT.4501) WRITE (6,FMT=6006) ISize2 6006 FORMAT ( + ' PROBLEMS IN GENDEN - GAUSS(4501) OVER PHI(',I4,')') C IN3 = 3*NAT2 IF (IN3.LT.4501) WRITE (6,FMT=6008) IN3 6008 FORMAT (' PROBLEMS IN GENHX - GAUSS(4501) OVER SDXB',I4) IF (NP1SF.GT.0 .AND. NP2SF.GT.0) RETURN CALL CCPERR(1,' ARRAY Size TOO SMALL') 9999 WRITE(6,'(A,3I4)')' Incorrect sampling grid factors',NX,NY,NZ CALL CCPERR(1,' Fatal error.') C END C C ============================================================= SUBROUTINE SOUTFC(X,N1,N2,N3,NSizePassTwo,R,ISLAB,LCYC,IEND) C ============================================================= C C---- X complex is equivalenced to FOFCPH (real). C C---- this calculates fc and phi and writes them over the x array. C C if LWghtModeFlag has been set then C calculate weighting for fourier coefficients to produce an C averaged map for determination of envelope using C wang's algorithm. C tAKEN FROM a.g.w. leslie, imperial college, london C august 1985 C C Uses C LWghtModeFlag, WangSphereRadi (free format) C LWghtModeFlag=1 Use weighting scheme w=1-(r/R) (Wang's method) C LWghtModeFlag=2 Use weighting scheme w=1-(r/R)**2 C WangSphereRadi Radius of averaging sphere (angstroms) C C is the array x(ik,il ih) (ie spacegroups 1 4 and 18,or 1018) C or x(il,ik,ih) 19 145 146 C OR X(IL,KH,1) SGS 92/96 OR 152/154 C C how I hate p2 and r - I think p2 0 no of h layers, r = Hminnow C C---- common block only used for sgs where hkl = kh ... C eg sfrk92 and sfk152 C C .. Parameters .. INTEGER MCOLS PARAMETER (MCOLS=200) C C .. Scalar Arguments .. INTEGER IEND,ISLAB,LCYC,N1,N2,N3,NSizePassTwo,R C .. C .. Array Arguments .. COMPLEX X(N1,N2,N3) C .. C .. Scalars in Common .. REAL AverageBfactor,BfactFpart,BfactorMax,BfactorMin,BfactOverall, + BfactReset,Bsmear,RHmax,RHmean,RHmin,ScaleFcalc,ScaleFpart, + SigmaExclude,Smax,Smin,SSbinSize,TSmax,TSmin,VolMtz, + WangSphereRadi INTEGER Hmax,HmaxA,Hmin,HminA,IXmax,IXmin,IYmax,IYmin,IZmax,IZmin, + Jsec,JU1,JU2,JV1,JV2,KHmin,Kmax,Kmin,LFpartFlag,Lmax,Lmin, + LPhiPartFlag,LWghtModeFlag,NLPRGO,Nslab,NumMultiplicity, + NumSections,NumSFspaceGroup,NumSFsymm,NX,NY,NZ LOGICAL LNoScaleFlag,LverboseFlag C .. C .. Arrays in Common .. REAL CellMtz INTEGER Iuvw C .. C .. Local Scalars .. COMPLEX F REAL A1,ALPH,ALPHA,ASTAR,B1,BET,BETA,BSTAR,C1,CORR,COSAST,COSBST, + COSGST,CSTAR,EPSI,FC,GAMM,GAMMA,PHI,S,SUM,V,WT INTEGER IC,ICHK,IH,IHC,IK,IKC,IKTOT,IL,ILC,ILTOT,IPrintFlag, + ISYSAB,J,K1,KCOUNT,KH,KLFLAG,L1,LDASH,MTZOUT,NK,NL C .. C .. Local Arrays .. REAL AC(6),ADATA(MCOLS),G(2) INTEGER IN(3) C .. C These may not all need saving SAVE AC, ADATA,G, F,ASTAR, BSTAR,CORR,EPSI,FC, PHI,S,WT, + IC,IH,IK,IKTOT,IL,ILTOT,ISYSAB,K1,KCOUNT,KH,KLFLAG,L1, + LDASH,NK,NL C .. External Functions .. REAL RECIPWT EXTERNAL RECIPWT C .. C .. External Subroutines .. EXTERNAL CENTR,EPSLON,LWCLOS,LWREFL,SYSAB C .. C .. Intrinsic Functions .. INTRINSIC ATAN2,COS,EXP,MOD,NINT,SIN,SQRT C .. C .. Common blocks .. COMMON /BFACTS/ + AverageBfactor, + BfactorMin, + BfactorMax, + Bsmear, + BfactReset COMMON /HKLLIM/ + Hmax,Kmax,Lmax,Hmin,Kmin,Lmin,Nslab COMMON /MPHDR/ + NX,NY,NZ, + IXmin,IXmax,IYmin,IYmax,IZmin,IZmax, + Jsec,JU1,JU2,JV1,JV2,Iuvw(3), + NumSFspaceGroup,NumSections, + RHmin,RHmax,RHmean,NumSFsymm, + CellMtz(6),VolMtz,Volfft,F000 COMMON /P41212/ + HminA,HmaxA,KHmin COMMON /SFOUT/ + Smin,Smax,TSmin,TSmax,SSbinSize, + LFpartFlag,LPhiPartFlag,LWghtModeFlag, + ScaleFcalc,ScaleFpart, + SigmaExclude,WangSphereRadi, + BfactOverall,BfactFpart, + NumMultiplicity,NLPRGO COMMON /TERSE/ + LverboseFlag,LNoScaleFlag C .. C .. Equivalences .. EQUIVALENCE (F,G(1)) C .. C ICHK = 0 MTZOUT = 2 IPrintFlag = 1 C IF (IEND.NE.1) THEN IF (R.EQ.Hmin) ISLAB = 0 C C---- if islab gt 0 jump this C IF (LverboseFlag) WRITE (6,FMT=6000) N1,N2,N3,R, + ISLAB,LCYC,IEND, + LWghtModeFlag, + WangSphereRadi 6000 FORMAT (' SOUTfc n1 n2 n3 r islab lcyc iend',7I5,/, + ' LWghtModeFlag WangSphereRadi',I4,F10.3) C IF (ISLAB.LE.0) THEN C C---- array fofc(l k h ) for spacegrooups 19 144 145 C KLFLAG = 1 NL = N1 NK = N2 C C---- array fofc(ldash k h ) for spacegrooups 146 C IF (NumSFspaceGroup.EQ.146 .OR. + NumSFspaceGroup.EQ.147) KLFLAG = 3 C C---- array fofc(l kh ) for spacegrooups p4121 p3121 C IF (NumSFspaceGroup.EQ.92 .OR. + NumSFspaceGroup.EQ.96 .OR. + NumSFspaceGroup.EQ.91 .OR. + NumSFspaceGroup.EQ.95 .OR. + NumSFspaceGroup.EQ.152 .OR. + NumSFspaceGroup.EQ.154) THEN KLFLAG = 2 NL = N1 C C---- array fofc(k l h ) for spacegrooups 1 4 18 C ELSE IF (NumSFspaceGroup.LE.18 .OR. + NumSFspaceGroup.EQ.1018) THEN KLFLAG = 0 NK = N1 NL = N2 END IF C C---- prepare to calculate s C A1 = CellMtz(1) B1 = CellMtz(2) C1 = CellMtz(3) ALPHA = CellMtz(4) BETA = CellMtz(5) GAMMA = CellMtz(6) C C---- We need astar etc to calculate sphere of possible fcs for this sg. C SUM = 0.0 ALPH = 0.017453*ALPHA BET = 0.017453*BETA GAMM = 0.017453*GAMMA SUM = (ALPH+BET+GAMM)*0.5 V = SIN(SUM-ALPH)*SIN(SUM-BET)*SIN(SUM-GAMM) V = 2.0*A1*B1*C1*SQRT(SIN(SUM)*V) ASTAR = B1*C1*SIN(ALPH)/V BSTAR = C1*A1*SIN(BET)/V CSTAR = A1*B1*SIN(GAMM)/V COSAST = (COS(BET)*COS(GAMM)-COS(ALPH))/ + (SIN(BET)*SIN(GAMM)) COSBST = (COS(GAMM)*COS(ALPH)-COS(BET))/ + (SIN(GAMM)*SIN(ALPH)) COSGST = (COS(ALPH)*COS(BET)-COS(GAMM))/ + (SIN(ALPH)*SIN(BET)) AC(1) = ASTAR*ASTAR AC(2) = BSTAR*BSTAR AC(3) = CSTAR*CSTAR AC(4) = 2.0*BSTAR*CSTAR*COSAST AC(5) = 2.0*CSTAR*ASTAR*COSBST AC(6) = 2.0*ASTAR*BSTAR*COSGST C C---- LCYC eq -1 - C program will output h k l fc ac to requested resolution . C Kcount = 0 END IF C C---- Section for lcyc = -1 C IKTOT = Kmax - Kmin + 1 ILTOT = Lmax - Lmin + 1 C DO 30 IHC = 1,NSizePassTwo IH = IHC - 1 + R IF (IH.GT.Hmax) THEN GO TO 40 ELSE DO 20 IKC = 1,IKTOT IK = IKC + Kmin - 1 IF (KLFLAG.NE.2 .OR. IK.LE.IH) THEN K1 = IK + 1 IF (IK.LT.0) K1 = NK + 1 + IK DO 10 ILC = 1,ILTOT IL = ILC + Lmin - 1 C C---- get rid of duplicate reflns for hk0 projection. C Ignore (-)h -k 0 C Now output to be +h +-k 0; 0 +k 0 - input to FFT for P1 C I wont try to fix other projections... C IF (IL.EQ.0) THEN IF (IH.LT.0) THEN GO TO 10 ELSE IF (IH.EQ.0 .AND. IK.LT.0) THEN GO TO 10 END IF END IF C C---- KDC Now we do a real sysab check: C IN(1)=IH IN(2)=IK IN(3)=IL C CALL EPSLON(IN,EPSI,ISYSAB) C IF (EPSI.GT.1.01)CALL SYSAB(IN,ISYSAB) IF (ISYSAB.EQ.1) GOTO 10 C C---- KDC End of sysab check. C C ************ CALL CENTR(IN,IC) C ************ C S = IH*IH*AC(1) + + IK*IK*AC(2) + + IL*IL*AC(3) + + IK*IL*AC(4) + + AC(5)*IL*IH + + AC(6)*IH*IK IF (S.GT.Smin .AND. S.LE.Smax) THEN L1 = IL + 1 IF (IL.LT.0) L1 = NL + 1 + IL C C---- NumSFspaceGroup 19 144 145 C IF (KLFLAG.EQ.1) THEN F = X(L1,K1,IHC) C C---- NumSFspaceGroup 146 C ELSE IF (KLFLAG.EQ.3) THEN LDASH = (IL+3000)/3 - 1000 L1 = LDASH + 1 IF (LDASH.LT.0) L1 = NL + 1 + LDASH F = X(L1,K1,IHC) C C---- NumSFspaceGroup 1 4 18 C ELSE IF (KLFLAG.EQ.0) THEN F = X(K1,L1,IHC) C C---- NumSFspaceGroup 91 92 95 96 152 154 C ELSE IF (KLFLAG.EQ.2) THEN KH = (IH+1)*IH/2 + IK + 1 - KHmin F = X(L1,KH,1) END IF C C---- remember f equivalent to g(2) C multiply fc by NumMultiplicity for non primitive correction C G(1) = G(1)*NumMultiplicity G(2) = -G(2)*NumMultiplicity FC = SQRT(G(1)*G(1)+G(2)*G(2)) PHI = 0.0 IF (FC.GT.0.0001) PHI = ATAN2(G(2),G(1)) Adata(1) = IH Adata(2) = IK Adata(3) = IL CORR = EXP(Bsmear*S/4.0)*ScaleFcalc Adata(4) = (CORR*FC) Adata(5) = (57.2957795*PHI) C C---- NumSFspaceGroup 91 92 95 96 152 154 C---- If a reflection is centric it must be a multiple of 15 C---- For 2 folds: 0 , 180 C---- For 4 folds, 0,180, +,- 90 C---- For 3,6 folds 0 +-30, +-60 etc.. C---For centric reflections, shift PHIC to nearest centric phase C This is phase returned by CENTPHASE or that plus 180 IF (IC.EQ.1) THEN CALL CENTPHASE(IN,CENPHS) PHI = MOD(Adata(5),360.0) IF (ABS(PHI - CENPHS).LE.90 .OR. + ABS(PHI - 360.0 - CENPHS).LE.90) THEN PHI = CENPHS ELSE PHI = CENPHS + 180.0 ENDIF Adata(5) = PHI END IF C IF (LWghtModeFlag.NE.0) THEN S = SQRT(S) WT = RECIPWT(S,WangSphereRadi,LWghtModeFlag) Adata(6) = WT END IF C Kcount = Kcount + 1 ICHK = MOD(Kcount,500) IF (LverboseFlag .AND. ICHK.EQ.0) + WRITE (6,FMT=6004) IH,IK,IL, + (Adata(J),J=4,NLPRGO) C C ******************** CALL LWREFL(MTZOUT,Adata) C ******************** C END IF 10 CONTINUE END IF 20 CONTINUE END IF 30 CONTINUE ISLAB = ISLAB + 1 40 CONTINUE IF (IH.GE.Hmax) CALL LWCLOS(MTZOUT,IPrintFlag) IF (IH.GE.Hmax) IEND = 1 END IF C C---- Format statements C 6004 FORMAT (3I4,10F12.4) C END C C ======================================================= SUBROUTINE SOUTN22(X,N1,N2,NPassTwoSave,IHKA,ISLAB,LCYC, + IEND) C ======================================================== C C This calculates fc and phi and writes them over the x array. C C x complex is equivalenced to fofcph (real). C NP@ = 1 - actually we only USE data up to IHKA. C C .. Parameters .. INTEGER MCOLS PARAMETER (MCOLS=200) C .. Scalar Arguments .. INTEGER IEND,IHKA,ISLAB,LCYC,N1,N2,NPassTwoSave C .. C .. Array Arguments .. COMPLEX X(N1,IHKA,NPassTwoSave) C .. C .. Scalars in Common .. REAL AverageBfactor,BfactFpart,BfactorMax,BfactorMin,BfactOverall, + BfactReset,BfactStartStepSize,Bsmear,RatioShiftTrunc, + RmsBfactor,RmsXyz,ScaleFcalc,ScaleFpart,SFrepeatValue, + SigmaExclude,Smax,Smin,SSbinSize,TH,TSmax,TSmin,W, + WangSphereRadi,XyzStartStepSize INTEGER Hmax,HmaxA,Hmin,HminA,KHmin,Kmax,Kmin,LatomMapFlag, + LBfactRefFlag,LcheckSFspaceGrpFlag,LFpartFlag, + LFreeRexcludeVal,LSFrefFlag,LhklInputFlag,LMapInFlag, + Lmax,Lmin,LPhiPartFlag,LSFcalcFlag,LSFmodeFlag, + LSolvMaskFlag,LWghtModeFlag,LxyzInputFlag,LXyzOutputFlag, + NLPRGO,LrefineCycFlag,Nslab,NtotalRefsUsed,NumMultiplicity LOGICAL LNoScaleFlag,LverboseFlag C .. C .. Arrays in Common .. INTEGER LookUp C .. C .. Local Scalars .. COMPLEX F REAL ALPH,CORR,DUMMY,FC,FC0,FO,PHIC,PHIC0,S,SCnew,SUMD,SUMF, + SUMFCC,SUMFOC INTEGER H,I1,I2,I3,IADD,IC,ICHK,J,JQ,K,KCOUNT,KH,L,L1,MTZIN, + MTZOUT,NUMREFLECTIONSREAD LOGICAL EOF C .. C .. Local Arrays .. REAL ADATA(MCOLS),Bdata(MCOLS),G(2) INTEGER IN(3) LOGICAL LOGMSS(MCOLS),LOGSAVE(MCOLS) C .. C These may not all need saving SAVE F, ALPH,CORR,FC,FC0,FO,PHIC,S,SCnew,SUMFCC, + SUMFOC, H,I1,I2,I3,IADD,IC,ICHK,JQ,K,KCOUNT,L,L1, + NUMREFLECTIONSREAD, ADATA,Bdata,G, IN, SUMD, SUMF C .. External Functions .. REAL RECIPWT EXTERNAL RECIPWT C .. C .. External Subroutines .. EXTERNAL CCPERR,CENTR,EQUAL_MAGIC,LRREFL,LRREFM,LRREWD,LWREFL, + NEWLIN,RESET_MAGIC C .. C .. Intrinsic Functions .. INTRINSIC ABS,ATAN2,COS,EXP,MOD,NINT,SIN,SQRT C .. C .. Common blocks .. COMMON /BFACTS/ + AverageBfactor, + BfactorMin, + BfactorMax, + Bsmear, + BfactReset COMMON /HKLLIM/ + Hmax,Kmax,Lmax,Hmin,Kmin,Lmin,Nslab COMMON /MTZOP/ + Mlook,LookUp(MCOLS) COMMON /P41212/ + HminA,HmaxA,KHmin COMMON /SFOUT/ + Smin,Smax,TSmin,TSmax,SSbinSize, + LFpartFlag,LPhiPartFlag,LWghtModeFlag, + ScaleFcalc,ScaleFpart, + SigmaExclude,WangSphereRadi, + BfactOverall,BfactFpart, + NumMultiplicity,NLPRGO COMMON /SRFCTL/ + NtotalRefsUsed, + RatioShiftTrunc,W,TH, + LSFmodeFlag,LrefineCycFlag,LBfactRefFlag, + LcheckSFspaceGrpFlag,LFreeRexcludeVal, + XyzStartStepSize,BfactStartStepSize, + SFrepeatValue, + RmsXyz,RmsBfactor COMMON /SRFCTL1/ + LSFcalcFlag,LSFrefFlag, + LatomMapFlag,LxyzInputFlag, + LhklInputFlag,LMapInFlag, + LSolvMaskFlag,LXyzOutputFlag COMMON /TERSE/ + LverboseFlag,LNoScaleFlag C .. C .. Equivalences .. EQUIVALENCE (F,G(1)) C .. C IF (LverboseFlag) WRITE (6,FMT=6000) N1,N2,IHKA, + LCYC,IEND 6000 FORMAT (' SOUTN22',8I5) MTZIN = 1 MTZOUT = 2 DUMMY = 0.0 C IF (LverboseFlag) THEN WRITE (6,FMT='(/,a)') + ' Every 500th reflections listed for checking:' IF ( LFreeRexcludeVal.NE.-999 .AND. LFpartFlag.GT.0) + WRITE (6,FMT='(a,a)') +' H K L S Fo SIGFo FreeR Fpart PHIpart ', +'FCatom PHIatom FCtot PHItot' IF ( LFreeRexcludeVal.NE.-999 .AND. LFpartFlag.EQ.0) + WRITE (6,FMT='(a)') +' H K L S Fo SIGFo FreeR FC PHIC ' IF ( LFreeRexcludeVal.EQ.-999 .AND. LFpartFlag.GT.0) + WRITE (6,FMT='(a,a)') +' H K L S Fo SIGFo Fpart PHIpart ', +'FCatom PHIatom FCtot PHItot' IF ( LFreeRexcludeVal.EQ.-999 .AND. LFpartFlag.EQ.0) + WRITE (6,FMT='(a)') +' H K L S Fo SIGFo FC PHIC ' END IF C PHIC0 = 0.0 IF (LSFcalcFlag.EQ.1 .AND. IEND.EQ.1) RETURN IF (KHmin.GT.Hmin) GO TO 10 ISLAB = 0 C 10 CONTINUE C C---- for p21 n1=ny/2+1 n2 = Lmax+1 NSizePassTwo=NPassTwoSave C DO 70 I3 = 1,NPassTwoSave DO 60 I2 = 1,IHKA DO 50 I1 = 1,N1 F = X(I1,I2,I3) C C---- multiply fcs by NumMultiplicity to correct for C possible non-primitive spacegrou C G(1) = G(1)*NumMultiplicity G(2) = -G(2)*NumMultiplicity X(I1,I2,I3) = F 50 CONTINUE 60 CONTINUE 70 CONTINUE C C---- zero Kcounts for r factor C IF (KHmin.GT.Hmin) THEN DO 75 JQ = 1,MCOLS LOGMSS(JQ) = LOGSAVE(JQ) 75 CONTINUE GO TO 110 END IF C C---- new pass through MTZ file C C ****************** IF (LCYC.GT.100) CALL LRREWD(MTZIN) C ****************** C Kcount = 0 NumReflectionsRead = 0 SUMD = 0.0 SUMF = 0.0 SUMFCC = 0.0 SUMFOC = 0.0 C C---- read Title of fobs file C C *********** CALL NEWLIN(6,1) C *********** C C---- if First time through (lcyc=0 or =1) read fobs data C calculate scale and r factor and output fobs file(19) C C NB. fobs file must be sorted into sections on h C (ie. h slowest moving index in input file) C 80 CONTINUE C C ===== Set all BDATA to missing value initially. C ******************************* CALL EQUAL_MAGIC(1,BDATA,MCols) C ******************************* C ************************* CALL LRREFL(MTZIN,S,Adata,EOF) C ************************* C IF (EOF) GO TO 160 CALL LRREFM(MTZIN,LOGMSS) NumReflectionsRead = NumReflectionsRead + 1 C DO 90 JQ = 1,3 IN(JQ) = NINT(Adata(LookUp(JQ))) Bdata(JQ) = Adata(LookUp(JQ)) 90 CONTINUE C C ************ CALL CENTR(IN,IC) C ************ C C---- copy FP SIGFP over C IF(.NOT.LOGMSS(LookUp(4))) Bdata(4) = Adata(LookUp(4)) IF(.NOT.LOGMSS(LookUp(5))) Bdata(5) = Adata(LookUp(5)) C C---- How many extra Bdata needto be found? C Depending on LWghtModeFlag, either nlprgo -3, or nlprgo -2 C Set a few Kcounters C---- This is messy: For SFCALC Bdata will contain a variety of data, C---- for SFREF Bdata will contain H K L FP SIGFP Free FC PHIC IF ( LSFrefFlag .NE.0) then IF(LookUp(6) .GT.0) THEN IF(.NOT.LOGMSS(LookUp(6)) ) Bdata(6) = Adata(LookUp(6)) END IF END IF C IF (LSFcalcFlag.EQ.1) THEN IADD = 6 I1 = IADD C C---- Loop round till you have found enough Bdata C 101 CONTINUE IF (IADD.GT.Mlook) GO TO 100 IF (LookUp(I1) .NE.0)THEN IF(.NOT.LOGMSS(LookUp(I1)))Bdata(IADD) = Adata(LookUp(I1)) IADD = IADD + 1 END IF I1 = I1 + 1 IF (I1 .LE. MCOLS) GO TO 101 100 CONTINUE END IF C IF (IN(1).LT.Hmin) GO TO 80 110 H = IN(1) K = IN(2) L = IN(3) IF (H.GT.Hmax) IEND = 1 IF (IEND.EQ.1) GO TO 170 IF (H.GT.HmaxA) GO TO 220 L1 = L + 1 IF (L.GT.Lmax .OR. L.LT.Lmin) GO TO 80 IF (K.GT.Kmax .OR. K.LT.Kmin) GO TO 80 C C---- not needed if k>=0 l>=0 C IF (L.LT.0) L1 = N1 + 1 + L KH = (H+1)*H/2 + K + 1 - KHmin IF (S.LT.Smin .OR. S.GT.Smax) GO TO 80 FO = 0.0 IF(.NOT.LOGMSS(Lookup(4))) FO = Bdata(4) C C---- remember x equivalent to fofcph C read in fc from x C CORR = EXP(Bsmear*S/4.0) F = X(L1,KH,1) C C---- G2) equivalenced to F C FC = SQRT(G(1)*G(1)+G(2)*G(2)) PHIC = 0.0 IF (FC.GT.0.0001) PHIC = 57.2957795*ATAN2(G(2),G(1)) IF (LFpartFlag.EQ.0) GO TO 120 IF (LOGMSS(Lookup(7)) .OR. LOGMSS(Lookup(8))) THEN IF (LOGMSS(Lookup(7)) .NEQV. LOGMSS(Lookup(8))) CALL CCPERR(1, + ' *** ERROR; either FPART/PHIP=MNF but other is not ***') GOTO 120 ENDIF FC0 = FC PHIC0 = PHIC ALPH = Adata(LookUp(8))/57.2957795 G(1) = Adata(Lookup(7))*ScaleFpart*EXP(-BfactFpart*S/4.0)* + COS(ALPH)/CORR + G(1) G(2) = Adata(Lookup(7))*ScaleFpart*EXP(-BfactFpart*S/4.0)* + SIN(ALPH)/CORR + G(2) FC = SQRT(G(1)*G(1)+G(2)*G(2)) PHIC = 0.0 IF (FC.GT.0.0001) PHIC = 57.2957795*ATAN2(G(2),G(1)) 120 CONTINUE C C IF (NumSFspaceGroup.EQ.91) LcheckSFspaceGrpFlag = 5 C IF (NumSFspaceGroup.EQ.92) LcheckSFspaceGrpFlag = 5 C IF (NumSFspaceGroup.EQ.95) LcheckSFspaceGrpFlag = 5 C IF (NumSFspaceGroup.EQ.96) LcheckSFspaceGrpFlag = 5 C IF (NumSFspaceGroup.EQ.152) LcheckSFspaceGrpFlag = 8 C IF (NumSFspaceGroup.EQ.154) LcheckSFspaceGrpFlag = 8 C---- If a reflection is centric and LcheckSFspaceGrpFlag = 5 C it must be a multiple of 45 C---- If a reflection is centric and LcheckSFspaceGrpFlag = 8 C it must be a multiple of 30 C---For centric reflections, shift PHIC to nearest centric phase C This is phase returned by CENTPHASE or that plus 180 IF (IC.EQ.1) THEN CALL CENTPHASE(IN,CENPHS) PHIC = MOD(PHIC,360.0) IF (ABS(PHIC - CENPHS).LE.90 .OR. + ABS(PHIC - 360.0 - CENPHS).LE.90) THEN PHIC = CENPHS ELSE PHIC = CENPHS + 180.0 ENDIF END IF C---- Apply CORR for Bsmear now. C Do not rescale FC for output C FC = CORR*FC C---- KDC include wangwt C IF (LWghtModeFlag.GT.0) THEN Bdata(NLPRGO-2) = FC Bdata(NLPRGO-1) = PHIC Bdata(NLPRGO) = RECIPWT(S,WangSphereRadi,LWghtModeFlag) ELSE Bdata(NLPRGO-1) = FC Bdata(NLPRGO) = PHIC ENDIF C C---- KDC OK now C---- Remove missing data from scale calc., old and new test. C FC = ScaleFcalc*FC IF(.NOT.LOGMSS(LOOKUP(4))) THEN IF (BDATA(4) .GT. 0.0) THEN SUMD = ABS(FO-FC) + SUMD SUMF = SUMF + FO SUMFCC = FC*FC + SUMFCC SUMFOC = FO*FC + SUMFOC Kcount = Kcount + 1 ENDIF END IF C C---- write out file with fobs and fcalc (if lcyc=0) C C ******************* CALL LWREFL(MTZOUT,Bdata) C ******************* C ICHK = MOD(Kcount-1,500) C IF (LverboseFlag .AND. ICHK.EQ.0 ) THEN CALL RESET_MAGIC(MTZOUT,Adata,Bdata,Mcols,DUMMY,-999.0) IF ( LFreeRexcludeVal.NE.-999)THEN IF ( LFpartFlag.GT.0) WRITE (6,FMT= + '(3i4,F7.4,2x,f8.1,f6.1,f8.1,2f6.0,2x,2(f8.1,f6.0))') + IN,S, (Bdata(LookUp(J)),J=4,8),FC0, + PHIC0,FC,PHIC IF ( LFpartFlag.EQ.0) + WRITE (6,FMT='(3I4,F7.4,2x,F8.1,2f6.1,f8.1,f6.0)') + IN,S, (Bdata(LookUp(J)),J=4,6),FC,PHIC END IF C C---- no freer C IF ( LFreeRexcludeVal.EQ.-999)THEN IF ( LFpartFlag.GT.0) WRITE (6, + FMT='(3i4,F7.4,2x,f8.1,f8.1,2f6.0,2x,2(f8.1,f6.0))') + IN,S, (Bdata(LookUp(J)),J=4,5),(Bdata(LookUp(J)),J=7,8),FC0, + PHIC0,FC,PHIC IF ( LFpartFlag.EQ.0) + WRITE (6,FMT='(3I4,F7.4,2x,F8.1,f6.1,f8.1,f6.0)') + IN,S, (Bdata(LookUp(J)),J=4,5),FC,PHIC END IF END IF C C GO TO 80 160 IEND = 1 170 CONTINUE C C---- 2nd pass of unrestrained refinement - DO NOT reset scales!! C EJD April 1991 C IF (LCYC.GT.100) GO TO 220 SCnew = ScaleFcalc*SUMFOC/SUMFCC WRITE (6,FMT=6002) + Kcount,NumReflectionsRead,ScaleFcalc,SCnew ScaleFcalc = SCnew 6002 FORMAT (/, +' Number of reflections used = ',I8,/, +' Number of reflns. on file = ',I9,/, +' Old value of SCALE is = ',F13.3,/, +' New value of SCALE is = ',F13.3,/) C 220 ISLAB = ISLAB + 1 C C---- keep LOGMSS for next block C DO 225 JQ = 1,MCOLS LOGSAVE(JQ) = LOGMSS(JQ) 225 CONTINUE C C---- write fcal file(20) from fofcph(1) C IF (LCYC.GT.100 .AND. ISLAB.EQ.Nslab) IEND = 1 END C C ===================================================== SUBROUTINE SOUTR3(X,N1,N2,NPassTwoSave,NSizePassTwo,R, + ISLAB,LCYC,IEND) C ===================================================== C C This calculates fc and phi and writes them over the x array. C C x complex is equivalenced to fofcph (real). C C .. Parameters .. INTEGER MCOLS PARAMETER (MCOLS=200) C .. Scalar Arguments .. INTEGER IEND,ISLAB,LCYC,N1,N2,NPassTwoSave,NSizePassTwo,R C .. C .. Array Arguments .. COMPLEX X(N1,N2,NPassTwoSave) C .. C .. Scalars in Common .. REAL AverageBfactor,BfactFpart,BfactorMax,BfactorMin,BfactOverall, + BfactReset,BfactStartStepSize,Bsmear,RatioShiftTrunc, + RmsBfactor,RmsXyz,ScaleFcalc,ScaleFpart,SFrepeatValue, + SigmaExclude,Smax,Smin,SSbinSize,TH,TSmax,TSmin,W, + WangSphereRadi,XyzStartStepSize INTEGER Hmax,Hmin,Kmax,Kmin,LatomMapFlag,LBfactRefFlag, + LcheckSFspaceGrpFlag,LFpartFlag,LFreeRexcludeVal, + LSFrefFlag,LhklInputFlag,LMapInFlag,Lmax,Lmin, + LPhiPartFlag,LSFcalcFlag,LSFmodeFlag,LSolvMaskFlag, + LWghtModeFlag,LxyzInputFlag,LXyzOutputFlag,NLPRGO, + LrefineCycFlag,Nslab,NtotalRefsUsed,NumMultiplicity LOGICAL LNoScaleFlag,LverboseFlag C .. C .. Arrays in Common .. INTEGER LookUp C .. C .. Local Scalars .. COMPLEX F REAL ALPH,CORR,DUMMY,FC,FC0,FO,PHIC,PHIC0,S,SCnew,SUMD,SUMF, + SUMFCC,SUMFOC INTEGER H,I1,I2,I3,IADD,IC,ICHK,IH1,J,JQ,K,K1,KCOUNT,L,L1,LDASH, + MTZIN,MTZOUT,NUMREFLECTIONSREAD LOGICAL EOF C .. C .. Local Arrays .. REAL ADATA(MCOLS),Bdata(MCOLS),G(2) INTEGER IN(3) LOGICAL LOGMSS(MCOLS),LOGSAVE(MCOLS) C .. C These may not all need saving SAVE F, ALPH,CORR,FC,FC0,FO,PHIC,S,SCnew,SUMFCC, + SUMFOC, H,I1,I2,I3,IADD,IC,ICHK,IH1,JQ,K,K1,KCOUNT,L,L1, + LDASH,NUMREFLECTIONSREAD, ADATA,Bdata,G, IN, SUMD, SUMF C .. External Functions .. REAL RECIPWT EXTERNAL RECIPWT C .. C .. External Subroutines .. EXTERNAL CCPERR,CENTR,EQUAL_MAGIC,LRREFL,LRREFM,LRREWD,LWREFL, + NEWLIN,RESET_MAGIC C .. C .. Intrinsic Functions .. INTRINSIC ABS,ATAN2,COS,EXP,MOD,NINT,SIN,SQRT C .. C .. Common blocks .. COMMON /BFACTS/ + AverageBfactor, + BfactorMin, + BfactorMax, + Bsmear, + BfactReset COMMON /HKLLIM/ + Hmax,Kmax,Lmax,Hmin,Kmin,Lmin,Nslab COMMON /MTZOP/ + Mlook,LookUp(MCOLS) COMMON /SFOUT/ + Smin,Smax,TSmin,TSmax,SSbinSize, + LFpartFlag,LPhiPartFlag,LWghtModeFlag, + ScaleFcalc,ScaleFpart, + SigmaExclude,WangSphereRadi, + BfactOverall,BfactFpart, + NumMultiplicity,NLPRGO COMMON /SRFCTL/ + NtotalRefsUsed, + RatioShiftTrunc,W,TH, + LSFmodeFlag,LrefineCycFlag,LBfactRefFlag, + LcheckSFspaceGrpFlag,LFreeRexcludeVal, + XyzStartStepSize,BfactStartStepSize, + SFrepeatValue, + RmsXyz,RmsBfactor COMMON /SRFCTL1/ + LSFcalcFlag,LSFrefFlag, + LatomMapFlag,LxyzInputFlag, + LhklInputFlag,LMapInFlag, + LSolvMaskFlag,LXyzOutputFlag COMMON /TERSE/ + LverboseFlag,LNoScaleFlag C .. C .. Equivalences .. EQUIVALENCE (F,G(1)) C .. C IF (LverboseFlag) WRITE (6,FMT=6000) N1,N2,NPassTwoSave, + NSizePassTwo,R,LCYC,IEND 6000 FORMAT (' SOUTZ',8I5) MTZIN = 1 MTZOUT = 2 DUMMY = 0.0 C IF (LverboseFlag) THEN WRITE (6,FMT='(/,a)') + ' Every 500th reflections listed for checking:' IF ( LFreeRexcludeVal.NE.-999 .AND. LFpartFlag.GT.0) + WRITE (6,FMT='(a,a)') +' H K L S Fo SIGFo FreeR Fpart PHIpart ', +'FCatom PHIatom FCtot PHItot' IF ( LFreeRexcludeVal.NE.-999 .AND. LFpartFlag.EQ.0) + WRITE (6,FMT='(a)') +' H K L S Fo SIGFo FreeR FC PHIC ' IF ( LFreeRexcludeVal.EQ.-999 .AND. LFpartFlag.GT.0) + WRITE (6,FMT='(a,a)') +' H K L S Fo SIGFo Fpart PHIpart ', +'FCatom PHIatom FCtot PHItot' IF ( LFreeRexcludeVal.EQ.-999 .AND. LFpartFlag.EQ.0) + WRITE (6,FMT='(a)') +' H K L S Fo SIGFo FC PHIC ' END IF C PHIC0 = 0.0 IF (LSFcalcFlag.EQ.1 .AND. IEND.EQ.1) RETURN IF (R.GT.Hmin) GO TO 10 ISLAB = 0 C 10 CONTINUE C C---- for p21 n1=ny/2+1 n2 = Lmax+1 NSizePassTwo=NPassTwoSave C C NSizePassTwo=NPassTwoSave C DO 70 I3 = 1,NPassTwoSave DO 60 I2 = 1,N2 DO 50 I1 = 1,N1 F = X(I1,I2,I3) C C---- multiply fcs by NumMultiplicity to correct for C possible non-primitive spacegrou C G(1) = G(1)*NumMultiplicity G(2) = -G(2)*NumMultiplicity X(I1,I2,I3) = F 50 CONTINUE 60 CONTINUE 70 CONTINUE C C---- zero Kcounts for r factor C IF (R.GT.Hmin) THEN DO 75 JQ = 1,MCOLS LOGMSS(JQ) = LOGSAVE(JQ) 75 CONTINUE GO TO 110 END IF C C---- new pass through MTZ file C C ****************** IF (LCYC.GT.100) CALL LRREWD(MTZIN) C ****************** C Kcount = 0 NumReflectionsRead = 0 SUMD = 0.0 SUMF = 0.0 SUMFCC = 0.0 SUMFOC = 0.0 C C---- read Title of fobs file C C *********** CALL NEWLIN(6,1) C *********** C C---- if First time through (lcyc=0 or =1) read fobs data C calculate scale and r factor and output fobs file(19) C C NB. fobs file must be sorted into sections on h C (ie. h slowest moving index in input file) C 80 CONTINUE C C ===== Set all BDATA to missing value initially. C ******************************* CALL EQUAL_MAGIC(1,BDATA,MCols) C ******************************* C ************************* CALL LRREFL(MTZIN,S,Adata,EOF) C ************************* C IF (EOF) GO TO 160 CALL LRREFM(MTZIN,LOGMSS) NumReflectionsRead = NumReflectionsRead + 1 C DO 90 JQ = 1,3 IN(JQ) = NINT(Adata(LookUp(JQ))) Bdata(JQ) = Adata(LookUp(JQ)) 90 CONTINUE C C ************ CALL CENTR(IN,IC) C ************ C C---- copy FP SIGFP over C IF(.NOT.LOGMSS(LookUp(4))) Bdata(4) = Adata(LookUp(4)) IF(.NOT.LOGMSS(LookUp(5))) Bdata(5) = Adata(LookUp(5)) C C---- How many extra Bdata needto be found? C Depending on LWghtModeFlag, either nlprgo -3, or nlprgo -2 C Set a few Kcounters C---- This is messy: For SFCALC Bdata will contain a variety of data, C---- for SFREF Bdata will contain H K L FP SIGFP Free FC PHIC C IF ( LSFrefFlag .NE.0) then IF(LookUp(6) .GT.0) THEN IF(.NOT.LOGMSS(LookUp(6)) ) Bdata(6) = Adata(LookUp(6)) END IF END IF C IF (LSFcalcFlag.EQ.1) THEN IADD = 6 I1 = IADD C C---- Loop round till you have found enough Bdata 101 CONTINUE IF (IADD.GT.Mlook) GO TO 100 IF (LookUp(I1) .NE.0)THEN IF(.NOT.LOGMSS(LookUp(I1)))Bdata(IADD) = Adata(LookUp(I1)) IADD = IADD + 1 END IF I1 = I1 + 1 IF (I1 .LE. MCOLS) GO TO 101 100 CONTINUE END IF C IF (IN(1).LT.Hmin) GO TO 80 110 H = IN(1) K = IN(2) L = IN(3) IF (H.GT.Hmax) IEND = 1 IF (IEND.EQ.1) GO TO 170 LDASH = (L+3000)/3 - 1000 IF (H.GE.R+NSizePassTwo) GO TO 220 L1 = LDASH + 1 K1 = K + 1 IF (L.GT.Lmax .OR. L.LT.Lmin) GO TO 80 IF (K.GT.Kmax .OR. K.LT.Kmin) GO TO 80 C C---- not needed if k>=0 l>=0 C IF (K.LT.0) K1 = N2 + 1 + K IF (LDASH.LT.0) L1 = N1 + 1 + LDASH IH1 = H - R + 1 IF (S.LT.Smin .OR. S.GT.Smax) GO TO 80 FO = 0.0 IF(.NOT.LOGMSS(Lookup(4))) FO = Bdata(4) C C---- remember x equivalent to fofcph C read in fc from x C CORR = EXP(Bsmear*S/4.0) F = X(L1,K1,IH1) FC = SQRT(G(1)*G(1)+G(2)*G(2)) PHIC = 0.0 IF (FC.GT.0.0001) PHIC = 57.2957795*ATAN2(G(2),G(1)) C IF (LFpartFlag.EQ.0) GO TO 120 IF (LOGMSS(Lookup(7)) .OR. LOGMSS(Lookup(8))) THEN IF (LOGMSS(Lookup(7)) .NEQV. LOGMSS(Lookup(8))) CALL CCPERR(1, + ' *** ERROR; either FPART/PHIP=MNF but other is not ***') GOTO 120 ENDIF FC0 = FC PHIC0 = PHIC ALPH = Adata(LookUp(8))/57.2957795 G(1) = Adata(Lookup(7))*ScaleFpart*EXP(-BfactFpart*S/4.0)* + COS(ALPH)/CORR + G(1) G(2) = Adata(Lookup(7))*ScaleFpart*EXP(-BfactFpart*S/4.0)* + SIN(ALPH)/CORR + G(2) FC = SQRT(G(1)*G(1)+G(2)*G(2)) PHIC = 0.0 IF (FC.GT.0.0001) PHIC = 57.2957795*ATAN2(G(2),G(1)) 120 CONTINUE C C---- If a reflection is centric it must be a multiple of 30 C C---For centric reflections, shift PHIC to nearest centric phase C This is phase returned by CENTPHASE or that plus 180 IF (IC.EQ.1) THEN CALL CENTPHASE(IN,CENPHS) PHIC = MOD(PHIC,360.0) IF (ABS(PHIC - CENPHS).LE.90 .OR. + ABS(PHIC - 360.0 - CENPHS).LE.90) THEN PHIC = CENPHS ELSE PHIC = CENPHS + 180.0 ENDIF END IF C C C---- Apply CORR for Bsmear now. C Do not rescale FC for output C FC = CORR*FC C---- KDC include wangwt C IF (LWghtModeFlag.GT.0) THEN Bdata(NLPRGO-2) = FC Bdata(NLPRGO-1) = PHIC Bdata(NLPRGO) = RECIPWT(S,WangSphereRadi,LWghtModeFlag) ELSE Bdata(NLPRGO-1) = FC Bdata(NLPRGO) = PHIC ENDIF C C---- KDC OK now C---- Remove missing data from scale calc., old and new test. C FC = ScaleFcalc*FC IF(.NOT.LOGMSS(LOOKUP(4))) THEN IF (BDATA(4) .GT. 0.0) THEN SUMD = ABS(FO-FC) + SUMD SUMF = SUMF + FO SUMFCC = FC*FC + SUMFCC SUMFOC = FO*FC + SUMFOC Kcount = Kcount + 1 ENDIF END IF C C---- write out file with fobs and fcalc (if lcyc=0) C C ******************* CALL LWREFL(MTZOUT,Bdata) C ******************* ICHK = MOD(Kcount-1,500) C IF (LverboseFlag .AND. ICHK.EQ.0 ) THEN CALL RESET_MAGIC(MTZOUT,Adata,Bdata,Mcols,DUMMY,-999.0) IF ( LFreeRexcludeVal.NE.-999)THEN IF ( LFpartFlag.GT.0) WRITE (6,FMT= + '(3i4,F7.4,2x,f8.1,f6.1,f8.1,2f6.0,2x,2(f8.1,f6.0))') + IN,S, (Bdata(LookUp(J)),J=4,8),FC0, + PHIC0,FC,PHIC IF ( LFpartFlag.EQ.0) + WRITE (6,FMT='(3I4,F7.4,2x,F8.1,2f6.1,f8.1,f6.0)') + IN,S, (Bdata(LookUp(J)),J=4,6),FC,PHIC END IF C C---- no freer C IF ( LFreeRexcludeVal.EQ.-999)THEN IF ( LFpartFlag.GT.0) WRITE (6, + FMT='(3i4,F7.4,2x,f8.1,f8.1,2f6.0,2x,2(f8.1,f6.0))') + IN,S, (Bdata(LookUp(J)),J=4,5),(Bdata(LookUp(J)),J=7,8),FC0, + PHIC0,FC,PHIC IF ( LFpartFlag.EQ.0) + WRITE (6,FMT='(3I4,F7.4,2x,F8.1,f6.1,f8.1,f6.0)') + IN,S, (Bdata(LookUp(J)),J=4,5),FC,PHIC END IF END IF C GO TO 80 160 IEND = 1 170 CONTINUE C C---- 2nd pass of unrestrained refinement - DO NOT reset scales!! C EJD April 1991 C IF (LCYC.GT.100) GO TO 220 SCnew = ScaleFcalc*SUMFOC/SUMFCC WRITE (6,FMT=6002) + Kcount,NumReflectionsRead,ScaleFcalc,SCnew ScaleFcalc = SCnew 6002 FORMAT (/, +' Number of reflections used = ',I8,/, +' Number of reflns. on file = ',I9,/, +' Old value of SCALE is = ',F13.3,/, +' New value of SCALE is = ',F13.3,/) 220 ISLAB = ISLAB + 1 C C---- keep LOGMSS for next block C DO 225 JQ = 1,MCOLS LOGSAVE(JQ) = LOGMSS(JQ) 225 CONTINUE IF (LCYC.GT.100 .AND. ISLAB.EQ.Nslab) IEND = 1 END C C ==================================================== SUBROUTINE SOUTY(X,N1,N2,NPassTwoSave,NSizePassTwo,R, + ISLAB,LCYC,IEND) C ==================================================== C C This calculates fc and phi and writes them over the x array. C C x complex is equivalenced to fofcph (real). C C .. Parameters .. INTEGER MCOLS PARAMETER (MCOLS=200) C .. Scalar Arguments .. INTEGER IEND,ISLAB,LCYC,N1,N2,NPassTwoSave,NSizePassTwo,R C .. C .. Array Arguments .. COMPLEX X(N1,N2,NPassTwoSave) C .. C .. Scalars in Common .. REAL AverageBfactor,BfactFpart,BfactorMax,BfactorMin,BfactOverall, + BfactReset,BfactStartStepSize,Bsmear,RatioShiftTrunc, + RmsBfactor,RmsXyz,ScaleFcalc,ScaleFpart,SFrepeatValue, + SigmaExclude,Smax,Smin,SSbinSize,TH,TSmax,TSmin,W, + WangSphereRadi,XyzStartStepSize INTEGER Hmax,Hmin,Kmax,Kmin,LatomMapFlag,LBfactRefFlag, + LcheckSFspaceGrpFlag,LFpartFlag,LFreeRexcludeVal, + LSFrefFlag,LhklInputFlag,LMapInFlag,Lmax,Lmin, + LPhiPartFlag,LSFcalcFlag,LSFmodeFlag,LSolvMaskFlag, + LWghtModeFlag,LxyzInputFlag,LXyzOutputFlag,NLPRGO, + LrefineCycFlag,Nslab,NtotalRefsUsed,NumMultiplicity LOGICAL LNoScaleFlag,LverboseFlag C .. C .. Arrays in Common .. INTEGER LookUp C .. C .. Local Scalars .. COMPLEX F REAL ALPH,CORR,DUMMY,FC,FC0,FO,PHIC,PHIC0,S,SCnew,SUMD,SUMF, + SUMFCC,SUMFOC INTEGER H,I1,I2,I3,IADD,IC,ICHK,IH1,J,JQ,K,K1,KCOUNT,L,L1,MTZIN, + MTZOUT,NUMREFLECTIONSREAD LOGICAL EOF C .. C .. Local Arrays .. REAL ADATA(MCOLS),Bdata(MCOLS),G(2) INTEGER IN(3) LOGICAL LOGMSS(MCOLS),LOGSAVE(MCOLS) C .. C These may not all need saving SAVE F, ALPH,CORR,FC,FC0,FO,PHIC,S,SCnew,SUMFCC, + SUMFOC, H,I1,I2,I3,IADD,IC,ICHK,IH1,JQ,K,K1,KCOUNT,L,L1, + NUMREFLECTIONSREAD, ADATA,Bdata,G, IN, SUMD, SUMF C .. External Functions .. REAL RECIPWT EXTERNAL RECIPWT C .. C .. External Subroutines .. EXTERNAL CCPERR,CENTR,EQUAL_MAGIC,LRREFL,LRREFM,LRREWD,LWREFL, + NEWLIN,RESET_MAGIC C .. C .. Intrinsic Functions .. INTRINSIC ABS,ATAN2,COS,EXP,MOD,NINT,SIN,SQRT C .. C .. Common blocks .. COMMON /BFACTS/ + AverageBfactor, + BfactorMin, + BfactorMax, + Bsmear, + BfactReset COMMON /HKLLIM/ + Hmax,Kmax,Lmax,Hmin,Kmin,Lmin,Nslab COMMON /MTZOP/ + Mlook,LookUp(MCOLS) COMMON /SFOUT/ + Smin,Smax,TSmin,TSmax,SSbinSize, + LFpartFlag,LPhiPartFlag,LWghtModeFlag, + ScaleFcalc,ScaleFpart, + SigmaExclude,WangSphereRadi, + BfactOverall,BfactFpart, + NumMultiplicity,NLPRGO COMMON /SRFCTL/ + NtotalRefsUsed, + RatioShiftTrunc,W,TH, + LSFmodeFlag,LrefineCycFlag,LBfactRefFlag, + LcheckSFspaceGrpFlag,LFreeRexcludeVal, + XyzStartStepSize,BfactStartStepSize, + SFrepeatValue, + RmsXyz,RmsBfactor COMMON /SRFCTL1/ + LSFcalcFlag,LSFrefFlag, + LatomMapFlag,LxyzInputFlag, + LhklInputFlag,LMapInFlag, + LSolvMaskFlag,LXyzOutputFlag COMMON /TERSE/ + LverboseFlag,LNoScaleFlag C .. C .. Equivalences .. EQUIVALENCE (F,G(1)) C .. C IF (LverboseFlag) WRITE (6,FMT=6000) N1,N2, + NPassTwoSave,NSizePassTwo,R,LCYC,IEND 6000 FORMAT (' SOUT18',8I5) MTZIN = 1 MTZOUT = 2 DUMMY = 0.0 C IF (LverboseFlag) THEN WRITE (6,FMT='(/,a)') + ' Every 500th reflections listed for checking:' IF ( LFreeRexcludeVal.NE.-999 .AND. LFpartFlag.GT.0) + WRITE (6,FMT='(a,a)') + ' H K L S Fo SIGFo FreeR Fpart PHIpart ', + 'FCatom PHIatom FCtot PHItot' IF ( LFreeRexcludeVal.NE.-999 .AND. LFpartFlag.EQ.0) + WRITE (6,FMT='(a)') + ' H K L S Fo SIGFo FreeR FC PHIC ' IF ( LFreeRexcludeVal.EQ.-999 .AND. LFpartFlag.GT.0) + WRITE (6,FMT='(a,a)') + ' H K L S Fo SIGFo Fpart PHIpart ', + 'FCatom PHIatom FCtot PHItot' IF ( LFreeRexcludeVal.EQ.-999 .AND. LFpartFlag.EQ.0) + WRITE (6,FMT='(a)') + ' H K L S Fo SIGFo FC PHIC ' END IF C PHIC0 = 0.0 IF (LSFcalcFlag.EQ.1 .AND. IEND.EQ.1) RETURN IF (R.GT.Hmin) GO TO 10 ISLAB = 0 C 10 CONTINUE C C---- for p21 n1=ny/2+1 n2 = Lmax+1 NSizePassTwo=NPassTwoSave C DO 70 I3 = 1,NPassTwoSave DO 60 I2 = 1,N2 DO 50 I1 = 1,N1 F = X(I1,I2,I3) C C---- multiply fcs by NumMultiplicity to correct for C possible non-primitive spacegrou C G(1) = G(1)*NumMultiplicity G(2) = -G(2)*NumMultiplicity X(I1,I2,I3) = F 50 CONTINUE 60 CONTINUE 70 CONTINUE C C---- zero Kcounts for r factor C IF (R.GT.Hmin) THEN DO 75 JQ = 1,MCOLS LOGMSS(JQ) = LOGSAVE(JQ) 75 CONTINUE GO TO 110 END IF C C---- new pass through MTZ file C C ****************** IF (LCYC.GT.100) CALL LRREWD(MTZIN) C ****************** C Kcount = 0 NumReflectionsRead = 0 SUMD = 0.0 SUMF = 0.0 SUMFCC = 0.0 SUMFOC = 0.0 C C---- read Title of fobs file C C *********** CALL NEWLIN(6,1) C *********** C C---- if First time through (lcyc=0 or =1) read fobs data C calculate scale and r factor and output fobs file(19) C C NB. fobs file must be sorted into sections on h C (ie. h slowest moving index in input file) C 80 CONTINUE C C ===== Set all BDATA to missing value initially. C ******************************* CALL EQUAL_MAGIC(1,BDATA,MCols) C ******************************* C ************************* CALL LRREFL(MTZIN,S,Adata,EOF) C ************************* C IF (EOF) GO TO 160 CALL LRREFM(MTZIN,LOGMSS) NumReflectionsRead = NumReflectionsRead + 1 C DO 90 JQ = 1,3 IN(JQ) = NINT(Adata(LookUp(JQ))) Bdata(JQ) = Adata(LookUp(JQ)) 90 CONTINUE C C ************ CALL CENTR(IN,IC) C ************ C C---- copy FP SIGFP over C IF(.NOT.LOGMSS(LookUp(4))) Bdata(4) = Adata(LookUp(4)) IF(.NOT.LOGMSS(LookUp(5))) Bdata(5) = Adata(LookUp(5)) C C---- How many extra Bdata needto be found? C Depending on LWghtModeFlag, either nlprgo -3, or nlprgo -2 C Set a few Kcounters C---- This is messy: For SFCALC Bdata will contain a variety of data, C---- for SFREF Bdata will contain H K L FP SIGFP Free FC PHIC IF ( LSFrefFlag .NE.0) then IF(LookUp(6) .GT.0) THEN IF(.NOT.LOGMSS(LookUp(6)) ) Bdata(6) = Adata(LookUp(6)) END IF END IF C IF (LSFcalcFlag.EQ.1) THEN IADD = 6 I1 = IADD C C---- Loop round till you have found enough Bdata C 101 CONTINUE IF (IADD.GT.Mlook) GO TO 100 IF (LookUp(I1) .NE.0)THEN IF(.NOT.LOGMSS(LookUp(I1)))Bdata(IADD) = Adata(LookUp(I1)) IADD = IADD + 1 END IF I1 = I1 + 1 IF (I1 .LE. MCOLS) GO TO 101 100 CONTINUE END IF C IF (IN(1).LT.Hmin) GO TO 80 110 H = IN(1) K = IN(2) L = IN(3) IF (H.GT.Hmax) IEND = 1 IF (IEND.EQ.1) GO TO 170 C IF (H.GE.R+NSizePassTwo) GO TO 220 L1 = L + 1 K1 = K + 1 IF (L.GT.Lmax .OR. L.LT.Lmin) GO TO 80 IF (K.GT.Kmax .OR. K.LT.Kmin) GO TO 80 C C---- not needed if k>=0 l>=0 C IF (K.LT.0) K1 = N1 + 1 + K IF (L.LT.0) L1 = N2 + 1 + L IH1 = H - R + 1 IF (S.LT.Smin .OR. S.GT.Smax) GO TO 80 FO = 0.0 IF(.NOT.LOGMSS(Lookup(4))) FO = Bdata(4) C C---- remember x equivalent to fofcph C read in fc from x C CORR = EXP(Bsmear*S/4.0) F = X(K1,L1,IH1) C C---- G(2) equivalenced to F - Now G(1) = FCreal G(2) = FCimag C FC = SQRT(G(1)*G(1)+G(2)*G(2)) PHIC = 0.0 IF (FC.GT.0.0001) PHIC = 57.2957795*ATAN2(G(2),G(1)) IF (LFpartFlag.EQ.0) GO TO 120 IF (LOGMSS(Lookup(7)) .OR. LOGMSS(Lookup(8))) THEN IF (LOGMSS(Lookup(7)) .NEQV. LOGMSS(Lookup(8))) CALL CCPERR(1, + ' *** ERROR; either FPART/PHIP=MNF but other is not ***') GOTO 120 ENDIF FC0 = FC PHIC0 = PHIC ALPH = Adata(LookUp(8))/57.2957795 G(1) = Adata(Lookup(7))*ScaleFpart*EXP(-BfactFpart*S/4.0)* + COS(ALPH)/CORR + G(1) G(2) = Adata(Lookup(7))*ScaleFpart*EXP(-BfactFpart*S/4.0)* + SIN(ALPH)/CORR + G(2) FC = SQRT(G(1)*G(1)+G(2)*G(2)) PHIC = 0.0 IF (FC.GT.0.0001) PHIC = 57.2957795*ATAN2(G(2),G(1)) 120 CONTINUE C C---- If a reflection is centric it must be at least a multiple of 15 C---For centric reflections, shift PHIC to nearest centric phase C This is phase returned by CENTPHASE or that plus 180 IF (IC.EQ.1) THEN CALL CENTPHASE(IN,CENPHS) PHIC = MOD(PHIC,360.0) IF (ABS(PHIC - CENPHS).LE.90 .OR. + ABS(PHIC - 360.0 - CENPHS).LE.90) THEN PHIC = CENPHS ELSE PHIC = CENPHS + 180.0 ENDIF END IF C C---- Apply CORR for Bsmear now. C Do not rescale FC for output C FC = CORR* FC C---- KDC include wangwt C IF (LWghtModeFlag.GT.0) THEN Bdata(NLPRGO-2) = FC Bdata(NLPRGO-1) = PHIC Bdata(NLPRGO) = RECIPWT(S,WangSphereRadi,LWghtModeFlag) ELSE Bdata(NLPRGO-1) = FC Bdata(NLPRGO) = PHIC ENDIF C C---- KDC OK now C---- Remove missing data from scale calc. C FC = ScaleFcalc* FC IF(.NOT.LOGMSS(LOOKUP(4))) THEN IF (BDATA(4) .GT. 0.0) THEN SUMD = ABS(FO-FC) + SUMD SUMF = SUMF + FO SUMFCC = FC*FC + SUMFCC SUMFOC = FO*FC + SUMFOC Kcount = Kcount + 1 ENDIF END IF C C---- write out file with fobs and fcalc (if lcyc=0) C C ******************* CALL LWREFL(MTZOUT,Bdata) C ******************* ICHK = MOD(Kcount-1,500) C IF (LverboseFlag .AND. ICHK.EQ.0 ) THEN CALL RESET_MAGIC(MTZOUT,Adata,Bdata,Mcols,DUMMY,-999.0) IF ( LFreeRexcludeVal.NE.-999)THEN IF ( LFpartFlag.GT.0) WRITE (6,FMT= + '(3i4,F7.4,2x,f8.1,f6.1,f8.1,2f6.0,2x,2(f8.1,f6.0))') + IN,S, (Bdata(LookUp(J)),J=4,8),FC0, + PHIC0,FC,PHIC IF ( LFpartFlag.EQ.0) + WRITE (6,FMT='(3I4,F7.4,2x,F8.1,2f6.1,f8.1,f6.0)') + IN,S, (Bdata(LookUp(J)),J=4,6),FC,PHIC END IF C C---- no freer C IF ( LFreeRexcludeVal.EQ.-999)THEN IF ( LFpartFlag.GT.0) WRITE (6, + FMT='(3i4,F7.4,2x,f8.1,f8.1,2f6.0,2x,2(f8.1,f6.0))') + IN,S, (Bdata(LookUp(J)),J=4,5),(Bdata(LookUp(J)),J=7,8),FC0, + PHIC0,FC,PHIC IF ( LFpartFlag.EQ.0) + WRITE (6,FMT='(3I4,F7.4,2x,F8.1,f6.1,f8.1,f6.0)') + IN,S, (Bdata(LookUp(J)),J=4,5),FC,PHIC END IF END IF C GO TO 80 160 IEND = 1 170 CONTINUE C C---- 2nd pass of unrestrained refinement - DO NOT reset scales!! C EJD April 1991 C IF (LCYC.GT.100) GO TO 220 SCnew = ScaleFcalc*SUMFOC/SUMFCC WRITE (6,FMT=6002) Kcount, + NumReflectionsRead, + ScaleFcalc, + SCnew ScaleFcalc = SCnew 6002 FORMAT (/, +' Number of reflections used = ',I8,/, +' Number of reflns. on file = ',I9,/, +' Old value of SCALE is = ',F13.3,/, +' New value of SCALE is = ',F13.3,/) 220 ISLAB = ISLAB + 1 C C---- keep LOGMSS for next block C DO 225 JQ = 1,MCOLS LOGSAVE(JQ) = LOGMSS(JQ) 225 CONTINUE C C---- write fcal file(20) from fofcph(1) C IF (LCYC.GT.100 .AND. ISLAB.EQ.Nslab) IEND = 1 END C C ================================================== SUBROUTINE SOUTZ(X,N1,N2,NPassTwoSave,NSizePassTwo, + R,ISLAB,LCYC,IEND) C =================================================== C C This calculates fc and phi and writes them over the x array. C C x complex is equivalenced to fofcph (real). C C .. Parameters .. INTEGER MCOLS PARAMETER (MCOLS=200) C .. Scalar Arguments .. INTEGER IEND,ISLAB,LCYC,N1,N2,NPassTwoSave,NSizePassTwo,R C .. C .. Array Arguments .. COMPLEX X(N1,N2,NPassTwoSave) C .. C .. Scalars in Common .. REAL AverageBfactor,BfactFpart,BfactorMax,BfactorMin,BfactOverall, + BfactReset,BfactStartStepSize,Bsmear,RatioShiftTrunc, + RmsBfactor,RmsXyz,ScaleFcalc,ScaleFpart,SFrepeatValue, + SigmaExclude,Smax,Smin,SSbinSize,TH,TSmax,TSmin,W, + WangSphereRadi,XyzStartStepSize INTEGER Hmax,Hmin,Kmax,Kmin,LatomMapFlag,LBfactRefFlag, + LcheckSFspaceGrpFlag,LFpartFlag,LFreeRexcludeVal, + LSFrefFlag,LhklInputFlag,LMapInFlag,Lmax,Lmin, + LPhiPartFlag,LSFcalcFlag,LSFmodeFlag,LSolvMaskFlag, + LWghtModeFlag,LxyzInputFlag,LXyzOutputFlag,NLPRGO, + LrefineCycFlag,Nslab,NtotalRefsUsed,NumMultiplicity LOGICAL LNoScaleFlag,LverboseFlag C .. C .. Arrays in Common .. INTEGER LookUp C .. C .. Local Scalars .. COMPLEX F REAL ALPH,CORR,DUMMY,FC,FC0,FO,PHIC,PHIC0,S,SCnew,SUMD,SUMF, + SUMFCC,SUMFOC INTEGER H,I1,I2,I3,IADD,IC,ICHK,IH1,J,JQ,K,K1,KCOUNT,L,L1,MTZIN, + MTZOUT,NUMREFLECTIONSREAD LOGICAL EOF C .. C .. Local Arrays .. REAL ADATA(MCOLS),Bdata(MCOLS),G(2) INTEGER IN(3) LOGICAL LOGMSS(MCOLS),LOGSAVE(MCOLS) C .. C These may not all need saving SAVE F, ALPH,CORR,FC,FC0,FO,PHIC,S,SCnew,SUMFCC, + SUMFOC, H,I1,I2,I3,IADD,IC,ICHK,IH1,JQ,K,K1,KCOUNT,L,L1, + NUMREFLECTIONSREAD, ADATA,Bdata,G, IN, SUMD, SUMF C .. External Functions .. REAL RECIPWT EXTERNAL RECIPWT C .. C .. External Subroutines .. EXTERNAL CCPERR,CENTR,EQUAL_MAGIC,LRREFL,LRREFM,LRREWD,LWREFL, + NEWLIN,RESET_MAGIC C .. C .. Intrinsic Functions .. INTRINSIC ABS,ATAN2,COS,EXP,MOD,NINT,SIN,SQRT C .. C .. Common blocks .. COMMON /BFACTS/ + AverageBfactor, + BfactorMin, + BfactorMax, + Bsmear, + BfactReset COMMON /HKLLIM/ + Hmax,Kmax,Lmax,Hmin,Kmin,Lmin,Nslab COMMON /MTZOP/ + Mlook,LookUp(MCOLS) COMMON /SFOUT/ + Smin,Smax,TSmin,TSmax,SSbinSize, + LFpartFlag,LPhiPartFlag,LWghtModeFlag, + ScaleFcalc,ScaleFpart, + SigmaExclude,WangSphereRadi, + BfactOverall,BfactFpart, + NumMultiplicity,NLPRGO COMMON /SRFCTL/ + NtotalRefsUsed, + RatioShiftTrunc,W,TH, + LSFmodeFlag,LrefineCycFlag,LBfactRefFlag, + LcheckSFspaceGrpFlag,LFreeRexcludeVal, + XyzStartStepSize,BfactStartStepSize, + SFrepeatValue, + RmsXyz,RmsBfactor COMMON /SRFCTL1/ + LSFcalcFlag,LSFrefFlag, + LatomMapFlag,LxyzInputFlag, + LhklInputFlag,LMapInFlag, + LSolvMaskFlag,LXyzOutputFlag COMMON /TERSE/ + LverboseFlag,LNoScaleFlag C .. C .. Equivalences .. EQUIVALENCE (F,G(1)) C .. C IF (LverboseFlag) WRITE (6,FMT=6000) N1,N2, + NPassTwoSave, + NSizePassTwo,R, + LCYC,IEND 6000 FORMAT (' SOUTZ',8I5) C MTZIN = 1 MTZOUT = 2 DUMMY = 0.0 C IF (LverboseFlag) THEN WRITE (6,FMT='(/,a)') +' Every 500th reflections listed for checking:' IF ( LFreeRexcludeVal.NE.-999 .AND. LFpartFlag.GT.0) + WRITE (6,FMT='(a,a)') +' H K L S Fo SIGFo FreeR Fpart PHIpart ', +'FCatom PHIatom FCtot PHItot' IF ( LFreeRexcludeVal.NE.-999 .AND. LFpartFlag.EQ.0) + WRITE (6,FMT='(a)') +' H K L S Fo SIGFo FreeR FC PHIC ' IF ( LFreeRexcludeVal.EQ.-999 .AND. LFpartFlag.GT.0) + WRITE (6,FMT='(a,a)') +' H K L S Fo SIGFo Fpart PHIpart ', +'FCatom PHIatom FCtot PHItot' IF ( LFreeRexcludeVal.EQ.-999 .AND. LFpartFlag.EQ.0) + WRITE (6,FMT='(a)') +' H K L S Fo SIGFo FC PHIC ' END IF C PHIC0 = 0.0 IF (LSFcalcFlag.EQ.1 .AND. IEND.EQ.1) RETURN IF (R.GT.Hmin) GO TO 10 ISLAB = 0 C 10 CONTINUE C C---- for p21 n1=ny/2+1 n2 = Lmax+1 NSizePassTwo=NPassTwoSave C DO 70 I3 = 1,NPassTwoSave DO 60 I2 = 1,N2 DO 50 I1 = 1,N1 F = X(I1,I2,I3) C C---- multiply fcs by NumMultiplicity to correct for C possible non-primitive spacegrou C G(1) = G(1)*NumMultiplicity G(2) = -G(2)*NumMultiplicity X(I1,I2,I3) = F 50 CONTINUE 60 CONTINUE 70 CONTINUE C C---- zero Kcounts for r factor C IF (R.GT.Hmin) THEN DO 75 JQ = 1,MCOLS LOGMSS(JQ) = LOGSAVE(JQ) 75 CONTINUE GO TO 110 END IF C C---- new pass through MTZ file C C ****************** IF (LCYC.GT.100) CALL LRREWD(MTZIN) C ****************** C Kcount = 0 NumReflectionsRead = 0 SUMD = 0.0 SUMF = 0.0 SUMFCC = 0.0 SUMFOC = 0.0 C C---- read Title of fobs file C C *********** CALL NEWLIN(6,1) C *********** C C---- if First time through (lcyc=0 or =1) read fobs data C calculate scale and r factor and output fobs file(19) C C NB. fobs file must be sorted into sections on h C (ie. h slowest moving index in input file) C 80 CONTINUE C C ===== Set all BDATA to missing value initially. C ******************************* CALL EQUAL_MAGIC(1,BDATA,MCols) C ******************************* C ************************* CALL LRREFL(MTZIN,S,Adata,EOF) C ************************* C IF (EOF) GO TO 160 CALL LRREFM(MTZIN,LOGMSS) NumReflectionsRead = NumReflectionsRead + 1 C DO 90 JQ = 1,3 IN(JQ) = NINT(Adata(LookUp(JQ))) Bdata(JQ) = Adata(LookUp(JQ)) 90 CONTINUE C C ************ CALL CENTR(IN,IC) C ************ C C---- copy FP SIGFP over C IF(.NOT.LOGMSS(LookUp(4))) Bdata(4) = Adata(LookUp(4)) IF(.NOT.LOGMSS(LookUp(5))) Bdata(5) = Adata(LookUp(5)) C C---- How many extra Bdata needto be found? C Depending on LWghtModeFlag, either nlprgo -3, or nlprgo -2 C Set a few Kcounters C---- This is messy: For SFCALC Bdata will contain a variety of data, C---- for SFREF Bdata will contain H K L FP SIGFP Free FC PHIC C C IF (LWghtModeFlag.GT.0) I2 = NLPRGO - 3 C IF (LWghtModeFlag.EQ.0) I2 = NLPRGO - 2 IF ( LSFrefFlag .NE.0) then IF(LookUp(6) .GT.0) THEN IF(.NOT.LOGMSS(LookUp(6)) ) Bdata(6) = Adata(LookUp(6)) END IF END IF C IF (LSFcalcFlag.EQ.1) THEN IADD = 6 I1 = IADD C C---- Loop round till you have found enough Bdata C 101 CONTINUE IF (IADD.GT.Mlook) GO TO 100 IF (LookUp(I1) .NE.0)THEN IF(.NOT.LOGMSS(LookUp(I1)))Bdata(IADD) = Adata(LookUp(I1)) IADD = IADD + 1 END IF I1 = I1 + 1 IF (I1 .LE. MCOLS) GO TO 101 100 CONTINUE END IF C IF (IN(1).LT.Hmin) GO TO 80 110 H = IN(1) K = IN(2) L = IN(3) IF (H.GT.Hmax) IEND = 1 IF (IEND.EQ.1) GO TO 170 C IF (H.GE.R+NSizePassTwo) GO TO 220 L1 = L + 1 K1 = K + 1 IF (L.GT.Lmax .OR. L.LT.Lmin) GO TO 80 IF (K.GT.Kmax .OR. K.LT.Kmin) GO TO 80 C C---- not needed if k>=0 l>=0 C IF (K.LT.0) K1 = N2 + 1 + K IF (L.LT.0) L1 = N1 + 1 + L IH1 = H - R + 1 C IF (IH1.LE.0) THEN WRITE(6,FMT=9001) 9001 FORMAT (' Error in SOUTZ - check that HKLIN has reflections'/, + ' sorted as H K L (H slowest, L fastest)',//, + ' Check for a warning earlier in logfile and see',/ + ' SFALL documentation for requirements placed on HKLIN', + //) CALL CCPERR (1, 'Fatal error in s/r SOUTZ') END IF C IF (S.LT.Smin .OR. S.GT.Smax) GO TO 80 C FO = 0.0 IF(.NOT.LOGMSS(Lookup(4))) FO = Bdata(4) C C---- remember x equivalent to fofcph C read in fc from x C CORR = EXP(Bsmear*S/4.0) F = X(L1,K1,IH1) FC = SQRT(G(1)*G(1)+G(2)*G(2)) PHIC = 0.0 IF (FC.GT.0.0001) PHIC = 57.2957795*ATAN2(G(2),G(1)) C IF (LFpartFlag.EQ.0) GO TO 120 IF (LOGMSS(Lookup(7)) .OR. LOGMSS(Lookup(8))) THEN IF (LOGMSS(Lookup(7)) .NEQV. LOGMSS(Lookup(8))) CALL CCPERR(1, + ' *** ERROR; either FPART/PHIP=MNF but other is not ***') GOTO 120 ENDIF FC0 = FC PHIC0 = PHIC ALPH = Adata(LookUp(8))/57.2957795 G(1) = Adata(Lookup(7))*ScaleFpart*EXP(-BfactFpart*S/4.0)* + COS(ALPH)/CORR + G(1) G(2) = Adata(Lookup(7))*ScaleFpart*EXP(-BfactFpart*S/4.0)* + SIN(ALPH)/CORR + G(2) FC = SQRT(G(1)*G(1)+G(2)*G(2)) PHIC = 0.0 IF (FC.GT.0.0001) PHIC = 57.2957795*ATAN2(G(2),G(1)) 120 CONTINUE C C---- If a reflection is centric it must at least be a multiple of 15 C---For centric reflections, shift PHIC to nearest centric phase C This is phase returned by CENTPHASE or that plus 180 IF (IC.EQ.1) THEN CALL CENTPHASE(IN,CENPHS) PHIC = MOD(PHIC,360.0) IF (ABS(PHIC - CENPHS).LE.90 .OR. + ABS(PHIC - 360.0 - CENPHS).LE.90) THEN PHIC = CENPHS ELSE PHIC = CENPHS + 180.0 ENDIF END IF C C---- Apply CORR for Bsmear now. C Do not rescale FC for output C FC = CORR*FC C---- KDC include wangwt C IF (LWghtModeFlag.GT.0) THEN Bdata(NLPRGO-2) = FC Bdata(NLPRGO-1) = PHIC Bdata(NLPRGO) = RECIPWT(S,WangSphereRadi,LWghtModeFlag) ELSE Bdata(NLPRGO-1) = FC Bdata(NLPRGO) = PHIC ENDIF C C---- KDC OK now C---- Exclude missing data from scale calc., both old and new test. C FC = ScaleFcalc*FC IF(.NOT.LOGMSS(LOOKUP(4))) THEN IF (BDATA(4) .GT. 0.0) THEN SUMD = ABS(FO-FC) + SUMD SUMF = SUMF + FO SUMFCC = FC*FC + SUMFCC SUMFOC = FO*FC + SUMFOC Kcount = Kcount + 1 ENDIF END IF C C---- write out file with fobs and fcalc (if lcyc=0) C C ******************* CALL LWREFL(MTZOUT,Bdata) C ******************* ICHK = MOD(Kcount-1,500) C IF (LverboseFlag .AND. ICHK.EQ.0 ) THEN CALL RESET_MAGIC(MTZOUT,Adata,Bdata,Mcols,DUMMY,-999.0) IF ( LFreeRexcludeVal.NE.-999)THEN IF ( LFpartFlag.GT.0) WRITE (6,FMT= + '(3i4,F7.4,2x,f8.1,f6.1,f8.1,2f6.0,2x,2(f8.1,f6.0))') + IN,S, (Bdata(LookUp(J)),J=4,8),FC0, + PHIC0,FC,PHIC IF ( LFpartFlag.EQ.0) + WRITE (6,FMT='(3I4,F7.4,2x,F8.1,2f6.1,f8.1,f6.0)') + IN,S, (Bdata(LookUp(J)),J=4,6),FC,PHIC END IF C C---- no freer C IF ( LFreeRexcludeVal.EQ.-999)THEN IF ( LFpartFlag.GT.0) WRITE (6, + FMT='(3i4,F7.4,2x,f8.1,f8.1,2f6.0,2x,2(f8.1,f6.0))') + IN,S, (Bdata(LookUp(J)),J=4,5),(Bdata(LookUp(J)),J=7,8),FC0, + PHIC0,FC,PHIC IF ( LFpartFlag.EQ.0) + WRITE (6,FMT='(3I4,F7.4,2x,F8.1,f6.1,f8.1,f6.0)') + IN,S, (Bdata(LookUp(J)),J=4,5),FC,PHIC END IF END IF C GO TO 80 160 IEND = 1 170 CONTINUE C C---- 2nd pass of unrestrained refinement - DO NOT reset scales!! C EJD April 1991 C IF (LCYC.GT.100) GO TO 220 SCnew = ScaleFcalc*SUMFOC/SUMFCC WRITE (6,FMT=6002) Kcount, + NumReflectionsRead, + ScaleFcalc, + SCnew ScaleFcalc = SCnew 6002 FORMAT (/, +' Number of reflections used = ',I8,/, +' Number of reflns. on file = ',I9,/, +' Old value of SCALE is = ',F13.3,/, +' New value of SCALE is = ',F13.3,/) 220 ISLAB = ISLAB + 1 C C---- keep LOGMSS for next block C DO 225 JQ = 1,MCOLS LOGSAVE(JQ) = LOGMSS(JQ) 225 CONTINUE C C---- write fcal file(20) from fofcph(1) C IF (LCYC.GT.100 .AND. ISLAB.EQ.Nslab) IEND = 1 END C C ====================================== SUBROUTINE TRANS1(X,N,NX,NY,Lmax,Hmax) C ====================================== C C TRANSPOSES xz-transform results for space group p21212. C transposed results are produced for h.ge.0 only. C the transposition formula is : C C sxz ( h , 1/2 - y , l ) = (-)**h * sxz ( -h , y , l ) . C C written by g. bricogne, may 1976. C C .. Scalar Arguments .. INTEGER Hmax,Lmax,N,NX,NY C .. C .. Array Arguments .. COMPLEX X(N,NX,NY) C .. C .. Local Scalars .. COMPLEX A INTEGER H,HL,HU,K,KL,KM,KU,L,NZ C .. C HL = Hmax + 1 KM = NY/2 KL = KM + 1 NZ = Lmax + 1 C IF (NY.EQ.1) GO TO 80 C C---- First, transpose h = 0 plane around its y-middle. C DO 20 K = 1,KM KU = NY + 1 - K DO 10 L = 1,NZ A = X(L,1,K) X(L,1,K) = X(L,1,KU) X(L,1,KU) = A 10 CONTINUE 20 CONTINUE C C---- now, transpose h < 0 results into h > 0 locations. C DO 70 K = 1,KM KU = NY + 1 - K C C---- h odd terms. C IF (HL.LT.2) GO TO 70 C DO 40 H = 2,HL,2 HU = NX + 2 - H DO 30 L = 1,NZ X(L,H,K) = -X(L,HU,KU) X(L,H,KU) = -X(L,HU,K) 30 CONTINUE 40 CONTINUE C C---- h even terms. C IF (HL.LT.3) GO TO 70 C DO 60 H = 3,HL,2 HU = NX + 2 - H DO 50 L = 1,NZ X(L,H,K) = X(L,HU,KU) X(L,H,KU) = X(L,HU,K) 50 CONTINUE 60 CONTINUE C 70 CONTINUE C 80 IF (2*KM.EQ.NY) GO TO 130 C C---- get transposed results for middle y - plane. C K = KL C C---- h odd terms. C IF (HL.LT.2) GO TO 130 C DO 100 H = 2,HL,2 HU = NX + 2 - H DO 90 L = 1,NZ X(L,H,K) = -X(L,HU,K) 90 CONTINUE 100 CONTINUE C C---- h even terms. C IF (HL.LT.3) GO TO 130 C DO 120 H = 3,HL,2 HU = NX + 2 - H DO 110 L = 1,NZ X(L,H,K) = X(L,HU,K) 110 CONTINUE 120 CONTINUE C 130 CONTINUE END C C ============================= SUBROUTINE TRNSP2(X,NZ,NY,NX) C ============================= C C This subroutine transposes intermediate results from -z to -h C for space group p212121. C C .. Scalar Arguments .. INTEGER NX,NY,NZ C .. C .. Array Arguments .. COMPLEX X(NZ,NY,NX) C .. C .. Local Scalars .. COMPLEX A INTEGER H,HL,HU,K,L,LL,LU,M C .. C HL = NX/2 LL = NZ/2 IF (NX.LT.2) GO TO 50 M = LL + 1 C DO 40 H = 1,HL HU = NX + 1 - H C C---- transpose line z = 1/4 C DO 10 K = 1,NY A = X(M,K,H) X(M,K,H) = X(M,K,HU) X(M,K,HU) = A 10 CONTINUE C C---- transpose rest of hkz C DO 30 K = 1,NY DO 20 L = 1,LL LU = NZ + 1 - L A = X(L,K,H) X(L,K,H) = X(LU,K,HU) X(LU,K,HU) = A A = X(LU,K,H) X(LU,K,H) = X(L,K,HU) X(L,K,HU) = A 20 CONTINUE 30 CONTINUE 40 CONTINUE C 50 CONTINUE IF (2*HL.EQ.NX) GO TO 80 H = NX/2 + 1 C DO 70 K = 1,NY DO 60 L = 1,LL LU = NZ + 1 - L A = X(L,K,H) X(L,K,H) = X(LU,K,H) X(LU,K,H) = A 60 CONTINUE 70 CONTINUE C C---- multiply by (-1)**k normally C but for z grad multiply by (-1)**(k+1) C 80 CONTINUE IF (NY.LT.2) RETURN C DO 110 H = 1,NX DO 100 K = 2,NY,2 DO 90 L = 1,NZ X(L,K,H) = -X(L,K,H) 90 CONTINUE 100 CONTINUE 110 CONTINUE C END C C =============================== SUBROUTINE TRNSP3(X,NY,NZ,NX,R) C =============================== C C Transposes k-transform results for space-group p21212 . C the transposition formula is : C tk(-h, y, l) = (-)**h * tk(h, 1/2 - y, l) . C C adapted from ten eyck's trnsp1 for p222, with an error mended, C by g. bricogne, may 1976 . C C C .. Scalar Arguments .. INTEGER NX,NY,NZ,R C .. C .. Array Arguments .. COMPLEX X(NY,NZ,NX) C .. C .. Local Scalars .. COMPLEX A,B INTEGER H,H1,H2,HL,HU,K,KL,KM,KU,L LOGICAL H1ODD,H2ODD,HEVEN C .. C HL = NX/2 KM = NY/2 KL = KM + 1 C C---- note : ny, as defined in calling program, is odd . C IF (NX.EQ.1) GO TO 50 C DO 40 H = 1,HL HU = NX + 1 - H H1 = H + R - 1 H2 = HU + R - 1 H1ODD = (H1/2)*2 .NE. H1 H2ODD = (H2/2)*2 .NE. H2 C DO 10 L = 1,NZ A = X(KL,L,H) B = X(KL,L,HU) IF (H1ODD) A = -A IF (H2ODD) B = -B X(KL,L,H) = B X(KL,L,HU) = A 10 CONTINUE C IF (KM.LT.1) GO TO 40 C DO 30 K = 1,KM KU = NY + 1 - K DO 20 L = 1,NZ A = X(K,L,H) B = X(KU,L,HU) IF (H1ODD) A = -A IF (H2ODD) B = -B X(K,L,H) = B X(KU,L,HU) = A A = X(KU,L,H) B = X(K,L,HU) IF (H1ODD) A = -A IF (H2ODD) B = -B X(KU,L,H) = B X(K,L,HU) = A 20 CONTINUE 30 CONTINUE C 40 CONTINUE C 50 CONTINUE IF ((KM.LT.1) .OR. (2*HL.EQ.NX)) GO TO 90 H = HL + 1 H1 = H + R - 1 HEVEN = (H1/2)*2 .EQ. H1 H1ODD = .NOT. HEVEN C DO 80 L = 1,NZ IF (H1ODD) X(KL,L,H) = -X(KL,L,H) DO 70 K = 1,KM KU = NY + 1 - K A = X(K,L,H) B = X(KU,L,H) IF (HEVEN) GO TO 60 A = -A B = -B 60 X(K,L,H) = B X(KU,L,H) = A 70 CONTINUE 80 CONTINUE C 90 CONTINUE END C C ====================================================== SUBROUTINE WATOM(XyzStartStepSize,BfactStartStepSize, + SIGWT,BfactOverall,RmsXyz,RmsBfactor) C ====================================================== C C .. Scalar Arguments .. REAL BfactOverall,BfactStartStepSize,RmsBfactor,RmsXyz,SIGWT, + XyzStartStepSize C .. C .. Scalars in Common .. REAL AverageBfactor,BfactorMax,BfactorMin,BfactReset,Bsmear INTEGER IOatomop,IOgradmat,IOhessian,IOmap,IOscratch,IOshifts, + IOxyzin,IOxyzoutunq LOGICAL LNoScaleFlag,LverboseFlag C .. C .. Local Scalars .. REAL AVB,AVX,AVXYZ,AVY,AVZ,BISO,DB,DBLM,DX,DXYZ,DXYZLM,DY,DZ, + ESD,ESDALL,Occupancy,SDB0,SDN,SDX0,SDY0,SDZ0,SIG,X0,X1,Y0, + Y1,Z0,Z1 INTEGER I,I1,IER,Ifail,IOxyzout,IRES,ITER,IZZ,J,JAB,JB1,JB2,MAXB, + MINB,NUM,NumAtmRefined,NumZeroOccAtms LOGICAL FIRST CHARACTER ID*4,MCH*1,MA*4,MAC*4,RSN*4,INSCOD*1,ALTCOD*1,SEGID*4 C .. C .. Local Arrays .. REAL B(6),ESDB(20),SDBUF(5) INTEGER NB(20) C .. C .. External Subroutines .. EXTERNAL NEWLIN,QREAD,QSEEK,XYZADVANCE,XYZATOM, + XYZCLOSE,XYZCOORD,XYZOPEN,XYZREWD C .. C .. Intrinsic Functions .. INTRINSIC ABS,INT,SQRT C .. C .. Common blocks .. COMMON /BFACTS/ + AverageBfactor, + BfactorMin, + BfactorMax, + Bsmear, + BfactReset COMMON /IOSF/ + IOscratch,IOgradmat,IOhessian,IOshifts, + IOatomop,IOmap,IOxyzin,IOxyzoutunq COMMON /TERSE/ + LverboseFlag,LNoScaleFlag C .. SAVE FIRST, NumZeroOccAtms C .. Data statements .. DATA FIRST/.TRUE./ C .. C IF (First) THEN First = .FALSE. NumZeroOccAtms = 0 END IF C NUM = 0 AVX = 0.0 AVY = 0.0 AVZ = 0.0 AVXYZ = 0.0 AVB = 0.0 ITER = 0 C DO 10 I = 1,20 ESDB(I) = 0.0 NB(I) = 0 10 CONTINUE C IF (BfactReset.EQ.0.0) BfactReset = 5.0 AverageBfactor = 0.0 Ifail = 0 IOxyzout = 0 C C ********************************************* CALL XYZOPEN('XYZOUT','OUTPUT',' ',IOxyzout,IFAIL) C ********************************************* C BfactorMin = 1000.0 BfactorMax = 0.0 NumAtmRefined = 0 I = 0 C CALL QSEEK(IOshifts,1,1,2) CALL QREAD(IOshifts,SDBUF,2,IER) C SDN = SDBUF(1) SDX0 = SDBUF(2) C C---- Set Limits if needed. C SDY0 = XyzStartStepSize SDZ0 = BfactStartStepSize C IF (RmsXyz.NE.0.000 .AND. + RmsXyz .LT.SDN ) SDY0 = RmsXyz/SDN IF (RmsBfactor.NE.0.000 .AND. + RmsBfactor .LT.SDX0 ) SDZ0 = RmsBfactor/SDX0 IF (ABS(RmsXyz).GT.0.00001 .OR. + XyzStartStepSize.GT.SDY0 ) XyzStartStepSize = SDY0 IF (ABS(RmsBfactor).GT.0.00001 .OR. + BfactStartStepSize.GT.SDZ0 ) XyzStartStepSize = SDY0 C WRITE(6,*)' SDN SDNORm',sdn,sdx0 WRITE(6,*)' RmsXyz RmsBfactor ',RmsXyz,RmsBfactor WRITE(6,*)' XyzStartStepSize BfactStartStepSize ', + XyzStartStepSize,BfactStartStepSize DXYZLM = 3.0*XyzStartStepSize*SDN DBLM = 3.0*BfactStartStepSize*SDX0 C C **************** CALL XYZREWD(IOxyzin) C **************** C WRITE(6,'(//,a,F4.1,a)') + ' B values RESET to ',BfactReset,' monitored:' WRITE(6,'(//,a,/,a)')' Large Shifts monitored:', +' NATOM ATOM DX DY DZ DTOT DB' 6009 FORMAT( I5,I5,A4,A1,4F10.3,F10.2) 20 CONTINUE C C ********************************************************* CALL XYZADVANCE(IOxyzin,IOxyzout,ITER,*30,*30) CALL XYZATOM(IOxyzin,I1,MA,MAC,MCH,IRES,RSN,INSCOD,ALTCOD, + SEGID,IZZ,ID) CALL XYZCOORD(IOxyzin,'O','U',X0,Y0,Z0,Occupancy,BISO,B) C ********************************************************* C IF (B(2).NE.0.0 .OR. B(3).NE.0.0) THEN IF (X0.EQ.0.0 .AND. Y0.EQ.0.0 .AND. Z0.EQ.0.0) GOTO 20 ENDIF B(1) = BISO DO 25 I=2,6 B(I) = 0.0 25 CONTINUE C NumAtmRefined = NumAtmRefined + 1 X1 = X0 Y1 = Y0 Z1 = Z0 DXYZ = 0.0 DB = 0.0 C IF (Occupancy.NE.0.0 ) THEN NUM = NUM + 1 NumZeroOccAtms = NumZeroOccAtms + 1 CALL QREAD(IOshifts,SDBUF,5,IER) SDX0 = SDBUF(1) SDY0 = SDBUF(2) SDZ0 = SDBUF(3) SIG = SDBUF(4) SDB0 = SDBUF(5) DX = - XyzStartStepSize*SDX0 DY = - XyzStartStepSize*SDY0 DZ = - XyzStartStepSize*SDZ0 DB = - BfactStartStepSize*SDB0 AVX = AVX + ABS(DX) AVY = AVY + ABS(DY) AVZ = AVZ + ABS(DZ) AVB = AVB + ABS(DB) X1 = X0 + DX Y1 = Y0 + DY Z1 = Z0 + DZ B(1) = B(1) + DB + BfactOverall DXYZ = SQRT(DX**2 + DY**2 + DZ**2) DB = ABS(DB) AVXYZ = AVXYZ + ABS(DXYZ) IF (DXYZ .GT.DXYZLM .OR. DB .GT. DBLM) WRITE (6,FMT=6009) + I1,IRES,MA,MAC,DX,DY,DZ,DXYZ,DB END IF C IF (B(1).LT.BfactReset) THEN IF (LverboseFlag) + WRITE (6,FMT=6010) I1,MA,MAC,IRES, + X1,Y1,Z1,Occupancy,B(1), + IZZ 6010 FORMAT (' BfactReset:', + I5,A4,1X,A4,1X,I8,3F8.4,F5.2,F8.2,I5) B(1) = BfactReset END IF AverageBfactor = AverageBfactor + B(1) IF (B(1).LT.BfactorMin) BfactorMin = B(1) IF (B(1).GT.BfactorMax) BfactorMax = B(1) C C---- Brookhaven C CALL XYZCOORD(IOxyzout,'O','U',X1,Y1,Z1,Occupancy,BISO,B) CALL XYZADVANCE(IOxyzout,0,0,*30,*30) C C---- ESDS for carbon atoms tabulated against b value. C sd = (1/h * w*delta**2 /(nref-nparam) )**1/2 C IF (IZZ.EQ.6 ) THEN JAB = INT((B(1)-1.0)/5.0) + 1 IF (JAB.LT.1) JAB = 1 IF (JAB.GT.20) JAB = 20 NB(JAB) = NB(JAB) + 1 ESDB(JAB) = ESDB(JAB) + SIG**2 END IF GO TO 20 C C---- ESD analysis lifted from neil isaacs C C *********** 30 CALL NEWLIN(6,1) C *********** C DX = AVX/NUM DY = AVY/NUM DZ = AVZ/NUM DB = AVB/NUM DXYZ = AVXYZ/NUM WRITE (6,FMT=6019) ' Totals:',DX,DY,DZ,DXYZ,DB 6019 FORMAT( a,7x,4F10.3,F10.2) C NumZeroOccAtms = NumAtmRefined - NumZeroOccAtms AverageBfactor = AverageBfactor/NumAtmRefined WRITE (6,FMT=6003) NumAtmRefined, + NumZeroOccAtms, + BfactorMin, + BfactorMax, + AverageBfactor 6003 FORMAT ( +' Number of atoms input = ',I13,/, +' Number of atoms with zero Occupancy = ',I5,/, +' Minimum B = ',F8.2,/, +' Maximum B = ',F8.2,/, +' Average B = ',F8.2,/) C NUM = 0 ESDALL = 0.0 MINB = 1 MAXB = 0 C Write(6,'(a,/,a,/,a)') + ' $TABLE: Error analysis v B value ( very rough!) :', + ' $GRAPHS: v. Bfactor :N:1,4: $$', + ' $$ Bmin Bmax Natoms Est_Error $$ $$' C DO 380 J = 1,20 NUM = NB(J) + NUM ESDB(J) = ESDB(J)*SIGWT ESDALL = ESDB(J) + ESDALL IF (NB(J).NE.0) THEN ESD = SQRT(ABS(ESDB(J)/NB(J))) JB1 = J*5 - 4 JB2 = J*5 IF (JB2.GT.MAXB) MAXB = JB2 WRITE (6,FMT=6030) JB1,JB2,NB(J),ESD NB(J) = 0 ESDB(J) = 0.0 END IF 380 CONTINUE C Write(6,'(a)')' $$' ESD = 0.0 IF (NUM .GT. 0) ESD = SQRT(ESDALL/NUM) WRITE (6,FMT=6030) MINB,MAXB,NUM,ESD C C---- end of cycle C C ****************** CALL XYZCLOSE(IOxyzout) C ****************** C 6030 FORMAT (' ',I4,I6,I7,F8.3) END C C ===================================================== SUBROUTINE WRINT(X,NY,NX,NZ,Kmax,Hmax,Size,IOscratch, + NumCurrentRecord,NRCSC) C ===================================================== C C---- writes intermediate results for p212121 C structure factor calculation C C .. Scalar Arguments .. INTEGER Hmax,IOscratch,Kmax,NRCSC,NumCurrentRecord,NX,NY,NZ,Size C .. C .. Array Arguments .. COMPLEX X(NY,NX,NZ) C .. C .. Local Scalars .. COMPLEX A INTEGER H,K,KM1,L,MH,ML,Ndiff,NZ21,P,Q LOGICAL DONE C .. C .. External Subroutines .. EXTERNAL QWRITE C .. C KM1 = Kmax + 1 DONE = .FALSE. 10 Q = 0 20 P = Q + 1 NumCurrentRecord = NumCurrentRecord + 1 Q = Q + Size IF (Q.GT.Hmax+1) Q = Hmax + 1 C DO 50 H = P,Q DO 40 K = 1,KM1 DO 30 L = 1,NZ C C **************************** CALL QWRITE(IOscratch,X(K,H,L),2) C **************************** C 30 CONTINUE 40 CONTINUE 50 CONTINUE C C---- pad record to nrcsc words C Ndiff = NRCSC - 2*NZ*KM1* (Q-P+1) C C ******************************** IF (Ndiff.GT.0) CALL QWRITE(IOscratch,X(1,1,1),Ndiff) C ******************************** C IF (Q.LE.Hmax) GO TO 20 IF (DONE) GO TO 130 C C---- transpose results for -h to 1/2-l C NZ21 = (NZ+1)/2 C DO 90 L = 1,NZ21 ML = NZ + 1 - L C DO 60 K = 1,KM1 A = X(K,1,ML) X(K,1,ML) = X(K,1,L) X(K,1,L) = A 60 CONTINUE C P = Hmax + 1 C DO 80 H = 2,P MH = NX + 2 - H C DO 70 K = 1,KM1 X(K,H,ML) = X(K,MH,L) X(K,H,L) = X(K,MH,ML) 70 CONTINUE 80 CONTINUE 90 CONTINUE C DONE = .TRUE. IF (KM1.LT.2) GO TO 10 C DO 120 L = 1,NZ DO 110 H = 1,P DO 100 K = 2,KM1,2 X(K,H,L) = -X(K,H,L) 100 CONTINUE 110 CONTINUE 120 CONTINUE C GO TO 10 C 130 CONTINUE END C C ======================================= SUBROUTINE WRITEMAP(IOmap,RHO,N1,N2,N3) C ======================================= C C .. Scalar Arguments .. INTEGER IOmap,N1,N2,N3 C .. C .. Array Arguments .. REAL RHO(N1,N2,N3) C .. C .. Scalars in Common .. REAL BfactStartStepSize,RatioShiftTrunc,RHmax,RHmean,RHmin, + RmsBfactor,RmsXyz,SFrepeatValue,TH,VolMtz,W,XyzStartStepSize INTEGER IXmax,IXmin,IYmax,IYmin,IZmax,IZmin,Jsec,JU1,JU2,JV1,JV2, + LBfactRefFlag,LcheckSFspaceGrpFlag,LFreeRexcludeVal, + LSFmodeFlag,LrefineCycFlag,NtotalRefsUsed,NumSections, + NumSFspaceGroup,NumSFsymm,NX,NY,NZ C .. C .. Arrays in Common .. REAL CellMtz INTEGER Iuvw C .. C .. Local Scalars .. REAL RhoMax,RhoMin,ScaleMap,SUM INTEGER I1,I2,I3,INT1 LOGICAL FIRST C .. C .. External Subroutines .. EXTERNAL MWRSEC C .. C .. Common blocks .. COMMON /MPHDR/ + NX,NY,NZ, + IXmin,IXmax,IYmin,IYmax,IZmin,IZmax, + Jsec,JU1,JU2,JV1,JV2,Iuvw(3), + NumSFspaceGroup,NumSections, + RHmin,RHmax,RHmean,NumSFsymm, + CellMtz(6),VolMtz,Volfft,F000 COMMON /SRFCTL/ + NtotalRefsUsed, + RatioShiftTrunc,W,TH, + LSFmodeFlag,LrefineCycFlag,LBfactRefFlag, + LcheckSFspaceGrpFlag,LFreeRexcludeVal, + XyzStartStepSize,BfactStartStepSize, + SFrepeatValue, + RmsXyz,RmsBfactor C .. SAVE FIRST, SCALEMAP, SUM C .. Data statements .. DATA FIRST/.TRUE./ C .. C C---- Map should ve uncorrected for GRID VOL - applied in GENDEN. C But If LSFmodeFlag eq -5 or -6 dont do this - C you destroy the Kcounter!! C IF (First ) THEN ScaleMap = 1.0 IF ( LSFmodeFlag.GT.-5) ScaleMap = VolMtz/(NX*NY*NZ) First = .FALSE. SUM = 0 RHmean = 0 RHmax = -9999999 RHmin = 99999999 END IF C C---- Write atom density map C INT1 = 1 C DO 10 I3 = 1,N3 RhoMax = -9999999 RhoMin = 99999999 DO 30 I1 = 1,N1-2 DO 20 I2 = 1,N2 RHO(I1,I2,I3) = RHO(I1,I2,I3)/ScaleMap SUM = RHO(I1,I2,I3) + SUM IF (RHO(I1,I2,I3).GT.RhoMax) RhoMax = RHO(I1,I2,I3) IF (RHO(I1,I2,I3).LT.RhoMin) RhoMin = RHO(I1,I2,I3) 20 CONTINUE 30 CONTINUE C WRITE (6,FMT=6000) I3,RhoMin,RhoMax IF (RHmax.LT.RhoMax) RHmax = RhoMax IF (RHmin.GT.RhoMin) RHmin = RhoMin RHmean = RHmean + SUM C C ******************** CALL MWRSEC(IOmap, + RHO(1,1,I3), + N1, + N2, + INT1, + (N1-2), + INT1, + N2) C ******************** C IF (ScaleMap.NE.1.00)THEN DO 40 I1 = 1,N1-2 DO 50 I2 = 1,N2 RHO(I1,I2,I3) = RHO(I1,I2,I3)*ScaleMap 50 CONTINUE 40 CONTINUE END IF 10 CONTINUE C RHmean = RHmean + SUM WRITE (6,FMT=6002) SUM C C C---- Format statemenyts C 6000 FORMAT (' SECTION =',I3,' MIN AND MAX DENSITY ARE ',2E12.4) 6002 FORMAT (' SUM OF DENSITY UP TO THIS BLOCK IS ',E14.4) C END C C ==================================================== SUBROUTINE WRITEZ(X,NY21,NX,NSizePassOne,Kmax1,IOscratch, + NumCurrentRecord) C ==================================================== C C C .. Scalar Arguments .. INTEGER IOscratch,Kmax1,NSizePassOne,NumCurrentRecord,NX,NY21 C .. C .. Array Arguments .. COMPLEX X(NY21,NX,NSizePassOne) C .. C .. Local Scalars .. INTEGER IX,IZ C .. C .. External Subroutines .. EXTERNAL QWRITE C .. C DO 20 IZ = 1,NSizePassOne NumCurrentRecord = NumCurrentRecord + 1 C DO 10 IX = 1,NX C C ************************************ CALL QWRITE(IOscratch,X(1,IX,IZ),2*Kmax1) C ************************************ C 10 CONTINUE 20 CONTINUE C END C C ======================================================== SUBROUTINE YIN2(X,NZ,NX,NY,Hmax,Lmax,Size,NumSkipRecords, + RECS,IOscratch,NumCurrentRecord, + NumMaxRecord,Nwords) C ========================================================= C C---- reads in intermediate results for all h and l for a block of k. C the input is stored with l down the columns and h on the rows. C C This version of the subroutine may be used for all monoclinic C space groups for which the intermediate results are complex, as C well as the triclinic space groups. C C C .. Scalar Arguments .. INTEGER Hmax,IOscratch,Lmax,NumCurrentRecord,NumMaxRecord, + NumSkipRecords,Nwords,NX,NY,NZ,RECS,Size C .. C .. Array Arguments .. COMPLEX X(NZ,NX,NY) C .. C .. Scalars in Common .. LOGICAL LNoScaleFlag,LverboseFlag C .. C .. Local Scalars .. INTEGER H,HL,HU,IER,K,L,LM1,P C .. C .. External Subroutines .. EXTERNAL QREAD,QSEEK C .. C .. Intrinsic Functions .. INTRINSIC CMPLX,CONJG C .. C .. Common blocks .. COMMON /TERSE/ + LverboseFlag,LNoScaleFlag C .. C LM1 = Lmax + 1 C DO 30 K = 1,NY DO 20 H = 1,NX DO 10 L = 1,NZ X(L,H,K) = CMPLX(0.0,0.0) 10 CONTINUE 20 CONTINUE 30 CONTINUE C P = Size HU = NX - Hmax NumCurrentRecord = NumCurrentRecord + NumSkipRecords C C---- read data for negative h C 40 CONTINUE HL = HU + 1 HU = HU + P IF (HU.GT.NX) GO TO 130 IF (NumCurrentRecord.GT.NumMaxRecord) GO TO 170 IF (LverboseFlag) WRITE (6,FMT=6000) + NumCurrentRecord,HL,HU 6000 FORMAT (' NEGATIVE H RECORD ',3I5) C C ****************************************** CALL QSEEK(IOscratch,NumCurrentRecord,1,Nwords) C ****************************************** C DO 60 K = 1,NY DO 50 H = HL,HU C C *********************************** CALL QREAD(IOscratch,X(1,H,K),2*LM1,IER) C *********************************** C 50 CONTINUE 60 CONTINUE C NumCurrentRecord = NumCurrentRecord + RECS + 1 C IF (HU.LT.NX) GO TO 40 C C---- read records for positive h C HU = 0 90 CONTINUE C HL = HU + 1 HU = HU + P IF (HU.GT.Hmax) HU = Hmax + 1 IF (NumCurrentRecord.GT.NumMaxRecord) GO TO 170 IF (LverboseFlag) WRITE (6,FMT=6002) + NumCurrentRecord,HL,HU 6002 FORMAT (' POSITIVE H RECORD ',3I5) C C ****************************************** CALL QSEEK(IOscratch,NumCurrentRecord,1,Nwords) C ****************************************** C DO 110 K = 1,NY DO 100 H = HL,HU C C *********************************** CALL QREAD(IOscratch,X(1,H,K),2*LM1,IER) C *********************************** C 100 CONTINUE 110 CONTINUE C IF (HU.GT.Hmax) GO TO 170 120 CONTINUE NumCurrentRecord = NumCurrentRecord + RECS + 1 GO TO 90 C C---- section to read a record spanning h = 0 C 130 CONTINUE HU = HU - NX IF (HU.GT.Hmax) HU = Hmax + 1 IF (NumCurrentRecord.GT.NumMaxRecord) GO TO 170 IF (LverboseFlag) WRITE (6,FMT=6004) + NumCurrentRecord,HL,HU 6004 FORMAT (' SPANNING H RECORD ',3I5) C C ****************************************** CALL QSEEK(IOscratch,NumCurrentRecord,1,Nwords) C ****************************************** C DO 160 K = 1,NY DO 140 H = HL,NX C C *********************************** CALL QREAD(IOscratch,X(1,H,K),2*LM1,IER) C *********************************** C 140 CONTINUE C DO 150 H = 1,HU C C *********************************** CALL QREAD(IOscratch,X(1,H,K),2*LM1,IER) C *********************************** C 150 CONTINUE 160 CONTINUE C IF (HU.LE.Hmax) GO TO 120 C C---- fill in the -h k 0 results by symmetry C 170 CONTINUE C DO 190 H = 2,HU HL = NX + 2 - H DO 180 K = 1,NY X(1,HL,K) = CONJG(X(1,H,K)) 180 CONTINUE 190 CONTINUE C END C C ======================================================== SUBROUTINE YIN5(X,NZ,NX,NY,Hmax,Lmax,Size,NumSkipRecords, + RECS,IOscratch,NumCurrentRecord, + NumMaxRecord,Nwords) C ========================================================= C C Reads back intermediate k-transform results for all h and l C for a block of ny y-values . the input is stored with l C down the columns and h on the rows. C C This version of the yin subroutine is for use with those C orthorhombic space-groups in which the transform along y C gives complex results, and the values for -h,y,l have been C obtained by transposition from those for h, 1/2 - y, l in C subroutine trnsp3. C C adapted from ten eyck's yin2 and yin3 ( with an error of logic C mended ) by g. bricogne , may 1976 . C C .. Scalar Arguments .. INTEGER Hmax,IOscratch,Lmax,NumCurrentRecord,NumMaxRecord, + NumSkipRecords,Nwords,NX,NY,NZ,RECS,Size C .. C .. Array Arguments .. COMPLEX X(NZ,NX,NY) C .. C .. Local Scalars .. COMPLEX DUMMY INTEGER H,HL,HL1,HL2,HU,HU1,HU2,IER,IX,IY,IZ,K,L,LM,NXM,P C .. C .. External Subroutines .. EXTERNAL CCPERR,QREAD,QSEEK C .. C .. Intrinsic Functions .. INTRINSIC CMPLX C .. C DO 30 IY = 1,NY DO 20 IX = 1,NX DO 10 IZ = 1,NZ X(IZ,IX,IY) = CMPLX(0.0,0.0) 10 CONTINUE 20 CONTINUE 30 CONTINUE C LM = Lmax + 1 NXM = NX - Hmax + 1 P = Size NumCurrentRecord = NumCurrentRecord + NumSkipRecords C C---- read First two records, which contain duplicate copies of C the h=0 results. the complex variable dummy is used to ignore C the h=0 result in h.le.0 record . C HL1 = 1 HU1 = P IF (HU1.GT.Hmax) HU1 = Hmax + 1 IF (NumCurrentRecord.GT.NumMaxRecord) GO TO 280 C C ****************************************** CALL QSEEK(IOscratch,NumCurrentRecord,1,Nwords) C ****************************************** C DO 60 K = 1,NY DO 50 H = HL1,HU1 DO 40 L = 1,LM C C ******************************* CALL QREAD(IOscratch,X(L,H,K),2,IER) C ******************************* C 40 CONTINUE 50 CONTINUE 60 CONTINUE C NumCurrentRecord = NumCurrentRecord + RECS + 1 HU2 = NX HL2 = NX - P + 2 IF (HL2.LT.NXM) HL2 = NXM IF (NumCurrentRecord.GT.NumMaxRecord) GO TO 280 IF (HU2.LT.HL2) GO TO 110 C C ****************************************** CALL QSEEK(IOscratch,NumCurrentRecord,1,Nwords) C ****************************************** C DO 100 K = 1,NY DO 80 H = HL2,HU2 DO 70 L = 1,LM C C ******************************* CALL QREAD(IOscratch,X(L,H,K),2,IER) C ******************************* C 70 CONTINUE 80 CONTINUE C DO 90 L = 1,LM C C **************************** CALL QREAD(IOscratch,DUMMY,2,IER) C **************************** C 90 CONTINUE C 100 CONTINUE C 110 CONTINUE C NumCurrentRecord = NumCurrentRecord + RECS + 1 IF (HU1.GT.Hmax) GO TO 190 C C---- now, read pairs of records for h1gt.0 and h.lt.0 . C 120 CONTINUE HL1 = HU1 + 1 HU1 = HU1 + P IF (HU1.GT.Hmax) HU1 = Hmax + 1 IF (NumCurrentRecord.GT.NumMaxRecord) GO TO 280 C C ****************************************** CALL QSEEK(IOscratch,NumCurrentRecord,1,Nwords) C ****************************************** C DO 150 K = 1,NY DO 140 H = HL1,HU1 DO 130 L = 1,LM C C ******************************** CALL QREAD(IOscratch,X(L,H,K),2,IER) C ******************************** C 130 CONTINUE 140 CONTINUE 150 CONTINUE C NumCurrentRecord = NumCurrentRecord + RECS + 1 HU2 = HL2 - 1 HL2 = HL2 - P IF (HL2.LT.NXM) HL2 = NXM IF (NumCurrentRecord.GT.NumMaxRecord) GO TO 280 C C ****************************************** CALL QSEEK(IOscratch,NumCurrentRecord,1,Nwords) C ****************************************** C DO 180 K = 1,NY DO 170 H = HL2,HU2 DO 160 L = 1,LM C C ******************************* CALL QREAD(IOscratch,X(L,H,K),2,IER) C ******************************* C 160 CONTINUE 170 CONTINUE 180 CONTINUE C IF (HU1.GT.Hmax) GO TO 190 NumCurrentRecord = NumCurrentRecord + RECS + 1 GO TO 120 C C---- check that original and transposed results have been read C correctly . C 190 CONTINUE IF (HL2.EQ.NXM) GO TO 200 WRITE (6,FMT=6000) HU1,HL2 CALL CCPERR(1,'Bad justification of scratch records ') 6000 FORMAT (/, +' ERROR : BAD JUSTIFICATION OF SCRATCH RECORDS IN ', +'YIN5 .',/10X,'HU1 = ',I5,' , HL2 = ',I5) C C---- pad array with zeros where there are no data . C 200 CONTINUE HL = Hmax + 2 HU = NX - Hmax IF (HU.LT.HL) GO TO 240 C DO 230 K = 1,NY DO 220 H = HL,HU DO 210 L = 1,LM X(L,H,K) = (0.0,0.0) 210 CONTINUE 220 CONTINUE 230 CONTINUE C 240 CONTINUE IF (LM.GE.NZ) GO TO 280 P = LM + 1 C DO 270 K = 1,NY DO 260 H = 1,NX DO 250 L = P,NZ X(L,H,K) = (0.0,0.0) 250 CONTINUE 260 CONTINUE 270 CONTINUE C C---- end of input . C 280 CONTINUE END C C ===================================================== SUBROUTINE YOUT2(X,NY,NZ,NX,Size,YMIN,YMAX,IOscratch, + NumCurrentRecord,NumWords) C ===================================================== C C C C---- writes y sections for complex intermediate results C C .. Scalar Arguments .. INTEGER IOscratch,NumCurrentRecord,NumWords,NX,NY,NZ,Size,YMAX, + YMIN C .. C .. Array Arguments .. COMPLEX X(NY,NZ,NX) C .. C .. Local Scalars .. INTEGER H,K,L,Ndiff,P,Q C .. C .. External Subroutines .. EXTERNAL QWRITE C .. C Q = YMIN 10 CONTINUE NumCurrentRecord = NumCurrentRecord + 1 P = Q + 1 Q = Q + Size IF (Q.GT.YMAX) Q = YMAX + 1 C DO 40 K = P,Q DO 30 H = 1,NX DO 20 L = 1,NZ C C **************************** CALL QWRITE(IOscratch,X(K,L,H),2) C **************************** C 20 CONTINUE 30 CONTINUE 40 CONTINUE C C---- pad record to NumWords words C Ndiff = NumWords - 2*NX*NZ* (Q-P+1) C C ******************************** IF (Ndiff.GT.0) CALL QWRITE(IOscratch,X(1,1,1),Ndiff) C ******************************** C IF (Q.LE.YMAX) GO TO 10 C END C C ====================================================== SUBROUTINE YOUT92(X,NZ21,IHKA,Y,Kmax1,NX,NZ,IOscratch, + NumSFspaceGroup,Nrec) C ====================================================== C C C .. Scalar Arguments .. INTEGER IHKA,IOscratch,Kmax1,Nrec,NumSFspaceGroup,NX,NZ,NZ21 C .. C .. Array Arguments .. COMPLEX X(NZ21,IHKA),Y(Kmax1,NX) C .. C .. Scalars in Common .. REAL RHmax,RHmean,RHmin,VolMtz INTEGER HmaxA,HminA,IXmax,IXmin,IYmax,IYmin,IZmax,IZmin,Jsec,JU1, + JU2,JV1,JV2,KHmin,MSFSPG,MX,MY,MZ,NumSections C .. C .. Arrays in Common .. REAL CellMtz INTEGER Iuvw C .. C .. Local Scalars .. COMPLEX F REAL ABSX INTEGER IER,IH,IH1,IH3,IH4,IHmax1,IHmin1,IK,IK1,ISIGN,IX,IY,IZ, + IZ2,IZ3,IZ4,IZmax1,IZmin1,IZZ,KH,NZ41 C .. C .. Local Arrays .. REAL G(2) C .. C .. External Subroutines .. EXTERNAL QREAD,QSEEK,QWRITE C .. C .. Intrinsic Functions .. INTRINSIC ABS,CMPLX,CONJG,MOD C .. C .. Common blocks .. COMMON /MPHDR/ + MX,MY,MZ, + IXmin,IXmax,IYmin,IYmax,IZmin,IZmax, + Jsec,JU1,JU2,JV1,JV2,Iuvw(3), + NSFSpaGrpDum,NumSections, + RHmin,RHmax,RHmean,MSFSPG, + CellMtz(6),VolMtz,Volfft,F000 COMMON /P41212/ + HminA,HmaxA,KHmin C .. C .. Equivalences .. EQUIVALENCE (F,G(1)) C .. C NZ41 = NZ/4 + 1 IZmin1 = IZmin + 1 IZmax1 = IZmax + 1 IF (HminA.GT.0) GO TO 40 C DO 20 IX = 1,NX DO 10 IY = 1,Kmax1 Y(IY,IX) = CMPLX(0.0,0.0) 10 CONTINUE 20 CONTINUE C C ************************* CALL QSEEK(IOscratch,1,1,Nrec) C ************************* C DO 30 IZ = 1,NZ21 C C ***************************** CALL QWRITE(IOscratch,Y(1,1),Nrec) C ***************************** C 30 CONTINUE 40 CONTINUE C C ****************************** CALL QSEEK(IOscratch,IZmin1,1,Nrec) C ****************************** C DO 100 IZ = IZmin1,IZmax1 IZZ = IZ C C ******************************** CALL QREAD(IOscratch,Y(1,1),Nrec,IER) C ******************************** C IHmin1 = HminA + 1 IHmax1 = HmaxA + 1 C DO 90 IH1 = IHmin1,IHmax1 DO 80 IK1 = 1,IH1 IH = IH1 - 1 IK = IK1 - 1 KH = IH*IH1/2 + IK1 - KHmin Isign = MOD(IH1+IK1,2) C C---- No point generating equivalents for absx=0 C ABSX = ABS(X(IZ,KH)) IF (ABSX.EQ.0.0) GO TO 80 Y(IK1,IH1) = X(IZ,KH) C C Use following symmetry to generate t(k h z) C---- P4122 -Y,-X,1/4-Z C t(-k -h z)= t(h k 1/4-z) - t(k h z )=t(h k 1/4-z) transpose C P41212 -Y,-X,1/2-Z C t(-k -h z)= t(h k 1/2-z) - t(k h z )=t(h k 1/2-z) transpose C P4322 Y, X,1/4-Z C t( k h z)= t(h k 1/4-z) C P43212 -Y,-X,1/2-Z C t(-k -h z)= t(h k 1/2-z) - t(k h z )=t(h k 1/2-z) transpose C C---- for p41212 and p43212 use t(-k -h z)= t(h k 1/2-z) C t(k h z )=t(h k 1/2-z) transpose C IF (NumSFspaceGroup.EQ.91 )IZ2 = NZ41 - IZ + 1 IF (NumSFspaceGroup.EQ.92 )IZ2 = NZ21 - IZ + 1 IF (NumSFspaceGroup.EQ.95 )IZ2 = NZ41 - IZ + 1 IF (NumSFspaceGroup.EQ.96 )IZ2 = NZ21 - IZ + 1 Y(IH1,IK1) = CONJG(X(IZ2,KH)) IF (NumSFspaceGroup.EQ.95)Y(IH1,IK1) = X(IZ2,KH) IF (IH.EQ.0) GO TO 60 C C Use following symmetry to generate t(-h k z) C---- P4122 X, -Y,1/2-Z C t(h -k z) = t(h k 1/2-z) - t(-h k z)=t(h -k z)transpose C P41212 1/2-X,1/2+Y,1/4-Z C t(-h k z) = t(h k 1/4-z)*(-1)**(h+k) C P4322 X, -Y,1/2-Z C t(h -k z) = t(h k 1/2-z) - t(-h k z)=t(h -k z)transpose C P43212 1/2+X,1/2-Y,1/4-Z C t(h -k z) = t(h k 1/4-z)*(-1)**(h+k) - t(-h k z)=t(h -k z)transpose C IH3 = NX - IH + 1 IF (NumSFspaceGroup.EQ.91 )IZ3 = NZ21 - IZ + 1 IF (NumSFspaceGroup.EQ.92 )IZ3 = NZ41 - IZ + 1 IF (NumSFspaceGroup.EQ.95 )IZ3 = NZ21 - IZ + 1 IF (NumSFspaceGroup.EQ.96 )IZ3 = NZ41 - IZ + 1 F = X(IZ3,KH) IF (NumSFspaceGroup.NE.92) F = CONJG(F) IF (Isign .EQ. 0 .OR. + NumSFspaceGroup .EQ. 91 .OR. + NumSFspaceGroup .EQ. 95) GO TO 50 IF (Isign.EQ.0) GO TO 50 G(1) = -G(1) G(2) = -G(2) 50 Y(IK1,IH3) = F 60 IF (IK.EQ.0) GO TO 80 C C---- Use following symmetry to generate t(-k h z) C C---- P4122 Y,-X,-1/4+Z C t( k -h z)= t(h k 1/4+z) - t(-k h z)=t(k -h z)transpose C P41212 1/2+Y,1/2-X.-1/4+Z C t( k -h z)= t(h k 1/4+z)*(-1)**(h+k) - t(-k h z)=t(k -h z)transpose C P4322 -Y, X,-1/4+Z C t(-k h z)= t(h k 1/4+z) C P43212 1/2-Y,1/2+X.-1/4+Z C t(-k h z)= t(h k 1/4+z)*(-1)**(h+k) C IH4 = NX - IK + 1 IF (NumSFspaceGroup.EQ.91 )IZ4 = NZ41 + IZ - 1 IF (NumSFspaceGroup.EQ.92 )IZ4 = NZ41 + IZ - 1 IF (NumSFspaceGroup.EQ.95 )IZ4 = NZ41 + IZ - 1 IF (NumSFspaceGroup.EQ.96 )IZ4 = NZ41 + IZ - 1 F = X(IZ4,KH) IF (NumSFspaceGroup .EQ. 91 .OR. + NumSFspaceGroup .EQ. 92) F = CONJG(F) IF (Isign .EQ.0 .OR. + NumSFspaceGroup .EQ. 91 .OR. + NumSFspaceGroup .EQ. 95) GO TO 70 G(1) = -G(1) G(2) = -G(2) 70 Y(IH1,IH4) = F 80 CONTINUE 90 CONTINUE C C ***************************** CALL QSEEK(IOscratch,IZZ,1,Nrec) CALL QWRITE(IOscratch,Y(1,1),Nrec) C ***************************** C 100 CONTINUE END C C ================================================ SUBROUTINE ZIN(X,NY2,NX,NSizePassTwo,Kmax, + IOscratch,NumCurrentRecord,Nrec) C ================================================ C C .. Scalar Arguments .. INTEGER IOscratch,Kmax,Nrec,NSizePassTwo,NumCurrentRecord,NX,NY2 C .. C .. Array Arguments .. COMPLEX X(NY2,NX,NSizePassTwo) C .. C .. Local Scalars .. INTEGER IER,IX,IY,IZ,Kmax1 C .. C .. External Subroutines .. EXTERNAL QREAD,QSEEK C .. C .. Intrinsic Functions .. INTRINSIC CMPLX C .. C Kmax1 = Kmax + 1 C DO 40 IX = 1,NX DO 30 IY = 1,NY2 DO 20 IZ = 1,NSizePassTwo X(IY,IX,IZ) = CMPLX(0.0,0.0) 20 CONTINUE 30 CONTINUE 40 CONTINUE C DO 60 IZ = 1,NSizePassTwo NumCurrentRecord = NumCurrentRecord + 1 C C **************************************** CALL QSEEK(IOscratch,NumCurrentRecord,1,Nrec) C **************************************** C DO 50 IX = 1,NX C C ************************************** CALL QREAD(IOscratch,X(1,IX,IZ),2*Kmax1,IER) C *************************************** C 50 CONTINUE 60 CONTINUE C END C C ======================================================== SUBROUTINE ZIN4(X,NY,NX,NZ,Hmax,Kmax,Size,NumSkipRecords, + RECS,IOscratch,NumCurrentRecord,NumWords) C ========================================================= C C reads complex intermediate results for all h and positive k C this subroutine is designed for programs calculating z sections, C where the results for -h, k, z have been obtained from the results C for +h, +k by symmetry. by permutation of the parameter list it C can also Work for y sections. C C C .. Scalar Arguments .. INTEGER Hmax,IOscratch,Kmax,NumCurrentRecord,NumSkipRecords, + NumWords,NX,NY,NZ,RECS,Size C .. C .. Array Arguments .. COMPLEX X(NY,NX,NZ) C .. C .. Local Scalars .. COMPLEX DUMMY(1) INTEGER H,HL,HU,I,IER,K,KM1,KM2,L,P,Q C .. C .. External Subroutines .. EXTERNAL QREAD,QSEEK C .. C .. Intrinsic Functions .. INTRINSIC CMPLX C .. C DO 30 L = 1,NZ DO 20 I = 1,NX DO 10 K = 1,NY X(K,I,L) = CMPLX(0.0,0.0) 10 CONTINUE 20 CONTINUE 30 CONTINUE C KM1 = Kmax + 1 NumCurrentRecord = NumCurrentRecord + NumSkipRecords C HU = 0 50 CONTINUE C C---- read results for positive h C HL = HU + 1 HU = HU + Size IF (HU.GT.Hmax) HU = Hmax + 1 C C ******************************************** CALL QSEEK(IOscratch,NumCurrentRecord,1,NumWords) C ******************************************** C DO 80 L = 1,NZ DO 70 K = 1,KM1 DO 60 H = HL,HU C C ******************************* CALL QREAD(IOscratch,X(K,H,L),2,IER) C ******************************* C 60 CONTINUE 70 CONTINUE 80 CONTINUE C NumCurrentRecord = NumCurrentRecord + RECS + 1 C C---- read results for negative h C P = NX + 2 - HU Q = NX + 2 - HL IF (Q.LE.NX) GO TO 140 IF (P.GT.NX) GO TO 130 C C ******************************************** CALL QSEEK(IOscratch,NumCurrentRecord,1,NumWords) C ******************************************** C DO 120 L = 1,NZ DO 110 K = 1,KM1 DO 100 H = P,NX C C ******************************* CALL QREAD(IOscratch,X(K,H,L),2,IER) C ******************************* C 100 CONTINUE C C **************************** CALL QREAD(IOscratch,DUMMY,2,IER) C **************************** C 110 CONTINUE 120 CONTINUE C 130 CONTINUE NumCurrentRecord = NumCurrentRecord + 1 GO TO 180 140 CONTINUE C C ******************************************** CALL QSEEK(IOscratch,NumCurrentRecord,1,NumWords) C ******************************************** C DO 170 L = 1,NZ DO 160 K = 1,KM1 DO 150 H = P,Q C C ******************************* CALL QREAD(IOscratch,X(K,H,L),2,IER) C ******************************* C 150 CONTINUE 160 CONTINUE 170 CONTINUE C NumCurrentRecord = NumCurrentRecord + 1 180 CONTINUE C IF (HU.GT.Hmax) GO TO 190 NumCurrentRecord = NumCurrentRecord + RECS GO TO 50 C C---- clear out the rest of the array C 190 CONTINUE P = Hmax + 2 Q = NX - Hmax IF (P.GT.Q) GO TO 230 C DO 220 H = P,Q DO 210 K = 1,KM1 DO 200 L = 1,NZ X(K,H,L) = CMPLX(0.0,0.0) 200 CONTINUE 210 CONTINUE 220 CONTINUE C 230 CONTINUE IF (KM1.GE.NY) GO TO 270 KM2 = Kmax + 2 C DO 260 H = 1,NX DO 250 K = KM2,NY DO 240 L = 1,NZ X(K,H,L) = CMPLX(0.0,0.0) 240 CONTINUE 250 CONTINUE 260 CONTINUE C 270 CONTINUE END C C ==================================================== SUBROUTINE ZOUT2(X,NZ,NY,NX,Size,ZMIN,ZMAX,IOscratch, + NumCurrentRecord,NumWords) C ==================================================== C C---- writes complex intermediate results for z sections C C C .. Scalar Arguments .. INTEGER IOscratch,NumCurrentRecord,NumWords,NX,NY,NZ,Size,ZMAX, + ZMIN C .. C .. Array Arguments .. COMPLEX X(NZ,NY,NX) C .. C .. Local Scalars .. INTEGER H,K,L,Ndiff,P,Q C .. C .. External Subroutines .. EXTERNAL QWRITE C .. C Q = ZMIN 10 CONTINUE NumCurrentRecord = NumCurrentRecord + 1 P = Q + 1 Q = Q + Size IF (Q.GT.ZMAX) Q = ZMAX + 1 C DO 40 L = P,Q DO 30 K = 1,NY DO 20 H = 1,NX C C **************************** CALL QWRITE(IOscratch,X(L,K,H),2) C **************************** C 20 CONTINUE 30 CONTINUE 40 CONTINUE C C---- pad record to NumWords words C Ndiff = NumWords - 2*NX*NY* (Q-P+1) C C ******************************** IF (Ndiff.GT.0) CALL QWRITE(IOscratch,X(1,1,1),Ndiff) C ******************************** C IF (Q.LE.ZMAX) GO TO 10 C END