C C FFT C Copyright (C) 1986 Lynn Ten Eyck C C This code is distributed under the terms and conditions of the C CCP4 licence agreement as `Part 2' (Annex 2) software. C A copy of the CCP4 licence can be obtained by writing to the C CCP4 Secretary, Daresbury Laboratory, Warrington WA4 4AD, UK. C C************************************************************* C C C The development of the MTZ files and associated software mark 1 C is part of the masterplan of the ESF/EACBM Working Group 2.1 for C better Protein Crystallographic software for Europe. C C************************************************************** C C =========== PROGRAM FFT C =========== C C Date: Thu, 24 Oct 91 C Phil Evans MRC LMB, Cambridge C some cleaning up C C Date: Tue, 20 Mar 90 9:30 GMT C From: Eleanor Dodson C modified to work with MTZ files C C appnds.f chksym.f cinfft.f closeit.f divi.f C exc1le.f exc1lo.f expand.f factrz.f fft.f(MAIN) C fft1.f fft10.f fft144.f fft146.f fft152.f C fft16.f fft169.f fft17.f fft18.f fft19.f C fft2.f fft20.f fft21.f fft23.f fft3.f C fft4.f fft47.f fft92.f fftctl.f(fft_control) C fftr18.f fileo.f fndsmp.f gethkl.f hsep1c.f C hsep1i.f jtime.f mapsav.f modphs.f multi.f C out144.f out146.f out152.f out169.f prmvec.f C prmvet.f prntyz.f rcsfft.f(Key_parser) sepevn.f C sepodd.f setgrd.f setlim.f sfiiyc.f sfip92.f C sfipyc.f sfipyr.f sfipz3.f sfipzc.f sfipzr.f C shfmap.f trnp1c.f trnp1i.f trnsp1.f trnsp2.f C trnsp3.f trnsp4.f trnspr.f trp1le.f trp1lo.f C yin1.f yin2.f yin3.f yin4.f yin5.f C yout1.f yout1i.f yout2.f yout4.f yout5.f C yout92.f zin.f zin4.f zin47.f zinrl.f C zout2.f zout47.f C C FORTRAN 77 VERSION USING DISKIO C C-Mods--Date----Purpose C C 16 Aug/Sep 1992 Modified code for default grid & limits C Eleanor Dodson/Phil Evans C C 15 5-Nov-90 Anomalous fourier should use phase - 90 (NOT +) PRE C C 14 9-Aug-90 Corrected calculation of Double Difference coefficients C in GGETF Phil Evans C C 13-20-Mar-90 C Many mods have not been documented: C Read the current writeup and TAKE CARE! What C worked last year may not work now!! C Eleanor Dodson C C 12 22-Sep-88 Expand incorporated into fft - C ass ffthklscr to a scratch error C C 11 22-Sep-88 Key worded input added - C see [chem3.oldxtal.doc]fft.doc C Redundant array KSGX deleted from CARDIN C Checked which sg allowed expansion?? ... but now all do.. C Expand now incorporated into FFT. Adam Ralph York. C Tested on all current problems. C C 10 22-Aug-88 Subroutines PRINTY and PRINTZ C replaced by one subroutine C C PRNTYZ. It used the variable "nsecax" to decide whether the C map will have the density array "y" fastest, C "x" medium and "z" sections (ie for spacegroups 19,92,etc) C or the density array "z" fastest,"x" medium and "y" sections C (ie for spacegroups 1,2,3,4,10,18 ) C The program has been tested successfully. E.D. C C It is a spin off from other programs which write pseudo-map C formats. C C 9 12-Jul-88 Add code written by Eleanor Dodson for C space groups 169 {P61}, 170 {P65}. C The program has been tested. E.D. C C 8 12-Apr-88 New version received from Eleanor Dodson. C Eleanor's non-standard sort option removed and C the documentation updated. Phase change for anomalous C difference map option reinserted. C Space-group 1018 now works. FFT18 CALLed YOUT2 instead C of YOUT5 which had been ommitted from this code. C Extra facilities introduced to apply cut-offs to the C coefficients. Allow vector difference of F's by C introducing phase and weight for second F. C C Substantial changes to CARDINFFT and GETHKL(entry GGETF). C Spacegroups 18 and 1018 allowed to calculate NY/2 C instead of NY/4. PB C C 7 8-Feb-88 Add code written by Jens Nyborg, Aarhus for C space groups 17 {P222(1)}, 20 {C222(1)} and 21 {C222}. C A total of 8 subroutines have been added. C The program has not been tested. P.B. C C 6 8-Feb-88 Changed GETHKL so that indices get C permuted from axis order C even if no symmetry operations given. C (from PRE dated 5-Feb-86)) C C 5 4-Jun-87 Fully implement R3 by incorporating code from C E. Dodson, and allow for unsorted data so that the C same routine can be used for R32 with data expansion. C Correct error in choosing asymmetric unit for trigonal C space groups (except P3121/P3221) in GETHKL. A.G.W.L. C C 4 17-Aug-86 Increase dimension of X from 110000 to 400000 C 3 2-May-86 Insert Phil's corrections in his version dated 20-Apr-86 C 2 6-Mar-86 Fully implement P3121/P3221 by incorporating code C from Eleanor Dodson. C SFIP92 - rewritten C OUT152 - insert QREAD/QWRITE C FFT152 - delete junk comment C 1 4-Mar-86 Correct computed GOTO in GETHKL (260 added) C C Main program C C .. Parameters .. INTEGER IDIM PARAMETER (IDIM=1000000) C .. C .. Local Scalars .. INTEGER IS C .. C .. Local Arrays .. REAL X(IDIM) C .. C .. External Subroutines .. EXTERNAL CCPERR,CLOSEIT,FFTCTL C IS = IDIM C C ********************************** CALL FFTCTL(X,IS) CALL CLOSEIT CALL CCPERR(0, 'Normal termination') C ********************************* C END C C C C ============================== SUBROUTINE APPNDS(LINE,STRING) C ============================== C C---- Append "string" to "line" C C .. Scalar Arguments .. CHARACTER LINE* (*),STRING* (*) C .. C .. Local Scalars .. INTEGER L C .. C .. External Functions .. INTEGER LENSTR EXTERNAL LENSTR C .. C .. Save statement .. SAVE C .. C L = LENSTR(LINE) + 1 LINE(L:) = STRING END C C C C C ================================================================ SUBROUTINE CHKSYM(SPGRP,NumSymmetry,CalcSpaceGroup,RealSymmMatrx, + NFFTSG,FFTSGS) C ================================================================ C C This subroutine choses which space group specific routines to use C in FFT given any particular space group. C C .. C .. Parameters .. INTEGER LSYM PARAMETER (LSYM=192) C .. C .. Scalar Arguments .. INTEGER CalcSpaceGroup,NFFTSG,NumSymmetry,SPGRP C .. C .. Array Arguments .. REAL RealSymmMatrx(4,4,LSYM) INTEGER FFTSGS(NFFTSG) 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,LSYM) C .. C .. External Subroutines .. EXTERNAL CCPERR,MSYGET,PGDEFN C .. C .. Intrinsic Functions .. INTRINSIC ABS,MOD,NINT C .. IF (SPGRP .EQ .0) CALL + CCPERR(1,' *** No symmetry given, SYMM card needed ***') C First check if the crystal spacegroup is an allowed one DO 60 ISGS = 1,NFFTSG IF(SPGRP.NE.FFTSGS(ISGS)) GO TO 60 C---- OK - same spacegroup C GO to 100 60 CONTINUE C DO 70 ISGS = NFFTSG,1,-1 ITMP = MOD(FFTSGS(ISGS),1000) IF(ITMP.GT.MOD(SPGRP,1000)) GOTO 70 IST = 49 C C ******************************** CALL MSYGET(IST,FFTSGS(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 = INT(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 = FFTSGS(ISGS) WRITE(6,'(A,I5,A)') + ' *** Calculation symmetry using space-group CalcSpaceGroup', + CalcSpaceGroup,' ***' C RETURN END C C C ======================== SUBROUTINE CINFFT(ISIZE) C ======================== C C Card input for data selection and equivalent reflexion generation C for FFT. C Returns array size ISIZE if given on card 1 C Enter with JFLAG=0 for FFT C or .ne.0 for EXPAND (exits early) C C .. Parameters .. INTEGER LSG,LSYM PARAMETER (LSG=20,LSYM=192) INTEGER MCOLS PARAMETER (MCOLS=500) C .. C .. Scalar Arguments .. INTEGER ISIZE C .. C .. Scalars in Common .. REAL A,B,BIAS,DEL,DEL1,F000,F1LIM,F2LIM,GRDSMP,RHMAX,RHMEAN,RHMIN, + RHOMAX,RHOMIN,RMAX,RMIN,SCLF1,SCLF2,SCMOD1,SCMOD2,SIG1,SIG2, + SMAX,SMIN,SSQ,TFF1,TFF2,V,F1MAX,F2MAX INTEGER HMAX,HMIN,ICEN,IDIG,IFreeRexcludeVal,ILIN,IPHTR,IPROJ, + ISORT,ISP,ISQ,IW,J,K,KE,KMAX,KMIN,KSYM,L,LCMAX,LCMIN, + LIST,LMAX,LMIN,LSPGRP,M,NABCH,NANOM,NCOL,NF1,NF2,NH,NI1, + NLAUE,NLAFFT,NLINES,NNA,NNB,NP,NP2,NPH,NS1,NS2,NSECAX, + NSG,NSMFFT,NSPFFT,NSSM,NSYM,NSYMCH,NSYMP,NUM_FREE_COLUMN, + NUSED10,NUSED11,NUSED6,NUSED7,NUSED8,NUSED9,NW,NW2,NX,NY, + NZ,IFIL,IFILO,T2,T3,T4,TYPE,XMAX,XMIN,YMAX,YMIN,ZMAX,ZMIN, + NsymAll CHARACTER TITLE*80,NAMSPG*10,PGNAME*10 LOGICAL USEFILL,USEFREE C .. C .. Arrays in Common .. REAL CELL,CS,PERM,RSMFFT,RSYM,RSYMT,SN,XYZLIM INTEGER IUVW,KP,MP,T C .. C .. Local Scalars .. REAL TTF2,XTMP,SAMPLE INTEGER I,I1,I2,I3,IAPPND,IDEBUG,IERR,IFAIL,J1,LDUM,N, + NLPRGO,NSCRCH,NSYMM,NSYM1,NSYMP1,NSPGR1 INTEGER IPRINT CHARACTER TITNEW*80,PATNAM*10,LTYPE1*1,SPGRN1*10,PGNAM1*10 C .. C .. Local Arrays .. REAL TR(3,LSYM),rsym1(4,4,1) INTEGER JUNK(3),KGPERM(LSG),KSC(LSG),LOOKUP(MCOLS), + MCEN(LSG),MSG(LSG),MSP(3,2) CHARACTER CTPRGO(MCOLS)*1,KXYZ(3)*1,LSPRGO(MCOLS)*30 C .. C .. External Subroutines .. EXTERNAL CCPDPN,CCPERR,CHKSYM,EXPAND,INVSYM,LRASSN,LROPEN,LWCELL, + LWCLAB,LWOPEN,LWTITL,PRMVEC,RCSFFT,SETGRD,SETLIM,PATSGP, $ LENSTR INTEGER LENSTR C .. C .. Intrinsic Functions .. INTRINSIC COS,MAX,MIN,NINT,SIN C .. C .. Common blocks .. COMMON /ATSYM/RSYM(4,4,LSYM),RSYMT(4,4,LSYM),NSYM,PERM(4,4),NSYMP, + NLAUE,NsymAll COMMON /FFTPRM/KP(3) COMMON /FFTSPG/NSPFFT,NSMFFT,RSMFFT(4,4,LSYM),NLAFFT COMMON /FOUT/LCMIN,LCMAX,ISP,IDIG,ILIN COMMON /HKLF/A,B,ISORT,J,K,L,M,SSQ COMMON /HKLLIM/HMAX,KMAX,LMAX,HMIN,KMIN,LMIN COMMON /IOFFT/IFIL,IFILO,T2,T3,T4,NSYMCH,NABCH,NSECAX COMMON /LFTOVR/MP(3),KE,RMAX,RMIN,XYZLIM(2,3),GRDSMP COMMON /MAPFMT/TYPE,NLINES,NCOL,V,F000,RHOMAX,RHOMIN COMMON /MPHDR/NX,NY,NZ,XMIN,XMAX,YMIN,YMAX,ZMIN,ZMAX,NUSED6, + NUSED7,NUSED8,NUSED9,NUSED10,IUVW(3),NUSED11,CELL(6), + LSPGRP,RHMIN,RHMAX,RHMEAN COMMON /MPHDRR/TITLE COMMON /SEL/NF1,NS1,NF2,NS2,NP,NW,IW,ISQ,NH,SMIN,SMAX,SCLF1,TFF1, + SCLF2,TFF2,BIAS,NSSM,NSG,IPROJ,LIST,ICEN,KSYM,NI1,CS(24), + SN(24),T(LSYM,3),NNA,NNB,NPH,NANOM,NW2,NP2,SIG1,SIG2,DEL, + DEL1,F1LIM,F2LIM,IPHTR,SCMOD1,SCMOD2,F1MAX,F2MAX,CX,CY,CZ COMMON /SPACGP/ NAMSPG, PGNAME COMMON /FREESTUFF/ USEFREE, NUM_FREE_COLUMN,IFreeRexcludeVal, + USEFILL C .. C .. Save statement .. SAVE C .. C .. Data statements .. C C NLPRGO = number of output labels C DATA NLPRGO,LSPRGO/5,'H','K','L','A','B',495*' '/ DATA CTPRGO/'H','H','H','R','R',495*' '/ DATA MSG/1,2,4,10,1018,18,19,20,21,23,47,92,96,144,145, + 146,152,154,169,170/,MCEN/0,1,0,1,0,0,0,0,0,0,1,0,0,0, + 0,0,0,0,0,0/,KSC/1,1,1,1,1,1,2,1,1,1,2,2,2,2,2,2,2,2,2, + 2/ DATA KGPERM/1,1,0,0,0,0,-1,0,1,1,1,0,0,0,0,0,0,0,0,0/ DATA MSP/3,1,2,2,1,3/ DATA KXYZ/'X','Y','Z'/ C .. C C---- Space group number MSG, centric flag MCEN C KSC =1 for y sections , =2 for z sections C KGPERM = 1 if permutation of axes allowed (-1 only cyclic permutations), C = 0 not C C Number of space-groups recognized C C P1 P-1 [P2] P21 P2/M [P222] [P2221] P21212 P21212 P212121 C2221 C222 C I222 PMMM P41212 P43212 P31 P3 P3121 P3221 [These have been removed] C C---- Program axis order : fast,medium,slow axes for y, z sections C NSYMCH = 4 NABCH = 22 NSCRCH = 23 T2 = NSCRCH C DO 10 I = 1,3 KP(I) = I 10 CONTINUE C BIAS = 0.0 F000 = 0.0 IDIG = 4 ILIN = 1 ISQ = 0 IPHTR = 0 SCMOD1 = 0.0 SCMOD2 = 0.0 ISORT = 0 IPROJ = 0 LIST = 0 LCMAX = 0 LCMIN = 0 NCOL = 0 DEL = 0.0 DEL1 = 0.0 NLINES = 0 SIG1 = 0.0 SIG2 = 0.0 F1LIM = 0.0 F2LIM = 0.0 F1MAX = 0.0 F2MAX = 0.0 NSYM = 0 RHOMAX = 999.0 RHOMIN = -999.0 SCLF1 = 1.0 SCLF2 = 1.0 TTF2 = 0.0 TYPE = 0 T3 = 1 T4 = 0 V = 0.0 NNA = 0 NNB = 0 NF1 = 0 NI1 = 0 NS1 = 0 NF2 = 0 NS2 = 0 NP = 0 NH = 0 NPH = 0 NW = 0 NANOM = 0 NW2 = 0 NP2 = 0 C C---- Control data error counter C KE = 0 C C---- Set one symmetry matrix to identity C DO 30 I = 1,4 DO 20 J = 1,4 IF (I.EQ.J) THEN RSYM(J,I,1) = 1 RSYMT(J,I,1) = 1.0 PERM(J,I) = 1.0 ELSE RSYM(J,I,1) = 0 RSYMT(J,I,1) = 0.0 PERM(J,I) = 0.0 END IF 20 CONTINUE 30 CONTINUE C C---- Table of Sin and Cos in 15 deg steps C DO 40 I = 1,24 CS(I) = COS(0.261799167*I) SN(I) = SIN(0.261799167*I) 40 CONTINUE C C---- read data cards C C ********************* CALL RCSFFT(ISIZE,LSG,MSG) C ********************* C C---- Check & write out input commands C C---- Phased translation function C IF (IPHTR.NE.0) THEN WRITE (6,FMT=6002) 6002 FORMAT (' Phased translation function calculated ',/, + ' Ref: R.J.READ and A.J.SCHIERBEEK J.Appl.', + 'Cryst(1988) 21 490-','495',/, + ' Terms are w1*w2*F1*F2*exp( PHI1 - PHI2)', + ' or w1*w2*F1*F2*exp( PHI1 + PHI2mod)',/, + ' Scale multiplied by 1/sqrt( Sigma((w*F1)**2)*', + 'Sigma((F2)**2)',/, + ' ** All translational elements of symmetry set to zero', + ' **') C IF (NF1.EQ.0 .OR. NF2.EQ.0 .OR. NP.EQ.0 .OR. NP2.EQ.0) THEN WRITE (6,FMT='(A)') + ' ** Define F1 F2 PHI PHI2 for PHTRANSLATION option **' KE = KE + 1 END IF END IF C IF ((NF1.GT.0.AND.NS1.LE.0) .OR. + (NF2.GT.0.AND.NS2.LE.0)) BIAS = 0.0 C WRITE (6,FMT=6004) RMIN,RMAX 6004 FORMAT (/,' Resolution limits: ',2F9.2) C WRITE (6,FMT=6006) 'F1',SCLF1,TFF1 6006 FORMAT (' Scale & B for ',A,' : ',2F9.5) C IF (NF2.GT.0) WRITE (6,FMT=6006) 'F2',SCLF2,TFF2 IF (ABS(BIAS).GT.0.0001) WRITE (6,FMT=6008) BIAS 6008 FORMAT (' Anomalous bias : ',F5.1,' DO NOT USE unless you K', + 'NOW your Sig(F) are sensible') C WRITE (6,FMT=6010) 6010 FORMAT(/,' * F used = Scale * exp(- B * (sin theta/lambda)**2);', + ' ** Scale and B applied to F BEFORE squaring for Patter', + 'son **',/) C C---- Check on exclusions, there is a muddle betwen DEL , F1MAX etc C IF (NF2 .EQ. 0) THEN IF (DEL.NE.0.0 .AND. F1MAX.EQ.0.0) THEN CALL CCPERR(3, + ' WARNING: possible inconsistency in EXCL: F1MAX set to DIFF') F1MAX = DEL DEL = 0.0 ENDIF IF (DEL.NE.0.0 .AND. F1MAX.NE.0.0 .AND. DEL.NE.F1MAX) THEN CALL CCPERR(3, + ' WARNING: possible inconsistency in EXCL: F1MAX cutoff used') DEL = 0.0 ENDIF C IF (DEL1.NE.0.0 .AND. F1MAX.NE.0.0) THEN CALL CCPERR(3, + ' WARNING: possible inconsistency in EXCL: F1MAX cutoff taken') DEL1 = 0.0 ENDIF ELSE IF (ISQ.NE.0 .AND. (DEL.NE.0.0 .AND. DEL1.NE.0.0)) THEN CALL CCPERR(3, + ' WARNING: possible inconsistency in EXCL: DIFF cutoff taken') DEL1 = 0.0 ENDIF ENDIF C C---- Only write out those tests which are actually being applied C IF (SIG1.GT.0.0 .OR. SIG2.GT.0.0 .OR. ABS(F1LIM).GT.0.0 .OR. + F2LIM.GT.0.0 .OR. F1MAX.GT.0. .OR. F2MAX.GT.0.0 .OR. + DEL.GT.0.0 .OR. DEL1.GT.0.0) THEN C WRITE (6,FMT=6012) 6012 FORMAT (/,' *** reflections excluded ***',/) C IF (SIG1 .GT. 0.0) WRITE (6,FMT=6101) SIG1 6101 FORMAT (21X,'if |F1| < ',F6.1,'* |sd(F1)|') IF (SIG2 .GT. 0.0) WRITE (6,FMT=6102) SIG2 6102 FORMAT (21X,'if |F2| < ',F6.1,'* |sd(F2)|') IF (NF1.GT.0 .AND.F1LIM .GT. 0.0) WRITE (6,FMT=6103) F1LIM 6103 FORMAT (21X,'if |F1| (or |DANO|) < ',F10.1) IF (NI1.GT.0 .AND.ABS(F1LIM) .GT. 0.0) WRITE (6,FMT=6123) F1LIM 6123 FORMAT (21X,'if I < ',F10.1) IF (F2LIM .GT. 0.0) WRITE (6,FMT=6104) F2LIM 6104 FORMAT (21X,'if |F2| < ',F10.1) IF (F1MAX .GT. 0.0) THEN IF(NF1.GT.0) WRITE (6,FMT=6013) F1MAX IF(NI1.GT.0) WRITE (6,FMT=6023) F1MAX 6013 FORMAT(21X,'if F1 (or |DANO|) > ',F10.1) 6023 FORMAT(21X,'if I > ',F10.1) ENDIF IF (F2MAX .GT. 0.0) THEN WRITE (6,FMT=6014) F2MAX 6014 FORMAT(21X,'if F2 > ',F10.1) ENDIF IF (DEL .GT. 0.0) WRITE (6,FMT=6011) DEL IF (DEL1 .GT. 0.0) WRITE (6,FMT=6105) DEL1 6011 FORMAT (21X,'if differences |F1-F2| > ',F12.2) 6105 FORMAT (21X,'if absolute magnitude of Sqrt(A*A +B*B) > ', + F12.2) WRITE (6,FMT=6106) 6106 FORMAT (/,/) C ELSE WRITE (6,FMT=6107) 6107 FORMAT (/,' *** No reflections excluded ***',/) ENDIF C IFAIL = 0 C IF (LIST.NE.0) THEN CALL CCPDPN(NABCH,'ABCOEFFS','UNKNOWN','F',LDUM, IFAIL) WRITE(NABCH,'(A,A)') + ' H K L k1*F1 PHI k2*F2 PHI2 ', + 'W1 W2 A B ATAN(B,A) SQRT(AA+BB)' ENDIF IF (LSPGRP.EQ.0) LSPGRP = NSPFFT C C---- Patterson C IF (ABS(ISQ).EQ.1) THEN IF(ISQ.EQ.1) WRITE (6,FMT=6000) 6000 FORMAT (' PATTERSON calculated - amplitudes used = F1 squared -', + /' ** All translational elements of symmetry set to zero', + ' **') C IF(ISQ.EQ.-1) WRITE (6,FMT=6007) 6007 FORMAT (' PATTERSON calculated - amplitudes used = input I -', + /' ** All translational elements of symmetry set to zero', + ' **') C C Get Patterson spacegroup CALL PATSGP(NAMSPG, PGNAME, PATNAM, I) IF (I .LE. 0) THEN WRITE (6, FMT=6001) NAMSPG 6001 FORMAT (' **** WARNING - no Patterson spacegroup known as ', $ 'equivalent to spacegroup ',A, '****'/ $ ' Spacegroup for map left as Fourier spacegroup'/) ELSE LSPGRP = I WRITE (6, FMT=6003) PATNAM(1:LENSTR(PATNAM)), LSPGRP 6003 FORMAT(/' Patterson spacegroup is ',A, $ ', number ',I6/) ENDIF END IF C WRITE (6,FMT=6015) NSYM,NSYMP,NSPFFT,LSPGRP,LIST 6015 FORMAT (/// + ' Number of symmetry and primitive operations =',2I4, + ' Space-group for FFT =',I4, + ' True space-group =',I4, + ' List terms gt',I6) C C---- check error flags C IF (NF1.GT.0 .OR. NF2.LE.0) THEN IF (NH.LE.0 .OR. (NF1.GT.0.AND.NF2.GT.0.AND.NP.GT.0)) THEN IF (NW.GT.0 .OR. IW.EQ.0) THEN IF ((NW2.LE.0.AND.NP2.LE.0) .OR. NF2.NE.0) GO TO 50 END IF END IF END IF C WRITE (6,FMT=6016) 6016 FORMAT (' ** Invalid combination of data items **') KE = KE + 1 C 50 NSYMM = NSYM IF (NSYMM.EQ.0) NSYMM = 1 C DO 70 N = 1,NSYMM DO 60 I = 1,3 C C--- Set translational part of symmetry operator = 0 for Patterson C IF (ABS(ISQ).EQ.1.OR.IPHTR.NE.0) RSYM(I,4,N) = 0.0 TR(I,N) = RSYM(I,4,N) T(N,I) = NINT(TR(I,N)*24.0) 60 CONTINUE C C ******************************** CALL INVSYM(RSYM(1,1,N),RSYMT(1,1,N)) C ******************************** write(6,'(A,4(/,4F8.2,I4))') + ' Sym reset', + (RSYM(I,1,N),RSYM(I,2,N),RSYM(I,3,N),RSYM(I,4,N),T(N,I),I=1,3) C 70 CONTINUE C KSYM = NSYM DO 80 NSG = 1,LSG IF (MSG(NSG).EQ.NSPFFT) GO TO 90 80 CONTINUE C WRITE (6,FMT=6018) 6018 FORMAT (' ** Illegal space group **') NSG = 1 KE = KE + 1 90 CONTINUE C ICEN = MCEN(NSG) C C---- Get axis permutation, read real axes for fast, medium slow C IF (MP(1).EQ.0 .OR. MP(2).EQ.0 .OR. MP(3).EQ.0) THEN C C---- Blank permutation, use default according to whether program is C sectioning along y or z C J = KSC(NSG) C DO 100 J1 = 1,3 MP(J1) = MSP(J1,J) 100 CONTINUE ELSE C C---- Only permit permutation in certain spacegroups C IF (KGPERM(NSG).EQ.0) THEN WRITE (6,FMT='(A)') + ' ****** Axis permutation not allowed in this FFT '// $ 'spacegroup ******' KE = KE + 1 END IF END IF C I1 = MP(1) I2 = MP(2) I3 = MP(3) WRITE (6,FMT=6020) KXYZ(I1),KXYZ(I2),KXYZ(I3) 6020 FORMAT (/' Axis order in map: fast=',A1,', medium= ',A1, + ', slow(section)= ',A1,/) C C---- Now generate program axis permutation C y-section spacegroups have fast medium slow axes z,x,y C z-section y,x,z C J = KSC(NSG) C C---- NSECAX = 2 for "printy" calls; 3 for "printz" calls C NSECAX = J + 1 C DO 110 I = 1,3 J1 = MSP(I,J) KP(J1) = MP(I) 110 CONTINUE IF (KGPERM(NSG).LT.0) THEN C---- Allow only cyclic permutation: check IF ((KP(2)-KP(1))*(KP(3)-KP(2))*(KP(1)-KP(3)) .NE. -2) THEN WRITE (6, FMT='(A)') $ ' **** Non-cyclic permutation NOT allowed in this'// $ ' FFT space-group ****' KE = KE + 1 ENDIF ENDIF C C Fudge Laue group for certain cases IF (NSPFFT .EQ. 47) NLAUE = 15 IF (NSPFFT .EQ. 10) NLAUE = 5 C C---- Set default grid, if not already set C IF (NX.LE.0) THEN C C SETGRD needs to work on true axes C SETGRD uses Laue group, returns sample grid C C NXMIN etc = 2hmax + 1 - set JUNK(.) = this. JUNK(1) = 2*HMAX + 1 JUNK(2) = 2*KMAX + 1 JUNK(3) = 2*LMAX + 1 C Desired sample = approx 3 * maximum index SAMPLE = GRDSMP/2.0 C C ***************************************************** CALL SETGRD(NLAUE,SAMPLE,JUNK(1),JUNK(2),JUNK(3),NX,NY,NZ) C ***************************************************** C IF (NX.LE.0) THEN WRITE (6,FMT='(A,I5)') ' ** Unrecognized Laue group ** ', + NLAFFT KE = KE + 1 END IF END IF C C---- Set up map volume if not set C IF (XYZLIM(1,1).LT.-0.9) THEN C C---- EJD - change - use ft spacegroup. C---- s/r SETLIM uses true spacegroup C C ********************* CALL SETLIM(NSPFFT,XYZLIM) C WRITE (6,FMT=7003)NSPFFT, XYZLIM 7003 FORMAT (/' ** The limits of the map have been set to those of', + /' the CCP4 asymmetric unit for spacegroup ',I4, + //' Min X Max X Min Y Max Y Min Z Max Z', + /,1X,6F8.3, + //' (expressed in fractional coordinates and with x,y,z', + /' referring to the unpermutated axes.)',/) C C CALL SETLIM(LSPGRP,XYZLIM) C ********************* END IF C C C---- Set up limits in grid units C XTMP = (XYZLIM(2,1)-XYZLIM(1,1))* (XYZLIM(2,2)-XYZLIM(1,2))* + (XYZLIM(2,3)-XYZLIM(1,3)) C IF ((XYZLIM(2,1)-XYZLIM(1,1)).LT.0.0000001) THEN XTMP = (XYZLIM(2,2)-XYZLIM(1,2))* (XYZLIM(2,3)-XYZLIM(1,3)) ELSE IF ((XYZLIM(2,2)-XYZLIM(1,2)).LT.0.0000001) THEN XTMP = (XYZLIM(2,1)-XYZLIM(1,1))* (XYZLIM(2,3)-XYZLIM(1,3)) ELSE IF ((XYZLIM(2,3)-XYZLIM(1,3)).LT.0.0000001) THEN XTMP = (XYZLIM(2,2)-XYZLIM(1,2))* (XYZLIM(2,1)-XYZLIM(1,1)) END IF C IF (XTMP.GT.5.0) THEN C C---- more than 5 "gridpoints" in map, limits were input in grid units C XMIN = NINT(XYZLIM(1,1)) XMAX = NINT(XYZLIM(2,1)) YMIN = NINT(XYZLIM(1,2)) YMAX = NINT(XYZLIM(2,2)) ZMIN = NINT(XYZLIM(1,3)) ZMAX = NINT(XYZLIM(2,3)) ELSE C C---- limits were input as fractional limits C C Need INT of Max values.. XMIN = NINT(XYZLIM(1,1)*NX) XMAX = INT(XYZLIM(2,1)*NX) YMIN = NINT(XYZLIM(1,2)*NY) YMAX = INT(XYZLIM(2,2)*NY) ZMIN = NINT(XYZLIM(1,3)*NZ) ZMAX = INT(XYZLIM(2,3)*NZ) END IF C C---- Force limits into range 0 -> NX-1 etc C XMIN = MAX(XMIN,0) XMAX = MIN(XMAX,NX-1) YMIN = MAX(YMIN,0) YMAX = MIN(YMAX,NY-1) ZMIN = MAX(ZMIN,0) ZMAX = MIN(ZMAX,NZ-1) C C---- If projection flag, fix up value for section axis C IPROJ = unpermuted projection axis C IF (IPROJ.NE.0) THEN IPROJ = MP(3) WRITE (6,FMT=6022) KXYZ(IPROJ) 6022 FORMAT (/' Map will be a projection along ',A1,/ + ' SECTION LIMITS set to zero') C C---- Get allowed minimum sample intervals C CALL SETGRD(NLAUE,1.0,0,0,0,JUNK(1),JUNK(2),JUNK(3)) C IF (IPROJ.EQ.1) THEN XMIN = 0 XMAX = 0 NX = JUNK(KP(1)) HMAX = 0 END IF IF (IPROJ.EQ.2) THEN YMIN = 0 YMAX = 0 NY = JUNK(KP(2)) KMAX = 0 END IF IF (IPROJ.EQ.3) THEN ZMIN = 0 ZMAX = 0 NZ = JUNK(KP(3)) LMAX = 0 END IF END IF C I1 = KP(1) I2 = KP(2) I3 = KP(3) WRITE (6,FMT=6024) KXYZ(I1),KXYZ(I2),KXYZ(I3) 6024 FORMAT (/' Permutation of axes: (program=input) x= ',A1,', y= ', + A1,', z= ',A1,/) C C---- Permute symmetry operations if symmetry operations are given C C---- reset permutation matrix C DO 130 I = 1,4 DO 120 J = 1,4 PERM(J,I) = 0.0 120 CONTINUE 130 CONTINUE C PERM(1,I1) = 1.0 PERM(2,I2) = 1.0 PERM(3,I3) = 1.0 PERM(4,4) = 1.0 C IF (NSYM.NE.0) THEN C DO 140 N = 1,NSYM C C ********************* CALL PRMVEC(PERM,T,N,LSYM) C ********************* C 140 CONTINUE END IF C IF (ABS(BIAS) .GT. 0.0001) BIAS = BIAS**2 C C DL 15/11/95: This comment looks bogus; the file number (IFIL) C indicates whence GETHKL was called. C---- Exit for EXPAND C Use hmax=0 as flag that GETHKL has been called from expand C IF (NSYM.NE.0) ISORT = 1 IF (I1.NE.1 .OR. I2.NE.2 .OR. I3.NE.3) THEN ISORT = 1 IF (NSYM.EQ.0) THEN WRITE (6,FMT= + '('' ** You need symmetry for axis permutation **'')') KE = KE + 1 END IF END IF C C---- Set input file stream to 1 unless reset below for scratch file IFIL = 1 C IF (LSPGRP.NE.NSPFFT) ISORT = 1 C IF (ISORT.NE.0) THEN C C---- Before expanding data, stop if any detected errors so far C IF (KE.GT.0) THEN CALL CCPERR(1,' **** Fatal error in input data ****') END IF C C---- Open output file C IFILO = 2 IERR = -1 C C ************************ CALL LWOPEN(IFILO,'FFTHKLSCR') C ************************ C C---- Do you want to change title?? C TITNEW = ' Temporary FFT h k l a b' IERR = -1 C Only need P1 symmetry NSYM1=1 NSYMP1=1 LTYPE1='P' NSPGR1=1 SPGRN1='P1' PGNAM1='PG1' C DO I = 1,4 DO J = 1,4 IF (I.EQ.J) THEN RSYM1(J,I,1) = 1 ELSE RSYM1(J,I,1) = 0 END IF END DO END DO C C C ************************ CALL LWTITL(IFILO,TITNEW,0) CALL LWCELL(IFILO,CELL) CALL LWSYMM(IFILO,NSYM1,NSYMP1,RSYM1,LTYPE1,NSPGR1,SPGRN1, + PGNAM1) C ************************ C IERR = -1 IAPPND = 0 C C **************************************** CALL LWCLAB(IFILO,LSPRGO,NLPRGO,CTPRGO,IAPPND) C **************************************** C IDEBUG = 0 C C ************** CALL EXPAND(IDEBUG) C ************** C C Input and output file closed in EXPAND C C---- Open file FFTHKLSCR to read now C IERR = -1 IFIL = 2 IPRINT = 0 IERR = -1 C C ************************************ CALL LROPEN(IFIL,'FFTHKLSCR',IPRINT,IERR) C ************************************ C IF (IERR.EQ.-1) THEN WRITE (6,FMT=*) ' *** NO SUCH FILE !**' CALL CCPERR(1,' ** Can''t find FFTHKL scratch file') END IF C C Reset USEFREE to avoid problems reading FFTHKLSCR back. USEFREE = .FALSE. LOOKUP(1)=-1 LOOKUP(2)=-1 LOOKUP(3)=-1 LOOKUP(4)=-1 LOOKUP(5)=-1 DO I = 6,MCOLS LOOKUP(I)=0 END DO C C **************************************** CALL LRASSN(IFIL,LSPRGO,NLPRGO,LOOKUP,CTPRGO) C **************************************** C ISORT = 0 NSYM = 0 C C---- Reset first (and only symm operator back to identity C Set one symmetry matrix to identity C DO 160 I = 1,4 DO 150 J = 1,4 IF (I.EQ.J) THEN RSYM(J,I,1) = 1 RSYMT(J,I,1) = 1.0 ELSE RSYM(J,I,1) = 0 RSYMT(J,I,1) = 0.0 END IF 150 CONTINUE 160 CONTINUE C NSYMM = 1 KSYM = 0 ISQ = 0 C C---- Set flag for previously prepared A & B parts C reset nna nnb etc C NNA = 4 NNB = 5 NF1 = -1 NS1 = 0 NP = 0 NF2 = 0 NS2 = 0 NH = 0 NPH = 0 NW = 0 NANOM = 0 NW2 = 0 NP2 = 0 NI1 = 0 END IF C C---- Check minimum & maximum limits C IF (XMIN.GE.0) THEN IF (YMIN.GE.0) THEN IF (ZMIN.GE.0) THEN IF (XMAX.LT.NX) THEN IF (YMAX.LT.NY) THEN IF (ZMAX.LT.NZ) GO TO 170 END IF END IF END IF END IF END IF C WRITE (6,FMT=6026) 6026 FORMAT (/' !!!!!! Illegal limits : XMIN,YMIN,ZMIN must be .ge. 0', + ', XMAX,YMAX,ZMAX must be .lt. NX,NY,NZ !!!!!!',/) KE = KE + 1 C C---- Check for sampling too coarse C 170 IF (NX.GE.2*HMAX+1) THEN IF (NY.GE.2*KMAX+1) THEN IF (NZ.GE.2*LMAX+1) GO TO 180 END IF END IF C WRITE (6,FMT=6028) 6028 FORMAT (/'!!!!!! Sampling too coarse : NX,NY,NZ must be .gt. 2*H', + 'MAX+1, 2*KMAX+1, 2*LMAX+1 !!!!!!',/) KE = KE + 1 C C---- Print input limits etc before permutation C 180 CONTINUE WRITE (6,FMT=6030) 6030 FORMAT (' Before permutation :') C WRITE (6,FMT=6032) HMAX,KMAX,LMAX,NX,NY,NZ,XMIN,XMAX,YMIN,YMAX, + ZMIN,ZMAX 6032 FORMAT (11X,'Maximum indices hkl ...................',3I5,/11X, + 'Sampling intervals on xyz .............',3I5,/11X,'Map l', + 'imits in grid points on xyz ......',3 (2I5,3X),/) C C write (6,fmt=9140) type,nlines,ncol,v,f000,rhomin,rhomax,lcmin, C + lcmax,isp,idig,ilin 6034 FORMAT (/' TYPE NLINES NCOL',7X,'V',8X,'F000',8X,'RHOMIN RHOMAX', + ' MIN MAX ISP IDIG ILIN',/1X,I3,I7,I5,2X,2E12.5,2F9.3, + 5I5,/) C IF (T3.NE.0) WRITE (6,FMT=6036) T3 6036 FORMAT (' Binary map will be written to stream',I4) IF (T4.NE.0) WRITE (6,FMT=6038) 6038 FORMAT (' Map will be printed to line-printer') C IF (ISORT.EQ.0) WRITE (6,FMT=6040) 6040 FORMAT (/' Data is assumed to be sorted') IF (ISORT.NE.0) WRITE (6,FMT=6042) 6042 FORMAT (/' Data is assumed to be unsorted') C IF (ISORT.EQ.0 .AND. PERM(1,1).NE.1) WRITE (6,FMT=6044) C 6044 FORMAT (//' ???? !!!!! Data is assumed to be sorted, but ', C + 'you are permuting indices. Are you sure you have resor', C + 'ted data???!!!!') C IF (ISORT.EQ.0 .AND. PERM(1,1).NE.1) NSYM = 1 IF (ISORT.EQ.0 .AND. PERM(1,1).NE.1) KSYM = 1 IF (ISORT.EQ.0 .AND. PERM(1,1).NE.1) NS = 1 C C---- Now permute limits etc and print C C---- Patch included to conform to F77 Standards C It is not permitted to pass to a subroutine a C single variable (where an array is expected) and C rely on the program selecting the appropriate number C of variables from a labelled COMMON BLOCK C JUNK(1) = NX JUNK(2) = NY JUNK(3) = NZ CALL PRMVEC(PERM,JUNK,1,1) NX = JUNK(1) NY = JUNK(2) NZ = JUNK(3) JUNK(1) = HMAX JUNK(2) = KMAX JUNK(3) = LMAX CALL PRMVEC(PERM,JUNK,1,1) HMAX = JUNK(1) KMAX = JUNK(2) LMAX = JUNK(3) JUNK(1) = XMIN JUNK(2) = YMIN JUNK(3) = ZMIN CALL PRMVEC(PERM,JUNK,1,1) XMIN = JUNK(1) YMIN = JUNK(2) ZMIN = JUNK(3) JUNK(1) = XMAX JUNK(2) = YMAX JUNK(3) = ZMAX CALL PRMVEC(PERM,JUNK,1,1) XMAX = JUNK(1) YMAX = JUNK(2) ZMAX = JUNK(3) WRITE (6,FMT=6046) 6046 FORMAT (' After permutation :') WRITE (6,FMT=6032) HMAX,KMAX,LMAX,NX,NY,NZ,XMIN,XMAX,YMIN,YMAX, + ZMIN,ZMAX C IF (KE.NE.0) THEN WRITE (6,FMT=6048) KE 6048 FORMAT (' Note',I3,' fatal error messages above') CALL CCPERR(1,' ** Fatal error in input **') END IF C END C C C ================== SUBROUTINE CLOSEIT C ================== C C .. Parameters .. INTEGER LSYM PARAMETER (LSYM=192) C .. C .. Scalars in Common .. INTEGER ICEN,IFIL,IFILO,IPROJ,ISQ,IW,KSYM,LIST,NABCH,NANOM,NSECAX, + NF1,NF2,NH,NI1,NNA,NNB,NP,NP2,NPH,NSG,NSSM,NSYMCH,NS1,NS2, + NW,NW2,T2,T3,T4 REAL BIAS,DEL,DEL1,F1LIM,F2LIM,F1MAX,F2MAX,IPHTR,SCLF1,SCLF2, + SCMOD1,SCMOD2,SIG1,SIG2,SMAX,SMIN,TFF1,TFF2 C .. C .. Arrays in Common .. REAL CS,SN,T C C .. Local Scalars .. CHARACTER WORKFILE*255 C .. C .. External Functions .. INTEGER LENSTR EXTERNAL LENSTR C .. C .. External Subroutines .. EXTERNAL UGTENV C .. C .. Common Blocks .. COMMON /IOFFT/IFIL,IFILO,T2,T3,T4,NSYMCH,NABCH,NSECAX COMMON /SEL/NF1,NS1,NF2,NS2,NP,NW,IW,ISQ,NH,SMIN,SMAX,SCLF1,TFF1, + SCLF2,TFF2,BIAS,NSSM,NSG,IPROJ,LIST,ICEN,KSYM,NI1,CS(24), + SN(24),T(LSYM,3),NNA,NNB,NPH,NANOM,NW2,NP2,SIG1,SIG2,DEL, + DEL1,F1LIM,F2LIM,IPHTR,SCMOD1,SCMOD2,F1MAX,F2MAX,CX,CY,CZ C .. IF (LIST .NE. 0) CLOSE(UNIT=NABCH,STATUS='KEEP') CALL LRCLOS (2) C **************************** CALL UGTENV('FFTHKLSCR',WORKFILE) C **************************** C OPEN (UNIT=66,FILE=WORKFILE(1:LENSTR(WORKFILE)),STATUS='OLD', + ERR=10) CLOSE (UNIT=66,STATUS='DELETE') 10 RETURN END C C 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 .. Save statement .. SAVE C .. HL = MOD(EVEN+1,2) + 1 C IF (HL.LE.NX) THEN 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 IF C END C C C C ======================= SUBROUTINE EXC1LE(X,NY) C ======================= C C .. Scalar Arguments .. INTEGER NY C .. C .. Array Arguments .. REAL X(NY) C .. C .. Local Scalars .. REAL A INTEGER K,K2,K2M,KL,KM,KU,KUM,M C .. C .. Save statement .. SAVE C .. M = NY/2 KL = M/2 C IF (KL.NE.0) THEN C C---- Generic Elements . C KM = M KU = M + 1 KUM = KU + M C DO 10 K = 1,KL KM = KM + 1 KU = KU - 1 KUM = KUM - 1 C X(KM) = X(KU) X(K) = -X(KUM) 10 CONTINUE C END IF C C---- Middle element ( Y = 1/4 ) . C K2 = KL + 1 K2M = K2 + M C A = X(K2) X(K2) = -X(K2M) X(K2M) = A C END C C C C ======================= SUBROUTINE EXC1LO(X,NY) C ======================= C C .. Scalar Arguments .. INTEGER NY C .. C .. Array Arguments .. REAL X(NY) C .. C .. Local Scalars .. REAL A INTEGER K,K2,K2M,KL,KM,KU,KUM,M C .. C .. Save statement .. SAVE C .. M = NY/2 KL = M/2 C IF (KL.NE.0) THEN C C---- Generic Elements . C KM = M KU = M + 1 KUM = KU + M C DO 10 K = 1,KL KM = KM + 1 KU = KU - 1 KUM = KUM - 1 C X(KM) = -X(KU) X(K) = X(KUM) 10 CONTINUE C END IF C C---- Middle element ( Y = 1/4 ) . C K2 = KL + 1 K2M = K2 + M C A = X(K2) X(K2) = X(K2M) X(K2M) = -A C END C C C C ========================= SUBROUTINE EXPAND(IDEBUG) C ========================= C C September 1991 - changed to use new binsort. C EXPAND Prepare and expand Fourier coefficients C Uses subroutines from FFT front-end Phil Evans C C F77 version February 1986 C Altered to write out unpermuted indices, which is what C the F77 FFT81 wants, and to sort the file here C C Ejd Feb 1988 - change to print out correct S C C Rewritten under UNIX system. Sort was changed Z210289 C C Changed to MTZ format, Cambridge Workshop, May 1991 P. J. Daly C C .. Parameters .. INTEGER EOF,SORTYP,KEYSIZ PARAMETER (EOF=-1,SORTYP=7,KEYSIZ=4) C .. C .. Scalar Arguments .. INTEGER IDEBUG C .. C .. Scalars in Common .. REAL A,B,SSQ INTEGER IH,IK,IL,ISORT,M,IFIL,IFILO,T2,T3,T4,NSYMCH,NABCH,NSECAX C .. C .. Arrays in Common .. INTEGER KP C .. C .. Local Scalars .. INTEGER I,ICHK,IPRINT,ISTAT,J,LASCND,LRECL,LUNOUT,N,NCOL, + NKEYS CHARACTER HKL*3 C .. C .. Local Arrays .. REAL ADATA(200) INTEGER KEYBUF(51),KEYS(10) C .. C .. External Functions .. INTEGER SRTBEG,SRTMRG,SRTRET,SRTRLS EXTERNAL SRTBEG,SRTMRG,SRTRET,SRTRLS C .. C .. External Subroutines .. EXTERNAL CCPERR,GETHKL,GGETF,LRCLOS,LWCLOS,LWREFL C .. C .. Intrinsic Functions .. INTRINSIC CMPLX,MOD,REAL C .. C .. Common blocks .. COMMON /FFTPRM/KP(3) COMMON /HKLF/A,B,ISORT,IH,IK,IL,M,SSQ COMMON /IOFFT/IFIL,IFILO,T2,T3,T4,NSYMCH,NABCH,NSECAX C .. C .. Save statement .. SAVE C .. C .. Data statements .. DATA HKL/'hkl'/,LUNOUT/6/,LASCND/0/,NCOL/5/,NKEYS/3/, + IPRINT/0/ C .. C WRITE (LUNOUT,FMT=6000) (HKL(KP(I) :KP(I)),I=1,3) 6000 FORMAT (/' Indices should be permuted by FFT to order ', + 3 (A1,3X),/) C C---- Get Record length and keys to sort on C LRECL = NCOL*KEYSIZ DO 10 I = 1,NKEYS KEYS(I) = KP(I) 10 CONTINUE C C---- Set up key buffer for number of keys. A descriptor consists of: C 2-byte length (in bytes) C 2-byte class & type (probably not used) C 4-byte address of array C DO 20 I = 1,NKEYS J = (I-1)*5 + 1 C C---- Sort Type is REAL (SORTYP set up in PARAMETER statement) C KEYBUF(J) = SORTYP C C---- Sort Order ascending/descending C KEYBUF(J+1) = LASCND C C---- position of 1st byte in key C KEYBUF(J+2) = (KEYS(I)-1)*KEYSIZ C C---- keylength in data units (1) C KEYBUF(J+3) = 1 20 CONTINUE WRITE (LUNOUT,FMT=6002) NKEYS, (KEYS(I),I=1,NKEYS) 6002 FORMAT (//1X,I8,' sort keys, in columns ', (3I4),/) C C---- Initialise sort, set parameters, etc C ISTAT = SRTBEG(NKEYS,KEYBUF,LRECL,0) IF (ISTAT.NE.0) THEN WRITE (LUNOUT,FMT=6004) ISTAT 6004 FORMAT (/' Sort fail : INIT, status = ',I8,/) C C ****************************** CALL CCPERR(1,' ERROR Termination') C ****************************** C END IF C N = 0 C C---- Now pass all input records to sort. Array ADATA is REAL C 30 CALL GETHKL C C---- End of file C IF (M.LT.0) GO TO 40 ADATA(KP(1)) = REAL(IH) ADATA(KP(2)) = REAL(IK) ADATA(KP(3)) = REAL(IL) C CALL GGETF C IF (M.LT.0) GO TO 30 ADATA(4) = A ADATA(5) = B C N = N + 1 ICHK = MOD(N,500) IF (ICHK.EQ.1 .AND. IDEBUG.EQ.1) WRITE (LUNOUT,FMT=*) (ADATA(J), + J=1,6) C C---- Pass keys and record to sort C ISTAT = SRTRLS(ADATA) C C---- Loop reflections if ok C IF (ISTAT.NE.0) THEN WRITE (LUNOUT,FMT=6006) ISTAT 6006 FORMAT (' Sort fail : RELEASE, status = ',I8,/) C C ******************************** CALL CCPERR(1,' ERROR - Termination') C ******************************** C END IF C C---- Loop back C GO TO 30 C C---- All records passed, now sort them C 40 WRITE (LUNOUT,FMT=6008) N 6008 FORMAT (1X,I8,' records passed to sort') ISTAT = SRTMRG() C IF (ISTAT.NE.0) THEN WRITE (LUNOUT,FMT=6010) ISTAT 6010 FORMAT (/' Sort fail : MERGE, status = ',I8,/) C C ******************************** CALL CCPERR(1,' ERROR - Termination') C ******************************** C END IF N = 0 C C---- Now pick up records and output C 50 ISTAT = SRTRET(ADATA) C C---- End of file C IF (ISTAT.EQ.EOF) GO TO 60 C IF (ISTAT.NE.0) THEN WRITE (LUNOUT,FMT=6012) ISTAT 6012 FORMAT (/' Sort fail : RETURN , status = ',I8,/) C C ********************************* CALL CCPERR(1,' ERROR - Termination ') C ********************************* C END IF C C---- Write reflection record C C ======================== CALL LWREFL(IFILO,ADATA) C ======================== C N = N + 1 ICHK = MOD(N,500) IF (ICHK.EQ.1 .AND. IDEBUG.EQ.1) WRITE (LUNOUT,FMT=*) (ADATA(J), + J=1,5) GO TO 50 60 CONTINUE C C---- Close MTZ input file C C ================== CALL LRCLOS(IFIL) C ================== C C---- Close MTZ output file C C ========================= CALL LWCLOS(IFILO,IPRINT) C ========================= C WRITE (LUNOUT,FMT=6014) N 6014 FORMAT (1X,I8,' records output') END C C C C ======================= SUBROUTINE FFT1(X,SIZE) C ======================= C C---- fourier synthesis for space group P1 C C .. Scalar Arguments .. INTEGER SIZE C .. C .. Array Arguments .. REAL X(SIZE) C .. C .. Scalars in Common .. INTEGER HMAX,HMIN,IXMAX,IXMIN,IYMAX,IYMIN,IZMAX,IZMIN,KMAX,KMIN, + LMAX,LMIN,NABCH,NSECAX,NSYMCH,NX,NY,NZ,IFIL,IFILO,T2,T3,T4 CHARACTER TITLE*80 C .. C .. Arrays in Common .. INTEGER JMPHDR C .. C .. Local Scalars .. REAL RHMAX,RHMEAN,RHMIN,RHRMS INTEGER I,IREC,IRMAX,LM1,LMODE,LSPGRP,M,MINSIZ,MP1,MP2,NP1, + NRECS,NSEC,NU1,NU2,NV1,NV2,NW1,NWORDS,P1,P2,R,RECS,SKIP, $ MODEDUM C .. C .. Local Arrays .. REAL CELL(6) INTEGER D(5),IUVW(3),MXYZ(3) C .. C .. External Subroutines .. EXTERNAL CCPERR,CMPLFT,FILEO,HERMFT,MRDHDR,PRNTYZ,QOPEN, + SFIPYC,YIN2,YOUT2 C .. C .. Intrinsic Functions .. INTRINSIC MAX C .. C .. Common blocks .. COMMON /HKLLIM/HMAX,KMAX,LMAX,HMIN,KMIN,LMIN COMMON /IOFFT/IFIL,IFILO,T2,T3,T4,NSYMCH,NABCH,NSECAX COMMON /MPHDR/NX,NY,NZ,IXMIN,IXMAX,IYMIN,IYMAX,IZMIN,IZMAX, + JMPHDR(19) COMMON /MPHDRR/TITLE C .. C .. Save statement .. SAVE C .. WRITE (6,FMT=6000) SIZE 6000 FORMAT (//30X,'Fourier synthesis for space-group P1',//I8) C C---- Set index limits C HMIN = -HMAX KMIN = -KMAX LMIN = 0 C C---- Check sampling C IF (NZ.EQ.NZ/2*2) THEN LM1 = LMAX + 1 C C---- Set array size from memory size: SIZE is maximum size, C MINSIZ is minimum = 1 section. Routine returns new value of SIZE C MP1 = ((NY*2)*LM1) MP2 = NX*NZ MINSIZ = MAX(MP1,MP2) C C---- calculate dimensioning parameters C P1 = SIZE/MP1 IF (P1.GT.HMAX-HMIN+1) P1 = HMAX - HMIN + 1 NP1 = P1 P2 = SIZE/MP2 C IF (P1.LE.0 .OR. P2.LE.0) THEN WRITE (6,FMT=6002) SIZE 6002 FORMAT (//' Buffer size too small, ',I8,/) C C *************************** CALL CCPERR(1,' ERROR - 88126') C *************************** C ELSE C C---- Calculate record length and number of records for scratch file C NWORDS = 2*P1*P2*LM1 NRECS = ((IYMAX-IYMIN)/P2+1)* (2*HMAX/P1+1) C C ********************************* CALL FILEO(T2,SIZE,P1,P2,NWORDS,NRECS) CALL QOPEN(T2,'DISKIO1','SCRATCH') CALL QMODE(T2,2,MODEDUM) C ********************************* C C---- transform on k and write results on t2 C IREC = 0 R = HMIN C 10 CONTINUE IF (R+P1.GT.HMAX) P1 = HMAX + 1 - R C C---- read in data C C *********************** CALL SFIPYC(X,NY,LM1,P1,R,M) C *********************** C C---- pass one. transform on k and write intermediate results on t2. C IF (R+P1.GT.HMAX) P1 = HMAX + 1 - R D(1) = (NY*2)* (LMAX+1)*P1 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,P1,P2,IYMIN,IYMAX,T2,IREC,NWORDS) C *************************************************** C R = R + P1 IF (R.LE.HMAX .AND. M.GT.0) 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 P1 = NP1 SKIP = 0 IRMAX = IREC RECS = (IYMAX-IYMIN)/P2 R = IYMIN 20 CONTINUE IREC = 1 IF (R+P2.GT.IYMAX) P2 = IYMAX - R + 1 C C ************************************************* CALL YIN2(X,NZ/2,NX,P2,HMAX,LMAX,P1,SKIP,RECS,T2,IREC,IRMAX, + NWORDS) C ************************************************* C SKIP = SKIP + 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*P2 D(2) = NZ D(3) = NX*NZ D(4) = (LMAX+1)*2 D(5) = 2 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 C---- map calculated for p2 sections C C ************************** CALL PRNTYZ(X,NZ,NX,P2,R,T3,T4) C ************************** C R = R + P2 IF (R.LE.IYMAX) GO TO 20 C C ********************************************* IF (T3.GT.0) CALL MRDHDR(T3,'MAPOUT',TITLE,NSEC,IUVW,MXYZ,NW1, + NU1,NU2,NV1,NV2,CELL,LSPGRP,LMODE, + RHMIN,RHMAX,RHMEAN,RHRMS) C ********************************************* C END IF ELSE C C ********************************************* CALL CCPERR(1,' ERROR - 88127 [permuted] NZ must be even ') C ********************************************* C END IF C END C C C C ======================== SUBROUTINE FFT10(X,SIZE) C ======================== C C P2/m fourier transform and monoclinic patterson function C C this version of the program produces y-sections in C which z varies most rapidly and x varies most slowly. C C the scratch file is in direct access. C G. Bricogne, april 77. C C .. Scalar Arguments .. INTEGER SIZE C .. C .. Array Arguments .. REAL X(SIZE) C .. C .. Scalars in Common .. INTEGER HMAX,HMIN,KMAX,KMIN,LMAX,LMIN,NABCH,NSECAX,NSYMCH,NX,NY, + NZ,IFIL,IFILO,T2,T3,T4,XMAX,XMIN,YMAX,YMIN,ZMAX,ZMIN CHARACTER TITLE*80 C .. C .. Arrays in Common .. INTEGER JMPHDR C .. C .. Local Scalars .. REAL RHMAX,RHMEAN,RHMIN,RHRMS INTEGER C1,C2,C3,I,I1,I2,I3,IREC,IRMAX,LMODE,LSPGRP,M,MINSIZ,MP1, + MP2,NH,NH1,NP1,NRECDS,NSEC,NU1,NU2,NV1,NV2,NW1,NWORDS,NX2, + NY2,NY21,P1,P2,R,RECS,SKIP,T,TIME,MODEDUM C .. C .. Local Arrays .. REAL CELL(6),SECOND(3) INTEGER D(5),IUVW(3),MXYZ(3) C .. C .. External Functions .. INTEGER JTIME,LENSTR EXTERNAL JTIME,LENSTR C .. C .. External Subroutines .. EXTERNAL CCPERR,FILEO,HERMFT,MRDHDR,PRNTYZ,QOPEN,REALFT, + RSYMFT,SFIPYR,YIN1,YOUT1 C .. C .. Intrinsic Functions .. INTRINSIC MAX,REAL C .. C .. Common blocks .. COMMON /HKLLIM/HMAX,KMAX,LMAX,HMIN,KMIN,LMIN COMMON /IOFFT/IFIL,IFILO,T2,T3,T4,NSYMCH,NABCH,NSECAX COMMON /MPHDR/NX,NY,NZ,XMIN,XMAX,YMIN,YMAX,ZMIN,ZMAX,JMPHDR(19) COMMON /MPHDRR/TITLE C .. C .. Save statement .. SAVE C .. C1 = 0 C2 = 0 C3 = 0 I1 = 0 I2 = 0 I3 = 0 C WRITE (6,FMT=6000) 6000 FORMAT (//30X,'Fourier synthesis for space-group P2/m',//) C C---- Set index limits C HMIN = - ((HMAX+1)/2)*2 KMIN = 0 LMIN = 0 C C---- Check sampling C IF (NX.EQ.2* ((NX+1)/2)) THEN IF (NY.EQ.8* ((NY+7)/8)) THEN IF (NZ.EQ.2* ((NZ+1)/2)) THEN IF (XMAX.LE.NX/2) THEN IF (YMAX.LE.NY/2) THEN C NX2 = NX + 2 NY21 = NY/2 + 1 C C---- Set array size from memory size: SIZE is maximum size, C MINSIZ is minimum = 1 section. C Routine returns new value of SIZE C MP1 = ((LMAX+1)*NY21) MP2 = NX2*NZ/2 MINSIZ = MAX(MP1,MP2) C C ********************* c CALL CCPASZ(X,SIZE,MINSIZ) C ********************* C P1 = ((SIZE/ ((LMAX+1)*NY21))/2)*2 P2 = 2*SIZE/ (NX2*NZ) IF (P1.GT.HMAX-HMIN+1) P1 = HMAX - HMIN + 1 NP1 = P1 C IF (P1.LE.0 .OR. P2.LE.0) THEN WRITE (6,FMT=6002) SIZE,NX,NY,NZ,KMAX 6002 FORMAT (' Request too large. Buffer = ',I10,/4I25) C C *********************** CALL CCPERR(1, 'Internal error in fft10') C *********************** C ELSE C C---- calculate the dimensions of the direct-access scratch file t2. C NH = 2*HMAX + 2 C NH1 = (NH-1)/P1 + 1 NY2 = (YMAX-YMIN)/P2 + 1 C NRECDS = NH1*NY2 NWORDS = P1*P2* (LMAX+1) C C---- Open file etc C C ********************************** CALL FILEO(T2,SIZE,P1,P2,NWORDS,NRECDS) CALL QOPEN(T2,'DISKIO1','SCRATCH') CALL QMODE(T2,2,MODEDUM) C ********************************** C C---- pass one. transform on k and write intermediate results on t2. C C---- note that hmax is implicitly rounded up to an even number if odd. C IREC = 0 R = - ((HMAX+1)/2)*2 TIME = JTIME(2) 10 CONTINUE IF (R+P1.GT.HMAX) P1 = 2* ((HMAX+2)/2) - R C C **************************** CALL SFIPYR(X,NY21,LMAX+1,P1,R,M) C **************************** C T = JTIME(2) I1 = I1 + T - TIME TIME = T D(1) = (LMAX+1)*NY21*P1 D(2) = 1 D(3) = D(1) D(4) = D(1) D(5) = NY21 C C ****************** CALL RSYMFT(X,NY21-1,D) C ****************** C T = JTIME(2) C1 = C1 + T - TIME TIME = T C C ************************************ CALL YOUT1(X,NY21,LMAX+1,P1,P2,YMIN,YMAX,T2,IREC, + NWORDS) C ************************************ C T = JTIME(2) I2 = I2 + T - TIME TIME = T R = R + P1 IF (R.LE.HMAX .AND. M.GE.0) 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 T = JTIME(2) I2 = I2 + T - TIME TIME = T IRMAX = IREC SKIP = 0 R = YMIN P1 = ((SIZE/ ((LMAX+1)*NY21))/2)*2 RECS = (YMAX-YMIN)/P2 20 CONTINUE IREC = 1 IF (R+P2.GT.YMAX) P2 = YMAX - R + 1 C C ************************************ CALL YIN1(X,NZ,NX2/2,P2,HMAX,LMAX,P1,SKIP,RECS,T2, + IREC,IRMAX,NWORDS) C ************************************ C SKIP = SKIP + 1 T = JTIME(2) I2 = I2 + T - TIME TIME = T C C---- X now contains intermediate results stored with even/odd pairs of C h across the rows. C D(1) = NX2*NZ*P2/2 D(2) = NZ D(3) = NX2*NZ/2 D(4) = (LMAX+1)*2 D(5) = 2 C C *************************** CALL REALFT(X(1),X(2),NX2/2-1,D) C *************************** C T = JTIME(2) C2 = C2 + T - TIME TIME = T D(2) = 2 D(4) = (XMAX-XMIN+1)*NZ D(5) = NZ I = XMIN*NZ + 1 C C ************************** CALL HERMFT(X(I),X(I+1),NZ/2,D) C ************************** C T = JTIME(2) C3 = C3 + T - TIME TIME = T C C ***************************** CALL PRNTYZ(X,NZ,NX2/2,P2,R,T3,T4) C ***************************** C T = JTIME(2) I3 = I3 + T - TIME TIME = T R = R + P2 IF (R.LE.YMAX) GO TO 20 C C **************************** IF (T3.GT.0) CALL MRDHDR(T3,'MAPOUT',TITLE,NSEC,IUVW, + MXYZ,NW1,NU1,NU2,NV1,NV2, + CELL,LSPGRP,LMODE,RHMIN, + RHMAX,RHMEAN,RHRMS) C **************************** C C---- End of job C WRITE (6,FMT=6004) TITLE(1:LENSTR(TITLE)) 6004 FORMAT (/1X,A) SECOND(1) = REAL(C1)/1000.0 SECOND(2) = REAL(C2)/1000.0 SECOND(3) = REAL(C3)/1000.0 WRITE (6,FMT=6006) SECOND 6006 FORMAT (' Transform Time = ',F7.3,' Seconds.') SECOND(1) = REAL(I1)/1000.0 SECOND(2) = REAL(I2)/1000.0 SECOND(3) = REAL(I3)/1000.0 WRITE (6,FMT=6008) SECOND 6008 FORMAT (' Input/Output Time = ',F7.3,' Seconds.') C END IF RETURN ELSE END IF END IF CALL CCPERR(1, 'Illegal limits: '// $ 'must have XMAX .le. NX/2, YMAX .le. NY/2') ELSE END IF END IF END IF CALL CCPERR(1, 'Illegal sampling intervals: '// $ 'must have NX=2n, NY=8n, NZ=2n') END C C C C ========================= SUBROUTINE FFT144(X,SIZE) C ========================= C C Fourier synthesis for space-group P31/P32 C INTEGER LSYM PARAMETER (LSYM=192) C C .. Scalar Arguments .. INTEGER SIZE C .. C .. Array Arguments .. REAL X(*) C .. C .. Scalars in Common .. INTEGER HMAX,HMIN,IXMAX,IXMIN,IYMAX,IYMIN,IZMAX,IZMIN,KMAX,KMIN, + LMAX,LMIN,NABCH,NSECAX,NSPFFT,NSYMCH,NX,NY,NZ,IFIL,IFILO,T2 $ ,T3,T4,NLAFFT,NSMFFT CHARACTER TITLE*80 C .. C .. Arrays in Common .. INTEGER JMPHDR REAL RSMFFT C .. C .. Local Scalars .. REAL RHMAX,RHMEAN,RHMIN,RHRMS INTEGER I,IREC,KM1,KMAX1,KMX1,LM1,LMODE,LSPGRP,M,MINSIZ,MP1,MP2, + NP2,NRECS,NSEC,NU1,NU2,NV1,NV2,NW1,NWORDS,NXOV3,NXOV31, + NY2,NYOV31,NZ2,NZ21,NZOV3,NZP2,P1,P2,R,MODEDUM C .. C .. Local Arrays .. REAL CELL(6) INTEGER D(5),IUVW(3),MXYZ(3) C .. C .. External Functions .. INTEGER LENSTR EXTERNAL LENSTR C .. C .. External Subroutines .. EXTERNAL CCPERR,CMPLFT,FILEO,HERMFT,MRDHDR,OUT144,PRNTYZ, + QOPEN,SFIPZC,ZIN C .. C .. Intrinsic Functions .. INTRINSIC MAX C .. C .. Common blocks .. COMMON /FFTSPG/NSPFFT,NSMFFT,RSMFFT(4,4,LSYM),NLAFFT COMMON /HKLLIM/HMAX,KMAX,LMAX,HMIN,KMIN,LMIN COMMON /IOFFT/IFIL,IFILO,T2,T3,T4,NSYMCH,NABCH,NSECAX COMMON /MPHDR/NX,NY,NZ,IXMIN,IXMAX,IYMIN,IYMAX,IZMIN,IZMAX, + JMPHDR(19) COMMON /MPHDRR/TITLE C .. C .. Save statement .. SAVE C .. WRITE (6,FMT=6000) 6000 FORMAT (/30X,'Fourier synthesis for space-group P31/P32',//) C C---- Set index limits C HMIN = 0 KMIN = 0 LMIN = -LMAX HMAX = MAX(HMAX,KMAX) KMAX = HMAX IF (NX.LT.2*HMAX+1) NX = 2*HMAX + 2 IF (NZ.LT.2*LMAX+2) NZ = 2*LMAX + 2 C C---- Check sampling etc C IF ((NZ.NE.NZ/6*6) .OR. (NX.NE.NX/6*6) .OR. (NY.NE.NX)) THEN WRITE(6,'(a,3i3,/,a,6i4)')' Current NX,NY,NZ ',NX,NY,NZ, + ' Current IXMIN,IXMAX,IYMIN,IYMAX,IZMIN,IZMAX,', + IXMIN,IXMAX,IYMIN,IYMAX,IZMIN,IZMAX CALL CCPERR(1, 'Illegal sampling intervals: must be NX=NY, NX' + // '=6n, NZ=6n') ELSE LM1 = LMAX + 1 KM1 = KMAX + 1 C C---- calculate dimensioning parameters C NXOV31 = NX/3 + 1 NYOV31 = NY/3 + 1 NXOV3 = NX/3 NZOV3 = NZ/3 NZOV3 = NZ/3 NZ2 = NZ/2 NZ21 = NZ/2 + 1 NZP2 = NZ + 2 KMAX1 = KMAX + 1 C C---- Allocate space at end of array X for C complex array Y(KMAX+1,NX) in OUT C SIZE = SIZE - (KMAX+1)*NX*2 IF (IXMAX.LT.NX) THEN IF (IYMAX.LT.NY) THEN IF (IZMAX.LT.NZ) THEN C NWORDS = 2*KMAX1*NX NRECS = IZMAX - IZMIN + 1 C C---- Set array size from memory size: SIZE is maximum size, C MINSIZ is minimum = 1 section. C Routine returns new value of SIZE C MP1 = (2*NZ*KMAX1) MP2 = NX*NY MINSIZ = MAX(MP1,MP2) C C ********************* c CALL CCPASZ(X,SIZE,MINSIZ) C ********************* C P1 = SIZE/ (2*NZ*KMAX1) P2 = SIZE/ (NX*NY) C IF (P1.GT.HMAX-HMIN+1) P1 = HMAX - HMIN + 1 C IF (P1.LE.0 .OR. P2.LE.0) THEN WRITE (6,FMT=6004) SIZE,NX,NY,NZ,KMAX 6004 FORMAT (' Request too large. Buffer = ',I10,/4I25) C C *********************** CALL CCPERR(1, 'Internal error in FFT144') C *********************** C ELSE C C---- open scratch file now - this contains records y(kmax1,nx) C C ********************************* CALL FILEO(T2,SIZE,P1,P2,NWORDS,NRECS) CALL QOPEN(T2,'DISKIO1','SCRATCH') CALL QMODE(T2,2,MODEDUM) C ********************************* C NP2 = P2 C C---- transform on l and write results on t2 C IREC = 0 R = HMIN 10 CONTINUE IF (R+P1.GT.HMAX) P1 = HMAX + 1 - R C C ************************* CALL SFIPZC(X,NZ,KMAX1,P1,R,M) C ************************* C D(1) = 2*NZ*KMAX1*P1 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 = KMAX1 C C *************************************************** CALL OUT144(X,NZ,KMX1,P1,X(SIZE+1),KMAX1,NX,R,T2,NSPFFT) C *************************************************** C R = R + P1 IF (R.LE.HMAX .AND. M.GT.0) GO TO 10 NY2 = NY/2 IREC = 0 R = IZMIN 20 CONTINUE IF (R+P2.GT.IZMAX) P2 = IZMAX + 1 - R C C *************************************** CALL ZIN(X,NY2,NX,P2,KMAX,NZ,T2,IREC,NWORDS) C *************************************** C D(1) = NX*NY*P2 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 D(4) = (IXMAX-IXMIN+1)*NY D(5) = NY I = IXMIN*NY + 1 C C ************************* CALL HERMFT(X(I),X(I+1),NY2,D) CALL PRNTYZ(X,NY,NX,P2,R,T3,T4) C ************************* C R = R + P2 IF (R.LE.IZMAX) GO TO 20 WRITE (6,FMT=6006) TITLE(1:LENSTR(TITLE)) 6006 FORMAT (' ',A) C C **************************************** IF (T3.GT.0) CALL MRDHDR(T3,'MAPOUT',TITLE,NSEC,IUVW, + MXYZ,NW1,NU1,NU2,NV1,NV2,CELL, + LSPGRP,LMODE,RHMIN,RHMAX, + RHMEAN,RHRMS) C **************************************** C END IF RETURN ELSE END IF END IF END IF CALL CCPERR(1, 'ZMAX must be .le. NZ,XMAX AND YMAX .LE. NX') END IF END C C C C ========================= SUBROUTINE FFT146(X,SIZE) C ========================= C C Fourier synthesis for space-group R3 C The data must lie in the symmetric unit h .ge. 0, k .gt.0 , all l C C Modified to make it work (!!!) and to accept unsorted data, so that C it can be used for space group R32 . A.G.W. Leslie, June 1987. C Note the presence of an extra subroutine MAPSAV associated with this C space group. This is required because the 'standard' asymmetric C unit for this space-group is 0-1 in X, 0-1 in Y, 0-1/3 in Z. C The S/R MAPSAV allows the map to be calculated as 0-1/3 in X, C 0-1/3 in Y and 0-1 in Z which can be more convienent. This C requirement is largely superflous now, since program EXTEND C can produce any desired section of the map. C C .. Scalar Arguments .. INTEGER SIZE C .. C .. Array Arguments .. REAL X(*) C .. C .. Scalars in Common .. INTEGER HMAX,HMIN,IXMAX,IXMIN,IYMAX,IYMIN,IZMAX,IZMIN,KMAX,KMIN, + LMAX,LMIN,NABCH,NSECAX,NSYMCH,NX,NY,NZ,IFIL,IFILO,T2,T3,T4 CHARACTER TITLE*80 C .. C .. Arrays in Common .. INTEGER JMPHDR C .. C .. Local Scalars .. REAL RHMAX,RHMEAN,RHMIN,RHRMS INTEGER HMAXA,HMINA,I,IFLAG,IREC,IYARR,IYARR2,IZDIFF,IZMN1,IZMX1, + KM1,KMAX1,KMX1,LM1,LMODE,LSPGRP,M,MINSIZ,MP1,MP2,NP2, + NREC23,NRECS,NSEC,NU1,NU2,NV1,NV2,NW1,NWORDS,NXOV3,NXOV31, + NY2,NYOV3,NYOV31,NZ2,NZ21,NZOV3,NZP2,P1,P2,R,T5,MODEDUM C .. C .. Local Arrays .. REAL CELL(6) INTEGER D(5),IUVW(3),MXYZ(3) C .. C .. External Functions .. INTEGER LENSTR EXTERNAL LENSTR C .. C .. External Subroutines .. EXTERNAL CCPERR,CMPLFT,FILEO,HERMFT,MAPSAV,MRDHDR,OUT146, + PRNTYZ,QOPEN,SFIPZ3,ZIN,ZINRL C .. C .. Intrinsic Functions .. INTRINSIC MAX C .. C .. Common blocks .. COMMON /HKLLIM/HMAX,KMAX,LMAX,HMIN,KMIN,LMIN COMMON /IOFFT/IFIL,IFILO,T2,T3,T4,NSYMCH,NABCH,NSECAX COMMON /MPHDR/NX,NY,NZ,IXMIN,IXMAX,IYMIN,IYMAX,IZMIN,IZMAX, + JMPHDR(19) COMMON /MPHDRR/TITLE C .. C .. Save statement .. SAVE C .. WRITE (6,FMT=6000) 6000 FORMAT (/30X,'Fourier synthesis for space-group R3',//) C C---- Set index limits C HMIN = 0 KMIN = 0 LMIN = -LMAX HMAX = MAX(HMAX,KMAX) KMAX = HMAX IF (NX.LT.2*HMAX+1) NX = 2*HMAX + 2 IF (NZ.LT.2*LMAX+2) NZ = 2*LMAX + 2 C C---- Check sampling etc C IF ((NZ.NE.NZ/6*6) .OR. (NX.NE.NX/6*6) .OR. (NY.NE.NX)) THEN WRITE(6,'(a,3i3,/,a,6i4)')' Current NX,NY,NZ ',NX,NY,NZ, + ' Current IXMIN,IXMAX,IYMIN,IYMAX,IZMIN,IZMAX,', + IXMIN,IXMAX,IYMIN,IYMAX,IZMIN,IZMAX CALL CCPERR(1, 'Illegal sampling intervals: must be NX=NY, NX' + // '=6n, NZ=6n') ELSE LM1 = LMAX + 1 KM1 = KMAX + 1 C C---- calculate dimensioning parameters C NXOV31 = NX/3 + 1 NYOV31 = NY/3 + 1 NXOV3 = NX/3 NYOV3 = NY/3 NZOV3 = NZ/3 NZ2 = NZ/2 NZ21 = NZ/2 + 1 NZP2 = NZ + 2 KMAX1 = KMAX + 1 C C---- no need to reorder map if izmax-izmin.lt.nzov3 C xmax and ymax can then be le nx-1 C mark this option by iflag = 1 C IZDIFF = IZMAX - IZMIN IFLAG = 1 IZMN1 = IZMIN IZMX1 = IZMAX C IF (IZDIFF.GE.NZOV3) THEN C C---- check xmax and ymax lt nxov3 C set iflag = 0 C IF ((IXMAX.GT.NXOV3) .OR. (IYMAX.GT.NYOV3) .OR. + (IZMAX.GE.NZ)) THEN CALL CCPERR(1, 'ZMAX must be .le. NZ, XMAX AND YMAX .LE. ' + // 'NX/3') ELSE IZMN1 = 0 IZMX1 = NZOV3 - 1 IFLAG = 0 END IF END IF C C---- Allocate space at end of array X for C complex array Y(KMAX+1,NX) in OUT C AND real array Y(NXOV31,NYOV31) for S/R MAPSAV if needed C IYARR = 2*NX*KMAX1 IYARR2 = NXOV31*NYOV31 IF (IFLAG.EQ.0) IYARR = MAX(IYARR,IYARR2) SIZE = SIZE - IYARR C NWORDS = 2*KMAX1*NX NRECS = IZMAX - IZMIN + 1 C C---- Set array size from memory size: SIZE is maximum size, C MINSIZ is minimum = 1 section. C Routine returns new value of SIZE C MP1 = (2*NZOV3*KMAX1) MP2 = NX*NY MINSIZ = MAX(MP1,MP2) C C ********************* c CALL CCPASZ(X,SIZE,MINSIZ) C ********************* C P1 = SIZE/ (2*NZOV3*KMAX1) P2 = SIZE/ (NX*NY) IF (P1.GT.HMAX-HMIN+1) P1 = HMAX - HMIN + 1 C IF (P1.LE.0 .OR. P2.LE.0) THEN WRITE (6,FMT=6006) SIZE,NX,NY,NZ,KMAX 6006 FORMAT (' Request TOO Large. Buffer = ',I10,/4I25) C C *********************** CALL CCPERR(1, 'Internal error in FFT146') C *********************** C ELSE C C---- open scratch file now - this contains records y(kmax1,nx) C C ********************************* CALL FILEO(T2,SIZE,P1,P2,NWORDS,NRECS) CALL QOPEN(T2,'DISKIO1','SCRATCH') CALL QMODE(T2,2,MODEDUM) C ********************************* C NP2 = P2 C C---- transform on l and write results on t2 C NREC23 = NXOV31*NYOV31 C IF (IFLAG.EQ.0) THEN C *************************** CALL QOPEN(T5,'DISKIO2','SCRATCH') CALL QMODE(T5,2,MODEDUM) C *************************** END IF C IREC = 0 HMINA = HMIN 10 CONTINUE IF (HMINA+P1.GT.HMAX) P1 = HMAX + 1 - HMINA HMAXA = HMINA + P1 - 1 C C ************************************** CALL SFIPZ3(X,NZOV3,KMAX1,P1,HMINA,HMAXA,M) C ************************************** C D(1) = 2*NZOV3*KMAX1*P1 D(2) = 2 D(3) = D(1) D(4) = D(1) D(5) = 2*NZOV3 C C ************************* CALL CMPLFT(X(1),X(2),NZOV3,D) C ************************* C KMX1 = KMAX1 C C ******************************************************** CALL OUT146(X,NZOV3,KMX1,P1,X(SIZE+1),KMAX1,NX,HMINA,T2,IZMN1, + IZMX1) C ******************************************************** C HMINA = HMINA + P1 IF (HMINA.LE.HMAX .AND. M.GT.0) GO TO 10 IF (IFLAG.EQ.0) WRITE (6,FMT=6008) NZOV3 6008 FORMAT (' No of Records on Scratch File = ',I5) NY2 = NY/2 C C---- ZMIN = 0, ZMAX = NZ/3 -1 for first pass at map if IFLAG = 0 C ZMIN= IZMIN ZMAX = IZMAX IF IFLAG=1 C IREC = 0 R = IZMN1 20 CONTINUE IF (R+P2.GT.IZMX1) P2 = IZMX1 + 1 - R C C *************************************** CALL ZIN(X,NY2,NX,P2,KMAX,NZ,T2,IREC,NWORDS) C *************************************** C D(1) = NX*NY*P2 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 D(4) = NX*NY I = 1 D(5) = NY C C **************************************************** CALL HERMFT(X(I),X(I+1),NY2,D) IF (IFLAG.EQ.0) CALL MAPSAV(X,NY,NX,P2,R,NZOV3,X(SIZE+1), + NYOV31,NXOV31,T5) IF (IFLAG.EQ.1) CALL PRNTYZ(X,NY,NX,P2,R,T3,T4) C ***************************************** C R = R + P2 IF (R.LE.IZMX1) GO TO 20 C IF (IFLAG.NE.1) THEN C C---- if (iflag.eq.0) reorder the map now. C P2 = NP2 IREC = IZMIN R = IZMIN 30 CONTINUE C IF (R+P2.GT.IZMAX) P2 = IZMAX - R + 1 C C ********************************* CALL ZINRL(X,NYOV31,NXOV31,P2,T5,IREC) CALL PRNTYZ(X,NYOV31,NXOV31,P2,R,T3,T4) C ********************************* C R = R + P2 IF (R.LE.IZMAX) GO TO 30 END IF C C---- End of job write map header C WRITE (6,FMT=6010) TITLE(1:LENSTR(TITLE)) 6010 FORMAT (' ',A) C C ************************************************ IF (T3.GT.0) CALL MRDHDR(T3,'MAPOUT',TITLE,NSEC,IUVW,MXYZ,NW1, + NU1,NU2,NV1,NV2,CELL,LSPGRP,LMODE, + RHMIN,RHMAX,RHMEAN,RHRMS) C ************************************************ C END IF END IF C END C C C C ========================= SUBROUTINE FFT152(X,SIZE) C ========================= C C Fourier synthesis for space-group P3121 (152) and P3221 (154) C INTEGER LSYM PARAMETER (LSYM=192) C C .. Scalar Arguments .. INTEGER SIZE C .. C .. Array Arguments .. REAL X(*) C .. C .. Scalars in Common .. INTEGER HMAX,HMIN,IXMAX,IXMIN,IYMAX,IYMIN,IZMAX,IZMIN,KMAX,KMIN, + LMAX,LMIN,NABCH,NSECAX,NSPFFT,NSYMCH,NX,NY,NZ,IFIL,IFILO,T2 $ ,T3,T4,NSMFFT,NLAFFT CHARACTER TITLE*80 C .. C .. Arrays in Common .. INTEGER JMPHDR REAL RSMFFT C .. C .. Local Scalars .. REAL RHMAX,RHMEAN,RHMIN,RHRMS INTEGER HMAXA,HMINA,I,IHKA,IREC,KHMIN,KM1,KMAX1,LM1,LMODE,LSPGRP, + M,MINSIZ,MP1,MP2,NRECS,NSEC,NU1,NU2,NV1,NV2,NW1,NWORDS, + NX1,NY2,NZ2,NZ21,NZP2,P1,P2,R,MODEDUM C .. C .. Local Arrays .. REAL CELL(6) INTEGER D(5),IUVW(3),MXYZ(3) C .. C .. External Functions .. INTEGER LENSTR EXTERNAL LENSTR C .. C .. External Subroutines .. EXTERNAL CCPERR,CMPLFT,FILEO,HERMFT,MRDHDR,OUT152,PRNTYZ, + QOPEN,SFIP92,ZIN C .. C .. Intrinsic Functions .. INTRINSIC INT,MAX,SQRT C .. C .. Common blocks .. COMMON /FFTSPG/NSPFFT,NSMFFT,RSMFFT(4,4,LSYM),NLAFFT COMMON /HKLLIM/HMAX,KMAX,LMAX,HMIN,KMIN,LMIN COMMON /IOFFT/IFIL,IFILO,T2,T3,T4,NSYMCH,NABCH,NSECAX COMMON /MPHDR/NX,NY,NZ,IXMIN,IXMAX,IYMIN,IYMAX,IZMIN,IZMAX, + JMPHDR(19) COMMON /MPHDRR/TITLE C .. C .. Save statement .. SAVE C .. WRITE (6,FMT=6000) 6000 FORMAT (/30X,'Fourier synthesis for space-group P3121/P3221',/) C C---- Set index limits C HMIN = 0 KMIN = 0 LMIN = -LMAX HMAX = MAX(HMAX,KMAX) KMAX = HMAX IF (NX.LT.2*HMAX+1) NX = 2*HMAX + 2 IF (NZ.LT.2*LMAX+2) NZ = 2*LMAX + 2 C C---- Check sampling etc C IF ((NZ.NE.NZ/6*6) .OR. (NX.NE.NX/6*6) .OR. (NY.NE.NX)) THEN WRITE(6,'(a,3i3,/,a,6i4)')' Current NX,NY,NZ ',NX,NY,NZ, + ' Current IXMIN,IXMAX,IYMIN,IYMAX,IZMIN,IZMAX,', + IXMIN,IXMAX,IYMIN,IYMAX,IZMIN,IZMAX CALL CCPERR(1, 'Illegal sampling intervals: must be NX=NY, NX' + //'=6n, NZ=6n') ELSE LM1 = LMAX + 1 KM1 = KMAX + 1 C C---- calculate dimensioning parameters C NZ2 = NZ/2 NZ21 = NZ/2 + 1 NZP2 = NZ + 2 KMAX1 = KMAX + 1 C C---- Allocate space at end of array X for C complex array Y(KMAX+1,NX) in OUT C SIZE = SIZE - (KMAX+1)*NX*2 C IF (IXMAX.LT.NX) THEN IF (IYMAX.LT.NY) THEN IF (IZMAX.LT.NZ) THEN C NWORDS = 2*KMAX1*NX NRECS = IZMAX - IZMIN + 1 C C---- Set array size from memory size: SIZE is maximum size, C MINSIZ is minimum = 1 section. C Routine returns new value of SIZE C MP1 = (2*NZ) MP2 = NX*NY MINSIZ = MAX(MP1,MP2) C C ********************* c CALL CCPASZ(X,SIZE,MINSIZ) C ********************* C P1 = SIZE/ (2*NZ) P2 = SIZE/ (NX*NY) C IF (P1.LE.0 .OR. P2.LE.0) THEN WRITE (6,FMT=6004) SIZE,NX,NY,NZ,KMAX 6004 FORMAT (' Request too large. Buffer = ',I10,/4I25) C C *********************** CALL CCPERR(1, 'Internal error in FFT152') C *********************** C ELSE C C---- open scratch file now - this contains records y(kmax1,nx) C C ********************************* CALL FILEO(T2,SIZE,P1,P2,NWORDS,NRECS) CALL QOPEN(T2,'DISKIO1','SCRATCH') CALL QMODE(T2,2,MODEDUM) C ********************************* C KHMIN = 0 HMINA = 0 10 CONTINUE C C---- First pass (transform on l) C C---- Want (HMAXA+1)*(HMAXA+2)/2 .LE. P1 + KHMIN C HMAXA = INT(SQRT(9.0- (1-P1-KHMIN)*8.0)+ (-3.0))/2 IF (HMAXA.GT.HMAX) HMAXA = HMAX IHKA = (HMAXA+1)* (HMAXA+2)/2 - KHMIN IHKA = ((IHKA+1)/2)*2 C C ************************************* CALL SFIP92(X,NZ,IHKA,HMINA,HMAXA,KHMIN,M) 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 KMAX1 = KMAX + 1 C C---- Write intermediate results C C *********************************************** CALL OUT152(X,NZ,IHKA,X(SIZE+1),KMAX1,NX,HMINA,HMAXA, + KHMIN,T2,NSPFFT) C *********************************************** C HMINA = HMAXA + 1 KHMIN = (HMAXA+1)* (HMAXA+2)/2 IF (HMINA.LE.HMAX .AND. M.GT.0) GO TO 10 C C---- End of first pass C KMAX1 = KMAX + 1 NX1 = NX + 1 NY2 = NY/2 IREC = 0 R = IZMIN 20 CONTINUE C C---- Start of second pass C IF (R+P2.GT.IZMAX) P2 = IZMAX - R + 1 C C *************************************** CALL ZIN(X,NY2,NX,P2,KMAX,NZ,T2,IREC,NWORDS) C *************************************** C D(1) = NX*NY*P2 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 D(4) = NX*NY D(5) = NY I = IXMIN*NY + 1 C C ************************** CALL HERMFT(X(I),X(I+1),NY2,D) CALL PRNTYZ(X,NY,NX,P2,R,T3,T4) C ************************** C R = R + P2 IF (R.LE.IZMAX) GO TO 20 C C---- End of second pass C C---- End of job C WRITE (6,FMT=6006) TITLE(1:LENSTR(TITLE)) 6006 FORMAT (' ',A) C C---- Read map header info C C ***************************************** IF (T3.GT.0) CALL MRDHDR(T3,'MAPOUT',TITLE,NSEC,IUVW, + MXYZ,NW1,NU1,NU2,NV1,NV2,CELL, + LSPGRP,LMODE,RHMIN,RHMAX, + RHMEAN,RHRMS) C ****************************************** C END IF RETURN ELSE END IF END IF END IF CALL CCPERR(1, 'ZMAX must be .le. NZ, XMAX AND YMAX .LE. NX') END IF END C C C C ======================== SUBROUTINE FFT16(X,SIZE) C ======================== C C calculates a fourier synthesis for space group p222 given the C unique set of structure factors. the volume calculated is half C x, half y, and all z. C C this version of the program produces y-sections in C which z varies most rapidly and x varies most slowly. C C the scratch file is in direct access. C G. Bricogne, april 77. C C .. Scalar Arguments .. INTEGER SIZE C .. C .. Array Arguments .. REAL X(SIZE) C .. C .. Scalars in Common .. INTEGER HMAX,HMIN,KMAX,KMIN,LMAX,LMIN,NABCH,NSECAX,NSYMCH,NX,NY, + NZ,IFIL,IFILO,T2,T3,T4,XMAX,XMIN,YMAX,YMIN,ZMAX,ZMIN CHARACTER TITLE*80 C .. C .. Arrays in Common .. INTEGER JMPHDR C .. C .. Local Scalars .. REAL RHMAX,RHMEAN,RHMIN,RHRMS,T,TIME INTEGER C1,C2,C3,I,I1,I2,I3,IREC,IRMAX,LMODE,LSPGRP,M,MINSIZ,MP1, + MP2,NH,NH1,NP1,NRECDS,NSEC,NU1,NU2,NV1,NV2,NW1,NWORDS,NY2, + P1,P2,R,RECS,SKIP,MODEDUM C .. C .. Local Arrays .. REAL CELL(6),SECOND(3) INTEGER D(5),IUVW(3),MXYZ(3) C .. C .. External Functions .. INTEGER JTIME,LENSTR EXTERNAL JTIME,LENSTR C .. C .. External Subroutines .. EXTERNAL CCPERR,FILEO,HERMFT,MRDHDR,PRNTYZ,QOPEN,REALFT, + SFIPYC,TRNSP1,YIN3,YOUT1 C .. C .. Intrinsic Functions .. INTRINSIC MAX,REAL C .. C .. Common blocks .. COMMON /HKLLIM/HMAX,KMAX,LMAX,HMIN,KMIN,LMIN COMMON /IOFFT/IFIL,IFILO,T2,T3,T4,NSYMCH,NABCH,NSECAX COMMON /MPHDR/NX,NY,NZ,XMIN,XMAX,YMIN,YMAX,ZMIN,ZMAX,JMPHDR(19) COMMON /MPHDRR/TITLE C .. C .. Save statement .. SAVE C .. C1 = 0 C2 = 0 C3 = 0 I1 = 0 I2 = 0 I3 = 0 C WRITE (6,FMT=6000) 6000 FORMAT (/30X,'Fourier synthesis for space-group P222',//) C HMAX = (HMAX/2)*2 + 1 IF (NX.GE.2*HMAX+1) THEN C C---- Set index limits C HMIN = 0 KMIN = 0 LMIN = 0 C C---- Check sampling C IF (NX.EQ.NX/2*2) THEN IF (NY.EQ.NY/2*2) THEN IF (NZ.NE.NZ/2*2) THEN ELSE IF (XMAX.LE.NX/2) THEN C C---- Set array size from memory size: SIZE is maximum size, C MINSIZ is minimum = 1 section. C Routine returns new value of SIZE C MP1 = (2*NY* (LMAX+1))/2 MP2 = (NX/2+1)*NZ MINSIZ = MAX(MP1,MP2) C C ********************* c CALL CCPASZ(X,SIZE,MINSIZ) C ********************* C P1 = (SIZE/ (2*NY* (LMAX+1)))*2 IF (P1.GT.HMAX-HMIN+1) P1 = HMAX - HMIN + 1 NP1 = P1 P2 = SIZE/ ((NX/2+1)*NZ) C IF (P1.LE.0 .OR. P2.LE.0) THEN WRITE (6,FMT=6002) SIZE,NX,NY,NZ,KMAX 6002 FORMAT (' Request too large. Buffer = ',I10,/4I25) C C *********************** CALL CCPERR(1, 'Internal error in FFT16') C *********************** C ELSE C C---- calculate the dimensions of the direct-access scratch file t2. C NH = HMAX + 1 C NH1 = (NH-1)/P1 + 1 NY2 = (YMAX-YMIN)/P2 + 1 C NRECDS = 2*NH1*NY2 NWORDS = P1*P2* (LMAX+1) C C ********************************** CALL FILEO(T2,SIZE,P1,P2,NWORDS,NRECDS) CALL QOPEN(T2,'DISKIO1','SCRATCH') CALL QMODE(T2,2,MODEDUM) C ********************************** C C---- pass one. transform on k and write intermediate results on t2. C IREC = 0 R = 0 TIME = JTIME(2) 10 CONTINUE IF (R+P1.GT.HMAX) P1 = HMAX + 1 - R C C **************************** CALL SFIPYC(X,NY/2,LMAX+1,P1,R,M) C **************************** C T = JTIME(2) I1 = I1 + T - TIME TIME = T D(1) = NY*P1* (LMAX+1) D(2) = 2 D(3) = D(1) D(4) = D(1) D(5) = NY C C ************************ CALL HERMFT(X(1),X(2),NY/2,D) C ************************ C T = JTIME(2) C1 = C1 + T - TIME TIME = T C C ************************************** CALL YOUT1(X,NY,LMAX+1,P1,P2,YMIN,YMAX,T2,IREC,NWORDS) CALL TRNSP1(X,NY,LMAX+1,P1) CALL YOUT1(X,NY,LMAX+1,P1,P2,YMIN,YMAX,T2,IREC,NWORDS) C ************************************** C T = JTIME(2) I2 = I2 + T - TIME TIME = T R = R + P1 IF (R.LE.HMAX .AND. M.GT.0) 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 T = JTIME(2) I2 = I2 + T - TIME TIME = T IRMAX = IREC SKIP = 0 RECS = (YMAX-YMIN)/P2 R = YMIN 20 CONTINUE P1 = NP1 IREC = 1 IF (R+P2.GT.YMAX) P2 = YMAX - R + 1 C C ************************************** CALL YIN3(X,NZ,NX/2+1,P2,HMAX,LMAX,P1,SKIP,RECS,T2,IREC, + IRMAX,NWORDS) C ************************************** C SKIP = SKIP + 1 T = JTIME(2) I2 = I2 + T - TIME TIME = T C C---- X now contains intermediate results stored with l down the C columns and h across the rows. C D(1) = (NX+2)*NZ*P2/2 D(2) = NZ D(3) = (NX+2)*NZ/2 D(4) = (LMAX+1)*2 D(5) = 2 C C ************************ CALL REALFT(X(1),X(2),NX/2,D) C ************************ C T = JTIME(2) C2 = C2 + T - TIME TIME = T D(2) = 2 D(3) = (NX+2)*NZ/2 D(4) = (XMAX-XMIN+1)*NZ D(5) = NZ I = XMIN*NZ + 1 C C ************************** CALL HERMFT(X(I),X(I+1),NZ/2,D) C ************************** C T = JTIME(2) C3 = C3 + T - TIME TIME = T C C ****************************** CALL PRNTYZ(X,NZ,NX/2+1,P2,R,T3,T4) C ****************************** C T = JTIME(2) I3 = I3 + T - TIME TIME = T R = R + P2 IF (R.LE.YMAX) GO TO 20 C C ******************************* IF (T3.GT.0) CALL MRDHDR(T3,'MAPOUT',TITLE,NSEC,IUVW, + MXYZ,NW1,NU1,NU2,NV1,NV2,CELL, + LSPGRP,LMODE,RHMIN,RHMAX, + RHMEAN,RHRMS) C ******************************* C C---- End of job C WRITE (6,FMT=6004) TITLE(1:LENSTR(TITLE)) 6004 FORMAT (' ',A) SECOND(1) = REAL(C1)/1000.0 SECOND(2) = REAL(C2)/1000.0 SECOND(3) = REAL(C3)/1000.0 WRITE (6,FMT=6006) SECOND 6006 FORMAT (' Transform Time = ',F7.3,' Seconds.') SECOND(1) = REAL(I1)/1000.0 SECOND(2) = REAL(I2)/1000.0 SECOND(3) = REAL(I3)/1000.0 WRITE (6,FMT=6008) SECOND 6008 FORMAT (' Input/Output Time = ',F7.3,' Seconds.') END IF C RETURN ELSE CALL CCPERR(1, + 'Illegal limits: must be [permuted] XMAX .le. NX/2') END IF END IF END IF CALL CCPERR(1, 'Illegal sampling: '// $ 'must be [permuted] NX=2n, NY=2n, NZ=2n') ELSE WRITE (6,FMT=6014) NX,HMAX 6014 FORMAT (/' !!!! [permuted] NX =,',I5, $ ' must be .ge. 2*HMAX+1, HMAX =',I5,/) C C ************************ CALL CCPERR(1, 'Bad grid size') C ************************ C END IF C END C C C C ========================= SUBROUTINE FFT169(X,SIZE) C ========================= C C Fourier synthesis for space-group p61/P65 C INTEGER LSYM PARAMETER (LSYM=192) C C .. Scalar Arguments .. INTEGER SIZE C .. C .. Array Arguments .. REAL X(*) C .. C .. Scalars in Common .. INTEGER HMAX,HMIN,IXMAX,IXMIN,IYMAX,IYMIN,IZMAX,IZMIN,KMAX,KMIN, + LMAX,LMIN,NABCH,NSECAX,NSPFFT,NSYMCH,NX,NY,NZ,IFIL,IFILO,T2 $ ,T3,T4,NSMFFT,NLAFFT CHARACTER TITLE*80 C .. C .. Arrays in Common .. INTEGER JMPHDR REAL RSMFFT C .. C .. Local Scalars .. REAL RHMAX,RHMEAN,RHMIN,RHRMS INTEGER I,IREC,KM1,KMAX1,KMX1,LM1,LMODE,LSPGRP,M,MINSIZ,MP1,MP2, + NP2,NRECS,NSEC,NU1,NU2,NV1,NV2,NW1,NWORDS,NXOV3,NXOV31, + NY2,NYOV31,NZ2,NZ21,NZOV3,NZP2,P1,P2,R,MODEDUM C .. C .. Local Arrays .. REAL CELL(6) INTEGER D(5),IUVW(3),MXYZ(3) C .. C .. External Functions .. INTEGER LENSTR EXTERNAL LENSTR C .. C .. External Subroutines .. EXTERNAL CCPERR,CMPLFT,FILEO,HERMFT,MRDHDR,OUT169,PRNTYZ, + QOPEN,SDIAD,SFIPZC,ZIN C .. C .. Intrinsic Functions .. INTRINSIC MAX C .. C .. Common blocks .. COMMON /FFTSPG/NSPFFT,NSMFFT,RSMFFT(4,4,LSYM),NLAFFT COMMON /HKLLIM/HMAX,KMAX,LMAX,HMIN,KMIN,LMIN COMMON /IOFFT/IFIL,IFILO,T2,T3,T4,NSYMCH,NABCH,NSECAX COMMON /MPHDR/NX,NY,NZ,IXMIN,IXMAX,IYMIN,IYMAX,IZMIN,IZMAX, + JMPHDR(19) COMMON /MPHDRR/TITLE C .. C .. Save statement .. SAVE C .. WRITE (6,FMT=6000) 6000 FORMAT (/30X,'Fourier synthesis for space-group P61/P65',//) C C---- Set index limits C HMIN = 0 KMIN = 0 LMIN = -LMAX HMAX = MAX(HMAX,KMAX) KMAX = HMAX IF (NX.LT.2*HMAX+1) NX = 2*HMAX + 2 IF (NZ.LT.2*LMAX+2) NZ = 2*LMAX + 2 C C---- Check sampling etc C C *********************** IF(IZMAX.GT.NZ/2) THEN WRITE(6,'(a,3i3,/,a,6i4)')' Current NX,NY,NZ ',NX,NY,NZ, + ' Current IXMIN,IXMAX,IYMIN,IYMAX,IZMIN,IZMAX,', + IXMIN,IXMAX,IYMIN,IYMAX,IZMIN,IZMAX WRITE (6,FMT=6001) 6001 FORMAT (/' !!! ZMAX must be .le. NZ/2 !!!',/) CALL CCPERR(1,'Fatal error') END IF C *********************** C IF ((NZ.NE.NZ/12*12) .OR. (NX.NE.NX/6*6) .OR. (NY.NE.NX)) THEN WRITE(6,'(a,3i3,/,a,6i4)')' Current NX,NY,NZ ',NX,NY,NZ, + ' Current IXMIN,IXMAX,IYMIN,IYMAX,IZMIN,IZMAX,', + IXMIN,IXMAX,IYMIN,IYMAX,IZMIN,IZMAX CALL CCPERR(1, 'Illegal sampling intervals : must be NX=NY, NX' + // '=6n, NZ=12n !!!!') ELSE LM1 = LMAX + 1 KM1 = KMAX + 1 C C---- calculate dimensioning parameters C NXOV31 = NX/3 + 1 NYOV31 = NY/3 + 1 NXOV3 = NX/3 NZOV3 = NZ/3 NZOV3 = NZ/3 NZ2 = NZ/2 NZ21 = NZ/2 + 1 NZP2 = NZ + 2 KMAX1 = KMAX + 1 C C---- Allocate space at end of array X for C complex array Y(KMAX+1,NX) in OUT C SIZE = SIZE - (KMAX+1)*NX*2 C IF (IXMAX.LT.NX) THEN IF (IYMAX.LT.NY) THEN IF (IZMAX.LT.NZ) THEN C NWORDS = 2*KMAX1*NX NRECS = IZMAX - IZMIN + 1 C C---- Set array size from memory size: SIZE is maximum size, C MINSIZ is minimum = 1 section. C Routine returns new value of SIZE C MP1 = (NZ+2)*KMAX1 MP2 = NX*NY MINSIZ = MAX(MP1,MP2) C C ********************* c CALL CCPASZ(X,SIZE,MINSIZ) C ********************* C P1 = SIZE/ ((NZ+2)*KMAX1) P2 = SIZE/ (NX*NY) C IF (P1.LE.0 .OR. P2.LE.0) THEN WRITE (6,FMT=6004) SIZE,NX,NY,NZ,KMAX 6004 FORMAT (' Request too large. Buffer = ',I10,/4I25) C C *********************** CALL CCPERR(1, 'Internal error in FFT169') C *********************** C ELSE C C---- open scratch file now - this contains records y(kmax1,nx) C C ********************************* CALL FILEO(T2,SIZE,P1,P2,NWORDS,NRECS) CALL QOPEN(T2,'DISKIO1','SCRATCH') CALL QMODE(T2,2,MODEDUM) C ********************************* C NP2 = P2 C C---- transform on l and write results on t2 C IREC = 0 R = HMIN 10 CONTINUE IF (R+P1.GT.HMAX) P1 = HMAX + 1 - R C C *************************** CALL SFIPZC(X,NZ21,KMAX1,P1,R,M) C *************************** C D(1) = (NZ+2)*KMAX1*P1 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) C *********************** C KMX1 = KMAX1 C C ************************************************ CALL OUT169(X,NZ/2+1,KMX1,P1,X(SIZE+1),KMAX1,NX,R,T2, + NSPFFT) C ************************************************ C R = R + P1 IF (R.LE.HMAX .AND. M.GT.0) GO TO 10 NY2 = NY/2 IREC = 0 R = IZMIN 20 CONTINUE IF (R+P2.GT.IZMAX) P2 = IZMAX + 1 - R C C *************************************** CALL ZIN(X,NY2,NX,P2,KMAX,NZ,T2,IREC,NWORDS) C *************************************** C D(1) = NX*NY*P2 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 D(4) = (IXMAX-IXMIN+1)*NY D(5) = NY I = IXMIN*NY + 1 C C ************************** CALL HERMFT(X(I),X(I+1),NY2,D) CALL PRNTYZ(X,NY,NX,P2,R,T3,T4) C ************************** C R = R + P2 IF (R.LE.IZMAX) GO TO 20 WRITE (6,FMT=6006) TITLE(1:LENSTR(TITLE)) 6006 FORMAT (' ',A) C C ***************************************** IF (T3.GT.0) CALL MRDHDR(T3,'MAPOUT',TITLE,NSEC,IUVW, + MXYZ,NW1,NU1,NU2,NV1,NV2,CELL, + LSPGRP,LMODE,RHMIN,RHMAX, + RHMEAN,RHRMS) C ***************************************** C END IF RETURN ELSE END IF END IF END IF CALL CCPERR(1, 'ZMAX must be .le. NZ, XMAX AND YMAX .LE. NX') END IF END C C C C ======================== SUBROUTINE FFT17(X,SIZE) C ======================== C C calculates a fourier synthesis for space group p2221 given the C unique set of structure factors. the volume calculated is half C x, half y, and all z. C C this version of the program produces y-sections in C which z varies most rapidly and x varies most slowly. C C the scratch file is in direct access. C written for P222 by G. Bricogne, april 77. C Modified for P2221 by J.Nyborg, Sept. 86. C C Because the twofold along Y in P2221 is at Z=1/4, the input C will be modified corresponding to a shift in Z by 1/4. C The origin must be shifted back. This is done before the C CALL of the final printing routine. C C The shift in origin produces new symmetry of the interme- C diate k Transform, so that the equivalent positions of C P2221 after an origin shift by 1/4 on Z are: C X,Y,Z; -X,Y,-Z; -X,-Y,1/2+Z; X,-Y,1/2-Z; C This will give the transposition formula: C Tk(-h,Y,l) = (-1)**(l) * Tk(h,-Y,l) ; 0<=Y<=1/2 C C .. Scalar Arguments .. INTEGER SIZE C .. C .. Array Arguments .. REAL X(SIZE) C .. C .. Scalars in Common .. INTEGER HMAX,HMIN,KMAX,KMIN,LMAX,LMIN,NABCH,NSECAX,NSYMCH,NX,NY, + NZ,IFIL,IFILO,T2,T3,T4,XMAX,XMIN,YMAX,YMIN,ZMAX,ZMIN CHARACTER TITLE*80 C .. C .. Arrays in Common .. INTEGER JMPHDR C .. C .. Local Scalars .. REAL RHMAX,RHMEAN,RHMIN,RHRMS,T,TIME INTEGER C1,C2,C3,I,I1,I2,I3,IREC,IRMAX,LMODE,LSPGRP,M,MINSIZ,MP1, + MP2,NH,NH1,NP1,NRECDS,NSEC,NU1,NU2,NV1,NV2,NW1,NWORDS,NY2, + P1,P2,R,RECS,SKIP,MODEDUM C .. C .. Local Arrays .. REAL CELL(6),SECOND(3) INTEGER D(5),IUVW(3),MXYZ(3) C .. C .. External Functions .. INTEGER JTIME,LENSTR EXTERNAL JTIME,LENSTR C .. C .. External Subroutines .. EXTERNAL CCPERR,FILEO,HERMFT,MODPHS,MRDHDR,PRNTYZ,QOPEN, + REALFT,SFIPYC,SHFMAP,TRNSP4,YIN3,YOUT1 C .. C .. Intrinsic Functions .. INTRINSIC MAX,REAL C .. C .. Common blocks .. COMMON /HKLLIM/HMAX,KMAX,LMAX,HMIN,KMIN,LMIN COMMON /IOFFT/IFIL,IFILO,T2,T3,T4,NSYMCH,NABCH,NSECAX COMMON /MPHDR/NX,NY,NZ,XMIN,XMAX,YMIN,YMAX,ZMIN,ZMAX,JMPHDR(19) COMMON /MPHDRR/TITLE C .. C .. Save statement .. SAVE C .. C1 = 0 C2 = 0 C3 = 0 I1 = 0 I2 = 0 I3 = 0 C WRITE (6,FMT=6000) 6000 FORMAT (/30X,'Fourier synthesis for space-group P2221',//) HMAX = (HMAX/2)*2 + 1 C IF (NX.GE.2*HMAX+1) THEN C C---- Set index limits C HMIN = 0 KMIN = 0 LMIN = 0 C C---- Check sampling etc C IF (NX.EQ.NX/2*2) THEN IF (NY.EQ.NY/2*2) THEN IF (NZ.NE.NZ/2*2) THEN ELSE IF (XMAX.LE.NX/2) THEN C C---- Set array size from memory size: SIZE is maximum size, C MINSIZ is minimum = 1 section. C Routine returns new value of SIZE C MP1 = (2*NY* (LMAX+1))/2 MP2 = (NX/2+1)*NZ MINSIZ = MAX(MP1,MP2) C C ********************* c CALL CCPASZ(X,SIZE,MINSIZ) C ********************* C P1 = (SIZE/ (2*NY* (LMAX+1)))*2 IF (P1.GT.HMAX-HMIN+1) P1 = HMAX - HMIN + 1 NP1 = P1 P2 = SIZE/ ((NX/2+1)*NZ) C IF (P1.LE.0 .OR. P2.LE.0) THEN WRITE (6,FMT=6002) SIZE,NX,NY,NZ,KMAX 6002 FORMAT (' Request TOO Large. Buffer = ',I10,/4I25) C C *********************** CALL CCPERR(1, 'Internal error in FFT17') C *********************** C ELSE C C---- calculate the dimensions of the direct-access scratch file t2. C NH = HMAX + 1 C NH1 = (NH-1)/P1 + 1 NY2 = (YMAX-YMIN)/P2 + 1 C NRECDS = 2*NH1*NY2 NWORDS = P1*P2* (LMAX+1) C C ********************************** CALL FILEO(T2,SIZE,P1,P2,NWORDS,NRECDS) CALL QOPEN(T2,'DISKIO1','SCRATCH') CALL QMODE(T2,2,MODEDUM) C ********************************** C C---- pass one. C transform on l and write intermediate results C on scratch disk file C IREC = 0 R = 0 TIME = JTIME(2) 10 CONTINUE IF (R+P1.GT.HMAX) P1 = HMAX + 1 - R C C **************************** CALL SFIPYC(X,NY/2,LMAX+1,P1,R,M) C **************************** C C---- Shift the origin along Z by 1/4 C C ********************** CALL MODPHS(X,NY,LMAX+1,P1) C ********************** C T = JTIME(2) I1 = I1 + T - TIME TIME = T D(1) = NY*P1* (LMAX+1) D(2) = 2 D(3) = D(1) D(4) = D(1) D(5) = NY C C ************************ CALL HERMFT(X(1),X(2),NY/2,D) C ************************ C T = JTIME(2) C1 = C1 + T - TIME TIME = T C C ************************************* CALL YOUT1(X,NY,LMAX+1,P1,P2,YMIN,YMAX,T2,IREC,NWORDS) CALL TRNSP4(X,NY,LMAX+1,P1) CALL YOUT1(X,NY,LMAX+1,P1,P2,YMIN,YMAX,T2,IREC,NWORDS) C ************************************* C T = JTIME(2) I2 = I2 + T - TIME TIME = T R = R + P1 IF (R.LE.HMAX .AND. M.GT.0) 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 T = JTIME(2) I2 = I2 + T - TIME TIME = T IRMAX = IREC SKIP = 0 RECS = (YMAX-YMIN)/P2 R = YMIN 20 CONTINUE P1 = NP1 IREC = 1 IF (R+P2.GT.YMAX) P2 = YMAX - R + 1 C C ************************************** CALL YIN3(X,NZ,NX/2+1,P2,HMAX,LMAX,P1,SKIP,RECS,T2,IREC, + IRMAX,NWORDS) C ************************************** C SKIP = SKIP + 1 T = JTIME(2) I2 = I2 + T - TIME TIME = T C C---- X now contains intermediate results stored with l down the C columns and h across the rows. C D(1) = (NX+2)*NZ*P2/2 D(2) = NZ D(3) = (NX+2)*NZ/2 D(4) = (LMAX+1)*2 D(5) = 2 C C ************************ CALL REALFT(X(1),X(2),NX/2,D) C ************************ C T = JTIME(2) C2 = C2 + T - TIME TIME = T D(2) = 2 D(3) = (NX+2)*NZ/2 D(4) = (XMAX-XMIN+1)*NZ D(5) = NZ I = XMIN*NZ + 1 C C ************************** CALL HERMFT(X(I),X(I+1),NZ/2,D) C ************************** C T = JTIME(2) C3 = C3 + T - TIME TIME = T C C---- shift map by 1/4 in Z C C ****************************** CALL SHFMAP(X,NZ,NX/2+1,P2) CALL PRNTYZ(X,NZ,NX/2+1,P2,R,T3,T4) C ****************************** C T = JTIME(2) I3 = I3 + T - TIME TIME = T R = R + P2 IF (R.LE.YMAX) GO TO 20 C C ******************************** IF (T3.GT.0) CALL MRDHDR(T3,'MAPOUT',TITLE,NSEC,IUVW, + MXYZ,NW1,NU1,NU2,NV1,NV2,CELL, + LSPGRP,LMODE,RHMIN,RHMAX, + RHMEAN,RHRMS) C ******************************** C C---- End of job C WRITE (6,FMT=6004) TITLE(1:LENSTR(TITLE)) 6004 FORMAT (' ',A) SECOND(1) = REAL(C1)/1000.0 SECOND(2) = REAL(C2)/1000.0 SECOND(3) = REAL(C3)/1000.0 WRITE (6,FMT=6006) SECOND 6006 FORMAT (' Transform Time = ',F7.3,' Seconds.') SECOND(1) = REAL(I1)/1000.0 SECOND(2) = REAL(I2)/1000.0 SECOND(3) = REAL(I3)/1000.0 WRITE (6,FMT=6008) SECOND 6008 FORMAT (' Input/Output Time = ',F7.3,' Seconds.') C END IF RETURN ELSE CALL CCPERR(1, 'Illegal limits: must be XMAX .le. NX/2') END IF END IF END IF CALL CCPERR(1, 'Illegal sampling: must be NX=2n, NY=2n, NZ=2n') ELSE WRITE (6,FMT=6014) NX,HMAX 6014 FORMAT (/' ! NX =,',I5,' MUST BE .GE. 2*HMAX+1, HMAX =',I5,/) C C ************************ CALL CCPERR(1, 'Bad grid') C ************************ C END IF END C C C C ======================== SUBROUTINE FFT18(X,SIZE) C ======================== C C Fourier synthesis for space-group P21212 C Origin on 21 21 (sg number 1018) C C This corresponds to symmetry operations C X,Y,Z C 1/2-X,1/2-Y,Z C 1/2+X,-Y,-Z C -X,1/2+Y,-Z C C .. Scalar Arguments .. INTEGER SIZE C .. C .. Array Arguments .. REAL X(SIZE) C .. C .. Scalars in Common .. INTEGER HMAX,HMIN,IXMAX,IXMIN,IYMAX,IYMIN,IZMAX,IZMIN,KMAX,KMIN, + LMAX,LMIN,NABCH,NSECAX,NSYMCH,NX,NY,NZ,IFIL,IFILO,T2,T3,T4 CHARACTER TITLE*80 C .. C .. Arrays in Common .. INTEGER JMPHDR C .. C .. Local Scalars .. REAL RHMAX,RHMEAN,RHMIN,RHRMS INTEGER I,IREC,IRMAX,KM1,LM1,LMODE,LSPGRP,M,MINSIZ,MP1,MP2,NP1, + NRECS,NSEC,NU1,NU2,NV1,NV2,NW1,NWORDS,P1,P2,R,RECS,SKIP, $ MODEDUM C .. C .. Local Arrays .. REAL CELL(6) INTEGER D(5),IUVW(3),MXYZ(3) C .. C .. External Subroutines .. EXTERNAL CCPERR,CMPLFT,FILEO,HERMFT,MRDHDR,PRNTYZ,QOPEN, + SDIAD,SFIPYC,TRNSP3,YIN5,YOUT5 C .. C .. Intrinsic Functions .. INTRINSIC MAX C .. C .. Common blocks .. COMMON /HKLLIM/HMAX,KMAX,LMAX,HMIN,KMIN,LMIN COMMON /IOFFT/IFIL,IFILO,T2,T3,T4,NSYMCH,NABCH,NSECAX COMMON /MPHDR/NX,NY,NZ,IXMIN,IXMAX,IYMIN,IYMAX,IZMIN,IZMAX, + JMPHDR(19) COMMON /MPHDRR/TITLE C .. C .. Save statement .. SAVE C .. WRITE (6,FMT=6000) 6000 FORMAT (/30X,'Fourier synthesis for space-group P21212',//) C C---- Set index limits C HMIN = 0 KMIN = 0 LMIN = 0 C C---- Check sampling C IF (NZ.EQ.NZ/2*2) THEN IF (NY.NE.NY/4*4) THEN ELSE IF (IYMAX.LE.NY/2) THEN C C---- Set array size from memory size: SIZE is maximum size, C MINSIZ is minimum = 1 section. C Routine returns new value of SIZE C MP1 = ((NY+2)* (LMAX+1)) MP2 = NX*NZ MINSIZ = MAX(MP1,MP2) C C ********************* c CALL CCPASZ(X,SIZE,MINSIZ) C ********************* C P1 = SIZE/ ((NY+2)* (LMAX+1)) IF (P1.GT.HMAX-HMIN+1) P1 = HMAX - HMIN + 1 NP1 = P1 P2 = SIZE/ (NZ*NX) C IF (P1.GT.0 .AND. P2.GT.0) THEN LM1 = LMAX + 1 KM1 = KMAX + 1 C NWORDS = 2*P1*P2*LM1 NRECS = (HMAX/P1+1)*2* ((IYMAX-IYMIN)/P2+1) C C ********************************* CALL FILEO(T2,SIZE,P1,P2,NWORDS,NRECS) CALL QOPEN(T2,'DISKIO1','SCRATCH') CALL QMODE(T2,2,MODEDUM) C ********************************* C IREC = 0 R = HMIN 10 CONTINUE IF (R+P1.GT.HMAX) P1 = HMAX + 1 - R C C---- read in data C C *************************** CALL SFIPYC(X,NY/2+1,LM1,P1,R,M) C *************************** C C---- pass one. transform on k and write intermediate results on t2. C IF (R+P1.GT.HMAX) P1 = HMAX + 1 - R D(1) = (NY+2)* (LMAX+1)*P1 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 YOUT5(X,NY/2+1,LMAX+1,P1,P2,IYMIN,IYMAX,T2,IREC,NWORDS) CALL TRNSP3(X,NY/2+1,LM1,P1,R) CALL YOUT5(X,NY/2+1,LMAX+1,P1,P2,IYMIN,IYMAX,T2,IREC,NWORDS) C ************************************************ C R = R + P1 IF (R.LE.HMAX .AND. M.GT.0) 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 P1 = NP1 SKIP = 0 IRMAX = IREC RECS = (IYMAX-IYMIN)/P2 R = IYMIN 20 CONTINUE IREC = 1 IF (R+P2.GT.IYMAX) P2 = IYMAX - R + 1 C C ************************************************* CALL YIN5(X,NZ/2,NX,P2,HMAX,LMAX,P1,SKIP,RECS,T2,IREC,IRMAX, + NWORDS) C ************************************************* C SKIP = SKIP + 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*P2 D(2) = NZ D(3) = NX*NZ D(4) = (LMAX+1)*2 D(5) = 2 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 C---- map calculated for p2 sections C C ************************** CALL PRNTYZ(X,NZ,NX,P2,R,T3,T4) C ************************** C R = R + P2 IF (R.LE.IYMAX) GO TO 20 C C *************************************** IF (T3.GT.0) CALL MRDHDR(T3,'MAPOUT',TITLE,NSEC,IUVW,MXYZ, + NW1,NU1,NU2,NV1,NV2,CELL,LSPGRP, + LMODE,RHMIN,RHMAX,RHMEAN,RHRMS) C *************************************** C CLOSE (UNIT=T2) ELSE WRITE (6,FMT=6002) SIZE 6002 FORMAT (' Array SIZE ',I8,' TOO Small',//) C C *********************** CALL CCPERR(1,'Internal error in FFT18') C *********************** C END IF RETURN ELSE CALL CCPERR(1, 'Illegal limits: YMAX must be .le. NY/2') END IF END IF CALL CCPERR(1, 'Illegal sampling : must be NY=4n, NZ=2n') END C C C C ======================== SUBROUTINE FFT19(X,SIZE) C ======================== C C fourier synthesis for space group P212121 C C .. Scalar Arguments .. INTEGER SIZE C .. C .. Array Arguments .. REAL X(SIZE) C .. C .. Scalars in Common .. INTEGER HMAX,HMIN,IXMAX,IXMIN,IYMAX,IYMIN,IZMAX,IZMIN,KMAX,KMIN, + LMAX,LMIN,NABCH,NSECAX,NSYMCH,NX,NY,NZ,IFIL,IFILO,T2,T3,T4 CHARACTER TITLE*80 C .. C .. Arrays in Common .. INTEGER JMPHDR C .. C .. Local Scalars .. REAL RHMAX,RHMEAN,RHMIN,RHRMS INTEGER IREC,IRMAX,KM1,LMODE,LSPGRP,M,MINSIZ,MP1,MP2,NP1,NRECS, + NSEC,NU1,NU2,NV1,NV2,NW1,NWORDS,NZ21,NZP2,P1,P2,R,RECS, + SKIP,MODEDUM C .. C .. Local Arrays .. REAL CELL(6) INTEGER D(5),IUVW(3),MXYZ(3) C .. C .. External Subroutines .. EXTERNAL CCPERR,CMPLFT,DIVI,FILEO,HERMFT,MRDHDR,MULTI, + PRNTYZ,QOPEN,SDIAD,SFIPZC,TRNSP2,ZIN4,ZOUT2 C .. C .. Intrinsic Functions .. INTRINSIC MAX C .. C .. Common blocks .. COMMON /HKLLIM/HMAX,KMAX,LMAX,HMIN,KMIN,LMIN COMMON /IOFFT/IFIL,IFILO,T2,T3,T4,NSYMCH,NABCH,NSECAX COMMON /MPHDR/NX,NY,NZ,IXMIN,IXMAX,IYMIN,IYMAX,IZMIN,IZMAX, + JMPHDR(19) COMMON /MPHDRR/TITLE C .. C .. Save statement .. SAVE C .. WRITE (6,FMT=6000) 6000 FORMAT (/30X,'Fourier synthesis for space-group P212121',//) C C---- Set index limits C HMIN = 0 KMIN = 0 LMIN = 0 C C---- Check sampling C IF (NZ.EQ.NZ/4*4) THEN IF (NY.NE.NY/2*2) THEN ELSE IF (IZMAX.LE.NZ/2) THEN NZ21 = NZ/2 + 1 NZP2 = NZ + 2 KM1 = KMAX + 1 C C---- Set array size from memory size: SIZE is maximum size, C MINSIZ is minimum = 1 section. C Routine returns new value of SIZE C MP1 = (NZP2*KM1) MP2 = NX*NY MINSIZ = MAX(MP1,MP2) C C ********************* c CALL CCPASZ(X,SIZE,MINSIZ) C ********************* C P1 = SIZE/ (NZP2*KM1) IF (P1.GT.HMAX-HMIN+1) P1 = HMAX - HMIN + 1 NP1 = P1 P2 = SIZE/ (NX*NY) C IF (P1.LE.0 .OR. P2.LE.0) THEN WRITE (6,FMT=6002) SIZE 6002 FORMAT (//' Buffer size too small, ',I8,/) C C ************************ CALL CCPERR(1, 'Internal error in FFT19') C ************************ C ELSE C C---- Calculate record levngth and number of records in scratch file C NWORDS = 2*P1*P2*KM1 NRECS = ((IZMAX-IZMIN)/P2+1)* (HMAX/P1+1)*2 C C ********************************* CALL FILEO(T2,SIZE,P1,P2,NWORDS,NRECS) CALL QOPEN(T2,'DISKIO1','SCRATCH') CALL QMODE(T2,2,MODEDUM) C ********************************* C C---- transform on l and write results on t2 C IREC = 0 R = HMIN 10 CONTINUE IF (R+P1.GT.HMAX) P1 = HMAX + 1 - R C C *************************** CALL SFIPZC(X,NZ21,KM1,P1,R,M) CALL MULTI(X,NZP2,KM1,P1,LMAX,R) C *************************** C D(1) = NZP2*KM1*P1 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,P1,R) CALL ZOUT2(X,NZ21,KM1,P1,P2,IZMIN,IZMAX,T2,IREC,NWORDS) CALL TRNSP2(X,NZ21,KM1,P1) CALL ZOUT2(X,NZ21,KM1,P1,P2,IZMIN,IZMAX,T2,IREC,NWORDS) C ******************************************* C R = R + P1 IF (R.LE.HMAX .AND. M.GE.0) GO TO 10 IRMAX = IREC C---- calculate transforms on h and k, and write output C P1 = NP1 RECS = (IZMAX-IZMIN)/P2 SKIP = 0 R = IZMIN 20 CONTINUE IREC = 1 IF (R+P2.GT.IZMAX) P2 = IZMAX - R + 1 C C ************************************************* CALL ZIN4(X,NY/2,NX,P2,HMAX,KMAX,P1,SKIP,RECS,T2,IREC,IRMAX, + NWORDS) C ************************************************* C SKIP = SKIP + 1 D(1) = NY*NX*P2 D(2) = NY D(3) = NY*NX D(4) = 2*KMAX + 2 D(5) = 2 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 ************************** CALL HERMFT(X(1),X(2),NY/2,D) CALL PRNTYZ(X,NY,NX,P2,R,T3,T4) C ************************** C R = R + P2 IF (R.LE.IZMAX) GO TO 20 C C *************************************** IF (T3.GT.0) CALL MRDHDR(T3,'MAPOUT',TITLE,NSEC,IUVW,MXYZ, + NW1,NU1,NU2,NV1,NV2,CELL,LSPGRP, + LMODE,RHMIN,RHMAX,RHMEAN,RHRMS) C *************************************** C C---- End of job C END IF RETURN ELSE CALL CCPERR(1, '[permuted] ZMAX must be .le. NZ/2') END IF END IF CALL CCPERR(1, 'Illegal sampling intervals: must be [permuted] ' $ // 'NZ=4n, NY=2n') END C C C C ======================= SUBROUTINE FFT2(X,SIZE) C ======================= C C P1 BAR fourier synthesis and triclinic patterson function C C this version of the program produces y-sections in C which z varies most rapidly and x varies most slowly. C C the scratch file is in direct access. C G Bricogne, april 77. C C .. Scalar Arguments .. INTEGER SIZE C .. C .. Array Arguments .. REAL X(SIZE) C .. C .. Scalars in Common .. INTEGER HMAX,HMIN,KMAX,KMIN,LMAX,LMIN,NABCH,NSECAX,NSYMCH,NX,NY, + NZ,IFIL,IFILO,T2,T3,T4,XMAX,XMIN,YMAX,YMIN,ZMAX,ZMIN CHARACTER TITLE*80 C .. C .. Arrays in Common .. INTEGER JMPHDR C .. C .. Local Scalars .. REAL RHMAX,RHMEAN,RHMIN,RHRMS INTEGER C1,C2,C3,I,I1,I2,I3,IREC,IRMAX,LMODE,LSPGRP,M,MINSIZ,MP1, + MP2,NH,NH1,NP1,NRECDS,NSEC,NU1,NU2,NV1,NV2,NW1,NWORDS,NY2, + P1,P2,R,RECS,SKIP,T,TIME,MODEDUM C .. C .. Local Arrays .. REAL CELL(6),SECOND(3) INTEGER D(5),IUVW(3),MXYZ(3) C .. C .. External Functions .. INTEGER JTIME,LENSTR EXTERNAL JTIME,LENSTR C .. C .. External Subroutines .. EXTERNAL CCPERR,CMPLFT,FILEO,HERMFT,MRDHDR,PRNTYZ,QOPEN, + REALFT,SFIPYR,YIN2,YOUT2 C .. C .. Intrinsic Functions .. INTRINSIC MAX,REAL C .. C .. Common blocks .. COMMON /HKLLIM/HMAX,KMAX,LMAX,HMIN,KMIN,LMIN COMMON /IOFFT/IFIL,IFILO,T2,T3,T4,NSYMCH,NABCH,NSECAX COMMON /MPHDR/NX,NY,NZ,XMIN,XMAX,YMIN,YMAX,ZMIN,ZMAX,JMPHDR(19) COMMON /MPHDRR/TITLE C .. C .. Save statement .. SAVE C .. C1 = 0 C2 = 0 C3 = 0 I1 = 0 I2 = 0 I3 = 0 C WRITE (6,FMT=6000) 6000 FORMAT (/30X,'Fourier synthesis for space-group P-1',//) C HMIN = -HMAX KMIN = -KMAX LMIN = 0 C C---- Check sampling C IF (NY.EQ.NY/2*2) THEN C IF (NZ.NE.NZ/2*2) THEN ELSE IF (YMAX.LE.NY/2) THEN C C---- Set array size from memory size: SIZE is maximum size, C MINSIZ is minimum = 1 section. Routine returns new value of SIZE C MP1 = ((NY+2)* (LMAX+1)) MP2 = NX*NZ MINSIZ = MAX(MP1,MP2) C C ********************* c CALL CCPASZ(X,SIZE,MINSIZ) C ********************* C P1 = SIZE/ ((NY+2)* (LMAX+1)) IF (P1.GT.HMAX-HMIN+1) P1 = HMAX - HMIN + 1 NP1 = P1 P2 = SIZE/ (NX*NZ) C IF (P1.LE.0 .OR. P2.LE.0) THEN WRITE (6,FMT=6002) SIZE,NX,NY,NZ,KMAX 6002 FORMAT (' Request too large. Buffer = ',I10,/4I25) C C ************************ CALL CCPERR(1, 'Internal error in FFT2') C ************************ C ELSE C C---- calculate the dimensions of the direct-access scratch file t2. C NH = 2*HMAX + 1 C NH1 = (NH-1)/P1 + 1 NY2 = (YMAX-YMIN)/P2 + 1 C NRECDS = NH1*NY2 NWORDS = 2*P1*P2* (LMAX+1) C C---- Open scratch file C C ********************************** CALL FILEO(T2,SIZE,P1,P2,NWORDS,NRECDS) CALL QOPEN(T2,'DISKIO1','SCRATCH') CALL QMODE(T2,2,MODEDUM) C ********************************** C C---- pass one. transform on k and write intermediate results on t2. C IREC = 0 R = HMIN TIME = JTIME(2) 10 CONTINUE IF (R+P1.GT.HMAX) P1 = HMAX + 1 - R C C **************************** CALL SFIPYR(X,NY+2,LMAX+1,P1,R,M) C **************************** C T = JTIME(2) I1 = I1 + T - TIME TIME = T D(1) = (NY+2)* (LMAX+1)*P1 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 T = JTIME(2) C1 = C1 + T - TIME TIME = T C C ********************************************** CALL YOUT2(X,NY/2+1,LMAX+1,P1,P2,YMIN,YMAX,T2,IREC,NWORDS) C ********************************************** C T = JTIME(2) I2 = I2 + T - TIME TIME = T R = R + P1 IF (R.LE.HMAX .AND. M.GE.0) 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 T = JTIME(2) I2 = I2 + T - TIME TIME = T C SKIP = 0 IRMAX = IREC R = YMIN P1 = NP1 RECS = (YMAX-YMIN)/P2 20 CONTINUE IREC = 1 IF (R+P2.GT.YMAX) P2 = YMAX - R + 1 C C ************************************************* CALL YIN2(X,NZ/2,NX,P2,HMAX,LMAX,P1,SKIP,RECS,T2,IREC,IRMAX, + NWORDS) C ************************************************* C SKIP = SKIP + 1 T = JTIME(2) I2 = I2 + T - TIME TIME = T C C---- X now contains intermediate results stored with l down the C columns and h across the rows. C D(1) = NX*NZ*P2 D(2) = NZ D(3) = NZ*NX D(4) = (LMAX+1)*2 D(5) = 2 C C ********************** CALL CMPLFT(X(1),X(2),NX,D) C ********************** C T = JTIME(2) C2 = C2 + T - TIME TIME = T D(2) = 2 D(4) = (XMAX-XMIN+1)*NZ D(5) = NZ I = XMIN*NZ + 1 C C ************************** CALL HERMFT(X(I),X(I+1),NZ/2,D) C ************************** C T = JTIME(2) C3 = C3 + T - TIME TIME = T C C ************************** CALL PRNTYZ(X,NZ,NX,P2,R,T3,T4) C ************************** C T = JTIME(2) I3 = I3 + T - TIME TIME = T R = R + P2 IF (R.LE.YMAX) GO TO 20 C C *************************************** IF (T3.GT.0) CALL MRDHDR(T3,'MAPOUT',TITLE,NSEC,IUVW,MXYZ, + NW1,NU1,NU2,NV1,NV2,CELL,LSPGRP, + LMODE,RHMIN,RHMAX,RHMEAN,RHRMS) C **************************************** C C---- end of job C WRITE (6,FMT=6004) TITLE(1:LENSTR(TITLE)) 6004 FORMAT (' ',A) SECOND(1) = REAL(C1)/1000.0 SECOND(2) = REAL(C2)/1000.0 SECOND(3) = REAL(C3)/1000.0 WRITE (6,FMT=6006) SECOND 6006 FORMAT (' Transform Time = ',F7.3,' Seconds.') SECOND(1) = REAL(I1)/1000.0 SECOND(2) = REAL(I2)/1000.0 SECOND(3) = REAL(I3)/1000.0 WRITE (6,FMT=6008) SECOND 6008 FORMAT (' Input/Output Time = ',F7.3,' Seconds.') C END IF RETURN ELSE CALL CCPERR(1, $ 'Illegal limits : must be [permuted] YMAX .le. NY/2 ') END IF END IF CALL CCPERR(1, 'Illegal sampling intervals: must ' // $ 'be [permuted] NY=2n, NZ=2n') END C C C C ======================== SUBROUTINE FFT20(X,SIZE) C ======================== C C calculates a fourier synthesis for space group c2221 given the C unique set of structure factors. the face-centering is used to C speed up the first transform . C the volume calculated is: 0 to nx/2 , 0 to ny/4 , 0 to nz-1 . C C this version of the program produces y-sections in C which z varies most rapidly and x varies most slowly. C this is considerably faster if whole sections are to be C written out. C C the scratch file is in direct access. C C written for i222 by g. bricogne, may 1977 C Modified for C2221 by J.Nyborg, Sept. 1986. C C This program is similar to the one for I222. The differen- C ces are listed below. C C The difference between the systematic absences for I-cente- C ring (h+k+l=2n+1) and C-centering (h+k=2n+1) makes the se- C paration routine simple. It will depend only on the parity C of h. C C Because the twofold along Y in C2221 is at Z=1/4, the input C will be modified corresponding to a shift in Z by 1/4. C The origin must be shifted back. This is done before the C CALL of the final printing routine. C C The shift in origin produces new symmetry of the interme- C diate k Transform, so that the equivalent positions of C C2221 after an origin shift by 1/4 on Z are: C X,Y,Z; -X,Y,-Z; -X,-Y,1/2+Z; X,-Y,1/2-Z; C +(1/2,1/2,0) C This will give the transposition formula: C Tk(-h,Y,l) = (-1)**(h+l)*Tk(h,1/2-Y,l) 0<=Y<=1/4 C which is the same as for I222. C C .. Scalar Arguments .. INTEGER SIZE C .. C .. Array Arguments .. REAL X(SIZE) C .. C .. Scalars in Common .. INTEGER HMAX,HMIN,KMAX,KMIN,LMAX,LMIN,NABCH,NSECAX,NSYMCH,NX,NY, + NZ,IFIL,IFILO,T2,T3,T4,XMAX,XMIN,YMAX,YMIN,ZMAX,ZMIN CHARACTER TITLE*80 C .. C .. Arrays in Common .. INTEGER JMPHDR C .. C .. Local Scalars .. REAL RHMAX,RHMEAN,RHMIN,RHRMS INTEGER C1,C2,C3,I,I1,I2,I3,IREC,IRMAX,LMODE,LSPGRP,M,MINSIZ,MP1, + MP2,NH,NH1,NP1,NRECDS,NSEC,NU1,NU2,NV1,NV2,NW1,NWORDS,NY2, + P1,P2,R,RECS,SKIP,T,TIME,MODEDUM C .. C .. Local Arrays .. REAL CELL(6) INTEGER D(5),IUVW(3),MXYZ(3) C .. C .. External Functions .. INTEGER JTIME EXTERNAL JTIME C .. C .. External Subroutines .. EXTERNAL CCPERR,FILEO,HERMFT,HSEP1C,MODPHS,MRDHDR,PRNTYZ, + QOPEN,REALFT,SFIIYC,SHFMAP,TRNP1I,YIN3,YOUT1I C .. C .. Intrinsic Functions .. INTRINSIC MAX C .. C .. Common blocks .. COMMON /HKLLIM/HMAX,KMAX,LMAX,HMIN,KMIN,LMIN COMMON /IOFFT/IFIL,IFILO,T2,T3,T4,NSYMCH,NABCH,NSECAX COMMON /MPHDR/NX,NY,NZ,XMIN,XMAX,YMIN,YMAX,ZMIN,ZMAX,JMPHDR(19) COMMON /MPHDRR/TITLE C .. C .. Save statement .. SAVE C .. C1 = 0 C2 = 0 C3 = 0 I1 = 0 I2 = 0 I3 = 0 C WRITE (6,FMT=6000) 6000 FORMAT (/30X,'Fourier synthesis for space-group C2221',//) C C---- Set minimum indices C HMIN = 0 KMIN = 0 LMIN = 0 HMAX = (HMAX/2)*2 + 1 C IF (NX.GE.2*HMAX+1) THEN C C---- Check for valid sampling C IF (NX.EQ.NX/4*4) THEN IF (NY.EQ.NY/4*4) THEN IF (NZ.EQ.NZ/4*4) THEN C C---- Check for map limits C IF (XMAX.LE.NX/2) THEN IF (YMAX.LE.NY/4) THEN C C---- Set array size from memory size: SIZE is maximum size, C MINSIZ is minimum = 1 section. C Routine returns new value of SIZE C MP1 = ((NY+2)* (LMAX+1))/2 MP2 = (NX/2+1)*NZ MINSIZ = MAX(MP1,MP2) C C ********************* c CALL CCPASZ(X,SIZE,MINSIZ) C ********************* C P1 = (SIZE/ ((NY+2)* (LMAX+1)))*2 IF (P1.GT.HMAX-HMIN+1) P1 = HMAX - HMIN + 1 NP1 = P1 P2 = SIZE/ ((NX/2+1)*NZ) C IF (P1.LE.0 .OR. P2.LE.0) THEN WRITE (6,FMT=6002) SIZE,NX,NY,NZ,KMAX 6002 FORMAT (' Request too large. Buffer = ',I10,/4I25) C C ************************ CALL CCPERR(1, 'Internal error in FFT20') C ************************ C ELSE C C---- calculate the dimensions of the direct-access scratch file t2. C NH = HMAX + 1 C NH1 = (NH-1)/P1 + 1 NY2 = (YMAX-YMIN)/P2 + 1 C NRECDS = 2*NH1*NY2 NWORDS = P1*P2* (LMAX+1) C C *************************** CALL FILEO(T2,SIZE,P1,P2,NWORDS,NRECDS) CALL QOPEN(T2,'DISKIO1','SCRATCH') CALL QMODE(T2,2,MODEDUM) C *************************** C C pass one : transform on k and write intermediate results on t2. C in this transform, the face-centering is used as follows : the C input routine 'sfiiyc' overlays pairs of h-planes of structure C factors for consecutive even/odd values of h ; these overlaid data C are subjected to the k-transform, then the intermediate results C are recovered according to their parity in routine 'hsep1c' . C IREC = 0 R = 0 TIME = JTIME(2) 10 CONTINUE IF (R+P1.GT.HMAX) P1 = HMAX + 1 - R C C ******************************** CALL SFIIYC(X, (NY/2)+1,LMAX+1,P1/2,R,M) C ******************************** C C---- Shift the origin along Z by 1/4 C C ************************** CALL MODPHS(X,NY+2,LMAX+1,P1/2) C ************************** C T = JTIME(2) I1 = I1 + T - TIME TIME = T D(1) = (NY+2)* (P1/2)* (LMAX+1) D(2) = 2 D(3) = D(1) D(4) = D(1) D(5) = NY + 2 C C ************************ CALL HERMFT(X(1),X(2),NY/2,D) C ************************ C T = JTIME(2) C1 = C1 + T - TIME TIME = T C C ******************************** CALL HSEP1C(X,NY+2,LMAX+1,P1/2) CALL YOUT1I(X,NY+2,LMAX+1,P1/2,P2,YMIN,YMAX,T2,IREC, + NWORDS) CALL TRNP1I(X,NY+2,LMAX+1,P1/2) CALL YOUT1I(X,NY+2,LMAX+1,P1/2,P2,YMIN,YMAX,T2,IREC, + NWORDS) C ******************************** C T = JTIME(2) I2 = I2 + T - TIME TIME = T R = R + P1 IF (R.LE.HMAX .AND. M.GT.0) 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 T = JTIME(2) I2 = I2 + T - TIME TIME = T IRMAX = IREC P1 = NP1 SKIP = 0 RECS = (YMAX-YMIN)/P2 R = YMIN 20 CONTINUE IREC = 1 IF (R+P2.GT.YMAX) P2 = YMAX - R + 1 C C ******************************** CALL YIN3(X,NZ,NX/2+1,P2,HMAX,LMAX,P1,SKIP,RECS,T2, + IREC,IRMAX,NWORDS) C ******************************** C SKIP = SKIP + 1 T = JTIME(2) I2 = I2 + T - TIME TIME = T C C---- X now contains intermediate results stored with l down the C columns and h across the rows. C D(1) = (NX+2)*NZ*P2/2 D(2) = NZ D(3) = (NX+2)*NZ/2 D(4) = (LMAX+1)*2 D(5) = 2 C C ************************ CALL REALFT(X(1),X(2),NX/2,D) C ************************ C T = JTIME(2) C2 = C2 + T - TIME TIME = T D(2) = 2 D(3) = (NX+2)*NZ/2 D(4) = (XMAX-XMIN+1)*NZ D(5) = NZ I = XMIN*NZ + 1 C C ************************** CALL HERMFT(X(I),X(I+1),NZ/2,D) C ************************** C T = JTIME(2) C3 = C3 + T - TIME TIME = T C C---- shift map by 1/4 in Z C C ****************************** CALL SHFMAP(X,NZ,NX/2+1,P2) CALL PRNTYZ(X,NZ,NX/2+1,P2,R,T3,T4) C ****************************** C T = JTIME(2) I3 = I3 + T - TIME TIME = T R = R + P2 IF (R.LE.YMAX) GO TO 20 C C ************************ IF (T3.GT.0) CALL MRDHDR(T3,'MAPOUT',TITLE,NSEC, + IUVW,MXYZ,NW1,NU1,NU2,NV1, + NV2,CELL,LSPGRP,LMODE, + RHMIN,RHMAX,RHMEAN,RHRMS) C ************************ C C---- End of job C END IF RETURN ELSE END IF END IF CALL CCPERR(1, 'XMAX, YMAX must be .le. NX/2, NY/4') ELSE END IF END IF END IF CALL CCPERR(1, 'NX,NY,NZ must be multiples of 4') ELSE WRITE (6,FMT=6008) NX,HMAX 6008 FORMAT (/' !! NX =',I5,' must be .ge. 2*HMAX+1, HMAX =',I5,/) C C ************************ CALL CCPERR(1, 'Bad grid') C ************************ C END IF C END C C C C ======================== SUBROUTINE FFT21(X,SIZE) C ======================== C C calculates a fourier synthesis for space group c222 given the C unique set of structure factors. the face-centering is used to C speed up the first transform . C the volume calculated is: 0 to nx/2 , 0 to ny/4 , 0 to nz-1 . C C this version of the program produces y-sections in C which z varies most rapidly and x varies most slowly. C this is considerably faster if whole sections are to be C written out. C C the scratch file is in direct access. C C written for I222 by G. Bricogne, may 1977. C Modified for C222 by J.Nyborg, Sept. 1986. C C This program is similar to the one for I222. The differen- C ces are listed below. C C The difference between the systematic absences for I-cente- C ring (h+k+l=2n+1) and C-centering (h+k=2n+1) makes the se- C paration routine simple. It will depend only on the parity C of h. C C The transposition formula is: C Tk(-h,Y,l) = (-1)**(h) * Tk(h,1/2-Y,l) ; 0<=Y<=1/4 C That is, it depends only on the parity of h. C C .. Scalar Arguments .. INTEGER SIZE C .. C .. Array Arguments .. REAL X(SIZE) C .. C .. Scalars in Common .. INTEGER HMAX,HMIN,KMAX,KMIN,LMAX,LMIN,NABCH,NSECAX,NSYMCH,NX,NY, + NZ,IFIL,IFILO,T2,T3,T4,XMAX,XMIN,YMAX,YMIN,ZMAX,ZMIN CHARACTER TITLE*80 C .. C .. Arrays in Common .. INTEGER JMPHDR C .. C .. Local Scalars .. REAL RHMAX,RHMEAN,RHMIN,RHRMS INTEGER C1,C2,C3,I,I1,I2,I3,IREC,IRMAX,LMODE,LSPGRP,M,MINSIZ,MP1, + MP2,NH,NH1,NP1,NRECDS,NSEC,NU1,NU2,NV1,NV2,NW1,NWORDS,NY2, + P1,P2,R,RECS,SKIP,T,TIME,MODEDUM C .. C .. Local Arrays .. REAL CELL(6),SECOND(3) INTEGER D(5),IUVW(3),MXYZ(3) C .. C .. External Functions .. INTEGER JTIME,LENSTR EXTERNAL JTIME,LENSTR C .. C .. External Subroutines .. EXTERNAL CCPERR,FILEO,HERMFT,HSEP1C,MRDHDR,PRNTYZ,QOPEN, + REALFT,SFIIYC,TRNP1C,YIN3,YOUT1I C .. C .. Intrinsic Functions .. INTRINSIC MAX,REAL C .. C .. Common blocks .. COMMON /HKLLIM/HMAX,KMAX,LMAX,HMIN,KMIN,LMIN COMMON /IOFFT/IFIL,IFILO,T2,T3,T4,NSYMCH,NABCH,NSECAX COMMON /MPHDR/NX,NY,NZ,XMIN,XMAX,YMIN,YMAX,ZMIN,ZMAX,JMPHDR(19) COMMON /MPHDRR/TITLE C .. C .. Save statement .. SAVE C .. C1 = 0 C2 = 0 C3 = 0 I1 = 0 I2 = 0 I3 = 0 C WRITE (6,FMT=6000) 6000 FORMAT (/30X,'Fourier synthesis for space-group C222',//) C C---- Set minimum indices C HMIN = 0 KMIN = 0 LMIN = 0 C HMAX = (HMAX/2)*2 + 1 IF (NX.GE.2*HMAX+1) THEN C C---- Check for valid sampling C IF (NX.EQ.NX/4*4) THEN IF (NY.EQ.NY/4*4) THEN IF (NZ.EQ.NZ/4*4) THEN C C---- Check for map limits C IF (XMAX.LE.NX/2) THEN IF (YMAX.LE.NY/4) THEN C C---- Set array size from memory size: SIZE is maximum size, C MINSIZ is minimum = 1 section. C Routine returns new value of SIZE C MP1 = ((NY+2)* (LMAX+1))/2 MP2 = (NX/2+1)*NZ MINSIZ = MAX(MP1,MP2) C C ********************* c CALL CCPASZ(X,SIZE,MINSIZ) C ********************* C P1 = (SIZE/ ((NY+2)* (LMAX+1)))*2 IF (P1.GT.HMAX-HMIN+1) P1 = HMAX - HMIN + 1 NP1 = P1 P2 = SIZE/ ((NX/2+1)*NZ) C IF (P1.LE.0 .OR. P2.LE.0) THEN WRITE (6,FMT=6002) SIZE,NX,NY,NZ,KMAX 6002 FORMAT (' Request too large. Buffer = ',I10,/4I25) C C ************************ CALL CCPERR(1,'Internal error in FFT21') C ************************ C ELSE C C---- calculate the dimensions of the direct-access scratch file t2. C NH = HMAX + 1 C NH1 = (NH-1)/P1 + 1 NY2 = (YMAX-YMIN)/P2 + 1 C NRECDS = 2*NH1*NY2 NWORDS = P1*P2* (LMAX+1) C C ********************************** CALL FILEO(T2,SIZE,P1,P2,NWORDS,NRECDS) CALL QOPEN(T2,'DISKIO1','SCRATCH') CALL QMODE(T2,2,MODEDUM) C ********************************** C C---- pass one : transform on k and write intermediate results on t2. C in this transform, the body-centering is used as follows : the C input routine 'ortsfi' overlays pairs of h-planes of structure C factors for consecutive even/odd values of h ; these overlaid data C are subjected to the k-transform, then the intermediate results C are recovered according to their parity in routine 'hsep1i' . C IREC = 0 R = 0 TIME = JTIME(2) 10 CONTINUE IF (R+P1.GT.HMAX) P1 = HMAX + 1 - R C C *********************************** CALL SFIIYC(X, (NY/2)+1,LMAX+1,P1/2,R,M) C *********************************** C T = JTIME(2) I1 = I1 + T - TIME TIME = T D(1) = (NY+2)* (P1/2)* (LMAX+1) D(2) = 2 D(3) = D(1) D(4) = D(1) D(5) = NY + 2 C C ************************ CALL HERMFT(X(1),X(2),NY/2,D) C ************************ C T = JTIME(2) C1 = C1 + T - TIME TIME = T C C *********************************************** CALL HSEP1C(X,NY+2,LMAX+1,P1/2) CALL YOUT1I(X,NY+2,LMAX+1,P1/2,P2,YMIN,YMAX,T2,IREC, + NWORDS) CALL TRNP1C(X,NY+2,LMAX+1,P1/2) CALL YOUT1I(X,NY+2,LMAX+1,P1/2,P2,YMIN,YMAX,T2,IREC, + NWORDS) C *********************************************** C T = JTIME(2) I2 = I2 + T - TIME TIME = T R = R + P1 IF (R.LE.HMAX .AND. M.GT.0) 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 T = JTIME(2) I2 = I2 + T - TIME TIME = T IRMAX = IREC P1 = NP1 SKIP = 0 RECS = (YMAX-YMIN)/P2 R = YMIN 20 CONTINUE IREC = 1 IF (R+P2.GT.YMAX) P2 = YMAX - R + 1 C C ********************************************* CALL YIN3(X,NZ,NX/2+1,P2,HMAX,LMAX,P1,SKIP,RECS,T2, + IREC,IRMAX,NWORDS) C ********************************************* C SKIP = SKIP + 1 T = JTIME(2) I2 = I2 + T - TIME TIME = T C C---- x now contains intermediate results stored with l down the C columns and h across the rows. C D(1) = (NX+2)*NZ*P2/2 D(2) = NZ D(3) = (NX+2)*NZ/2 D(4) = (LMAX+1)*2 D(5) = 2 C C ************************ CALL REALFT(X(1),X(2),NX/2,D) C ************************ C T = JTIME(2) C2 = C2 + T - TIME TIME = T D(2) = 2 D(3) = (NX+2)*NZ/2 D(4) = (XMAX-XMIN+1)*NZ D(5) = NZ I = XMIN*NZ + 1 C C ************************** CALL HERMFT(X(I),X(I+1),NZ/2,D) C ************************** C T = JTIME(2) C3 = C3 + T - TIME TIME = T C C ****************************** CALL PRNTYZ(X,NZ,NX/2+1,P2,R,T3,T4) C ****************************** C T = JTIME(2) I3 = I3 + T - TIME TIME = T R = R + P2 IF (R.LE.YMAX) GO TO 20 C C *********************************** IF (T3.GT.0) CALL MRDHDR(T3,'MAPOUT',TITLE,NSEC, + IUVW,MXYZ,NW1,NU1,NU2,NV1, + NV2,CELL,LSPGRP,LMODE, + RHMIN,RHMAX,RHMEAN,RHRMS) C ************************************ C C---- End of job C WRITE (6,FMT=6004) TITLE(1:LENSTR(TITLE)) 6004 FORMAT (' ',A) SECOND(1) = REAL(C1)/1000.0 SECOND(2) = REAL(C2)/1000.0 SECOND(3) = REAL(C3)/1000.0 WRITE (6,FMT=6006) SECOND 6006 FORMAT (' Transform Time = ',F10.3,' Seconds.') SECOND(1) = REAL(I1)/1000.0 SECOND(2) = REAL(I2)/1000.0 SECOND(3) = REAL(I3)/1000.0 WRITE (6,FMT=6008) SECOND 6008 FORMAT (' Input/Output Time = ',F10.3,' Seconds.') C END IF RETURN ELSE END IF END IF CALL CCPERR(1, '[permuted] XMAX, YMAX must be'// $ '.le. NX/2, NY/4') ELSE END IF END IF END IF CALL CCPERR(1, '[permuted] NX,NY,NZ must be multiples of 4') ELSE WRITE (6,FMT=6014) NX,HMAX 6014 FORMAT (/' !!!! NX =',I5,' must be .ge. 2*HMAX+1, HMAX =',I5,/) C C ************************ CALL CCPERR(1, 'bad grid') C ************************ C END IF C END C C C C ======================== SUBROUTINE FFT23(X,SIZE) C ======================== C C calculates a fourier synthesis for space group i222 given the C unique set of structure factors. the body-centering is used to C speed up the first transform . C the volume calculated is: 0 to nx/2 , 0 to ny/4 , 0 to nz-1 . C C this version of the program produces y-sections in C which z varies most rapidly and x varies most slowly. C this is considerably faster if whole sections are to be C written out. C C the scratch file is in direct access. C C written by G. Bricogne, may 1977. C C .. Scalar Arguments .. INTEGER SIZE C .. C .. Array Arguments .. REAL X(SIZE) C .. C .. Scalars in Common .. INTEGER HMAX,HMIN,KMAX,KMIN,LMAX,LMIN,NABCH,NSECAX,NSYMCH,NX,NY, + NZ,IFIL,IFILO,T2,T3,T4,XMAX,XMIN,YMAX,YMIN,ZMAX,ZMIN CHARACTER TITLE*80 C .. C .. Arrays in Common .. INTEGER JMPHDR C .. C .. Local Scalars .. REAL RHMAX,RHMEAN,RHMIN,RHRMS INTEGER C1,C2,C3,I,I1,I2,I3,IREC,IRMAX,LMODE,LSPGRP,M,MINSIZ,MP1, + MP2,NH,NH1,NP1,NRECDS,NSEC,NU1,NU2,NV1,NV2,NW1,NWORDS,NY2, + P1,P2,R,RECS,SKIP,T,TIME,MODEDUM C .. C .. Local Arrays .. REAL CELL(6),SECOND(3) INTEGER D(5),IUVW(3),MXYZ(3) C .. C .. External Functions .. INTEGER JTIME,LENSTR EXTERNAL JTIME,LENSTR C .. C .. External Subroutines .. EXTERNAL CCPERR,FILEO,HERMFT,HSEP1I,MRDHDR,PRNTYZ,QOPEN, + REALFT,SFIIYC,TRNP1I,YIN3,YOUT1I C .. C .. Intrinsic Functions .. INTRINSIC MAX,REAL C .. C .. Common blocks .. COMMON /HKLLIM/HMAX,KMAX,LMAX,HMIN,KMIN,LMIN COMMON /IOFFT/IFIL,IFILO,T2,T3,T4,NSYMCH,NABCH,NSECAX COMMON /MPHDR/NX,NY,NZ,XMIN,XMAX,YMIN,YMAX,ZMIN,ZMAX,JMPHDR(19) COMMON /MPHDRR/TITLE C .. C .. Save statement .. SAVE C .. C1 = 0 C2 = 0 C3 = 0 I1 = 0 I2 = 0 I3 = 0 C WRITE (6,FMT=6000) 6000 FORMAT (/30X,'Fourier synthesis for space-group I222',//) C C---- Set minimum indices C HMIN = 0 KMIN = 0 LMIN = 0 HMAX = (HMAX/2)*2 + 1 C IF (NX.GE.2*HMAX+1) THEN C C---- Check for valid sampling C IF (NX.EQ.NX/4*4) THEN IF (NY.EQ.NY/4*4) THEN IF (NZ.EQ.NZ/4*4) THEN C C---- Check for map limits C IF (XMAX.LE.NX/2) THEN IF (YMAX.LE.NY/4) THEN C C---- Set array size from memory size: SIZE is maximum size, C MINSIZ is minimum = 1 section. C Routine returns new value of SIZE C MP1 = ((NY+2)* (LMAX+1))/2 MP2 = (NX/2+1)*NZ MINSIZ = MAX(MP1,MP2) C C ********************* c CALL CCPASZ(X,SIZE,MINSIZ) C ********************* C P1 = (SIZE/ ((NY+2)* (LMAX+1)))*2 IF (P1.GT.HMAX-HMIN+1) P1 = HMAX - HMIN + 1 NP1 = P1 P2 = SIZE/ ((NX/2+1)*NZ) C IF (P1.LE.0 .OR. P2.LE.0) THEN WRITE (6,FMT=6002) SIZE,NX,NY,NZ,KMAX 6002 FORMAT (' Request too large. Buffer = ',I10,/4I25) C C *********************** CALL CCPERR(1,'Internal error in FFT23') C *********************** C ELSE C C---- calculate the dimensions of the direct-access scratch file t2. C NH = HMAX + 1 C NH1 = (NH-1)/P1 + 1 NY2 = (YMAX-YMIN)/P2 + 1 C NRECDS = 2*NH1*NY2 NWORDS = P1*P2* (LMAX+1) C C ********************************** CALL FILEO(T2,SIZE,P1,P2,NWORDS,NRECDS) CALL QOPEN(T2,'DISKIO1','SCRATCH') CALL QMODE(T2,2,MODEDUM) C ********************************** C C---- pass one : transform on k and write intermediate results on t2. C in this transform, the body-centering is used as follows : the C input routine 'ortsfi' overlays pairs of h-planes of structure C factors for consecutive even/odd values of h ; these overlaid data C are subjected to the k-transform, then the intermediate results C are recovered according to their parity in routine 'hsep1i' . C IREC = 0 R = 0 TIME = JTIME(2) 10 CONTINUE IF (R+P1.GT.HMAX) P1 = HMAX + 1 - R C C *********************************** CALL SFIIYC(X, (NY/2)+1,LMAX+1,P1/2,R,M) C *********************************** C T = JTIME(2) I1 = I1 + T - TIME TIME = T D(1) = (NY+2)* (P1/2)* (LMAX+1) D(2) = 2 D(3) = D(1) D(4) = D(1) D(5) = NY + 2 C C ************************ CALL HERMFT(X(1),X(2),NY/2,D) C ************************ C T = JTIME(2) C1 = C1 + T - TIME TIME = T C C ********************************************** CALL HSEP1I(X,NY+2,LMAX+1,P1/2) CALL YOUT1I(X,NY+2,LMAX+1,P1/2,P2,YMIN,YMAX,T2,IREC, + NWORDS) CALL TRNP1I(X,NY+2,LMAX+1,P1/2) CALL YOUT1I(X,NY+2,LMAX+1,P1/2,P2,YMIN,YMAX,T2,IREC, + NWORDS) C *********************************************** C T = JTIME(2) I2 = I2 + T - TIME TIME = T R = R + P1 IF (R.LE.HMAX .AND. M.GT.0) 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 T = JTIME(2) I2 = I2 + T - TIME TIME = T IRMAX = IREC P1 = NP1 SKIP = 0 RECS = (YMAX-YMIN)/P2 R = YMIN 20 CONTINUE IREC = 1 IF (R+P2.GT.YMAX) P2 = YMAX - R + 1 C C ********************************************* CALL YIN3(X,NZ,NX/2+1,P2,HMAX,LMAX,P1,SKIP,RECS,T2, + IREC,IRMAX,NWORDS) C ********************************************* C SKIP = SKIP + 1 T = JTIME(2) I2 = I2 + T - TIME TIME = T C C---- X now contains intermediate results stored with l down the C columns and h across the rows. C D(1) = (NX+2)*NZ*P2/2 D(2) = NZ D(3) = (NX+2)*NZ/2 D(4) = (LMAX+1)*2 D(5) = 2 C C ************************ CALL REALFT(X(1),X(2),NX/2,D) C ************************ C T = JTIME(2) C2 = C2 + T - TIME TIME = T D(2) = 2 D(3) = (NX+2)*NZ/2 D(4) = (XMAX-XMIN+1)*NZ D(5) = NZ I = XMIN*NZ + 1 C C ************************** CALL HERMFT(X(I),X(I+1),NZ/2,D) C ************************** C T = JTIME(2) C3 = C3 + T - TIME TIME = T C C ****************************** CALL PRNTYZ(X,NZ,NX/2+1,P2,R,T3,T4) C ****************************** C T = JTIME(2) I3 = I3 + T - TIME TIME = T R = R + P2 IF (R.LE.YMAX) GO TO 20 C C ************************************* IF (T3.GT.0) CALL MRDHDR(T3,'MAPOUT',TITLE,NSEC, + IUVW,MXYZ,NW1,NU1,NU2,NV1, + NV2,CELL,LSPGRP,LMODE, + RHMIN,RHMAX,RHMEAN,RHRMS) C ************************************* C C---- End of job C WRITE (6,FMT=6004) TITLE(1:LENSTR(TITLE)) 6004 FORMAT (' ',A) SECOND(1) = REAL(C1)/1000.0 SECOND(2) = REAL(C2)/1000.0 SECOND(3) = REAL(C3)/1000.0 WRITE (6,FMT=6006) SECOND 6006 FORMAT (' Transform Time = ',F10.3,' Seconds.') SECOND(1) = REAL(I1)/1000.0 SECOND(2) = REAL(I2)/1000.0 SECOND(3) = REAL(I3)/1000.0 WRITE (6,FMT=6008) SECOND 6008 FORMAT (' Input/Output Time = ',F10.3,' Seconds.') C END IF RETURN ELSE END IF END IF CALL CCPERR(1, + '[permuted] XMAX, YMAX must be.le. NX/2, NY/4') ELSE END IF END IF END IF CALL CCPERR(1,'[permuted] NX,NY,NZ must be multiples of 4') ELSE WRITE (6,FMT=6014) NX,HMAX 6014 FORMAT (/' !!!! [permuted] NX =',I5, $ ' must be .ge. 2*HMAX+1, HMAX =',I5,/) C C *********************** CALL CCPERR(1, 'Bad grid') C *********************** C END IF C END C C C C ======================= SUBROUTINE FFT3(X,SIZE) C ======================= C C fourier synthesis for space group P2, b axis unique C C this version of the program produces y-sections in C which z varies most rapidly and x varies most slowly. C C the scratch file is in direct access. C G. Bricogne, april 77. C C .. Scalar Arguments .. INTEGER SIZE C .. C .. Array Arguments .. REAL X(SIZE) C .. C .. Scalars in Common .. INTEGER HMAX,HMIN,KMAX,KMIN,LMAX,LMIN,NABCH,NSECAX,NSYMCH,NX,NY, + NZ,IFIL,IFILO,T2,T3,T4,XMAX,XMIN,YMAX,YMIN,ZMAX,ZMIN CHARACTER TITLE*80 C .. C .. Arrays in Common .. INTEGER JMPHDR C .. C .. Local Scalars .. REAL RHMAX,RHMEAN,RHMIN,RHRMS,T,TIME INTEGER C1,C2,C3,I,I1,I2,I3,IREC,IRMAX,LMODE,LSPGRP,M,MINSIZ,MP1, + MP2,NH,NH1,NP1,NRECDS,NSEC,NU1,NU2,NV1,NV2,NW1,NWORDS,NY2, + P1,P2,R,RECS,SKIP,MODEDUM C .. C .. Local Arrays .. REAL CELL(6),SECOND(3) INTEGER D(5),IUVW(3),MXYZ(3) C .. C .. External Functions .. INTEGER JTIME,LENSTR EXTERNAL JTIME,LENSTR C .. C .. External Subroutines .. EXTERNAL CCPERR,FILEO,HERMFT,MRDHDR,PRNTYZ,QOPEN,REALFT, + SFIPYC,YIN1,YOUT1 C .. C .. Intrinsic Functions .. INTRINSIC MAX,REAL C .. C .. Common blocks .. COMMON /HKLLIM/HMAX,KMAX,LMAX,HMIN,KMIN,LMIN COMMON /IOFFT/IFIL,IFILO,T2,T3,T4,NSYMCH,NABCH,NSECAX COMMON /MPHDR/NX,NY,NZ,XMIN,XMAX,YMIN,YMAX,ZMIN,ZMAX,JMPHDR(19) COMMON /MPHDRR/TITLE C .. C .. Save statement .. SAVE C .. C1 = 0 C2 = 0 C3 = 0 I1 = 0 I2 = 0 I3 = 0 C WRITE (6,FMT=6000) 6000 FORMAT (/30X,'Fourier synthesis for space-group P2',//) C HMAX = ((HMAX+1)/2)*2 C IF (NX.GE.2*HMAX+1) THEN C C---- Set index limits C HMIN = -HMAX KMIN = 0 LMIN = 0 C C---- Check sampling C IF (NX.EQ.NX/2*2) THEN IF (NY.EQ.NY/2*2) THEN IF (NZ.NE.NZ/2*2) THEN ELSE IF (XMAX.LE.NX/2) THEN C C---- Set array size from memory size: SIZE is maximum size, C MINSIZ is minimum = 1 section. Routine returns new value of SIZE C MP1 = (2*NY* (LMAX+1))/2 MP2 = (NX/2+1)*NZ MINSIZ = MAX(MP1,MP2) C C ********************* c CALL CCPASZ(X,SIZE,MINSIZ) C ********************* C P1 = (SIZE/ (2*NY* (LMAX+1)))*2 IF (P1.GT.HMAX-HMIN+1) P1 = HMAX - HMIN + 1 NP1 = P1 P2 = SIZE/ ((NX/2+1)*NZ) C IF (P1.LE.0 .OR. P2.LE.0) THEN WRITE (6,FMT=6002) SIZE,NX,NY,NZ,KMAX 6002 FORMAT (' Request TOO Large. Buffer = ',I10,/4I25) C C *********************** CALL CCPERR(1, 'Internal error in FFT3') C *********************** C ELSE C C---- calculate the dimensions of the direct-access scratch file t2. C NH = 2*HMAX + 2 C NH1 = (NH-1)/P1 + 1 NY2 = (YMAX-YMIN)/P2 + 1 C NRECDS = NH1*NY2 NWORDS = P1*P2* (LMAX+1) C C ********************************** CALL FILEO(T2,SIZE,P1,P2,NWORDS,NRECDS) CALL QOPEN(T2,'DISKIO1','SCRATCH') CALL QMODE(T2,2,MODEDUM) C ********************************** C C---- pass one. transform on k and write intermediate results on t2. C IREC = 0 R = HMIN TIME = JTIME(2) 10 CONTINUE IF (R+P1-2.GT.HMAX) P1 = HMAX - R + 2 C C **************************** CALL SFIPYC(X,NY/2,LMAX+1,P1,R,M) C **************************** C T = JTIME(2) I1 = I1 + T - TIME TIME = T D(1) = NY*P1* (LMAX+1) D(2) = 2 D(3) = D(1) D(4) = D(1) D(5) = NY C C ************************ CALL HERMFT(X(1),X(2),NY/2,D) C ************************ C T = JTIME(2) C1 = C1 + T - TIME TIME = T C C ************************************* CALL YOUT1(X,NY,LMAX+1,P1,P2,YMIN,YMAX,T2,IREC,NWORDS) C ************************************* C T = JTIME(2) I2 = I2 + T - TIME TIME = T R = R + P1 IF (R.LE.HMAX .AND. M.GT.0) 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 T = JTIME(2) I2 = I2 + T - TIME TIME = T IRMAX = IREC P1 = NP1 SKIP = 0 RECS = (YMAX-YMIN)/P2 R = YMIN 20 CONTINUE IREC = 1 IF (R+P2.GT.YMAX) P2 = YMAX - R + 1 C C ************************************** CALL YIN1(X,NZ,NX/2+1,P2,HMAX,LMAX,P1,SKIP,RECS,T2,IREC, + IRMAX,NWORDS) C *************************************** C SKIP = SKIP + 1 T = JTIME(2) I2 = I2 + T - TIME TIME = T C C---- X now contains intermediate results stored with l down the C columns and h across the rows in even/odd pairs. C D(1) = (NX+2)*NZ*P2/2 D(2) = NZ D(3) = (NX+2)*NZ/2 D(4) = (LMAX+1)*2 D(5) = 2 C C ************************ CALL REALFT(X(1),X(2),NX/2,D) C ************************ C T = JTIME(2) C2 = C2 + T - TIME TIME = T D(2) = 2 D(3) = (NX+2)*NZ/2 D(4) = (XMAX-XMIN+1)*NZ D(5) = NZ I = XMIN*NZ + 1 C C ************************** CALL HERMFT(X(I),X(I+1),NZ/2,D) C ************************** C T = JTIME(2) C3 = C3 + T - TIME TIME = T C C ****************************** CALL PRNTYZ(X,NZ,NX/2+1,P2,R,T3,T4) C ****************************** C T = JTIME(2) I3 = I3 + T - TIME TIME = T R = R + P2 IF (R.LE.YMAX) GO TO 20 C C ******************************* IF (T3.GT.0) CALL MRDHDR(T3,'MAPOUT',TITLE,NSEC,IUVW, + MXYZ,NW1,NU1,NU2,NV1,NV2,CELL, + LSPGRP,LMODE,RHMIN,RHMAX, + RHMEAN,RHRMS) C ******************************* C C---- End of job C WRITE (6,FMT=6004) TITLE(1:LENSTR(TITLE)) 6004 FORMAT (' ',A) SECOND(1) = REAL(C1)/1000.0 SECOND(2) = REAL(C2)/1000.0 SECOND(3) = REAL(C3)/1000.0 WRITE (6,FMT=6006) SECOND 6006 FORMAT (' Transform Time = ',F7.3,' Seconds.') SECOND(1) = REAL(I1)/1000.0 SECOND(2) = REAL(I2)/1000.0 SECOND(3) = REAL(I3)/1000.0 WRITE (6,FMT=6008) SECOND 6008 FORMAT (' Input/Output Time = ',F7.3,' Seconds.') C END IF RETURN ELSE CALL CCPERR(1, 'Illegal limits: must be NX .le. NX/2') END IF END IF END IF CALL CCPERR(1, 'Illegal sampling: must be NX=2n, NY=2n, NZ=2n') ELSE WRITE (6,FMT=6014) NX,HMAX 6014 FORMAT (/' !! NX = ',I5,' must be .ge. 2*HMAX+2 , HMAX =',I5/) C C *********************** CALL CCPERR(1,'Bad grid') C *********************** C END IF C END C C C C ======================= SUBROUTINE FFT4(X,SIZE) C ======================= C C fourier synthesis for space group P21 C C .. Scalar Arguments .. INTEGER SIZE C .. C .. Array Arguments .. REAL X(SIZE) C .. C .. Scalars in Common .. INTEGER HMAX,HMIN,IXMAX,IXMIN,IYMAX,IYMIN,IZMAX,IZMIN,KMAX,KMIN, + LMAX,LMIN,NABCH,NSECAX,NSYMCH,NX,NY,NZ,IFIL,IFILO,T2,T3,T4 CHARACTER TITLE*80 C .. C .. Arrays in Common .. INTEGER JMPHDR C .. C .. Local Scalars .. REAL RHMAX,RHMEAN,RHMIN,RHRMS INTEGER I,IQ,IREC,IRMAX,KM1,LM1,LMODE,LSPGRP,M,MINSIZ,MP1,MP2,NP1, + NRECS,NSEC,NU1,NU2,NV1,NV2,NW1,NWORDS,P1,P2,R,RECS,SKIP, $ MODEDUM C .. C .. Local Arrays .. REAL CELL(6) INTEGER D(5),IUVW(3),MXYZ(3) C .. C .. External Subroutines .. EXTERNAL CCPERR,CMPLFT,FILEO,HERMFT,MRDHDR,PRNTYZ,QOPEN, + SDIAD,SFIPYC,YIN2,YOUT2 C .. C .. Intrinsic Functions .. INTRINSIC MAX C .. C .. Common blocks .. COMMON /HKLLIM/HMAX,KMAX,LMAX,HMIN,KMIN,LMIN COMMON /IOFFT/IFIL,IFILO,T2,T3,T4,NSYMCH,NABCH,NSECAX COMMON /MPHDR/NX,NY,NZ,IXMIN,IXMAX,IYMIN,IYMAX,IZMIN,IZMAX, + JMPHDR(19) COMMON /MPHDRR/TITLE C .. C .. Save statement .. SAVE C .. WRITE (6,FMT=6000) 6000 FORMAT (/30X,'Fourier synthesis for space-group P21',//) C C---- Set minimum indices C HMIN = -HMAX KMIN = 0 LMIN = 0 C C---- Check for valid sampling intervals C IF (NZ.EQ.NZ/2*2) THEN IF (NY.NE.NY/4*4) THEN C C---- Check y limits C ELSE IF (IYMAX.LE.NY/2) THEN C LM1 = LMAX + 1 KM1 = KMAX + 1 C C---- Set array size from memory size: SIZE is maximum size, C MINSIZ is minimum = 1 section. C Routine returns new value of SIZE C MP1 = ((NY+2)*LM1) MP2 = NX*NZ MINSIZ = MAX(MP1,MP2) C C ********************* c CALL CCPASZ(X,SIZE,MINSIZ) C ********************* C C---- calculate dimensioning parameters C P1 = SIZE/MP1 IF (P1.GT.HMAX-HMIN+1) P1 = HMAX - HMIN + 1 NP1 = P1 P2 = SIZE/MP2 C IF (P1.LE.0 .OR. P2.LE.0) THEN WRITE (6,FMT=6002) SIZE 6002 FORMAT (//' Buffer size too small, ',I8,/) C C *********************** CALL CCPERR(1,' Internal error in FFT4') C *********************** C ELSE C C---- Calculate record size and number of records for C direct access scratch file C NWORDS = 2*P1*P2*LM1 NRECS = ((2*HMAX)/P1+1)* ((IYMAX-IYMIN)/P2+1) C C---- Open file and print numbers C C ********************************* CALL FILEO(T2,SIZE,P1,P2,NWORDS,NRECS) CALL QOPEN(T2,'DISKIO1','SCRATCH') CALL QMODE(T2,2,MODEDUM) C ********************************* C C---- transform on k and write results on t2 C IREC = 0 R = -HMAX 10 CONTINUE IF (R+P1.GT.HMAX) P1 = HMAX + 1 - R C C---- read in data C C *************************** CALL SFIPYC(X,NY/2+1,LM1,P1,R,M) C *************************** C IQ = R + P1 - 1 C C---- pass one. transform on k and write intermediate results on t2. C IF (R+P1.GT.HMAX) P1 = HMAX + 1 - R D(1) = (NY+2)* (LMAX+1)*P1 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,P1,P2,IYMIN,IYMAX,T2,IREC,NWORDS) C ************************************************ C R = R + P1 IF (R.LE.HMAX .AND. M.GT.0) 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 P1 = NP1 SKIP = 0 IRMAX = IREC RECS = (IYMAX-IYMIN)/P2 R = IYMIN 20 CONTINUE IREC = 1 IF (R+P2.GT.IYMAX) P2 = IYMAX - R + 1 C C ************************************************* CALL YIN2(X,NZ/2,NX,P2,HMAX,LMAX,P1,SKIP,RECS,T2,IREC,IRMAX, + NWORDS) C ************************************************* C SKIP = SKIP + 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*P2 D(2) = NZ D(3) = NX*NZ D(4) = (LMAX+1)*2 D(5) = 2 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 C---- map calculated for p2 sections C WRITE (6,FMT=*) NX,NZ C C ************************** CALL PRNTYZ(X,NZ,NX,P2,R,T3,T4) C ************************** C R = R + P2 IF (R.LE.IYMAX) GO TO 20 C C *************************************** IF (T3.GT.0) CALL MRDHDR(T3,'MAPOUT',TITLE,NSEC,IUVW,MXYZ, + NW1,NU1,NU2,NV1,NV2,CELL,LSPGRP, + LMODE,RHMIN,RHMAX,RHMEAN,RHRMS) C *************************************** C END IF RETURN ELSE CALL CCPERR(1, 'YMAX must be .le. NY/2') END IF END IF CALL CCPERR(1, 'NY must be a multiple of 4 and NZ must be even') END C C C C ======================== SUBROUTINE FFT47(X,SIZE) C ======================== C C FOURIER SYNTHESIS FOR SPACE GROUP Pmmm C z-sections, based on John Chambers' version C C .. Scalar Arguments .. INTEGER SIZE C .. C .. Array Arguments .. REAL X(SIZE) C .. C .. Scalars in Common .. INTEGER HMAX,HMIN,IXMAX,IXMIN,IYMAX,IYMIN,IZMAX,IZMIN,KMAX,KMIN, + LMAX,LMIN,NABCH,NSECAX,NSYMCH,NX,NY,NZ,IFIL,IFILO,T2,T3,T4 CHARACTER TITLE*80 C .. C .. Arrays in Common .. INTEGER JMPHDR C .. C .. Local Scalars .. REAL RHMAX,RHMEAN,RHMIN,RHRMS INTEGER IREC,IRMAX,KM1,LMODE,LSPGRP,M,MINSIZ,MP1,MP2,NP1,NRECS, + NSEC,NU1,NU2,NV1,NV2,NW1,NWORDS,NX21,NY21,NZ21,NZP2,P1,P2, + R,RECS,SKIP,MODEDUM C .. C .. Local Arrays .. REAL CELL(6) INTEGER D(5),IUVW(3),MXYZ(3) C .. C .. External Subroutines .. EXTERNAL CCPERR,FILEO,MRDHDR,PRNTYZ,QOPEN,RSYMFT,SFIPYR, + ZIN47,ZOUT47 C .. C .. Intrinsic Functions .. INTRINSIC MAX C .. C .. Common blocks .. COMMON /HKLLIM/HMAX,KMAX,LMAX,HMIN,KMIN,LMIN COMMON /IOFFT/IFIL,IFILO,T2,T3,T4,NSYMCH,NABCH,NSECAX COMMON /MPHDR/NX,NY,NZ,IXMIN,IXMAX,IYMIN,IYMAX,IZMIN,IZMAX, + JMPHDR(19) COMMON /MPHDRR/TITLE C .. C .. Save statement .. SAVE C .. WRITE (6,FMT=6000) 6000 FORMAT (/30X,'Fourier synthesis for space-group Pmmm',//) C C---- Set index limits C HMIN = 0 KMIN = 0 LMIN = 0 C C---- Check sampling C IF (NX.EQ.NX/8*8) THEN IF (NZ.EQ.NZ/8*8) THEN IF (NY.EQ.NY/8*8) THEN IF (IXMAX.LE.NX/2) THEN IF (IYMAX.LE.NY/2) THEN IF (IZMAX.LE.NZ/2) THEN C NZ21 = NZ/2 + 1 NZP2 = NZ + 2 KM1 = KMAX + 1 C C---- Set array size from memory size: SIZE is maximum size, C MINSIZ is minimum = 1 section. C Routine returns new value of SIZE C MP1 = (NZ21*KM1) MP2 = NX*NY MINSIZ = MAX(MP1,MP2) C C ********************* c CALL CCPASZ(X,SIZE,MINSIZ) C ********************* C P1 = SIZE/ (NZ21*KM1) IF (P1.GT.HMAX-HMIN+1) P1 = HMAX - HMIN + 1 NP1 = P1 P2 = SIZE/ (NX*NY) C IF (P1.LE.0 .OR. P2.LE.0) THEN WRITE (6,FMT=6002) SIZE 6002 FORMAT (//' Buffer size too small, ',I8,/) C C *********************** CALL CCPERR(1,'Internal error in fft47') C *********************** C ELSE C C---- Calculate record levngth and number of records in scratch file C NWORDS = P1*P2*KM1 NRECS = ((IZMAX-IZMIN)/P2+1)* (HMAX/P1+1) C C ********************************* CALL FILEO(T2,SIZE,P1,P2,NWORDS,NRECS) CALL QOPEN(T2,'DISKIO1','SCRATCH') CALL QMODE(T2,2,MODEDUM) C ********************************* C C---- transform on l and write results on t2 C IREC = 0 R = 0 10 CONTINUE IF (R+P1.GT.HMAX) P1 = HMAX + 1 - R C C---- NB Although this routine gives z-sections it wants the array C as X(k,l,h) C C ************************* CALL SFIPYR(X,KM1,NZ21,P1,R,M) C ************************* C D(1) = NZ21*KM1*P1 D(2) = KMAX + 1 D(3) = NZ21*KM1 D(4) = KMAX + 1 D(5) = 1 C C ******************************************** CALL RSYMFT(X,NZ/2,D) CALL ZOUT47(X,KM1,NZ21,P1,P2,IZMIN,IZMAX,T2,IREC, + NWORDS) C ******************************************** C R = R + P1 IF (R.LE.HMAX .AND. M.GE.0) GO TO 10 IRMAX = IREC C---- calculate transforms on h and k, and write output C P1 = NP1 RECS = (IZMAX-IZMIN)/P2 NX21 = NX/2 + 1 NY21 = NY/2 + 1 SKIP = 0 R = IZMIN 20 CONTINUE IREC = 1 IF (R+P2.GT.IZMAX) P2 = IZMAX - R + 1 C C ********************************************** CALL ZIN47(X,NY21,NX21,P2,HMAX,KMAX,P1,SKIP,RECS,T2, + IREC,IRMAX,NWORDS) C ********************************************** C SKIP = SKIP + 1 C D(1) = NY21*NX21*P2 D(2) = NY21 D(3) = NY21*NX21 D(4) = KMAX + 1 D(5) = 1 C C **************** CALL RSYMFT(X,NX/2,D) C **************** C D(2) = 1 D(4) = (IXMAX-IXMIN+1)*NY21 D(5) = NY21 C C ****************************** CALL RSYMFT(X(IXMIN*NY21+1),NY/2,D) CALL PRNTYZ(X,NY21,NX21,P2,R,T3,T4) C ****************************** C R = R + P2 IF (R.LE.IZMAX) GO TO 20 C C ************************************* IF (T3.GT.0) CALL MRDHDR(T3,'MAPOUT',TITLE,NSEC, + IUVW,MXYZ,NW1,NU1,NU2,NV1, + NV2,CELL,LSPGRP,LMODE, + RHMIN,RHMAX,RHMEAN,RHRMS) C ************************************* C C---- End of job C END IF RETURN ELSE END IF END IF END IF CALL CCPERR(1, '[permuted] XMAX,YMAX,ZMAX must be' // $ '.le. NZ/2,NY/2,NZ/2') ELSE END IF END IF END IF CALL CCPERR(1, 'Illegal sampling intervals: must be' // $ '[permuted] NX,NY,NZ=8n') END C C C C ======================== SUBROUTINE FFT92(X,SIZE) C ======================== C C Fourier synthesis for space-group P41212 C The data must lie in the symmetric unit h .ge. k , l .ge. 0 C INTEGER LSYM PARAMETER (LSYM=192) C C .. Scalar Arguments .. INTEGER SIZE C .. C .. Array Arguments .. REAL X(*) C .. C .. Scalars in Common .. INTEGER HMAX,HMIN,IXMAX,IXMIN,IYMAX,IYMIN,IZMAX,IZMIN,KMAX,KMIN, + LMAX,LMIN,NABCH,NSECAX,NSPFFT,NSYMCH,NX,NY,NZ,IFIL,IFILO,T2 $ ,T3,T4,NSMFFT,NLAFFT CHARACTER TITLE*80 C .. C .. Arrays in Common .. INTEGER JMPHDR REAL RSMFFT C .. C .. Local Scalars .. REAL RHMAX,RHMEAN,RHMIN,RHRMS INTEGER HMAXA,HMINA,I,IHKA,IREC,KHMIN,KMAX1,LMODE,LSPGRP,M,MINSIZ, + MP1,MP2,NRECS,NSEC,NU1,NU2,NV1,NV2,NW1,NWORDS,NX1,NY2, + NZ21,P1,P2,R,MODEDUM C .. C .. Local Arrays .. REAL CELL(6) INTEGER D(5),IUVW(3),MXYZ(3) C .. C .. External Functions .. INTEGER LENSTR EXTERNAL LENSTR C .. C .. External Subroutines .. EXTERNAL CCPERR,CMPLFT,FILEO,HERMFT,MRDHDR,PRNTYZ,QOPEN, + SDIAD,SFIP92,YOUT92,ZIN C .. C .. Intrinsic Functions .. INTRINSIC INT,MAX,SQRT C .. C .. Common blocks .. COMMON /FFTSPG/NSPFFT,NSMFFT,RSMFFT(4,4,LSYM),NLAFFT COMMON /HKLLIM/HMAX,KMAX,LMAX,HMIN,KMIN,LMIN COMMON /IOFFT/IFIL,IFILO,T2,T3,T4,NSYMCH,NABCH,NSECAX COMMON /MPHDR/NX,NY,NZ,IXMIN,IXMAX,IYMIN,IYMAX,IZMIN,IZMAX, + JMPHDR(19) COMMON /MPHDRR/TITLE C .. C .. Save statement .. SAVE C .. WRITE (6,FMT=6000) 6000 FORMAT + (/30X,'Fourier synthesis for space-group P41212/P43212',//) C C---- Set index limits C HMIN = 0 KMIN = 0 LMIN = 0 HMAX = MAX(HMAX,KMAX) KMAX = HMAX C C---- Check sampling etc C IF (NZ.EQ.NZ/8*8) THEN IF (NX.EQ.NX/2*2) THEN IF (NY.NE.NX) THEN ELSE IF (IZMAX.LE.NZ/2) THEN C NZ21 = NZ/2 + 1 KMAX1 = KMAX + 1 C C---- Allocate space at end of array X for C complex array Y(KMAX+1,NX) in YOU C SIZE = SIZE - (KMAX+1)*NX*2 C NWORDS = 2*KMAX1*NX NRECS = IZMAX - IZMIN + 1 C C---- Set array size from memory size: SIZE is maximum size, C MINSIZ is minimum = 1 section. C Routine returns new value of SIZE C MP1 = (2*NZ21) MP2 = NX*NY MINSIZ = MAX(MP1,MP2) C C ********************* c CALL CCPASZ(X,SIZE,MINSIZ) C ********************* C P1 = SIZE/ (2*NZ21) P2 = SIZE/ (NX*NY) C IF (P1.LE.0 .OR. P2.LE.0) THEN WRITE (6,FMT=6002) SIZE,NX,NY,NZ,KMAX 6002 FORMAT (' Request too large. Buffer = ',I10,/4I25) C C *********************** CALL CCPERR(1,'Internal error in FFT92') C *********************** C ELSE C C---- open scratch file now - this contains records y(kmax1,nx) C C ********************************* CALL FILEO(T2,SIZE,P1,P2,NWORDS,NRECS) CALL QOPEN(T2,'DISKIO1','SCRATCH') CALL QMODE(T2,2,MODEDUM) C ********************************* C C---- pass one. C transform on l and write intermediate results C on scratch disk file C KHMIN = 0 HMINA = 0 10 CONTINUE C C---- want (HMAXA+1)*(HMAXA+2)/2 .LE. P1 + KHMIN C HMAXA = INT(SQRT(9.0- (1-P1-KHMIN)*8.0)+ (-3.0))/2 IF (HMAXA.GT.HMAX) HMAXA = HMAX IHKA = (HMAXA+1)* (HMAXA+2)/2 - KHMIN IHKA = ((IHKA+1)/2)*2 C C *************************************** CALL SFIP92(X,NZ21,IHKA,HMINA,HMAXA,KHMIN,M) 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 SDIAD(X(1),X(2),NZ21-1,D) C ************************* C C---- YOUT92 generates the complete set of t(hkz) for each z section C in turn (z<1/8) for 0 - sampling fineness of 1.0/ C ============================================================ C 160 CONTINUE KEY = CVALUE(2) CALL CCPUPC(KEY) IF (KEY .EQ. 'SAMP') THEN CALL GTPREA(3,GRDSMP,NTOK,ITYP,FVALUE) IF (GRDSMP .LT. 2.0) THEN WRITE (ISYSW,FMT='(A)') $ ' ** GRID sampling must be at least 2 **' KE = KE + 1 ENDIF ELSE IF (NTOK.EQ.4) THEN C C ****************************** CALL GTPINT(2,NX,NTOK,ITYP,FVALUE) CALL GTPINT(3,NY,NTOK,ITYP,FVALUE) CALL GTPINT(4,NZ,NTOK,ITYP,FVALUE) C ****************************** C ELSE WRITE (ISYSW,FMT='(A)') ' ** Too few tokens on GRID **' KE = KE + 1 END IF GO TO 10 C C---- SYMMETRY the true space group for the data C =========================================== C 170 CONTINUE JTOK = 2 C C ************************************************** CALL RDSYMM(JTOK,LINE,IBEG,IEND,ITYP,FVALUE,NTOK,NAMSPG, + LSPGRP,PGNAME,NSYM,NSYMP,RSYM) C ************************************************** C C---- Get NLAUE C C Default unset point group to P1 IF (PGNAME .EQ. ' ') THEN PGNAME = 'PG1' ENDIF CALL PGDEFN(PGNAME,NSYMP,NSYM,RSYM,.FALSE.) CALL PGNLAU(PGNAME,NLAUE,LAUNAM) C C For fft hkl generation we only need the primitive symmetry operators. C The output map reads the SYMOP.LIB again and copies all the symmetry C operators into the output file. C NsymAll = NSYM NSYM = NSYMP GO TO 10 C C---- Line printer MAP FORMAT "LPFM" C ============================== C 180 CONTINUE C C ****************************** CALL GTPINT(2,NLINES,NTOK,ITYP,FVALUE) CALL GTPINT(3,NCOL,NTOK,ITYP,FVALUE) CALL GTPINT(4,IDIG,NTOK,ITYP,FVALUE) CALL GTPINT(5,ILIN,NTOK,ITYP,FVALUE) CALL GTPINT(6,LCMIN,NTOK,ITYP,FVALUE) CALL GTPINT(7,LCMAX,NTOK,ITYP,FVALUE) C ****************************** C IF (IDIG.LT.1 .OR. IDIG.GT.4) IDIG = 4 IF (ILIN.GT.3 .OR. ILIN.LT.1) ILIN = 1 C IF (LCMAX.LT.LCMIN) THEN TMP = LCMAX LCMAX = LCMIN LCMIN = TMP END IF C GO TO 10 C C---- "LPMA" Line printer map flag C ============================ C 190 T4 = 6 GO TO 10 C C---- "LABI" i.e. set input labels C ================================ C 200 CONTINUE C ITOK = 2 C C ****************************************************** CALL LKYSET(LSPRGI,NLPRGI,LSUSRJ,LOOKUP,ITOK,NTOK,LINE, + IBEG,IEND) C ****************************************************** C C---- Set up Label Keys. Needed for LRASSN C C **************************************** CALL LKYIN(1,LSPRGI,NLPRGI,NTOK,LINE,IBEG,IEND) C **************************************** C GO TO 10 C C---- "PROJ" Map axis projection - down section axis C ================================================ C 230 CONTINUE C C---- Choose sectioning axis at end C IPROJ = 1 GO TO 10 C C---- "PATT" Patterson C ================= C 240 ISQ = 1 GO TO 10 C C---- "RESO"lution C ============== C 250 CONTINUE JTOK = 2 C C ************************************************* CALL RDRESO(JTOK,ITYP,FVALUE,NTOK,RMIN,RMAX,SMIN,SMAX) C ************************************************* C GO TO 10 C C---- "RHOL" Rho limits C ==================== C 260 CONTINUE RHOMAX = 0.0 TYPE = 0 RHOMIN = 0.0 C C ********************************* CALL GTPREA(2,RHOMAX,NTOK,ITYP,FVALUE) C ********************************* IF (NTOK.GT.2) THEN TYPE = 1 C ********************************* CALL GTPREA(3,RHOMIN,NTOK,ITYP,FVALUE) C ********************************* END IF IF (RHOMAX.LT.RHOMIN) THEN RHOTEM = RHOMAX RHOMAX = RHOMIN RHOMIN = RHOTEM END IF C GO TO 10 C C---- "NOCHeck" C ========= C C - You do not wish to generate any symmetry C equivalent data; If you change axis order, C or do anything fancy it will be overridden C 270 CONTINUE ISORT = 0 NSYM = 0 GO TO 10 C C---- "TITLE" Title C =============== C 280 CONTINUE IF(NTOK.GE.2)TITLE = LINE(IBEG(2) :IEND(NTOK)) GO TO 10 C C---- "XYZLIM" X Y and Z Limits, grid or fractional C ============================================== C 290 CONTINUE C C 22/12/98 - XYZLIM ASU option will get map limits from a call to C s/r SETLIM, otherwise limits set as normal. C IF (NTOK.EQ.2) THEN C IF (CVALUE(2).EQ.'ASU '.OR. CVALUE(2).EQ.'asu ') THEN WRITE (6,FMT='(A,A)') + ' Map limits will be set to the CCP4 asymmetric', + ' unit' LASU = .TRUE. ELSE WRITE (6,FMT='(A,/,2A)') + ' ** Unrecognised argument for XYZLIM **', + ' Must be ASU or else 6 numbers specifying', + ' map limits' END IF C ELSE IF (NTOK.NE.7) THEN C KE = KE + 1 WRITE (6,FMT='(A)') ' ** Too few tokens on XYZLIM **' GO TO 10 C ELSE C I = 1 C DO 310 II = 1,3 DO 300 JJ = 1,2 I = I + 1 C C *************************************** CALL GTPREA(I,XYZLIM(JJ,II),NTOK,ITYP,FVALUE) C *************************************** C 300 CONTINUE C C---- Reorder if needed C IF (XYZLIM(2,II).LT.XYZLIM(1,II)) THEN XTMP = XYZLIM(1,II) XYZLIM(1,II) = XYZLIM(2,II) XYZLIM(2,II) = XTMP END IF C 310 CONTINUE C END IF C GO TO 10 C C---- "VF00" V and F000 Rho scaling C =============================== C 320 CONTINUE F000 = 0.0 C C ****************************** CALL GTPREA(2,V,NTOK,ITYP,FVALUE) CALL GTPREA(3,F000,NTOK,ITYP,FVALUE) C ****************************** C GO TO 10 C C---- "PHTRANSLATION" C ================== C C Phased translation calculation - terms used are: C w*F1*F2 exp(phi1 - phi2) or w*F1*F2 exp(phi1 + PHI2) C 330 IPHTR = 1 IF(NTOK.GT.2)THEN CALL CCPUPC(CVALUE(2)) IF(CVALUE(2).EQ.'HAND') + CALL GTPINT(3,IHAND,NTOK,ITYP,FVALUE) IF(IHAND.EQ.2) CALL HANDCHANGE(LSPGRP,CX,CY,CZ) IF(IHAND.EQ.2) IPHTR = -1 END IF GO TO 10 C C---- "HKLMAX" C ======== C C Set hkl maxima: only for anisotropic resolution C Ignore empty fields, to leave HMAX, KMAX, LMAX C to be set later from resolution limits C (note that HMAX, KMAX, LMAX are set = -1 at beginning C of this routine) 340 IF (ITYP(2) .EQ. 2) CALL GTPINT(2,HMAX,NTOK,ITYP,FVALUE) IF (ITYP(3) .EQ. 2) CALL GTPINT(3,KMAX,NTOK,ITYP,FVALUE) IF (ITYP(4) .EQ. 2) CALL GTPINT(4,LMAX,NTOK,ITYP,FVALUE) GO TO 10 C C---- Free R factor - Value in table to exclude. C ===== C 345 CONTINUE C C ********************************* CALL GTPINT(2,IFreeRexcludeVal,NTOK,ITYP,FVALUE) C ********************************* GO TO 10 C END IF END IF C C---- "END " Must be at end C ========================= C 1000 CONTINUE C C For fft hkl generation we only need the primitive symmetry operators. C The output map reads the SYMOP.LIB again and copies all the symmetry C operators into the output file. C IFIL = 1 IPRINT = 2 IERR = -1 C C ****************************** CALL LROPEN(IFIL,FILIN,IPRINT,IERR) C ****************************** C IF (IERR.EQ.-1) THEN WRITE (ISYSW,FMT='(A)') ' *** NO SUCH FILE !**' C C ************************************** CALL CCPERR(1,' ** File does not exist **') C ************************************** C END IF C C---- Read file info, mostly to get hkl range C C ************************************** CALL LRINFO(IFIL,DUMMY,NCOLS,NREFLS,CRANGE) C ************************************** C C---- Set up true symmetry C IF (NSYMP.LE.0) THEN C C No true symmetry read from control data, so read from HKLIN file C For rest of program, we need only C NSYM = NSYMP (primitive only) C RSYM symmetry operations (primitive) for expansion C LSPGRP space group number to write symmetry to map file C C ********************************************* CALL LRSYMI(IFIL,NSYMP,LTYPE,LSPGRP,NAMSPG,PGNAME) CALL LRSYMM(IFIL,NSYM,RSYM) C---- Get NLAUE (Attention!!! This will re-sort the RSYM array !!!) CALL PGDEFN (PGNAME, NSYMP, NSYM, RSYM, .FALSE.) CALL PGNLAU(PGNAME,NLAUE,LAUNAM) C ********************************************* C If PATT set this may need changing. C NsymAll = NSYM NSYM = NSYMP END IF C Fix Phased translation function if requested. IF (IPHTR.NE.0) THEN C C Set search area whole unit cell XYZLIM(1,1) = 0.0 XYZLIM(2,1) = 1.0 XYZLIM(1,2) = 0.0 XYZLIM(2,2) = 1.0 XYZLIM(1,3) = 0.0 XYZLIM(2,3) = 1.0 LASU = .FALSE. C C Set FFTSPG = P1 if not already done IF(NSMFFT.EQ.-1) THEN NSPFFT = 1 NSMFFT = 1 NAMSPG = 'P1' DO I = 1,4 DO J = 1,4 RSMFFT(J,I,1)=0.0 END DO END DO RSMFFT(1,1,1)=1.0 RSMFFT(2,2,1)=1.0 RSMFFT(3,3,1)=1.0 RSMFFT(4,4,1)=1.0 C C---- Get NLAU ready for grid assignment. C CALL PGDEFN(PGNFFT,NSPFFT,NSMFFT,RSMFFT,.FALSE.) CALL PGNLAU(PGNFFT,NLAFFT,LAUNAM) END IF END IF C C---- Patterson C IF (ISQ.EQ.1) THEN WRITE (6,FMT=7000) 7000 FORMAT (' PATTERSON calculated - ', + /' ** All translational elements of symmetry set to zero', + ' **') C Write out harker vectors CALL HARKER ( NSYM,RSYM) C C Get Patterson spacegroup CALL PATSGP(NAMSPG, PGNAME, PATNAM, I) IF (I .LE. 0) THEN WRITE (6, FMT=7001) NAMSPG 7001 FORMAT (' **** WARNING - no Patterson spacegroup known as ', $ 'equivalent to spacegroup ',A, '****'/ $ ' Spacegroup for map left as Fourier spacegroup'/) ELSE LSPGRP = I WRITE (6, FMT=6003) PATNAM(1:LENSTR(PATNAM)), LSPGRP 6003 FORMAT(/' Patterson spacegroup is ',A, $ ', number ',I6/) C--- Reset sym ops CALL MSYGET(24,LSPGRP,NSYM,RSYM) ENDIF END IF C C---- If LASU then get XYZLIM limits from SETLIM to correspond C to the CCP4 asymmetric unit for the spacegroup of the map C IF (LASU) THEN CALL SETLIM (LSPGRP, XYZLIM) WRITE (6,FMT=7002)LSPGRP, XYZLIM 7002 FORMAT (/' ** The limits of the map have been set to those of', + /' the CCP4 asymmetric unit for appropriate spacegroup', + //' For map spacegroup ',I4,' these limits are:' + //' Min X Max X Min Y Max Y Min Z Max Z', + /,1X,6F8.3, + //' expressed in fractional coordinates and with x,y,z', + /' referring to the unpermutated axes.',/) END IF C C---- Set up FFT symmetry C If not explicitly given set = true symmetry C IF (NSMFFT.LE.0) THEN IF (NAMSPG(1:1).EQ.'H') THEN CALL CHKSYM(LSPGRP,NsymAll,NSPFFT,RSYM,LSG,MSG) ELSE CALL CHKSYM(LSPGRP,NSYM,NSPFFT,RSYM,LSG,MSG) END IF C CALL MSYGET(24,NSPFFT,NSMFFT,RSMFFT) C CALL PGDEFN(PGNFFT,JSYM,NSMFFT,RSMFFT,.TRUE.) CALL PGNLAU(PGNFFT,NLAFFT,LAUNAM) C C -- Not a patterson IF (ISQ.GT.0) THEN C These pattersons can be set. No others.. C fft10 has a bug - disable it altogether.. C IF(NLAFFT.EQ.4) NSPFFT = 10 IF(NLAFFT.EQ.4) NSPFFT = 2 IF(NLAFFT.EQ.6) NSPFFT = 47 C -- Set to P1 (from P1bar) because permution of axes permitted IF(NLAFFT.EQ.3) NSPFFT = 1 IF(NSPFFT.LE.0) + CALL CCPERR(1,' Please set FFTSPG for Patterson') C Get FFTSG symmetry matrices from reset SG C the translation parts will be set back to 0.0 later CALL MSYGET(24, NSPFFT, NSMFFT, RSMFFT) END IF 1370 CONTINUE END IF C C Reset default axis order to Y X Z for any space group above C monoclinic class IF (NSPFFT.EQ.1 .AND. LSPGRP.GE.19 .AND. .NOT.LAXIS) THEN MP(1) = 2 MP(2) = 1 MP(3) = 3 END IF C C---- Get inverse for symmetry - leave RSMFFT(4,??) as the real vector C DO 1430 N = 1,NSMFFT C C ********************************* CALL INVSYM(RSMFFT(1,1,N),RSMINV(1,1)) C ********************************* C DO 1420 II = 1,3 DO 1410 JJ = 1,3 RSMFFT(II,JJ,N) = RSMINV(II,JJ) 1410 CONTINUE 1420 CONTINUE 1430 CONTINUE C C---- if vol not set AND TYPE = -1 work it out C C ******************** CALL LRCELL(IFIL,CELL) C **************************************** C---- Actual column types returned from LRASSN in program order C C---- Get actual column types (& labels) in file order CALL LRASSN(IFIL,LSPRGI,NLPRGI,LOOKUP,CTPRGI) CALL LRCLAB(IFIL,CDUMMY,CTPRGI,NCOLS) C **************************************** C---- Get dataset info using LRIDX: C Notify available space NDATASETS = MaxSets CALL LRIDX(IFIL,PNAME,XNAME,DNAME,ISETS, + DATCELL,DATWAVE,NDATASETS) C C---- We can only check the datasets if there is dataset C information in the mtz file C IF (NDATASETS.GT.0) THEN C C---- Get the complete list of labels and types and the C datasets to which they belong C C C **************************************** CALL LRCLID(IFIL,CSETID,NCOLS) C **************************************** SET_INDEX = 0 SETID = 0 C Must either have F1 or DANO or I set IF(LOOKUP(6).GT.0) SETID = CSETID(LOOKUP(6)) IF(LOOKUP(14).GT.0) SETID = CSETID(LOOKUP(14)) IF(LOOKUP(18).GT.0) SETID = CSETID(LOOKUP(18)) DO ISET = 1,NDATASETS IF (ISETS(ISET).EQ.SETID) THEN SET_INDEX = ISET END IF ENDDO C Set output dataset and correct choice of cell IF (SET_INDEX.GT.0) THEN DO I=1,6 CELL(I) = DATCELL(I,SET_INDEX) ENDDO write(6,'(a,6f8.2)')' Map cell is set to:',cell ENDIF END IF CALL RBFRO1(CELL,VOL,RR) C ******************** C IF (V.EQ.0.0) V = VOL C C---- Set up resolution limits if not set C IF (RMIN.LT.0.0) THEN C C ********************** CALL LRRSOL(IFIL,SMIN,SMAX) C ********************** C RMIN = 10000 RMAX = 0.5 IF (SMIN.GT.0.0) RMIN = 1.0/SQRT(SMIN) IF (SMAX.GT.0.0) RMAX = 1.0/SQRT(SMAX) C C---- If resolution limit taken from file, C set index limits == limits from file, unless explicitly set C IF (HMAX .LT. 0) $ HMAX = INT(MAX(-CRANGE(1,1),CRANGE(2,1),CELL(1)/RMAX)) IF (KMAX .LT. 0) $ KMAX = INT(MAX(-CRANGE(1,2),CRANGE(2,2),CELL(2)/RMAX)) IF (LMAX .LT. 0) $ LMAX = INT(MAX(-CRANGE(1,3),CRANGE(2,3),CELL(3)/RMAX)) ELSE C . . otherwise set them from resolution command IF (HMAX .LT. 0) $ HMAX = INT(CELL(1)/RMAX) IF (KMAX .LT. 0) $ KMAX = INT(CELL(2)/RMAX) IF (LMAX .LT. 0) $ LMAX = INT(CELL(3)/RMAX) END IF C IERR = -1 C C C C C------ Set up lookup pointers, & check column types C C Count assignments other than A, B C NCHK = 0 C DO 1440 I = 6,NLPRGI NCHK = LOOKUP(I) + NCHK 1440 CONTINUE C IF (LOOKUP(4).NE.0) NNA = LOOKUP(4) IF (LOOKUP(5).NE.0) NNB = LOOKUP(5) C IF (NNA.EQ.0) THEN IF (NNB.NE.0) THEN C C---- Can't have B without A C GO TO 1450 ELSE IF (NCHK.EQ.0) THEN C C---- If not A&B must have something else assigned C GO TO 1450 END IF ELSE C C---- A is assigned, must have B as well C IF (NNB.EQ.0) THEN GO TO 1450 ELSE C C---- Both A & B, check types, should both be real C IF (CTPRGI(NNA).NE.'R' .OR. CTPRGI(NNB).NE.'R') THEN WRITE (ISYSW,FMT='(A)') + ' ** Columns A & B must both be of type R **' KE = KE + 1 END IF END IF END IF C Pregenerated patterson terms IF (LOOKUP(18) .NE.0) THEN ISQ = -1 NI1 = LOOKUP(18) IF (CTPRGI(NI1).NE.'J') THEN WRITE (ISYSW,FMT='(A)') + ' ** Column I must be of type J **' KE = KE + 1 END IF IF (NI1.NE.0) THEN IF(LOOKUP(4).NE.0 .OR.LOOKUP(6) .NE.0 .OR.LOOKUP(14).NE.0)THEN WRITE (ISYSW,FMT='(A)') + ' ** Column I set; none of F or A or DANO allowed **' KE = KE + 1 END IF END IF IF(LOOKUP(19).NE.0) THEN NS1=LOOKUP(19) C---- SIG column can be of any type, but print warning if not Q, L or M C IF (CTPRGI(NS1).NE.'Q' .AND. CTPRGI(NS1).NE.'L'.AND. + CTPRGI(NS1).NE.'M') THEN WRITE (ISYSW,FMT='(A)') + ' ** WARNING ** column SIG1 is not of type Q, L or M' END IF END IF IF (SIG1.GT.0.0 .AND. LOOKUP(19).EQ.0) + CALL CCPERR(1,' EXCLUDE on SIG1 requested but SIG1 unassigned') END IF C IF (LOOKUP(6).NE.0) THEN NF1 = LOOKUP(6) IF (CTPRGI(NF1).NE.'F' .AND. CTPRGI(NF1).NE.'J'.AND. + CTPRGI(NF1).NE.'D' .AND. CTPRGI(NF1).NE.'G'.AND. + CTPRGI(NF1).NE.'K' .AND. CTPRGI(NF1).NE.'E') THEN WRITE (ISYSW,FMT='(A)') + ' ** Column F1 must be of type F or J or D or G or K or E **' KE = KE + 1 END IF IF (SIG1.GT.0.0 .AND. LOOKUP(7).EQ.0) + CALL CCPERR(1,' EXCLUDE on SIG1 requested but SIG1 unassigned') END IF C IF (LOOKUP(7).NE.0) THEN NS1 = LOOKUP(7) C C---- SIG column can be of any type, but print warning if not Q, L or M C IF (CTPRGI(NS1).NE.'Q' .AND. CTPRGI(NS1).NE.'L'.AND. + CTPRGI(NS1).NE.'M') THEN WRITE (ISYSW,FMT='(A)') + ' ** WARNING ** column SIG1 is not of type Q, L or M' END IF END IF C IF (LOOKUP(8).NE.0) THEN NP = LOOKUP(8) IF (CTPRGI(NP).NE.'P') THEN WRITE (ISYSW,FMT='(A)') ' ** Column PHI must be of type P **' KE = KE + 1 END IF IF (ISQ.EQ.1) THEN NP = 0 WRITE (ISYSW,FMT='(A)') + ' ** Note: No PHI used for a Patterson map **' END IF END IF C IF (LOOKUP(9).NE.0) THEN NF2 = LOOKUP(9) IF (CTPRGI(NF2).NE.'F' .AND. CTPRGI(NF2).NE.'J' .AND. + CTPRGI(NF2).NE.'D' .AND. CTPRGI(NF2).NE.'G' .AND. + CTPRGI(NF2).NE.'K' .AND. CTPRGI(NF2).NE.'E') THEN WRITE (ISYSW,FMT='(A)') + ' ** Column F2 must be of type F or J or D or G or K or E **' KE = KE + 1 END IF IF (SIG2.GT.0.0 .AND. LOOKUP(10).EQ.0) + CALL CCPERR(1,' EXCLUDE on SIG2 requested but SIG2 unassigned') END IF C IF (LOOKUP(10).NE.0) THEN NS2 = LOOKUP(10) C C---- SIG column can be of any type, but print warning if not Q, L or M C IF (CTPRGI(NS2).NE.'Q' .AND.CTPRGI(NS2).NE.'L' .AND. + CTPRGI(NS2).NE.'M') THEN WRITE (ISYSW,FMT='(A)') + ' ** WARNING ** column SIG2 is not of type Q, L or M' END IF END IF C IF (LOOKUP(11).NE.0) THEN NH = LOOKUP(11) IF (CTPRGI(NH).NE.'F') THEN WRITE (ISYSW,FMT='(A)') ' ** Column FH must be of type F **' KE = KE + 1 END IF END IF C IF (LOOKUP(12).NE.0) THEN NPH = LOOKUP(12) IF (CTPRGI(NPH).NE.'P') THEN WRITE (ISYSW,FMT='(A)') ' ** Column PHIH must be of type P **' KE = KE + 1 END IF END IF C IF (LOOKUP(13).NE.0) THEN NW = LOOKUP(13) IW = 1 IF (CTPRGI(NW).NE.'W') THEN WRITE (ISYSW,FMT='(A)') ' ** Column W must be of type W **' KE = KE + 1 END IF END IF C C Weight will be multiplied by FREE flag (1 or 0) to exclude reflections. NUM_FREE_COLUMN = 0 IF (LOOKUP(17).NE.0) THEN NUM_FREE_COLUMN = LOOKUP(17) USEFREE = .TRUE. END IF IF (NUM_FREE_COLUMN .eq. 0) + Write(ISYSW,*)' FREE column NOT assigned' C IF (LOOKUP(14).NE.0) THEN NANOM = LOOKUP(14) IF (CTPRGI(NANOM).NE.'D') THEN WRITE (ISYSW,FMT='(A)') ' ** Column DANO must be of type D **' KE = KE + 1 END IF END IF C IF (LOOKUP(15).NE.0) THEN NW2 = LOOKUP(15) IF (CTPRGI(NW2).NE.'W') THEN WRITE (ISYSW,FMT='(A)') ' ** Column W2 must be of type W **' KE = KE + 1 END IF END IF C IF (LOOKUP(16).NE.0) THEN NP2 = LOOKUP(16) IF (CTPRGI(NP2).NE.'P') THEN WRITE (ISYSW,FMT='(A)') ' ** Column PHI2 must be of type P **' KE = KE + 1 END IF END IF C IF (NANOM.NE.0) THEN C C---- Anomalous difference Fourier (DANO) C Set column number for F1 C Flag NANOM used later to retard phase by 90 degrees C NF1 = NANOM LSUSRJ(6) = LSUSRJ(14) END IF C C---- Set flag for previously prepared A & B parts C IF (NNA.GT.0) NF1 = -1 C C C---- Check whether "fillin " option is sensible. C IF(ABS(ISQ).EQ.1 .OR. NF2.EQ.0) USEFILL = .FALSE. IF(USEFILL) THEN WRITE (ISYSW,'(a,/,a,a,/,a,/,a)') + '*****************************************', + ' Coefficients used for Fourier calculation will have ', + 'missing data replaced:', + ' ie: If F1 is missing, then (SC1 -SC2)* F2 replaces it.', + ' NB - ONLY to be used for (n+1)*F1 - n*F2 type maps', + '*****************************************' IF(ABS(SCLF1-SCLF2-1.0).GT.0.1 .OR. + ABS(SCLF1-SCLF2).LT.0.9) WRITE (ISYSW,'(//,a,/,a,/,a,//)') + '*****************************************', + ' BEWARE - Scales seem strange for a FILLIN procedure ', + '*****************************************' END IF C--- Print the type of Fourier coefficients to be used C C---- Rare cases first C IF (IPHTR.NE.0) THEN C C---- Phased translation function C IF(IPHTR.GT.0) THEN WRITE (ISYSW,FMT=6006) + 'Phased translation function: W * F1 * F2 exp (i (PHI - PHI2))' ELSE WRITE (ISYSW,FMT=6006) + 'Phased translation function on other hand: ', + 'W * F1 * F2 exp (i (PHI + PHI2mod))' ENDIF 6006 FORMAT (//' Coefficients used for Fourier calculation:-',/' **', + '*****************************************',//1X,2A,/) ELSE IF (NNA.NE.0) THEN WRITE (ISYSW,FMT=6006) 'Fourier coefficients A & B' ELSE IF (NANOM.NE.0) THEN C C---- Anomalous Fourier C WRITE (ISYSW,FMT=6006) + 'Anomalous Fourier: DANO exp (i (PHI - 90))' ELSE IF (NH.NE.0) THEN C C---- Double difference Fourier C WRITE (ISYSW,FMT=6006) LINE = 'Double difference Fourier: ' IF (NW.NE.0) CALL APPNDS(LINE,' W * ') C C ****************************************************** CALL APPNDS(LINE, + ' (k1 * F1 - k2 * | F2exp(i PHI2) + FHexp(i PHIH)|)' + //' exp (i AlphaPH))') C ****************************************************** C WRITE (ISYSW,FMT=6008) LINE(1:LENSTR(LINE)) 6008 FORMAT (1X,A,/) ELSE IF (NP2.NE.0) THEN C C---- Vector difference C WRITE (ISYSW,FMT=6006) LINE = 'Vector difference: ' C IF (NW.NE.0 .AND. NW2.EQ.0) THEN CALL APPNDS(LINE,' W * (') ELSE IF (NW.NE.0) THEN CALL APPNDS(LINE,'( W * ') ELSE CALL APPNDS(LINE,' ( ') END IF CALL APPNDS(LINE,' k1 * F1 exp(i PHI) - ') IF (NW2.NE.0) CALL APPNDS(LINE,'W2 * ') CALL APPNDS(LINE,' k2 * F2 exp(i PHI2))') WRITE (ISYSW,FMT=6008) LINE(1:LENSTR(LINE)) ELSE C C---- Usual options C WRITE (ISYSW,FMT=6006) IF (ISQ.NE.0) THEN LINE = 'Patterson synthesis: ' ELSE LINE = 'Fourier synthesis: ' END IF C IF (NW.NE.0 .AND. NW2.EQ.0) THEN CALL APPNDS(LINE,' W * (') ELSE IF (NW.NE.0) THEN CALL APPNDS(LINE,' (W * ') ELSE CALL APPNDS(LINE,' ( ') END IF C IF(NI1.NE.0)CALL APPNDS(LINE,' k1 * I ') C IF(NF1.NE.0)CALL APPNDS(LINE,' k1 * F1 ') C IF (NF2.NE.0) THEN CALL APPNDS(LINE,' -') IF (NW2.NE.0) CALL APPNDS(LINE,' W2 * ') CALL APPNDS(LINE,' k2 * F2)') ELSE CALL APPNDS(LINE,')') END IF C IF (ISQ.NE.0) THEN CALL APPNDS(LINE,'**2') ELSE CALL APPNDS(LINE,' exp( i PHI)') END IF WRITE (ISYSW,FMT=6008) LINE(1:LENSTR(LINE)) END IF C C---- Echo column labels C IF (NF1.GT.0) THEN LINE = ' F1 = '//LSUSRJ(6) IF (NS1.NE.0) CALL APPNDS(LINE, + ' checked by SIG1 = '//LSUSRJ(7)) WRITE (ISYSW,FMT='(1x,a)') LINE(1:LENSTR(LINE)) END IF C IF (NF2.GT.0) THEN LINE = ' F2 = '//LSUSRJ(9) IF (NS2.NE.0) CALL APPNDS(LINE, + ' checked by SIG2 = '//LSUSRJ(10)) WRITE (ISYSW,FMT='(1x,a)') LINE(1:LENSTR(LINE)) END IF C IF (NP.NE.0) WRITE (ISYSW,FMT='(1x,a)') ' PHI = '//LSUSRJ(8) IF (NW.NE.0) WRITE (ISYSW,FMT='(1x,a)') ' W = '//LSUSRJ(13) IF (NW2.NE.0) WRITE (ISYSW,FMT='(1x,a)') ' W2 = '//LSUSRJ(15) IF (NP2.NE.0) WRITE (ISYSW,FMT='(1x,a)') ' PHI2 = '//LSUSRJ(16) IF (NH.NE.0) WRITE (ISYSW,FMT='(1x,a)') ' FH = '//LSUSRJ(11) IF (NPH.NE.0) WRITE (ISYSW,FMT='(1x,a)') ' PHIH = '//LSUSRJ(12) IF (NANOM.NE.0) WRITE (ISYSW,FMT='(1x,a)') ' DANO = '// + LSUSRJ(14) C WRITE (ISYSW,FMT='(/)') C C---- Before going further, stop if any detected errors so far C IF (KE.GT.0) THEN CALL CCPERR(1,' **** Fatal error in input cards ****') END IF C RETURN C C---- Error in input C C ******************************************************* 1450 CALL CCPERR(1, $ 'A & B parts must either be both given,'// + 'or neither, & may not be combined with other items') C ******************************************************* C END C C C ============================ SUBROUTINE SEPEVN(X,N,SETUP) C ============================ C C---- initializations. C C .. Scalar Arguments .. INTEGER N LOGICAL SETUP C .. C .. Array Arguments .. REAL X(N) C .. C .. Local Scalars .. REAL A,B,C INTEGER K,KM,M,M1,NY C .. C .. Save statement .. SAVE C .. IF (.NOT.SETUP) THEN NY = N - 2 M = NY/2 M1 = M + 1 END IF C C---- transport y=0 result to y=1 . C X(NY+1) = X(1) C C---- unscramble the results in place 1 C C---- first saves . C KM = M + 1 B = X(KM) C = X(KM+1) C C---- unscrambling for generic elements . C DO 10 K = 1,M KM = KM + 1 A = X(K) X(K) = (A+B)*0.5 X(KM) = (A-B)*0.5 B = C C = X(KM+1) 10 CONTINUE C C---- last elements . C A = X(M1) X(M1) = (A+B)*0.5 X(N) = (A-B)*0.5 C END C C C C ============================ SUBROUTINE SEPODD(X,N,SETUP) C ============================ C C---- initializations. C C .. Scalar Arguments .. INTEGER N LOGICAL SETUP C .. C .. Array Arguments .. REAL X(N) C .. C .. Local Scalars .. REAL A,B,C INTEGER K,KM,M,M1,NY C .. C .. Save statement .. SAVE C .. IF (.NOT.SETUP) THEN NY = N - 2 M = NY/2 M1 = M + 1 END IF C C---- transport y=0 result to y=1 . C X(NY+1) = X(1) C C---- unscramble the results in place 1 C C---- first saves . C KM = M + 1 B = X(KM) C = X(KM+1) C C---- unscrambling for generic elements . C DO 10 K = 1,M KM = KM + 1 A = X(K) X(K) = (A-B)*0.5 X(KM) = (A+B)*0.5 B = C C = X(KM+1) 10 CONTINUE C C---- last elements . C A = X(M1) X(M1) = (A-B)*0.5 X(N) = (A+B)*0.5 C END C C ================================== SUBROUTINE SFIIYC(X,N1,N2,N3,R,MM) C ================================== C C Input routine for complex data, for fft programs which C section along y, for body-centred space-groups. C The data is stored in the array X as klh, with odd and even h interlea 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/2+1 for I222 C N2 =LMAX+1 C N3 =P1/2 C R is minimum h for this pass C MM is return = -1 is end of file found with sorted data C C .. Scalar Arguments .. INTEGER MM,N1,N2,N3,R C .. C .. Array Arguments .. COMPLEX X(N1,N2,N3) C .. C .. Scalars in Common .. REAL A,B,SSQ INTEGER H,HMAX,HMIN,ISORT,JPRM1,JPRM2,K,KMAX,KMIN,KP1,L,LMAX,LMIN, + M C .. C .. Local Scalars .. COMPLEX F INTEGER HM,IH,IK,IL,TOTAL,USED C .. C .. Local Arrays .. CHARACTER LHKL(3)*1 C .. C .. External Subroutines .. EXTERNAL CCPERR,GETHKL,GGETF,REWND C .. C .. Intrinsic Functions .. INTRINSIC CMPLX C .. C .. Common blocks .. COMMON /FFTPRM/KP1,JPRM1,JPRM2 COMMON /HKLF/A,B,ISORT,H,K,L,M,SSQ COMMON /HKLLIM/HMAX,KMAX,LMAX,HMIN,KMIN,LMIN C .. C .. Save statement .. SAVE C .. C .. Data statements .. DATA LHKL/'h','k','l'/ C .. C HM = 2*N3 + R - 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 40 TOTAL = 0 USED = 0 MM = 1 GO TO 60 40 CONTINUE C IF (ISORT.NE.0) GO TO 50 IF (MM.LT.0) RETURN GO TO 70 50 CONTINUE C C ***** CALL REWND C ***** C 60 CONTINUE C C ****** CALL GETHKL C ****** C IF (M.LT.0) GO TO 100 TOTAL = TOTAL + M 70 CONTINUE IF (H.GT.HM) GO TO 90 IF (H.GE.R) GO TO 80 IF (R.EQ.HMIN) GO TO 60 IF (ISORT.NE.0) GO TO 60 GO TO 120 80 CONTINUE IF (K.GT.KMAX .OR. L.GT.LMAX) GO TO 60 IF (K.LT.KMIN .OR. L.LT.LMIN) GO TO 130 C C ***** CALL GGETF F = CMPLX(A,B) C ***** C IF (M.LT.0) GO TO 60 USED = USED + 1 IH = (H-R)/2 + 1 IK = K + 1 IF (IK.LE.0) IK = IK + N1 L = L + 1 X(IK,L,IH) = F C Check H=0 L=0 and set both K and -K IF (KMIN.LE.0) THEN IF (H.EQ.0 .AND. L.EQ.1 .AND. K.GT.0) X(N1+1-K,1,IH) = CONJG(F) IF (H.EQ.0 .AND. L.EQ.1 .AND. K.LT.0) X(1-K,1,IH) = CONJG(F) END IF C GO TO 60 90 CONTINUE C IF (ISORT.NE.0) GO TO 60 GO TO 110 100 IF (ISORT.EQ.0) MM = -1 110 CONTINUE WRITE (6,FMT=6000) USED,TOTAL,LHKL(KP1),R,HM 6000 FORMAT (1X,I10,' Structure factors used out of',I6,' on the inpu', + 't file. Limits on ',A1,' are ',2I5) TOTAL = 0 RETURN 120 CONTINUE C WRITE (6,FMT=6002) H,K,L 6002 FORMAT (' Reflection out of Order. HKL = ',3I10) C C *********************** CALL CCPERR(1,'Internal error') C *********************** C 130 CONTINUE C WRITE (6,FMT=6004) H,K,L 6004 FORMAT (' Reflection outside asymmetric unit. hkl =',3I10) C C *********************** CALL CCPERR(1,'Internal error') C *********************** C END C C C C ================================================== SUBROUTINE SFIP92(X,NZD,IHKA,HMINA,HMAXA,KHMIN,MM) C ================================================== C C Stores structure factor data in complex array X C 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 HMINA and HMAXA are the limits on H for this pass C For P41212 h.ge.k with both .ge. 0 , l.ge.0 C C For P3121/P3221 h.ge.k with both .ge. 0 , all l C When h.eq.k then l.ge.0 C C MM is return = -1 if end of file found with sorted data C C .. Scalar Arguments .. INTEGER HMAXA,HMINA,IHKA,KHMIN,MM,NZD C .. C .. Array Arguments .. COMPLEX X(NZD,IHKA) C .. C .. Scalars in Common .. REAL A,B,SSQ INTEGER H,HMAX,HMIN,ISORT,K,KMAX,KMIN,L,LMAX,LMIN,M,NX,NY,NZ C .. C .. Arrays in Common .. INTEGER JMPHDR C .. C .. Local Scalars .. COMPLEX F INTEGER IL,KH,L1,TOTAL,USED C .. C .. External Subroutines .. EXTERNAL CCPERR,GETHKL,GGETF,REWND C .. C .. Intrinsic Functions .. INTRINSIC CMPLX C .. C .. Common blocks .. COMMON /HKLF/A,B,ISORT,H,K,L,M,SSQ COMMON /HKLLIM/HMAX,KMAX,LMAX,HMIN,KMIN,LMIN COMMON /MPHDR/NX,NY,NZ,JMPHDR(25) C .. C .. Save statement .. SAVE C .. KMAX = HMAX C DO 20 KH = 1,IHKA DO 10 IL = 1,NZD X(IL,KH) = CMPLX(0.0,0.0) 10 CONTINUE 20 CONTINUE C C---- If first CALL then zero totals and skip to first reflection C IF (HMINA.LE.0) THEN TOTAL = 0 USED = 0 MM = 1 GO TO 30 END IF C C---- If sorted data then skip to process last reflection read C on previous CALL C IF (ISORT.EQ.0) THEN C C---- Next line redundant?? C IF (MM.LT.0) RETURN GO TO 40 END IF C C ***** CALL REWND C ***** C C---- Start of reflection loop C C ****** 30 CALL GETHKL C ****** C C---- Skip if end of input MTZ file - setting flag if sorted data C 40 IF (M.LT.0) THEN IF (ISORT.EQ.0) MM = -1 GO TO 70 END IF C IF (H.GT.HMAXA) GO TO 60 IF (H.GE.HMINA) GO TO 50 IF (HMINA.EQ.0) GO TO 30 IF (ISORT.NE.0) GO TO 30 GO TO 100 C 50 IF (K.GT.KMAX .OR. L.GT.LMAX) GO TO 30 IF (K.LT.KMIN) GO TO 90 IF (K.GT.H) GO TO 80 IF (LMIN.EQ.0 .AND. L.LT.LMIN) GO TO 90 C TOTAL = TOTAL + M C C ***** CALL GGETF F = CMPLX(A,B) C ***** C C---- Skip to next reflection if reflection not available (F=0??) C IF (M.LT.0) GO TO 30 C USED = USED + 1 C IF (L.LT.0) THEN L1 = NZ + L + 1 ELSE L1 = L + 1 END IF C KH = (H+1)*H/2 + K + 1 - KHMIN X(L1,KH) = F C C---- For P3121/P3221 fill in h,h,-l C (2-fold along h=k) C IF (H.EQ.K .AND. LMIN.NE.0 .AND. L.NE.0) THEN L1 = NZ - L + 1 X(L1,KH) = F END IF C GO TO 30 C 60 IF (ISORT.NE.0) GO TO 30 C 70 WRITE (6,FMT=6000) USED,TOTAL,H,K,L,HMINA,HMAXA 6000 FORMAT (' ',I10,' Structure factors used out of ',I6,' on file. ', + /' Last reflection read ',3I5,' "H" limits:',2I5) C RETURN C C---- Errors C 80 WRITE (6,FMT=6002) H,K,L 6002 FORMAT (' K greater than H ',3I10,//) C C *********************** CALL CCPERR(1,'Fatal error') C *********************** C 90 WRITE (6,FMT=6004) H,K,L 6004 FORMAT (' H, K or L out of bounds. HKL = ',3I5) C C *********************** CALL CCPERR(1,'Fatal error') C *********************** C 100 WRITE (6,FMT=6006) H,K,L,HMINA,HMAXA 6006 FORMAT (' H out of order - resort data',/' Last reflection rea', + 'd ',3I5,/' "H" limits are ',2I5) C C *********************** CALL CCPERR(1,'Fatal error') C *********************** C END C C C C ================================== SUBROUTINE SFIPYC(X,N1,N2,N3,R,MM) 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 =P1 C R is minimum h for this pass C MM is return = -1 is end of file found with sorted data C C .. Scalar Arguments .. INTEGER MM,N1,N2,N3,R C .. C .. Array Arguments .. COMPLEX X(N1,N2,N3) C .. C .. Scalars in Common .. REAL A,B,SSQ INTEGER H,HMAX,HMIN,ISORT,JPRM1,JPRM2,K,KMAX,KMIN,KP1,L,LMAX,LMIN, + M C .. C .. Local Scalars .. COMPLEX F INTEGER HM,IH,IK,IL,TOTAL,USED C .. C .. Local Arrays .. CHARACTER LHKL(3)*1 C .. C .. External Subroutines .. EXTERNAL CCPERR,GETHKL,GGETF,REWND C .. C .. Intrinsic Functions .. INTRINSIC CMPLX,CONJG C .. C .. Common blocks .. COMMON /FFTPRM/KP1,JPRM1,JPRM2 COMMON /HKLF/A,B,ISORT,H,K,L,M,SSQ COMMON /HKLLIM/HMAX,KMAX,LMAX,HMIN,KMIN,LMIN C .. C .. Save statement .. SAVE C .. C .. Data statements .. DATA LHKL/'h','k','l'/ C .. C 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 40 TOTAL = 0 USED = 0 MM = 1 GO TO 60 40 CONTINUE C IF (ISORT.NE.0) GO TO 50 IF (MM.LT.0) RETURN GO TO 70 50 CONTINUE C C ***** CALL REWND C ***** C 60 CONTINUE C C ****** CALL GETHKL C ****** C IF (M.LT.0) GO TO 100 TOTAL = TOTAL + M 70 CONTINUE IF (H.GT.HM) GO TO 90 IF (H.GE.R) GO TO 80 IF (R.EQ.HMIN) GO TO 60 IF (ISORT.NE.0) GO TO 60 GO TO 120 80 CONTINUE IF (K.GT.KMAX .OR. L.GT.LMAX) GO TO 60 IF (K.LT.KMIN .OR. L.LT.LMIN) GO TO 130 C C ***** CALL GGETF F = CMPLX(A,B) C ***** C IF (M.LT.0) GO TO 60 USED = USED + 1 IH = H - R + 1 IK = K + 1 IF (IK.LE.0) IK = IK + N1 L = L + 1 X(IK,L,IH) = F C C---- For space group P1, fill in 0 -k 0 C IF (KMIN.GE.0) GO TO 60 IF (H.EQ.0 .AND. L.EQ.1 .AND. K.GT.0) X(N1+1-K,1,IH) = CONJG(F) IF (H.EQ.0 .AND. L.EQ.1 .AND. K.LT.0) X(1-K,1,IH) = CONJG(F) C IF (H.EQ.0 .AND. L.EQ.1) X(N1+1-K,1,IH) = CONJG(F) GO TO 60 90 CONTINUE C IF (ISORT.NE.0) GO TO 60 GO TO 110 100 IF (ISORT.EQ.0) MM = -1 110 CONTINUE WRITE (6,FMT=6000) USED,TOTAL,LHKL(KP1),R,HM 6000 FORMAT (1X,I10,' Structure factors used out of',I6,' on the inpu', + 't file. Limits on ',A1,' are ',2I5) TOTAL = 0 RETURN 120 CONTINUE C WRITE (6,FMT=6002) H,K,L 6002 FORMAT (' Reflection out of Order. HKL =',3I10) C C *********************** CALL CCPERR(1,'Fatal error') C *********************** C 130 CONTINUE C WRITE (6,FMT=6004) H,K,L 6004 FORMAT (' Reflection outside asymmetric unit. hkl =',3I10) C C *********************** CALL CCPERR(1,'Fatal error') C *********************** C END C C C C ================================== SUBROUTINE SFIPYR(X,N1,N2,N3,R,MM) C ================================== C C Input routine for real data, for fft programs which C section along y. 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+2 for P-1, NY/2 for P2/m, NY for Pmmm C N2 =LMAX+1 C N3 =P1 C R is minimum h for this pass C MM is return = -1 is end of file found with sorted data C C .. Scalar Arguments .. INTEGER MM,N1,N2,N3,R C .. C .. Array Arguments .. REAL X(N1,N2,N3) C .. C .. Scalars in Common .. REAL A,B,SSQ INTEGER H,HMAX,HMIN,ISORT,JPRM1,JPRM2,K,KMAX,KMIN,KP1,L,LMAX,LMIN, + M C .. C .. Local Scalars .. REAL F INTEGER HM,IH,IK,IL,TOTAL,USED C .. C .. Local Arrays .. CHARACTER LHKL(3)*1 C .. C .. External Subroutines .. EXTERNAL CCPERR,GETHKL,GGETF,REWND C .. C .. Intrinsic Functions .. INTRINSIC CMPLX C .. C .. Common blocks .. COMMON /FFTPRM/KP1,JPRM1,JPRM2 COMMON /HKLF/A,B,ISORT,H,K,L,M,SSQ COMMON /HKLLIM/HMAX,KMAX,LMAX,HMIN,KMIN,LMIN C .. C .. Save statement .. SAVE C .. C .. Data statements .. DATA LHKL/'h','k','l'/ C .. C HM = R + N3 - 1 C DO 30 IH = 1,N3 DO 20 IL = 1,N2 DO 10 IK = 1,N1 X(IK,IL,IH) = 0.0 10 CONTINUE 20 CONTINUE 30 CONTINUE C IF (R.NE.HMIN) GO TO 40 TOTAL = 0 USED = 0 MM = 1 GO TO 60 40 CONTINUE C IF (ISORT.NE.0) GO TO 50 IF (MM.LT.0) RETURN GO TO 70 50 CONTINUE C C ***** CALL REWND C ***** C 60 CONTINUE C C ****** CALL GETHKL C ****** C IF (M.LT.0) GO TO 100 TOTAL = TOTAL + M 70 CONTINUE IF (H.GT.HM) GO TO 90 IF (H.GE.R) GO TO 80 IF (R.EQ.HMIN) GO TO 60 IF (ISORT.NE.0) GO TO 60 GO TO 120 80 CONTINUE IF (K.GT.KMAX .OR. L.GT.LMAX) GO TO 60 IF (K.LT.KMIN .OR. L.LT.LMIN) GO TO 130 C C ***** CALL GGETF C ***** C Assume real F is in A part F = A C IF (M.LT.0) GO TO 60 USED = USED + 1 IH = H - R + 1 IK = K + 1 IF (IK.LE.0) IK = IK + N1 - 2 L = L + 1 X(IK,L,IH) = F C C---- For space group P1, fill in 0 -k 0 C IF (KMIN.GE.0) GO TO 60 IF (H.EQ.0 .AND. L.EQ.1) X(N1-IK,1,IH) = F GO TO 60 90 CONTINUE C IF (ISORT.NE.0) GO TO 60 GO TO 110 100 IF (ISORT.EQ.0) MM = -1 110 CONTINUE WRITE (6,FMT=6000) USED,TOTAL,LHKL(KP1),R,HM 6000 FORMAT (1X,I10,' Structure factors used out of',I6,' on the inpu', + 't file. Limits on ',A1,' are ',2I5) TOTAL = 0 RETURN 120 CONTINUE C WRITE (6,FMT=6002) H,K,L 6002 FORMAT (' Reflection out of order. HKL =',3I10) C C *********************** CALL CCPERR(1,'Fatal error') C *********************** C 130 CONTINUE C WRITE (6,FMT=6004) H,K,L 6004 FORMAT (' Reflection outside asymmetric unit. hkl =',3I10) C C *********************** CALL CCPERR(1,'Fatal error') C *********************** C END C C C C ============================================ SUBROUTINE SFIPZ3(X,N1,N2,N3,HMINA,HMAXA,MM) C ============================================ C C this subroutine reads complex hkl data sorted on h for fourier maps C stacked up z - mod for non primitive r3. ie r3 etc. C C N1=NZOV3, N2=KMAX1, N3=P1 C C Modified to accept unsorted reflection lists, to allow calculation C of R32 maps. A.G.W. Leslie June 1987. C C .. Scalar Arguments .. INTEGER HMAXA,HMINA,MM,N1,N2,N3 C .. C .. Array Arguments .. COMPLEX X(N1,N2,N3) C .. C .. Scalars in Common .. REAL A,B,SSQ INTEGER H,HMAX,HMIN,ISORT,K,KMAX,KMIN,L,LMAX,LMIN,M C .. C .. Local Scalars .. COMPLEX F INTEGER IH,IK,IL,JH,JK,JL,TOTAL,USED LOGICAL SORTED C .. C .. External Subroutines .. EXTERNAL CCPERR,GETHKL,GGETF,REWND C .. C .. Intrinsic Functions .. INTRINSIC CMPLX,CONJG C .. C .. Common blocks .. COMMON /HKLF/A,B,ISORT,H,K,L,M,SSQ COMMON /HKLLIM/HMAX,KMAX,LMAX,HMIN,KMIN,LMIN C .. C .. Save statement .. SAVE C .. SORTED = (ISORT.EQ.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 C---- On first CALL,initialise sums C IF (HMINA.EQ.HMIN) THEN TOTAL = 0 USED = 0 MM = 1 GO TO 40 END IF C C---- If sorted, deal with reflection read on last CALL to this S/R, C otherwise rewind file and start again C IF (SORTED) THEN IF (MM.LT.0) RETURN GO TO 50 ELSE C C ***** CALL REWND C ***** C END IF C C---- Get next reflection C C ****** 40 CALL GETHKL C ****** C C---- save h,k,l needed for test later C JH = H JK = K JL = L C C---- GETHKL returns M=-1 if EOF C IF (M.LT.0) THEN IF (SORTED) MM = -1 GO TO 70 END IF C TOTAL = TOTAL + M C 50 IF (H.GT.HMAXA) THEN IF (SORTED) THEN GO TO 70 ELSE GO TO 40 END IF END IF C IF (H.GE.HMINA) GO TO 60 C IF (SORTED) THEN GO TO 80 ELSE GO TO 40 END IF C 60 IF (K.GT.KMAX .OR. L.GT.LMAX .OR. K.LT.KMIN .OR. + L.LT.LMIN) GO TO 40 C C ***** CALL GGETF F = CMPLX(A,B) C ***** C IF (M.LT.0) GO TO 40 USED = USED + 1 H = H - HMINA + 1 C C---- for R3 divide l by 3 - we will unscramble the mess later C L = (L+3000)/3 - 1000 L = L + 1 K = K + 1 IF (L.LE.0) L = L + N1 C IF (L.GT.N1 .OR. K.GT.N2 .OR. H.GT.N3 .OR. L.LT.1 .OR. K.LT.1 .OR. + H.LT.1) THEN WRITE (6,FMT=6000) JH,JK,JL 6000 FORMAT (//1X,'*** FATAL ERROR ***',/1X,'REFLECTION',3I5,' OUT ', + 'OF LIMITS') C C *********************** CALL CCPERR(1,'Fatal error') C *********************** C END IF C X(L,K,H) = F IF (JK.EQ.0 .AND. JH.EQ.0 .AND. JL.GT.0 .AND. L.GT.1 .AND. + LMIN.LT.0) X(N1+2-L,K,H) = CONJG(X(L,K,H)) GO TO 40 C C---- End of this block on H C 70 WRITE (6,FMT=6002) USED,TOTAL 6002 FORMAT (' ',I10,' Structure Factors used out of ',I6,' on file') RETURN 80 WRITE (6,FMT=6004) 6004 FORMAT (//1X,'*** FATAL ERROR, REFLECTION OUT OF ORDER ***',/1X, + 'IS THE DATA REALLY SORTED ??') C C ********************** CALL CCPERR(1,'Fatal error') C ********************** C END C C C C ================================== SUBROUTINE SFIPZC(X,N1,N2,N3,R,MM) C ================================== C C Input routine for complex data, for fft programs which C section along Z. The data is stored in the array X as lkh 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 = NZ/2+1 for P212121 , NZ for P31 C N2 = KMAX+1 C N3 =P1 C R is minimum h for this pass C MM is return = -1 is end of file found with sorted data C C .. Scalar Arguments .. INTEGER MM,N1,N2,N3,R C .. C .. Array Arguments .. COMPLEX X(N1,N2,N3) C .. C .. Scalars in Common .. REAL A,B,SSQ INTEGER H,HMAX,HMIN,ISORT,JPRM1,JPRM2,K,KMAX,KMIN,KP1,L,LMAX,LMIN, + M C .. C .. Local Scalars .. COMPLEX F INTEGER HM,IH,IK,IL,TOTAL,USED C .. C .. Local Arrays .. CHARACTER LHKL(3)*1 C .. C .. External Subroutines .. EXTERNAL CCPERR,GETHKL,GGETF,REWND C .. C .. Intrinsic Functions .. INTRINSIC CMPLX,CONJG C .. C .. Common blocks .. COMMON /FFTPRM/KP1,JPRM1,JPRM2 COMMON /HKLF/A,B,ISORT,H,K,L,M,SSQ COMMON /HKLLIM/HMAX,KMAX,LMAX,HMIN,KMIN,LMIN C .. C .. Save statement .. SAVE C .. C .. Data statements .. DATA LHKL/'h','k','l'/ C .. C 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 40 TOTAL = 0 USED = 0 MM = 1 GO TO 60 40 CONTINUE C IF (ISORT.NE.0) GO TO 50 IF (MM.LT.0) RETURN GO TO 70 50 CONTINUE C C ***** CALL REWND C ***** C 60 CONTINUE C C ****** CALL GETHKL C ****** C IF (M.LT.0) GO TO 100 TOTAL = TOTAL + M 70 CONTINUE IF (H.GT.HM) GO TO 90 IF (H.GE.R) GO TO 80 IF (R.EQ.HMIN) GO TO 60 IF (ISORT.NE.0) GO TO 60 GO TO 120 80 CONTINUE IF (K.GT.KMAX .OR. L.GT.LMAX) GO TO 60 IF (K.LT.KMIN .OR. L.LT.LMIN) GO TO 130 C C ***** CALL GGETF F = CMPLX(A,B) C ***** C IF (M.LT.0) GO TO 60 USED = USED + 1 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 space group P31 etc, fill in 0 0 -l C IF (LMIN.GE.0) GO TO 60 IF (H.EQ.0 .AND. K.EQ.0) X(N1+1-L,1,IH) = CONJG(F) GO TO 60 90 CONTINUE C IF (ISORT.NE.0) GO TO 60 GO TO 110 100 IF (ISORT.EQ.0) MM = -1 110 CONTINUE WRITE (6,FMT=6000) USED,TOTAL,LHKL(KP1),R,HM 6000 FORMAT (1X,I10,' Structure factors used out of',I6,' on the inpu', + 't file. Limits on ',A1,' are ',2I5) TOTAL = 0 RETURN 120 CONTINUE C WRITE (6,FMT=6002) H,K,L 6002 FORMAT (' Reflection out of order. HKL =',3I10) C C *********************** CALL CCPERR(1,'Fatal error') C *********************** C 130 CONTINUE C WRITE (6,FMT=6004) H,K,L 6004 FORMAT (' Reflection outside asymmetric unit. hkl =',3I10) C C *********************** CALL CCPERR(1,'Fatal error') C *********************** C END C C C C ================================== SUBROUTINE SFIPZR(X,N1,N2,N3,R,MM) C ================================== C C Input routine for real data, for fft programs which C section along Z. The data is stored in the array X as lkh 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 = --- NZ --- C N2 = KMAX+1 C N3 =P1 C R is minimum h for this pass C MM is return = -1 is end of file found with sorted data C C .. Scalar Arguments .. INTEGER MM,N1,N2,N3,R C .. C .. Array Arguments .. REAL X(N1,N2,N3) C .. C .. Scalars in Common .. REAL A,B,SSQ INTEGER H,HMAX,HMIN,ISORT,JPRM1,JPRM2,K,KMAX,KMIN,KP1,L,LMAX,LMIN, + M C .. C .. Local Scalars .. COMPLEX F INTEGER HM,IH,IK,IL,TOTAL,USED C .. C .. Local Arrays .. CHARACTER LHKL(3)*1 C .. C .. External Subroutines .. EXTERNAL CCPERR,GETHKL,GGETF,REWND C .. C .. Intrinsic Functions .. INTRINSIC CMPLX C .. C .. Common blocks .. COMMON /FFTPRM/KP1,JPRM1,JPRM2 COMMON /HKLF/A,B,ISORT,H,K,L,M,SSQ COMMON /HKLLIM/HMAX,KMAX,LMAX,HMIN,KMIN,LMIN C .. C .. Save statement .. SAVE C .. C .. Data statements .. DATA LHKL/'h','k','l'/ C .. C HM = R + N3 - 1 C DO 30 IH = 1,N3 DO 20 IK = 1,N2 DO 10 IL = 1,N1 X(IL,IK,IH) = 0.0 10 CONTINUE 20 CONTINUE 30 CONTINUE C IF (R.NE.HMIN) GO TO 40 TOTAL = 0 USED = 0 MM = 1 GO TO 60 40 CONTINUE C IF (ISORT.NE.0) GO TO 50 IF (MM.LT.0) RETURN GO TO 70 50 CONTINUE C C ***** CALL REWND C ***** C 60 CONTINUE C C ****** CALL GETHKL C ****** C IF (M.LT.0) GO TO 100 TOTAL = TOTAL + M 70 CONTINUE IF (H.GT.HM) GO TO 90 IF (H.GE.R) GO TO 80 IF (R.EQ.HMIN) GO TO 60 IF (ISORT.NE.0) GO TO 60 GO TO 120 80 CONTINUE IF (K.GT.KMAX .OR. L.GT.LMAX) GO TO 60 IF (K.LT.KMIN .OR. L.LT.LMIN) GO TO 130 C C ***** CALL GGETF F = CMPLX(A,B) C ***** C IF (M.LT.0) GO TO 60 USED = USED + 1 IH = H - R + 1 IK = K + 1 IL = L + 1 IF (IL.LE.0) IL = IL + N1 - 2 X(IL,IK,IH) = F C C---- For space group P1, fill in 0 -l 0 C IF (LMIN.GE.0) GO TO 60 IF (IH.EQ.0 .AND. K.EQ.1) X(N1-IL,1,IH) = F GO TO 60 90 CONTINUE C IF (ISORT.NE.0) GO TO 60 GO TO 110 100 IF (ISORT.EQ.0) MM = -1 110 CONTINUE WRITE (6,FMT=6000) USED,TOTAL,LHKL(KP1),R,HM 6000 FORMAT (1X,I10,' Structure factors used out of',I6,' on the inpu', + 't file. Limits on ',A1,' are ',2I5) TOTAL = 0 RETURN 120 CONTINUE C WRITE (6,FMT=6002) H,K,L 6002 FORMAT (' Reflection out of order. HKL =',3I10) C C *********************** CALL CCPERR(1,'Fatal error') C *********************** C 130 CONTINUE C WRITE (6,FMT=6004) H,K,L 6004 FORMAT (' Reflection outside asymmetric unit. hkl =',3I10) C C *********************** CALL CCPERR(1,'Fatal error') C *********************** C END C C C C ============================= SUBROUTINE SHFMAP(X,NZ,NX,NY) C ============================= C C Routine used for spacegroups where the origin has been shifted C by 1/4 in Z C Written by J.Nyborg, Sept. 1986. C C Shift the origin in Z by 1/4 C C .. Scalar Arguments .. INTEGER NX,NY,NZ C .. C .. Array Arguments .. REAL X(NZ,NX,NY) INTEGER MAXZSIZE PARAMETER (MAXZSIZE=600) C .. C .. Local Scalars .. INTEGER I,II,J,K,NZ4,NZ4M1 C .. C .. Local Arrays .. REAL Z(MAXZSIZE) C .. C .. External Subroutines .. EXTERNAL CCPERR C .. C .. Save statement .. SAVE C .. IF (NZ.GT.MAXZSIZE) THEN CALL CCPERR(1,'Array Z too short in routine SHFMAP') ELSE NZ4 = 3*NZ/4 + 1 NZ4M1 = NZ4 - 1 C DO 50 K = 1,NY DO 40 J = 1,NX II = 1 C DO 10 I = NZ4,NZ Z(II) = X(I,J,K) II = II + 1 10 CONTINUE C DO 20 I = 1,NZ4M1 Z(II) = X(I,J,K) II = II + 1 20 CONTINUE C DO 30 I = 1,NZ X(I,J,K) = Z(I) 30 CONTINUE C 40 CONTINUE 50 CONTINUE C END IF C END C C C C ============================= SUBROUTINE TRNP1C(X,NY,NZ,NX) C ============================= C C Routine to transpose intermediate results for C-centered spacegroups C Modified from 'TRNP 1 I' by J.Nyborg, sept. 1986. C C For C-centering the transpose depends only on the parity of h C C .. Scalar Arguments .. INTEGER NX,NY,NZ C .. C .. Array Arguments .. REAL X(NY,NZ,NX) C .. C .. Local Scalars .. INTEGER H,H2,HL,HU,L C .. C .. External Subroutines .. EXTERNAL EXC1LE,TRP1LE C .. C .. Save statement .. SAVE C .. HL = NX/2 H2 = HL + 1 C IF (HL.NE.0) THEN C C---- Generic h-planes . C DO 20 H = 1,HL HU = NX + 1 - H C C---- all l terms . C DO 10 L = 1,NZ C C ***************************** CALL TRP1LE(X(1,L,H),X(1,L,HU),NY) C ***************************** C 10 CONTINUE 20 CONTINUE C END IF C C---- middle h-plane , i f a n y C IF (2*HL.NE.NX) THEN C C---- all l terms . C DO 30 L = 1,NZ C C ******************** CALL EXC1LE(X(1,L,H2),NY) C ******************** C 30 CONTINUE END IF C C---- e n d o f t r a n s p o s i t i o n . C END C C C C ============================= SUBROUTINE TRNP1I(X,NY,NZ,NX) C ============================= C C .. Scalar Arguments .. INTEGER NX,NY,NZ C .. C .. Array Arguments .. REAL X(NY,NZ,NX) C .. C .. Local Scalars .. INTEGER H,H2,HL,HU,L C .. C .. External Subroutines .. EXTERNAL EXC1LE,EXC1LO,TRP1LE,TRP1LO C .. C .. Save statement .. SAVE C .. HL = NX/2 H2 = HL + 1 C IF (HL.NE.0) THEN C C---- Generic h-planes . C DO 30 H = 1,HL HU = NX + 1 - H C C---- l even terms . C DO 10 L = 1,NZ,2 C C ***************************** CALL TRP1LE(X(1,L,H),X(1,L,HU),NY) C ***************************** C 10 CONTINUE C C---- l odd terms . C IF (NZ.GE.2) THEN C DO 20 L = 2,NZ,2 C C ***************************** CALL TRP1LO(X(1,L,H),X(1,L,HU),NY) C ***************************** C 20 CONTINUE END IF 30 CONTINUE C END IF C C---- Middle h-plane , if any C IF (2*HL.NE.NX) THEN C C---- l even terms . C DO 40 L = 1,NZ,2 C C ******************** CALL EXC1LE(X(1,L,H2),NY) C ******************** C 40 CONTINUE C C---- l odd terms . C IF (NZ.GE.2) THEN DO 50 L = 2,NZ,2 C C ******************** CALL EXC1LO(X(1,L,H2),NY) C ******************** C 50 CONTINUE END IF END IF C C---- end of transposition. C END C C C C ============================= SUBROUTINE TRNSP1(X,NY,NZ,NX) C ============================= C C this subroutine transposes intermediate results from -y to -h C for space group p222. C C NY is assumed to be even. C C .. Scalar Arguments .. INTEGER NX,NY,NZ C .. C .. Array Arguments .. REAL X(NY,NZ,NX) C .. C .. Local Scalars .. REAL A INTEGER H,HL,HU,K,KL,KM,KU,L C .. C .. Save statement .. SAVE C .. HL = NX/2 KM = NY/2 KL = KM + 1 C IF (NX.NE.1) THEN C DO 40 H = 1,HL HU = NX + 1 - H C DO 10 L = 1,NZ A = X(1,L,H) X(1,L,H) = X(1,L,HU) X(1,L,HU) = A A = X(KL,L,H) X(KL,L,H) = X(KL,L,HU) X(KL,L,HU) = A 10 CONTINUE C IF (KM.GE.2) THEN C DO 30 K = 2,KM KU = NY + 2 - K C DO 20 L = 1,NZ A = X(K,L,H) X(K,L,H) = X(KU,L,HU) X(KU,L,HU) = A A = X(KU,L,H) X(KU,L,H) = X(K,L,HU) X(K,L,HU) = A 20 CONTINUE 30 CONTINUE END IF 40 CONTINUE END IF C IF (KM.GE.2 .AND. 2*HL.NE.NX) THEN H = NX/2 + 1 C DO 60 K = 2,KM KU = NY + 2 - K C DO 50 L = 1,NZ A = X(K,L,H) X(K,L,H) = X(KU,L,H) X(KU,L,H) = A 50 CONTINUE 60 CONTINUE C END IF C END C C 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 .. Save statement .. SAVE C .. HL = NX/2 LL = NZ/2 C IF (NX.GE.2) THEN M = LL + 1 C DO 40 H = 1,HL HU = NX + 1 - H 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 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 END IF C IF (2*HL.NE.NX) THEN H = NX/2 + 1 C DO 60 K = 1,NY DO 50 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 50 CONTINUE 60 CONTINUE END IF C IF (NY.GE.2) THEN DO 90 H = 1,NX DO 80 K = 2,NY,2 DO 70 L = 1,NZ X(L,K,H) = -X(L,K,H) 70 CONTINUE 80 CONTINUE 90 CONTINUE C END IF C END C C 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) 1 C C adapted from Ten Eyck's TRNSP1 for P222, with an error mended, C by G. Bricogne, may 1976 . 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 .. Save statement .. SAVE C .. HL = NX/2 KM = NY/2 KL = KM + 1 C C---- note : ny, as defined in CALLing program, is odd . C IF (NX.NE.1) THEN 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.GE.1) THEN C DO 30 K = 1,KM KU = NY + 1 - K C 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 END IF 40 CONTINUE C END IF C IF ((KM.GE.1) .AND. (2*HL.NE.NX)) THEN H = HL + 1 H1 = H + R - 1 HEVEN = (H1/2)*2 .EQ. H1 H1ODD = .NOT. HEVEN C DO 60 L = 1,NZ IF (H1ODD) X(KL,L,H) = -X(KL,L,H) C DO 50 K = 1,KM KU = NY + 1 - K A = X(K,L,H) B = X(KU,L,H) C IF (.NOT.HEVEN) THEN A = -A B = -B END IF C X(K,L,H) = B X(KU,L,H) = A 50 CONTINUE 60 CONTINUE END IF C END C C C C ============================= SUBROUTINE TRNSP4(X,NY,NZ,NX) C ============================= C C this subroutine transposes intermediate results for space C group P2221. C C NY is assumed to be even. C C Modified from 'TRNSP1' by J.Nyborg, Sept. 1986. C C The transposition formula is: C Tk(-h,Y,l) = (-1)**l * Tk(h,-Y,l) ; 0<=Y<=1/2 C C .. Scalar Arguments .. INTEGER NX,NY,NZ C .. C .. Array Arguments .. REAL X(NY,NZ,NX) C .. C .. Local Scalars .. REAL A INTEGER H,HL,HU,K,KL,KM,KU,L C .. C .. Save statement .. SAVE C .. HL = NX/2 KM = NY/2 KL = KM + 1 C IF (NX.NE.1) THEN DO 60 H = 1,HL HU = NX + 1 - H C C---- Miller index l even (i.e. FORTRAN index odd) C DO 10 L = 1,NZ,2 A = X(1,L,H) X(1,L,H) = X(1,L,HU) X(1,L,HU) = A A = X(KL,L,H) X(KL,L,H) = X(KL,L,HU) X(KL,L,HU) = A 10 CONTINUE C C---- Miller index l odd (i.e. FORTRAN index even) C DO 20 L = 2,NZ,2 A = X(1,L,H) X(1,L,H) = -X(1,L,HU) X(1,L,HU) = -A A = X(KL,L,H) X(KL,L,H) = -X(KL,L,HU) X(KL,L,HU) = -A 20 CONTINUE C IF (KM.GE.2) THEN DO 50 K = 2,KM KU = NY + 2 - K C C---- Miller index l even (i.e. FORTRAN index odd) C DO 30 L = 1,NZ,2 A = X(K,L,H) X(K,L,H) = X(KU,L,HU) X(KU,L,HU) = A A = X(KU,L,H) X(KU,L,H) = X(K,L,HU) X(K,L,HU) = A 30 CONTINUE C C---- Miller index l odd (i.e. FORTRAN index even) C DO 40 L = 2,NZ,2 A = X(K,L,H) X(K,L,H) = -X(KU,L,HU) X(KU,L,HU) = -A A = X(KU,L,H) X(KU,L,H) = -X(K,L,HU) X(K,L,HU) = -A 40 CONTINUE 50 CONTINUE END IF 60 CONTINUE END IF C IF (KM.GE.2 .AND. 2*HL.NE.NX) THEN H = NX/2 + 1 C DO 90 K = 2,KM KU = NY + 2 - K C C---- Miller index l even (i.e. FORTRAN index odd) C DO 70 L = 1,NZ,2 A = X(K,L,H) X(K,L,H) = X(KU,L,H) X(KU,L,H) = A 70 CONTINUE C C---- Miller index l odd (i.e. FORTRAN index even) C DO 80 L = 2,NZ,2 A = X(K,L,H) X(K,L,H) = -X(KU,L,H) X(KU,L,H) = -A 80 CONTINUE 90 CONTINUE END IF C END C C C C ================================= SUBROUTINE TRNSPR(X,NYH,NL,NH,H0) C ================================= C C Transpose intermediate transform for P21212 C (International tables origin) C C T(-h,y,l) = (-1)**h T*(h,1/2-y,l) C C After transposition, the h index runs in the opposite direction C in the array. C C NYH = NY/2+1 number of points in half cell C H0 minimum h for this slab C C Phil Evans July 1985 C C .. Scalar Arguments .. INTEGER H0,NH,NL,NYH C .. C .. Array Arguments .. COMPLEX X(NYH,NL,NH) C .. C .. Local Scalars .. COMPLEX A INTEGER H,HU,K,KI,KU,L,NH2,NY4,NYL C .. C .. Intrinsic Functions .. INTRINSIC CONJG,MOD C .. C .. Save statement .. SAVE C .. NYL = NYH/2 NY4 = NYL + 1 NH2 = (NH+1)/2 C C---- Loop all l C DO 30 L = 1,NL C C---- Loop h C DO 20 H = 1,NH HU = NH - H + 1 C C---- Loop up to but not including y=1/4 C DO 10 K = 1,NYL KU = NYH - K + 1 C C---- Interchange h,y and -h,1/2-y C A = X(K,L,H) X(K,L,H) = CONJG(X(KU,L,HU)) X(KU,L,HU) = CONJG(A) 10 CONTINUE C C---- Interchange y=1/4 for first half of h only C IF (H.LE.NH2) THEN A = X(NY4,L,H) X(NY4,L,H) = CONJG(X(NY4,L,HU)) X(NY4,L,HU) = CONJG(A) END IF 20 CONTINUE 30 CONTINUE C C---- Negate all elements with h odd C C---- On entry to this routine the real h index runs C from H0 to H0+NH-1 C---- The arrays are now reversed, so the h index runs C from H0+NH-1 to H0 C So test the parity of the 1st array element H=0 C KI = 1 IF (MOD(H0+NH-1,2).EQ.0) KI = 2 C IF (NH.GE.2 .OR. KI.NE.2) THEN DO 60 H = KI,NH,2 DO 50 L = 1,NL DO 40 K = 1,NYH X(K,L,H) = -X(K,L,H) 40 CONTINUE 50 CONTINUE 60 CONTINUE C END IF C END C C C C ========================== SUBROUTINE TRP1LE(X,XU,NY) C ========================== C C .. Scalar Arguments .. INTEGER NY C .. C .. Array Arguments .. REAL X(NY),XU(NY) C .. C .. Local Scalars .. REAL A,B INTEGER K,K2,K2M,KL,KM,KU,KUM,M C .. C .. Save statement .. SAVE C .. M = NY/2 KL = M/2 C IF (KL.NE.0) THEN C C---- Generic Elements . C KM = M KU = M + 1 KUM = KU + M C DO 10 K = 1,KL KM = KM + 1 KU = KU - 1 KUM = KUM - 1 C X(KM) = XU(KU) XU(KM) = X(KU) C X(K) = -XU(KUM) XU(K) = -X(KUM) 10 CONTINUE C END IF C C---- Generic Elements ( Y = 1/4 ) . C K2 = KL + 1 K2M = K2 + M C A = X(K2) B = XU(K2) C X(K2) = -XU(K2M) XU(K2) = -X(K2M) C XU(K2M) = A X(K2M) = B C END C C C C ========================== SUBROUTINE TRP1LO(X,XU,NY) C ========================== C C .. Scalar Arguments .. INTEGER NY C .. C .. Array Arguments .. REAL X(NY),XU(NY) C .. C .. Local Scalars .. REAL A,B INTEGER K,K2,K2M,KL,KM,KU,KUM,M C .. C .. Save statement .. SAVE C .. M = NY/2 KL = M/2 C IF (KL.NE.0) THEN C C---- Generic Elements . C KM = M KU = M + 1 KUM = KU + M C DO 10 K = 1,KL KM = KM + 1 KU = KU - 1 KUM = KUM - 1 X(KM) = -XU(KU) XU(KM) = -X(KU) C X(K) = XU(KUM) XU(K) = X(KUM) 10 CONTINUE C END IF C C---- Middle Elements ( Y = 1/4 ) . C K2 = KL + 1 K2M = K2 + M C A = X(K2) B = XU(K2) C X(K2) = XU(K2M) XU(K2) = X(K2M) C XU(K2M) = -A X(K2M) = -B C END C C C C ============================================================= SUBROUTINE YIN1(X,NZ,NX,NY,HMAX,LMAX,SIZE,SKIP,RECS,TAPE,IREC, + IRMAX,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 is for monoclinic space groups in C which the first transform was along a diad. the intermediate C results are real but not symmetric. the intermediate results are C stored across the rows as even/odd pairs on h so that after C transformation across the rows the real and imaginary parts will C be adjacent. space is left for the unique values at x = 1/2. C C the scratch file t2 is in direct access. C G. Bricogne, april 77. C C .. Scalar Arguments .. INTEGER HMAX,IREC,IRMAX,LMAX,NWORDS,NX,NY,NZ,RECS,SIZE,SKIP,TAPE C .. C .. Array Arguments .. REAL X(NZ,NX,NY) C .. C .. Local Scalars .. INTEGER H,HL,HU,IER,K,L,LM,P,Q,R C .. C .. External Subroutines .. EXTERNAL QREAD,QSEEK C .. C .. Save statement .. SAVE C .. LM = (LMAX+1)*2 P = SIZE/2 R = (HMAX+2)/2 HU = NX - 1 - (HMAX+1)/2 IREC = IREC + SKIP 10 CONTINUE C C---- read data for negative h C IF (HU+P.GT.NX-1) GO TO 50 HL = HU + 1 HU = HU + P IF (IREC.GT.IRMAX) GO TO 160 C C ************************* CALL QSEEK(TAPE,IREC,1,NWORDS) C ************************* C DO 40 L = 1,LM,2 DO 30 K = 1,NY DO 20 H = HL,HU C C ************************** CALL QREAD(TAPE,X(L,H,K),2,IER) C ************************** C 20 CONTINUE 30 CONTINUE 40 CONTINUE C IREC = IREC + RECS + 1 GO TO 10 50 CONTINUE C C---- go pick up record which spans h = 0 if necessary C IF (HU.NE.NX-1) GO TO 110 HU = 0 60 CONTINUE C C---- read records for positive h C HL = HU + 1 HU = HU + P IF (HU.GT.R) HU = R IF (IREC.GT.IRMAX) GO TO 160 C C ************************* CALL QSEEK(TAPE,IREC,1,NWORDS) C ************************* C DO 90 L = 1,LM,2 DO 80 K = 1,NY DO 70 H = HL,HU C C ************************** CALL QREAD(TAPE,X(L,H,K),2,IER) C ************************** C 70 CONTINUE 80 CONTINUE 90 CONTINUE 100 CONTINUE C IF (HU.EQ.R) GO TO 160 IREC = IREC + RECS + 1 GO TO 60 110 CONTINUE C C---- section to read a record spanning h = 0 C Q = NX - 1 HL = HU + 1 HU = HU + P - NX + 1 IF (HU.GT.R) HU = R IF (IREC.GT.IRMAX) GO TO 160 C C ************************* CALL QSEEK(TAPE,IREC,1,NWORDS) C ************************* C DO 150 L = 1,LM,2 DO 140 K = 1,NY DO 120 H = HL,Q C C ************************** CALL QREAD(TAPE,X(L,H,K),2,IER) C ************************** C 120 CONTINUE C DO 130 H = 1,HU C C ************************** CALL QREAD(TAPE,X(L,H,K),2,IER) C ************************** C 130 CONTINUE 140 CONTINUE 150 CONTINUE C GO TO 100 160 CONTINUE C C---- pad the array with zero where there are no data, and fill in the C -h k 0 results by symmetry. C DO 180 H = 2,R HL = H - 1 HU = NX + 1 - H C DO 170 K = 1,NY X(1,HU,K) = X(1,H,K) X(2,HU,K) = X(2,HL,K) 170 CONTINUE 180 CONTINUE C IF ((HMAX/2)*2.EQ.HMAX) GO TO 200 HU = NX - R C DO 190 K = 1,NY X(2,HU,K) = X(2,R,K) 190 CONTINUE C 200 CONTINUE C HL = R + 1 HU = NX - 1 - (HMAX+1)/2 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 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 250 CONTINUE 260 CONTINUE 270 CONTINUE 280 CONTINUE C DO 300 K = 1,NY DO 290 L = 1,LM X(L,NX,K) = 0.0 290 CONTINUE 300 CONTINUE C C---- End of input C RETURN C END C C C C ============================================================= SUBROUTINE YIN2(X,NZ,NX,NY,HMAX,LMAX,SIZE,SKIP,RECS,TAPE,IREC, + IRMAX,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 .. Scalar Arguments .. INTEGER HMAX,IREC,IRMAX,LMAX,NWORDS,NX,NY,NZ,RECS,SIZE,SKIP,TAPE C .. C .. Array Arguments .. COMPLEX X(NZ,NX,NY) 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 .. Save statement .. SAVE 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 IREC = IREC + SKIP 40 CONTINUE C C---- read data for negative h C HL = HU + 1 HU = HU + P IF (HU.GT.NX) GO TO 110 IF (IREC.GT.IRMAX) GO TO 150 C C ************************* CALL QSEEK(TAPE,IREC,1,NWORDS) C ************************* C DO 60 K = 1,NY DO 50 H = HL,HU C C ****************************** CALL QREAD(TAPE,X(1,H,K),2*LM1,IER) C ****************************** C 50 CONTINUE 60 CONTINUE C IREC = IREC + RECS + 1 IF (HU.LT.NX) GO TO 40 C C---- read records for positive h C HU = 0 70 CONTINUE HL = HU + 1 HU = HU + P IF (HU.GT.HMAX) HU = HMAX + 1 IF (IREC.GT.IRMAX) GO TO 150 C C ************************* CALL QSEEK(TAPE,IREC,1,NWORDS) C ************************* C DO 90 K = 1,NY DO 80 H = HL,HU C C ****************************** CALL QREAD(TAPE,X(1,H,K),2*LM1,IER) C ****************************** C 80 CONTINUE 90 CONTINUE C IF (HU.GT.HMAX) GO TO 150 100 CONTINUE IREC = IREC + RECS + 1 GO TO 70 110 CONTINUE C C---- section to read a record spanning h = 0 C HU = HU - NX IF (HU.GT.HMAX) HU = HMAX + 1 IF (IREC.GT.IRMAX) GO TO 150 C C ************************* CALL QSEEK(TAPE,IREC,1,NWORDS) C ************************* C DO 140 K = 1,NY DO 120 H = HL,NX C C ****************************** CALL QREAD(TAPE,X(1,H,K),2*LM1,IER) C ****************************** C 120 CONTINUE C DO 130 H = 1,HU C C ****************************** CALL QREAD(TAPE,X(1,H,K),2*LM1,IER) C ****************************** C 130 CONTINUE 140 CONTINUE C IF (HU.LE.HMAX) GO TO 100 150 CONTINUE C C---- fill in the -h k 0 results by symmetry C DO 170 H = 2,HU HL = NX + 2 - H C DO 160 K = 1,NY X(1,HL,K) = CONJG(X(1,H,K)) 160 CONTINUE 170 CONTINUE C RETURN C END C C C C ============================================================== SUBROUTINE YIN3(X,NZ,NX,NY,HMAX,LMAX,SIZE,SKIP,RECS,TAPE,IREC, + IRMAX,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 intermediate results are stored as even/odd pairs on h so that C after transformation on h the real and imaginary parts will be C adjacent on the columns. space is left for the unique values at C x = 1/2. C C this version of the subroutine is suitable for orthorhombic space C groups in which the transform along y gives real results and the C values for -h,y,l are obtained by conjugate symmetry from the C values for h,-y,l. C C hmax must be odd and size must be even. C C the scratch file is in direct access. C G. Bricogne, april 77. C C---- position the intermediate tape C C .. Scalar Arguments .. INTEGER HMAX,IREC,IRMAX,LMAX,NWORDS,NX,NY,NZ,RECS,SIZE,SKIP,TAPE C .. C .. Array Arguments .. REAL X(NZ,NX,NY) C .. C .. Local Scalars .. INTEGER H,HL,HU,IER,K,L,LM,P,Q,R C .. C .. External Subroutines .. EXTERNAL QREAD,QSEEK C .. C .. Save statement .. SAVE C .. IREC = IREC + SKIP C C---- set up indexing parameters C LM = (LMAX+1)*2 P = SIZE/2 Q = (HMAX+1)/2 R = 0 10 CONTINUE IF (R+P.GT.Q) P = Q - R C C---- read data for positive h C HL = R + 1 HU = R + P C IF (IREC.LE.IRMAX) THEN C C ************************* CALL QSEEK(TAPE,IREC,1,NWORDS) C ************************* C DO 40 L = 1,LM,2 DO 30 K = 1,NY DO 20 H = HL,HU C C ************************** CALL QREAD(TAPE,X(L,H,K),2,IER) C ************************** C 20 CONTINUE 30 CONTINUE 40 CONTINUE C C---- position to associated record for negative h . C IREC = IREC + RECS + 1 C C---- read data for negative h C HL = NX - R - P HU = NX - R - 1 C IF (IREC.LE.IRMAX) THEN C C ************************* CALL QSEEK(TAPE,IREC,1,NWORDS) C ************************* C DO 70 L = 1,LM,2 DO 60 K = 1,NY DO 50 H = HL,HU C C **************************** CALL QREAD(TAPE,X(L+1,H,K),1,IER) CALL QREAD(TAPE,X(L,H+1,K),1,IER) C **************************** C 50 CONTINUE 60 CONTINUE 70 CONTINUE C R = R + P C IF (R.LT.Q) THEN C C---- position to next record for this block of y sections C IREC = IREC + RECS + 1 GO TO 10 ELSE GO TO 90 END IF ELSE GO TO 80 END IF END IF C GO TO 100 80 CONTINUE 90 CONTINUE C C---- fill in the necessary zeroes where there are no data C 100 HL = NX - Q C DO 120 K = 1,NY DO 110 L = 1,LM,2 X(L,HL,K) = 0.0 X(L,NX,K) = 0.0 X(L+1,NX,K) = 0.0 110 CONTINUE 120 CONTINUE C HL = Q + 1 HU = NX - Q - 1 C IF (HL.LE.HU) THEN DO 150 H = HL,HU DO 140 K = 1,NY DO 130 L = 1,LM X(L,H,K) = 0.0 130 CONTINUE 140 CONTINUE 150 CONTINUE END IF C IF (LM.LT.NZ) THEN R = LM + 1 DO 180 H = 1,NX DO 170 K = 1,NY DO 160 L = R,NZ X(L,H,K) = 0.0 160 CONTINUE 170 CONTINUE 180 CONTINUE END IF C END C C C C ============================================================== SUBROUTINE YIN4(X,NZ,NX,NY,HMAX,LMAX,SIZE,SKIP,RECS,TAPE,IREC, + IRMAX,NWORDS) C ============================================================ C C reads complex intermediate results for all h and positive l C this subroutine is designed for programs calculating y sections, C where the results for -h, y, l have been obtained from the results C for +h, +l by symmetry. C C .. Scalar Arguments .. INTEGER HMAX,IREC,IRMAX,LMAX,NWORDS,NX,NY,NZ,RECS,SIZE,SKIP,TAPE C .. C .. Array Arguments .. COMPLEX X(NZ,NX,NY) C .. C .. Local Scalars .. COMPLEX DUMMY INTEGER H,HL,HU,I,IER,J,K,L,NL,P,Q C .. C .. External Subroutines .. EXTERNAL QREAD,QSEEK C .. C .. Intrinsic Functions .. INTRINSIC CMPLX C .. C .. Save statement .. SAVE C .. NL = LMAX + 1 C DO 30 K = 1,NY DO 20 I = 1,NX DO 10 J = 1,NZ X(J,I,K) = CMPLX(0.0,0.0) 10 CONTINUE 20 CONTINUE 30 CONTINUE C IREC = IREC + SKIP C HU = 0 40 CONTINUE C C---- read results for positive h C HL = HU + 1 HU = HU + SIZE IF (HU.GT.HMAX) HU = HMAX + 1 C IF (IREC.GT.IRMAX) THEN GO TO 200 ELSE C C ************************* CALL QSEEK(TAPE,IREC,1,NWORDS) C ************************* C DO 70 K = 1,NY DO 60 L = 1,NL DO 50 H = HL,HU C C ************************** CALL QREAD(TAPE,X(L,H,K),2,IER) C ************************** C 50 CONTINUE 60 CONTINUE 70 CONTINUE C IREC = IREC + RECS + 1 C C---- read results for negative h C P = NX + 2 - HU Q = NX + 2 - HL C IF (Q.LE.NX) THEN IF (IREC.GT.IRMAX) THEN GO TO 200 ELSE C C ************************* CALL QSEEK(TAPE,IREC,1,NWORDS) C ************************* C DO 100 K = 1,NY DO 90 L = 1,NL DO 80 H = P,Q C C ************************** CALL QREAD(TAPE,X(L,H,K),2,IER) C ************************** C 80 CONTINUE 90 CONTINUE 100 CONTINUE C IREC = IREC + 1 END IF ELSE IF (IREC.GT.IRMAX) THEN GO TO 200 ELSE IF (P.LE.NX) THEN C C ************************* CALL QSEEK(TAPE,IREC,1,NWORDS) C ************************* C DO 130 K = 1,NY DO 120 L = 1,NL DO 110 H = P,NX C C ************************** CALL QREAD(TAPE,X(L,H,K),2,IER) C ************************** C 110 CONTINUE C C *********************** CALL QREAD(TAPE,DUMMY,2,IER) C *********************** C 120 CONTINUE 130 CONTINUE END IF C IREC = IREC + 1 END IF C IF (HU.LE.HMAX) THEN IREC = IREC + RECS GO TO 40 END IF END IF C C---- clear out the rest of the array C P = HMAX + 2 Q = NX - HMAX C IF (P.LE.Q) THEN DO 160 H = P,Q DO 150 L = 1,NL DO 140 K = 1,NY X(L,H,K) = CMPLX(0.0,0.0) 140 CONTINUE 150 CONTINUE 160 CONTINUE END IF C IF (NL.LT.NZ) THEN NL = LMAX + 2 DO 190 H = 1,NX DO 180 L = NL,NZ DO 170 K = 1,NY X(L,H,K) = CMPLX(0.0,0.0) 170 CONTINUE 180 CONTINUE 190 CONTINUE END IF C 200 CONTINUE C END C C C C ============================================================== SUBROUTINE YIN5(X,NZ,NX,NY,HMAX,LMAX,SIZE,SKIP,RECS,TAPE,IREC, + IRMAX,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 scratch file is in direct access . C C .. Scalar Arguments .. INTEGER HMAX,IREC,IRMAX,LMAX,NWORDS,NX,NY,NZ,RECS,SIZE,SKIP,TAPE 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 .. Save statement .. SAVE 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 IREC = IREC + SKIP 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 C IF (IREC.LE.IRMAX) THEN C C ************************* CALL QSEEK(TAPE,IREC,1,NWORDS) C ************************* C DO 60 L = 1,LM DO 50 K = 1,NY DO 40 H = HL1,HU1 C C ************************** CALL QREAD(TAPE,X(L,H,K),2,IER) C ************************** C 40 CONTINUE 50 CONTINUE 60 CONTINUE C IREC = IREC + RECS + 1 HU2 = NX HL2 = NX - P + 2 IF (HL2.LT.NXM) HL2 = NXM C IF (IREC.LE.IRMAX) THEN IF (HU2.GE.HL2) THEN C C ************************* CALL QSEEK(TAPE,IREC,1,NWORDS) C ************************* C DO 90 L = 1,LM DO 80 K = 1,NY DO 70 H = HL2,HU2 C C ************************** CALL QREAD(TAPE,X(L,H,K),2,IER) C ************************** C 70 CONTINUE C C *********************** CALL QREAD(TAPE,DUMMY,2,IER) C *********************** C 80 CONTINUE 90 CONTINUE END IF C IREC = IREC + RECS + 1 C IF (HU1.LE.HMAX) THEN 100 CONTINUE C C---- now, read pairs of records for h1gt.0 and h.lt.0 . C HL1 = HU1 + 1 HU1 = HU1 + P IF (HU1.GT.HMAX) HU1 = HMAX + 1 C IF (IREC.GT.IRMAX) THEN GO TO 230 ELSE C C ************************* CALL QSEEK(TAPE,IREC,1,NWORDS) C ************************* C DO 130 L = 1,LM DO 120 K = 1,NY DO 110 H = HL1,HU1 C C ************************** CALL QREAD(TAPE,X(L,H,K),2,IER) C ************************** C 110 CONTINUE 120 CONTINUE 130 CONTINUE C IREC = IREC + RECS + 1 HU2 = HL2 - 1 HL2 = HL2 - P IF (HL2.LT.NXM) HL2 = NXM C IF (IREC.GT.IRMAX) THEN GO TO 230 ELSE C C ************************* CALL QSEEK(TAPE,IREC,1,NWORDS) C ************************* C DO 160 L = 1,LM DO 150 K = 1,NY DO 140 H = HL2,HU2 C C ************************** CALL QREAD(TAPE,X(L,H,K),2,IER) C ************************** C 140 CONTINUE 150 CONTINUE 160 CONTINUE C IF (HU1.LE.HMAX) THEN IREC = IREC + RECS + 1 GO TO 100 END IF END IF END IF END IF C C---- check that original and transposed results have been read C correctly . C IF (HL2.EQ.NXM) THEN C C---- pad array with zeros where there are no data . C HL = HMAX + 2 HU = NX - HMAX C IF (HU.GE.HL) THEN DO 190 L = 1,LM DO 180 K = 1,NY DO 170 H = HL,HU X(L,H,K) = (0.0,0.0) 170 CONTINUE 180 CONTINUE 190 CONTINUE END IF C IF (LM.LT.NZ) THEN P = LM + 1 C DO 220 K = 1,NY DO 210 L = P,NZ DO 200 H = 1,NX X(L,H,K) = (0.0,0.0) 200 CONTINUE 210 CONTINUE 220 CONTINUE END IF C ELSE WRITE (6,FMT=6000) HU1,HL2 6000 FORMAT (///10X,'ERROR : BAD JUSTIFICATION OF SCRATCH RECOR', + 'DS IN YIN5 .',/10X,'HU1 = ',I5,' , HL2 = ',I5) C C *********************** CALL CCPERR(1,'Fatal error') C *********************** C END IF END IF END IF C C---- End of input . C 230 CONTINUE C END C C C C ============================================================ SUBROUTINE YOUT1(X,NY,NZ,NX,SIZE,YMIN,YMAX,TAPE,IREC,NWORDS) C ============================================================ C C this version of the subroutine is for the case in which the first C transform was along a crystallographic diad. the intermediate C results are real. C C the scratch file is in direct access. C G. Bricogne, april 77. C C .. Scalar Arguments .. INTEGER IREC,NWORDS,NX,NY,NZ,SIZE,TAPE,YMAX,YMIN C .. C .. Array Arguments .. REAL X(NY,NZ,NX) C .. C .. Local Scalars .. INTEGER H,K,L,NDIFF,P,Q C .. C .. External Subroutines .. EXTERNAL QWRITE C .. C .. Save statement .. SAVE C .. Q = YMIN 10 CONTINUE IREC = IREC + 1 P = Q + 1 Q = Q + SIZE IF (Q.GT.YMAX) Q = YMAX + 1 C DO 40 L = 1,NZ DO 30 K = P,Q DO 20 H = 1,NX C C *********************** CALL QWRITE(TAPE,X(K,L,H),1) C *********************** C 20 CONTINUE 30 CONTINUE 40 CONTINUE C C---- pad record to nwords words C NDIFF = NWORDS - 2*NX*NZ* (Q-P+1) C C ******************************** IF (NDIFF.GT.0) CALL QWRITE(TAPE,X(1,1,1),NDIFF) C ******************************** C IF (Q.LE.YMAX) GO TO 10 C END C C C C ============================================================ SUBROUTINE YOUT1I(X,NY,NZ,NX,SIZE,YMIN,YMAX,TAPE,IREC,NWORDS) C ============================================================ C C this version of the subroutine is for the case in which the first C transform was along a crystallographic diad of a body-centered C space-group. the intermediate results are real, and stored with C the h even terms in the first half of each column, and the h odd C terms in the second half. C C the scratch file is in direct access. C G. Bricogne, april 77. C C .. Scalar Arguments .. INTEGER IREC,NWORDS,NX,NY,NZ,SIZE,TAPE,YMAX,YMIN C .. C .. Array Arguments .. REAL X(NY,NZ,NX) C .. C .. Local Scalars .. INTEGER H,K,L,M,NDIFF,P,Q C .. C .. External Subroutines .. EXTERNAL QWRITE C .. C .. Save statement .. SAVE C .. M = NY/2 Q = YMIN 10 CONTINUE IREC = IREC + 1 P = Q + 1 Q = Q + SIZE IF (Q.GT.YMAX) Q = YMAX + 1 C DO 40 L = 1,NZ DO 30 K = P,Q DO 20 H = 1,NX C C ************************* CALL QWRITE(TAPE,X(K,L,H),1) CALL QWRITE(TAPE,X(K+M,L,H),1) C ************************* C 20 CONTINUE 30 CONTINUE 40 CONTINUE C C---- pad record to nwords words C NDIFF = NWORDS - 2*NX*NZ* (Q-P+1) C C ******************************** IF (NDIFF.GT.0) CALL QWRITE(TAPE,X(1,1,1),NDIFF) C ******************************** C IF (Q.LE.YMAX) GO TO 10 C END C C C C ============================================================ SUBROUTINE YOUT2(X,NY,NZ,NX,SIZE,YMIN,YMAX,TAPE,IREC,NWORDS) C ============================================================ C C writes y sections for complex intermediate results C C .. Scalar Arguments .. INTEGER IREC,NWORDS,NX,NY,NZ,SIZE,TAPE,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 .. Save statement .. SAVE C .. Q = YMIN 10 CONTINUE IREC = IREC + 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(TAPE,X(K,L,H),2) C *********************** C 20 CONTINUE 30 CONTINUE 40 CONTINUE C C---- pad record to nwords words C NDIFF = NWORDS - 2*NX*NZ* (Q-P+1) C C ******************************** IF (NDIFF.GT.0) CALL QWRITE(TAPE,X(1,1,1),NDIFF) C ******************************** C IF (Q.LE.YMAX) GO TO 10 C END C C C C ============================================================ SUBROUTINE YOUT4(X,NY,NZ,NX,SIZE,YMIN,YMAX,TAPE,IREC,NWORDS) C ============================================================ C C writes complex intermediate results for y sections C C .. Scalar Arguments .. INTEGER IREC,NWORDS,NX,NY,NZ,SIZE,TAPE,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 .. Save statement .. SAVE C .. Q = YMIN 10 CONTINUE IREC = IREC + 1 P = Q + 1 Q = Q + SIZE IF (Q.GT.YMAX) Q = YMAX + 1 C DO 40 K = P,Q DO 30 L = 1,NZ DO 20 H = 1,NX C C *********************** CALL QWRITE(TAPE,X(K,L,H),2) C *********************** C 20 CONTINUE 30 CONTINUE 40 CONTINUE C C---- Pad record to NWORDS words C NDIFF = NWORDS - 2*NX*NZ* (Q-P+1) C C ******************************** IF (NDIFF.GT.0) CALL QWRITE(TAPE,X(1,1,1),NDIFF) C ******************************** C IF (Q.LE.YMAX) GO TO 10 C END C C C C ============================================================ SUBROUTINE YOUT5(X,NY,NZ,NX,SIZE,YMIN,YMAX,TAPE,IREC,NWORDS) C ============================================================ C C writes y sections for complex intermediate results C C .. Scalar Arguments .. INTEGER IREC,NWORDS,NX,NY,NZ,SIZE,TAPE,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 .. Save statement .. SAVE C .. Q = YMIN 10 CONTINUE IREC = IREC + 1 P = Q + 1 Q = Q + SIZE IF (Q.GT.YMAX) Q = YMAX + 1 C DO 40 L = 1,NZ DO 30 K = P,Q DO 20 H = 1,NX C C *********************** CALL QWRITE(TAPE,X(K,L,H),2) C *********************** C 20 CONTINUE 30 CONTINUE 40 CONTINUE C C---- pad record to nwords words C NDIFF = NWORDS - 2*NX*NZ* (Q-P+1) C C ******************************** IF (NDIFF.GT.0) CALL QWRITE(TAPE,X(1,1,1),NDIFF) C ******************************** C IF (Q.LE.YMAX) GO TO 10 C END C C C C ================================================================= SUBROUTINE YOUT92(X,NZ21,IHKA,Y,KMAX1,NX,NZ,HMINA,HMAXA,KHMIN,NOT, + NSPFFT) C ================================================================= C C .. Scalar Arguments .. INTEGER HMAXA,HMINA,IHKA,KHMIN,KMAX1,NOT,NSPFFT,NX,NZ,NZ21 C .. C .. Array Arguments .. COMPLEX X(NZ21,IHKA),Y(KMAX1,NX) C .. C .. Scalars in Common .. INTEGER IXMAX,IXMIN,IYMAX,IYMIN,IZMAX,IZMIN,NUSED,NUSED1,NUSED2 C .. C .. Arrays in Common .. INTEGER JMPHDR C .. C .. Local Scalars .. COMPLEX F REAL ABSX INTEGER IER,IH,IH1,IH2,IH3,IH4,IHMAX1,IHMIN1,IK,IK1,IK2,IK3,IK4, + ISIGN,IX,IY,IZ,IZ1,IZ2,IZ3,IZ4,IZMAX1,IZMIN1,IZSEC,IZZ,KH, + NWORDS,NZ341,NZ41,NZ81 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/NUSED,NUSED1,NUSED2,IXMIN,IXMAX,IYMIN,IYMAX,IZMIN, + IZMAX,JMPHDR(19) C .. C .. Equivalences .. EQUIVALENCE (F,G(1)) C .. C .. Save statement .. SAVE C .. NZ41 = NZ/4 + 1 NZ341 = NZ*3/4 + 1 NZ81 = NZ/8 + 1 IZSEC = IZMAX - IZMIN + 1 IZMIN1 = IZMIN + 1 IZMAX1 = IZMAX + 1 NWORDS = 2*KMAX1*NX C IF (HMINA.LE.0) THEN 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(NOT,1,1,NWORDS) C ********************* C DO 30 IZ = 1,IZSEC C ************************* CALL QWRITE(NOT,Y(1,1),NWORDS) C ************************* C 30 CONTINUE END IF C C ********************* CALL QSEEK(NOT,1,1,NWORDS) C ********************* C DO 60 IZZ = 1,IZSEC IZ = IZZ + IZMIN C C **************************** CALL QREAD(NOT,Y(1,1),NWORDS,IER) C **************************** C IHMIN1 = HMINA + 1 IHMAX1 = HMAXA + 1 C DO 50 IH1 = IHMIN1,IHMAX1 DO 40 IK1 = 1,IH1 IZ1 = IZ IH = IH1 - 1 IK = IK1 - 1 KH = IH*IH1/2 + IK1 - KHMIN C C---- Do not generate equivalents for T(h k z) if abxy=0. (EJD) C ABSX = ABS(X(IZ,KH)) C IF (ABSX.NE.0.0) THEN Y(IK1,IH1) = X(IZ,KH) 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 IH2 = IK + 1 IK2 = IH + 1 IZ2 = NZ21 - IZ + 1 C Y(IH1,IK1) = CONJG(X(IZ2,KH)) C ISIGN = MOD(IH1+IK1,2) C C---- Z LE 1/4 - P41212 T(-H K Z) = T(H K 1/4-Z)*(-1)**(H+K) C Z LE 1/4 - P43212 T(H -K Z) = T(H K 1/4-Z)*(-1)**(H+K) C Z GT 1/4 - P41212 T(H -K Z) = T(H K 3/4-Z)*(-1)**(H+K) C Z GT 1/4 - P43212 T(-H K Z) = T(H K 3/4-Z)*(-1)**(H+K) C C T(-H K Z)=T(H -K Z)TRANSPOSE C IF (IH.NE.0) THEN IH3 = NX - IH + 1 IK3 = IK + 1 C IF (IZ.GT.NZ41) THEN IZ3 = NZ341 - IZ + 1 F = X(IZ3,KH) IF (NSPFFT.EQ.92) F = CONJG(X(IZ3,KH)) ELSE IZ3 = NZ41 - IZ + 1 F = X(IZ3,KH) IF (NSPFFT.NE.92) F = CONJG(X(IZ3,KH)) END IF C IF (ISIGN.NE.0) THEN G(1) = -G(1) G(2) = -G(2) END IF Y(IK1,IH3) = F END IF C IF (IK.NE.0) THEN C C---- Z LE 1/4 - P41212 T(K -H Z)=T(H K 1/4+Z)*(-1)**(H+K) C Z LE 1/4 - P43212 T(-K H Z)=T(H K 1/4+Z)*(-1)**(H+K) C Z GT 1/4 - P41212 T(-K H Z)=T(H K -1/4+Z)*(-1)**(H+K) C Z GT 1/4 - P43212 T(K -H Z)=T(H K -1/4+Z)*(-1)**(H+K) C C T(K -H Z)=CONJG(T(-K H Z)) C IH4 = NX - IK + 1 IK4 = IH + 1 C IF (IZ.GT.NZ41) THEN IZ4 = NZ341 + IZ - 1 - NZ F = X(IZ4,KH) IF (NSPFFT.NE.92) F = CONJG(X(IZ4,KH)) ELSE IZ4 = NZ41 + IZ - 1 F = X(IZ4,KH) IF (NSPFFT.EQ.92) F = CONJG(X(IZ4,KH)) END IF C IF (ISIGN.NE.0) THEN G(1) = -G(1) G(2) = -G(2) END IF C Y(IH1,IH4) = F END IF END IF 40 CONTINUE 50 CONTINUE C C ************************** CALL QSEEK(NOT,IZZ,1,NWORDS) CALL QWRITE(NOT,Y(1,1),NWORDS) C ************************** C 60 CONTINUE C END C C C C ================================================== SUBROUTINE ZIN(X,NY2,NX,P2,KMAX,NZ,T2,IREC,NWORDS) C ================================================== C C .. Scalar Arguments .. INTEGER IREC,KMAX,NWORDS,NX,NY2,NZ,P2,T2 C .. C .. Array Arguments .. COMPLEX X(NY2,NX,P2) 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 .. Save statement .. SAVE C .. KMAX1 = KMAX + 1 NWORDS = 2*KMAX1*NX C DO 30 IX = 1,NX DO 20 IY = 1,NY2 DO 10 IZ = 1,P2 X(IY,IX,IZ) = CMPLX(0.0,0.0) 10 CONTINUE 20 CONTINUE 30 CONTINUE C DO 50 IZ = 1,P2 IREC = IREC + 1 C C *********************** CALL QSEEK(T2,IREC,1,NWORDS) C *********************** C DO 40 IX = 1,NX C C ******************************** CALL QREAD(T2,X(1,IX,IZ),2*KMAX1,IER) C ******************************** C 40 CONTINUE 50 CONTINUE C END C C C C ============================================================== SUBROUTINE ZIN4(X,NY,NX,NZ,HMAX,KMAX,SIZE,SKIP,RECS,TAPE,IREC, + IRMAX,NWORDS) 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 .. Scalar Arguments .. INTEGER HMAX,IREC,IRMAX,KMAX,NWORDS,NX,NY,NZ,RECS,SIZE,SKIP,TAPE C .. C .. Array Arguments .. COMPLEX X(NY,NX,NZ) C .. C .. Local Scalars .. COMPLEX DUMMY INTEGER H,HL,HU,I,IER,J,K,L,NK,P,Q C .. C .. External Subroutines .. EXTERNAL QREAD,QSEEK C .. C .. Intrinsic Functions .. INTRINSIC CMPLX C .. C .. Save statement .. SAVE C .. NK = KMAX + 1 C DO 30 L = 1,NZ DO 20 I = 1,NX DO 10 J = 1,NY X(J,I,L) = CMPLX(0.0,0.0) 10 CONTINUE 20 CONTINUE 30 CONTINUE C IREC = IREC + SKIP C HU = 0 40 CONTINUE C C---- read results for positive h C HL = HU + 1 HU = HU + SIZE IF (HU.GT.HMAX) HU = HMAX + 1 C IF (IREC.GT.IRMAX) THEN GO TO 200 ELSE C C ************************* CALL QSEEK(TAPE,IREC,1,NWORDS) C ************************* C DO 70 L = 1,NZ DO 60 K = 1,NK DO 50 H = HL,HU C C ************************** CALL QREAD(TAPE,X(K,H,L),2,IER) C ************************** C 50 CONTINUE 60 CONTINUE 70 CONTINUE C IREC = IREC + RECS + 1 C C---- read results for negative h C P = NX + 2 - HU Q = NX + 2 - HL C IF (Q.LE.NX) THEN IF (IREC.GT.IRMAX) THEN GO TO 200 ELSE C C ************************* CALL QSEEK(TAPE,IREC,1,NWORDS) C ************************* C DO 100 L = 1,NZ DO 90 K = 1,NK DO 80 H = P,Q C C ************************** CALL QREAD(TAPE,X(K,H,L),2,IER) C ************************** C 80 CONTINUE 90 CONTINUE 100 CONTINUE C IREC = IREC + 1 END IF ELSE IF (IREC.GT.IRMAX) THEN GO TO 200 ELSE IF (P.LE.NX) THEN C C ************************* CALL QSEEK(TAPE,IREC,1,NWORDS) C ************************* C DO 130 L = 1,NZ DO 120 K = 1,NK DO 110 H = P,NX C C ************************** CALL QREAD(TAPE,X(K,H,L),2,IER) C ************************** C 110 CONTINUE C C *********************** CALL QREAD(TAPE,DUMMY,2,IER) C *********************** C 120 CONTINUE 130 CONTINUE END IF IREC = IREC + 1 END IF C IF (HU.LE.HMAX) THEN IREC = IREC + RECS GO TO 40 END IF END IF C C---- clear out the rest of the array C P = HMAX + 2 Q = NX - HMAX C IF (P.LE.Q) THEN DO 160 H = P,Q DO 150 K = 1,NK DO 140 L = 1,NZ X(K,H,L) = CMPLX(0.0,0.0) 140 CONTINUE 150 CONTINUE 160 CONTINUE END IF C IF (NK.LT.NY) THEN NK = KMAX + 2 DO 190 H = 1,NX DO 180 K = NK,NY DO 170 L = 1,NZ X(K,H,L) = CMPLX(0.0,0.0) 170 CONTINUE 180 CONTINUE 190 CONTINUE END IF C 200 CONTINUE C END C C C C =============================================================== SUBROUTINE ZIN47(X,NY,NX,NZ,HMAX,KMAX,SIZE,SKIP,RECS,TAPE,IREC, + IRMAX,NWORDS) C =============================================================== C C .. Scalar Arguments .. INTEGER HMAX,IREC,IRMAX,KMAX,NWORDS,NX,NY,NZ,RECS,SIZE,SKIP,TAPE C .. C .. Array Arguments .. REAL X(NY,NX,NZ) C .. C .. Local Scalars .. INTEGER H,HL,HU,IER,K,L,NK C .. C .. External Subroutines .. EXTERNAL QREAD,QSEEK C .. C .. Save statement .. SAVE C .. DO 30 L = 1,NZ DO 20 H = 1,NX DO 10 K = 1,NY X(K,H,L) = 0.0 10 CONTINUE 20 CONTINUE 30 CONTINUE C NK = KMAX + 1 IREC = IREC + SKIP HU = 0 40 CONTINUE HL = HU + 1 HU = HU + SIZE IF (HU.GT.HMAX) HU = HMAX + 1 C IF (IREC.LE.IRMAX) THEN C C ************************* CALL QSEEK(TAPE,IREC,1,NWORDS) C ************************* C DO 60 L = 1,NZ DO 50 H = HL,HU C C *************************** CALL QREAD(TAPE,X(1,H,L),NK,IER) C *************************** C 50 CONTINUE 60 CONTINUE C IF (HU.LE.HMAX) THEN IREC = IREC + RECS + 1 GO TO 40 ELSE GO TO 70 END IF END IF RETURN C 70 CONTINUE C END C C C C ============================================ SUBROUTINE ZINRL(X,NYOV31,NXOV31,P2,T5,IREC) C ============================================ C C .. Scalar Arguments .. INTEGER IREC,NXOV31,NYOV31,P2,T5 C .. C .. Array Arguments .. REAL X(NYOV31,NXOV31,P2) C .. C .. Local Scalars .. INTEGER IER,IZ,NREC23 C .. C .. External Subroutines .. EXTERNAL QREAD,QSEEK C .. C .. Save statement .. SAVE C .. NREC23 = NXOV31*NYOV31 C DO 10 IZ = 1,P2 IREC = IREC + 1 C C ****************************** CALL QSEEK(T5,IREC,1,NREC23) CALL QREAD(T5,X(1,1,IZ),NREC23,IER) C ****************************** C 10 CONTINUE C END C C C C ============================================================ SUBROUTINE ZOUT2(X,NZ,NY,NX,SIZE,ZMIN,ZMAX,TAPE,IREC,NWORDS) C ============================================================ C C writes complex intermediate results for z sections C C .. Scalar Arguments .. INTEGER IREC,NWORDS,NX,NY,NZ,SIZE,TAPE,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 .. Save statement .. SAVE C .. Q = ZMIN 10 CONTINUE IREC = IREC + 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(TAPE,X(L,K,H),2) C *********************** C 20 CONTINUE 30 CONTINUE 40 CONTINUE C C---- padd record to nwords words C NDIFF = NWORDS - 2*NX*NY* (Q-P+1) C C ******************************** IF (NDIFF.GT.0) CALL QWRITE(TAPE,X(1,1,1),NDIFF) C ******************************** C IF (Q.LE.ZMAX) GO TO 10 C END C C C C ============================================================= SUBROUTINE ZOUT47(X,NY,NZ,NX,SIZE,ZMIN,ZMAX,TAPE,IREC,NWORDS) C ============================================================= C C Write intermediate results for space-group 47 Pmmm C C .. Scalar Arguments .. INTEGER IREC,NWORDS,NX,NY,NZ,SIZE,TAPE,ZMAX,ZMIN C .. C .. Array Arguments .. REAL X(NY,NZ,NX) C .. C .. Local Scalars .. INTEGER H,L,NDIFF,P,Q C .. C .. External Subroutines .. EXTERNAL QWRITE C .. C .. Save statement .. SAVE C .. Q = ZMIN 10 CONTINUE P = Q + 1 Q = Q + SIZE IF (Q.GT.ZMAX) Q = ZMAX + 1 IREC = IREC + 1 C DO 30 L = P,Q DO 20 H = 1,NX C C ************************ CALL QWRITE(TAPE,X(1,L,H),NY) C ************************ C 20 CONTINUE 30 CONTINUE C C---- pad record to nwords words C NDIFF = NWORDS - NX*NY* (Q-P+1) C C ******************************** IF (NDIFF.GT.0) CALL QWRITE(TAPE,X(1,1,1),NDIFF) C ******************************** C IF (Q.LE.ZMAX) GO TO 10 C END