C C This code is distributed under the terms and conditions of the C CCP4 licence agreement as `Part ii)' software. See the conditions C in the CCP4 manual for a copyright statement. C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C OASIS C a program for phasing OAS (One-wavelength Anomalous Scattering) C or SIS (Single Isomorphous Substitution) data C Authors: Q.Hao (1,2), Y.X.Gu, C.D.Zheng & H.F.Fan (2) C Email: qhao@dmu.ac.uk or fan@aphy.iphy.ac.cn C (1) Cornell University, USA C (2) Institute of Physics, Chinese Academy of Sciences, Beijing,China CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC PROGRAM OASIS CHARACTER*132 AA,SccsId C SccsId = "@(#)oasis.f 1.2 /disk2/people/liu/.source/SCCS/s.oasis.f" CALL CCPFYP call ccprcs (6, 'OASIS', '$Date: 2002/06/17 08:14:46 $') WRITE (6,100) CALL CCPDPN(10,'KEYWORD','SCRATCH','F',80,0) 1 READ (5,10,END=2)AA WRITE (10,10)AA GOTO 1 2 CONTINUE CALL PREPAR(1) CALL PREPAR(2) CALL TSIGN 10 FORMAT(A132) 100 FORMAT(///,' ****** OASIS ******',/ & ' Version 1.2.1, 23 Oct 2001',// & 'A program for phasing OAS (One-wavelength Anomalous Scattering)' & ,/'or SIR (Single Isomorphous Replacement) data',// & 'Authors: Q.Hao (1,2), Y.X.Gu, C.D.Zheng & H.F.Fan (2)',/ & ' (1) Cornell University, USA',/ & ' (2) Institute of Physics, Chinese Academy of Sciences',/ & ' Email: qh22@cornell.edu or fan@aphy.iphy.ac.cn',///) CALL CCPERR(0,'Normal termination') END CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C PPPPPPPP RRRRRRRR EEEEEEEEE PPPPPPPP A RRRRRRRR C C PPPPPPPPP RRRRRRRRR EEEEEEEEE PPPPPPPPP AAA RRRRRRRRR C C PP PP RR RR EE PP PP AA AA RR RR C C PP PP RR RR EE PP PP AA AA RR RR C C PPPPPPPPP RRRRRRRRR EEEEEEE PPPPPPPPP AA AA RRRRRRRRR C C PPPPPPPP RRRRRRRR EEEEEEE PPPPPPPP AA AA RRRRRRRR C C PP RR RR EE PP AAAAAAAAA RR RR C C PP RR RR EE PP AAAAAAAAA RR RR C C PP RR RR EEEEEEEEE PP AA AA RR RR C C PP RR RR EEEEEEEEE PP AA AA RR RR C C C C PROGRAM FOR PRELIMINARY PROCESSING OF THE INPUT DATA C C ** AN EXTENSIVE MODIFICATION OF THE PROGRAM 'NORMAL' OF MULTAN-80 ** C C VERSION 1999 C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC SUBROUTINE PREPAR(IPASS) CHARACTER*8 CDATE,CTIME PARAMETER (MAXRE=150000) COMMON/DATETIME/ CDATE,CTIME COMMON/ATMFACTOR/AL(8),AS(8),BL(8),BS(8),CL(8),CS(8),DL(8),DS(8), 1 EL(8),NW(8),NO(8),NK,NAT,F(9),F2(9) COMMON/ATMGROUP/NINF(10),NAG(10),X(500),Y(500),Z(500),NZ(500), 1 Q(500),U11(500),U22(500),U33(500),U23(500),U13(500),U12(500) COMMON/REFLXIN/LH(60),LK(60),LL(60),FO(60),ID(60),RHO(60),DFO(60), 1 EO(60),BTP(60),ITPH(60),ED(60),EDP(60),SDFO(60) COMMON/REFLXOUT/FH(60),XKP(60),PHIP(60),DELT(60),SFJ2(60) COMMON/RESCALING/MG,BT(9),SC(9),SCAL(8) COMMON/SCATFACTOR/GIS(142),GIW(142),NGP COMMON/SINETABLE/SINT(450) COMMON/SYMMETRY/IS(3,3,24),TS(3,24),NSYM,PTS,KSYS,ICENT,LATT C UNITS FOR INPUT/OUTPUT, TITLE, FLAGS COMMON/STTTIC/VST(10,5),NST(5),ZT(25,5),EE(10),MULT,IND,NZR,TMUL COMMON/UNIT_OAS/ITLE(80),LIST,PI,IDTYPE,DEVIAT,ICOMP COMMON/WILSON/FLGW(30),FLGD(30),AVR(30),SLOPE,DEL(9),KS(9) COMMON/XXX/P(6),CX(9),NREF,NPWP,RHOMAX,MREF,EMAX,EMIN,RHOCUT, 1 SIGCUT,ZCG(8),ZOG(8),KNOWN,KMIN,ISGM2,NCYC,ISIMP,IFIT COMMON/OUT/MH(MAXRE),MK(MAXRE),ML(MAXRE),MTPH(MAXRE),FOM(MAXRE), 1 EOM(MAXRE),CDPM(MAXRE),PHIM(MAXRE),ESGMM(MAXRE), 2 XSINM(MAXRE),RSLM(MAXRE),SDM(MAXRE) CHARACTER NGS(26),KX(10),ITERM(4),NTLE(80),ITLE,KSP,KP,KM,KEQ,KSC DATA KX/'0','1','2','3','4','5','6','7','8','9'/ DATA KSP/' '/,KP/'+'/,KM/'-'/,KEQ/'='/,KSC/';'/ DATA ITERM/'H','K','L','N'/ C SET UP INITIAL VALUES, READ PROGRAM PARAMETERS PI=4.0*ATAN(1.0) NREF=0 RHOMAX=0.0 DTOR=PI/180.0 C SET UP SIN/COS TABLE DO 50 I=1,450 SINT(I)=SIN(DTOR*FLOAT(I-1)) 50 CONTINUE C GET INITIAL TIME CALL CCPDAT(CDATE) CALL UTIME(CTIME) IF (IPASS.EQ.1) THEN CALL CCPDPN(1,'SIGNDT','SCRATCH','F',80,0) CALL CCPDPN(9,'PROTDT','SCRATCH','F',80,0) ELSE REWIND(9) END IF REWIND(10) CALL CCPDPN(8,'SCRA8','SCRATCH','U',80,0) C READ TITLE READ(10,100) NTLE 100 FORMAT(80A1) IL=80 IR=80 DO 103 I=1,80 IF(NTLE(I).NE.KSP.AND.IL.EQ.80) IL=I-1 IF(NTLE(80-I+1).NE.KSP.AND.IR.EQ.80) IR=I-1 103 CONTINUE IM=(IL+IR)/2 DO 105 I=1,80 IF(I.LE.IM) ITLE(I)=KSP IF(I.GT.IM) ITLE(I)=NTLE(IL+I-IM) 105 CONTINUE CALL INPUT_OAS(IPASS) ccc IF(MREF.GT.0) WRITE(6,405) MREF ccc 405 FORMAT('0',27X,'OUTPUT FOR PHASE - ',I5,13H LARGEST E'S) MKR=0 C READ REFLECTION DATA (& symmetry info) FROM files IF (IPASS.EQ.1) CALL DATAIN1 IF (IPASS.EQ.2) CALL DATAIN2 ANAT=FLOAT(NAT)/(PTS*FLOAT((ICENT+1)*NSYM)) WRITE(6,370) ANAT 370 FORMAT(/1X,'NUMBER OF ATOMS IN ASYMMETRIC UNIT =',F10.2) NASU=INT(ANAT+0.5) MREF=NREF IF(NPWP.EQ.0) NPWP=8.0*ALOG10(0.05*FLOAT(NREF)+0.5) C MAXIMUM OF 30 POINTS ON WILSON PLOT IF(NPWP.GT.30) NPWP=30 WRITE(6,640) NREF,RHOMAX,NPWP 640 FORMAT(/1X,'TOTAL NUMBER OF REFLEXION (IN DATA-FILE) =',I6/ 1 1X,'MAXIMUM (SIN(THETA)/LAMBDA)**2 =',F7.4/ 2 1X,'NUMBER OF POINTS ON WILSON PLOT =',I3) SC(1)=1.0 C IF(JUMP.GE.0) GOTO 650 C OBTAIN SUMS FOR WILSON PLOT AND FIT LEAST SQUARES STRAIGHT LINE CALL WILSONN(PTS,KSYS) 645 DO 655 I=1,8 BT(I)=2.0*BT(I) IF(BT(I).LT.-19.9) BT(I)=BT(1) IF(SCAL(I).LT.0.00001) SCAL(I)=SCAL(1) 655 CONTINUE C CALCULATE SCALE FACTORS FOR APPROPRIATE REFLEXION GROUPS CALL RESCA(KSYS) IF(KMIN.NE.0) GOTO 657 KMIN=5 IF(IDTYPE.GT.0) KMIN=10 657 IF(IDTYPE.LT.0) THEN c OUTPUT FOR SIGN OR PHASE WRITE(1,660) ITLE,(CX(I),I=1,6),NW,NO,ICENT,LATT,NSYM,NASU 660 FORMAT(80A1/' DIRECT CELL:'/' A B C ', 1 'ALPHA BETA GAMMA'/6F10.5/ 2 ' ATOMS IN THE WHOLE UNIT CELL:'/' N1 N2 N3 N4 N5', 3 ' N6 N7 N8 Z1 Z2 Z3 Z4 Z5 Z6 Z7 Z8'/16I5/ 4 ' ICENT LATT NSYM NASU '/4I5) WRITE(1,670) ((TS(I,J),(IS(K,I,J),K=1,3),I=1,3),J=1,NSYM) 670 FORMAT(' EQUIVALENT POSITIONS IN REAL SPACE:'/3(F11.8,3I3)) ENDIF C CALCULATE FINAL E'S AND OUTPUT REFLEXION STATISTICS CALL ECAL(KSYS,PTS) C JOB ENDS AT THIS TIME 900 CONTINUE CALL CCPDAT(CDATE) CALL UTIME(CTIME) WRITE(6,910) CDATE,CTIME 910 FORMAT(53X,A8,3X,A8) IF (IPASS.EQ.2) CLOSE (9) CLOSE (8) WRITE(6,*)' --- PREPARE COMPLETED ---' END C----------------------------------------------------------------------- SUBROUTINE ATMCOEF C CALCULATE SPHERICAL SCATTERING FACTOR COEFFICIENTS C ATOMIC SCATTERING FACTOR COEFFICIENTS FOR 98 ATOM TYPES C F = AL * EXP(-AS * RHO) + BL * EXP(-BS * RHO) C + CL * EXP(-CS * RHO) + DL * EXP(-DS * RHO) + EL C COMMON/ATMFACTOR/AL(8),AS(8),BL(8),BS(8),CL(8),CS(8),DL(8),DS(8), 1 EL(8),NW(8),NO(8),NK,NAT,F(9),F2(9) DIMENSION ALT(98),AST(98),BLT(98),BST(98),ELT(98),NT(98) DIMENSION CLT(98),CST(98),DLT(98),DST(98) DATA NT/ 8,805,1209,205, 2, 3, 14, 15, 6,1405,1401,1307,112,1909, 1 16, 19, 312,118, 11, 301,1903,2009, 22, 318,1314,605,315,1409, 2 321,2614, 701,705,119,1905,218,1118,1802,1918,25,2618,1402,1315, 3 2003,1821,1808,1604, 107,304,914,1914,1902,2005, 9,2405,319,201, 4 1201,305,1618,1404,1613,1913,521,704,2002,425,815,518,2013,2502, 5 1221,806,2001, 23,1805,1519,918,1620,121,807,2012,1602,209,1615, 6 120,1814,618,1801, 103,2008,1601, 21,1416,1621,113,313, 211,306/ DATA ALT/0.489918,0.873400, 1.128200, 1.591900, 2.054500, 9 2.310000, 12.212600, 3.048500, 3.539200, 3.955300, 9 4.762600, 5.420400, 6.420200, 6.291500, 6.434500, 9 6.905300, 11.460400, 7.484500, 8.218600, 8.626600, 9 9.189000, 9.759500, 10.297100, 10.640600, 11.281900, 9 11.769500, 12.284100, 12.837600, 13.338000, 14.074300, 9 15.235400, 16.081600, 16.672300, 17.000601, 17.178900, 9 17.355499, 17.178400, 17.566299, 17.775999, 17.876499, 9 17.614201, 3.702500, 19.130100, 19.267401, 19.295700, 9 19.331900, 19.280800, 19.221399, 19.162399, 19.188900, 9 19.641800, 19.964399, 20.147200, 20.293301, 20.389200, 9 20.336100, 20.577999, 21.167101, 22.044001, 22.684500, 9 23.340500, 24.004200, 24.627399, 25.070900, 25.897600, 9 26.507000, 26.904900, 27.656300, 28.181900, 28.664101, 9 28.947599, 29.143999, 29.202400, 29.081800, 28.762100, 9 28.189400, 27.304899, 27.005899, 16.881901, 20.680901, 9 27.544600, 31.061701, 33.368900, 34.672600, 35.316299, 9 35.563099, 35.929901, 35.763000, 35.659698, 35.564499, 9 35.884701, 36.022800, 36.187401, 36.525398, 36.670601, 9 36.648800, 36.788101, 36.918499/ DATA AST/20.659300,9.103700,3.954600, 43.642700, 23.218500, 9 20.843901, 0.005700, 13.277100, 10.282500, 8.404200, 9 3.285000, 2.827500, 3.038700, 2.438600, 1.906700, 9 1.467900, 0.010400, 0.907200, 12.794900, 10.442100, 9 9.021300, 7.850800, 6.865700, 6.103800, 5.340900, 9 4.761100, 4.279100, 3.878500, 3.582800, 3.265500, 9 3.066900, 2.850900, 2.634500, 2.409800, 2.172300, 9 1.938400, 1.788800, 1.556400, 1.402900, 1.276180, 9 1.188650, 0.277200, 0.864132, 0.808520, 0.751536, 9 0.698655, 0.644600, 0.594600, 0.547600, 5.830300, 9 5.303400, 4.817420, 4.347000, 3.928200, 3.569000, 9 3.216000, 2.948170, 2.812190, 2.773930, 2.662480, 9 2.562700, 2.472740, 2.387900, 2.253410, 2.242560, 9 2.180200, 2.070510, 2.073560, 2.028590, 1.988900, 9 1.901820, 1.832620, 1.773330, 1.720290, 1.671910, 9 1.629030, 1.592790, 1.512930, 0.461100, 0.545000, 9 0.655150, 0.690200, 0.704000, 0.700999, 0.685870, 9 0.663100, 0.646453, 0.616341, 0.589092, 0.563359, 9 0.547751, 0.529300, 0.511929, 0.499384, 0.483629, 9 0.465154, 0.451018, 0.437533/ DATA BLT/0.262003,0.630900, 0.750800, 1.127800, 1.332600, 9 1.020000, 3.132200, 2.286800, 2.641200, 3.112500, 9 3.173600, 2.173500, 1.900200, 3.035300, 4.179100, 9 5.203400, 7.196400, 6.772300, 7.439800, 7.387300, 9 7.367900, 7.355800, 7.351100, 7.353700, 7.357300, 9 7.357300, 7.340900, 7.292000, 7.167600, 7.031800, 9 6.700600, 6.374700, 6.070100, 5.819600, 5.235800, 9 6.728600, 9.643500, 9.818400, 10.294600, 10.948000, 9 12.014400, 17.235600, 11.094800, 12.918200, 14.350100, 9 15.501700, 16.688499, 17.644400, 18.559601, 19.100500, 9 19.045500, 19.013800, 18.994900, 19.029800, 19.106199, 9 19.297001, 19.599001, 19.769501, 19.669701, 19.684700, 9 19.609501, 19.425800, 19.088600, 19.079800, 18.218500, 9 17.638300, 17.294001, 16.428499, 15.885100, 15.434500, 9 15.220800, 15.172600, 15.229300, 15.430000, 15.718900, 9 16.155001, 16.729601, 17.763901, 18.591299, 19.041700, 9 19.158400, 13.063700, 12.951000, 15.473300, 19.021099, 9 21.281601, 23.054701, 22.906401, 23.103201, 23.421900, 9 23.294800, 23.412800, 23.596399, 23.808300, 24.099199, 9 24.409599, 24.773600, 25.199499/ DATA BST/7.740390,3.356800, 1.052400, 1.862300, 1.021000, 9 10.207500, 9.893300, 5.701100, 4.294400, 3.426200, 9 8.842200, 79.261101, 0.742600, 32.333698, 27.157000, 9 22.215099, 1.166200, 14.840700, 0.774800, 0.659900, 9 0.572900, 0.500000, 0.438500, 0.392000, 0.343200, 9 0.307200, 0.278400, 0.256500, 0.247000, 0.233300, 9 0.241200, 0.251600, 0.264700, 0.272600, 16.579599, 9 16.562300, 17.315100, 14.098800, 12.800600, 11.916000, 9 11.766000, 1.095800, 8.144870, 8.434670, 8.217580, 9 7.989290, 7.472600, 6.908900, 6.377600, 0.503100, 9 0.460700, 0.420885, 0.381400, 0.344000, 0.310700, 9 0.275600, 0.244475, 0.226836, 0.222087, 0.210628, 9 0.202088, 0.196451, 0.194200, 0.181951, 0.196143, 9 0.202172, 0.197940, 0.223545, 0.238849, 0.257119, 9 9.985190, 9.599900, 9.370460, 9.225900, 9.092270, 9 8.979480, 8.865530, 8.811740, 8.621600, 8.448400, 9 8.707510, 2.357600, 2.923800, 3.550780, 3.974580, 9 4.069100, 4.176190, 3.871350, 3.651550, 3.462040, 9 3.415190, 3.325300, 3.253960, 3.263710, 3.206470, 9 3.089970, 3.046190, 3.007750/ DATA CLT/0.196767,0.311200, 0.617500, 0.539100, 1.097900, 9 1.588600, 2.012500, 1.546300, 1.517000, 1.454600, 9 1.267400, 1.226900, 1.593600, 1.989100, 1.780000, 9 1.437900, 6.255600, 0.653900, 1.051900, 1.589900, 9 1.640900, 1.699100, 2.070300, 3.324000, 3.019300, 9 3.522200, 4.003400, 4.443800, 5.615800, 5.165200, 9 4.359100, 3.706800, 3.431300, 3.973100, 5.637700, 9 5.549300, 5.139900, 5.422000, 5.726290, 5.417320, 9 4.041830, 12.887600, 4.649010, 4.863370, 4.734250, 9 5.295370, 4.804500, 4.461000, 4.294800, 4.458500, 9 5.037100, 6.144870, 7.513800, 8.976700, 10.662000, 9 10.888000, 11.372700, 11.851300, 12.385600, 12.774000, 9 13.123500, 13.439600, 13.760300, 13.851800, 14.316700, 9 14.559600, 14.558300, 14.977900, 15.154200, 15.308700, 9 15.100000, 14.758600, 14.513500, 14.432700, 14.556400, 9 14.930500, 15.611500, 15.713100, 25.558201, 21.657499, 9 15.538000, 18.441999, 16.587700, 13.113800, 9.498870, 9 8.003700, 12.143900, 12.473900, 12.597700, 12.747300, 9 14.189100, 14.949100, 15.640200, 16.770700, 17.341499, 9 17.399000, 17.891899, 18.331699/ DATA CST/49.551899,22.927601,85.390503,103.483002, 60.349800, 9 0.568700, 28.997499, 0.323900, 0.261500, 0.230600, 9 0.313600, 0.380800, 31.547199, 0.678500, 0.526000, 9 0.253600, 18.519400, 43.898300, 213.186996, 85.748398, 9 136.108002, 35.633801, 26.893801, 20.262600, 17.867399, 9 15.353500, 13.535900, 12.176300, 11.396600, 10.316300, 9 10.780500, 11.446800, 12.947900, 15.237200, 0.260900, 9 0.226100, 0.274800, 0.166400, 0.125599, 0.117622, 9 0.204785, 11.004000, 21.570700, 24.799700, 25.874901, 9 25.205200, 24.660500, 24.700800, 25.849899, 26.890900, 9 27.907400, 28.528400, 27.766001, 26.465900, 24.387899, 9 20.207300, 18.772600, 17.608299, 16.766899, 15.885000, 9 15.100900, 14.399600, 13.754600, 12.933100, 12.664800, 9 12.189900, 11.440700, 11.360400, 10.997500, 10.664700, 9 0.261033, 0.275116, 0.295977, 0.321703, 0.350500, 9 0.382661, 0.417916, 0.424593, 1.482600, 1.572900, 9 1.963470, 8.618000, 8.793700, 9.556420, 11.382400, 9 14.042200, 23.105200, 19.988701, 18.599001, 17.830900, 9 16.923500, 16.092699, 15.362200, 14.945500, 14.313600, 9 13.434600, 12.894600, 12.404400/ DATA DLT/0.049879,0.178000, 0.465300, 0.702900, 0.706800, 9 0.865000, 1.166300, 0.867000, 1.024300, 1.125100, 9 1.112800, 2.307300, 1.964600, 1.541000, 1.490800, 9 1.586300, 1.645500, 1.644200, 0.865900, 1.021100, 9 1.468000, 1.902100, 2.057100, 1.492200, 2.244100, 9 2.304500, 2.348800, 2.380000, 1.673500, 2.410000, 9 2.962300, 3.683000, 4.277900, 4.354300, 3.985100, 9 3.537500, 1.529200, 2.669400, 3.265880, 3.657210, 9 3.533460, 3.742900, 2.712630, 1.567560, 1.289180, 9 0.605844, 1.046300, 1.602900, 2.039600, 2.466300, 9 2.682700, 2.523900, 2.273500, 1.990000, 1.495300, 9 2.695900, 3.287190, 3.330490, 2.824280, 2.851370, 9 2.875160, 2.896040, 2.922700, 3.545450, 2.953540, 9 2.965770, 3.638370, 2.982330, 2.987060, 2.989630, 9 3.716010, 4.300130, 4.764920, 5.119820, 5.441740, 9 5.675890, 5.833770, 5.783700, 5.860000, 5.967600, 9 5.525930, 5.969600, 6.469200, 7.025880, 7.425180, 9 7.443300, 2.112530, 3.210970, 4.086550, 4.807030, 9 4.172870, 4.188000, 4.185500, 3.479470, 3.493310, 9 4.216650, 4.232840, 4.243910/ DATA DST/2.201590,0.982100,168.261002, 0.542000, 0.140300, 9 51.651199, 0.582600, 32.908901, 26.147600, 21.718399, 9 129.423996, 7.193700, 85.088600, 81.693703, 68.164497, 9 56.172001, 47.778400, 33.392899, 41.684101, 178.436996, 9 51.353100, 116.105003, 102.477997, 98.739899, 83.754303, 9 76.880501, 71.169197, 66.342102, 64.812599, 58.709702, 9 61.413502, 54.762501, 47.797199, 43.816299, 41.432800, 9 39.397202, 164.934006, 132.376007, 104.353996, 87.662697, 9 69.795700, 61.658401, 86.847198, 94.292801, 98.606201, 9 76.898598, 99.815598, 87.482498, 92.802902, 83.957100, 9 75.282501, 70.840302, 66.877602, 64.265800, 213.904007, 9 167.201996, 133.123993, 127.112999, 143.643997, 137.903000, 9 132.720993, 128.007004, 123.174004, 101.398003, 115.362000, 9 111.874001, 92.656601, 105.703003, 102.960999, 100.417000, 9 84.329803, 72.028999, 63.364399, 57.056000, 52.086102, 9 48.164700, 45.001099, 38.610298, 36.395599, 38.324600, 9 45.814899, 47.257900, 48.009300, 47.004501, 45.471500, 9 44.247299, 150.645004, 142.324997, 117.019997, 99.172203, 9 105.250999, 100.612999, 97.490799, 105.980003, 102.273003, 9 88.483398, 86.002998, 83.788101/ DATA ELT/0.001305,0.006400, 0.037700, 0.038500, -0.193200, 9 0.215600, -11.529000, 0.250800, 0.277600, 0.351500, 9 0.676000, 0.858400, 1.115100, 1.140700, 1.114900, 9 0.866900, -9.557400, 1.444500, 1.422800, 1.375100, 9 1.332900, 1.280700, 1.219900, 1.183200, 1.089600, 9 1.036900, 1.011800, 1.034100, 1.191000, 1.304100, 9 1.718900, 2.131300, 2.531000, 2.840900, 2.955700, 9 2.825000, 3.487300, 2.506400, 1.912130, 2.069290, 9 3.755910, 4.387500, 5.404280, 5.378740, 5.328000, 9 5.265930, 5.179000, 5.069400, 4.939100, 4.782100, 9 4.590900, 4.352000, 4.071200, 3.711800, 3.335200, 9 2.773100, 2.146780, 1.862640, 2.058300, 1.984860, 9 2.028760, 2.209630, 2.574500, 2.419600, 3.583240, 9 4.297280, 4.567960, 5.920460, 6.756210, 7.566720, 9 7.976280, 8.581540, 9.243540, 9.887500, 10.472000, 9 11.000500, 11.472200, 11.688300, 12.065800, 12.608900, 9 13.174600, 13.411800, 13.578200, 13.677000, 13.710800, 9 13.690500, 13.724700, 13.621100, 13.526600, 13.431400, 9 13.428700, 13.396600, 13.357300, 13.381200, 13.359200, 9 13.288700, 13.275400, 13.267400/ DO 150 I=1,NK C CHECK ATOM TYPE DO 120 J=1,98 IF (NW(I).NE.NT(J)) GO TO 120 NO(I)=J C TEST IF THE PARAMETERS HAVE BEEN INPUT BY USER IN A KEYWORD FILE C TEST=AL(I)+BL(I)+CL(I)+ABS(DL(I))+ABS(EL(I)) C IF (TEST.GT.0.001) GO TO 120 AS(I)=AST(J) AL(I)=ALT(J) BS(I)=BST(J) BL(I)=BLT(J) CL(I)=CLT(J) CS(I)=CST(J) DL(I)=DLT(J) DS(I)=DST(J) EL(I)=ELT(J) 120 CONTINUE 150 CONTINUE RETURN END C----------------------------------------------------------------------- SUBROUTINE DATAIN1 C READ REFLEXIONS FROM DATA FILE COMMON/REFLXIN/LH(60),LK(60),LL(60),FO(60),ID(60),RHO(60),DFO(60), 1 EO(60),BTP(60),ITPH(60),ED(60),EDP(60),SDFO(60) COMMON/REFLXOUT/FH(60),XKP(60),PHIP(60),DELT(60),SFJ2(60) COMMON/RESCALING/MG,BT(9),SC(9),SCAL(8) COMMON/UNIT_OAS/ITLE(80),LIST,PI,IDTYPE,DEVIAT,ICOMP COMMON/SYMMETRY/IS(3,3,24),TS(3,24),NSYM,PTS,KSYS,ICENT,LATT COMMON/XXX/P(6),CX(9),NREF,NPWP,RHOMAX,MREF,EMAX,EMIN,RHOCUT, 1 SIGCUT,ZCG(8),ZOG(8),KNOWN,KMIN,ISGM2,NCYC,ISIMP,IFIT REAL RSYM(4,4,64),CELLP(6) DIMENSION ADATA1(9),I1(3),I2(3),KL3(24) integer IFLAG(24),JFLAG(24) CHARACTER ITLE INTEGER IPOINT1(9) CHARACTER*30 LAB1(9),LSUSRJ(9) CHARACTER*1 CTYP1(9) LOGICAL EOF,LOGMSS(9) CHARACTER*4 KEY, CCVAL(20) CHARACTER*400 LINE CHARACTER NCH(7), LTYPEX*1,PGNAMX*10,SPGRNX*10 INTEGER NTOK, IBEG(20), IEND(20), ITYP(20), IDEC(20) REAL FVAL(20) DATA ADATA1/9*0.0/ DATA LAB1/'H','K','L','F1','SIGF1','F2','SIGF2', + ' ',' '/ DATA CTYP1/'H','H','H','F','Q','D','Q',' ',' '/ DATA IPOINT1/-1,-1,-1,6*0/ DATA NCH/'A','B','C','I','R','F','P'/ REWIND (10) 10 READ(10,'(A132)',END=15) LINE NTOK = 20 CALL PARSER (KEY,LINE,IBEG,IEND,ITYP,FVAL,CCVAL, + IDEC,NTOK,EOF,.FALSE.) CALL CCPUPC(KEY) IF (KEY.NE.'LABI') GO TO 10 GOTO 20 15 CALL CCPERR(1,' ---- LABIN card missing ---- ') 20 NL = 7 IF (ICOMP.GE.1) THEN NL = NL + 1 LAB1(8) = 'TPHI' CTYP1(8) = 'P' END IF IF(ICOMP.EQ.2) THEN NL = NL + 1 LAB1(9) = 'FOM' CTYP1(9) = 'W' END IF CALL MTZINI ITOK = 2 CALL LKYSET(LAB1,NL,LSUSRJ,IPOINT1,ITOK,NTOK,LINE, + IBEG,IEND) CALL LKYIN(1,LAB1,NL,NTOK,LINE,IBEG,IEND) CALL LROPEN (1,'HKLIN',1,IFAIL) IF (IFAIL.EQ.1) CALL CCPERR(1,'Error opening HKLIN') if (latt.eq.0) then CALL LRSYMM(1,NSYM,RSYM) call lrsymi(1,nsympx,ltypex,nspgrx,spgrnx,pgnamx) DO 22 I=1,7 IF (LTYPEX.EQ.NCH(I)) IN1=I 22 CONTINUE LATT=MOD(IN1,7)+1 IF (LATT.LE.5) PTS=MIN0(2,LATT) IF (LATT.GE.6) PTS=LATT-3 IF (IN1.EQ.6) LATT=6 IF (IN1.EQ.5) LATT=7 nsym = nsym/pts do n = 1, nsym do i = 1, 3 ts(i,n) = rsym(i,4,n) do j = 1, 3 is(i,j,n) = nint(rsym(j,i,n)) end do end do end do ksys = 1 if (nspgrx.ge.3.and.nspgrx.le.15) ksys = 2 if (nspgrx.ge.16.and.nspgrx.le.74) ksys = 3 if (nspgrx.ge.75.and.nspgrx.le.142) ksys = 4 if (nspgrx.ge.143.and.nspgrx.le.167) ksys = 5 if (nspgrx.ge.168.and.nspgrx.le.194) ksys = 6 if (nspgrx.ge.195) ksys = 8 end if if (cx(1).eq.0.0) then CALL LRCELL(1,CELLP) do i = 1, 6 cx(i) = cellp(i) end do call incell(volume) end if CALL LRASSN (1,LAB1,NL,IPOINT1,CTYP1) K=0 100 CALL LRREFF(1,RESOL,ADATA1,EOF) IF (EOF) GOTO 450 CALL LRREFM(1,LOGMSS) IF (LOGMSS(4)) GOTO 100 IF (adata1(4).le.0.) GOTO 100 if (adata1(4).lt.sigcut*adata1(5)) goto 100 IF (LOGMSS(6)) adata1(6) = 0.0 KH=ADATA1(1) KK=ADATA1(2) KL=ADATA1(3) F=ADATA1(4) SD=ADATA1(5) DF=ADATA1(6) ITRP=NINT(ADATA1(8)) C GENERATE SYMMETRY RELATED REFLEXIONS AND FIND STANDARD ONE. MAXI=1 I1(1)=KH I1(2)=KK I1(3)=KL KCEN = 0 DO 250 J=1,NSYM IFLAG(J) = 1 JFLAG(J) = 1 DO 220 I0=1,3 I2(I0)=IS(I0,1,J)*I1(1) + IS(I0,2,J)*I1(2) + IS(I0,3,J)*I1(3) 220 CONTINUE IF((I2(1)+I1(1)).EQ.0.AND.(I2(2)+I1(2)).EQ.0.AND. + (I2(3)+I1(3)).EQ.0) KCEN=1 IND=65536*I2(1)+256*I2(2)+I2(3) IF (IND.LT.0) IFLAG(J) = -1 IF (IND.LT.0.AND.IDTYPE.EQ.-1) JFLAG(J) = -1 KL3(J)=32896+IABS(IND) IF(J.EQ.1) GOTO 250 JM1=J-1 DO 240 I0=1,JM1 IF(KL3(I0).EQ.KL3(J)) KL3(J)=0 240 CONTINUE IF(KL3(J).GT.KL3(MAXI)) MAXI=J 250 CONTINUE cccc IF(IDTYPE.EQ.-1.AND.KCEN.EQ.0.AND.DF.EQ.0.0) GOTO 100 C UNPACKING STANDARD REFLEXIONS IND=KL3(MAXI) KH=IND/65536 IF(IND.LT.0) KH=KH-1 IND=IND-65536*KH KK=IND/256 KL=IND-256*KK-128 KK=KK-128 K=K+1 LH(K)=KH LK(K)=KK LL(K)=KL FO(K)=F SDFO(K)=SD DFO(K)=JFLAG(MAXI)*DF ITRP=MOD(IFLAG(MAXI)*ITRP+1440,360) 300 IF(ICOMP.GT.0) ITPH(K)=ITRP IF(K.NE.60) GOTO 100 C CALCULATE RHO, EPSILON, MULTIPLICITY, SCATTERING FACTOR AND C CREATE SCRATCH FILE CALL FCAL K=0 GOTO 100 450 FO(K+1) = -1.0 CALL FCAL CALL LRCLOS (1) RETURN END C----------------------------------------------------------------------- SUBROUTINE DATAIN2 C READ REFLEXIONS FROM DATA FILE COMMON/REFLXIN/LH(60),LK(60),LL(60),FO(60),ID(60),RHO(60),DFO(60), 1 EO(60),BTP(60),ITPH(60),ED(60),EDP(60),SDFO(60) COMMON/REFLXOUT/FH(60),XKP(60),PHIP(60),DELT(60),SFJ2(60) COMMON/RESCALING/MG,BT(9),SC(9),SCAL(8) COMMON/UNIT_OAS/ITLE(80),LIST,PI,IDTYPE,DEVIAT,ICOMP COMMON/SYMMETRY/IS(3,3,24),TS(3,24),NSYM,PTS,KSYS,ICENT,LATT COMMON/XXX/P(6),CX(9),NREF,NPWP,RHOMAX,MREF,EMAX,EMIN,RHOCUT, 1 SIGCUT,ZCG(8),ZOG(8),KNOWN,KMIN,ISGM2,NCYC,ISIMP,IFIT DIMENSION KH(9),KK(9),KL(9),F(9),B(9),KD(9),KL3(24),I1(3),I2(3), 1 DF(9),E(9),FJ2(9),ITRP(9),IFOM(9),SD(9) CHARACTER FM*80,CFM*19,ITLE CFM='1234567890., ()FHIX' NRP=0 NLP=0 TEST=0.0 10 READ(9,'(A80)') FM IF(INDEX(FM,'E-VALUE').GT.0) IDTYPE=-IDTYPE DO 20 I=1,LEN(FM) IF(INDEX(CFM,FM(I:I)).EQ.0) GOTO 10 IF(FM(I:I).NE.' ') TEST=1.0 IF(FM(I:I).EQ.'(') NRP=NRP+1 IF(FM(I:I).EQ.')') NLP=NLP+1 20 CONTINUE IF(TEST.LT.0.5) GOTO 10 IF((NRP+NLP).EQ.0.OR.NRP.NE.NLP) GOTO 10 NPC=1 IPST1=INDEX(FM,'(') IPST2=INDEX(FM(IPST1+1:),'(') IF(IPST2.EQ.0) GOTO 50 DO 30 I=IPST1+1,IPST1+IPST2-1 NPCT=INDEX(CFM,FM(I:I)) IF(NPCT.GT.0.AND.NPCT.LT.10) NPC=NPCT 30 CONTINUE 50 K=0 100 IF(ICOMP.EQ.0) READ(9,FM) 1 (KH(I),KK(I),KL(I),F(I),B(I),FJ2(I),E(I),DF(I),SD(I),I=1,NPC) IF(ICOMP.GT.0) READ(9,FM) 1 (KH(I),KK(I),KL(I),F(I),B(I),FJ2(I),E(I),DF(I),ITRP(I),SD(I) 2 ,I=1,NPC) 120 DO 400 I=1,NPC C GENERATE SYMMETRY RELATED REFLEXIONS AND FIND STANDARD ONE. MAXI=1 I1(1)=KH(I) I1(2)=KK(I) I1(3)=KL(I) DO 250 J=1,NSYM DO 220 I0=1,3 I2(I0)=IS(I0,1,J)*I1(1) + IS(I0,2,J)*I1(2) + IS(I0,3,J)*I1(3) 220 CONTINUE IND=65536*I2(1)+256*I2(2)+I2(3) KL3(J)=32896+IABS(IND) IF(J.EQ.1) GOTO 250 JM1=J-1 DO 240 I0=1,JM1 IF(KL3(I0).EQ.KL3(J)) KL3(J)=0 240 CONTINUE IF(KL3(J).GT.KL3(MAXI)) MAXI=J 250 CONTINUE C UNPACKING STANDARD REFLEXIONS IND=KL3(MAXI) KH(I)=IND/65536 IF(IND.LT.0) KH(I)=KH(I)-1 IND=IND-65536*KH(I) KK(I)=IND/256 KL(I)=IND-256*KK(I)-128 KK(I)=KK(I)-128 K=K+1 LH(K)=KH(I) LK(K)=KK(I) LL(K)=KL(I) FO(K)=F(I) SDFO(K)=SD(I) DFO(K)=DF(I) BTP(K)=B(I) EO(K)=E(I) SFJ2(K)=FJ2(I) 300 IF(ICOMP.GT.0) ITPH(K)=ITRP(I) IF(F(I).LT.0.0) GOTO 450 IF(K.NE.60) GOTO 400 C CALCULATE RHO, EPSILON, MULTIPLICITY, SCATTERING FACTOR AND C CREATE SCRATCH FILE CALL FCAL K=0 400 CONTINUE GOTO 100 450 CALL FCAL RETURN END CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C EEEEEEE CCCCC A L C C E C C A A L C C E C A A L C C EEEEE C A A L C C E C AAAAAAA L C C E C C A A L C C EEEEEEE CCCCC A A LLLLLLL C C C C CALCULATE FINAL E-VALUES AND RESCALED F'S C C OUTPUT REFLEXIONS FOR PHASE, PREPARE TABLES OF STATISTICS C C VERSION 1996 C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC SUBROUTINE ECAL(KSYS,PTS) PARAMETER (MAXRE=150000) COMMON/ATMGROUP/NINF(10),NAG(10),X(500),Y(500),Z(500),NZ(500), 1 Q(500),U11(500),U22(500),U33(500),U23(500),U13(500),U12(500) COMMON/REFLXIN/LH(60),LK(60),LL(60),FO(60),ID(60),RHO(60), 1 DFO(60),EO(60),BTP(60),ITPH(60),ED(60),EDP(60), 2 SDFO(60) COMMON/REFLXOUT/FH(60),XKP(60),PHIP(60),DELT(60),SFJ2(60) COMMON/RESCALING/MG,BT(9),SC(9),SCAL(8) COMMON/SCATFACTOR/GIS(142),GIW(142),NGP COMMON/STTTIC/VST(10,5),NST(5),ZT(25,5),EE(10),MULT,IND,NZR,TMUL COMMON/UNIT_OAS/ITLE(80),LIST,PI,IDTYPE,DEVIAT,ICOMP COMMON/WILSON/FLGW(30),FLGD(30),AVR(30),SLOPE,DEL(9),KS(9) COMMON/XXX/P(6),CX(9),NREF,NPWP,RHOMAX,MREF,EMAX,EMIN,RHOCUT, 1 SIGCUT,ZCG(8),ZOG(8),KNOWN,KMIN,ISGM2,NCYC,ISIMP,IFIT COMMON/OUT/MH(MAXRE),MK(MAXRE),ML(MAXRE),MTPH(MAXRE),FOM(MAXRE), 1 EOM(MAXRE),CDPM(MAXRE),PHIM(MAXRE),ESGMM(MAXRE), 2 XSINM(MAXRE),RSLM(MAXRE),SDM(MAXRE) DIMENSION INP(60),INPA(60),EH(60),XSIN(60),COSDP(60),ESGM(60) DIMENSION AVA(10),AVC(10),AVH(10),RHR(10),NHR(10),STL(10), 1 CPH(25),NU(25) CHARACTER ITLE,NN(80),ICHR(80) C TABLES OF THEORETICAL DISTRIBUTIONS CHARACTER*5 MKTYPE(2) DATA AVA/0.886,1.0,1.329,2.0,3.323,6.0,0.736,1.0,2.0,2.415/ DATA AVC/0.798,1.0,1.596,3.0,6.383,15.0,0.968,2.0,8.0,8.691/ DATA AVH/0.718,1.0,1.916,4.5,12.26,37.5,1.145,3.5,26.0,26.903/ DATA CPH/0.368,0.463,0.526,0.574,0.612,0.643,0.670,0.694,0.715, 1 0.733,0.765,0.791,0.813,0.832,0.848,0.863,0.875,0.886,0.896, 2 0.905,0.913,0.920,0.926,0.932,0.938/ DATA ICHR/19*' ','A','L','L',' ','D','A','T','A',4*' ','H','K', 1 'L',4*' ','0','K','L',17*' ','A','C','E','N','T',' ',' ','C', 2 'E','N','T',' ',' ','H','-','C','E','N','T',3*' '/ DATA MKTYPE(1)/'*OAS*'/MKTYPE(2)/'*SIR*'/ C SET INITIAL VALUES IF (IDTYPE.LT.0) GOTO 100 MC=0 MZR=0 IF(RHOCUT.GT.RHOMAX) RHOCUT=RHOMAX RSLIM=SQRT(1/(4*RHOCUT)) 100 DO 110 I=1,10 RHR(I)=0.0 NHR(I)=0 DO 110 J=1,5 VST(I,J)=0.0 110 CONTINUE DO 120 I=1,5 NST(I)=0 DO 120 J=1,25 ZT(J,I)=0.0 120 CONTINUE DO 130 I=1,25 NU(I)=0 130 CONTINUE NRW=0 KG=1 SCF=SQRT(SC(1)) RR=10.0/SQRT(RHOMAX) IF(IDTYPE.LT.0) THEN WRITE(9,290) MKTYPE(IABS(IDTYPE)) IF(ICOMP.EQ.0) WRITE(9,300) IF(ICOMP.GT.0) WRITE(9,310) IF(LIST.EQ.1) WRITE(6,320) NREF ELSE WRITE(1,330) ISGM2,ISIMP,KMIN,LIST,NCYC,RSLIM,IDTYPE,IFIT IF(ICOMP.GT.0) WRITE(1,340) IF(ICOMP.EQ.0) WRITE(1,350) ENDIF 290 FORMAT(1X,A5/' ABS(F) = F(OBS) * SQRT(K)*EXP(BS**2))'/ 1 ' EXBT = EXP(-BS**2)'/ 2 ' SGM(FJ**2) = SUM OVER THE SQUARES OF ATOMIC SCATTERING FACTOR') 300 FORMAT(' H K L ABS(F) EXBT SGM(FJ**2) E-VALUE DLT(F)'/ 1 ' (1X,3I4,F7.1,F8.4,F11.3,F7.3,F7.1,F7.2)') 310 FORMAT(' H K L ABS(F) EXBT SGM(FJ**2) E-VALUE DLT(F) *PHI*' 1 /' (1X,3I4,F7.1,F8.4,F11.3,F7.3,F7.1,I6,F7.2)') 320 FORMAT(//1X,'LIST OF',I5,1X,'REFLEXIONS.'/' F IS ON AN ABSOLUTE ', 1 'SCALE AND THE E-VALUES ARE SUITABLE FOR INPUT TO PHASE'/ 2 1X,1X,3(' H K L',5X,'F',4X,'E',4X)) 330 FORMAT(' ISGM2 ISIM KMIN LIST NCYC RSLIM IDTYPE IFIT' 1 /5I5,F7.2,I4,I6) 340 FORMAT(' H K L FPH E COSDPH PHP ESGMA ', 1 ' XSIN RSL TRPHI'/ 2 ' (3I4,F8.1,F7.3,F9.4,I5,2X,F9.5,F8.3,F7.2,I5,F8.2)') 350 FORMAT(' H K L FPH E COSDPH PHP ESGMA ', 1 ' XSIN RSL'/ 2 ' (3I4,F8.1,F7.3,F9.4,I5,2X,F9.5,F8.3,F7.2,F8.2)') REWIND(8) 360 READ(8) LH,LK,LL,FO,ID,ED,RHO,EDP,DFO, 1 FH,XKP,PHIP,EO,SFJ2,ITPH,BTP,DELT,SDFO DO 520 I=1,60 IG=MOD(ID(I),100) KG=IG INPA(I)=32896 MF=I C TEST FOR END OF DATA IF(FO(I).LT.0.0) GOTO 540 D=EXP(BT(IG)*RHO(I)) D=D*SCAL(IG) MULT=ID(I)/10000 IE=(ID(I)-10000*MULT)/100 ESQ=D*ED(I) IF(IDTYPE.GE.0) THEN C CALCULATE PHASE DIFFERENCES FOR PROTEIN DATA CTOP=0.0 IF(ABS(DFO(I)).GT.0.0) CTOP=DFO(I)*SQRT(ESQ/ED(I)) COSDP(I)=CTOP/((3-IDTYPE)*FH(I)) IF(ABS(COSDP(I)).GT.500.0) COSDP(I)=SIGN(1.0,COSDP(I))*500.0 PHIP(I)=MOD(PHIP(I)*180.0/PI+360.0,360.0)+.5 C CONSIDERATION FOR LACK OF CLOSURE ERROR ESGM(I)=0.0 IF(ABS(FH(I)).LT.0.01) GOTO 380 C FOR OAS DATA IF(IDTYPE.EQ.1) ESGM(I)=EXP(-DEVIAT**2/(4*FH(I)**2)) C FOR SIR DATA --- WITH FO CORRESPONDING TO THE NATIVE IF(IDTYPE.EQ.2) ESGM(I)=EXP(-DEVIAT**2*FO(I)**2 1 /(FH(I)**2*(FO(I)+CTOP)**2)) 380 FO(I)=FO(I)*BTP(I) sdfo(i)=sdfo(i)*btp(i) C---------------------------------------------------- IF(IDTYPE.EQ.2) ISIMP=0 RSL=SQRT(1/(4*RHO(I))) IF(RHO(I).GT.RHOCUT.OR.EO(I).GT.EMAX.OR.EO(I).LT.EMIN) GOTO 400 XSIN(I)=XKP(I)*SIGN(1.0,DELT(I))*SIN(ABS(DELT(I))) IF(IDTYPE.EQ.1.AND.COSDP(I).NE.0.0000.AND.FO(I).GT.0.0) GOTO 390 MC=MC+1 IF(MC.GT.MAXRE) GOTO 540 MH(MC)=LH(I) MK(MC)=LK(I) ML(MC)=LL(I) FOM(MC)=FO(I) SDM(MC)=SDFO(I) EOM(MC)=EO(I) CDPM(MC)=COSDP(I) PHIM(MC)=PHIP(I) ESGMM(MC)=ESGM(I) XSINM(MC)=XSIN(I) RSLM(MC)=RSL IF(ICOMP.GT.0) MTPH(MC)=ITPH(I) GOTO 400 C IN OAS CASE, REFLECTION NOT BELONGING TO A CENTRIC ZONE C WILL BE SELECTED DIRECTLY. 390 MZR=MZR+1 IF(ICOMP.GT.0) WRITE(1,580) LH(I),LK(I),LL(I),FO(I), 1 EO(I),COSDP(I),PHIP(I),ESGM(I),XSIN(I),RSL,ITPH(I),SDFO(I) IF(ICOMP.EQ.0) WRITE(1,590) LH(I),LK(I),LL(I),FO(I), 1 EO(I),COSDP(I),PHIP(I),ESGM(I),XSIN(I),RSL,SDFO(I) 400 CONTINUE C-------------------------------------------------------- ELSE C CALCULATE E AND RESCALED F EO(I)=SQRT(ESQ) ED(I)=EO(I) FO(I)=FO(I)*SCF sdfo(i)=sdfo(i)*scf BTP(I)=EXP(-BT(IG)/2*RHO(I)) FO(I)=FO(I)/BTP(I) sdfo(i)=sdfo(i)/btp(i) DFO(I)=DFO(I)*SCF C PACKING INPA(I)=65536*LH(I)+256*(LK(I)+128)+LL(I)+128 INP(I)=INPA(I)*32+ISIGN(1,INPA(I))*IG IF(RHO(I).GT.RHOCUT) GOTO 410 IF(EO(I).GT.EMIN.AND.EO(I).LT.EMAX) GOTO 410 EO(I)=EO(I)+0.2*RHO(I) 410 TMUL=FLOAT(MULT) C DISTRIBUTION OF E WITH SIN(THETA)/LAMBDA N=MIN0(10,INT(1.0+RR*SQRT(RHO(I)))) NHR(N)=NHR(N)+MULT RHR(N)=RHR(N)+ESQ*TMUL NZR=INT(10.0*ESQ)+1 IF(NZR.GT.10) NZR=10+(NZR-9)/2 EE(1)=ED(I) DO 420 J=2,6 EE(J)=EE(J-1)*ED(I) 420 CONTINUE EE(7)=ESQ-1.0 EE(8)=EE(7)*EE(7) EE(9)=EE(8)*EE(7) EE(10)=ABS(EE(9)) EE(7)=ABS(EE(7)) DO 430 J=1,10 EE(J)=TMUL*EE(J) 430 CONTINUE C ADD FUNCTIONS OF E TO APPROPRIATE ZONES IND=1 J=LH(I) K=LK(I) L=LL(I) CALL ADD(1) GOTO (440,440,440,450,460,460,470,480),KSYS C TRICLINIC, MONOCLINIC AND ORTHORHOMBIC 440 IF(J.EQ.0) CALL ADD(3) IF(K.EQ.0) CALL ADD(4) IF(L.EQ.0) CALL ADD(5) GOTO 500 C TETRAGONAL 450 IF(J.EQ.0.OR.K.EQ.0) CALL ADD(3) IF(IABS(J).EQ.IABS(K)) CALL ADD(4) IF(L.EQ.0) CALL ADD(5) GOTO 500 C TRIGONAL, HEXAGONAL AND RHOMBOHEDRAL INDEXED ON HEXAGONAL AXES 460 IF(J.EQ.0.OR.K.EQ.0.OR.J+K.EQ.0) CALL ADD(3) IF(J.EQ.K.OR.J+2*K.EQ.0.OR.2*J+K.EQ.0) CALL ADD(4) IF(L.EQ.0) CALL ADD(5) GOTO 500 C PRIMITIVE RHOMBOHEDRAL 470 IF(J.EQ.K.OR.J.EQ.L.OR.K.EQ.L) CALL ADD(3) IF(L.EQ.2*K-J.OR.K.EQ.2*J-L.OR.J.EQ.2*L-K) CALL ADD(4) IF(J+K+L.EQ.0) CALL ADD(5) GOTO 500 C CUBIC 480 IF(J.EQ.0.OR.K.EQ.0.OR.L.EQ.0) CALL ADD(3) IF(IABS(J).EQ.IABS(K).OR.IABS(J).EQ.IABS(L).OR.IABS(K).EQ.IABS(L)) 1 CALL ADD(4) C H,H,2H IS IN TWO PRINCIPAL ZONES BUT NOT ON A PRINCIPAL AXIS IF(IND.EQ.4) IND=0 IF(IABS(L).EQ.IABS(J+K).OR.IABS(K).EQ.IABS(J+L).OR.IABS(J). 1 EQ.IABS(K+L)) CALL ADD(5) C REFLEXIONS NOT BELONGING TO PRINCIPAL ZONES 500 IF(IND.EQ.1) CALL ADD(2) C DISTRIBUTION OF E FOR COMPLETE DATA NET=MIN0(25,INT(10.0*ED(I))) IF(NET.EQ.0) GOTO 510 NU(NET)=NU(NET)+1 510 NRW=NRW+MULT ENDIF 520 CONTINUE 540 CONTINUE IF(IDTYPE.LT.0) THEN IF(ICOMP.EQ.0) WRITE(9,550) (LH(K),LK(K),LL(K),FO(K),BTP(K), 1 SFJ2(K),EO(K),DFO(K),SDFO(K),K=1,MF) 550 FORMAT (1X,3I4,F7.1,F8.4,F11.3,F7.3,F7.1,F7.2) IF(ICOMP.GT.0) WRITE(9,560) (LH(K),LK(K),LL(K),FO(K),BTP(K), 1 SFJ2(K),EO(K),DFO(K),ITPH(K),SDFO(K),K=1,MF) 560 FORMAT (1X,3I4,F7.1,F8.4,F11.3,F7.3,F7.1,I6,F7.2) IF(FO(MF).LT.0.0) MF=MF-1 C LIST REFLEXIONS IF REQUIRED IF(LIST.EQ.1.AND.MF.NE.0) 1 WRITE(6,570) (LH(K),LK(K),LL(K),FO(K),ED(K),K=1,MF) C FORMAT FOR REFLEXION LIST - A WIDER LINEPRINTER MAY ALLOW MORE C REFLEXIONS TO BE OUTPUT ON ONE LINE - THUS SAVING PAPER 570 FORMAT(3(' ',3I3,F7.1,F5.2,1X)) ENDIF C TEST FOR END OF DATA IF(MF.EQ.60.and.fo(mf).gt.0.) GOTO 360 IF(IDTYPE.GT.0) THEN NUMB=MC+MZR NUMB=MIN0(NUMB,MAXRE) MC=NUMB-MZR DO 600 K=1,MC IF(ICOMP.GT.0) WRITE(1,580) MH(K),MK(K),ML(K),FOM(K), 1 EOM(K),CDPM(K),PHIM(K),ESGMM(K),XSINM(K),RSLM(K),MTPH(K),SDM(K) 580 FORMAT(3I4,F8.1,F7.3,F9.4,F7.1,F9.5,F8.3,F7.2,I5,F8.2) IF(ICOMP.EQ.0) WRITE(1,590) MH(K),MK(K),ML(K),FOM(K), 1 EOM(K),CDPM(K),PHIM(K),ESGMM(K),XSINM(K),RSLM(K),SDM(K) 590 FORMAT(3I4,F8.1,F7.3,F9.4,F7.1,F9.5,F8.3,F7.2,F8.2) 600 CONTINUE c CLOSE (9) RETURN ELSE C OUTPUT STATISTICS RR=1.0/RR DO 620 I=1,10 STL(I)=RR*FLOAT(I) IF(NHR(I).GT.0) RHR(I)=RHR(I)/FLOAT(NHR(I)) DO 610 J=1,5 IF(NST(J).GT.0) VST(I,J)=VST(I,J)/FLOAT(NST(J)) 610 CONTINUE 620 CONTINUE WRITE(6,630) STL,RHR,NHR 630 FORMAT(///1X,32X,'FINAL STATISTICS'//' ',17X, 1 'DISTRIBUTION OF E**2 WITH SIN(THETA)/LAMBDA'/' SIN/LAM', 2 F6.4,9F7.4/' ',1X,'E**2',2X,F6.4,9F7.4/' ','NUMBER',10I7) WRITE(6,640) 640 FORMAT(//1X,32X,'AVERAGE VALUES', 1 //1X,4X,'AVERAGE',19X,'EXPERIMENTAL',19X,'THEORETICAL') IF (KSYS.LE.6) THEN ICHR(53)='H' ICHR(54)='K' ICHR(55)='0' IF (KSYS.LE.3) THEN ICHR(46)='H' ICHR(47)='0' ICHR(48)='L' ELSE ICHR(46)='H' ICHR(47)='H' ICHR(48)='L' ENDIF ELSE ICHR(50)='H' ICHR(51)=',' ICHR(52)='K' ICHR(53)=',' ICHR(54)='-' ICHR(55)='H' ICHR(56)='-' ICHR(57)='K' IF (KSYS.EQ.7) THEN ICHR(35)='H' ICHR(36)=',' ICHR(37)='K' ICHR(38)='2' ICHR(39)='K' ICHR(40)='-' ICHR(41)='H' ENDIF ENDIF WRITE(6,642) ICHR 642 FORMAT(80A1/) WRITE(6,643) ((VST(I,J),J=1,5),AVA(I),AVC(I),AVH(I),I=1,10) 643 FORMAT(' ',5X,'MOD(E)',8X,8F7.3/ 1 ' ',6X,'E**2',9X,8F7.3/ 2 ' ',6X,'E**3',9X,8F7.3/ 3 ' ',6X,'E**4',9X,8F7.3/ 4 ' ',6X,'E**5',9X,8F7.3/ 5 ' ',6X,'E**6',9X,8F7.3/ 6 ' ',2X,'HMOD(E**2-1)',6X,8F7.3/ 7 ' ',2X,'(E**2-1)**2',6X,8F7.3/ 8 ' ',2X,'(E**2-1)**3',6X,8F7.3/ 9 ' ','(MOD(E**2-1))**3',3X,8F7.3) WRITE(6,750) NST 750 FORMAT(1X,'WEIGHTED SAMPLE SIZE',I6,4I7) WRITE(6,760) 760 FORMAT(//18X,'DISTRIBUTION OF E - NUMBER OF ','E''S .GT. LIMIT') DO 780 I=1,25 AVR(I)=0.1*FLOAT(I) II=I+1 IF(II.GT.25) GOTO 780 DO 770 J=II,25 NU(I)=NU(I)+NU(J) 770 CONTINUE 780 CONTINUE WRITE(6,800) (AVR(I),I= 7,16),(NU(I),I= 7,16), 1 (AVR(I),I=17,25),(NU(I),I=17,25) 800 FORMAT(' ',7X,'E ',10F6.1/' ',6X,'NO. ',10I6// 1 ' ',7X,'E ',9F6.1,6X/' ',6X,'NO. ',9I6) ENDIF RETURN END C -------- SUBROUTINE ADD(N) C SUMS FOR REFLEXION IN ZONE N COMMON/STTTIC/VST(10,5),NST(5),ZT(25,5),EE(10),MULT,IND,NZR,TMUL IS=1 NT=N IF(N.LE.2.OR.IND.LE.1) GOTO 20 C REFLEXION IS ON PRINCIPAL AXIS - THEREFORE IGNORE IT NT=IND IS=-1 20 S=FLOAT(IS) DO 30 I=1,10 VST(I,NT)=VST(I,NT)+S*EE(I) 30 CONTINUE NST(NT)=NST(NT)+IS*MULT IF(NZR.LE.25) ZT(NZR,NT)=ZT(NZR,NT)+S*TMUL IND=N RETURN END CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C FFFFFFF CCCCC A L C C F C C A A L C C F C A A L C C FFFFF C A A L C C F C AAAAAAA L C C F C C A A L C C F CCCCC A A LLLLLLL C C C C CALCULATE RHO, EPSILON, MULTIPLICITY AND SCATTERING FACTOR C C CREATE THE SCRATCH TAPE (CH.=8), PREPARE FILE FOR WEIGHTED FOURIER C C VERSION 1996 C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC SUBROUTINE FCAL PARAMETER (MAXRE=150000) COMMON/ATMGROUP/NINF(10),NAG(10),X(500),Y(500),Z(500),NZ(500), 1 Q(500),U11(500),U22(500),U33(500),U23(500),U13(500),U12(500) COMMON/REFLXIN/LH(60),LK(60),LL(60),FO(60),ID(60),RHO(60),DFO(60), 1 EO(60),BTP(60),ITPH(60),ED(60),EDP(60),SDFO(60) COMMON/REFLXOUT/FH(60),XKP(60),PHIP(60),DELT(60),SFJ2(60) COMMON/OUT/MH(MAXRE),MK(MAXRE),ML(MAXRE),MTPH(MAXRE),FOM(MAXRE), 1 EOM(MAXRE),CDPM(MAXRE),PHIM(MAXRE),ESGMM(MAXRE), 2 XSINM(MAXRE),RSLM(MAXRE),SDM(MAXRE) COMMON/RESCALING/MG,BT(9),SC(9),SCAL(8) COMMON/SCATFACTOR/GIS(142),GIW(142),NGP COMMON/SYMMETRY/IS(3,3,24),TS(3,24),NSYM,PTS,KSYS,ICENT,LATT COMMON/UNIT_OAS/ITLE(80),LIST,PI,IDTYPE,DEVIAT,ICOMP COMMON/WILSON/FLGW(30),FLGD(30),AVR(30),SLOPE,DEL(9),KS(9) COMMON/XXX/P(6),CX(9),NREF,NPWP,RHOMAX,MREF,EMAX,EMIN,RHOCUT, 1 SIGCUT,ZCG(8),ZOG(8),KNOWN,KMIN,ISGM2,NCYC,ISIMP,IFIT DIMENSION I1(3),I2(3) CHARACTER ITLE DO 300 I=1,60 IF(FO(I).LT.0.0) GOTO 310 NREF=NREF+1 RHO(I)=P(1)*FLOAT(LH(I)*LH(I))+P(2)*FLOAT(LK(I)*LK(I)) 1 +P(3)*FLOAT(LL(I)*LL(I))+P(4)*FLOAT(LH(I)*LK(I)) 2 +P(5)*FLOAT(LH(I)*LL(I))+P(6)*FLOAT(LK(I)*LL(I)) RHOMAX=AMAX1(RHOMAX,RHO(I)) C COMPUTE EPSILON AND MULTIPLICITY BY GENERATING EQUIVALENT C REFLEXIONS C EPSILON = NUMBER OF TIMES SAME REFLEXION APPEARS IN LIST C MULTIPLICITY = NUMBER DIFFERENT REFLEXIONS IN LIST EPS=1.0 MULT=1 I1(1)=LH(I) I1(2)=LK(I) I1(3)=LL(I) C IN TRICLINIC SPACE GROUPS EPS = 1.0 AND MULT = 1 IF(NSYM.EQ.1) GOTO 60 K1=65536*I1(1)+256*(I1(2)+128)+I1(3)+128 IK1=65792-K1 DO 50 J=2,NSYM DO 40 L=1,3 I2(L)=IS(L,1,J)*I1(1) + IS(L,2,J)*I1(2) + IS(L,3,J)*I1(3) 40 CONTINUE K2=65536*I2(1)+256*(I2(2)+128)+I2(3)+128 IF(K2.EQ.K1) EPS=EPS+1.0 IF(ICENT.NE.0.AND.K2.EQ.IK1) EPS=EPS+1.0 IF(K2.EQ.K1.OR.K2.EQ.IK1) MULT=MULT+1 50 CONTINUE 60 IF(IDTYPE.LT.0) THEN FF=FO(I)*FO(I)/PTS ELSE FF=DFO(I)*DFO(I)/PTS ENDIF ID(I)=NSYM/MULT C DETERMINE INDEX GROUP (FOR RESCALING) MG=8 IF(KSYS.GT.3) MG=6 IF(KSYS.GE.7) GOTO 90 LG=MOD(IABS(LL(I)),2) IF(KSYS.GE.5) GOTO 80 KG=MOD(IABS(LK(I)),2) JG=MOD(IABS(LH(I)),2) C TRICLINIC, MONCLINIC AND ORTHORHOMBIC IF(KSYS.LE.3) IG=JG+2*KG+4*LG C TETRAGONAL IF(KSYS.EQ.4) IG=JG+KG+3*LG GOTO 100 C TRIGONAL, HEXAGONAL AND RHOMBOHEDRAL INDEXED ON HEXAGONAL AXES 80 IG=3*LG IF(MOD(LH(I),3).EQ.0) IG=IG+1 IF(MOD(LK(I),3).EQ.0.OR.MOD(LH(I)+LK(I),3).EQ.0) IG=IG+1 GOTO 100 C CUBIC AND PRIMITIVE RHOMBOHEDRAL 90 IG=3*MOD(IABS(LH(I)+LK(I)+LL(I)),2) IF(MOD(LH(I)-LL(I),3).EQ.0) IG=IG+1 IF(MOD(LK(I)-LL(I),3).EQ.0.OR.MOD(LH(I)-LK(I),3).EQ.0) IG=IG+1 C PACK SYMMETRY FUNCTIONS FOR LATER USE 100 IG=IG+1 ID(I)=10000*ID(I)+100*INT(EPS+0.5)+IG C LOOK UP SCATTERING FACTOR TABLES GENERATED BY ATMCOEF SINTH=100.0*SQRT(RHO(I)) IND=MAX0(2,INT(SINTH+1.5)) FRAC=SINTH-FLOAT(IND-1) BF=0.5*(GIW(IND+1)-GIW(IND-1)) AF=BF+GIW(IND-1)-GIW(IND) WFORM=AF*FRAC*FRAC+BF*FRAC+GIW(IND) IF(IDTYPE.LT.0) SFJ2(I)=WFORM C 'WILSON' STRUCTURE FACTOR ED(I)=FF/(WFORM*EPS) BF=0.5*(GIS(IND+1)-GIS(IND-1)) AF=BF+GIS(IND-1)-GIS(IND) FORM=AF*FRAC*FRAC+BF*FRAC+GIS(IND) IF(IDTYPE.LT.0) GOTO 300 IF(KNOWN.EQ.1) GOTO 105 C 'DEBYE' STRUCTURE FACTOR ED(I)=FF/(FORM*EPS) GOTO 300 105 NS=1 C PHASES FOR WEIGHTED F-MAP DO 110 IGP=1,NGP NF=NS+NAG(IGP)-1 IF(NINF(IGP).EQ.4) GOTO 120 NS=NF+1 110 CONTINUE 120 REL=0.0 REL2=0.0 RIM=0.0 RIM2=0.0 IENT=0 DO 160 J=1,NSYM T=1000.0 DO 150 L=1,3 T=T+FLOAT(I1(L))*TS(L,J) I2(L)=IS(L,1,J)*I1(1) + IS(L,2,J)*I1(2) + IS(L,3,J)*I1(3) 150 CONTINUE CALL SFAC(NS,NF,I2,T,RHO(I),A,B,A2,B2,IENT) IENT=1 REL=REL+A REL2=REL2+A2 IF(ICENT.EQ.0) RIM=RIM+B IF(ICENT.EQ.0.AND.IDTYPE.EQ.1) RIM2=RIM2+B2 IF(ICENT.EQ.1) REL=REL+A IF(ICENT.EQ.1.AND.IDTYPE.EQ.1) REL2=REL2+A2 160 CONTINUE IIG=1 FCL=PTS*SQRT(REL*REL+RIM*RIM) XKP(I) = 2.0*FO(I)*FCL/(SFJ2(I)-WFORM)/EPS/PTS WEIGHT=0.5 IF(IDTYPE.EQ.1) THEN C SIM WEIGHTING SCHEME FOR *OAS* DATA FH(I)=PTS*SQRT(REL2*REL2+RIM2*RIM2) IF(FH(I).LT.0.001)FH(I)=0.001 PHIP(I)=ATAN2(REL2,-RIM2) DELT(I)=ATAN2(RIM,REL)-PHIP(I) IF(ABS(XKP(I)).GT.0.000001) WEIGHT=BS10(XKP(I))/XKP(I) IF(NINF(IGP).EQ.4)EDP(I)=FF/((4*(FH(I)**2/PTS+FORM*EPS))*WEIGHT) ELSE C SIM WEIGHTING SCHEME FOR *SIR* DATA FH(I)=FCL PHIP(I)=ATAN2(RIM,REL) DELT(I)=0.0 IF(ABS(XKP(I)).GT.0.000001) WEIGHT=1-BS10(XKP(I))/XKP(I) IF(NINF(IGP).EQ.4.)EDP(I)=FF/((FCL**2/PTS+FORM*EPS)*WEIGHT) ENDIF 300 CONTINUE I=60 C CREATE SCRATCH FILE 310 WRITE(8) LH,LK,LL,FO,ID,ED,RHO,EDP,DFO, 1 FH,XKP,PHIP,EO,SFJ2,ITPH,BTP,DELT,SDFO RETURN END C ------------------ C BESSEL FUNCTION I1(X)/I0(X) FUNCTION BS10(X) REAL*8 Y,P1,P2,P3,P4,P5,P6,P7,Q1,Q2,Q3,Q4,Q5,Q6,Q7,Q8,Q9, 1 R1,R2,R3,R4,R5,R6,R7,S1,S2,S3,S4,S5,S6,S7,S8,S9 DATA P1,P2,P3,P4,P5,P6,P7/1.0D0,3.5156229D0,3.0899424D0, 1 1.2067492D0,0.2659732D0,0.360768D-1,0.45813D-2/, 2 Q1,Q2,Q3,Q4,Q5,Q6,Q7,Q8,Q9/0.39894228D0,0.1328592D-1, 3 0.225319D-2,-0.157565D-2,0.916281D-2,-0.2057706D-1, 4 0.2635537D-1,-0.1647633D-1,0.392377D-2/, 5 R1,R2,R3,R4,R5,R6,R7/0.5D0,0.87890594D0,0.51498869D0, 6 0.15084934D0,0.2658733D-1,0.301532D-2,0.32411D-3/, 7 S1,S2,S3,S4,S5,S6,S7,S8,S9/0.39894228D0,-0.3988024D-1, 8 -0.362018D-2,0.163801D-2,-0.1031555D-1,0.2282967D-1, 9 -0.2895312D-1,0.1787654D-1,-0.420059D-2/ IF (ABS(X).LT.3.75) THEN Y=(X/3.75)**2 BS10=X*(R1+Y*(R2+Y*(R3+Y*(R4+Y*(R5+Y*(R6+Y*R7)))))) 1 /(P1+Y*(P2+Y*(P3+Y*(P4+Y*(P5+Y*(P6+Y*P7)))))) ELSE Y=3.75/ABS(X) BS10=(S1+Y*(S2+Y*(S3+Y*(S4+Y*(S5+Y*(S6+Y*(S7+Y*(S8+Y*S9)))))))) 1 /(Q1+Y*(Q2+Y*(Q3+Y*(Q4+Y*(Q5+Y*(Q6+Y*(Q7+Y*(Q8+Y*Q9)))))))) ENDIF RETURN END C----------------------------------------------------------------------- SUBROUTINE INCELL(VOLUME) C INPUT UNIT CELL PARAMETERS AND CALCULATE RECIPROCAL PARAMETERS COMMON/UNIT_OAS/ITLE(80),LIST,PI,IDTYPE,DEVIAT,ICOMP COMMON/XXX/P(6),CX(9),NREF,NPWP,RHOMAX,MREF,EMAX,EMIN,RHOCUT, 1 SIGCUT,ZCG(8),ZOG(8),KNOWN,KMIN,ISGM2,NCYC,ISIMP,IFIT CHARACTER ITLE WRITE(6,20) (CX(I),I=1,6) 20 FORMAT(/1X,'UNIT CELL:',7X,'A =',F8.3,7X,'B =',F8.3,7X, 1 'C =',F8.3/14X,'ALPHA =',F7.2,5X,'BETA =',F7.2,4X,'GAMMA =',F7.2) CALL VOL(CX,V) C VOLUME AND RECIPROCAL CELL FUNCTIONS V=1.0/(V*CX(1)*CX(2)*CX(3)) VOLUME=1.0/V P(1)=CX(2)*CX(3)*CX(7)*V P(2)=CX(1)*CX(3)*CX(8)*V P(3)=CX(1)*CX(2)*CX(9)*V P(4)=0.5*P(1)*P(2)*(CX(4)*CX(5)-CX(6))/(CX(7)*CX(8)) P(5)=0.5*P(1)*P(3)*(CX(4)*CX(6)-CX(5))/(CX(7)*CX(9)) P(6)=0.5*P(2)*P(3)*(CX(5)*CX(6)-CX(4))/(CX(8)*CX(9)) DO 40 I=1,3 P(I)=0.25*P(I)*P(I) CX(I+3)=180.0*ATAN2(CX(I+6),CX(I+3))/PI 40 CONTINUE RETURN END CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C IIIIIII N N PPPPPP U U TTTTTTT C C I NN N P P U U T C C I N N N P P U U T C C I N N N PPPPPP U U T C C I N N N P U U T C C I N NN P U U T C C IIIIIII N N P UUUUU T C C C C FREE FORMAT INPUT ROUTINE C C VERSION 1996 C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC SUBROUTINE INPUT_OAS(IPASS) CHARACTER*8 CDATE,CTIME COMMON/DATETIME/ CDATE,CTIME COMMON/ATMFACTOR/AL(8),AS(8),BL(8),BS(8),CL(8),CS(8),DL(8),DS(8), 1 EL(8),NW(8),NO(8),NK,NAT,F(9),F2(9) COMMON/ATMGROUP/NINF(10),NAG(10),X(500),Y(500),Z(500),NZ(500), 1 Q(500),U11(500),U22(500),U33(500),U23(500),U13(500),U12(500) COMMON/REFLXIN/LH(60),LK(60),LL(60),FO(60),ID(60),RHO(60),DFO(60), 1 EO(60),BTP(60),ITPH(60),ED(60),EDP(60),SDFO(60) COMMON/RESCALING/MG,BT(9),SC(9),SCAL(8) COMMON/SCATFACTOR/GIS(142),GIW(142),NGP COMMON/SYMMETRY/IS(3,3,24),TS(3,24),NSYM,PTS,KSYS,ICENT,LATT COMMON/UNIT_OAS/ITLE(80),LIST,PI,IDTYPE,DEVIAT,ICOMP COMMON/XXX/P(6),CX(9),NREF,NPWP,RHOMAX,MREF,EMAX,EMIN,RHOCUT, 1 SIGCUT,ZCG(8),ZOG(8),KNOWN,KMIN,ISGM2,NCYC,ISIMP,IFIT CHARACTER N(80),LETT(26),KX(10),KSP,KM,KD,KEQ,KP,KSC,ITERM(4), 1 NGS(26),M(80),ITLE,LETT1(26) DIMENSION POP(10),NA(8),CR(9,10),KEYWRD(39) DIMENSION ICONV(250),WTFOM(3),IDIV(20),IB(20) real cellp(6) DATA LETT/'A','B','C','D','E','F','G','H','I','J','K','L','M', 1 'N','O','P','Q','R','S','T','U','V','W','X','Y','Z'/ DATA LETT1/'a','b','c','d','e','f','g','h','i','j','k','l','m', 1 'n','o','p','q','r','s','t','u','v','w','x','y','z'/ DATA KX/'0','1','2','3','4','5','6','7','8','9'/ DATA KSP/' '/,KM/'-'/,KD/'.'/ DATA KEQ/'='/,KP/'+'/,KSC/';'/ DATA ITERM/'H','K','L','N'/ DATA IOFR/0/,NANY/0/,ANOM/0.0/,KMIN/0/,NDET/0/,LIST/-1/,IFIT/0/, 2 NGEN/0/,SIGCUT/0./,NINPUT/0/,KMAX/5000/,NRAN/250/,IWT/2/,NSREQ/0/ DATA KEYWRD/1000,2000,3000,11220,11415,30512,31514,32503,40520, C-KEYWD ALT ANO CEL CON CYC DET 2 51301,51309,51401,60103,60920,61513,70514,80315,111301, C-KEYWD EMA EMI ENA FAC FIT FOM GEN HCO KMA 3 111309,120102,120305,120913,120919,130124, C-KEYWD KMI LAB LCE LIM LIS MAX 4 140803,141623,141801,141805,150119,151806,151809,151814, C-KEYWD NHC NPW NRA NRE OAS ORF ORI ORN 5 160809,160818,161220,161519,180519,190918,190907/ C-KEYWD PHI PHR PLT POS RES SIR SIG C NAME OF THE WHOLE PACKAGE, TO BE PRINTED OUT ONLY WITH JOB REMARKS 10 FORMAT(////// &' SSSSSSSS AA PPPPPPPPP IIIIII '/ &' SSSSSSSSSS AAAA PPPPPPPPPP IIIIII '/ &' SS SS AA AA PP PP II '/ &' SS AA AA PP PP II 9999 6666 '/ &' SSSSSSSSS AA AA PPPPPPPPPP II 9 9 6 6 '/ &' SSSSSSSSS AA AA PPPPPPPPP II 9 9 6 '/ &' SS AAAAAAAAAA PP II === 99999 66666 '/ &' SS SS AAAAAAAAAA PP II 9 6 6 '/ &' SSSSSSSSSS AA AA PP IIIIII 9 9 6 6 '/ &' SSSSSSSS AA AA PP IIIIII 9999 6666 '/ &/////) C SET INITIAL AND DEFAULT VALUES DO 12 I=1,500 X(I)=0.0 Y(I)=0.0 Z(I)=0.0 Q(I)=1.0 U11(I)=0.0 U22(I)=0.0 U33(I)=0.0 U23(I)=0.0 U13(I)=0.0 U12(I)=0.0 12 CONTINUE DO 20 I=1,250 ICONV(I)=0 IF(I.GT.20) GOTO 20 IB(I)=0 IDIV(I)=0 IF(I.GT.10) GOTO 20 NINF(I)=0 IF(I.GT.8) GOTO 20 F2(I)=0.000 AL(I)=0.000 AS(I)=0.000 BL(I)=0.000 BS(I)=0.000 CL(I)=0.000 CS(I)=0.000 DL(I)=0.000 DS(I)=0.000 EL(I)=0.000 SCAL(I)=0.0 SC(I)=-1.0 NW(I)=0 NO(I)=0 BT(I)=-10.0 20 CONTINUE C DEFAULT UNIT CELL CONTENT: C ATOM --- CARBON. THE NUMBER OF WHICH IS TO BE ESTIMATED C ACCORDING TO THE VOLUME OF UNIT CELL NK=1 NW(1)=3 NA(1)=-100 ITPR=0 IND=1 MREF=0 NPWP=0 LIST=0 NTOT=0 NGP=0 NCYC=1 DEVIAT = 7.0 ICOMP = 0 IDTYPE = -1 IF (IPASS.EQ.1) then NSYM = 1 pts = 1 ICENT = 0 C -- flag latt = 0 cx(1) = 0.0 end if ISGM2=0 ISIMP=1 RHOCUT=1.0 EMAX=20.0 EMIN=0.001 80 KS=1 READ(10,90) N 90 FORMAT(80A1) 100 KEY=0 IKW=0 IC=0 IMK=0 IM=1 110 DO 200 I=KS,80 DO 120 K=1,26 IF(LETT(K).EQ.N(I).or.lett1(k).eq.n(i)) GOTO 190 120 CONTINUE IF(IKW.EQ.0) GOTO 200 IF(IKW.LT.3.AND.N(I).EQ.KSP) GOTO 185 IF(IKW.LT.3) GOTO 6000 IF(IC.GT.20) GOTO 200 DO 130 K=1,10 IF(KX(K).EQ.N(I)) GOTO 180 130 CONTINUE IF(N(I).EQ.KD) GOTO 170 IF(N(I).EQ.KM) GOTO 150 IM=1 IF(N(I).EQ.KSP) GOTO 160 150 IM=-1 160 IF(IMK.LE.0) IC=IC+1 IB(IC)=0 IDIV(IC)=0 IMK=1 GOTO 200 170 IMK=-1 GOTO 200 180 IB(IC)=IM*(10*IABS(IB(IC))+K-1) IF(IMK.EQ.1) IMK=0 IF(IMK.LT.0) IDIV(IC)=IDIV(IC)-1 C TEST FOR REMARKS IF(KEY.EQ.180513) GOTO 300 GOTO 200 185 GOTO (6000,6000,2100,2200,2300),IND 190 IF(IC.GT.0) GOTO 210 IF(IKW.GE.3) GOTO 200 IKW=IKW+1 KEY=100*KEY+K IF(IKW.LT.3) GOTO 200 C TEST FOR END OF KEYWORD FILE IF(KEY.EQ.51404) GOTO 2800 C (REMARK) IF(KEY.EQ.180513.OR.ITPR.EQ.1) GOTO 195 C PRINT TITLE WRITE(6,360) ITLE C PRINT INITIAL TIME WRITE(6,370) CDATE,CTIME ITPR=1 C (SPACE GROUP) 195 IF(KEY.EQ.191607) GOTO 1630 200 CONTINUE KS=1 READ(10,90) N GOTO 110 210 KS=I DO 250 II=1,39 IF(KEY.NE.KEYWRD(II)) GOTO 250 GOTO (2150,2250,2350,430,460,610,630,685,690, C-KEYWD ALT ANO CEL CON CYC DET 2 765, 770, 780,810,835,837,840,635,910,920, 80,952, C-KEYWD EMA EMI ENA FAC FIT FOM GEN HCO KMA KMI LAB LCE 3 955, 960,980,1255,1310,1320,1330,1340,1350, C-KEYWD LIM LIS MAX NHC NPW NRA NRE OAS ORF 4 1360,1370,1430,1437,1440,1445,1550,1610,1650), II C-KEYWD ORI ORN PHI PHR PLT POS RES SIR SIG 250 CONTINUE GOTO 6000 300 IF(IPASS.EQ.1) WRITE(6,10) ITPR=1 IREM=IB(1) DO 340 I=1,IREM READ(10,90) N WRITE(6,330) N 330 FORMAT(50X,80A1) 340 CONTINUE C PRINT JOB TITLE WRITE(6,360) ITLE 360 FORMAT(1X,'PROGRAM FOR PRELIMINARY PROCESSING OF INPUT ', 1 'DATA',12X,'VERSION 1999'//80A1) C PRINT INITIAL TIME WRITE(6,370) CDATE,CTIME 370 FORMAT(53X,A8,3X,A8) GOTO 80 C *** KEYWORD PROCESSING *** C *ALT* LIST A FULL CONVERGENCE MAP 430 LIST = 1 GOTO 100 C *ANO* IMAGINARY CORRECTION TO ANOMALOUS SCATTERING FACTORS 460 IF (IPASS.EQ.2) THEN IND=5 ANOM=1.0 GOTO 100 ELSE 465 READ(10,90) N IF(N(1).EQ.' ')GOTO 465 KS=1 GOTO 100 END IF C *CEL* CELL DIMENSIONS 610 IF(IC.NE.7) GOTO 6000 DO 615 J=1,6 IF(NGP.EQ.0) CX(J)=FLOAT(IB(J))*10.0**IDIV(J) 615 CONTINUE CALL INCELL(VOLUME) IF(NA(1).LT.0) NA(1)=VOLUME*0.036 GOTO 100 C *CON* CONTENTS OF THE UNIT CELL 630 IF (IPASS.EQ.1) THEN NK=0 IND=3 GOTO 100 ELSE GOTO 80 END IF C *HCO* HEAVY ATOM CONTENTS OF THE UNIT CELL 635 IF (IPASS.EQ.2) THEN NK=0 IND=3 GOTO 100 ELSE GOTO 80 END IF C *CYC* NUMBER OF CYCLES REQUESTED FOR THE ITERATION C OF PROTEIN PHASE DETERMINATION 685 NCYC = IB(1) GOTO 100 C *DET* NUMBER OF PHASES TO BE DETERMINED 690 NDET = IB(1) GOTO 100 CC *EMA* MAXIMUM VALUE OF LARGEST E'S PASSED TO "PHASE" 765 EMAX=FLOAT(IB(1))*10.0**IDIV(1) GOTO 100 CC *EMI* MINIMUM VALUE OF LARGEST E'S PASSED TO "PHASE" 770 EMIN=FLOAT(IB(1))*10.0**IDIV(1) GOTO 100 C *ENA* ENANTIOMORPH FIXING REFLECTION 780 IEND = IC-1 DO 785 II=1,IEND NINPUT = NINPUT + 1 IF (NINPUT.GT.250) GOTO 1720 ICONV(NINPUT) = IB(II) * 1000000 + 300 785 CONTINUE GOTO 100 C *FAC* ANALYTICAL CONSTANTS OF ATOMIC SCATTERING FACTORS 810 IND=5 GOTO 100 C *FIT* FIT PROTEIN PHASE DIFFERENCES TO A UNIFORM DISTRIBUTION 835 IFIT = 1 GOTO 100 C *FOM* 837 ICOMP = 2 GOTO 100 CC *GEN* NUMBER OF GENERAL REFLECTIONS IN STARTING SET 840 NGEN = IB(1) GOTO 100 C *KMA* MAXIMUM KAPPA-VALUE ACCEPTED IN "PHASE" 910 KMAX = INT(100.0*FLOAT(IB(1))*10.0**IDIV(1)) GOTO 100 C *KMI* MINIMUM KAPPA-VALUE ACCEPTED IN "PHASE" 920 KMIN = INT(100.0*FLOAT(IB(1))*10.0**IDIV(1)) GOTO 100 C *LCE* LACK OF CLOSURE ERROR FOR PROTEIN DATA 952 DEVIAT=FLOAT(IB(1))*10.0**IDIV(1) GOTO 100 C *LIM* RESOLUTION LIMIT FOR REFLECTIONS TO BE ACCEPTED(ANGSTROM) 955 ANSTRM=FLOAT(IB(1))*10.0**IDIV(1) RHOCUT=1/(4*ANSTRM*ANSTRM) WRITE(6,956) ANSTRM 956 FORMAT(/1X,'LIMIT OF RESOLUTION FOR E TO BE PASSED TO ', 1 'PHASE AND EXFFT =',F7.3,2X,'ANGSTROM'/) GOTO 100 C *LIS* LIST SIGN RESULTS. LAST CYCLE PRINT WITH 3 QUEUE LAYOUT 960 LIST=1 GOTO 100 CC *MAX* MAXIMUM NUMBER OF PHASE SETS TO BE GENERATED 980 NSREQ = IB(1) GOTO 100 C *NHC* NO HEAVY-ATOM CORRECTION FOR THE PROTEIN PHASES 1255 ISIMP = 0 GOTO 100 C *NPW* NUMBER OF POINTS ON WILSON PLOT 1310 NPWP=IB(1) GOTO 100 CC *NRA* NUMBER OF REFLECTIONS IN STARTING SET OF "PHASE" 1320 NRAN = IB(1) GOTO 100 CC *NRE* NUMBER OF LARGEST E'S PASSED TO "PHASE" 1330 MREF=IB(1) GOTO 100 C *OAS* ONE-WAVELENGTH ANOMALOUS SCATTERING DATA 1340 IDTYPE = -1 GOTO 100 CC *ORF* FREE OF ORIGIN FIXATION 1350 IOFR=1 GOTO 100 CC *ORI* ORIENTED MOLECULAR GROUP 1360 IND=3 GOTO 1710 CC *ORN* CODES OF ORIGIN FIXING REFLECTIONS 1370 IEND = IC-1 DO 1375 II=1,IEND NINPUT = NINPUT + 1 IF (NINPUT.GT.250) GOTO 1720 ICONV(NINPUT) = IB(II) * 1000000 + 200 1375 CONTINUE GOTO 100 C *PHI* PHASES AVAILABLE FOR COMPARISON 1430 ICOMP = 1 GOTO 100 C *PHR* PHASE RELATIONSHIPS ALREADY AVAILABLE 1437 ISGM2 = 1 GOTO 100 CC *PLT* PARTIAL LIST OF CONVERGENCE MAP 1440 LIST = 0 GOTO 100 C *POS* POSITIONED MOLECULAR GROUP 1445 IF (IPASS.EQ.2) THEN IND=4 GOTO 1710 ELSE 1447 READ(10,90) N IF(N(1).EQ.' ')GOTO 1447 KS=1 GOTO 100 END IF C *RES* high resolution limit 1550 ANSTRM=FLOAT(IB(1))*10.0**IDIV(1) RHOCUT=1/(4*ANSTRM*ANSTRM) WRITE(6,1551) ANSTRM 1551 FORMAT(/1X,'HIGH RESOLUTION LIMIT =',F7.3,2X,'ANGSTROM'/) GOTO 100 C *SIR* SINGLE ISOMORPHOUS REPLACEMENT DATA 1610 IDTYPE = -2 GOTO 100 C *SPG* SET UP LINE FOR SPGR; READ TO SPACE, THEN TO NON-SPACE 1630 IF (IPASS.EQ.1) THEN KS=MAX0(1,MOD(KS+1,81)) IF (N(KS).NE.KSP) GOTO 1630 1640 KS=MAX0(1,MOD(KS+1,81)) IF (N(KS).EQ.KSP) GOTO 1640 CALL SPGR(N,KS,IERR) IF(IERR.EQ.1) GOTO 6000 END IF GOTO 80 CC *SIG* sigma rejection level 1650 SIGCUT = FLOAT(IB(1))*10.0**IDIV(1) GOTO 100 1710 NGP=NGP+1 NINF(NGP)=IND IND=4 NAG(NGP)=0 POP(NGP)=1.0 GOTO 100 1720 WRITE(6,1730) 1730 FORMAT (//1X,'** MORE THAN 250 REFLEXIONS INPUT TO CONVERGE **') GOTO 6000 2100 NK=NK+1 NW(NK)=KEY KEY=1000 IKW=3 GOTO 110 2150 NA(NK)=IB(1) GOTO 100 2200 NAG(NGP)=NAG(NGP)+1 NTOT=NTOT+1 DO 2210 I=1,NK IF(KEY.EQ.NW(I)) GOTO 2230 2210 CONTINUE GOTO 6000 2230 NZ(NTOT)=I KEY=2000 IKW=3 GOTO 110 2250 IF(IC.GT.1) X(NTOT)=FLOAT(IB(1))*10.0**IDIV(1) IF(IC.GT.2) Y(NTOT)=FLOAT(IB(2))*10.0**IDIV(2) IF(IC.GT.3) Z(NTOT)=FLOAT(IB(3))*10.0**IDIV(3) IF(IC.GT.5) Q(NTOT)=FLOAT(IB(5))*10.0**IDIV(5) IF(IC.GT.6) U11(NTOT)=FLOAT(IB(6))*10.0**IDIV(6) IF(IC.GT.7) U22(NTOT)=FLOAT(IB(7))*10.0**IDIV(7) IF(IC.GT.8) U33(NTOT)=FLOAT(IB(8))*10.0**IDIV(8) IF(IC.GT.9) U23(NTOT)=FLOAT(IB(9))*10.0**IDIV(9) IF(IC.GT.10) U13(NTOT)=FLOAT(IB(10))*10.0**IDIV(10) IF(IC.GT.11) U12(NTOT)=FLOAT(IB(11))*10.0**IDIV(11) IF(IC.LE.5) GOTO 100 DO 2270 J=1,8 BT(J)=0.0 2270 CONTINUE GOTO 100 2300 DO 2310 JF=1,NK IF(KEY.EQ.NW(JF)) GOTO 2320 2310 CONTINUE GOTO 6000 2320 KEY=3000 IKW=3 GOTO 110 2350 IF(ANOM.LE.0.5) GOTO 2355 F2(JF)=FLOAT(IB(1))*10.0**IDIV(1) GOTO 100 2355 IF(IC.GT.1) AL(JF)=FLOAT(IB(1))*10.0**IDIV(1) IF(IC.GT.2) AS(JF)=FLOAT(IB(2))*10.0**IDIV(2) IF(IC.GT.3) BL(JF)=FLOAT(IB(3))*10.0**IDIV(3) IF(IC.GT.4) BS(JF)=FLOAT(IB(4))*10.0**IDIV(4) IF(IC.GT.5) CL(JF)=FLOAT(IB(5))*10.0**IDIV(5) IF(IC.GT.6) CS(JF)=FLOAT(IB(6))*10.0**IDIV(6) IF(IC.GT.7) DL(JF)=FLOAT(IB(7))*10.0**IDIV(7) IF(IC.GT.8) DS(JF)=FLOAT(IB(8))*10.0**IDIV(8) IF(IC.GT.9) EL(JF)=FLOAT(IB(9))*10.0**IDIV(9) IF(IC.GT.10) GOTO 6000 GOTO 100 C END OF KEYWORD FILE C MARK FOR WILSON STATISTICS WITH KNOWN ATOMIC POSITIONS 2800 KNOWN=0 DO 2802 L=1,10 IF(NINF(L).EQ.4) KNOWN=1 2802 CONTINUE C CALCULATE ATOMIC SCATTERING FACTORS CALL ATMCOEF NAT=0 DO 2805 L=1,80 M(L)=KSP 2805 CONTINUE if (na(1).lt.0) then CALL LROPEN (1,'HKLIN',1,IFAIL) IF (IFAIL.EQ.1) CALL CCPERR(1,'Error opening HKLIN') CALL LRCELL(1,CELLP) do i = 1, 6 cx(i) = cellp(i) end do call incell(volume) NA(1)=VOLUME*0.036 CALL lrclos(1) end if DO 2810 L=1,NK K=NW(L)/100 J=NW(L)-100*K IF (K.GT.0) M(L)=LETT(K) IF (J.GT.0) M(L+40)=LETT(J) NW(L)=NA(L) NO(L)=INT(AL(L)+BL(L)+CL(L)+DL(L)+EL(L)+0.5) C IF(NO(L).NE.1.OR.IDTYPE.EQ.1) NAT=NAT+NA(L) IF(NO(L).NE.1) NAT=NAT+NA(L) 2810 CONTINUE WRITE(6,2824) (M(L),M(L+40),NA(L),NO(L),L=1,NK) 2824 FORMAT(/1X,'UNIT CELL CONTENTS:'/ 1 1X,22X,'ATOM',3X,'NUMBER IN CELL',2X,'ATOMIC NUMBER'/ 2 (' ',24X,2A1,8X,I5,10X,I3)) WRITE(6,2825) (M(L),M(L+40), 1 AL(L),AS(L),BL(L),BS(L),CL(L),CS(L),DL(L),DS(L),EL(L),L=1,NK) 2825 FORMAT(/1X,'SCATTERING FACTOR CONSTANTS:'//7X,'F=', 1 'AA*EXP(-A*RHO)+BB*EXP(-B*RHO)+CC*EXP(-C*RHO)+DD*EXP(-D*RHO)+E'/ 2 /8X,'AA A BB B CC C DD D', 3 ' E'/ (' ',2A1,9F8.3)) IF(ANOM.LT.0.5) GOTO 2829 WRITE(6,2826) 2826 FORMAT(1X,'IMAGINARY PART OF THE ATOMIC SCATTERING FACTORS') DO 2828 L=1,NK IF(F2(L).GT.0.001) WRITE(6,2827) M(L),M(L+40),F2(L) 2827 FORMAT(1X,2A1,8X,F8.3) 2828 CONTINUE 2829 DO 2830 L=1,142 GIS(L)=0.0 2830 CONTINUE IF(NGP.EQ.0) GOTO 2880 NF=0 DO 2870 L=1,NGP NS=NF+1 NF=NF+NAG(L) IF (NINF(L).EQ.3) WRITE(6,2843) 2843 FORMAT(/1X,'CORRECTLY ORIENTED CLUSTER(S) FOR WILSON STATISTICS:') IF (NINF(L).EQ.4) WRITE(6,2844) 2844 FORMAT(/1X,'CORRECTLY POSITIONED ATOM(S) FOR WILSON STATISTICS:') DO 2860 J=NS,NF K=NZ(J) IF(NINF(L).LE.2) NA(K)=NA(K)-INT(POP(L)+0.5) IF(NINF(L).EQ.4) GOTO 2856 WRITE(6,2854) M(K),M(K+40),X(J),Y(J),Z(J) 2854 FORMAT(' ',9X,2A1,3F15.4) GOTO 2860 2856 NA(K)=NA(K)-INT(NSYM*(ICENT+1)*Q(J)*PTS+0.5) WRITE(6,2858) M(K),M(K+40),X(J),Y(J),Z(J),Q(J) 2858 FORMAT(' ',9X,2A1,4F15.4) 2860 CONTINUE if (na(k).lt.0) then call ccperr(1, + '*** Check *unit cell* contents in CON and HCO ***') end if 2870 CONTINUE C CALCULATE WILSON (GIW) AND DEBYE (GIS) SCATTERING FACTORS 2880 DO 2900 L=1,142 T=0.01*FLOAT(L-1) TT=T*T GIW(L)=0.0 DO 2890 J=1,NK IF(IDTYPE.EQ.1) FZ=F2(J) IF(IDTYPE.NE.1) FZ=AL(J)*EXP(-AS(J)*TT)+BL(J)*EXP(-BS(J)*TT) 1 +CL(J)*EXP(-CS(J)*TT)+DL(J)*EXP(-DS(J)*TT)+EL(J) GIS(L)=GIS(L)+FZ*FZ*FLOAT(NA(J)) GIW(L)=GIW(L)+FZ*FZ*FLOAT(NW(J)) 2890 CONTINUE 2900 CONTINUE 5000 II=0 RETURN 6000 WRITE(6,6010) N 6010 FORMAT(' ERROR IN LINE',5X,80A1) C CLOSE (6) c CLOSE (5) CALL CCPERR(1,' --- ERROR IN PREPARE ---') END C----------------------------------------------------------------------- SUBROUTINE RESCA(KSYS) C INDEX GROUP RESCALING COMMON/REFLXIN/LH(60),LK(60),LL(60),FO(60),ID(60),RHO(60),DFO(60), 1 EO(60),BTP(60),ITPH(60),ED(60),EDP(60),SDFO(60) COMMON/RESCALING/MG,BT(9),SC(9),SCAL(8) COMMON/UNIT_OAS/ITLE(80),LIST,PI,IDTYPE,DEVIAT,ICOMP COMMON/WILSON/FLGW(30),FLGD(30),AVR(30),SLOPE,DEL(9),KS(9) COMMON/XXX/P(6),CX(9),NREF,NPWP,RHOMAX,MREF,EMAX,EMIN,RHOCUT, 1 SIGCUT,ZCG(8),ZOG(8),KNOWN,KMIN,ISGM2,NCYC,ISIMP,IFIT CHARACTER ITLE DIMENSION NG(8),SCS(8) TOT=0.0 IIG=1 NW=0 DO 10 I=1,8 SCS(I)=0.0 NG(I)=0 10 CONTINUE WRITE(6,80) 80 FORMAT(/1X,12X,'***** NORMALIZATION BY LEAST SQUARES STRAIGHT' 1 ,'LINE *****'/) REWIND(8) 100 READ(8) LH,LK,LL,FO,ID,ED,RHO,EDP DO 250 I=1,60 IF(FO(I).LT.0.0) GOTO 300 IF(IDTYPE.GT.0.AND.EDP(I).GT.100.0) GOTO 250 IG=MOD(ID(I),100) IF(KNOWN.EQ.0.OR.IDTYPE.LT.0) GOTO 120 ESQ=EDP(I)*EXP(BT(IG)*RHO(I)) GOTO 140 120 ESQ=ED(I)*EXP(BT(IG)*RHO(I)) C UNPACK SYMMETRY FUNCTIONS 140 MULT=ID(I)/10000 TMUL=FLOAT(MULT) TOT=TOT+ESQ*TMUL NW=NW+MULT SCS(IG)=SCS(IG)+ESQ*TMUL NG(IG)=NG(IG)+MULT 250 CONTINUE GOTO 100 300 TOT=TOT/FLOAT(NW) C MG=8 (PARITY GROUPS) FOR TRICLINIC, MONOCLINIC AND ORTHORHOMBIC C MG=6 (MODIFIED PARITY GROUPS) FOR TETRAGONAL C MG=6 (INDEX GROUPS) IN OTHER SYSTEMS C MG=ANY NUMBER FROM 1 TO 8 FOR SPECIAL RESCALING DO 310 I=1,MG IF(NG(I).GT.0) SCS(I)=SCS(I)/(FLOAT(NG(I))*TOT) 310 CONTINUE WRITE(6,330) 330 FORMAT(/1X,6X,'AVERAGE E**2 ACCORDING TO APPROPRIATE INDEX ', 1 'GROUP BEFORE RESCALING') IF(KSYS.LE.3) WRITE(6,335) 335 FORMAT(/1X,33X,'PARITY GROUPS'/1X,13X,'ALL',4X,'EEE',4X,'OEE', 1 4X,'EOE',4X,'OOE',4X,'EEO',4X,'OEO',4X,'EOO',4X,'OOO') IF(KSYS.EQ.4) WRITE(6,340) 340 FORMAT(/1X,28X,'MODIFIED PARITY GROUPS'/1X,13X,'ALL',5X,'EEE', 1 5X,'EOE,OEE',5X,'OOE',5X,'EEO',5X,'EOO,OEO',5X,'OOO') IF(KSYS.LE.4) GOTO 365 WRITE(6,345) 345 FORMAT(/1X,'INDEX GROUPS DIVIDED ON -') IF(KSYS.LE.6) WRITE(6,350) 350 FORMAT(10X,'1) MOD(H,3)',4X,'2) MOD(K,3)',4X, 1 '3) MOD(H+K,3)',4X,'4) MOD(L,2)') IF(KSYS.GE.7) WRITE(6,355) 355 FORMAT(10X,'1) MOD(H-L,3)',4X,'2) MOD(K-L,3)',4X, 1 '3) MOD(H-K,3)',4X,'4) MOD(H+K+L,2)') WRITE(6,360) 360 FORMAT(/1X,15X,'E - ZERO REMAINDER',4X,'O - NON-ZERO REMAINDER'/ 1 /1X,14X,'ALL',3X,'OOOE',1X,'OOEE,OEOE',1X,'EEEE',1X,'OOOO', 2 1X,'OOEO,OEOO',1X,'EEEO'/' ',27X,'EOOE',17X,'EOOO') 365 TT=1.0000 IF(KSYS.EQ.4) THEN WRITE(6,366) TT,(SCS(I),I=1,MG) WRITE(6,368) NW,(NG(I),I=1,MG) ELSE WRITE(6,370) TT,(SCS(I),I=1,MG) WRITE(6,380) NW,(NG(I),I=1,MG) ENDIF 366 FORMAT(' ',4X,'E**2',2X,F7.3,F8.3,2F10.3,F8.3,2F10.3) 368 FORMAT(' ',3X,'NUMBER',1X,I7,I8,2I10,I8,2I10) 370 FORMAT(' ',4X,'E**2',2X,9F7.3) 380 FORMAT(' ',3X,'NUMBER',1X,9I7) C IF(JUMP.EQ.1) GOTO 500 TOT=1.0/TOT DO 400 I=1,MG SCAL(I)=TOT 400 CONTINUE WRITE(6,542) 542 FORMAT(/1X,11X,'TEMPERATURE AND SCALING FACTORS DERIVED BY THE', 1 ' PROGRAM') C IF (JUMP.EQ.0) WRITE(6,543) C 543 FORMAT(/1X,20X,37HSCALING FACTOR DERIVED BY THE PROGRAM/ C 1 1H ,12X,53H WITH THE TEMPERATURE FACTOR(BT) SUPPLIED BY THE USER) C IF (JUMP.EQ.1) WRITE(6,544) C 544 FORMAT(/1X,6X,41HTEMPERATURE FACTOR(BT) AND SCALING FACTOR, C 1 21H SUPPLIED BY THE USER) WRITE(6,545) 545 FORMAT(' ',16X,'H--- EXP{(-2*BT)*RHO}*FCAL**2=SCALE*FOBS**2 ---'/ 1 ' ',24X,'GROUP',5X,'2*BT',6X,'SCALE') WRITE(6,548) BT(1),SCAL(1) 548 FORMAT(' ',25X,'ALL',F10.4,F11.4) IF(KNOWN.NE.0.AND.IDTYPE.LT.0) WRITE(6,550) 550 FORMAT(10X,'*** NOTE THAT THE SCALING FACTOR HERE IS ', 1 'MEANINGLESS ***') RETURN END C----------------------------------------------------------------------- SUBROUTINE SFAC(NS,NF,L,T,RHO,A,B,A2,B2,IENT) C STRUCTURE FACTOR CALCULATION COMMON/ATMFACTOR/AL(8),AS(8),BL(8),BS(8),CL(8),CS(8),DL(8),DS(8), 1 EL(8),NW(8),NO(8),NK,NAT,F(9),F2(9) COMMON/ATMGROUP/NINF(10),NAG(10),X(500),Y(500),Z(500),NZ(500), 1 Q(500),U11(500),U22(500),U33(500),U23(500),U13(500),U12(500) COMMON/SINETABLE/SINT(450) COMMON/XXX/P(6),CX(9),NREF,NPWP,RHOMAX,MREF,EMAX,EMIN,RHOCUT, 1 SIGCUT,ZCG(8),ZOG(8),KNOWN,KMIN,ISGM2,NCYC,ISIMP,IFIT DIMENSION L(3),COST(360) EQUIVALENCE (SINT(91),COST(1)) A=0.0 B=0.0 A2=0.0 B2=0.0 IF(IENT.EQ.1) GOTO 30 DO 10 I=1,NK F(I)=AL(I)*EXP(-AS(I)*RHO)+BL(I)*EXP(-BS(I)*RHO)+CL(I)*EXP(-CS(I) 1 *RHO)+DL(I)*EXP(-DS(I)*RHO)+EL(I) 10 CONTINUE 30 HJ=FLOAT(L(1)) HK=FLOAT(L(2)) HL=FLOAT(L(3)) DO 50 I=NS,NF N=NZ(I) ARG=AMOD(HJ*X(I)+HK*Y(I)+HL*Z(I)+T,1.0) IARG=INT(360.0*ARG+0.5)+1 IF(IARG.EQ.361) IARG=1 FJ2=F2(N) IF(U11(I).GT.0.00001) GOTO 40 FJ=F(N) GOTO 45 40 UU = U11(I)*HJ*HJ*P(1)+U22(I)*HK*HK*P(2)+U33(I)*HL*HL*P(3) * +U12(I)*HJ*HK*P(4)+U13(I)*HJ*HL*P(5)+U23(I)*HK*HL*P(6) IF(U22(I).LT.0.00001) UU = U11(I)*RHO FJ=F(N)*EXP(-8*3.1416*3.1416*UU) 45 A=A+FJ*Q(I)*COST(IARG) B=B+FJ*Q(I)*SINT(IARG) A2=A2+FJ2*Q(I)*COST(IARG) B2=B2+FJ2*Q(I)*SINT(IARG) 50 CONTINUE RETURN END ************************************************************************ * * * SSSSS PPPPPP GGGGG RRRRRR * * S S P P G G R R * * S P P G R R * * SSSSS PPPPPP G GGGG RRRRRR * * S P G G R R * * S S P G G R R * * SSSSS P GGGGGG R R * * * * DERIVATION OF SYMMETRY OPERATIONS FROM THE SPACE GROUP SYMBOL * * A MODIFICATION OF THE PROGRAM * * BY H.BURZLAFF & A.HOUNTAS, J. APPL. CRYST. 15 (1982) 464-467 * * VERSION 1995 * ************************************************************************ SUBROUTINE SPGR(NCHA,KS,IERR) COMMON/SYMMETRY/IS(3,3,24),TS(3,24),NSYM,PTS,KSYS,ICENT,LATT CHARACTER NCHA(80),NT(16),NV(12),H(31) CHARACTER*4 TEXB(9),TX(6,3) CHARACTER*2 NTEX(42),CGES(3,3,21) DIMENSION LAT(63),ITL(3,3),ISS(3),KSS(3,3),LS(48,3,3),MTS(3,3), * NSV(3,18),NSW(3),NET(3),NES(3),IN(13),NTS(48,3),NCH(31), * IGET(3,13),NGES(3,3,21) DATA NTEX/ ' ',' ',' 0',' 0',' 0',' 0','+1','/8','+1','/6', * ' 0',' 0','+1','/4',' 0',' 0','+1','/3','+3','/8', * ' 0',' 0',' 0',' 0','+1','/2',' 0',' 0',' 0',' 0', * ' 0',' 0','+2','/3',' 0',' 0','+3','/4',' 0',' 0', * '+5','/6'/ DATA TEXB/ ' -Z',' -Y',' X-Y',' -X',' 0.0', * ' X',' Y-X',' Y',' Z'/ ,NV/12*'0'/ DATA H/' ','-','/','0','1','2','3','4','5','6','A','B','C','I','R' * ,'F','P','D','M','N','Y',':','E','U','O','G','Q','T','L','H','X'/ C ALL DIGITAL NUMBER BELOW ARE ASCII CODES FOR EACH CHARACTER ABOVE DATA NCH/ 32,45,47,48,49,50,51,52,53,54,65,66,67,73,82, * 70,80,68,77,78,89,58,69,85,79,71,81,84,76,72,88/ C DATA NGES/1,3*0,1,3*0,1,-1,3*0,-1,3*0,1,0,1,0,2*-1,3*0,1,0,1,0,-1, *4*0,1,0,1,3*0,2*1,2*0,2*1,0,-1,4*0,1,-1,3*0,-1,3*0,-1,1,3*0,1,3*0, * -1,0,-1,0,2*1,3*0,-1,0,-1,0,1,4*0,2*-1,3*0,1,3*0,3*-1,0,1,4*0,-1, *1,3*0,-1,3*0,1,0,1,0,1,4*0,-1,0,-1,0,-1,4*0,2*1,2*0,2*-1,3*0,2*-1, *2*0,2*1,3*0,1,-1,3*0,1,3*0,1,0,1,0,1,4*0,2*1,3*0,-1,3*0,-1,0,-1,0, *-1,4*0,-1/ DATA CGES/' 1',' 0',' 0',' 0',' 1',' 0',' 0',' 0',' 1','-1', * ' 0',' 0',' 0','-1',' 0',' 0',' 0',' 1',' 0',' 1',' 0', * '-1','-1',' 0',' 0',' 0',' 1',' 0',' 1',' 0','-1',' 0', * ' 0',' 0',' 0',' 1',' 0',' 1',' 0',' 0',' 0',' 1',' 1', * ' 0',' 0',' 1',' 1',' 0','-1',' 0',' 0',' 0',' 0',' 1', * '-1',' 0',' 0',' 0','-1',' 0',' 0',' 0','-1',' 1',' 0', * ' 0',' 0',' 1',' 0',' 0',' 0','-1',' 0','-1',' 0',' 1', * ' 1',' 0',' 0',' 0','-1',' 0','-1',' 0',' 1',' 0',' 0', * ' 0',' 0','-1','-1',' 0',' 0',' 0',' 1',' 0',' 0',' 0', * '-1','-1','-1',' 0',' 1',' 0',' 0',' 0',' 0','-1',' 1', * ' 0',' 0',' 0','-1',' 0',' 0',' 0',' 1',' 0',' 1',' 0', * ' 1',' 0',' 0',' 0',' 0','-1',' 0','-1',' 0','-1',' 0', * ' 0',' 0',' 0',' 1',' 1',' 0',' 0','-1','-1',' 0',' 0', * ' 0','-1','-1',' 0',' 0',' 1',' 1',' 0',' 0',' 0',' 1', * '-1',' 0',' 0',' 0',' 1',' 0',' 0',' 0',' 1',' 0',' 1', * ' 0',' 1',' 0',' 0',' 0',' 0',' 1',' 1',' 0',' 0',' 0', * '-1',' 0',' 0',' 0','-1',' 0','-1',' 0','-1',' 0',' 0', * ' 0',' 0','-1'/ DATA IGET/ 3*0,12,3*0,12,3*0,12,0,3*12,0,3*12,0, * 3*12,0,3*6,0,3*6,0,3*6,18,2*6/ DATA NSV/ 6,3*0,6,3*0,6,2*0,4,2*0,8,2*9,0,5*6,0,6,18,0,6,18,3,6, * 18,2*6,18,9,12,6,9,0,12,0,0,18,4*0,18,4*6,18/ DATA LAT/ 0,0,0,0,0,0,0,0,0,0,12,12,0,0,0,0,0,0,12,0,12,0,0,0, * 0,0,0,12,12,0,0,0,0,0,0,0,12,12,12,0,0,0,0,0,0, * 0,12,12,12,0,12,12,12,0,16,8,8,8,16,16,0,0,0/ DATA ICENT/0/, JN/2/,JM/ 0/,JP/0/,NSQ/0/,NN/0/,INTJ/0 /,INVJ/0/, * IIS /1/,ISYS/2/,IR/-1/,NG/0/, NS/1/,JS/1/, JR/-1/, KL/0/, * NSS/-1/,MS/16/ C 300 FORMAT((22X,I2,'.',3X,2(A4,2A2,2X),A4,2A2)) 400 FORMAT(/' SPACE GROUP:',18X,16A1) 500 FORMAT(/' SYMMETRY CLASS:',15X,16A1) 600 FORMAT(/' SPACE GROUP:',18X,4A1,'-',12A1) 800 FORMAT('H EQUIVALENT POSITIONS:') IERR=1 DO 900 I=1,16 NT(I)=' ' IF (I.GT.13) GO TO 900 IN(I)=0 900 CONTINUE DO 1020 I=1,3 NES(I)=1 NSW(I)=0 DO 1020 J=1,3 MTS(I,J)=0 DO 1010 K=1,48 NTS(K,J)=0 1010 CONTINUE 1020 CONTINUE C TRY TO FIND OUT IF THERE IS THE SIGN '-3' AT THE SECOND C POSITION ON THE RECORD OF AN INPUT WITH SPACE GROUP SYMBOL NCHH=0 ICT=0 ISP=0 DO 1040 I=KS,80 IF (NCHA(I).EQ.H(1)) GO TO 1035 IF (ISP.EQ.0) GO TO 1040 ICT=ICT+1 ISP=0 IF (ICT.NE.2) GO TO 1040 IF (NCHA(I).NE.H(2)) GO TO 1045 IF (NCHA(I+1).NE.H(7)) GO TO 1045 NCHH=I GO TO 1045 1035 ISP=1 1040 CONTINUE C SEPREATE TWO PARTS OF CONTROL CARD 1045 J0=0 DO 1080 I=KS,80 IF (I.EQ.NCHH) GO TO 1080 IF (J0.EQ.2) GO TO 1070 IF (NCHA(I).EQ.H(1)) GO TO 1050 J0=0 GO TO 1060 1050 J0=J0+1 1060 INTJ=INTJ+1 NT(INTJ)=NCHA(I) IF (INTJ.EQ.16) RETURN GO TO 1080 1070 IF (INVJ.GT.12.OR.NCHA(I).EQ.H(1).AND.IIS.EQ.1) GO TO 1080 IIS=2 INVJ=INVJ+1 NV(INVJ)=NCHA(I) 1080 CONTINUE C BEGIN DERIVING DO 1100 I=1,16 IF (JS.LT.14) IN(JS)=NH(NT(I)) IF (NT(I).NE.H(1)) GO TO 1090 JR=JR+1 JS=4*JR+1 1090 JS=JS+1 1100 IF (NT(I).EQ.H(7).OR.NT(I).EQ.H(10)) ISYS=5 IF (IN(2).EQ.NCH(8).OR.IN(2).EQ.NCH(2).AND.IN(3).EQ.NCH(8)) * ISYS=4 IF (IN(6).EQ.NCH(7)) ISYS=6 IF (ISYS.EQ.2.AND.IN(2).GE.NCH(6).AND.IN(6).GE.NCH(6)) * ISYS=3 IF (IN(2).EQ.NCH(5).AND.IN(6).LE.NCH(4).OR.IN(2).EQ.NCH(2).AND. * IN(3).EQ.NCH(5)) ISYS=1 KSYS=ISYS+MAX0(0,ISYS-4) IF (IN(2).EQ.NCH(7).OR.IN(2).EQ.NCH(2).AND.IN(3).EQ.NCH(7)) * KSYS=5 DO 1200 I=1,7 LO=I+10 IF (IN(1).EQ.NCH(LO)) IN(1)=I 1200 CONTINUE LATT=MOD(IN(1),7)+1 IF (LATT.LE.5) PTS=MIN0(2,LATT) IF (LATT.GE.6) PTS=LATT-3 IF (IN(1).EQ.6) LATT=6 IF (IN(1).EQ.5) LATT=7 C DETERMINATION OF MONOCLINIC SETTING. IF (ISYS.NE.2.OR.IN(6).GT.NCH(4)) GO TO 1320 DO 1300 I=2,5 LO=I+4 IN(LO)=IN(I) 1300 IN(I)=0 C SELECTION OF GENERATORS 1320 IF (ISYS.GE.2.AND.ISYS.LE.3) GO TO 1330 C 1. POINT GROUPS 1,-1,3,-3,4,-4,6,-6,4/M,6/M. NET(1)=IN(2)-NCH(4) KL=24*(IN(3)-NCH(4))/NET(1) IF (IN(2).EQ.NCH(2)) NET(1)=IN(3)-NCH(4)+6 IF (NET(1).GT.2.AND.NET(1).LT.7.AND.IN(3).GT.NCH(4)) * MTS(1,3)=KL IF (IN(6).LE.NCH(4).OR.IN(2).EQ.NCH(7).OR.IN(2).EQ.NCH(2).AND. 1 IN(3).EQ.NCH(7)) NG=1 IF (IN(6).GT.NCH(4)) GO TO 1330 IF (IN(4).LT.NCH(3)) GO TO 1400 NET(2)=8 IF (IN(5).EQ.NCH(11).OR.IN(4).EQ.NCH(11)) NES(2)=2 IF (IN(5).EQ.NCH(20).OR.IN(4).EQ.NCH(20)) NES(2)=7 NG=2 IF (IN(6).LE.NCH(4)) GO TO 1400 C 2. MONOCLINIC-ORTHORHOMBIC. 1330 DO 1390 I=1,3 DO 1390 J=1,4 L=1+4*(I-1)+J M=L+4 IF (M.GT.13) M=M-12 IF (ISYS.GT.3) GO TO 1350 IF (IN(L).NE.NCH(6).OR.IN(M).GE.NCH(11)) GO TO 1340 NG=NG+1 NET(NG)=29-9*I LO=L+1 IF (IN(LO).EQ.NCH(5)) NES(NG)=I+1 IF (NG.EQ.2.AND.IN(11).EQ.NCH(5)) MTS(2,3)=12 IF (NG.EQ.2) GO TO 1400 1340 IF (IN(L).LE.NCH(10)) GO TO 1390 NG=NG+1 NET(NG)=23-5*I IF (IN(L).GE.NCH(11).AND.IN(L).LE.NCH(13)) * NES(NG)=IN(L)-NCH(11)+2 IF (IN(L).EQ.NCH(20)) NES(NG)=I+4 IF (IN(L).EQ.NCH(18)) NES(NG)=I+8 IF (ISYS.LT.4) GO TO 1390 C 3. TETRAGONAL-HEXAGONAL-CUBIC. 1350 IF (IN(M).LE.NCH(5)) GO TO 1390 IF (I.EQ.3.AND.(ISYS.LT.6.AND.IN(4).LT.NCH(3).OR.ISYS.EQ.6.AND. * IN(2).LE.NCH(10).AND.IN(10).GT.NCH(4))) GO TO 1390 NG=NG+1 IF (NG.EQ.4) NG=3 IF (I.NE.1) GO TO 1360 IF (ISYS.EQ.6) NET(1)=5 IF (IN(6).EQ.NCH(6)) NET(NG)=36-4*ISYS IF (IN(6).GE.NCH(11)) NET(NG)=22-ISYS IF (IN(7).EQ.NCH(5)) NES(1)=2 1360 IF (I.NE.2) GO TO 1370 IF (IN(10).EQ.NCH(6)) NET(NG)=21 IF (IN(10).GE.NCH(11)) NET(NG)=19 IF (NET(1).EQ.5.AND.IN(10).EQ.NCH(6)) NET(2)=14 IF (IN(2).EQ.NCH(2).AND.NET(1).EQ.5) NET(2)=15 1370 IF (IN(M).GE.NCH(11).AND.I.EQ.3) NET(NG)=8 IF (IN(M).EQ.NCH(6).AND.I.EQ.3) NET(NG)=2 IF (IN(2).EQ.NCH(6).AND.IN(3).EQ.NCH(5)) NES(2)=6 IF (IN(6).EQ.NCH(6).AND.IN(10).EQ.NCH(6).AND.I.EQ.1.AND. * IN(3).GT.NCH(4)) MTS(2,3)=24-MTS(1,3) IF (IN(2).NE.NCH(7)) MTS(1,3)=0 DO 1380 II=1,3 IF (NET(2).EQ.14.AND.IN(3).GT.NCH(4)) * MTS(2,II)=48-3*KL+(2*KL-24)*II 1380 IF (NET(2).EQ.14.AND.IN(3).GT.NCH(4)) MTS(2,3)=MTS(2,2) IF (IN(M).GE.NCH(11).AND.IN(M).LE.NCH(13)) * NES(NG)=IN(M)-NCH(11)+2 IF (IN(M).EQ.NCH(20)) NES(NG)=4+I IF (IN(M).EQ.NCH(20).AND.I.EQ.2) NES(NG)=8 IF (IN(M).EQ.NCH(18)) NES(NG)=14-I IF (IN(10).EQ.NCH(18).AND.NET(1).EQ.5) NES(2)=13 IF (NES(2).EQ.13.AND.IN(2).EQ.NCH(11)) NES(2)=12 1390 CONTINUE C COMPLETE SYMMETRY OPERATIONS. 1400 DO 1410 K=1,NG NESK=NES(K) NETK=NET(K) DO 1410 I=1,3 NTS(K,I)=IGET(I,NESK)+MTS(K,I) DO 1410 J=1,3 LS(K,I,J)=NGES(I,J,NETK) 1410 CONTINUE K=0 1420 K=K+1 IF (K.GT.NG) GO TO 1560 L=1 IF (LS(K,1,1)+LS(K,2,2)+LS(K,3,3).EQ.-3) NSS=K IF (LS(K,1,1)+LS(K,2,2)+LS(K,3,3).EQ.3) NU=K 1430 IF (L.GT.NG) GO TO 1420 DO 1450 I=1,3 ITN=NTS(K,I) DO 1450 J=1,3 N=0 ITN=ITN+LS(K,I,J)*NTS(L,J) DO 1440 M=1,3 N=N+LS(K,I,M)*LS(L,M,J) 1440 CONTINUE ITN=MOD(ITN,24) IF (ITN.LT.0) ITN=ITN+24 KSS(I,J)=N ISS(I)=ITN 1450 CONTINUE DO 1470 KK=1,NG N=0 DO 1460 I=1,3 DO 1460 J=1,3 1460 IF (KSS(I,J).NE.LS(KK,I,J)) N=1 IF (N.EQ.0) GO TO 1490 1470 CONTINUE NG=NG+1 DO 1480 I=1,3 NTS(NG,I)=ISS(I) DO 1480 J=1,3 1480 LS(NG,I,J)=KSS(I,J) 1490 L=L+1 IF (K.NE.NSS) GO TO 1550 DO 1540 I=1,3 J=I+1 IK=I+2 IM=I+4 IF (J.GT.3) J=J-3 IF (IK.GT.3) IK=IK-3 IF (IN(1).NE.4) GO TO 1510 IF (I.GT.1) GO TO 1540 IF (NTS(NSS,1).GE.12.AND.NTS(NSS,2).GE.12.AND.NTS(NSS,3).GE.12) * NN=1 IF (NN.NE.1) GO TO 1540 DO 1500 IJ=1,3 1500 NTS(NSS,IJ)=NTS(NSS,IJ)-12 1510 NN=0 IF (IN(1).EQ.6) GO TO 1520 IF (IN(1).NE.I) GO TO 1540 1520 IF (NTS(NSS,J).GE.12.AND.NTS(NSS,IK).GE.12) NN=1 IF (NN.NE.1) GO TO 1540 DO 1530 II=1,3 NTS(NSS,II)=NTS(NSS,II)-IGET(II,IM) 1530 CONTINUE 1540 CONTINUE 1550 GO TO 1430 C DETERMINE CENTROSYMMETRY AND SHIFT VECTOR TO A CENTRE OF SYMM.. 1560 IF (NSS.GT.0) NS=0 IF (NS.EQ.0) ICENT=1 DO 1570 I=1,3 1570 MTS(1,I)=0 IF (NS.EQ.1) GO TO 1590 DO 1580 K=1,3 MTS(1,K)=NTS(NSS,K)/2 MTS(1,K)=MOD(MTS(1,K),24) IF (MTS(1,K).LT.0) MTS(1,K)=MTS(1,K)+24 1580 CONTINUE C DETERMINE THE REF, NUMBER OF SHIFT VECTOR TO AN ORIGIN OF I. T.. 1590 IF (IIS.EQ.2) GO TO 1650 NSQ=1 DO 1600 I=1,13 1600 IF (IN(I).EQ.NCH(1).OR.IN(I).EQ.0) IN(I)=NCH(4) IF (ISYS.LT.3.OR.IN(4).NE.NCH(4).OR.ISYS.GT.4) GO TO 1630 IF (ISYS.NE.3) GO TO 1610 IF ((IN(3)+IN(7))/2.GT.NCH(4)) MS=8-6*(IN(11)-NCH(4)) IF ((IN(6).EQ.NCH(11).OR.(IN(2)+IN(6))/2.EQ.NCH(20)) * .AND.IN(10).EQ.NCH(6)) MS=8 IF (MS.EQ.8.AND.(IN(2).EQ.NCH(19).OR.IN(2).EQ.NCH(13))) MS=1 IF (IN(1).EQ.3.AND.IN(2).EQ.NCH(19).AND.IN(10).EQ.NCH(11)) MS=8 IF ((IN(2).EQ.NCH(20).OR.IN(2).EQ.NCH(12)).AND. * (IN(6).EQ.NCH(13).OR.IN(6).EQ.NCH(19)).AND.IN(10).EQ.NCH(6)) * MS=2 IF (IN(1).EQ.4.AND.IN(10).EQ.NCH(11)) MS=7 IF (IN(6).EQ.NCH(18).AND.IN(10).EQ.NCH(6)) MS=6 GO TO 1680 1610 IF (IN(1).EQ.4.AND.IN(3).EQ.NCH(5)) MS=9 IF ((IN(6)+IN(10))/2.EQ.NCH(6).AND. * (IN(3)-NCH(4)+1)/2.GT.(IN(3)-NCH(4))/2) MS=3 IF (MS.EQ.3.AND.IN(1).EQ.4) MS=12 DO 1620 I=1,4 1620 IF (IN(7).EQ.NCH(5).AND.IN(3).EQ.NCH(I+3)) MS=8+I IF (IN(10).EQ.NCH(13).AND.IN(6).EQ.NCH(6)) MS=3+8*(IN(7)-NCH(4)) IF (IN(7).EQ.NCH(5).AND.IN(10).EQ.NCH(19).OR.IN(10).EQ.NCH(18)) * MS=13-4*(IN(7)-NCH(4)) IF (IN(6).EQ.NCH(12).OR.IN(6).EQ.NCH(13).AND.IN(2).EQ.NCH(2)) * MS=8-5*(IN(6)-NCH(12)) IF (IN(6).EQ.NCH(20)) MS=9-(IN(3)-NCH(4))/2 IF (IN(6).EQ.NCH(12).AND.IN(10).GE.NCH(11).OR. * IN(6).EQ.NCH(13).AND.IN(10).EQ.NCH(18)) * MS=9-7*(IN(6)-NCH(12)) IF (IN(6).EQ.NCH(19).AND.IN(10).EQ.NCH(18).OR.IN(6).EQ.NCH(13) * .AND.IN(10).EQ.NCH(19)) MS=14+IN(3)-NCH(4) 1630 IF (ISYS.NE.4) GO TO 1640 IF (IN(6).EQ.NCH(12).OR.IN(1).EQ.4.AND.IN(6).EQ.NCH(13)) MS=14 IF (IN(5).EQ.NCH(20).AND.(IN(6).EQ.NCH(4).OR.IN(6).EQ.IN(5)).OR. * IN(4).EQ.NCH(20).AND.IN(6).EQ.IN(4)) MS=14 IF (IN(5).EQ.NCH(11).AND.IN(6).GT.NCH(10)) * MS=18-((IN(6)-NCH(13))/10) 1640 IF (IN(2).EQ.NCH(7).AND.IN(3).NE.NCH(4).AND.IN(6).NE.NCH(4)) * MS=IN(3)-NCH(4)+3 IF (IN(1).EQ.6.AND.IN(3).EQ.NCH(5).OR.IN(1).EQ.4.AND. * IN(2).EQ.NCH(11)) MS=7 IF (IN(4).EQ.NCH(19).AND.IN(6).EQ.NCH(20)) MS=14 GO TO 1680 C SHIFT TO ANOTHER ORIGIN. 1650 DO 1660 I=1,12 IF (JN.LT.14) IN(JN)=NH(NV(I)) IF (NV(I).NE.H(1)) GO TO 1655 JM=JM+1 JN=4*JM+1 1655 JN=JN+1 1660 CONTINUE DO 1670 I=1,9,4 JP=JP+1 IO=I+1 LO=I+3 IF (IN(LO).NE.NCH(4)) NSW(JP)=(IN(IO)-NCH(4))*24/ * (IN(LO)-NCH(4)) 1670 CONTINUE C APPLY THE SHIFT OF ORIGIN TO ALL OPERATIONS. 1680 IF (NS.EQ.1.AND.IIS.EQ.0) GO TO 1730 DO 1690 K=1,3 IF (IIS.NE.1) NSV(K,MS)=0 NSW(K)=NSV(K,MS)+MTS(1,K)+NSW(K) NSW(K)=MOD(NSW(K),24) IF (NSW(K).LT.0) NSW(K)=NSW(K)+24 1690 CONTINUE DO 1720 I=1,NG DO 1720 J=1,3 L=NTS(I,J) DO 1700 K=1,3 L=L-(LS(NU,J,K)-LS(I,J,K))*NSW(K) 1700 CONTINUE 1710 IF (L.LT.24.AND.L.GE.0) GO TO 1715 IF (L.LT.0) L=L+24 IF (L.GE.24) L=L-24 GO TO 1710 1715 NTS(I,J)=L 1720 CONTINUE C NORMALIZATION OF CENTRING TYPE. 1730 DO 1780 I=1,NG DO 1780 J=1,3 NN=0 K=J+1 KI=J+2 IF (K.GT.3) K=K-3 IF (KI.GT.3) KI=KI-3 IF (IN(1).NE.4) GO TO 1750 IF (J.GT.1) GO TO 1780 IF (NTS(I,1).GE.12.AND.NTS(I,2).GE.12.AND.NTS(I,3).GE.12) NN=1 IF (NN.NE.1) GO TO 1780 DO 1740 IJ=1,3 1740 NTS(I,IJ)=NTS(I,IJ)-12 1750 IF (IN(1).EQ.6) GO TO 1760 IF (IN(1).NE.J) GO TO 1780 1760 IF (NTS(I,K).GE.12.AND.NTS(I,KI).GE.12) NN=1 IF (NN.NE.1) GO TO 1780 DO 1770 II=1,3 JI=J+4 NTS(I,II)=NTS(I,II)-IGET(II,JI) 1770 CONTINUE 1780 CONTINUE C OUTPUT ON LINE-PRINTER. IF (ISYS.EQ.1) WRITE(6,500) H(28),H(15),H(14),H(13),H(29), 1 H(14),H(20),H(14),H(13) IF (ISYS.EQ.2) WRITE(6,500) H(19),H(25),H(20),H(25),H(13), 1 H(29),H(14),H(20),H(14),H(13) IF (ISYS.EQ.3) WRITE(6,500) H(25),H(15),H(28),H(30),H(25), 1 H(15),H(30),H(25),H(19),H(12),H(14),H(13) IF (ISYS.EQ.4) WRITE(6,500) H(28),H(23),H(28),H(15),H(11), 1 H(26),H(25),H(20),H(11),H(29) IF (ISYS.EQ.5) WRITE(6,500) H(30),H(23),H(31),H(11),H(26), 1 H(25),H(20),H(11),H(29) IF (ISYS.EQ.6) WRITE(6,500) H(13),H(24),H(12),H(14),H(13) IF (NCHH.EQ.0) WRITE(6,400) NT IF (NCHH.NE.0) WRITE(6,600) NT C LOOK FOR 'X,Y,Z' OPERATION DO 1790 I=1,NG IZER=IABS(NTS(I,1))+IABS(NTS(I,2))+IABS(NTS(I,3)) IF (IZER.NE.0) GO TO 1790 IZER=IABS(LS(I,1,2))+IABS(LS(I,1,3))+IABS(LS(I,2,3))+ * IABS(LS(I,2,1))+IABS(LS(I,3,1))+IABS(LS(I,3,2)) IF (IZER.NE.0) GO TO 1790 IF (LS(I,1,1).EQ.1.AND.LS(I,2,2).EQ.1.AND.LS(I,3,3).EQ.1) * GO TO 1800 1790 CONTINUE RETURN C PRINT SYMMTRICAL SYMBOLS 1800 IF (LATT.EQ.1) WRITE(6,800) IF (LATT.EQ.2) WRITE(6,1810) 1810 FORMAT(/' EQUIVALENT POSITIONS:',8X,'+(0 0 0 0 1/2 1/2)'/) IF (LATT.EQ.3) WRITE(6,1820) 1820 FORMAT(/' EQUIVALENT POSITIONS:',8X,'+(0 0 0 1/2 0 1/2)'/) IF (LATT.EQ.4) WRITE(6,1830) 1830 FORMAT(/' EQUIVALENT POSITIONS:',8X,'+(0 0 0 1/2 1/2 0)'/) IF (LATT.EQ.5) WRITE(6,1840) 1840 FORMAT(/' EQUIVALENT POSITIONS:',8X,'+(0 0 0 1/2 1/2 1/2)'/) IF (LATT.EQ.6) WRITE(6,1850) 1850 FORMAT(/' EQUIVALENT POSITIONS:',8X,'+(0 0 0 0 1/2 1/2 ', 1 '1/2 0 1/2 1/2 1/2 0)'/) IF (LATT.EQ.7) WRITE(6,1860) 1860 FORMAT(/' EQUIVALENT POSITIONS:',8X,'+(0 0 0 2/3 1/3 1/3 ', 1 ' 1/3 2/3 2/3)'/) ML=(LATT-1)*9+1 DO 1880 LL=1,3 ITL(LL,1)=LAT(ML) ITL(LL,2)=LAT(ML+1) ITL(LL,3)=LAT(ML+2) ML=ML+3 1880 CONTINUE I0=I-1 IR=I0-1 JJ=0 1890 IR=MOD(NG+IR+1,NG)+1 IE=MOD(NG+IR,NG)+1 DO 1900 I1=1,2 JJ=JJ+1 I=IR IF (I1.EQ.2) I=IE IU=I DO 1900 J=1,3 MO=LS(I,J,1)+LS(I,J,2)*3+LS(I,J,3)*4+5 TX(J,I1)=TEXB(MO) DO 1900 K=1,2 LO=2*NTS(I,J)+K CGES(K,J,I1)=NTEX(LO) 1900 CONTINUE JJ1=JJ-1 IF (JJ.LE.NG) WRITE(6,300) JJ1,TX(1,1),(CGES(I,1,1),I=1,2), * TX(2,1),(CGES(I,2,1),I=1,2),TX(3,1),(CGES(I,3,1),I=1,2), * JJ,TX(1,2),(CGES(I,1,2),I=1,2), * TX(2,2),(CGES(I,2,2),I=1,2),TX(3,2),(CGES(I,3,2),I=1,2) IF (JJ.GT.NG) WRITE(6,300) JJ1,TX(1,1),(CGES(I,1,1),I=1,2), * TX(2,1),(CGES(I,2,1),I=1,2),TX(3,1),(CGES(I,3,1),I=1,2) C IF (JJ.LE.NG) WRITE(6,300) JJ1,(TX(J,1),(CGES(I,J,1),I=1,2), C * J=1,3),JJ,(TX(J,2),(CGES(I,J,2),I=1,2),J=1,3) C IF (JJ.GT.NG) WRITE(6,300) JJ1,(TX(J,1), C * (CGES(I,J,1),I=1,2),J=1,3) IF (JJ.LT.NG) GO TO 1890 IF (ICENT.EQ.0) GO TO 1980 C GIVE UP THE CENTROSYMMTRICAL OPERATIONS I1=I0 DO 1970 I=1,NG I1=MOD(I1,NG)+1 IF (LS(I1,1,1).EQ.100) GO TO 1970 DO 1960 J1=1,NG IF (LS(J1,1,1).EQ.100.OR.I1.EQ.J1) GO TO 1960 IZER=0 JZER=0 DO 1920 K1=1,3 IZER=IZER+MOD(IABS(NTS(I1,K1)+NTS(J1,K1)+24),24) DO 1910 L1=1,3 JZER=JZER+IABS(LS(I1,K1,L1)+LS(J1,K1,L1)) IF (JZER.NE.0) GO TO 1960 1910 CONTINUE 1920 CONTINUE IF (IZER.EQ.0) GO TO 1950 DO 1940 K2=1,3 IZER=0 DO 1930 K1=1,3 IZER=IZER+MOD(IABS(NTS(I1,K1)+NTS(J1,K1)+ITL(K2,K1)+24),24) 1930 CONTINUE IF (IZER.EQ.0) GO TO 1950 1940 CONTINUE GO TO 1960 1950 LS(J1,1,1)=100 GO TO 1970 1960 CONTINUE RETURN 1970 CONTINUE C TRANSLATE INTO FORMAT OF PREPAR 1980 J=0 DO 2000 I=1,NG I0=MOD(I0,NG)+1 IF (LS(I0,1,1).EQ.100) GO TO 2000 J=J+1 DO 1990 K=1,3 TS(K,J)=NTS(I0,K)/24.0 DO 1985 L=1,3 IS(L,K,J)=LS(I0,K,L) 1985 CONTINUE 1990 CONTINUE 2000 CONTINUE NSYM=J IF (J.NE.NG.AND.J.NE.NG/2) RETURN IERR=0 RETURN END C ----------------------------------------------------------------- FUNCTION NH(ICH) DIMENSION NCH(31) CHARACTER H(31),ICH DATA H/' ','-','/','0','1','2','3','4','5','6','A','B','C','I', * 'R','F','P','D','M','N','Y',':','E','U','O','G','Q','T','L','H', * 'X'/ C THOSE DIGITAL NUMBER BELOW ARE ASCII CODES FOR EACH CHARACTER ABOVE DATA NCH/ 32,45,47,48,49,50,51,52,53,54,65,66,67,73,82, * 70,80,68,77,78,89,58,69,85,79,71,81,84,76,72,88/ DO 200 I=1,31 IF (ICH.EQ.H(I)) GO TO 300 200 CONTINUE NH=0 RETURN 300 NH=NCH(I) RETURN END C----------------------------------------------------------------------- SUBROUTINE VOL(CX,V) C SINE AND COSINE OF CELL ANGLES PLUS TRIGONOMETRIC PART OF VOLUME COMMON/UNIT_OAS/ITLE(80),LIST,PI,IDTYPE,DEVIAT,ICOMP CHARACTER ITLE DIMENSION CX(9) DTOR=PI/180.0 ARG=1.0 DO 10 I=4,6 CX(I+3)=SIN(DTOR*CX(I)) CX(I)=COS(DTOR*CX(I)) ARG=ARG-CX(I)*CX(I) 10 CONTINUE V=SQRT(ARG+2.0*CX(4)*CX(5)*CX(6)) RETURN END CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C W W IIIII L SSSSS OOOOO N N C C W W I L S S O O NN N C C W W I L S O O N N N C C W W I L SSSSS O O N N N C C W W W I L S O O N N N C C W W W W I L S S O O N NN C C W W IIIII LLLLLL SSSSS OOOOO N N C C C C WILSON STATISTICS C C A MODIFICATION OF THE SUBROUTINE 'SUM' OF MULTAN-80 C C VERSON 1995 C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC SUBROUTINE WILSONN(PTS,KSYS) COMMON/ATMGROUP/NINF(10),NAG(10),X(500),Y(500),Z(500),NZ(500), 1 QQ(500),U11(500),U22(500),U33(500),U23(500),U13(500),U12(500) COMMON/REFLXIN/LH(60),LK(60),LL(60),FO(60),ID(60),RHO(60),DFO(60), 1 EO(60),BTP(60),ITPH(60),ED(60),EDP(60),SDFO(60) COMMON/RESCALING/MG,BT(9),SC(9),SCAL(8) COMMON/UNIT_OAS/ITLE(80),LIST,PI,IDTYPE,DEVIAT,ICOMP COMMON/WILSON/FLGW(30),FLGD(30),AVR(30),SLOPE,DEL(9),KS(9) COMMON/XXX/P(6),CX(9),NREF,NPWP,RHOMAX,MREF,EMAX,EMIN,RHOCUT, 1 SIGCUT,ZCG(8),ZOG(8),KNOWN,KMIN,ISGM2,NCYC,ISIMP,IFIT CHARACTER ITLE DIMENSION SW(30),SD(30),SR(30),SI(30),NSUM(30) WRITE(6,40) 40 FORMAT(/44X,'EXP(-2*B*RHO)*E**2'/ 1 ' RANGE',2X,'(SIN/LAM)**2',2X,'NUMBER',2X,'MEAN RHO', 2 2X,'MEAN I',5X,'MEAN',5X,'DEBYE',5X,'WILSON') C SET INITIAL VALUES PP=0.0 Q=0.0 R=0.0 S=0.0 T=0.0 NUMBER=0 ADD=RHOMAX/FLOAT(NPWP) START=-ADD END=ADD RR=FLOAT(NPWP)/RHOMAX DO 50 I=1,30 SW(I)=0.0 SD(I)=0.0 SR(I)=0.0 SI(I)=0.0 NSUM(I)=0 50 CONTINUE REWIND(8) C READ SCRATCH TAPE 100 READ(8) LH,LK,LL,FO,ID,ED,RHO,EDP DO 200 I=1,60 C TAPE ENDS WITH FO .LT. 0.0 IF(FO(I).LT.0.0) GOTO 210 IF(IDTYPE.GT.0.AND.EDP(I).GT.100.0) GOTO 200 C N STORES RANGE OF RHO N=MIN0(INT(1.0+RR*RHO(I)),NPWP) IG=1 MULT=ID(I)/10000 IE=(ID(I)-10000*MULT)/100 EPS=FLOAT(IE) TMUL=FLOAT(MULT) C WEIGHTED SUMS C NUMBER OF REFLEXIONS NSUM(N)=NSUM(N)+MULT C WILSON SW(N)=SW(N)+ED(I)*TMUL C DEBYE IF(KNOWN.EQ.0) SD(N)=SD(N)+ED(I)*TMUL IF(KNOWN.EQ.1) SD(N)=SD(N)+EDP(I)*TMUL C RHO SR(N)=SR(N)+RHO(I)*TMUL C INTENSITY SI(N)=SI(N)+TMUL*FO(I)*FO(I)/(EPS*PTS) 200 CONTINUE GOTO 100 210 CONTINUE DO 300 I=1,NPWP C SMOOTH CURVE BY ADDING ADJACENT RANGES NUMBER=NUMBER+NSUM(I) NSUM(I)=NSUM(I)+NSUM(I+1) SW(I)=SW(I)+SW(I+1) SD(I)=SD(I)+SD(I+1) SR(I)=SR(I)+SR(I+1) SI(I)=SI(I)+SI(I+1) C CALCULATE WEIGHTED AVERAGES AND LOGS WT=FLOAT(NSUM(I)) DIV=1.0/AMAX1(1.0,WT) ESQAV=SD(I)*DIV AVI=SI(I)*DIV START=START+ADD END=AMIN1(END+ADD,RHOMAX) IF(NSUM(I).EQ.0) GOTO 260 FLGD(I)=ALOG(ESQAV) FLGW(I)=ALOG(SW(I)*DIV) AVR(I)=SR(I)*DIV GOTO 270 260 FLGD(I)=-20.0 FLGW(I)=-20.0 AVR(I)=(START+END)/2.0 270 WRITE(6,280) I,START,END,NSUM(I),AVR(I),AVI,ESQAV,FLGD(I),FLGW(I) 280 FORMAT(' ',I3,F8.4,' -',F6.4,I6,F10.4,F10.1,F9.4,F10.4,F11.4) C COEFFICIENTS OF NORMAL EQUATIONS PP=PP+WT*AVR(I)*AVR(I) Q=Q+WT*AVR(I) R=R+WT*AVR(I)*FLGD(I) S=S+WT*FLGD(I) T=T+WT 300 CONTINUE IF(NUMBER.NE.0) GOTO 310 SC(IG)=0.0 GOTO 350 310 WRITE(6,320) PP,Q,R,Q,T,S 320 FORMAT(1X,'NORMAL EQUATIONS'/(' ',E11.3,' * SLOPE +',E11.3, 1 ' * INTERCEPT =',E11.3)) C LEAST SQUARES DIV=PP*T-Q*Q SLOPE=(R*T-Q*S)/DIV FLGK=(PP*S-Q*R)/DIV SC(IG)=EXP(-FLGK) BT(IG)=-0.5*SLOPE WRITE(6,340) SLOPE,FLGK,BT(IG),SC(IG) 340 FORMAT(/1X,'SLOPE=',F7.3,1X,'INTERCEPT=',F6.3,2X, 1 'TEMPERATURE FACTOR(B)=',F7.2,1X,'SCALE=',F7.2/ 2 20X,'SQRT(SCALE)*F(OBS) = EXP(-B*RHO)*F(CAL)') 350 M=MG+1 DO 360 I=2,M BT(I)=BT(1) 360 CONTINUE RETURN END CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C SSSSSSS IIIIIIII GGGGGGG NN NN C C SSSSSSSSS IIIIIIII GGGGGGGGG NNN NN C C SS SS II GG GG NNNN NN C C SS II GG NN NN NN C C SSSSSSSS II GG GGGG NN NN NN C C SSSSSSSS II GG GGGG NN NNNN C C SS II GG GG NN NNN C C SS SS II GG GG NN NN C C SSSSSSSSS IIIIIIII GGGGGGGGG NN NN C C SSSSSSS IIIIIIII GGGGGGG NN NN C C C C PROGRAM DETERMINING THE SIGNS OF PHASE DIFFERENCES C C FOR PROTEIN 'SIR' OR 'OAS' DATA C C VERSION 1999 C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC SUBROUTINE TSIGN CHARACTER*8 CDATE,CTIME PARAMETER (MAXRE=150000) COMMON /DATETIME/CDATE,CTIME COMMON /AAAA/ MAXIM(MAXRE*18+24174) COMMON /CNST/ SGM32,ITLE(80) COMMON /RFLX/ NUMB,JH(MAXRE),JK(MAXRE),JL(MAXRE),IDPH(MAXRE), 1 IPHP(MAXRE),ITPH(MAXRE),IORD(MAXRE),ISDP(MAXRE),IDPB(MAXRE), 2 MARK(MAXRE),FO(MAXRE),SD(MAXRE),E(MAXRE),RSL(MAXRE),XSIN(MAXRE), 3 ESGMH(MAXRE),COSDP(MAXRE),PROB(MAXRE),FOM(MAXRE),ARG(MAXRE), 4 ABSARG(MAXRE),RSLIM,IDTYPE,IFIT COMMON /SYMT/ IS(3,3,24),ITS(3,24),NSYM,LATT,ICENT,PARA(6),NASU, 1 TS(3,24) COMMON /TABL/ SINT(451),DTOR COMMON /USER/ ISIM,ISGM2,KMIN,LIST,NCYC,PHCOMP,IXRAN,IYRAN DIMENSION JN(8),JZ(8),MAXH(3) CHARACTER ITLE C ASSIGN CHANNELS C 1: FORMATED DATA AND KEYWORD INPUT C 2: BINARY OUTPUT OF PHASES FOR EXFFT C 3: BINARY SCRATCH OF SIGMA2 RELATIONSHIPS C 6: FORMATED LINE-PRINTER OUTPUT REWIND(1) CALL CCPDPN(3,'SIGMA2','SCRATCH','U',80,0) C KUSER2: MAX. NO OF REFLEXIONS IN HEMISPHERE: DIMENSION OF IR1,IR2,LOC KUSER2=MAXRE*6 DTOR=ATAN(1.0)/45.0 DO 10 I=1,451 SINT(I)=SIN(DTOR*(I-1)) 10 CONTINUE C GET INITIAL TIME CALL CCPDAT(CDATE) CALL UTIME(CTIME) C READ CELL, GROUP AND SYMMETRY INFORMATION FROM PREPAR READ(1,20) ITLE,PARA,JN,JZ,ICENT,LATT,NSYM,NASU 20 FORMAT(80A1///6F10.5///16I5//4I5) READ(1,30) ((TS(I,J),(IS(K,I,J),K=1,3),I=1,3),J=1,NSYM) 30 FORMAT(/3(F11.8,3I3)) DO 60 I=1,3 DO 50 J=1,NSYM ITS(I,J)=TS(I,J)*24 50 CONTINUE 60 CONTINUE C READ KEYWORDS READ(1,70) ISGM2,ISIM,KMIN,LIST,NCYC,RSLIM,IDTYPE,IFIT 70 FORMAT(/5I5,F7.2,I4,I6) NN=2 IF(LATT.EQ.1) NN=1 IF(LATT.EQ.6) NN=4 IF(LATT.EQ.7) NN=3 SUM1 = 0.0 SUM2 = 0.0 DO 80 I=1,8 TEMP=(JN(I)*JZ(I)**2)/NN SUM1 = SUM1 + TEMP SUM2 = SUM2 + TEMP * FLOAT(JZ(I)) 80 CONTINUE SGM32=SUM2/(SUM1**1.5) XKMN=FLOAT(KMIN)/100 CALL READER(PHCOMP) CALL SORT(E,10,7) WRITE(6,200) ITLE,CDATE,CTIME, 1 SGM32,XKMN,RSLIM,NUMB,IFIT 200 FORMAT(/80A1//11X,'RESOLVING PAHSE AMBIGUITIES FOR', 1 ' PROTEIN ''SIR'' OR ''OAS'' DATA'//30X,'VERSION AUGUST 1999' 2 //55X,A8,3X,A8/ 2 /28X,'SET UP PHASE RELATIONSHIPS' 3 //26X,'SIGMA3/SIGMA2**1.5 =',F9.5 4 //25X,'MINIMUM VALUE OF KAPPA =',F7.3 5 //10X,'NUMBER OF REFLECTIONS AT ',F5.2,2X, 6 'ANGSTROM RESOLUTION =',I8//37X,'IFIT = ',I1) SGM32 = 200.0 * SGM32 IF(ISGM2.EQ.0) GOTO 400 WRITE(6,300) 300 FORMAT(/18X,' SIGMA2 RELATIONSHIPS READ FROM A PREVIOUS RUN') GOTO 500 400 CALL SETUP(NIOR,KUSER2) C SET UP SIGMA2 RELATIONSHIPS JUMP=1 CALL SIGMA2(NIOR) 500 DO 510 I=1,3 MAXH(I)=-999 510 CONTINUE DO 550 I=1,NUMB IORD(I)=NUMB+1-I MAXH(1)=MAX0(MAXH(1),IABS(JH(I))) MAXH(2)=MAX0(MAXH(2),IABS(JK(I))) MAXH(3)=MAX0(MAXH(3),IABS(JL(I))) 550 CONTINUE CALL BEST(MAXH) CALL CCPDAT(CDATE) CALL UTIME(CTIME) WRITE(6,900) CDATE,CTIME 900 FORMAT(55X,A8,3X,A8) CLOSE (1) CLOSE (3) CLOSE (10) WRITE (6,*)' --- SIGN COMPLETED ---' END CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C BBBBBB EEEEEEE SSSSS TTTTTTT C C B B E S S T C C B B E S T C C BBBBBB EEEEEE SSSSS T C C B B E S T C C B B E S S T C C BBBBBB EEEEEEE SSSSS T C C C C PROGRAM CALCULATING THE BEST PHASES FOR PROTEIN 'SIR' OR 'OAS' DATA C C VERSION 1996 C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC SUBROUTINE BEST(MAXH) PARAMETER (MAXRE=150000) COMMON /AAAA/ IPH1(3000),IPH2(3000), 1 IPHB(MAXRE),IPHM(MAXRE),IPHC(MAXRE),IPHAV(MAXRE), 2 NOUSE(14*MAXRE-6000+24174) COMMON /CNST/ SGM32,ITLE(80) COMMON /RFLX/ NUMB,JH(MAXRE),JK(MAXRE),JL(MAXRE),IDPH(MAXRE), 1 IPHP(MAXRE),ITPH(MAXRE),IORD(MAXRE),ISDP(MAXRE),IDPB(MAXRE), 2 MARK(MAXRE),FO(MAXRE),SD(MAXRE),E(MAXRE),RSL(MAXRE),XSIN(MAXRE), 3 ESGMH(MAXRE),COSDP(MAXRE),PROB(MAXRE),FOM(MAXRE),ARG(MAXRE), 4 ABSARG(MAXRE),RSLIM,IDTYPE,IFIT COMMON /SYMT/ IS(3,3,24),ITS(3,24),NSYM,LATT,ICENT,PARA(6),NASU, 1 TS(3,24) COMMON /TABL/ SINT(451),DTOR COMMON /USER/ ISIM,ISGM2,KMIN,LIST,NCYC,PHCOMP,IXRAN,IYRAN DIMENSION MAXH(3),ADATA1(7) CHARACTER ITLE CHARACTER*30 LAB1(7) CHARACTER*1 CTYP1(7) LOGICAL EOF CHARACTER*4 KEY, CCVAL(20) CHARACTER*400 LINE CHARACTER*80 HSTR INTEGER NTOK, IBEG(20), IEND(20), ITYP(20), IDEC(20) REAL FVAL(20) C --- SYMLIB, MTZLIB --- CHARACTER*1 LTYPE CHARACTER*10 PGNAME,SPGNAM INTEGER NUMSGP,MSYMP,NSYMM,MLAUE,IHKL(3),JHKL(3),ISYM,LSYM REAL RSYM(4,4,96),PHASIN,PHSOUT C DATA LAB1/'H','K','L','F1','SIGF1','PHI','W'/ DATA CTYP1/'H','H','H','F','Q','P','W'/ DATA HSTR/'Created by the program OASIS'/ SINV(I)=SINT(MOD(I+1080,360)+1) COSV(I)=SINT(MOD(I+1080,360)+91) CALL MTZINI CALL LROPEN (1,'HKLIN',0,IFAIL) CALL LWOPEN (1,'HKLOUT') C Read LABOUT card if present REWIND(10) 10 READ(10,'(A132)',END=20) LINE NTOK = 20 CALL PARSER (KEY,LINE,IBEG,IEND,ITYP,FVAL,CCVAL, + IDEC,NTOK,EOF,.FALSE.) CALL CCPUPC(KEY) IF (KEY.NE.'LABO') GO TO 10 CALL LKYOUT(1,LAB1,7,NTOK,LINE,IBEG,IEND) 20 CALL LWHIST (1,HSTR,1) IAPPND = 0 CALL LWASSN(1,LAB1,7,CTYP1,IAPPND) JEND=1 IF(NCYC.EQ.0) NCYC = 1 REWIND(3) DO 2360 J=1,NCYC DO 2020 I=1,NUMB ARG(I)=0.0 2020 CONTINUE 2040 READ(3) IPH1,IPH2 DO 2080 I=1,3000 IF(IPH1(I).NE.0) GOTO 2060 II=IPH2(I) IF(II-NUMB) 2080,2080,2100 2060 IBUF3=IPH1(I)/65536 IE311=IPH2(I)/65536 IPH11=16384-(IPH1(I)-65536*IBUF3) IPH22=16384-(IPH2(I)-65536*IE311) ILA=IABS(IPH11) IRA=IABS(IPH22) M1=ISIGN(1,IPH11) M2=ISIGN(1,IPH22) J1=II J2=ILA J3=IRA IPHQ=M1*IPHP(J2)+M2*IPHP(J3)+IBUF3*15-IPHP(J1) IPHQ=MOD(IPHQ+1440,360) EE=FLOAT(IE311)/100.0 U1=EE*SINV(IDPH(J1)) V1=EE*SINV(IDPH(J2)) W1=EE*SINV(IDPH(J3)) IF(J.GE.2) GOTO 2070 ARG(J1)=ARG(J1)+ESGMH(J2)*ESGMH(J3)*SINV(IPHQ) 1 *COSV(IDPH(J2))*COSV(IDPH(J3))*U1 ARG(J2)=ARG(J2)-ESGMH(J1)*ESGMH(J3)*V1*FLOAT(M1)*SINV(IPHQ) 1 *COSV(IDPH(J1))*COSV(IDPH(J3)) ARG(J3)=ARG(J3)-ESGMH(J2)*ESGMH(J1)*W1*FLOAT(M2)*SINV(IPHQ) 1 *COSV(IDPH(J1))*COSV(IDPH(J2)) GOTO 2080 2070 ARG(J1)=ARG(J1)+( 1 FOM(J2)*FOM(J3)*U1*SINV(IPHQ+M1*IDPB(J2)+M2*IDPB(J3))) ARG(J2)=ARG(J2)+FLOAT(M1)*( 1 FOM(J1)*FOM(J3)*V1*SINV(-IPHQ+IDPB(J1)-M2*IDPB(J3))) ARG(J3)=ARG(J3)+FLOAT(M2)*( 1 FOM(J1)*FOM(J2)*W1*SINV(-IPHQ+IDPB(J1)-M1*IDPB(J2))) 2080 CONTINUE GOTO 2040 2100 REWIND(3) DO 2110 L=1,NUMB IF(ISIM.EQ.1) ARG(L)=ARG(L)+XSIN(L)*SINV(IDPH(L)) PROB(L)=0.5000+0.5*TANH(ARG(L)) IF(NCYC.GT.1.AND.J.EQ.NCYC) ESGMH(L)=1.0 FOM(L)=ESGMH(L)* 1 SQRT(1.-2.*PROB(L)*(1.-PROB(L))*(1.-COSV(2*IDPH(L)))) 2110 CONTINUE C LIST=1 LAST CYCLE PRINT WITH THREE QUEUE LAYOUT(ABSARG,FOM,E). IF(LIST.EQ.1.AND.J.EQ.NCYC) JEND=3 DO 2340 IJ=1,JEND IF(IJ-2) 2120,2140,2150 2120 DO 2130 L=1,NUMB ABSARG(L)=ABS(ARG(L)) 2130 CONTINUE CALL SORT(ABSARG,10,11) GOTO 2160 2140 CALL SORT(FOM,10,10) GOTO 2160 2150 CALL SORT(FO,10,10) 2160 NTOT=0 FTOT=0.0 WTOT=0.0 ERR=0.0 ERRA=0.0 ERRB=0.0 ERRWB=0.0 ERRC=0.0 ERRF=0.0 ERRAF=0.0 IF(PHCOMP.LT.0.5) GOTO 2190 WRITE(6,2165) 2165 FORMAT(/,1X,'COMPARISON OF DERIVED PHASES WITH INPUT PHASES.') WRITE(6,2170) 2170 FORMAT(/1X,' No ERM ERMF ERB ERBW ERC') 2190 DO 2300 L=1,NUMB NTOT=NTOT+1 FTOT=FTOT+FO(L) WTOT=WTOT+FOM(L) IQQ=1 IF(ABS(ARG(L)).NE.0.00) IQQ=SIGN(1.0,ARG(L)) IF(MARK(L).EQ.1) GOTO 2230 IDPB(L)=ATAN2(2.*(PROB(L)-0.5)*SINV(IDPH(L)),COSV(IDPH(L)))/DTOR GOTO 2250 2230 IDPB(L)=ATAN2(FLOAT(IQQ)*SINV(IDPH(L)),COSV(IDPH(L)))/DTOR 2250 IPHC(L)=MOD(IPHP(L)+ISDP(L)*IDPH(L)+360,360) IF(ISDP(L).EQ.0) IPHC(L)=MOD(IPHP(L)+IDPH(L)+360,360) IPHM(L)=MOD(IPHP(L)+IQQ*IDPH(L)+360,360) IPHB(L)=MOD(IPHP(L)+IDPB(L)+360,360) IF(PHCOMP.LT.0.5) GOTO 2300 C COMPARE WITH STANDARD PHASES IDIF=MOD(IPHM(L)-ITPH(L)+1080,360) IF(IDIF.GT.180) IDIF=360-IDIF IPHAV(L)=IPHP(L) IF(IABS(IPHM(L)-IPHAV(L)).GT.90) IPHAV(L)=MOD(IPHAV(L)+180,360) IDIFA=MOD(IPHAV(L)-ITPH(L)+1080,360) IF(IDIFA.GT.180) IDIFA=360-IDIFA IDIFB=MOD(IPHB(L)-ITPH(L)+1080,360) IF(IDIFB.GT.180) IDIFB=360-IDIFB IDIFC=MOD(IPHC(L)-ITPH(L)+1080,360) IF(IDIFC.GT.180) IDIFC=360-IDIFC FNTOT=FLOAT(NTOT) ERR=ERR+IDIF AVER=ERR/FNTOT ERRF=ERRF+IDIF*FO(L) AVERF=ERRF/FTOT C ERRA=ERRA+IDIFA C AVERA=ERRA/FNTOT ERRB=ERRB+IDIFB AVERB=ERRB/FNTOT ERRWB=ERRWB+FOM(L)*IDIFB IF(WTOT.LE.0.1) AVERWB=180.0 IF(WTOT.GT.0.1) AVERWB=ERRWB/WTOT ERRC=ERRC+IDIFC AVERC=ERRC/FNTOT IF(MOD(L,1000).EQ.0.OR.L.EQ.NUMB) WRITE(6,2275) L, 1 AVER,AVERF,AVERB,AVERWB,AVERC 2275 FORMAT(I7,2X,5F7.2) 2300 CONTINUE 2340 CONTINUE IF(J.NE.NCYC) CALL ISORT(IORD,10,10) 2360 CONTINUE WRITE (6,*) CALL LRSYMI(1,MSYMP,LTYPE,NUMSGP,SPGNAM,PGNAME) CALL LRSYMM(1,NSYMM,RSYM) CALL ASUSET(SPGNAM,NUMSGP,PGNAME,NSYMM,RSYM,MSYMP,MLAUE,.FALSE.) DO 2400 I=1,NUMB IHKL(1)=JH(I) IHKL(2)=JK(I) IHKL(3)=JL(I) CALL ASUPUT(IHKL,JHKL,ISYM) LSYM = (ISYM-1)/2 + 1 PHASIN=MOD(IPHP(I)+IDPB(I)+360,360) IISIGN = MOD(ISYM,2)*2 - 1 CALL ASUPHP(JHKL,LSYM,IISIGN,PHASIN,PHSOUT) C--- USE MARK(I) TO STORE BEST PHASES MARK(I)=PHSOUT JH(I)=JHKL(1) JK(I)=JHKL(2) JL(I)=JHKL(3) ABSARG(I)=-((JH(I)+128)*65536+(JK(I)+128)*256+JL(I)+128) 2400 CONTINUE CALL SORT(ABSARG,10,11) DO 2450 I=1,NUMB ADATA1(1)=JH(I) ADATA1(2)=JK(I) ADATA1(3)=JL(I) ADATA1(4)=FO(I) ADATA1(5)=SD(I) ADATA1(6)=MARK(I) ADATA1(7)=FOM(I) CALL LWREFL (1,ADATA1) 2450 CONTINUE CALL LRCLOS(1) CALL LWCLOS(1,1) RETURN END C----------------------------------------------------------------------- SUBROUTINE FITDPH(PHCOMP) C RESTRICT PHASE DIFFERENCES FOR SPECIAL REFLECTIONS AND C FIT THE GENERAL PHASE DIFFERENCES TO A UNIFORM DISTRIBUTION PARAMETER (MAXRE=150000) COMMON /RFLX/ NUMB,JH(MAXRE),JK(MAXRE),JL(MAXRE),IDPH(MAXRE), 1 IPHP(MAXRE),ITPH(MAXRE),IORD(MAXRE),ISDP(MAXRE),IDPB(MAXRE), 2 MARK(MAXRE),FO(MAXRE),SD(MAXRE),E(MAXRE),RSL(MAXRE),XSIN(MAXRE), 3 ESGMH(MAXRE),COSDP(MAXRE),PROB(MAXRE),FOM(MAXRE),ARG(MAXRE), 4 ABSARG(MAXRE),RSLIM,IDTYPE,IFIT COMMON /SYMT/ IS(3,3,24),ITS(3,24),NSYM,LATT,ICENT,PARA(6),NASU, 1 TS(3,24) COMMON /TABL/ SINT(451),DTOR DIMENSION MH(3),IH(3) NUMF=NUMB C FIND AND SEPARATE CENTRIC REFLECTIONS DO 100 J=1,NUMB IH(1)=JH(J) IH(2)=JK(J) IH(3)=JL(J) MARK(J)=0 DO 60 I=1,NSYM IHT=0 DO 50 K=1,3 MH(K)=IS(K,1,I)*IH(1) + IS(K,2,I)*IH(2) + IS(K,3,I)*IH(3) ICHK=IABS(MH(K)+IH(K)) IF(ICHK.EQ.0) IHT=IHT+1 50 CONTINUE IF(IHT.EQ.3) MARK(J)=1 IF(IHT.EQ.3) GO TO 80 60 CONTINUE IF(IDTYPE.EQ.1) GOTO 100 C SEPARATE REFLECTIONS WITH PHASE DIFFERENCE NEAR 90 DEGREES IF(ABS(COSDP(J)).LT.0.1) GOTO 80 GOTO 100 80 NUMF=NUMF-1 COSDP(J)=COSDP(J)-5000.0 100 CONTINUE CALL SORT(COSDP,10,7) IF(IFIT.EQ.1) GOTO 150 DO 120 I=1,NUMF IDPH(I)=ACOS(SIGN(1.0,COSDP(I))*AMIN1(1.0,ABS(COSDP(I))))/DTOR+0.5 120 CONTINUE GOTO 600 C FIT THE REST REFLECTIONS TO A UNIFORM DISTRIBUTION 150 DO 200 I=1,NUMF IDPH(I)=I*180.0/NUMF+0.5 200 CONTINUE C RESTRICT PHASE DIFFERENCES FOR THE SEPARATED REFLECTIONS 600 DO 700 I=NUMF+1,NUMB IDPH(I)=90 IF(IDTYPE.EQ.1) GOTO 700 IF(ABS(COSDP(I)+5000.0).LT.0.1) GOTO 680 IF(COSDP(I)+5000.0.GE.0.1) IDPH(I)=0 IF(COSDP(I)+5000.0.LE.-0.1) IDPH(I)=180 GOTO 700 680 IF(ABS(JH(I))+MH(1).EQ.0.OR.ABS(JK(I))+MH(2).EQ.0.OR. 1 ABS(JL(I))+MH(3).EQ.0) IPHP(I)=MOD(IPHP(I)+90,360) 700 CONTINUE IF(PHCOMP.EQ.0.0) GOTO 900 DO 800 I=1,NUMB IDEF=ITPH(I)-IPHP(I) IF(ABS(IDEF).GT.180) IDEF=ISIGN(1,IDEF)*(ABS(IDEF)-360) ISDP(I)=ISIGN(1,IDEF) IF(MOD(IDEF,180).EQ.0) ISDP(I)=0 800 CONTINUE 900 RETURN END C----------------------------------------------------------------------- SUBROUTINE READER(PHCOMP) C READ REFLEXIONS FROM FORMATED DATA FILE: '*.TM1' PARAMETER (MAXRE=150000) COMMON /RFLX/ NUMB,JH(MAXRE),JK(MAXRE),JL(MAXRE),IDPH(MAXRE), 1 IPHP(MAXRE),ITPH(MAXRE),IORD(MAXRE),ISDP(MAXRE),IDPB(MAXRE), 2 MARK(MAXRE),FO(MAXRE),SD(MAXRE),E(MAXRE),RSL(MAXRE),XSIN(MAXRE), 3 ESGMH(MAXRE),COSDP(MAXRE),PROB(MAXRE),FOM(MAXRE),ARG(MAXRE), 4 ABSARG(MAXRE),RSLIM,IDTYPE,IFIT CHARACTER FM*120,CFM*20 CFM='1234567890., ()EFHIX' NRP=0 NLP=0 PHCOMP=0.0 TEST=0.0 10 READ(1,'(A120)') FM IF(INDEX(FM,'TRPHI').GT.0) PHCOMP=1.0 DO 20 I=1,LEN(FM) IF(INDEX(CFM,FM(I:I)).EQ.0) GOTO 10 IF(FM(I:I).NE.' ') TEST=1.0 IF(FM(I:I).EQ.'(') NRP=NRP+1 IF(FM(I:I).EQ.')') NLP=NLP+1 20 CONTINUE IF(TEST.LT.0.5) GOTO 10 IF((NRP+NLP).EQ.0.OR.NRP.NE.NLP) GOTO 10 I=0 25 IF(PHCOMP.GT.0.5) GOTO 30 I=I+1 READ(1,FM,END=60) JH(I),JK(I),JL(I),FO(I),E(I),COSDP(I),IPHP(I), 1 ESGMH(I),XSIN(I),RSL(I),SD(I) GOTO 25 30 I=I+1 READ(1,FM,END=60) JH(I),JK(I),JL(I),FO(I),E(I),COSDP(I),IPHP(I), 1 ESGMH(I),XSIN(I),RSL(I),ITPH(I),SD(I) GOTO 25 60 NUMB=I-1 CALL FITDPH(PHCOMP) RETURN END C----------------------------------------------------------------------- SUBROUTINE SETUP(NIOR,KUSER2) C ARRANGE REFLEXION DATA AND SET UP ARRAYS OF EQUIVALENT REFLEXIONS PARAMETER (MAXRE=150000) COMMON /AAAA/ IR1(MAXRE*6),IR2(MAXRE*6),LOC(MAXRE*6),I1(3),I2(3), 1 NOUSE(24168) COMMON /CNST/ SGM32,ITLE(80) COMMON /RFLX/ NUMB,JH(MAXRE),JK(MAXRE),JL(MAXRE),IDPH(MAXRE), 1 IPHP(MAXRE),ITPH(MAXRE),IORD(MAXRE),ISDP(MAXRE),IDPB(MAXRE), 2 MARK(MAXRE),FO(MAXRE),SD(MAXRE),E(MAXRE),RSL(MAXRE),XSIN(MAXRE), 3 ESGMH(MAXRE),COSDP(MAXRE),PROB(MAXRE),FOM(MAXRE),ARG(MAXRE), 4 ABSARG(MAXRE),RSLIM,IDTYPE,IFIT COMMON /SYMT/ IS(3,3,24),ITS(3,24),NSYM,LATT,ICENT,PARA(6),NASU, 1 TS(3,24) COMMON /TABL/ SINT(451),DTOR COMMON /USER/ ISIM,ISGM2,KMIN,LIST,NCYC,PHCOMP,IXRAN,IYRAN CHARACTER ITLE NIP=1 NIOR=0 C GENERATE SYMMETRY RELATED REFLEXIONS DO 480 II=1,NUMB I1(1)=JH(II) I1(2)=JK(II) I1(3)=JL(II) DO 450 J=1,NSYM KL1=0 DO 200 I=1,3 KL1=KL1 - I1(I)*ITS(I,J) I2(I)=IS(I,1,J)*I1(1) + IS(I,2,J)*I1(2) + IS(I,3,J)*I1(3) 200 CONTINUE KL3=256*I2(1) + I2(2) KL2=1 IF (KL3 .LT. 0) KL2=-1 IF (KL3 .EQ. 0 .AND. I2(3) .LT. 0) KL2=-1 KL3=IABS(KL3) KL4=I2(3)*KL2 KL1=MOD(KL1*KL2+2400, 24) C ELIMINATE DUPLICATIONS AND USE KL2 +VE AS FAR AS POSSIBLE IF (J .EQ. 1) GOTO 300 DO 240 I=NIP,NIOR IF (KL3 .NE. IR1(I) .OR. KL4 .NE. IR2(I)) GOTO 240 IF (LOC(I) .LT. 0) LOC(I)=(24*II + KL1)*KL2 GOTO 450 240 CONTINUE C STORE PACKED INDICES IN IOR AND CODE IN LOC 300 NIOR=NIOR+1 IF (NIOR .GT. KUSER2) GOTO 500 IR1(NIOR)=KL3 IR2(NIOR)=KL4 LOC(NIOR)=(24*II + KL1)*KL2 450 CONTINUE NIP=NIOR + 1 480 CONTINUE GOTO 900 C TOO MANY REFLEXIONS FOR EXPANSION TO HEMISPHERE - IGNORE EXTRA 500 NUMB=II - 1 NIOR=NIP - 1 C SORT PACKED INDICES KEEPING TRACK OF ADDRESS IN LOC 900 IND=NIOR 1020 IND=IND/2 IF (2*(IND/2) .EQ. IND) IND=IND - 1 IFIN=NIOR - IND DO 1120 II=1,IFIN I=II J=I + IND IF (IR1(I) - IR1(J)) 1120,1030,1040 1030 IF (IR2(I) .LE. IR2(J)) GOTO 1120 1040 K=IR1(J) L=IR2(J) M=LOC(J) 1060 IR1(J)=IR1(I) IR2(J)=IR2(I) LOC(J)=LOC(I) J=I I=I - IND IF (I .LE. 0) GOTO 1100 IF (IR1(I) - K) 1100,1080,1060 1080 IF (IR2(I) .GT. L) GOTO 1060 1100 IR1(J)=K IR2(J)=L LOC(J)=M 1120 CONTINUE IF (IND .GT. 1) GOTO 1020 RETURN END CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C SSSSS IIIII GGGGG M M A 22222 C C S S I G G MM MM A A 2 2 C C S I G M M M M A A 2 C C SSSSS I G GGGG M M M A A 222 C C S I G G M M AAAAAAA 22 C C S S I G G M M A A 2 C C SSSSS IIIII GGGGGG M M A A 2222222 C C C C PROGRAM FOR SETING UP SIGMA2 RELATIONSHIPS C C VERSION 1992 C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC SUBROUTINE SIGMA2(NIOR) C SET UP PHASE RELATIONSHIPS WITH CORRECT SPACE GROUP WEIGHTING PARAMETER (MAXRE=150000) COMMON /AAAA/ IR1(MAXRE*6),IR2(MAXRE*6),LOC(MAXRE*6),STABLE(30), 1 KNOW1(24),KNOW2(24),KNOW3(24),KNOW4(24),KNOW5(24),KNOW6(24), 2 IPH1(8000),IPH2(8000),EEE(8000) COMMON /CNST/ SGM32,ITLE(80) COMMON /RFLX/ NUMB,JH(MAXRE),JK(MAXRE),JL(MAXRE),IDPH(MAXRE), 1 IPHP(MAXRE),ITPH(MAXRE),IORD(MAXRE),ISDP(MAXRE),IDPB(MAXRE), 2 MARK(MAXRE),FO(MAXRE),SD(MAXRE),E(MAXRE),RSL(MAXRE),XSIN(MAXRE), 3 ESGMH(MAXRE),COSDP(MAXRE),PROB(MAXRE),FOM(MAXRE),ARG(MAXRE), 4 ABSARG(MAXRE),RSLIM,IDTYPE,IFIT COMMON /SYMT/ IS(3,3,24),ITS(3,24),NSYM,LATT,ICENT,PARA(6),NASU, 1 TS(3,24) COMMON /TABL/ SINT(451),DTOR COMMON /USER/ ISIM,ISGM2,KMIN,LIST,NCYC,PHCOMP,IXRAN,IYRAN CHARACTER ITLE C T(U)=U*U*(U+0.4807)/((U+0.8636)*U+1.3943) C MAX NO RELATIONSHIPS FOR A REFLEXION - DIMENSION OF IPH1,IPH2,EEE MAXREL=8000 EE3MIN=KMIN NS=2 NSR=0 NSRT=1 IPH1(1)=0 IPH2(1)=1 IFAZQ=0 I=NUMB + 1 JUG=0 C SET UP SINE/COSINE TABLE DO 1000 I=1,30 STABLE(I)=SIN(15.0*DTOR*FLOAT(I-1)) 1000 CONTINUE C INPUT REFLEXION INDICES NN=NUMB C SET UP RELATIONSHIPS FOR EACH REFLEXION IN TURN 1010 DO 1500 I=1,NN IF (JUG.EQ.1) GOTO 1420 INDEX1=256*JH(I)+JK(I) INDEX2=JL(I) ISG=-1 IND1=NIOR IND2=NIOR C MOVE POINTER UP ARRAY 1020 IND1=IND1 - 1 IF (IND1 .LE. 0) GOTO 1100 1040 IF (IR1(IND2)-IR1(IND1)-INDEX1) 1020,1060,1080 1060 IF (IR2(IND2)-IR2(IND1)-INDEX2) 1020,1200,1080 1080 IND2=IND2 - 1 GOTO 1040 1100 ISG=1 C MOVE POINTER DOWN ARRAY 1120 IND1=IND1 + 1 IF (IND1 .GE. IND2) GOTO 1400 1140 IF (IR1(IND2)+IR1(IND1)-INDEX1) 1120,1160,1180 1160 IF (IR2(IND2)+IR2(IND1)-INDEX2) 1120,1200,1180 1180 IND2=IND2 - 1 IF (IND1 - IND2) 1140,1400,1400 C REMOVE 3-FOLD DUPLICATION AND SIGMA1 RELATIONSHIPS 1200 J=IABS(LOC(IND1))/24 K=IABS(LOC(IND2))/24 IF (J .EQ. K) GOTO 1320 IF (I .LE. J .OR. I .LE. K) GOTO 1320 C SET UP RELATIONSHIP 1210 EE3=SGM32*E(I)*E(J)*E(K) EE3=IFIX(ABS(EE3)) IF (EE3 .LT. EE3MIN) GOTO 1320 IPH1(NSRT+1)=ISIGN(J, LOC(IND1))*ISG IPH2(NSRT+1)=ISIGN(K, LOC(IND2)) IFZ=ISG*MOD(IABS(LOC(IND1)),24) + MOD(IABS(LOC(IND2)),24) IFAZE=MOD(IFZ+IFAZQ+240, 24) EEE(NSRT+1)=0.01*(EE3 + 0.01*FLOAT(IFAZE)) IF (K .LT. J) GOTO 1215 L=IPH1(NSRT+1) IPH1(NSRT+1)=IPH2(NSRT+1) IPH2(NSRT+1)=L C TEST FOR DUPLICATIONS 1215 IF (NSRT .LT. NS) GOTO 1240 DO 1220 L=NS,NSRT IF (IABS(IPH1(NSRT+1)) .NE. IABS(IPH1(L))) GOTO 1220 IF (IABS(IPH2(NSRT+1)) .NE. IABS(IPH2(L))) GOTO 1220 IF (IPH1(L) .NE. IPH1(NSRT+1)) GOTO 1320 IF (IPH2(L) - IPH2(NSRT+1)) 1320,1260,1320 1220 CONTINUE C ACCEPT NEW RELATIONSHIP 1240 NSRT=NSRT + 1 NSR=NSR + 1 IF (NSRT - MAXREL) 1320,1420,1420 C RELATIONSHIP ALREADY FOUND - ADD THEM TOGETHER 1260 E3=IFIX(100.0*EEE(L) + 0.5) IFZ=100.0*(100.0*EEE(L) - E3) + 1.5 SR=EE3*STABLE(IFAZE+7) + E3*STABLE(IFZ+6) SI=EE3*STABLE(IFAZE+1) + E3*STABLE(IFZ) EE3=IFIX(SQRT(SR*SR + SI*SI) + 0.5) IFAZE=(ATAN2(SI,SR)/DTOR + 360.0)/15.0 + 0.5 IFAZE=MOD(IFAZE, 24) EEE(L)=0.01*(EE3 + 0.01*FLOAT(IFAZE)) C RETURN TO LOOK FOR NEXT RELATIONSHIP 1320 IF (ISG) 1020,1500,1120 C FOUND ALL THE RELATIONSHIPS FOR THIS REFLEXION 1400 NSRT=NSRT + 1 IPH1(NSRT)=0 IPH2(NSRT)=I + 1 IF (NSRT .LT. 3000) GOTO 1460 1420 DO 1430 L1=1,3000 IF(IPH1(L1).EQ.0) GOTO 1430 IFZ1=100.0*(100.0*EEE(L1) - FLOAT(IFIX(100.0*EEE(L1)+0.5)))+0.5 IE31=INT(100.0*EEE(L1) + 0.5) IPH1(L1)=65536*IFZ1+(16384-IPH1(L1)) IPH2(L1)=65536*IE31+(16384-IPH2(L1)) 1430 CONTINUE WRITE (3) (IPH1(L),L=1,3000),(IPH2(L),L=1,3000) IF(JUG.EQ.1) GOTO 1600 DO 1440 L=3001,NSRT IPH1(L-3000)=IPH1(L) IPH2(L-3000)=IPH2(L) EEE(L-3000)=EEE(L) 1440 CONTINUE NSRT=NSRT - 3000 IF (NSRT+3000 .EQ. MAXREL) GOTO 1320 IF (NSRT .GE. 3000) GOTO 1420 1460 NS=NSRT + 1 1500 CONTINUE JUG=1 GOTO 1010 1600 WRITE (6,1900) NSR 1900 FORMAT(/20X,'NUMBER OF PHASE RELATIONSHIPS =',I10) RETURN END C----------------------------------------------------------------------- SUBROUTINE SORT(A,NI,NF) INTEGER NI,NF PARAMETER (MAXRE=150000) COMMON /RFLX/ NUMB,IP(MAXRE,10),FP(MAXRE,11),RSLIM,IDTYPE,IFIT DIMENSION A(MAXRE),IP1(10),FP1(11) INT=NUMB 100 INT=INT/2 IF(2*(INT/2).EQ.INT) INT=INT-1 IFIN=NUMB-INT DO 1000 II=1,IFIN I=II J=I+INT IF(A(I).GE.A(J)) GOTO 1000 A1=A(J) DO 200 K=1,NI IP1(K)=IP(J,K) 200 CONTINUE DO 300 K=1,NF FP1(K)=FP(J,K) 300 CONTINUE 400 DO 500 K=1,NI IP(J,K)=IP(I,K) 500 CONTINUE DO 600 K=1,NF FP(J,K)=FP(I,K) 600 CONTINUE J=I I=I-INT IF(I.LE.0) GOTO 700 IF(A(I).LT.A1) GOTO 400 700 DO 800 K=1,NI IP(J,K)=IP1(K) 800 CONTINUE DO 900 K=1,NF FP(J,K)=FP1(K) 900 CONTINUE 1000 CONTINUE IF(INT.GT.1) GOTO 100 RETURN END C----------------------------------------------------------------------- SUBROUTINE ISORT(A,NI,NF) INTEGER NI,NF INTEGER A,A1 PARAMETER (MAXRE=150000) COMMON /RFLX/ NUMB,IP(MAXRE,10),FP(MAXRE,11),RSLIM,IDTYPE,IFIT DIMENSION A(MAXRE),IP1(10),FP1(11) INT=NUMB 100 INT=INT/2 IF(2*(INT/2).EQ.INT) INT=INT-1 IFIN=NUMB-INT DO 1000 II=1,IFIN I=II J=I+INT IF(A(I).GE.A(J)) GOTO 1000 A1=A(J) DO 200 K=1,NI IP1(K)=IP(J,K) 200 CONTINUE DO 300 K=1,NF FP1(K)=FP(J,K) 300 CONTINUE 400 DO 500 K=1,NI IP(J,K)=IP(I,K) 500 CONTINUE DO 600 K=1,NF FP(J,K)=FP(I,K) 600 CONTINUE J=I I=I-INT IF(I.LE.0) GOTO 700 IF(A(I).LT.A1) GOTO 400 700 DO 800 K=1,NI IP(J,K)=IP1(K) 800 CONTINUE DO 900 K=1,NF FP(J,K)=FP1(K) 900 CONTINUE 1000 CONTINUE IF(INT.GT.1) GOTO 100 RETURN END