CDC*DECK,XYCM CDC OVERLAY(XRAY,21,0) CDC PROGRAM XRY270 SUBROUTINE XRY270 XYCM0001 C---- XYCM0002 C---- PROGRAMME CAMEL JOCKEY XYCM0003 C---- VERSION OF JUNE 1976... EXPERIMENTAL ABSORPTION,EXTINCTION AND XYCM0004 C---- MISCENTERING CORRECTION PROGRAMME USING MODIFIED GRAM SCHMIDT XYCM0005 C---- TRANSFORMATIONS. XYCM0006 C---- ALRIGHT FOR ANY SPACE GROUP. XYCM0007 C---- XYCM0008 C---- XYCM0009 C---- WRITTEN BY HOWARD FLACK, LABORATOIRE DISCIPLINAIRE DE XYCM0010 C---- CRISTALLOGRAPHIE AUX RAYONS X, 24 QUAI ERNEST ANSERMET, XYCM0011 C---- CH - 1211 GENEVE - 4. SWITZERLAND. (TELEPHONE ) XYCM0012 C---- XYCM0013 C---- XYCM0014 C---- THIS SUBROUTINE IS CALLED BY NUC001 XYCM0015 C---- XYCM0016 C---- AND CALLS ... XRY271,XRY272,XRY274 XYCM0017 C---- AND CALLS NUC002,NUC005,NUC007,NUC014,NUC010,NUC011,NUC013,MORCOR C---- XYCM0019 C---- XYCM0020 C---- XYCM0021 C---- COMMON PACKAGES XYCM0022 C---- XYCM0023 C---- SYSTEM COMMON,DIMENSION AND EQUIVALENCE PACKAGE XYCM0024 C---- XYCM0025 COMMON/SYS/IDCOMP(2),NTIN,NTOUT,NFILEA,NFILEB,NFILEC,NFILED, XYCM0026 *NFILEE,NFILEF,NFILEG,NFILEH,NFILEI,NFILEJ,NCDBUF,NTINM,NTOUTM, XYCM0027 *NTPCHM,IDPROG(2),ITOOB,NPAGE,LINMX,LINCT,NCRDS,ISHORT, XYCM0028 *TITLE(19),CARD(21),QTQ(100),ICYCLE,IQUIT, XYCM0029 *JUNK,JUNK1,JUNK2,JUNK3,JUNK4,IOZY,IOZTM,ICDC(20) XYCM0030 DIMENSION IQTQ(100),ICARD(21),NTIND(1) XYCM0031 EQUIVALENCE (QTQ(1),IQTQ(1)),(NFILEC,NTPCH),(NTCU,NTPCHM) XYCM0032 EQUIVALENCE (CARD(1),ICARD(1)),(NTIND(1),NTIN) XYCM0033 C---- XYCM0034 C---- INPUT - OUTPUT COMMON,DIMENSION AND EQUIVALENCE PACKAGE XYCM0035 C---- XYCM0036 COMMON/IONEW/IORW,IOPLAC,IOMODE(12),IOSIGL(12),IOUNIT(12), 1IODISC(12),IOINST(12) COMMON /IO/MAXREC,IOBMX,IOBUF(4) DIMENSION BUFIO(255) XYCM0038 EQUIVALENCE (IOBUF(1),IOBUF1),(IOBUF(2),IOBUF2),(IOBUF(3),IOBUF3),XYCM0039 *(IOBUF(4),IOBUF4),(IOBUF(1),BUFIO(1)) XYCM0040 C---- XYCM0041 C---- CORE USEAGE COMMON XYCM0042 C---- XYCM0043 COMMON/XYINFO/MAXCOR,MINCOR,MAXUTL,IDPREV(2) XYCM0044 C---- XYCM0045 C---- X-RAY DATA COMMON AND EQUIVALENCE PACKAGE XYCM0046 C---- XYCM0047 COMMON/XYDATA/RI(1) XYCM0048 DIMENSION IR(1) XYCM0049 EQUIVALENCE (RI(1),IR(1)) XYCM0050 C---- C---- COMMON PACKAGE PACK C---- COMMON/PACK/IBITPT,ISIGPK,NITEM,IBITS(310),ITEM(31) C---- XYCM0051 C---- COMMON PACKAGE OMNIA XYCM0052 C---- XYCM0053 COMMON/OMNIA/NOBLAB,NUMREF,LFINAL,MAXH,MAXI,MAXJ,MAXK,MAXL,ICENTR,XYCM0054 1 LSTUDY,ERREUR,QMAX,WOVERD,ABSMU,FACTOR,DOWNWT, 2I,IACPT,IACSP,IAPT,IASP,IBMPT,IBMSP,IBOND,IC,ICFNPT,ICONPT,ICONSD,XYCM0056 3ICONSP,ICPRSP,ICPT,ICSNPT,ICSNSP,ICSP,IFNINC,IFUNCT,IFUNPT,IFUNSP,XYCM0057 4IGRMSH,IH,II,IK,IKEYPT,IKEYSP,IL,IM,IN,INCCYC,INDXC,IP,IPAR,IPRPT,XYCM0058 5IPRSP,IPT,IREFPT,IREFSP,IRUN,ISTOP1,ISTOP2,ISUMPT,ISUMSP,IWKPT, XYCM0059 6IWKSP,IWUNPT,IWUNSP,IW2PT,IW2SP,IZERO,J,JCYCLE,JS,K,KCD,KFUN,L, XYCM0060 7LIMLO,LIMUP,LPARNT,M,MARK1,MARK2,MAXORG,MDATA,N,NPAR, XYCM0061 9ABB(23),AVAL,AW,AWW2,CAMCOR,CONCON,CONST,DAR,DROP,FINMAX,SPHCOR, XYCM0062 ASQ,SSLIM,SSQAGE,SUMF,SUMSQ,W2INV,YW,ZERO,ZSSUM XYCM0063 B,IAPCPT,IAPCSP,LGMSCH,THETA(23),DERIV(23) C---- XYCM0064 C---- DIMENSION AND DATA STATEMENTS FOR XYCM XYCM0065 C---- XYCM0066 DIMENSION IVALMN(10),IVALMX(10),VALMIN(6),VALMAX(6),IVALUE(10) DIMENSION NX(7),NXDF(7),FNX(6),FNXDF(6) DIMENSION IFLST1(3),IFLST2(3) DIMENSION IDATA1(3),IDATA2(2) XYCM0070 EQUIVALENCE(IVALUE(1),NOBLAB), (IVALUE(2),NUMREFXYCM0071 1),(IVALUE(3),LFINAL),(IVALUE(4),MAXH),(IVALUE(5),MAXI),(IVALUE(6),XYCM0072 2MAXJ),(IVALUE(7),MAXK),(IVALUE(8),MAXL),(IVALUE( 9),ICENTR), XYCM0073 3(IVALUE(10),LSTUDY) XYCM0074 EQUIVALENCE (NX(1),NUMREF),(NX(2),LFINAL),(NX(3),MAXH),(NX(4),MAXIXYCM0075 1),(NX(5),MAXJ),(NX(6),MAXK),(NX(7),MAXL) XYCM0076 EQUIVALENCE (FNX(1),ERREUR),(FNX(2),QMAX),(FNX(3),WOVERD), XYCM0077 1(FNX(4),ABSMU),(FNX(5),FACTOR),(FNX(6),DOWNWT) DATA VALMIN(1),VALMIN(2)/ 0.0001,0.2/ XYCM0079 DATA VALMIN(3),VALMIN(4)/ 0.0001,1.0/ XYCM0080 DATA VALMIN(5),VALMIN(6)/2.0,0.0/ DATA VALMAX(1),VALMAX(2)/0.5,20.0/ XYCM0082 DATA VALMAX(3),VALMAX(4)/0.5,4000.0/ XYCM0083 DATA VALMAX(5),VALMAX(6)/100.0,50./ DATA IVALMN(1),IVALMN(2)/0,4/ XYCM0085 DATA IVALMN(3),IVALMN(4)/1,0/ XYCM0086 DATA IVALMN(5),IVALMN(6)/0,0/ XYCM0087 DATA IVALMN(7),IVALMN(8)/0,0/ XYCM0088 DATA IVALMN(9),IVALMN(10)/0,9/ DATA IVALMX(1),IVALMX(2)/2,100/ XYCM0090 DATA IVALMX(3),IVALMX(4)/400,7/ DATA IVALMX(5),IVALMX(6)/2*30/ XYCM0092 DATA IVALMX(7),IVALMX(8)/2*30/ XYCM0093 DATA IVALMX(9),IVALMX(10)/1,5000/ DATA NXDF(1),NXDF(2),NXDF(3),NXDF(4)/25,40,0,3/ DATA NXDF(5),NXDF(6),NXDF(7)/3,6,6/ XYCM0096 DATA FNXDF(1),FNXDF(2),FNXDF(3),FNXDF(4)/0.1,1.0,0.01,30.0/ XYCM0097 DATA FNXDF(5),FNXDF(6)/5.0,0.5/ DATA IBL2,IBL3,IBL4/2H ,3H ,4H / DATA IFLST1(1),IFLST2(1)/2HAB,4HSBON/ XYCM0100 DATA IFLST1(2),IFLST2(2)/ 2HPA,4HRENT/ DATA IFLST1(3),IFLST2(3)/ 2HEN,4HD / DATA IFMAX/3/ DATA EPS3,EPS/ 1.E-3,1.E-6/ XYCM0103 DATA IDATA1(1),IDATA1(2),IDATA1(3)/4HCAML,4H ALL,4H NO/ XYCM0104 DATA IDATA2(1),IDATA2(2)/4H YES,4H NO / DATAIREJ2/ 2HR / C***** C***** C GLOSSARY OF SYMBOLS C ------------------- C C ABB(23) SPHERICAL ABSORPTION CORRECTION VALUES C ABSMU LINEAR ABSORPTION COEFFICIENT C AVAL CURRENT GRAM-SCHMIDT A COEFFICIENT C AW DOT PRODUCT OF FUNCTION VECTOR AND G.S. VECTOR C AWW2 TERM OF G.S.MATRIX C CAMCOR CAMEL CORRECTION VALUE C CONCON CONSTRAINT CONSTANT C(0) C CONST 1.0/8192.0 (PACKING CONSTANT) C DAR PI/180. (CONVERTS DEGREES TO RADIANS) C DOWNWT APPROXIMATE CONSTRAINT DOWNWEIGHTING FACTOR C DROP REDUCTION IN SUM OF SQUARES C EPS 1.E-6 C EPS3 1.E-3 C ERREUR RELATIVE ERROR TO BE TOLERATED ON SAMPLE FIT C FACTOR VALUE USED TO DECIDE IF REFLECTION INTENSITY IS WEAK C FINMAX MAXIMUM INTENSITY IN FILE C FNX FLOATING POINT INPUT QUANTITIES C FNXDF DEFAULT VALUES FOR FNX C IACPT POINTERS FOR PACKED-POWERS OF ACCEPTED C IACSP FUNCTIONS SECTION OF XYDATA ARRAY C IAPCPT POINTERS FOR APPROXIMATE CONSTRAINT SECTION C IAPCSP OF XYDATA ARRAY C IAPT POINTERS FOR A COEFFICIENT SECTION OF C IASP XYDATA ARRAY C IBMPT POINTERS FOR GRAM-SCHMIDT B MATRIX SECTION C IBMSP OF XYDATA ARRAY C IBOND ABSBON CARD COUNTER C ICENTR DIFFRACTOMETER ALIGNED/MISALIGNED INDICATOR C ICFNPT POINTER FOR FUNCTION SUBSECTION OF ICPT-ICSP C ICONPT POINTERS FOR CONSTRAINT COEFFICIENT SECTION C ICONSP OF XYDATA ARRAY C ICONSD NUMBER OF FUNCTIONS TESTED C ICPRSP POINTER FOR PARENT SUBSECTION OF ICPT-ICSP C ICPT POINTERS FOR C COEFFICIENT SECTION OF THE C ICSP XYDATA ARRAY C ICSNPT POINTERS FOR COSINE-SINE ADDRESS SECTION C ICSNSP OF XYDATA ARRAY C IFNINC NUMBER OF FUNCTIONS INCLUDED IN MODEL C IFUNCT NUMBER OF TRIGONOMETRIC FUNCTIONS IN MODEL C IFUNPT POINTERS FOR FUNCTION SECTION OF C IFUNSP XYDATA ARRAY C IGRMSH COUNTER FOR STARTING G.S. VECTORS C IKEYPT POINTERS FOR KEY SECTION OF C IKEYSP XYDATA ARRAY C INCCYC MARKER FOR INCLUSION OF FUNCTIONS IN A CYCLE C INDXC INCREMENT FOR IFUNPT-IFUNSP SECTION OF XYDATA C IPAR POINTER TO PARENT OF AN INPUT REFLECTION C IPRPT POINTERS TO PARENT (CONTAINS SORTWORD) C IPRSP SECTION OF XYDATA C IPT POINTER TO IOBUF FOR UNBUFFERING C IR - RI VARIABLE OF XYDATA ARRAY C IREFPT POINTERS TO THE REFLECTION SECTION OF THE C IREFSP XYDATA ARRAY C IRUN KEY SECTION OF XYDATA INCREMENT C ISTOP1 POINTERS FOR TEMPORARY SECTIONS OF C ISTOP2 XYDATA ARRAY C ISUMPT POINTERS TO SUMS SECTION OF XYDATA ARRAY C ISUMSP C IVALMN MINIMIN VALUES OF INPUT INTEGERS C IVALMX MAXIMUM VALUES OF INPUT INTEGERS C IVALUE INPUT INTEGERS C IWKPT POINTERS TO WORKING SECTION OF XYDATA C IWKSP ARRAY C IWUNPT POINTERS TO FORMATION OF NEW VECTOR C IWUNSP SECTION OF XYDATA ARRAY C IW2PT POINTERS TO LENGTH**2 OF VECTORS SECTION C IW2SP OF XYDATA ARRAY C IZERO 0 C JCYCLE CYCLE COUNTER C KFUN FUNCTION CODE TO BE TESTED C LFINAL NUMBER OF FUNCTIONS WANTED IN FINAL MODEL C LGMSCH NUMBER OF ITEMS IN A GRAM-SCHMIDT VECTOR C LIMLO LOWER LIMIT OF SORT WORD TO BE ACCEPTED C LIMUP UPPER LIMIT OF SORT WORD TO BE ACCEPTED C LSTUDY MAXIMUM NUMBER OF FUNCTIONS TO BE TESTED C MARK1 POINTERS TO TEMPORARY SECTIONS OF XYDATA C MARK2 ARRAY C MAXH MAXIMUM ORDER IN INTENSITY FUNCTION C MAXI MAXIMUM ORDER IN OMEGA FUNCTION C MAXJ MAXIMUM ORDER IN TWO-THETA FUNCTION C MAXK MAXIMUM ORDER IN CHI FUNCTION C MAXL MAXIMUM ORDER IN PHI FUNCTION C MAXORG ORIGINAL CORE SIZE C MDATA NUMBER OF REFLECTIONS FOR CAMEL C NOBLAB PRINTING CONTROL C NPAR NUMBER OF PARENT REFLECTIONS C NUMREF NUMBER OF DATA NECESSARY TO MAKE A PARENT REFLECTION C NX INPUT INTEGER VALUES C NXDF DEFAULT VALUES FOR BLANK INTEGERS C QMAX MAXIMUM VALUE OF Q OF A FUNCTION C SPHCOR SPHERICAL ABSORPTION CORRECTION C SQ CURRENT SUM OF SQUARES C SSLIM LOWEST LIMIT ON SUM OF SQUARES C SSQAGE SUM OF SQUARES ABOUT MEANS C SUMF SUM OF ITEMS IN A FUNCTION VECTOR C SUMSQ INITIAL SUM OF SQUARES C VALMAX MAXIMUM PERMITTED VALUE OF FLOATING-POINT INPUT C VALMIN MINIMUM PERMITTED VALUE OF FLOATING-POINT INPUT C WOVERD COEFFICIENT FOR CORRELATION TEST C W2INV RECIPROCAL LENGTH**2 OF G.S. VECTOR C YW DOT PRODUCT OF G.S. VECTOR AND OBSERVATIONAL VEC. C ZERO SHORTEST PERMITTED LENGTH OF A G.S. VECTOR C ZSSUM SUM FOR WEIGHTED EXPECTED SUM OF SQUARES C C***** C***** C---- SET INITIAL VALUES XYCM0106 MAXUTL = 0 XYCM0107 MDATA = 0 XYCM0108 MAXORG = MAXCOR XYCM0109 IBOND=0 XYCM0110 CONST=1.0/8192.0 XYCM0111 IZERO=0 XYCM0112 DAR=0.0174532925 XYCM0114 ZSSUM=0.0 XYCM0115 C---- ASSIGN ARRAYS FOR PARENT REFLECTIONS IPRPT=1 IPRSP=IPRPT-1 C---- SET MAXIMUM INTENSITY FINMAX = 0.0 C---- SET NUMBER OF PARENTS NPAR = 0 C---- SET UP PACKING CONSTANTS FOR COSINE/SINE VALUES IBITPT = 1 ISIGPK = 1 NITEM = 2 IBITS( 1) = 1 IBITS( 2) = 16 C---- SET UP PACKING CONSTANTS FOR FUNCTION ORDER IBITS(32) = 1 IBITS(33) = 6 IBITS(34) = 11 IBITS(35) = 16 IBITS(36) = 21 IBITS(37) = 26 IBITS(38) = 27 IBITS(39) = 28 IBITS(40) = 29 C**** XYCM0116 C**** XYCM0117 C IN THE 1000 BLOCK THE CAMEL CARD IS READ. THE BLANK XYCM0118 C VALUES ARE RESET TO DEFAULT SETTINGS. THIS IS ACHIEVED BY HAVING XYCM0119 C FIXED POINT INPUT QUANTITIES EQUIVALENCED XYCM0120 C TO ARRAY NX AND FLOATING POINT QUANTITIES TO FNX. DEFAULT XYCM0121 C VALUES ARE GIVEN IN NXDF AND FNXDF. THE VALUES ARE TESTED XYCM0122 C AGAINST BLANKS ON INPUT CARD FOR INTEGERS BECAUSE 0 XYCM0123 C COULD BE THE VALUE WANTED. XYCM0124 C**** XYCM0125 C**** XYCM0126 CIBM READ(NCDBUF,1005) NOBLAB,NUMREF,LFINAL,MAXH,MAXI,MAXJ,MAXK,MAXL DECODE(80,1005,ICDC) NOBLAB,NUMREF,LFINAL,MAXH,MAXI,MAXJ,MAXK,MAXL 1,ICENTR, LSTUDY,ERREUR,QMAX,WOVERD,ABSMU,FACTOR,DOWNWT 1005 FORMAT(13X,2I2,I3,6I2,I4,6F7.2) C---- REREAD IN PREPARATION OF DEFAULT TESTS ON POSSIBLY ZERO VALUES CIBM READ(NCDBUF,1010) (IQTQ(I),I=1,11) DECODE (80,1010,ICDC) (IQTQ(I),I=1,11) 1010 FORMAT(15X,A2,1X,6A2,34X,2(A4,A3)) C---- PUT IN DEFAULT VALUE IF CARD WAS BLANK XYCM0136 DO 1020 I=1,7 XYCM0137 IF(IQTQ(I)-IBL2) 1020,1015,1020 XYCM0138 1015 NX(I) = NXDF(I) XYCM0139 1020 CONTINUE XYCM0140 C---- DEFAULT VALUE FOR LSTUDY XYCM0141 IF(LSTUDY) 1025,1025,1030 XYCM0142 1025 LSTUDY = 500 XYCM0143 C---- DEFAULT VALUES FOR FLOATING POINT QUANTITIES XYCM0144 1030 DO 1040 I=1,4 IF(FNX(I)) 1035,1035,1040 XYCM0146 1035 FNX(I) = FNXDF(I) XYCM0147 1040 CONTINUE XYCM0148 JUNK=4 DO 1043 I=1,3,2 JUNK= JUNK + 1 IF(IQTQ(I+7)-IBL4) 1043,1041,1043 1041 IF(IQTQ(I+8) - IBL3) 1043,1042,1043 1042 FNX(JUNK) = FNXDF(JUNK) 1043 CONTINUE C---- PRINT OUT A RESUME OF THE CAMEL CARD XYCM0149 JUNK = NUC005(17) JUNK = NOBLAB + 1 JUNK1 = ICENTR + 1 CICL WRITE(NTOUT,1045) NUMREF,LFINAL,MAXH,MAXI,MAXJ,MAXK,MAXL,LSTUDY, PRINT 1045, NUMREF,LFINAL,MAXH,MAXI,MAXJ,MAXK,MAXL,LSTUDY, 1ERREUR,QMAX,WOVERD,FACTOR,DOWNWT,IDATA1(JUNK),IDATA2(JUNK1) 2,ABSMU 1045 FORMAT(/19H0CAMEL CONTROL DATA//1H0,2X,9HNUMBER OF,6X,9HNUMBER OF, 14X,29HMAXIMUM TRIAL FUNCTION ORDERS,5X,7HMAXIMUM,5X,8HRELATIVE,4X, 28HFUNCTION,7X,7HMAXIMUM,/2X,12HMEASUREMENTS,4X,9HFUNCTIONS,17X, 32HIN,18X,9HNUMBER OF,5X,5HERROR,7X,6HCHOICE,7X,9HPERMITTED,/,3X, 410HTO QUALIFY,5X,8HEXPECTED,5X,29HINTENS OMEGA 2THETA CHI PHI, 56X,6HTRIALS,5X,2HON,3X,3HFIT,4X,9HPARAMETER,4X,11HCORRELATION,//, 66X,I3,12X,I3,9X,I2,4X,I2,6X,I2,4X,I2,2X,I2,8X,I3,8X,F5.3,9X,F4.2, 710X,F4.3,//12H0 REFLECTION,6X,5HDOWN-,6X,7HREFLCTN,4X,14HDIFFRACTO 8METER, 5X,9HLIN. ABS./4X,5HSIGMA,7X,9HWEIGHTING,4X, 97HLISTING,8X,7HALIGNED, 7X,11HCOEFFICIENT,/4X,6HCUTOFF,7X, *6HFACTOR,36X, 9HIN CM**-1,//5X,F4.1,10X,F4.2,7X,A4,11X, *A4, 8X ,F7.2) C---- TEST INPUT OR RESET VALUES FOR REASONABLENESS(MAX-MIN) XYCM0167 1055 DO 1065 I=1,10 IF(IVALUE(I)-IVALMN(I)) 1085,1060,1060 XYCM0169 1060 IF(IVALUE(I)-IVALMX(I)) 1065,1065,1085 XYCM0170 1065 CONTINUE XYCM0171 DO 1075 I=1,6 IF(FNX(I)-VALMIN(I)) 1085,1070,1070 XYCM0173 1070 IF(FNX(I) - VALMAX(I)) 1075,1075,1085 XYCM0174 1075 CONTINUE XYCM0175 C---- RESET QMAX TO MAKE SURE HIGHEST ORDERS ARE INCLUDED IF SOME MAXIMUXYCM0176 C---- ORDERS ARE ZERO XYCM0177 QMAX=QMAX + 0.005 XYCM0178 IF(LSTUDY-LFINAL) 1085,1095,1095 XYCM0187 1085 JUNK=NUC005(2) XYCM0188 CICL WRITE(NTOUT,1090) XYCM0189 PRINT 1090 XYCM0190 1090 FORMAT(36H0*****CRAZY DATA VALUE ON CAMEL CARD) XYCM0191 GO TO 9975 XYCM0192 1095 CONTINUE XYCM0193 C---- READ IN THE REST OF THE CARDS XYCM0194 CALL NUC002(0,KCD,IFMAX,IFLST1,IFLST2,IQTQ) XYCM0195 GO TO (1100,1185,1125,9975),KCD C---- TREAT AN ABSBON CARD XYCM0197 1100 IBOND = IBOND + 1 XYCM0198 IF(IBOND - 19) 1115,1115,1105 XYCM0199 1105 JUNK = NUC005(2) XYCM0200 CICL WRITE(NTOUT,1110) XYCM0201 PRINT 1110 XYCM0202 1110 FORMAT(40H0THERE SHOULD BE EXACTLY 19 ABSBON CARDS) XYCM0203 GO TO 9975 XYCM0204 1115 CONTINUE XYCM0205 CIBM READ(NCDBUF,1120) THETA(IBOND),ABB(IBOND),DERIV(IBOND),QTQ(43) DECODE(80,1120,ICDC)THETA(IBOND),ABB(IBOND),DERIV(IBOND),QTQ(43) 1120 FORMAT(13X,F4.0,2X,3F10.3) C---- GET TBAR IF(DERIV(IBOND)) 1175,1122,1121 C---- DERIVATIVE ON CARD 1121 DERIV(IBOND)=DERIV(IBOND)*QTQ(43)/ABSMU GO TO 1095 C---- NO DERIVATIVE GIVEN USE LN(A)/MU 1122 DERIV(IBOND) = ALOG(ABB(IBOND))/ABSMU GO TO 1095 XYCM0209 C---- TREAT AN END CARD XYCM0210 1125 CONTINUE XYCM0211 C---- CHECK WE GOT EXACTLY 19 ABSBON CARDS XYCM0212 IF(IBOND-19) 1105,1130,1105 XYCM0213 C---- ADD IN AT END OF TABLE FOR 4 POINT INTERPOLATION XYCM0214 1130 DO 1135 J=1,4 XYCM0215 DERIV(J+19) = DERIV(J+18) 1135 ABB(J+19) = ABB(J + 18) XYCM0216 C---- PRINT OUT THE SPHERICAL ABSORPTION INFORMATION XYCM0217 JUNK=NUC005(24) CICL WRITE(NTOUT,1140) PRINT 1140 1140 FORMAT(/,39H0SPHERICAL ABSORPTION CORRECTION VALUES,/, 116H0THETA ABSCOR,5X,4HTBAR) DO 1150 I=1,19 XYCM0223 CICL WRITE(NTOUT,1145) THETA(I),ABB(I),DERIV(I) PRINT 1145, THETA(I),ABB(I),DERIV(I) 1145 FORMAT(1X,F5.1,F10.4,F9.4) 1150 CONTINUE XYCM0227 C---- CHECK THAT ANGLES GIVEN WERE 0,5,10 ... 90 AND THAT THE XYCM0228 C---- ABSORPTION CORRECTION DIMINISHES WITH ANGLE AND IS GOOD XYCM0229 JUNK=-5 XYCM0230 DO 1170 I=1,19 XYCM0231 JUNK=JUNK+5 XYCM0232 IF(ABS(THETA(I)-FLOAT(JUNK))-0.001) 1155,1155,1175 1155 IF(ABB(I)-ABB(I+1)+0.01) 1175,1175,1160 XYCM0234 1160 IF(ABB(I)-1.00) 1175,1165,1165 XYCM0235 1165 IF(ABB(I)-1333.0) 1170,1170,1175 XYCM0236 1170 CONTINUE XYCM0237 GO TO 1225 1175 JUNK=NUC005(4) XYCM0239 CICL WRITE(NTOUT,1180) I,THETA(I),ABB(I),THETA(I+1),ABB(I+1) PRINT 1180 I,THETA(I),ABB(I),THETA(I+1),ABB(I+1) 1180 FORMAT(63H0*****ABSBON CARD ERROR ... ANGLE OR ABSORBTION VALUE INXYCM0242 1CORRECT,/1H ,I5,F4.0,2X,F10.3,/,1H ,5X,F4.0,2X,F10.3) XYCM0243 GO TO 9975 XYCM0244 C C---- A PARENT CARD C 1185 CONTINUE CIBM READ(NCDBUF,1190) (IQTQ(I),I=1,3) DECODE(80,1190,ICDC) (IQTQ(I),I=1,3) 1190 FORMAT(13X,3I4) C---- CHECK THAT THE HKL ARE REASONABLE DO 1195 I=1,3 IF(IABS(IQTQ(I))-99) 1195,1195,1200 1195 CONTINUE GO TO 1210 1200 JUNK = NUC005(2) CICL WRITE(NTOUT,1205) (IQTQ(I),I=1,3) PRINT 1205 (IQTQ(I),I=1,3) 1205 FORMAT(38H0H K L INDICES ON PARENT CARD TOO BIG.,3I5,13H CARD IGNO 1RED) GO TO 1095 1210 IPRSP = IPRSP + 1 IR(IPRSP) =40000*(IQTQ(1)+100) + 200*(IQTQ(2)+100) + (IQTQ(3) + 1100) NPAR = NPAR + 1 GO TO 1095 1225 IF(NPAR) 1230,1230,2000 1230 JUNK = NUC005(2) CICL WRITE(NTOUT,1235) PRINT 1235 1235 FORMAT(26H0*****NO PARENT CARD FOUND) GO TO 9975 C**** XYCM0245 C**** XYCM0246 C IN THE 2000 BLOCK, THE BINARY DATA FILE WILL BE INITIALIZED C C**** XYCM0254 C**** XYCM0255 2000 CONTINUE C---- READ IN THE B.D.F. FIRST TIME WE DONT WANT TO UPDATE CALL NUC009(0,NFILEA,NFILEB) C**** XYCM0397 C**** XYCM0398 C IN THE 3000 BLOCK, REFLECTIONS HAVING THE SAME (TRANSFORMED) C INDICES AS A PARENT REFLECTION ARE LOADED INTO CORE. C THE REFLECTION SECTION XYCM0401 C OF THE XYDATA ARRAY WILL CONTAIN XYCM0402 C 1. POINTER TO PARENT REFLECTION XYCM0403 C 2. REDUCED INTENSITY (INTENSITY/MAX INTENSITY) XYCM0404 C 3. COS(OMEGA AND SIN(OMEGA) PACKED XYCM0405 C 4. COS(2THETA) AND SIN(2THETA) PACKED. XYCM0406 C 5. COS(CHI) AND SIN(CHI) PACKED. C 6. COS(PHI) AND SIN(PHI) PACKED XYCM0408 C XYCM0409 C AT THE TOP END OF THE STORE WE WILL RESERVE ENOUGH XYCM0410 C SPACE TO STORE CERTAIN SUMS NECESSARY FOR THE PARENT REFLECTIONS. XYCM0411 C THREE WORDS PER PARENT C**** XYCM0412 C**** XYCM0413 C---- SET UP THIRD PART(PERMANENT) REFLECTION SECTION OF XYDATA 3000 IREFSP = IPRSP IREFPT = IPRSP + 1 INDXC=6 XYCM0433 C---- SET UP AND ZERO MARK1 ARRAY FOR SUMS AND COUNTS XYCM0434 MARK1 = MAXCOR - 3*NPAR + 1 ISTOP1=MAXCOR XYCM0436 DO 3025 I=MARK1,ISTOP1 XYCM0437 3025 IR(I) = 0 C---- READ A REFLECTION DATUM AND SEE IF IT IS A PARENT XYCM0442 3030 IPT = NUC013(0,15,NFILEA,NFILEB) IF(IPT) 3110,3110,3035 C---- KEEP MAXIMUM INTENSITY 3035 FINMAX = AMAX1(FINMAX,BUFIO(IPT+4)) C---- DONT CONSIDER WEAK REFLECTIONS XYCM0447 IF(BUFIO(IPT+4)-FACTOR*ABS(BUFIO(IPT+28))) 3030,3040,3040 C---- PACK UP REFLECTION INDI CES 3040 IQTQ(100) = 40000*(IOBUF(IPT+1)+100) + 200*(IOBUF(IPT+2) + 100) 1 +(IOBUF(IPT + 3) + 100) C---- LOOP TO FIND IF ITS A PARENT DO 3085 I= IPRPT,IPRSP IPAR = I IF(IQTQ(100) - IR(I)) 3085,3090,3085 C---- BOTTOM OF PARENT LOOP 3085 CONTINUE C---- THIS REFLECTION IS NOT A PARENT, GET NEXT ONE GO TO 3030 C---- THIS REFLECTION BELONGS TO PARENT POINTED BY IPAR. PUT IT IN CORE 3090 IF(IREFSP+INDXC-MARK1) 3100,3095,3095 C---- NOT ENOUGH CORE AVAILABLE...WHAT IS CURRENT BEST ESTIMATE 3095 JUNK1 = 9*NPAR +9*MDATA + 3*LFINAL + 3 CALL MORCOR(JUNK1) C---- WAS THE CALL ACCEPTED IF(MAXCOR-JUNK1) 3010,3020,3020 3010 JUNK = NUC005(2) CICL WRITE(NTOUT,3015) JUNK1,MAXCOR PRINT 3015, JUNK1,MAXCOR 3015 FORMAT(39H0*****INSUFFICIENT CORE FOR CAMEL NEED,I7,5H ,GOT,I7) GO TO 9975 3020 MAXUTL = MAX0( JUNK1,MAXUTL) C---- COPY UP MARK1 ARRAY TO TOP OF STORE JUNK = 3*NPAR JUNK1 = MAXCOR - JUNK + 1 CALL FMOVE(IR(MARK1),IR(JUNK1),JUNK) MARK1 = JUNK1 ISTOP1 = MAXCOR C---- NOW PUT REFLECTION IN CORE 3100 IR(IREFSP+1) = IPAR - IPRPT + 1 RI(IREFSP+2) = BUFIO(IPT+4) C---- PUT IN PACKED TRIGONOMETRIC FUNCTIONS DO 3105 J=1,4 QTQ(1) = DAR*BUFIO(IPT+J+36) ITEM(1) = IFIX(8192.0*COS(QTQ(1))+8192.5) ITEM(2) = IFIX(8192.0*SIN(QTQ(1))+8192.5) CALL NUC014(IR(IREFSP+J+2)) 3105 CONTINUE C---- ADD INTO SUMS. INTENSITY**-1,INTENSITY**-2,COUNT. JUNK = MARK1 +(IR(IREFSP+1)-1)*3 RI(JUNK)=RI(JUNK) +1.0/RI(IREFSP+2) XYCM0465 RI(JUNK+1) = RI(JUNK+1)+1.0/(RI(IREFSP+2)*RI(IREFSP+2)) IR(JUNK+2) = IR(JUNK+2) + 1 MDATA = MDATA + 1 C---- ADD INTO WEIGHTED EXPECTED SUM OF SQUARES XYCM0466 ZSSUM = ZSSUM + (BUFIO(IPT+28)/BUFIO(IPT+4))**2 IREFSP=IREFSP+INDXC XYCM0469 GO TO 3030 XYCM0470 C---- FINISHED READING 3110 CALL NUC007(NFILEA,0) C---- THE DATA IN CORE NOW HAVE TO BE EXAMINED TO MAKE SURE THERE ARE C---- A SUFFICIENT NUMBER OF DATA PER REFLECTION. C---- PARENTS WITH INSUFFICIENT ARE ELIMINATED AND THE NECESSARY POINTER C---- ARE RESET. THE LIST OF ALL PARENTS IS PRINTED NOW. C---- RESET NUMBER OF PARENTS TO 0 NPAR = 0 C C---- PRINT OUT TITLE JUNK = NUC005(4) CICL WRITE(NTOUT,3115) NUMREF PRINT 3115, NUMREF 3115 FORMAT(46H0PARENT REFLECTIONS (R = REJECTED AS LESS THAN,I5, 7H DA 1TA.),//,6X,1HH,3X,1HK,3X,1HL,6X,4HNOBS) C---- LOOP OVER PARENTS JUNK4 = MARK1 -3 DO 3140 I=IPRPT,IPRSP C---- GET OUT PARENT REFLECTION INDICES AND NUMBER OF REFLECTIONS JUNK4 = JUNK4 + 3 IQTQ(1) = IR(I)/40000 - 100 IQTQ(2) = MOD(IR(I),40000)/200 - 100 IQTQ(3) = MOD(IR(I),200) - 100 IQTQ(4) = IR(JUNK4 + 2) C---- TEST ON NUMBER OF MEASUREMENTS IF( IQTQ(4) - NUMREF) 3125,3120,3120 3120 NPAR = NPAR + 1 IR(IPRPT+NPAR-1) = IR(I) C---- PARENT IS ACCEPTED,COUNT IT,STORE PARENT NUMBER IN PLACE OF NOBS IR(JUNK4 + 2) = NPAR C---- BLANK NOT REJECTED IQTQ(5) = IBL2 GO TO 3130 3125 IR(JUNK4+ 2) = 0 C---- PARENT IS REJECTED. ZERO NOBS,CORRECT MDATA AND MARK REJECTED MDATA = MDATA - IQTQ(4) IQTQ(5) = IREJ2 3130 JUNK = NUC005(1) CICL WRITE(NTOUT,3135) (IQTQ(K),K=1,5) PRINT 3135, (IQTQ(K),K=1,5) 3135 FORMAT(3X,3I4,1X,I8,A2) 3140 CONTINUE C---- DO WE HAVE ANY PARENTS LEFT IF(NPAR) 3141,3141,3144 3141 JUNK = NUC005(2) CICL WRITE(NTOUT,3142) PRINT 3142 3142 FORMAT(22H0NO ACCEPTABLE PARENTS) GO TO 9975 C---- RESET IPRSP FOR (REDUCED) NUMBER OF PARENTS 3144 IPRSP = IPRPT + NPAR - 1 C---- NOW LOOP OVER THE REFLECTION DATA TO UPDATE POINTERS AND ELIMINATE C---- UNWANTED DATA JUNK4 = IREFPT - INDXC DO 3155 I = IREFPT,IREFSP,INDXC JUNK = IR(I)*3 + MARK1 - 3 C---- WAS THIS REFLECTION PARENT ELIMINATED IF(IR(JUNK+2))3155,3155,3145 C---- ACCEPTABLE REFLECTION 3145 JUNK4 = JUNK4 + INDXC C---- REDUCE THE INTENSITY AND RESET PARENT POINTER RI(I+1) = RI(I+1)/FINMAX IR(I) = IR(JUNK+2) C---- MOVE IN CORE IF NEEDS BE IF(I - JUNK4) 3150,3155,3150 3150 CALL FMOVE(IR(I),IR(JUNK4),INDXC) 3155 CONTINUE C---- UPDATE IREFSP IREFSP = JUNK4 + INDXC -1 C---- SEE IF WE HAVE ENOUGH CORE. COUNT SPACE NEEDED. IPRPT, IREFS C---- P,MARK1 AND IW2PT,IWKPT,IBMPT,IFUNPT,IWUNPT,ISUMPT,IACPT SECTIONS C---- WHICH WILL BE DEFINED LATER IN XRY271 BUT WE KNOW THE DESIRED C---- LENGTH NOW. ONLY UNKNOWN IS IKEYPT SECTION JUNK1 = 9*NPAR + 9*MDATA + 3*LFINAL + 2 IF(MAXCOR - JUNK1) 3160,3165,3165 C---- NOT ENOUGH TRY AND INGREASE IT 3160 CALL MORCOR(JUNK1) C---- WAS THE CALL ACCEPTED IF(MAXCOR-JUNK1)3010,3165,3165 3165 MAXUTL = MAX0(JUNK1,MAXUTL) C---- CORRECT COUNTS FOR VALUE OF FINMAX AND REMOVE ELIMINATED PARENT C---- SUMS JUNK1 = MARK1 - 3 DO 3175 I = MARK1,ISTOP1,3 IF(IR(I+2)) 3175,3175,3170 3170 JUNK1 = JUNK1 + 3 RI(JUNK1) = RI(I)*FINMAX RI(JUNK1 + 1) = RI(I+1) *FINMAX*FINMAX IR(JUNK1+2) = IR(I+2) 3175 CONTINUE ISTOP1 = JUNK1 + 2 C**** XYCM0473 C**** XYCM0474 C IN THE 4000 BLOCK, THE KEY IS FORMED IN THE IR XYCM0475 C ARRAY. EACH VALUE IN THE KEY IS A PACKED VALUE OF THE XYCM0476 C POWERS OF THE FUNCTION WHICH IT REPRESENTS IN THE ABSORPTION XYCM0477 C EXTINCTION TRIGONOMETRIC SERIES. ONLY FUNCTIONS WHICH XYCM0478 C HAVE A Q VALUE,(Q=H/MAXH+I/MAXI+J/MAXJ+K/MAXK+L/MAXL) XYCM0479 C SMALLER THAN QMAX ARE INCORPORATED INTO THE KEY TO BE XYCM0480 C TESTED.THE VALUES IN THE KEY ARE SORTED XYCM0481 C INTO ORDER OF INCREASING Q. XYCM0482 C**** XYCM0483 C**** XYCM0484 C---- THE IR ARRAY HAS TWO PERMANENT SECTIONS(PARENT SORT WORDS AND XYCM0485 C---- REFLECTIONS). HERE WE WILL CREATE ONE MORE PERMANENT SECTION XYCM0486 C---- FOR THE KEYS AND Q VALUES WHICH WILL BE COLLAPSED TO KEYS WHEN XYCM0487 C---- SORTING IS COMPLETE XYCM0488 IKEYPT = IREFSP + 1 XYCM0489 IKEYSP = IREFSP XYCM0490 C---- FLOAT,INCREMENT AND INVERSE THE MAXIMUM VALUES INTO QTQ(21) XYCM0491 DO 4000 I=1,5 XYCM0492 C---- THE ADDITION OF EPS SAVES PROBLEMS WHEN MAXIMUM POWER IS ZERO. XYCM0493 4000 QTQ(20+I)=1.0/(FLOAT(NX(I+2)) + EPS3 ) XYCM0494 C---- HERE THERE ARE NINE NESTED DO LOOPS, EACH STARTING AT XYCM0495 C---- ZERO, WHICH REPRESENT VARIATION OF THE FIVE INDICES,H,I, XYCM0496 C---- J,K,L AND THE OTHERS TO INDICATE WHETHER OME,TTH,CHI,PHI, ARE XYCM0497 C---- COSINE OR SINE. XYCM0498 C---- FUNCTION ORDER AND TRIGONOMETRIC INDICATORS ARE PACKED C---- INTO ONE WORD.SET UP COMMON/PACK/ IBITPT = 2 NITEM = 9 ISIGPK = 1 C---- H IS THE INDEX OF THE INTENSITY FUNCTION XYCM0499 DO 4135 IH=IZERO,MAXH XYCM0500 C---- QTQ(1) CONTAINS CONTRIBUTION OF H TO Q XYCM0501 C---- ITEM(1) CONTAINS H QTQ(1)=(FLOAT(IH)+EPS)*QTQ(21) XYCM0503 ITEM(1) = IH C---- IS Q TOO LARGE ... XYCM0505 IF(QTQ(1)-QMAX) 4005,4005,4135 XYCM0506 C---- I IS THE INDEX OF THE OMEGA FUNCTION XYCM0507 4005 DO 4130 I=IZERO,MAXI XYCM0508 C---- QTQ(3) CONTAINS CONTRIBUTION OF H AND I TO Q XYCM0509 C---- ITEM(2) CONTAINS I QTQ(3)=QTQ(1)+(FLOAT(I)+EPS)*QTQ(22) XYCM0511 ITEM(2) = I C---- IS Q TOO LARGE XYCM0513 IF(QTQ(3)-QMAX) 4010,4010,4130 XYCM0514 C---- J IS THE INDEX OF TWO-THETA FUNCTION XYCM0515 4010 DO 4125 J=IZERO,MAXJ XYCM0516 C---- QTQ(5) CONTAINS CONTRIBUTION OF H, I AND J TO Q XYCM0517 C---- ITEMS(3) CONTAINS J QTQ(5)=QTQ(3)+(FLOAT(J)+EPS)*QTQ(23) XYCM0519 ITEM(3) = J C---- IF Q TOO LARGE XYCM0521 IF(QTQ(5)-QMAX) 4015,4015,4125 XYCM0522 C---- K IS THE INDEX OF THE CHI FUNCTION XYCM0523 4015 DO 4120 IK=IZERO,MAXK XYCM0524 C---- QTQ(7) CONTAINS CONTRIBUTION OF H,I,J AND K TO Q XYCM0525 C---- ITEM(4) CONTAINS K QTQ(7)=QTQ(5)+(FLOAT(IK)+EPS)*QTQ(24) XYCM0527 ITEM(4) = IK C---- IS Q TOO LARGE XYCM0529 IF(QTQ(7)-QMAX) 4020,4020,4120 XYCM0530 C---- L IS THE INDEX OF PHI FUNCTION XYCM0531 4020 DO 4115 IL=IZERO,MAXL XYCM0532 C---- QTQ(9) CONTAINS VALUE OF Q FOR H,I,J,K AND L XYCM0533 C---- ITEM(5) CONTAINS L QTQ(9) = QTQ(7)+(FLOAT(IL)+EPS)*QTQ(25) XYCM0535 ITEM(5) = IL C---- IS Q TOO LARGE XYCM0537 IF(QTQ(9)-QMAX) 4025,4025,4115 XYCM0538 C---- GET RID OF PURE TWO THETA FUNCTIONS XYCM0539 4025 IF(I+IK+IL) 4115,4115,4030 XYCM0540 C---- M IS THE INDEX TO SAY WHETHER OMEGA FUNCTION IS SIN OR COS 0/1 XYCM0541 4030 DO 4110 M=IZERO,1 XYCM0542 C---- IS IT SIN(0) .... IF SO SKIP XYCM0543 IF(I+M) 4035,4110,4035 XYCM0544 C---- TEST TO SEE IF OMEGA FUNCTION AGREES WITH PARITIES OF ORDERS XYCM0545 C---- SYMMETRY IN THE FOLLOWING COMMENTS MEANS ASSUMED DIFFRACTOMETER XYCM0546 C---- SYMMETRY. FULL IF MACHINE IS ALIGNED, PARTIAL IF MISALIGNED. XYCM0547 C---- FOR FULL SYMMETRY COS IF (I+K) EVEN, SIN IF (I+K) ODD XYCM0548 C---- FOR LOW SYMMETRY NO RESTRICTION XYCM0549 4035 IF(ICENTR) 4045,4040,4045 XYCM0550 4040 IF(MOD((I+IK),2)-M) 4045,4110,4045 XYCM0551 C---- ITEM(6) CONTAINS M 4045 ITEM(6) = M C---- N IS THE INDEX TO SAY WHETHER 2-THETA FUNCTION IS SINE OR COSINE XYCM0554 DO 4105 N=IZERO,1 XYCM0555 C---- IS IT SINE (0) .... IF SO SKIP XYCM0556 IF(J+N) 4050,4105,4050 XYCM0557 C---- FOR FULL SYMMETRY ACCEPT COS IF I EVEN, SINE IF I ODD XYCM0558 C---- FOR LOW SYMMETRY SAME THING XYCM0559 4050 IF(MOD(I,2)-N) 4055,4105,4055 XYCM0560 C---- FOR CENTERED MACHINE, ALLOW K ZERO ONLY FOR COS(OMEGA)AND COS(TTH) 4055 IF(ICENTR) 4058,4056,4058 4056 IF(M*N*IK) 4105,4058,4105 C---- ITEM(7) CONTAINS N 4058 ITEM(7) = N C---- IC IS THE INDEX TO SAY WHETHER CHI FUNCTION IS SINE OR COSINE. XYCM0563 DO 4100 IC=IZERO,1 XYCM0564 C---- IS IT SINE(0) ....IF SO SKIP XYCM0565 IF(IK+IC) 4060,4100,4060 XYCM0566 C---- FOR FULL SYMMETRY ACCEPT COS IF I+L EVEN, SIN IF I+L ODD XYCM0567 C---- FOR LOW SYMMETRY NO RESTRICTION XYCM0568 4060 IF(ICENTR) 4070,4065,4070 XYCM0569 4065 IF(MOD((I+IL),2)-IC) 4068,4100,4068 C---- WANT L ZERO ONLY FOR SIN*COS*SIN*L 4068 IF((M-1)*N*(IC-1)*IL) 4100,4070,4100 C---- ITEM(8) CONTAINS IC 4070 ITEM(8) = IC C---- IP IS THE INDEX TO SAY WHETHER PHI FUNCTION IS SINE OR COSINE XYCM0573 DO 4095 IP=IZERO,1 XYCM0574 C---- IS IT SINE(0) ....IF SO SKIP XYCM0575 IF(IL+IP) 4075,4095,4075 XYCM0576 C---- FOR FULL SYMMETRY ACCEPT ALL FUNCTIONS XYCM0577 C---- FOR LOW SYMMETRY ACCEPT ALL FUNCTIONS XYCM0578 C---- STORE VALUE OF Q AND KEY ... UPDATE POINTERS XYCM0579 4075 IKEYSP=IKEYSP+2 XYCM0580 C---- IS THERE ENOUGH ROOM XYCM0581 IF(IKEYSP - MAXCOR) 4090,4090, 4080 XYCM0582 C---- TRY AND INCREASE CORE SIZE BY 1000 WORDS XYCM0583 4080 JUNK1= 1000 + MAXCOR XYCM0584 CALL MORCOR(JUNK1) XYCM0585 C---- WAS THE CALL ACCEPTED XYCM0586 IF(MAXCOR-JUNK1) 3010, 4085, 4085 XYCM0587 4085 MAXUTL = MAX0(JUNK1,MAXUTL) XYCM0588 C---- FILL Q AND KEY XYCM0589 4090 RI(IKEYSP)=QTQ(9) XYCM0590 ITEM(9) = IP CALL NUC014(IR(IKEYSP-1)) C---- BOTTOM OF IP LOOP XYCM0592 4095 CONTINUE XYCM0593 C---- BOTTOM OF IC LOOP XYCM0594 4100 CONTINUE XYCM0595 C---- BOTTOM OF N LOOP XYCM0596 4105 CONTINUE XYCM0597 C---- BOTTOM OF M LOOP XYCM0598 4110 CONTINUE XYCM0599 C---- BOTTOM OF IL LOOP XYCM0600 4115 CONTINUE XYCM0601 C---- BOTTOM OF IK LOOP XYCM0602 4120 CONTINUE XYCM0603 C---- BOTTOM OF J LOOP XYCM0604 4125 CONTINUE XYCM0605 C---- BOTTOM OF I LOOP XYCM0606 4130 CONTINUE XYCM0607 C---- BOTTOM OF IH LOOP XYCM0608 4135 CONTINUE XYCM0609 C---- NOW SORT VALUES IN THE KEY BY ORDER OF Q. SORTING IS XYCM0610 C---- SIMPLE MINDED AND DONE BY INTERCHANGE XYCM0611 C---- TEST TO SEE IF THERE ARE NO , ONE OR SEVERAL FUNCTIONS. XYCM0612 C---- NONE...STOP STRAIGHT AWAY, ONE...NO SORTING , SEVERAL..SORT XYCM0613 IF(IKEYSP-IKEYPT - 1) 4140,4170,4150 XYCM0614 4140 JUNK=NUC005(2) XYCM0615 CICL WRITE(NTOUT,4145) XYCM0616 PRINT 4145 XYCM0617 4145 FORMAT(28H0*****NO CANDIDATE FUNCTIONS) XYCM0618 GO TO 9975 XYCM0619 4150 JUNK1 = IKEYSP - 2 XYCM0620 DO 4165 I= IKEYPT,JUNK1,2 XYCM0621 JUNK2 = I+ 2 XYCM0622 DO 4160 J=JUNK2,IKEYSP,2 XYCM0623 C---- TEST TO SEE IF VALUE FURTHER DOWN LIST IS LARGER XYCM0624 IF(RI(I+1)-RI(J+1)) 4160,4160,4155 XYCM0625 C---- IT ISNT DO INTERCHANGE XYCM0626 4155 QTQ(1) = RI(I+1) XYCM0627 RI( I+1)=RI(J+1) XYCM0628 RI(J+1) = QTQ(1) XYCM0629 IQTQ(1) = IR(I) XYCM0630 IR(I) = IR(J) XYCM0631 IR(J) = IQTQ(1) XYCM0632 4160 CONTINUE XYCM0633 4165 CONTINUE XYCM0634 C---- COLLAPSE KEY ARRAY REMOVING THE VALUES OF Q XYCM0635 4170 JUNK = IKEYPT-1 XYCM0636 DO 4175 I=IKEYPT , IKEYSP,2 XYCM0637 JUNK= JUNK +1 XYCM0638 4175 IR(JUNK) = IR(I) XYCM0639 IKEYSP = JUNK XYCM0640 C**** XYCM0641 C**** XYCM0642 C IN THE 5000 BLOCK WE CALL XRY271 TO FORM XYCM0643 C THE FIRST PART OF GRAM-SCHMIDT MATRIX WHICH TAKES THE XYCM0644 C INTENSITIES OF THE PARENT REFLECTIONS AS FUNCTIONS. XYCM0645 C THESE ARE ALWAYS ALWAYS ALWAYS INCLUDED AS FUNCTIONS. XYCM0646 C XRY271 WILL ALSO CALCULATE THE INITIAL SUM OF SQUARES XYCM0647 C OF THE SCALED INTENSITIES ABOUT THEIR MEAN, ZERO ... THE XYCM0648 C MULTIPLE CORRELATION FACTOR LENGTH PREPARE THE XYCM0649 C CAMEL INTERNAL SCRATCH FILES, AND ARRANGE THE CORE XYCM0650 C**** XYCM0651 C**** XYCM0652 C---- CONTROL OF VALUES....KEEP GOING ANYWAY XYCM0653 IF(NPAR-LFINAL) 5010,5000,5000 XYCM0654 5000 JUNK=NUC005(2) XYCM0655 CICL WTITE(NTOUT,5005) NPAR,LFINAL XYCM0656 5005 FORMAT(41H0*****THERE ARE MORE PARENT REFLECTIONS (,I5,18H) THAN FXYCM0657 1UNCTIONS (,I5,28H) WANTED IN FINAL EXPRESSION) XYCM0658 5010 IF(MDATA-LFINAL) 5015,5015,5025 XYCM0659 5015 JUNK = NUC005(2) XYCM0660 CICL WRITE(NTOUT,5020) MDATA,LFINAL XYCM0661 PRINT 5020,MDATA,LFINAL XYCM0662 5020 FORMAT(40H0*****THERE ARE LESS DATA MEASUREMENTS (,I5,17H) THAN FU 1NCTIONS(,I5,28H) WANTED IN FINAL EXPRESSION) XYCM0664 5025 CALL XRY271 XYCM0665 IF(IQUIT) 6005,6000,6005 XYCM0666 C**** XYCM0667 C**** XYCM0668 C IN THE 6000 BLOCK WE CALL XRY272 TO DO THE XYCM0669 C MULTIDIMENSIONAL FIT XYCM0670 C**** XYCM0671 C**** XYCM0672 6000 CALL XRY272 XYCM0673 IF(IQUIT) 6015,6015,6005 XYCM0674 6005 JUNK=NUC005(2) XYCM0675 CICL WRITE(NTOUT,6010) XYCM0676 PRINT 6010 XYCM0677 6010 FORMAT(31H0MULTI-DIMENSIONAL FIT FAILURE.) XYCM0678 GO TO 9975 XYCM0679 6015 CONTINUE XYCM0680 C**** XYCM0681 C**** XYCM0682 C IN THE 7000 BLOCK XRY274 IS CALLED TO APPLY THE CORRECTIONS TO ALLXYCM0683 C OF THE DATA ON NFILEE XYCM0684 C**** XYCM0685 C**** XYCM0686 CALL XRY274 XYCM0687 C---- RESET CORE TO INITIAL VALUE IF ITS CHANGED XYCM0688 IF(MAXORG - MAXCOR) 7000,7005,7005 XYCM0689 7000 CALL MORCOR(MAXORG) XYCM0690 7005 CONTINUE XYCM0691 GO TO 9999 XYCM0692 9975 IQUIT=1 XYCM0693 9999 CONTINUE XYCM0694 RETURN XYCM0695 END XYCM0696 CDC*DECK,CMST SUBROUTINE XRY271 CMST0001 C---- CMST0002 C---- CMST0003 C---- SUBROUTINE CMST TO START THE GRAM-SCHMIDT PROCESS FOR THE PARENT CMST0004 C---- REFLECTIONS AND TO FORM THE INITIAL SUM OF SQUARES CMST0005 C---- CMST0006 C---- THIS SUBROUTINE IS CALLED BY XRY270 CMST0007 C---- CMST0008 C---- AND CALLS NUC005,NUC007,NUC112,NUC217,MORCOR CMST0009 C---- CMST0010 C---- SYSTEM COMMON,DIMENSION AND EQUIVALENCE PACKAGE CMST0011 C---- CMST0012 COMMON/SYS/IDCOMP(2),NTIN,NTOUT,NFILEA,NFILEB,NFILEC,NFILED, CMST0013 *NFILEE,NFILEF,NFILEG,NFILEH,NFILEI,NFILEJ,NCDBUF,NTINM,NTOUTM, CMST0014 *NTPCHM,IDPROG(2),ITOOB,NPAGE,LINMX,LINCT,NCRDS,ISHORT, CMST0015 *TITLE(19),CARD(21),QTQ(100),ICYCLE,IQUIT, CMST0016 *JUNK,JUNK1,JUNK2,JUNK3,JUNK4,IOZY,IOZTM,ICDC(20) CMST0017 DIMENSION IQTQ(100),ICARD(21),NTIND(1) CMST0018 EQUIVALENCE (QTQ(1),IQTQ(1)),(NFILEC,NTPCH),(NTCU,NTPCHM) CMST0019 EQUIVALENCE (CARD(1),ICARD(1)),(NTIND(1),NTIN) CMST0020 C---- CMST0021 C---- INPUT - OUTPUT COMMON,DIMENSION AND EQUIVALENCE PACKAGE CMST0022 C---- CMST0023 COMMON/IO/MAXREC,IOBMX,IOBUF(255) CMST0024 DIMENSION BUFIO(255) CMST0025 EQUIVALENCE (IOBUF(1),IOBUF1),(IOBUF(2),IOBUF2),(IOBUF(3),IOBUF3),CMST0026 *(IOBUF(4),IOBUF4),(IOBUF(1),BUFIO(1)) CMST0027 C---- CMST0028 C---- CORE USEAGE COMMON CMST0029 C---- CMST0030 COMMON/XYINFO/MAXCOR,MINCOR,MAXUTL,IDPREV(2) CMST0031 C---- CMST0032 C---- X-RAY DATA COMMON AND EQUIVALENCE PACKAGE CMST0033 C---- CMST0034 COMMON/XYDATA/RI(1) CMST0035 DIMENSION IR(1) CMST0036 EQUIVALENCE (RI(1),IR(1)) CMST0037 C---- CMST0038 C---- COMMON PACKAGE OMNIA CMST0039 C---- CMST0040 COMMON/OMNIA/NOBLAB,NUMREF,LFINAL,MAXH,MAXI,MAXJ,MAXK,MAXL,ICENTR,CMST0041 1 LSTUDY,ERREUR,QMAX,WOVERD,ABSMU,FACTOR,DOWNWT, 2I,IACPT,IACSP,IAPT,IASP,IBMPT,IBMSP,IBOND,IC,ICFNPT,ICONPT,ICONSD,CMST0043 3ICONSP,ICPRSP,ICPT,ICSNPT,ICSNSP,ICSP,IFNINC,IFUNCT,IFUNPT,IFUNSP,CMST0044 4IGRMSH,IH,II,IK,IKEYPT,IKEYSP,IL,IM,IN,INCCYC,INDXC,IP,IPAR,IPRPT,CMST0045 5IPRSP,IPT,IREFPT,IREFSP,IRUN,ISTOP1,ISTOP2,ISUMPT,ISUMSP,IWKPT, CMST0046 6IWKSP,IWUNPT,IWUNSP,IW2PT,IW2SP,IZERO,J,JCYCLE,JS,K,KCD,KFUN,L, CMST0047 7LIMLO,LIMUP,LPARNT,M,MARK1,MARK2,MAXORG,MDATA,N,NPAR, CMST0048 9ABB(23),AVAL,AW,AWW2,CAMCOR,CONCON,CONST,DAR,DROP,FINMAX,SPHCOR, CMST0049 ASQ,SSLIM,SSQAGE,SUMF,SUMSQ,W2INV,YW,ZERO,ZSSUM CMST0050 B,IAPCPT,IAPCSP,LGMSCH ,THETA(23),DERIV(23) C---- CALCULATE ARRANGEMENT OF STORE ... WE NEED THE FOLLOWING CMST0051 C---- SPACE FOR THE CALCULATIONS. CMST0052 C---- IAPCPT FOR WEIGHTED FACTOR OF PARENT TO APPLY THE APROXIMATE C---- CONSTRAINT OBSERVATIONAL EQUATION. C---- IW2PT FOR LENGTH**2 OF ACCEPTED FUNCTIONS(W) CMST0053 C---- IWKPT FOR GRAM-SCHIMDT VECTOR OF AN ACCEPTED FUNCTION CMST0054 C---- IBMPT FOR COLUMN OF MATRIX B GRAM-SCHMIDT CMST0055 C---- IFUNPT FOR VECTOR OF FUNCTION VALUES CMST0056 C---- IWUNPT FOR VECTOR OF FUNCTION BEING CURRENTLY TRANSFORMED CMST0057 C---- ISUMPT FOR VECTOR OF FUNCTION SUMS OVER PARENTS TO SAVE READING CMST0058 C---- NFILEI FOR G-S TRANSFORMATION OF PARENTS. CMST0059 C---- IACPT FOR PACKED POWERS OF ACCEPTED FUNCTIONS CMST0060 IAPCPT = IKEYSP + 1 IAPCSP = IKEYSP + NPAR IW2PT= IAPCSP + 1 IW2SP = IAPCSP +LFINAL IWKPT = IW2SP + 1 CMST0063 IWKSP = IW2SP+MDATA+NPAR IBMPT = IWKSP + 1 CMST0065 IBMSP = IWKSP + LFINAL+2 CMST0066 IFUNPT = IBMSP + 1 CMST0067 IFUNSP = IBMSP + MDATA + NPAR IWUNPT = IFUNSP + 1 CMST0069 IWUNSP = IFUNSP + MDATA + NPAR ISUMPT=IWUNSP + 1 CMST0071 ISUMSP = IWUNSP + NPAR CMST0072 IACPT=ISUMSP + 1 CMST0073 IACSP = ISUMSP + LFINAL CMST0074 C---- HOPE WE HAVE ENOUGH SPACE ... THERE ARE STILL THE SUMS CMST0075 C---- IN MARK1 ARRAY AT TOP END OF STORE BUT WE CMST0076 C---- USE THESE BEFORE WRITING INTO IACPT CMST0077 IF(IACSP - MAXCOR) 515,515,500 CMST0078 C---- TRY AND INCREASE CORE SIZE CMST0079 500 CALL MORCOR(IACSP) CMST0080 C---- WAS THE CALL ACCEPTED CMST0081 IF(MAXCOR-IACSP) 505,515,515 CMST0082 505 JUNK = NUC005(2) CMST0083 IQUIT = 1 CMST0084 CICL WRITE(NTOUT,510) IACSP CMST0085 PRINT 510,IACSP CMST0086 510 FORMAT(17H0*****CAMEL NEEDS ,I10,10H CORE SIZE) CMST0087 GO TO 9975 CMST0088 515 MAXUTL = MAX0(MAXUTL,IACSP ) CMST0089 C---- PRINT A TITLE CMST0090 JUNK = NUC005(7) CICL WRITE(NTOUT,520) CMST0092 PRINT 520 CMST0093 520 FORMAT(/22H0MULTI-DIMENSIONAL FIT,/,1H0,66X,1HA,9X,11HDROP IN SUM, 16X,6HSUM OF,9X,6HLENGTH,/,24X,8HFUNCTION,30X,11HCOEFFICIENT,4X, 210HOF SQUARES,7X,7HSQUARES,8X,7HSQUARED,/) C---- START UP THE SCRATCH FILES CMST0098 C---- CMST0099 C---- NFILEG IS USED TO STORE THE GRAM SCHMIDT MATRIX B ,THE LINEAR CON.CMST0100 C---- AND COEFFICIENT A. IT WILL USE BUFFER IOBUF CMST0101 CALL NUC007(NFILEG,0) CMST0102 IOBUF1 = 4 CMST0103 IOBUF2 = 1 CMST0104 IOBUF3 = 1 CMST0105 IOBUF4 = 0 CMST0106 C---- NFILEI IS USED TO STORE THE ACCEPTED GRAM SCHMIDT CMST0107 C---- VECTORS. SINCE THE SCRATCH IS USED A LOT AND THE VECTOR CMST0108 C---- IS NORMALLY LONGER THAN THE X-RAY BUFFERS WE SAVE A CMST0109 C---- LOT OF TIME BY TRANSFERING DIRECTLY IN AND OUT OF CMST0110 C---- THE XYDATA ARRAY WITH NUCLEUS SUBROUTINE NUC217 CMST0111 C---- ESPECIALLY DESIGNED FOR CAMEL. CMST0112 C---- GRAM SCHMIDT VECTORS FOR PARENTS ARE NOT PUT ONTO NFILEI, SINCE ALCMST0113 C---- THE INFORMATION IS IN CORE AND WE CAN SAVE SOME CPU AND I/O TIME CMST0114 C---- SET LENGTH OF GRAM SCHMIDT VECTORS LGMSCH = MDATA + NPAR CALL NUC217(NFILEI,IR(1),LGMSCH,2) C---- RESCALE DOWNT DOWNWT = DOWNWT*SQRT(FLOAT(MDATA)/FLOAT(NPAR)) C---- SET WEIGHTED SUM OF SQUARES CMST0116 SUMSQ=FLOAT(MDATA) C**** CMST0118 C**** CMST0119 C IN THE 1000 BLOCK WE BUILD THE G.S VECTOR AND MATRIX CMST0120 C ELEMENTS FOR EACH PARENT AT A TIME. WE ALSO CALCULATE CMST0121 C THE CONTRIBUTION OF EACH SCALED-SHIFTED(BY ITS MEAN) CMST0122 C INTENSITY TO THE SUM OF SQUARES. CMST0123 C THE G.S VECTOR FOR THE MDATA POINTS FOR A PARENT REFLECTION CMST0124 C HAS SQRT-WEIGHT IF A POINT BELONGS TO THE PARENT AND ZERO CMST0125 C---- OTHERWISE, FOR THE NPAR POINTS WHICH AUGMENT THE G.S. C---- VECTOR, THE VALUE IS ALWAYS ZERO C THE G.S MATRIX IS DIAGONAL WITH 1 ON THE DIAGONALS FOR CMST0127 C PARENTS CMST0128 C THE W2 SECTION HAS VALUE SUM(SQRT-WEIGHT**2) CMST0129 C OF DATA POINTS FOR A PARENT CMST0130 C THE VALUE OF A IS SUM(INTENSITY*SQRT-WEIGHT**2)/SUM(SQRT-WEIGHT**2CMST0131 C**** CMST0132 C**** CMST0133 C---- SET SUM OF SQUARES TO INITIAL VALUE CMST0134 SSQAGE = SUMSQ CMST0135 C---- LOOP OVER PARENT REFLECTIONS CMST0136 JUNK3 = MARK1-3 JUNK2 = IPRPT-1 DO 1045 I= 1,NPAR CMST0138 C---- CALCULATE VALUE OF A FOR THIS PARENT CMST0139 JUNK2 = JUNK2+1 JUNK3 = JUNK3 + 3 AVAL = RI (JUNK3)/RI(JUNK3+1) CMST0141 C---- FILL IAPCPT PART OF ARRAY WITH DOWNWT/(SUM INTENSITY**-1) RI(IAPCPT+I-1) = DOWNWT/RI(JUNK3) C---- TAKE OFF CONTRIBUTION TO SUM OF SQUARES CMST0142 DROP = AVAL*RI(JUNK3) CMST0143 SSQAGE = SSQAGE - DROP CMST0144 C---- PUT LENGTH**2 INTO W2 SECTION CMST0145 RI(IW2PT + I -1) = RI(JUNK3+1) CMST0146 C---- PUT AVAL,LINEAR CONSTRAINT COEFFICENT AND COLUMN OF MATRIX B INTO CMST0147 C---- OUTPUT BUFFER CMST0148 C---- IS THERE ENOUGH ROOM ... CMST0149 IF(IOBUF1 + I + 2 - IOBMX) 1010,1010,1005 CMST0150 1005 CALL NUC112(NFILEG,IOBUF,IOBMX) CMST0151 IOBUF2 = IOBUF2 + 1 CMST0152 IOBUF1=4 CMST0153 1010 BUFIO(IOBUF1 + 1) = AVAL CMST0154 C---- LINEAR CONSTRAINT COEFFICENT CMST0155 BUFIO(IOBUF1 + 2 ) = 0.0 CMST0156 C---- NOW PUT IN THE MATRIX B ... DIAGONAL CMST0157 IF(I - 2) 1025,1015,1015 CMST0158 1015 DO 1020 J=2,I CMST0159 1020 BUFIO(IOBUF1+1+J) = 0.0 CMST0160 1025 BUFIO(IOBUF1 + I + 2) = 1.0 CMST0161 IOBUF1 = IOBUF1 + I + 2 CMST0162 C---- GET PARENT REFLECTION INDICES IQTQ(61)= IR(JUNK2)/40000 - 100 IQTQ(62)= MOD(IR(JUNK2),40000)/200 - 100 IQTQ(63)= MOD(IR(JUNK2),200) - 100 C---- PRINT INFORMATION ON THIS PARENT CMST0163 IF(NUC005(1)) 1030,1035,1030 CMST0164 1030 JUNK = NUC005(7) CICL WRITE(NTOUT,520) CMST0166 PRINT 520 CMST0167 1035 CONTINUE CMST0168 CICL WRITE(NTOUT,1040) I,I,(IQTQ(J),J=61,63),AVAL,DROP,SSQAGE, PRINT 1040, I,I,(IQTQ(J),J=61,63),AVAL,DROP,SSQAGE, 1RI(IW2PT+I-1) 1040 FORMAT(1X,I3,1H),2X,13HPARENT NUMBER,I4,15H. H K L INDICES,3I4, 16X,4E15.5) 1045 CONTINUE CMST0172 C---- CALCULATE ZERO CMST0173 ZERO = WOVERD * SSQAGE CMST0174 C---- CALCULATE LIMIT ON SUM OF SQUARES CMST0175 SSLIM= ERREUR*ERREUR*SSQAGE CMST0176 C---- WEVE NOW DONE ALL THAT WAS REQUIRED ... MARK1 ARRAY CMST0177 C---- NO LONGER REQUIRED CMST0178 9975 CONTINUE CMST0179 RETURN CMST0180 END CMST0181 CDC*DECK,CMMU SUBROUTINE XRY272 CMMU0001 C---- CMMU0002 C---- CMMU0003 C---- SUBROUTINE CMMU TO DO THE MULTIDIMENSIONAL FIT USING THE CMMU0004 C---- MODIFIED GRAM SCHMIDT TRANSFORMATIONS CMMU0005 C---- CMMU0006 C---- THIS SUBROUTINE IS CALLED BY XRY270 CMMU0007 C---- CMMU0008 C---- AND CALLS XRY273 CMMU0009 C---- AND NUC005,NUC007,NUC014,NUC111,NUC112,NUC217,MORCOR C---- CMMU0011 C---- CMMU0012 C---- SYSTEM COMMON,DIMENSION AND EQUIVALENCE PACKAGE CMMU0013 C---- CMMU0014 COMMON/SYS/IDCOMP(2),NTIN,NTOUT,NFILEA,NFILEB,NFILEC,NFILED, CMMU0015 *NFILEE,NFILEF,NFILEG,NFILEH,NFILEI,NFILEJ,NCDBUF,NTINM,NTOUTM, CMMU0016 *NTPCHM,IDPROG(2),ITOOB,NPAGE,LINMX,LINCT,NCRDS,ISHORT, CMMU0017 *TITLE(19),CARD(21),QTQ(100),ICYCLE,IQUIT, CMMU0018 *JUNK,JUNK1,JUNK2,JUNK3,JUNK4,IOZY,IOZTM,ICDC(20) CMMU0019 DIMENSION IQTQ(100),ICARD(21),NTIND(1) CMMU0020 EQUIVALENCE (QTQ(1),IQTQ(1)),(NFILEC,NTPCH),(NTCU,NTPCHM) CMMU0021 EQUIVALENCE (CARD(1),ICARD(1)),(NTIND(1),NTIN) CMMU0022 C---- CMMU0023 C---- INPUT - OUTPUT COMMON,DIMENSION AND EQUIVALENCE PACKAGE CMMU0024 C---- CMMU0025 COMMON/IO/MAXREC,IOBMX,IOBUF(255) CMMU0026 DIMENSION BUFIO(255) CMMU0027 EQUIVALENCE (IOBUF(1),IOBUF1),(IOBUF(2),IOBUF2),(IOBUF(3),IOBUF3),CMMU0028 *(IOBUF(4),IOBUF4),(IOBUF(1),BUFIO(1)) CMMU0029 C---- CMMU0030 C---- X-RAY DATA COMMON AND EQUIVALENCE PACKAGE CMMU0031 C---- CMMU0032 COMMON/XYDATA/RI(1) CMMU0033 DIMENSION IR(1) CMMU0034 EQUIVALENCE (RI(1),IR(1)) CMMU0035 C---- CMMU0036 C---- CORE USEAGE COMMON CMMU0037 C---- CMMU0038 COMMON/XYINFO/MAXCOR,MINCOR,MAXUTL,IDPREV(2) CMMU0039 C---- C---- COMMON PACKAGE PACK C---- COMMON/PACK/IBITPT,ISIGPK,NITEM,IBITS(310),ITEM(31) C---- CMMU0040 C---- COMMON PACKAGE OMNIA CMMU0041 C---- CMMU0042 COMMON/OMNIA/NOBLAB,NUMREF,LFINAL,MAXH,MAXI,MAXJ,MAXK,MAXL,ICENTR,CMMU0043 1 LSTUDY,ERREUR,QMAX,WOVERD,ABSMU,FACTOR,DOWNWT, 2I,IACPT,IACSP,IAPT,IASP,IBMPT,IBMSP,IBOND,IC,ICFNPT,ICONPT,ICONSD,CMMU0045 3ICONSP,ICPRSP,ICPT,ICSNPT,ICSNSP,ICSP,IFNINC,IFUNCT,IFUNPT,IFUNSP,CMMU0046 4IGRMSH,IH,II,IK,IKEYPT,IKEYSP,IL,IM,IN,INCCYC,INDXC,IP,IPAR,IPRPT,CMMU0047 5IPRSP,IPT,IREFPT,IREFSP,IRUN,ISTOP1,ISTOP2,ISUMPT,ISUMSP,IWKPT, CMMU0048 6IWKSP,IWUNPT,IWUNSP,IW2PT,IW2SP,IZERO,J,JCYCLE,JS,K,KCD,KFUN,L, CMMU0049 7LIMLO,LIMUP,LPARNT,M,MARK1,MARK2,MAXORG,MDATA,N,NPAR, CMMU0050 9ABB(23),AVAL,AW,AWW2,CAMCOR,CONCON,CONST,DAR,DROP,FINMAX,SPHCOR, CMMU0051 ASQ,SSLIM,SSQAGE,SUMF,SUMSQ,W2INV,YW,ZERO,ZSSUM CMMU0052 B,IAPCPT,IAPCSP,LGMSCH ,THETA(23),DERIV(23) C---- CMMU0053 C---- XRY272 DIMENSION AND DATA PACKAGE CMMU0054 C---- CMMU0055 DIMENSION IDATA1(2) CMMU0056 DATA IDATA1(1),IDATA1(2)/3HSIN,3HCOS/ C**** CMMU0058 C IN THE 1000 BLOCK THE SELECTION OF SUITABLE CMMU0059 C FUNCTIONS TAKES PLACE BASED ON THEIR REDUCTION IN THE SUM OF CMMU0060 C SQUARES. THE GRAM-SCHMIDT MATRIX AND COEFFICENTS ARE KEPT ON A CMMU0061 C SCRATCH FILE. FITTING STOPS WHEN 3 CYCLES ARE COMPLETED, OR CMMU0062 C THE DESIRED PRECISION IS ATTAINED, OR WE HAVE DESIRED CMMU0063 C NUMBER OF FUNCTIONS OR WE HAVE TRIED ENOUGH FUNCTIONS. CMMU0064 C**** CMMU0065 C---- IFNINC COUNTS THE NUMBER OF FUNCTIONS ALREADY INCLUDED CMMU0066 IFNINC=NPAR CMMU0067 C---- IGRMSH GIVES STARTING POINTER TO VECTORS IN G.S FILE CMMU0068 IGRMSH = NPAR + 1 CMMU0069 C---- INCCYC INDICATES WHETHER A FUNCTION WAS INCLUDED IN PREVIOUS CMMU0070 C---- CYCLE CMMU0071 INCCYC=-1 CMMU0072 C---- SET SUM OF SQUARES TO INITIAL VALUE CMMU0073 SQ=SSQAGE CMMU0074 C---- ICONSD COUNTS THE NUMBER OF FUNCTIONS ALREADY CMMU0075 C---- CONSIDERED CMMU0076 ICONSD=NPAR CMMU0077 C---- LOOP 3 TIMES OVER AVAILABLE FUNCTIONS ... CMMU0078 DO 1195 JCYCLE =1,3 CMMU0079 C---- INCCYC INDICATES WHETHER A FUNCTION WAS INCLUDED IN CMMU0080 C---- PREVIOUS CYCLE CMMU0081 IF(INCCYC) 1015,1005,1015 CMMU0082 1005 JUNK=NUC005(2) CMMU0083 JUNK=JCYCLE-1 CMMU0084 CICL WRITE(NTOUT,1010) JUNK CMMU0085 PRINT 1010, JUNK CMMU0086 1010 FORMAT(63H0FITTING PROCESS STOPPED AS NO FUNCTIONS WERE INCLUDED OCMMU0087 1N CYCLE,I2) CMMU0088 GO TO 1205 CMMU0089 1015 INCCYC=0 CMMU0090 C---- PRINT CYCLE INDICATION IF(NUC005(1)) 1016,1017,1016 1016 JUNK=NUC005(4) CICL WRITE(NTOUT,1135) PRINT 1135 1017 CONTINUE CICL WRITE(NTOUT,1018) JCYCLE PRINT 1018,JCYCLE 1018 FORMAT(10H CYCLE NO.,I2) C---- LOOP OVER THE FUNCTIONS IN THE KEY. AT THE START CMMU0091 C---- ALL FUNCTIONS ARE POSITIVE IN THE KEY. IF A TRIAL FUNCTION CMMU0092 C---- IS ACCEPTED WE MAKE THE KEY NEGATIVE. IF A TRIAL CMMU0093 C---- FUNCTION IS KILLED BECAUSE IT IS TOO SMALL(IE HIGHLY CMMU0094 C---- CORRELATED) WE MAKE IT ZERO CMMU0095 DO 1190 IRUN=IKEYPT,IKEYSP CMMU0096 C---- TEST TO SEE IF WE WANT TO TRY THIS FUNCTION CMMU0097 IF(IR(IRUN)) 1190,1190,1020 CMMU0098 C---- PUT IT IN KFUN FOR XRY273 AND CALCULATE FUNCTION VALUES CMMU0099 1020 KFUN=IR(IRUN) CMMU0100 CALL XRY273 CMMU0101 C---- COUNT THIS FUNCTION AS CONSIDERED CMMU0102 ICONSD = ICONSD + 1 CMMU0103 C---- THIS IS THE START OF THE GRAM-SCHMIDT TRANSFORMATION CMMU0116 C---- REWIND G.S. SCRATCH FILE CMMU0117 CALL NUC217(NFILEI,IR(1),LGMSCH,2) C---- SET LENGTH**2 TO ZERO CMMU0119 RI(IW2PT + IFNINC) = 0.0 CMMU0120 C---- CALCULATE COEFFICENTS OF G.S MATRIX DUE TO PARENTS. CMMU0121 C---- JUNK POINTS INTO IBMPT SECTION AND JUNK1 INTO IW2PT SECTION CMMU0122 JUNK = IBMPT + 1 CMMU0123 JUNK1 = IW2PT - 1 CMMU0124 DO 1035 I=ISUMPT,ISUMSP CMMU0125 JUNK=JUNK+1 CMMU0126 JUNK1 = JUNK1 +1 CMMU0127 1035 RI(JUNK) = -RI(I)/RI(JUNK1) CMMU0128 C---- MOVE F INTO W TAKING OFF CONTRIBUTION FROM PARENTS CMMU0129 JUNK = IWUNPT - 1 CMMU0130 JUNK1=IFUNPT -1 CMMU0131 DO 1040 I=IREFPT,IREFSP,INDXC CMMU0132 JUNK=JUNK+1 CMMU0133 JUNK1=JUNK1+1 CMMU0134 JUNK2=IR(I) + IBMPT + 1 CMMU0135 1040 RI(JUNK) = RI(JUNK1) + RI(JUNK2)/RI(I+1) CMMU0136 C---- MOVE AUGMENTED PART OF F INTO AUGNENTED PART OF W. C---- NOTHING TO BE SUBSTRACTED AS PARENT TERMS ARE ZERO DO 1041 I=1,NPAR JUNK = JUNK + 1 JUNK1 = JUNK1 + 1 1041 RI(JUNK) = RI(JUNK1) C---- LOOP OVER PREVIOUSLY ACCEPTED FUNCTIONS IN G.S. FILE CMMU0137 C---- ARE THERE ANY.... CMMU0138 IF(IFNINC-IGRMSH) 1065,1045,1045 CMMU0139 1045 DO 1060 J= IGRMSH,IFNINC CMMU0140 C---- READ FUNCTION INTO WK SECTION CMMU0141 CALL NUC217(NFILEI,RI(IWKPT),LGMSCH,1) C---- GET LENGTH**2 OF THIS VECTOR CMMU0143 W2INV=1.0/RI(IW2PT+J-1) CMMU0144 C---- WORK OUT DOT PRODUCT OF IWUNPT ARRAY AND WK AW=0.0 CMMU0146 JUNK=IWKPT-1 CMMU0147 DO 1050 I=IWUNPT,IWUNSP JUNK=JUNK+1 CMMU0149 1050 AW=AW+RI(JUNK)*RI(I) CMMU0150 C---- RATO OF TWO LENGTH**2 CMMU0151 AWW2=AW*W2INV CMMU0152 C---- KEEP IN THE G.S. MATRIX IN CASE THE FUNCTION IS CMMU0153 C---- ACCEPTED ... LEAVE ONE SPACE FOR A AND ONE FOR CONSTRAINT COEFF CMMU0154 RI(IBMPT+J+1)=AWW2 CMMU0155 C---- TAKE OFF CONTRIBUTION OF G.S. VECTOR IN FORMATION DUE CMMU0156 C---- TO THIS ACCEPTED FUNCTION CMMU0157 JUNK=IWKPT-1 CMMU0158 DO 1055 I=IWUNPT,IWUNSP CMMU0159 JUNK=JUNK+1 CMMU0160 1055 RI(I)=RI(I)-RI(JUNK)*AWW2 CMMU0161 1060 CONTINUE CMMU0162 C---- NEW G.S. VECTOR NOW FORMED IN IWUNPT SECTION ... CMMU0163 C---- WHAT DO WE THINK ABOUT IT CMMU0164 C---- COMPUTE LENGTH SQUARED OF NEW VECTOR INTO W2 ARRAY CMMU0165 1065 JUNK1=IW2PT+IFNINC CMMU0166 DO 1070 I=IWUNPT,IWUNSP CMMU0167 1070 RI(JUNK1)=RI(JUNK1)+RI(I)*RI(I) CMMU0168 C---- IS LENGTH**2 SMALLER THAN ZERO CMMU0169 IF(RI(JUNK1)-ZERO) 1075,1080,1080 CMMU0170 C---- YES KILL THE FUNCTION CMMU0171 1075 IR(IRUN)=0 CMMU0172 GO TO 1175 CMMU0173 C---- COMPUTE A MATRIX B AND DROP CMMU0174 1080 YW=0. CMMU0175 JUNK=IWUNPT-1 CMMU0176 DO 1085 I=IREFPT,IREFSP,INDXC CMMU0177 JUNK=JUNK+1 CMMU0178 1085 YW=YW-RI(JUNK) CMMU0179 C---- NOTHING TO DO FOR AGMENTED PART SINCE THE OBSERVATIONAL VALUES ARE C---- ZERO C---- THIS IS THE VALUE OF A CMMU0180 RI(IBMPT)=YW/RI(JUNK1) CMMU0181 C---- THIS IS THE DIAGONAL TERM OF B AND DROP CMMU0182 RI(IBMPT+IFNINC+2)=1.0 CMMU0183 DROP=RI(IBMPT)*YW CMMU0184 C---- SHOULD WE ACCEPT THIS FUNCTION CMMU0185 IF(DROP-(SQ-SSLIM)/FLOAT(LFINAL-IFNINC)) 1175,1175,1090 CMMU0186 C---- YES ACCEPT IT ... REDUCE SUM OF SQUARES AND UPDATE CMMU0187 C---- COUNTERS AND POINTERS CMMU0188 1090 SQ=SQ-DROP CMMU0189 C---- CHECK THAT SQ IS STILL POSITIVE. .IF NOT SAY THAT DESIRED CMMU0190 C---- PRECISION ATTAINED BUT DO NOT INCLUDE LAST FUNCTION. CMMU0191 C---- SQ NEGATIVE DUE TO ROUNDING ERRORS OR PROGRAMME COCK UP CMMU0192 IF(SQ) 1095,1100,1100 CMMU0193 1095 SQ = SQ + DROP CMMU0194 GO TO 1165 CMMU0195 1100 IFNINC=IFNINC+1 CMMU0196 INCCYC=1 CMMU0197 C---- PUT FUNCTION KEY INTO IACPT SECTION CMMU0198 IR(IACPT+IFNINC-1)=IR(IRUN) CMMU0199 C---- NEGATE THE FUNCTION KEY TO SAY THAT ITS ACCEPTED CMMU0200 IR(IRUN)=-IR(IRUN) CMMU0201 C---- OUTPUT THE VALUE OF A,CONSTR. COEFF AND COLUMN OF B ON NFILEG CMMU0202 C---- IS THERE ENOUGH ROOM CMMU0203 IF(IOBUF1+IFNINC+2-IOBMX) 1110,1110,1105 CMMU0204 1105 CALL NUC112(NFILEG,IOBUF,IOBMX) CMMU0205 IOBUF2=IOBUF2+1 CMMU0206 IOBUF1=4 CMMU0207 1110 JUNK=IFNINC+2 CMMU0208 DO 1115 I=1,JUNK CMMU0209 1115 BUFIO(IOBUF1+I)=RI(IBMPT+I-1) CMMU0210 IOBUF1=IOBUF1+JUNK CMMU0211 C---- OUTPUT THE NEW G.S. VECTOR ON THE G.S. SCRATCH FILE CMMU0212 CALL NUC217(NFILEI,IR(IWUNPT),LGMSCH,0) C---- PRINT OUT INFORMATION ON FUNCTION ACCEPTED CMMU0214 C---- THE POWERS OF THE VARIABLE ARE AVAILABLE FROM THE CALL CMMU0215 C---- TO XRY273 CMMU0216 C---- UPDATE IQTQ(5) 6,7,8 TO CONTAIN SINE/COSINE INDICATOR CMMU0217 DO 1120 J=5,8 CMMU0218 JUNK=IQTQ(J) +1 CMMU0219 1120 IQTQ(J) = IDATA1(JUNK) CMMU0220 1125 IF(NUC005(1)) 1130,1140,1130 CMMU0221 1130 JUNK=NUC005(4) CMMU0222 CICL WRITE(NTOUT,1135) CMMU0223 PRINT 1135 CMMU0224 1135 FORMAT(1H0,66X,1HA,9X,11HDROP IN SUM,6X,6HSUM OF,9X,6HLENGTH,/, 124X,8HFUNCTION,30X,11HCOEFFICIENT,4X,10HOF SQUARES,7X,7HSQUARES, 28X,7HSQUARED,/) 1140 CONTINUE CMMU0230 CICL WRITE(NTOUT,1145) IFNINC,II,(IQTQ(J+4),IQTQ(J),J=1,4),RI(IBMPT), PRINT 1145, IFNINC,II,(IQTQ(J+4),IQTQ(J),J=1,4),RI(IBMPT), 1DROP,SQ,RI(IW2PT+IFNINC-1) 1145 FORMAT(1X,I3,1H),2X,5HINT**,I1,1H*,A3,1H(,I2,5HOMG)*,A3,1H(,I2, 15HTTH)*,A3,1H(,I2,5HCHI)*,A3,1H(I2,4HPHI), 4E15.5) C---- DO WE NOW HAVE THE EXPECTED NUMBER OF FUNCTIONS ... CMMU0235 IF(IFNINC-LFINAL) 1160,1150,1150 CMMU0236 1150 JUNK=NUC005(2) CMMU0237 CICL WRITE(NTOUT,1155) CMMU0238 PRINT 1155 CMMU0239 1155 FORMAT(46H0FITTING PROCESS STOPPED AS EXPECTED NUMBER OF CMMU0240 129H FUNCTIONS HAVE BEEN INCLUDED) CMMU0241 GO TO 1205 CMMU0242 C---- DO WE HAVE DESIRED PRECISION CMMU0243 1160 IF(SQ-SSLIM ) 1165,1165,1175 CMMU0244 1165 JUNK=NUC005(2) CMMU0245 CICL WRITE(NTOUT,1170) CMMU0246 PRINT 1170 CMMU0247 1170 FORMAT(45H0FITTING PROCESS STOPPED AS DESIRED PRECISION, CMMU0248 19H ATTAINED) CMMU0249 GO TO 1205 CMMU0250 C---- SEE IF WE HAVE CONSIDERED ENOUGH FUNCTIONS CMMU0251 1175 IF(ICONSD-LSTUDY) 1190,1180,1180 CMMU0252 1180 JUNK=NUC005(2) CMMU0253 CICL WRITE(NTOUT,1185) CMMU0254 PRINT 1185 CMMU0255 1185 FORMAT(46H0FITTING PROCESS STOPPED AS MAXIMUM NUMBER OF , CMMU0256 124HTRIALS HAS BEEN EFFECTED) CMMU0257 GO TO 1205 CMMU0258 C---- BOTTOM OK KEY LOOP CMMU0259 1190 CONTINUE CMMU0260 C---- BOTTOM OF CYCLE LOOP CMMU0261 1195 CONTINUE CMMU0262 JUNK=NUC005(2) CMMU0263 CICL WRITE(NTOUT,1200) CMMU0264 PRINT 1200 CMMU0265 1200 FORMAT(46H0FITTING PROCESS STOPPED AS 3 CYCLES COMPLETED) CMMU0266 C---- FITTING STOPPED CMMU0267 C---- FINISH OFF NFILEG CMMU0268 1205 IOBUF2=0 CMMU0269 CALL NUC112(NFILEG,IOBUF,IOBMX) CMMU0270 C---- REWIND NFILEI FOR PROSPERITY CMMU0271 CALL NUC217(NFILEI,IR(1),LGMSCH,2) C---- NUMBER OF TRIGONOMETRIC FUNCTIONS (I.E. TOTAL NUMBER LESS PARENTS)CMMU0273 IFUNCT=IFNINC-NPAR CMMU0274 C**** CMMU0275 C IN THE 2000 BLOCK THE STORE IS REARRANGED AS ALL WE NEED CMMU0276 C IS PARENT CODE WORDS AND ACCEPTED FUNCTION CODES. THEN THE CMMU0277 C ACCEPTED FUNCTION CODES ARE UNPACKED INTO THE XYDATA ARRAY AND THECMMU0278 C SCRATCH FILE IS READ TO PUT THE GRAM-SCHMIDT MATRIX AND CMMU0279 C VECTOR INTO CORE. THE MATRIX IS INVERTED AND MULTIPLIED CMMU0280 C BY THE VECTOR TO GET THE COEFFICENTS OF THE FINAL MODEL. CMMU0281 C**** CMMU0282 C---- REARRANGE THE CORE. WE KEEP THE IPRPT SECTION WHICH IS CMMU0283 C---- AT THE BOTTOM OF XYDATA AND (FOR THE TIME BEING) IACPT WHICH CMMU0284 C---- IS AT THE TOP. WE CREATE OR RECREATE, CMMU0285 C---- 1. IFUNPT SECTION FOR UNPACKED ACCEPTED FUNCTION ORDERS CMMU0286 C---- 2. ICPT SECTION FOR C COEFFICENTS CMMU0287 C---- 3. IAPT SECTION FOR A COEFFICENTS CMMU0288 C---- 4. IBMPT SECTION FOR GRAM-SCHMIDT MATRIX CMMU0289 C---- 5. ICONPT LINEAR CONSTRAINT SECTION CMMU0290 IFUNPT=IPRSP+1 CMMU0291 INDXC=9 CMMU0292 IFUNSP=IFUNCT*INDXC+IPRSP CMMU0293 ICPT=IFUNSP+1 CMMU0294 ICSP=IFUNSP+IFNINC CMMU0295 IAPT=ICSP+1 CMMU0296 IASP=ICSP+IFNINC CMMU0297 C---- JUST TO COMPLICATE THINGS THE C COEFFICENT CMMU0298 C---- SECTION IS SUBDIVIDED FOR PARENT INTENSITY AND TRIGONOMETRIC CMMU0299 C---- FUNCTIONS CMMU0300 ICFNPT=ICPT+NPAR CMMU0301 ICPRSP=ICFNPT-1 CMMU0302 C---- NOW THE MATRIX AND CONSTRAINTS CMMU0303 IBMPT=IASP+1 CMMU0304 IBMSP=IASP+(IFNINC*(IFNINC+1))/2 CMMU0305 ICONPT = IBMSP + 1 CMMU0306 ICONSP = IBMSP + IFNINC CMMU0307 C---- DO WE HAVE ENOUGH SPACE CMMU0308 IF(ICONSP-MAXCOR) 2015,2015,2000 CMMU0309 C---- TRY AND INCREASE CORE SIZE CMMU0310 2000 CALL MORCOR(ICONSP) CMMU0311 C---- WAS THE CALL ACCEPTED CMMU0312 IF(MAXCOR-ICONSP) 2005,2015,2015 CMMU0313 2005 JUNK=NUC005(2) CMMU0314 IQUIT=1 CMMU0315 CICL WRITE(NTOUT,2010) ICONSP CMMU0316 PRINT 2010,ICONSP CMMU0317 2010 FORMAT(17H0*****CAMEL NEEDS ,I10,10H CORE SIZE) CMMU0318 GO TO 9975 CMMU0319 2015 MAXUTL=MAX0(MAXUTL,ICONSP) CMMU0320 C---- UNPACK THE FUNCTION ORDER CODES INTO IFUNPT SECTION CMMU0321 C---- THE ORDER IS ... CMMU0322 C---- 1. H CMMU0323 C---- 2. I CMMU0324 C---- 3. J CMMU0325 C---- 4. K CMMU0326 C---- 5. L CMMU0327 C---- 6. (0)/(1) FOR SINE/COSINE FUNCTION FOR OMEGA CMMU0328 C---- 7. (0)/(1) FOR SINE/COSINE FUNCTION FOR 2THETA CMMU0329 C---- 8. (0)/(1) FOR SINE/COSINE FUNCTION FOR CHI CMMU0330 C---- 9. (0)/(1) FOR SINE/COSINE FUNCTION FOR PHI CMMU0331 C---- BEWARE CODES DONT START AT IACPT BUT A BIT FURTHER CMMU0332 C---- ALONG ... CHANGE IACPT AND IACSP AS NECESSARY CMMU0333 IBITPT = 2 ISIGPK = 2 NITEM = 9 IF(IFUNCT) 2030,2030,2020 CMMU0334 2020 IACPT = IACPT+NPAR CMMU0335 IACSP=IACPT+IFUNCT-1 CMMU0336 JUNK4=IFUNPT-INDXC CMMU0337 C---- RESET MAXIMUM POWERS USED CMMU0338 MAXH = 0 CMMU0339 MAXI = 0 CMMU0340 MAXJ = 0 CMMU0341 MAXK = 0 CMMU0342 MAXL = 0 CMMU0343 DO 2025 I=IACPT,IACSP CMMU0344 C---- JUNK4 POINTS INTO IFUNPT CMMU0345 JUNK4=JUNK4+INDXC CMMU0346 C---- UNPACK THE FUNCTION POWERS CALL NUC014(IR(I)) DO 2021 J=1,9 2021 IR(JUNK4+J-1) = ITEM(J) MAXH = MAX0(IR(JUNK4 ),MAXH) CMMU0350 MAXI = MAX0(IR(JUNK4+1),MAXI) CMMU0354 MAXJ = MAX0(IR(JUNK4+2),MAXJ) CMMU0358 MAXK = MAX0(IR(JUNK4+3),MAXK) CMMU0362 MAXL = MAX0(IR(JUNK4+4),MAXL) CMMU0366 2025 CONTINUE CMMU0375 C---- WEVE NOW FINISHED WITH IACPT SECTION CMMU0376 C---- PREPARE TO READ IN THE MATRIX CMMU0377 2030 CALL NUC007(NFILEG,0) CMMU0378 C---- JUST AS A REMINDER THE MATRIX IS UPPER TRIANGULAR CMMU0379 C---- STORED BY COLUMNS ON THE FILE,EACH COLUMN HEADED BY CMMU0380 C---- THE VALUE OF A FOLLOWED BY A CONSTRAINT COEFFICIENT. WE READ IT CMMU0381 C---- INTO STORE BY ROWS IN THE IBMPT SECTION. CMMU0382 C---- SET DUMMY VALUES TO FORCE READ CMMU0383 IOBUF1=0 CMMU0384 IPT=1 CMMU0385 C---- LOOP OVER COLUMN OF MATRIX CMMU0386 DO 2050 I=1,IFNINC CMMU0387 C---- DO WE HAVE ANYTHING LEFT IN THE BUFFER ... CMMU0388 IF(IPT-IOBUF1) 2040,2040,2035 CMMU0389 2035 CALL NUC111(NFILEG,1,IOBUF,IOBMX) CMMU0390 C---- IPT POINTS TO NEXT POSITION TO READ IN BUFIO CMMU0391 IPT=5 CMMU0392 C---- READ THE A COEFFICENT AND CONSTRAINT CMMU0393 2040 RI(IAPT+I-1)=BUFIO(IPT) CMMU0394 RI(ICONPT + I - 1 ) = BUFIO(IPT +1) CMMU0395 IPT = IPT + 2 CMMU0396 C---- SET THE COLUMN - ROW STEP CMMU0397 JUNK2=IFNINC CMMU0398 C---- PICK UP POSITION FOR FIRST VALUE IN THIS COLUMN CMMU0399 JUNK=IBMPT-1+I CMMU0400 C---- LOOP OVER ROWS CMMU0401 DO 2045 J=1,I CMMU0402 C---- DECREASE STEP CMMU0403 JUNK2=JUNK2-1 CMMU0404 C---- TRANSFER VALUE UPDATE IPT AND JUNK CMMU0405 RI(JUNK)=BUFIO(IPT) CMMU0406 IPT=IPT+1 CMMU0407 JUNK=JUNK+JUNK2 CMMU0408 2045 CONTINUE CMMU0409 2050 CONTINUE CMMU0410 C---- WEVE FINISHED WITH NFILEG NOW CMMU0411 CALL NUC007(NFILEG,0) CMMU0412 C---- THE NEXT PART IS THE MATRIX INVERSION OF AN UPPER TRIANGULAR CMMU0413 C---- MATRIX. THIS INVERSION IS QUITE EASY ANYWAY AND WE MAKE CMMU0414 C---- USE OF TWO SPECIALITIES OF THE GRAM-SCHMIDT MATRIX TO CMMU0415 C---- SPEED IT UP EVEN MORE. (1) THE DIAGONAL TERMS ARE 1.0 AND CMMU0416 C---- (2) THE PARENT REFLECTIONS PRODUCE PLENTY OF ZERO VALUES CMMU0417 C---- IH IS THE MATRIX TERM WE ARE CALCULATING CMMU0418 IH=IBMSP+1 CMMU0419 C---- JUNK3 POINTS TO FIRST NON-DIAGONAL TERM IN SAME ROW AS IH CMMU0420 JUNK3=IBMSP+1 CMMU0421 C---- LOOP OVER ROWS OF THE MATRIX (EXCEPT LAST) CMMU0422 DO 2080 I=2,IFNINC CMMU0423 C---- UPDATE START OF ROW POINTER,AND ELEMENT POINTER CMMU0424 JUNK3=JUNK3-I CMMU0425 IH=IH-1 CMMU0426 C---- LOOP OVER COLUMNS (EXCLUDE DIAGONAL TERM) CMMU0427 DO 2075 J=2,I CMMU0428 C---- UPDATE ELEMENT POINTER CMMU0429 IH = IH-1 CMMU0430 C---- SUM TERMS FOR THIS ELEMENT CMMU0431 QTQ(1)=0.0 CMMU0432 C---- DONT BOTHER TO MULTIPLY BY 1.0 OF A DIAGONAL TERM CMMU0433 IF(JUNK3-IH) 2055,2070,2055 CMMU0434 C---- SET ROW-STEP IN JUNK, IH-1 IN JUNK2 AND NEXT ROW CMMU0435 C---- POINTER IN JUNK1 CMMU0436 2055 JUNK=I CMMU0437 JUNK2=IH-1 CMMU0438 JUNK1=IH CMMU0439 C---- LOOP TO SUM TERMS CMMU0440 DO 2065 K=JUNK3,JUNK2 CMMU0441 JUNK=JUNK-1 CMMU0442 JUNK1=JUNK1+JUNK CMMU0443 C---- LOOK IF MATRIX TERM IS ZERO TO AVOID MULTIPLICATION CMMU0444 IF(RI(K)) 2060,2065,2060 CMMU0445 2060 QTQ(1)=QTQ(1)-RI(K)*RI(JUNK1) CMMU0446 2065 CONTINUE CMMU0447 2070 RI(IH)=QTQ(1)-RI(IH) CMMU0448 C---- BOTTOM OF COLUMN LOOP CMMU0449 2075 CONTINUE CMMU0450 C---- BOTTOM OF ROW LOOP CMMU0451 2080 CONTINUE CMMU0452 C---- THE INVERSE MATRIX IS NOW IN THE IBMPT SECTION CMMU0453 C---- THE BOTTOM TRIANGLE IS ZERO CMMU0454 C---- NOW MULTIPLY THIS UPPER TRIANGULAR MATRIX BY CMMU0455 C---- VECTOR A TO GET FINAL MODEL C CMMU0456 C---- CALCULATE VALUE OF CONSTANT FROM LINEAR CONSTRAINT AT SAME TIME CMMU0457 CONCON= 1.0 CMMU0458 JUNK3 = ICONPT - 1 CMMU0459 C---- JUNK1 POINTS TO MATRIX ELEMENT CMMU0460 JUNK1=IBMPT-1 CMMU0461 C---- JUNK4 GIVES STARTING VALUE IN VECTOR A CMMU0462 JUNK4=IAPT CMMU0463 C---- LOOP OVER THE C COEFFICIENTS CMMU0464 DO 2090 I=ICPT,ICSP CMMU0465 JUNK3 = JUNK3 + 1 CMMU0466 C---- SUM VALUES CMMU0467 RI(I)=0.0 CMMU0468 C---- LOOP OVER MATRIX ROW AND VECTOR CMMU0469 DO 2085 J=JUNK4,IASP CMMU0470 JUNK1=JUNK1+1 CMMU0471 2085 RI(I)=RI(I)+RI(J)*RI(JUNK1) CMMU0472 C---- INCREASE STARTING VALUE OF A CMMU0473 JUNK4=JUNK4+1 CMMU0474 C---- SUM INTO CONCON CMMU0475 CONCON = CONCON + RI(I)*RI(JUNK3) CMMU0476 2090 CONTINUE CMMU0477 C---- THE FINAL MODEL IS NOW IN C. PRINT THEM CMMU0478 JUNK = NUC005(NPAR+6) CICL WRITE(NTOUT,2095) CMMU0480 PRINT 2095 CMMU0481 2095 FORMAT(28H0COEFFICIENTS OF FINAL MODEL,/,24X,8HFUNCTION,29X, 113HCOEFFICIENT C,/) C---- JUNK2 POINTS INTO THE C SECTION CMMU0485 JUNK2=ICPT-1 CMMU0486 JUNK3 = IPRPT - 1 C---- LOOP OVER PARENT COEFFICIENT CMMU0487 DO 2105 I=1,NPAR CMMU0488 JUNK2=JUNK2+1 CMMU0489 JUNK3 = JUNK3 + 1 C---- GET REFLECTION INDICES IQTQ(61) = IR(JUNK3)/40000 - 100 IQTQ(62) = MOD(IR(JUNK3),40000)/200 - 100 IQTQ(63) = MOD(IR(JUNK3),200) - 100 CICL WRITE(NTOUT,2100) I,I,(IQTQ(J),J=61,63),RI(JUNK2) PRINT 2100, I,I,(IQTQ(J),J=61,63),RI(JUNK2) 2100 FORMAT(1X,I3,1H),2X,13HPARENT NUMBER,I4,15H. H K L INDICES,3I4, 16X,4E15.5) 2105 CONTINUE CMMU0493 C---- PRINT CONSTANT CMMU0494 CICL WRITE(NTOUT,2110) CONCON CMMU0495 PRINT 2110,CONCON CMMU0496 2110 FORMAT(3X,2HC),2X,8HCONSTANT,42X,E15.5) C---- NOW LOOP OVER TRIGONOMETRIC FUNCTIONS CMMU0498 IF(IFUNCT) 2145,2145,2115 CMMU0499 C---- JUNK1 COUNTS COEFFICIENT NUMBER CMMU0500 2115 JUNK1=NPAR CMMU0501 DO 2140 I=IFUNPT,IFUNSP,INDXC CMMU0502 JUNK1=JUNK1+1 CMMU0503 JUNK2=JUNK2+1 CMMU0504 IF(NUC005(1)) 2120,2125,2120 CMMU0505 2120 JUNK=NUC005(4) CMMU0506 CICL WRITE(NTOUT,2095) CMMU0507 PRINT 2095 CMMU0508 C---- PUT SIN/COS INDICATORS IN IQTQ(1) ..4 CMMU0509 2125 DO 2130 J=1,4 CMMU0510 JUNK=IR(I+J+4)+1 CMMU0511 2130 IQTQ(J) = IDATA1(JUNK) CMMU0512 CICL WRITE(NTOUT,1145) JUNK1,IR(I),IQTQ(1),IR(I+1),IQTQ(2),IR(I+2), PRINT 1145, JUNK1,IR(I),IQTQ(1),IR(I+1),IQTQ(2),IR(I+2), 1IQTQ(3),IR(I+3),IQTQ(4),IR(I+4),RI(JUNK2) 2140 CONTINUE CMMU0518 2145 CONTINUE CMMU0519 C---- PRINT OUT INTERESTING VALUES CMMU0520 C---- NUMBER OF FUNCTIONS CONSTRUCTED CMMU0521 IQTQ(3) = IKEYSP - IKEYPT + 1 CMMU0522 JUNK=NUC005(22) CMMU0523 CICL WRITE(NTOUT,2150) NPAR,MDATA,IQTQ(3),ICONSD,IFNINC,SQ,SSQAGE, CMMU0524 PRINT 2150, NPAR,MDATA,IQTQ(3),ICONSD,IFNINC,SQ,SSQAGE, CMMU0525 1SUMSQ,ZSSUM, FINMAX,ZERO CMMU0526 2150 FORMAT(//,1H0,67(1H*),/,2H *,65X,1H*,/,26H * FINAL AGREEMENT FACTOCMMU0527 1RS,41X,1H*,/,2H *,65X,1H*,/, CMMU0528 231H * NUMBER OF PARENT REFLECTIONS,29X,I5,2X,1H*,/, CMMU0529 329H * NUMBER OF DATA INTENSITIES,31X,I5,2X,1H*,/, CMMU0530 440H * NUMBER OF TRIG. FUNCTIONS CONSTRUCTED,20X,I5,2X,1H*,/, CMMU0531 528H * NUMBER OF FUNCTIONS TRIED,32X,I5,2X,1H*,/, CMMU0532 631H * NUMBER OF FUNCTIONS INCLUDED,29X,I5,2X,1H*,/, CMMU0533 726H * RESIDUAL SUM OF SQUARES,24X,E15.6,2X,1H*,/, CMMU0534 837H * INITIAL SUM OF SQUARES ABOUT MEANS,13X,E15.6,2X,1H*,/, CMMU0535 925H * INITIAL SUM OF SQUARES,25X,E15.6,2X,1H*,/, CMMU0536 A35H * EXPECTED RESIDUAL SUM OF SQUARES,15X,E15.6,2X,1H*,/, CMMU0537 C29H * MAXIMUM INTENSITY MEASURED,21X,F15.2,2X,1H*,/, CMMU0538 D39H * MINIMUM W**2 OF ACCEPTABLE FUNCTIONS,11X,E15.6,2X,1H*,/, CMMU0539 E2H *,65X,1H*,/,1H ,67(1H*),///) CMMU0540 9975 CONTINUE CMMU0541 RETURN CMMU0542 END CMMU0543 CDC*DECK,CMFN SUBROUTINE XRY273 CMFN0001 C---- CMFN0002 C---- CMFN0003 C---- SUBROUTINE CMFN TO CALCULATE FUNCTION VALUES FOR THE MDATA CMFN0004 C---- POINTS FOR THE FUNCTION GIVEN IN KFUN. THE FUNCTION CMFN0005 C---- VALUES ARE PUT INTO THE IFUNPT SECTION OF THE XYDATA CMFN0006 C---- ARRAY. THE FACT THAT COSINE AND SINE VALUES OF THE ANGLES CMFN0007 C---- ARE STORED ALLOWS US TO USE AN ITERATIVE PROCEDURE FOR CMFN0008 C---- THE CALCULATION OF HIGHER ORDER ANGLES. CMFN0009 C---- CMFN0010 C---- THIS SUBROUTINE IS CALLED BY XRY272 CMFN0011 C---- AND CALLS NUC014 C---- CMFN0012 C---- SYSTEM COMMON,DIMENSION AND EQUIVALENCE PACKAGE CMFN0013 C---- CMFN0014 COMMON/SYS/IDCOMP(2),NTIN,NTOUT,NFILEA,NFILEB,NFILEC,NFILED, CMFN0015 *NFILEE,NFILEF,NFILEG,NFILEH,NFILEI,NFILEJ,NCDBUF,NTINM,NTOUTM, CMFN0016 *NTPCHM,IDPROG(2),ITOOB,NPAGE,LINMX,LINCT,NCRDS,ISHORT, CMFN0017 *TITLE(19),CARD(21),QTQ(100),ICYCLE,IQUIT, CMFN0018 *JUNK,JUNK1,JUNK2,JUNK3,JUNK4,IOZY,IOZTM,ICDC(20) CMFN0019 DIMENSION IQTQ(100),ICARD(21),NTIND(1) CMFN0020 EQUIVALENCE (QTQ(1),IQTQ(1)),(NFILEC,NTPCH),(NTCU,NTPCHM) CMFN0021 EQUIVALENCE (CARD(1),ICARD(1)),(NTIND(1),NTIN) CMFN0022 C---- CMFN0023 C---- X-RAY DATA COMMON AND EQUIVALENCE PACKAGE CMFN0024 C---- CMFN0025 COMMON/XYDATA/RI(1) CMFN0026 DIMENSION IR(1) CMFN0027 EQUIVALENCE (RI(1),IR(1)) CMFN0028 C---- C---- COMMON PACKAGE PACK C---- COMMON/PACK/IBITPT,ISIGPK,NITEM,IBITS(310),ITEM(31) C---- CMFN0029 C---- COMMON PACKAGE OMNIA CMFN0030 C---- CMFN0031 COMMON/OMNIA/NOBLAB,NUMREF,LFINAL,MAXH,MAXI,MAXJ,MAXK,MAXL,ICENTR,CMFN0032 1 LSTUDY,ERREUR,QMAX,WOVERD,ABSMU,FACTOR,DOWNWT, 2I,IACPT,IACSP,IAPT,IASP,IBMPT,IBMSP,IBOND,IC,ICFNPT,ICONPT,ICONSD,CMFN0034 3ICONSP,ICPRSP,ICPT,ICSNPT,ICSNSP,ICSP,IFNINC,IFUNCT,IFUNPT,IFUNSP,CMFN0035 4IGRMSH,IH,II,IK,IKEYPT,IKEYSP,IL,IM,IN,INCCYC,INDXC,IP,IPAR,IPRPT,CMFN0036 5IPRSP,IPT,IREFPT,IREFSP,IRUN,ISTOP1,ISTOP2,ISUMPT,ISUMSP,IWKPT, CMFN0037 6IWKSP,IWUNPT,IWUNSP,IW2PT,IW2SP,IZERO,J,JCYCLE,JS,K,KCD,KFUN,L, CMFN0038 7LIMLO,LIMUP,LPARNT,M,MARK1,MARK2,MAXORG,MDATA,N,NPAR, CMFN0039 9ABB(23),AVAL,AW,AWW2,CAMCOR,CONCON,CONST,DAR,DROP,FINMAX,SPHCOR, CMFN0040 ASQ,SSLIM,SSQAGE,SUMF,SUMSQ,W2INV,YW,ZERO,ZSSUM CMFN0041 B,IAPCPT,IAPCSP,LGMSCH ,THETA(23),DERIV(23) C---- SET FUNCTION SUMS TO ZERO CMFN0042 SUMF = 0.0 CMFN0043 C---- UNPACK KFUN TO FIND OUT WHAT ORDERS OF THE FUNCTIONS CMFN0044 C---- ARE REQUIRED. CMFN0045 IBITPT = 2 ISIGPK = 2 NITEM = 9 CALL NUC014(KFUN) DO 995 I=1,8 995 IQTQ(I) = ITEM(I+1) II = ITEM(1) C---- IQTQ(8) SAYS 0/1 WHETHER PHI FUNCTION IS SIN/COS CMFN0046 C---- IQTQ(7) SAYS 0/1 WHETHER CHI FUNCTION IS SIN/COS CMFN0048 C---- IQTQ(6) SAYS 0/1 WHETHER 2THETA FUNCTION IS SIN/COS CMFN0050 C---- IQTQ(5) SAYS 0/1 WHETHER OMEGA FUNCTION IS SIN/COS CMFN0052 C---- IQTQ(4) GIVES POWER OF TRIG. FUNCTIONS OF PHI CMFN0054 C---- IQTQ(3) GIVES POWER OF TRIG FUNCTION OF CHI CMFN0056 C---- IQTQ(2) GIVES POWER OF TRIG. FUNCTION OF TWO-THETA CMFN0058 C---- IQTQ(1) GIVES POWER OF TRIG FUNCTION OF OMEGA CMFN0060 C---- II GIVES POWER OF INTENSITY FUNCTION CMFN0062 C---- INDICATE UNPACKING OF TRIG.FUNCTIONS IBITPT = 1 NITEM = 2 C---- LOOP OVER MDATA DATA POINTS, JUNK4 POINTS INTO IFUNPT SECTION CMFN0064 JUNK4=IFUNPT-1 CMFN0065 DO 1035 K=IREFPT,IREFSP,INDXC CMFN0066 JUNK4= JUNK4 +1 CMFN0067 C---- JUNK3 POINTS AT PACKED TRIGONOMETRIC FUNCTIONS OF ANGLE BEING CMFN0068 C---- CONSIDERED CMFN0069 JUNK3 = K+1 CMFN0070 C---- START FUNCTION VALUE WITH INTENSITY FUNCTION CMFN0071 RI(JUNK4) = RI(JUNK3)**II CMFN0072 C---- LOOP OVER THE FOUR ANGLES....OMG,2THETA,CHI,PHI CMFN0073 DO 1030 L=1,4 CMFN0074 JUNK3 = JUNK3 +1 CMFN0075 C---- UNPACK THE TRIG. FUNCTIONS. PUT COS(ANGLE) INTO QTQ(9), SIN(ANGLECMFN0076 C---- INTO QTQ(10) AND 2.0*COS(ANGLE) INTO QTQ(100) CMFN0077 CALL NUC014(IR(JUNK3)) QTQ(9) = CONST*FLOAT(ITEM(1))-1.0 QTQ(10) = CONST*FLOAT(ITEM(2))-1.0 QTQ(100) = 2.0*QTQ(9) CMFN0080 C---- DO WE WANT SIN OR COS CMFN0081 IF(IQTQ(L+4)) 1000,1005,1000 CMFN0082 C---- INITIALIZATION FOR A COSINE FUNCTION CMFN0083 C---- PUTTING STARTING VALUES COS(0) AND COS(ANGLE) IN QTQ(13) AND 14 CMFN0084 1000 QTQ(13) =1.0 CMFN0085 QTQ(14) =QTQ(9) CMFN0086 GO TO 1010 CMFN0087 C---- INITIALIZATION FOR A SINE FUNCTION CMFN0088 1005 QTQ(13) = 0.0 CMFN0089 QTQ(14) = QTQ(10) CMFN0090 C---- DO ITERATION TO CHANGE COS(A) INTO COS(NA) AND CMFN0091 C---- SIN(A) INTO SIN(NA) CMFN0092 C---- IT WORKS AS FOLLOWS : CMFN0093 C---- COS((N+1)A)=2.*COS(NA)*COS(A)-COS((N-1).A) CMFN0094 C---- SIN((N+1)A) = 2.*SIN(NA)*COS(A) - SIN((N-1)A) CMFN0095 C---- WE USE QTQ(13) FOR ZERO ORDER FUNCTION CMFN0096 C---- WE USE QTQ(14) FOR FIRST ORDER FUNCTION ... ETC CMFN0097 1010 JUNK1 = 14 CMFN0098 JUNK = IQTQ(L) + 13 CMFN0099 1015 IF(JUNK1-JUNK) 1020,1025,1025 CMFN0100 1020 JUNK1 = JUNK1 + 1 CMFN0101 QTQ(JUNK1) = QTQ(JUNK1 -1)*QTQ(100) - QTQ(JUNK1-2) CMFN0102 GO TO 1015 CMFN0103 C---- UPDATE FUNCTIONS VALUE WITH THIS TRIG. CMFN0104 1025 RI(JUNK4) = RI(JUNK4) * QTQ(JUNK) CMFN0105 1030 CONTINUE CMFN0106 SUMF = SUMF + RI(JUNK4) CMFN0107 1035 CONTINUE CMFN0108 C---- IN THE BLOCK THE RIGID CONSTRAINT IS APPLIED TO THE MDATA FUNCTION C---- POINTS. AT THE SAME TIME VALUES ARE ACCULMULATED FOR THE EXTRA C---- NPAR DATA POINTS OF THE APPROXIMATE CONSTRAINTS. C C---- CALCULATE AND STORE LINEAR CONSTRAINT CONSTANT QTQ(51) = -SUMF/FLOAT(MDATA) RI(IBMPT+1) = QTQ(51) C---- ZERO THE AUXILIARLY NPAR DATA POINTS DO 2005 I = 1,NPAR JUNK4 = JUNK4 + 1 2005 RI(JUNK4) = 0.0 C---- LOOP OVER MDATA DATA POINTS JUNK4 = IFUNPT -1 DO 2010 K=IREFPT,IREFSP,INDXC JUNK4 = JUNK4 + 1 C---- APPLY LINEAR CONSTRAINT RI(JUNK4) = RI(JUNK4) + QTQ(51) C----- SUM INTO CORRECSPOING PARENT JUNK1 = IR(K) + MDATA+IFUNPT - 1 2010 RI(JUNK1)=RI(JUNK1) + RI(JUNK4)/RI(K+1) C---- KEEP SUM SHIFTED FUNCTION*INTENSITY**-1 FOR G.S. CALCULATION C---- MULTIPLY THE NPAR POINTS BY THE WEIGHTING FACTOR JUNK3 = ISUMPT -1 JUNK4 = IFUNPT+MDATA-1 DO 2015 K=1,NPAR JUNK3 = JUNK3 +1 JUNK4 = JUNK4 +1 RI(JUNK3) = RI(JUNK4) 2015 RI(JUNK4) = RI(JUNK4)*RI(IAPCPT+K-1) RETURN CMFN0109 END CMFN0110 CDC*DECK,CMCR SUBROUTINE XRY274 CMCR0001 C---- CMCR0002 C---- CMCR0003 C---- SUBROUTINE CMCR TO APPLY CORRCTIONS (BOTH ANISOTROPIC AND SPHERICACMCR0004 C---- L ) TO ALL OF THE DATA ON NFILEE AND TO PRINT OUT THESE RESULTS CMCR0005 C---- CMCR0006 C---- THIS SUBROUTINE IS CALLED BY XRY270 CMCR0007 C---- CMCR0008 C---- AND CALLS NUC005,NUC007,NUC111,NUC112,NUC113,MORCOR CMCR0009 C---- CMCR0010 C---- CMCR0011 C---- SYSTEM COMMON,DIMENSION AND EQUIVALENCE PACKAGE CMCR0012 C---- CMCR0013 COMMON/SYS/IDCOMP(2),NTIN,NTOUT,NFILEA,NFILEB,NFILEC,NFILED, CMCR0014 *NFILEE,NFILEF,NFILEG,NFILEH,NFILEI,NFILEJ,NCDBUF,NTINM,NTOUTM, CMCR0015 *NTPCHM,IDPROG(2),ITOOB,NPAGE,LINMX,LINCT,NCRDS,ISHORT, CMCR0016 *TITLE(19),CARD(21),QTQ(100),ICYCLE,IQUIT, CMCR0017 *JUNK,JUNK1,JUNK2,JUNK3,JUNK4,IOZY,IOZTM,ICDC(20) CMCR0018 DIMENSION IQTQ(100),ICARD(21),NTIND(1) CMCR0019 EQUIVALENCE (QTQ(1),IQTQ(1)),(NFILEC,NTPCH),(NTCU,NTPCHM) CMCR0020 EQUIVALENCE (CARD(1),ICARD(1)),(NTIND(1),NTIN) CMCR0021 C---- CMCR0022 C---- INPUT - OUTPUT COMMON,DIMENSION AND EQUIVALENCE PACKAGE CMCR0023 C---- CMCR0024 COMMON/IO/MAXREC,IOBMX,IOBUF(255) CMCR0025 DIMENSION BUFIO(255) CMCR0026 EQUIVALENCE (IOBUF(1),IOBUF1),(IOBUF(2),IOBUF2),(IOBUF(3),IOBUF3),CMCR0027 *(IOBUF(4),IOBUF4),(IOBUF(1),BUFIO(1)) CMCR0028 C---- CMCR0029 C---- CORE USEAGE COMMON CMCR0030 C---- CMCR0031 COMMON/XYINFO/MAXCOR,MINCOR,MAXUTL,IDPREV(2) CMCR0032 C---- CMCR0033 C---- X-RAY DATA COMMON AND EQUIVALENCE PACKAGE CMCR0034 C---- CMCR0035 COMMON/XYDATA/RI(1) CMCR0036 DIMENSION IR(1) CMCR0037 EQUIVALENCE (RI(1),IR(1)) CMCR0038 C---- CMCR0039 C---- COMMON PACKAGE OMNIA CMCR0040 C---- CMCR0041 COMMON/OMNIA/NOBLAB,NUMREF,LFINAL,MAXH,MAXI,MAXJ,MAXK,MAXL,ICENTR,CMCR0042 1 LSTUDY,ERREUR,QMAX,WOVERD,ABSMU,FACTOR,DOWNWT, 2I,IACPT,IACSP,IAPT,IASP,IBMPT,IBMSP,IBOND,IC,ICFNPT,ICONPT,ICONSD,CMCR0044 3ICONSP,ICPRSP,ICPT,ICSNPT,ICSNSP,ICSP,IFNINC,IFUNCT,IFUNPT,IFUNSP,CMCR0045 4IGRMSH,IH,II,IK,IKEYPT,IKEYSP,IL,IM,IN,INCCYC,INDXC,IP,IPAR,IPRPT,CMCR0046 5IPRSP,IPT,IREFPT,IREFSP,IRUN,ISTOP1,ISTOP2,ISUMPT,ISUMSP,IWKPT, CMCR0047 6IWKSP,IWUNPT,IWUNSP,IW2PT,IW2SP,IZERO,J,JCYCLE,JS,K,KCD,KFUN,L, CMCR0048 7LIMLO,LIMUP,LPARNT,M,MARK1,MARK2,MAXORG,MDATA,N,NPAR, CMCR0049 9ABB(23),AVAL,AW,AWW2,CAMCOR,CONCON,CONST,DAR,DROP,FINMAX,SPHCOR, CMCR0050 ASQ,SSLIM,SSQAGE,SUMF,SUMSQ,W2INV,YW,ZERO,ZSSUM CMCR0051 B,IAPCPT,IAPCSP,LGMSCH ,THETA(23),DERIV(23) C---- CMCR0052 C---- XRY274 DIMENSION,EQUIVALENCE AND DATA PACKAGE CMCR0053 C---- CMCR0054 DIMENSION NX(4) CMCR0055 EQUIVALENCE (MAXI,NX(1)),(MAXJ,NX(2)),(MAXK,NX(3)),(MAXL,NX(4)) CMCR0056 DATA IBL1,IREJ/1H ,1HR/ CMCR0057 C**** CMCR0058 C**** CMCR0059 C IN THE 1000 BLOCK THE PREPARATORY CALCULATIONS FOR APPLYING THE CMCR0060 C CORRECTION ARE CARRIED OUT. THE STORE IS REARRANGED FOR THE CMCR0061 C LAST TIME (THANK GOD), THE SUMS FOR CALCULATING THE SUM OF SQUARESCMCR0062 C AND R VALUES ARE ZEROED. THE TITLE IS PRINTED IF REQUIRED. CMCR0063 C**** CMCR0064 C**** CMCR0065 C---- IN THE STORE WE STILL NEED,IPRPT,IFUNPT,ICPT, ARRAYS. WE NEED AN CMCR0066 C---- ARRAY ISUMPT TO KEEP SUMS FOR PARENTS, 13 WORDS PER PARENT AS... C---- 1. SUM (WEIGHT*INTENSITY) BEFORE CORRECTION CMCR0068 C---- 2. SUM (WEIGHT*INTENSITY**2) BEFORE CORRECTION CMCR0069 C---- 3. SUM (WEIGHT) BEFORE CORRECTION CMCR0070 C---- 4. SUM(WEIGHT*INTENSITY) AFTER CORRECTION CMCR0071 C---- 5. SUM(WEIGHT*INTENSITY**2) AFTER CORRECTION CMCR0072 C---- 6. SUM(WEIGHT) AFTER CORRECTION CMCR0073 C---- 7. COUNT OF REFLECTIONS CMCR0074 C---- 8. SUM(1.0/INTENSITY) BEFORE CORRECTION C---- 9. SUM((INTENSITY AFTER CAMEL ONLY)*(INTENSITY BEFORE)**-2) C---- 10. SUM(1.0/INTENSITY) AFTER CORRECTION C---- 11. SUM (INTENSITY**-2) BEFORE CORRECTION C---- 12. SUM(INTENSITY**-2) AFTER CORRECTION(CAMEL NOT SPHERE) C---- 13. SUM(INTENSITY**-2) AFTER CORRECTION C---- WEIGHT = SIGMA**-2 CMCR0075 C---- WE ALSO NEED ICSNPT ARRAY TO KEEP COSINE AND SINE VALUES CMCR0076 C---- OF ANGLES AND INTENSITY POWERS ARRANGED AS.... CMCR0077 C---- 1.COS(N*OMEGA),2.COS(N*2-THETA),3.COS(N*CHI),4.COS(N*PHI), CMCR0078 C---- 5.SIN(N*OMEGA),6.SIN(N*2-THETA),7.SIN(N*CHI),8.SIN(N*PHI), CMCR0079 C---- 9.N*INTENSITY CMCR0080 C---- N=0,1,2,3..... UP TO MAXIMUM ORDER CMCR0081 ISUMPT = ICSP +1 CMCR0082 ISUMSP = ICSP + 13*NPAR JUNK=MAX0(MAXH,MAXI,MAXJ,MAXK,MAXL) + 1 CMCR0084 ICSNPT = ISUMSP +1 CMCR0085 ICSNSP = ISUMSP + JUNK*9 CMCR0086 C---- IS THERE ENOUGH ROOM ... CMCR0087 IF(ICSNSP - MAXCOR) 1020,1020,1005 CMCR0088 C---- TRY AND INCREASE CORE SIZE CMCR0089 1005 CALL MORCOR(ICSNSP) CMCR0090 C---- WAS THE CALL ACCEPTED CMCR0091 IF(MAXCOR-ICSNSP) 1010,1020,1020 CMCR0092 1010 JUNK = NUC005(2) CMCR0093 IQUIT = 1 CMCR0094 CICL WRITE(NTOUT,1015) ICSNSP CMCR0095 PRINT 1015,ICSNSP CMCR0096 1015 FORMAT(17H0*****CAMEL NEEDS ,I10,10H CORE SIZE) CMCR0097 GO TO 9975 CMCR0098 1020 MAXUTL = MAX0(MAXUTL,ICSNSP) CMCR0099 C---- CONVERT FUNCTION ORDERS IN IFUNPT SECTION INTO ADDRESS OF THE CMCR0100 C---- FUNCTION IN ICSNPT SECTION. CMCR0101 C---- LOOP OVER FUNCTIONS CMCR0102 DO 1030 I=IFUNPT,IFUNSP,INDXC CMCR0103 C---- DIRECTLY CONVERT ADDRESS OF INTENSITY FUNCTION CMCR0104 IR(I) = ICSNPT + 9*IR(I) + 8 CMCR0105 C---- LOOP OVER THE ORDERS OF THE ANGLES CMCR0106 DO 1025 J=1,4 CMCR0107 C---- GET THE ADDRESS OF THE SINE/COSINE OF CORRECT ORDER OF ANGLE CMCR0108 IR(I+J) = ICSNPT + 9*IR(I+J) + J + 3 - 4*IR(I+J+4) CMCR0109 1025 CONTINUE CMCR0110 1030 CONTINUE CMCR0111 C---- ZERO ISUMPT CMCR0112 DO 1035 I=ISUMPT,ISUMSP CMCR0113 1035 RI(I) = 0.0 CMCR0114 C---- SET ZERO ORDER SINE AND COSINES AND INTENSITY CMCR0115 JUNK = ICSNPT -1 CMCR0116 DO 1040 I=1,4 CMCR0117 RI(JUNK + I) = 1.0 CMCR0118 1040 RI(JUNK + I + 4) = 0.0 CMCR0119 C---- ZERO ORDER INTENSITY FUNCTION. CMCR0120 RI(ICSNPT+8) = 1.0 CMCR0121 C---- PREPARE FILES CALL NUC007(NFILEA,0) CALL NUC007(NFILEB,0) CALL NUC009(1,NFILEA,NFILEB) C---- ARE WE GPOING TP LIST REFLECTIONS IF(NOBLAB.NE.2) LINCT =-1 CALL NUC010(NFILEA,NFILEB,2,14) C**** CMCR0130 C**** CMCR0131 C IN THE 2000 BLOCK WE READ REFLECTION BY REFLECTION AND WORK OUT CMCR0132 C THE CORRECTION. THE INFORMATION IS PRINTED IF REQUIRED AND THE CMCR0133 C INTENSITY,SIGMA AND TBAR IN THE FILE ARE CORRECTED CMCR0134 C**** CMCR0135 C**** CMCR0136 2005 IPT = NUC013(1,15,NFILEA,NFILEB) IF(IPT) 3005,3005,2010 CMCR0138 C---- FILL UP COSINE AND SINE SECTION OF RI ARRAY FOR FIRST ORDER CMCR0139 C---- ANGLES AND STARTING VALUE IN QTQ(5)... FOR ITERATION CMCR0140 2010 DO 2015 I=1,4 CMCR0141 QTQ(1) = DAR*BUFIO(IPT+I+36) RI(ICSNPT+I+8) = COS(QTQ(1)) CMCR0143 QTQ(I+4) = 2.0*RI(ICSNPT + I + 8) CMCR0144 2015 RI(ICSNPT + I + 12) = SIN(QTQ(1)) CMCR0145 C---- FILL UP INTENSITY FOR FIRST ORDER. CMCR0146 RI(ICSNPT+17) = ABS(BUFIO(IPT+4))/FINMAX C---- CARRY OUT ITERATION TO GET HIGHER ORDER TRIG. FUNCTIONS. METHOD ISCMCR0148 C---- DESCRIBED IN XRY273 CMCR0149 C---- LOOP OVER THE 4 ANGLES CMCR0150 JUNK1 = ICSNPT + 17 CMCR0151 DO 2035 I=1,4 CMCR0152 C---- GET OUT MAXIMUM VALUE CMCR0153 JUNK4 = NX(I) CMCR0154 JUNK1=JUNK1+1 CMCR0155 JUNK2=JUNK1 - 9 CMCR0156 C---- LOOP OVER POWERS REQUIRED ... DO WE NEED TO DO THE ITERATION CMCR0157 IF(JUNK4 - 1) 2035,2035,2020 CMCR0158 2020 DO 2030 J= 2,JUNK4 CMCR0159 JUNK2 = JUNK2 +9 CMCR0160 C---- LOOP OVER TWO SORTS OF TRIG . FUNCTIONS(COS,SIN) CMCR0161 JUNK3 = JUNK2 -4 CMCR0162 DO 2025 K=1,2 CMCR0163 JUNK3 = JUNK3 + 4 CMCR0164 C---- ITERATION CMCR0165 2025 RI(JUNK3) = RI(JUNK3-9)*QTQ(I+4)-RI(JUNK3-18) CMCR0166 C---- BOTTOM OF J LOOP CMCR0167 2030 CONTINUE CMCR0168 C---- BOTTOM OF I LOOP CMCR0169 2035 CONTINUE CMCR0170 C---- CARRY OUT THE ITERATION FOR INTENSITY FUNCTIONS. CMCR0171 C---- DO WE NEED IT CMCR0172 IF(MAXH-1) 2050,2050, 2040 CMCR0173 2040 JUNK=ICSNPT + 17 CMCR0174 DO 2045 I= 2,MAXH CMCR0175 JUNK = JUNK + 9 CMCR0176 2045 RI(JUNK) = RI(JUNK-9)*RI(ICSNPT+17) CMCR0177 C---- LOOP OVER THE ACCEPTED FUNCTION ADDRESSED IN IFUNPT.... JUNK4 CMCR0178 C---- POINTS TO CORRESPONDING COEFFICENT IN ICPT CMCR0179 2050 JUNK4 = ICFNPT - 1 CMCR0180 C---- SET INITIAL VALUE OF ABSORPTION CORRECTION CMCR0181 CAMCOR = CONCON CMCR0182 C---- ARE THERE ANY FUNCTIONS CMCR0183 IF(IFUNCT) 2070,2070,2055 CMCR0184 2055 DO 2065 I=IFUNPT,IFUNSP,INDXC CMCR0185 JUNK4 = JUNK4 + 1 CMCR0186 C---- SET QTQ(20) TO TAKE PRODUCT OF COEFFICIENTS AND FUNCTIONS CMCR0187 QTQ(20) = RI(JUNK4) CMCR0188 C---- LOOP OVER THE FIVE FUNCTIONS CMCR0189 DO 2060 J=IZERO,4 CMCR0190 C---- GET ADDRESS OF FUNCTION CMCR0191 JUNK=IR(I+J) CMCR0192 2060 QTQ(20) = QTQ(20)*RI(JUNK) CMCR0193 C---- UPDATE CAMCOR CMCR0194 CAMCOR = CAMCOR+QTQ(20) CMCR0195 2065 CONTINUE CMCR0196 2070 CONTINUE C---- GET THE VALUES A SPHERICAL ABSORPTION AND ITS TBAR QTQ(1) = 0.5*BUFIO(IPT+38) CALL XRY275(QTQ(1),THETA,ABB,SPHCOR) CALL XRY275(QTQ(1),THETA,DERIV,TBAR) C---- PUT TOTAL CORRECTION IN QTQ(1) CMCR0216 QTQ(1) = SPHCOR*CAMCOR CMCR0217 C---- PUT CORRECTED INTENSITY IN QTQ(2) CMCR0218 QTQ(2) = BUFIO(IPT+4)*QTQ(1) C---- PUT CORRECTED SIGMA IN QTQ(3) CMCR0220 QTQ(3) = BUFIO(IPT+28)*ABS(QTQ(1)) C---- ADD CAMEL CONTRIBUTION TO TBAR TBAR = TBAR + ALOG(CAMCOR)/ABSMU C---- FIND OUT TO WHICH PARENT THIS REFLECTION BELONGS CMCR0224 C---- PUT PACKED INDICES IN IQTQ(100) IQTQ(100) = 40000*(IOBUF(IPT+1)+100) + 200*(IOBUF(IPT+2) + 100) 1 + (IOBUF(IPT+3) + 100) DO 2085 I=IPRPT,IPRSP CMCR0225 IPAR = I CMCR0226 IF(IQTQ(100) - IR(I)) 2085,2090,2085 2085 CONTINUE CMCR0228 C--- NOT A PARENT CMCR0229 IPAR = 0 CMCR0230 GO TO 2105 CMCR0231 C---- LOOK TO SEE IF REFLECTION WAS STRONG ENOUGH FOR CAMEL CMCR0232 2090 JUNK1=IBL1 CMCR0233 IF(BUFIO(IPT+4)-FACTOR*ABS(BUFIO(IPT+28))) 2095,2100,2100 C---- NOT STRONG ENOUGH ... MARK AS REJECTED DO NOT INCLUDE IN SUMS CMCR0235 2095 JUNK1=IREJ CMCR0236 GO TO 2105 CMCR0237 C---- ADD INTO SUMS CMCR0238 2100 JUNK=ISUMPT+(IPAR-1)*13 RI(JUNK+10) = RI(JUNK+10)+1.0/(BUFIO(IPT+4)*BUFIO(IPT+4)) RI(JUNK+11) = RI(JUNK+11) + 1.0/(BUFIO(IPT+4)*BUFIO(IPT+4)*CAMCOR* 1CAMCOR) RI(JUNK+12) = RI(JUNK+12) + 1.0/(QTQ(2)*QTQ(2)) QTQ(100)=1.0/(BUFIO(IPT+28)**2) RI(JUNK)= RI(JUNK) + BUFIO(IPT+4)*QTQ(100) RI(JUNK+1)=RI(JUNK+1) + QTQ(100)*BUFIO(IPT+4)**2 RI(JUNK+2) = RI(JUNK+2) +QTQ(100) CMCR0243 QTQ(100) = 1.0/(QTQ(3)*QTQ(3)) CMCR0244 RI(JUNK+3) = RI(JUNK+3) + QTQ(100)*QTQ(2) CMCR0245 RI(JUNK+4) = RI(JUNK+4) + QTQ(100)*QTQ(2)*QTQ(2) CMCR0246 RI(JUNK+5) = RI(JUNK+5) +QTQ(100) CMCR0247 RI(JUNK+6) = RI(JUNK+6) +1.0 CMCR0248 RI(JUNK+7) = RI(JUNK+7) + 1.0/BUFIO(IPT+4) RI(JUNK+8) = RI(JUNK+8) + CAMCOR/BUFIO(IPT+4) RI(JUNK+9) = RI(JUNK+9) + 1.0/QTQ(2) C---- NOW WE CAN PRINT THIS REFLECTION IF REQUIRED CMCR0249 2105 IF(NOBLAB-1) 2110,2115,2155 CMCR0250 2110 IF(IPAR) 2155,2155,2115 CMCR0251 C---- PUT OUT TITLE WHEN REQUIRED CMCR0252 2115 IF(NUC005(1)) 2120,2130,2120 CMCR0253 2120 JUNK = NUC005(6) CMCR0254 CICL WRITE(NTOUT,2125) FACTOR CMCR0255 PRINT 2125,FACTOR CMCR0256 2125 FORMAT(71H0(REFLECTIONS MARKED R WERE NOT USED BY CAMEL AS INTENSICMCR0257 1TY IS LESS THAN,F5.1,21H STANDARD DEVIATIONS),/, CMCR0258 A 1H0,1X,2HPR,4X,1HH,3X,1HK,3X,1HL,4X,5HOMEGA,2X,7H2-THETA, CMCR0259 16X,3HCHI,6X,3HPHI,2(6X,9HINTENSITY),3X,4HTBAR,4X,5HTOTAL, CMCR0260 23X,5HCAMEL,3X,6HSPHERE,/,61X,6HBEFORE,10X,5HAFTER,15X,11HCORRECTIOCMCR0261 3NS,/) CMCR0262 2130 CONTINUE C---- PRINT OUT LINE....DOES IT HAVE A PARENT CMCR0267 IF(IPAR) 2135,2135,2145 CMCR0268 C---- NO CMCR0269 2135 CONTINUE CMCR0270 CICL WRITE(NTOUT,2140) IOBUF(IPT+1),IOBUF(IPT+2),IOBUF(IPT+3),BUFIO(IPT PRINT 2140, IOBUF(IPT+1),IOBUF(IPT+2),IOBUF(IPT+3),BUFIO(IPT 1+37),BUFIO(IPT+38),BUFIO(IPT+39),BUFIO(IPT+40),BUFIO(IPT+4), 2QTQ(2),TBAR,QTQ(1),CAMCOR,SPHCOR 2140 FORMAT(5X,3I4,4F9.2,2F15.2,F7.4,F9.2,F8.3,F9.2) CMCR0275 GO TO 2155 CMCR0276 C---- THERE IS A PARENT CMCR0277 2145 CONTINUE CMCR0278 CICL WRITE(NTOUT,2150) IPAR,JUNK1,IOBUF(IPT+1),IOBUF(IPT+2),IOBUF(IPT+ PRINT 2150, IPAR,JUNK1,IOBUF(IPT+1),IOBUF(IPT+2),IOBUF(IPT+ 13),BUFIO(IPT+37),BUFIO(IPT+38),BUFIO(IPT+39),BUFIO(IPT+40),BUFIO( 2IPT+4),QTQ(2),TBAR,QTQ(1),CAMCOR,SPHCOR 2150 FORMAT(1X,I3,A1,3I4,4F9.2,2F15.2,F7.4,F9.2,F8.3,F9.2) CMCR0283 C---- UPDATE THE FILE CMCR0284 C---- F RELATIVE AND ITS SIGMA 2155 QTQ(88) = SQRT(QTQ(1)/BUFIO(IPT+8)) BUFIO(IPT+12) = QTQ(88)*BUFIO(IPT+12) BUFIO(IPT+13) = QTQ(88)*BUFIO(IPT+13) C---- ABSORPTION CORRECTION BUFIO(IPT+8) = QTQ(1) C---- DELXT AND TBAR BUFIO(IPT+21) = TBAR C---- GO BACK AND GET ANOTHER REFLECTION CMCR0288 GO TO 2005 CMCR0289 C**** CMCR0290 C**** CMCR0291 C IN THE 3000 BLOCK THE PSUEDO R VALUES ARE CALCULATED AND PRINTED CMCR0292 C**** CMCR0293 C**** CMCR0294 3005 IF(LINCT-15) 3010,3015,3015 CMCR0295 3010 LINCT=0 CMCR0296 3015 JUNK=NUC005(6) CICL WRITE(NTOUT,3020) CMCR0298 PRINT 3020 CMCR0299 3020 FORMAT(40H0PARENT REFLECTION INTENSITY INFORMATION,/,1H0,7X,1HH, 13X,1HK,3X,1HL,2X,4HNOBS,4X,9(1H.),8HR VALUES,9(1H.),9X,11(1H.), 214HMEAN INTENSITY,11(1H.),/,27X,6HBEFORE,5X,5HAFTER,2X,8HEXPECTED, 39X,6HBEFORE,4X,11HAFTER CAMEL,4X,11HAFTER TOTAL,/) C---- LOOP OVER SUMS CMCR0302 JUNK = 0 CMCR0303 JUNK2= IPRPT - 1 DO 3040 I=ISUMPT,ISUMSP,13 JUNK2 = JUNK2 + 1 C---- PUT OUT TITLE IF NECESSARY CMCR0305 IF(NUC005(1)) 3025,3030,3025 CMCR0306 3025 JUNK1=NUC005(6) CICL WRITE(NTOUT,3020) CMCR0308 PRINT 3020 CMCR0309 3030 JUNK = JUNK + 1 CMCR0310 C---- COUNT OF MEASUREMENTS USED JUNK4 = (RI(I+6)+0.1) C---- MEAN INTENSITY BEFORE CORRECTION RI(I+7) = RI(I+7)/RI(I+10) C---- MEAN INTENSITY AFTER JUST CAMEL RI(I+8) = RI(I+8)/RI(I+10) C---- MEAN INTENSITY AFTER TOTAL CORRECTION RI(I+9) = RI(I+9)/RI(I+12) C---- R VALUE BEFORE CMCR0311 RI(I) = SQRT(1.0 - RI(I)*RI(I)/(RI(I+2)*RI(I+1))) CMCR0312 C---- R VALUE AFTER CMCR0313 RI(I+3)=SQRT(1.0-RI(I+3)*RI(I+3)/(RI(I+5)*RI(I+4))) CMCR0314 C---- R VALUE EXPECTED FROM SIGMAS CMCR0315 RI(I+6) = SQRT(RI(I+6)/RI(I+1)) CMCR0316 C---- GET PARENT REFLECTION INDICES IQTQ(61) = IR(JUNK2)/40000 - 100 IQTQ(62) = MOD(IR(JUNK2),40000)/200 - 100 IQTQ(63) = MOD(IR(JUNK2),200) - 100 CICL WRITE(NTOUT,3035) JUNK,(IQTQ(J),J=61,63),JUNK4,RI(I),RI(I+3), PRINT3035, JUNK,(IQTQ(J),J=61,63),JUNK4,RI(I),RI(I+3), 1(RI(I+J),J=6,9) 3035 FORMAT(1X,I3,1H),3I4,I6,3F10.3,3F15.2) 3040 CONTINUE CMCR0320 FACTOR =1.0/FACTOR CMCR0321 JUNK=NUC005(4) CMCR0322 CICL WRITE(NTOUT,3045) FACTOR CMCR0323 PRINT 3045,FACTOR CMCR0324 3045 FORMAT(27H0MAXIMUM EXPECTED R VALUE =, F6.3,//) CMCR0325 C---- FINISH OFF FILES CALL NUC010(NFILEA,NFILEB,16,MAXREC) CALL NUC007(NFILEA,0) CALL NUC007(NFILEB,0) 9975 CONTINUE CMCR0332 RETURN CMCR0333 END CMCR0334 SUBROUTINE XRY275(ARG,T1,T2,RESULT) CMIN0001 C----VERSION AND UPDATING ESTABLISHED 5 OCT 1968 CMIN0002 C ALTERATIONS MADE AS FOLLOWS... 7 OCT 68, 23 SEP 69 CMIN0003 C CMIN0004 C CMIN0005 C----SUBROUTINE INTER CMIN0006 C----ARG IS A MEMBER OF TABLE 1, T1 CMIN0007 C T1 IS A TABLE OF ARGUMENT VALUES THAT MUST EXTEND 3 ENTRIES BEYOND CMIN0008 C THE INTERVAL IN WHICH ARG FALLS CMIN0009 C T2 IS A TABLE OF FUNCTION VALUES FOR THE ENTRIES OF T1 CMIN0010 C CMIN0011 C NO PRESUMPTION IS MADE REGARDING INTERVAL STEPS OF T1 CMIN0012 DIMENSION T1(50),T2(50),DIF(5) CMIN0013 K = 1 CMIN0014 1203 IF (ARG-T1(K)) 1207,1206,1204 CMIN0015 1204 K = K + 1 CMIN0016 IF (K-50)1203,1206,1206 CMIN0017 C ENTRY COINCIDES WITH EXACT TABLE VALUE CMIN0018 1206 RESULT = T2(K) CMIN0019 GO TO 9999 CMIN0020 C WE ARE IN FIRST INTERVAL, LET'S INTERPOLATE CMIN0021 1207 K = K - 1 CMIN0022 DO 1208 I=1,3 CMIN0023 J = K + I CMIN0024 1208 DIF(I)=((T2(K)*(T1(J)-ARG))-(T2(J)*(T1(K)-ARG)))/ CMIN0025 * ((T1(J))-(T1(K))) CMIN0026 DIF(4) = ((DIF(1)*(T1(K+2)-ARG))-(DIF(2)*(T1(K+1)-ARG)))/ CMIN0027 * (T1(K+2)-T1(K+1)) CMIN0028 DIF(5) = ((DIF(1)*(T1(K+3)-ARG))-(DIF(3)*(T1(K+1)-ARG)))/ CMIN0029 * (T1(K+3)-T1(K+1)) CMIN0030 C CMIN0031 RESULT = ((DIF(4)*(T1(K+3)-ARG))-(DIF(5)*(T1(K+2)-ARG)))/ CMIN0032 * (T1(K+3)-T1(K+2)) CMIN0033 C CMIN0034 9999 RETURN CMIN0035 END CMIN0036 SUBROUTINE NUC217(NT,IR,ILBUF,IWRRE) NUBB0001 C----- NUBB0002 C-----SUBROUTINE NUBB NUBB0003 C----- NUBB0004 C---- SUBROUTINE TO DO SPECIAL FILE READING AND WRITING WITHOUT USE NUBB0005 C---- OF AN INTERMEDIATE BUFFER, IN A WAY SIMILAR TO VIRTUAL NUBB0006 C---- MEMORY. THERE IS TRANSFER DIRECTLY FROM DEVICE TO NUBB0007 C---- ARRAY IR WITHOUT ANY CHECKING. VERY USEFUL FOR THE NUBB0008 C---- CAMEL NUBB0009 C---- IWRRE = D FOR WRITING = 1 FOR READING, = 2 FOR REWIND. NUBB0010 C---- NT IS POINTER TO LOGICAL UNIT NUBB0011 C---- IR IS ARRAY TO BE TRANSFERED NUBB0012 C---- ILBUF IS LENGTH OF BUFFER NUBB0013 C----- NUBB0014 C-----COMMON IONEW FOR INFORMATION ON INPUT OUTPUT UNITS NUBB0015 C----- NUBB0016 COMMON/IONEW/IORW,IOPLAC,IOMODE(12),IOSIGL(12),IOUNIT(12), NUBB0017 1IODISC(12),IOINST(12),IO NUBB0018 C---- NUBB0019 C---- SYSTEM COMMON,DIMENSION AND EQUIVALENCE PACKAGE NUBB0020 C---- NUBB0021 COMMON/SYS/IDCOMP(2),NTIN,NTOUT,NFILEA,NFILEB,NFILEC,NFILED, NUBB0022 *NFILEE,NFILEF,NFILEG,NFILEH,NFILEI,NFILEJ,NCDBUF,NTINM,NTOUTM, NUBB0023 *NTPCHM,IDPROG(2),ITOOB,NPAGE,LINMX,LINCT,NCRDS,ISHORT, NUBB0024 *TITLE(19),CARD(21),QTQ(100),ICYCLE,IQUIT, NUBB0025 *JUNK,JUNK1,JUNK2,JUNK3,JUNK4,IOZY,IOZTM,ICDC(20) NUBB0026 DIMENSION IQTQ(100),ICARD(21),NTIND(1) NUBB0027 EQUIVALENCE (QTQ(1),IQTQ(1)),(NFILEC,NTPCH),(NTCU,NTPCHM) NUBB0028 EQUIVALENCE (CARD(1),ICARD(1)),(NTIND(1),NTIN) NUBB0029 C----- NUBB0030 C----DIMENSION AND DATA FOR NUBB NUBB0031 C----- NUBB0032 DIMENSION IR(ILBUF),IMES(2) NUBB0033 DATA IMES/6HWRITE ,6H READ / NUBB0034 ITEMP = IWRRE + 1 NUBB0035 JDISC = IOUNIT(NT) NUBB0036 IF(IWRRE-2) 101,100,100 NUBB0037 100 CALL NTRAN(JDISC,10,22) NUBB0038 GO TO 9999 NUBB0039 101 CALL NTRAN(JDISC,ITEMP,ILBUF,IR,ITEST,22) NUBB0040 IF(ITEST.EQ.ILBUF) GO TO 9999 NUBB0041 JUNK = NUC005(2) NUBB0042 CICL WRITE(NTOUT,102) IMES(ITEMP),JDISC,ITEST NUBB0043 PRINT 102,IMES(ITEMP),JDISC,ITEST NUBB0044 102 FORMAT(11H0FAILURE TO,A6,7HON UNIT,I5,15H NTRAN SIGNAL = , I5) NUBB0045 C---- FORCE DUMP NUBB0046 IF(IQUIT.NE.0) CALL DEAD NUBB0047 IQUIT = 1 NUBB0048 9999 CONTINUE NUBB0049 RETURN NUBB0050 END NUBB0051 *DECK,CAMEL1 ELEMENT 1 1.CAMEL - 1 0 0 0 CAMEL JOCKEY ------------ 0 (AN EXPERIMENTAL ABSORPTION-EXTINCTION-MISALIGNMENT CORRECTION PROGRAMME) ------------------------------------------------------------------------- 0 OR 0 THE QUINTESSENCE OF EMPIRICISM ------------------------------ 0 0INTRODUCTION ----------- 0 THE CAMEL JOCKEY PROGRAMME WAS WRITTEN BY H.D. FLACK OF THE =LABORATOIRE DISCIPLINAIRE DE CRISTALLOGRAPHIE AUX RAYONS X = OF THE UNIVERSITY OF GENEVA. THIS WORK WAS SUPPORTED BY THE = FONDS NATIONAL SUISSE DE LA RECHERCHE SCIENTIFIQUE = PROJECT NO. 2.173-0.74. THE PROGRAMME WAS DEBUGGED AND TESTED ON THE UNIVAC 1108 OF THE = CENTRE UNIVERSITAIRE D'INFORMATIQUE = OF THE UNIVERSITY OF GENEVA. 0 THE OBJECT OF THE PROGRAMME IS TO MAKE AN ABSORPTION, EXTINCTION AND MISALIGNMENT CORRECTION FROM INTENSITY MEASUREMENTS ON THE CRYSTAL UNDER STUDY. NO DETAILED KNOWLEDGE OF THE SHAPE OR MOSAIC DISTRIBUTION OF THE CRYSTAL IS REQUIRED. THE METHOD IS THUS APPLICABLE TO CRYSTALS OF IRREGULAR SHAPE OR CRYSTALS CONTAINED WITHIN A SUPPORT(SUCH AS A GLASS CAPILLARY WITH MOTHER LIQUOR,OPPOSED ANVILS OF A HIGH PRESSURE CELL, HOUSING OF A LIQUID HELIUM CRYOSTAT, ONE CRYSTAL INCLUDED INSIDE ANOTHER). THE PROGRAMME MAY ALSO BE USED TO CORRECT FOR MISCENTRING OF THE CRYSTAL OR MISALIGNMENT OF THE DIFFRACTOMETER. THIS FEATURE COULD BE USEFUL IN CASES WHERE THE CENTRING IS DIFFICULT TO CARRY OUT (E.G. LIQUID HELIUM CRYOSTAT OR CRYSTAL INCLUSIONS). THE PRESENT CODE HAS NO LIMITATIONS OR ASSUMPTIONS WITH REGARD TO SPACE GROUP, NUMBER OF MEASUREMENTS OR THE STRENGTH OF THE ABSORPTION-EXTINCTION-MISALIGNMENT. 0 0INTENSITY MEASUREMENTS ---------------------- 0 TWO SETS OF INTENSITY MEASUREMENTS FROM THE CRYSTAL ARE REQUIRED. 01. THE STANDARD DATA COLLECTON WHICH IS GENERALLY THE SEQUENTIAL MEASUREMENT OF ALL REFLECTIONS IN THE ASYMMETRIC UNIT OF RECIPROCAL SPACE. THESE INTENSITIES WILL BE CORRECTED FOR ABSORPTION-EXTINCTION-MISALIGNMENT FROM THE RESULTS OF THE CALCULATIONS MADE WITH THE SECOND SET OF MEASUREMENTS. 02. THE CAMEL DATA COLLECTION OF SETS OF INTENSITY MEASUREMENTS WHICH IN THE ABSENCE OF ABSORPTION-EXTINCTION-MISALIGNMENT WOULD HAVE EXACTLY THE SAME INTENSITY VALUE BUT WHICH IN THEIR PRESENCE SHOW DIFFERENCES OF INTENSITY. THE REQUIREMENTS OF A CAMEL DATA COLLECTION ARE FULFILLED BY MEASUREMENTS OF SYMMETRY EQUIVALENT REFLECTIONS AND OF AZIMUTHAL SCANS (PSI) OF THESE REFLECTIONS. (AZIMUTHAL SCANS ARE OBTAINED BY ROTATION OF THE CRYSTAL ABOUT THE NORMAL TO ITS REFLECTING PLANE WHICH ON A FOUR CIRCLE DIFFRACT- OMETER RESULTS FROM A CONCURRENT MOVEMENT OF THE CIRCLES OMEGA,CHI,AND PHI.) A NUMBER OF =BASIC= OR PARENT REFLECTIONS ARE CHOSEN. FOR EACH OF THESE WE MEASURE ALL OF THE INTENSITY EQUIVALENT REFLECTIONS AT PSI ANGLES PSIMIN,PSIMIN+DELPSI,PSIMIN+2*DELPSI,....,PSIMAX ACCESSIBLE TO THE DIFFRACTOMETER. 0SEE BELOW FOR SOME HELP ON HOW TO CHOOSE THE PARENT REFLECTIONS,PSIMIN,DELPSI, AND PSIMAX. 0 0THE METHOD OF FINDING THE CAMEL CORRECTION ------------------------------------------ 0 IT IS A STATISTICAL CURVE FITTING METHOD DEVOID OF A PHYSICAL MODEL. LET.. 0H(IJ) BE THE INTENSITY OF THE I TH. MEASUREMENT BEFORE CAMEL CORRECTION. J INDICATES THAT IT BELONGS TO THE J TH. SET OF EQUIVALENT REFLECTIONS (J TH. PARENT). 0G(IJ) BE THE INTENSITY OF THE I TH. MEASUREMENT AFTER CORRECTION FOR ABSORPTION-EXTINCTION-MISALIGNMENT. 0WE CAN WRITE... 0 G(IJ) = H(IJ) * CAMCOR(I) 0WHERE CAMCOR(I) IS THE CAMEL ABSORPTION-EXTINCTION-MISALIGNMENT CORRECTION FOR THE I TH. MEASUREMENT. WE WRITE 0 CAMCOR(I) = C(0)*F(0I) + C(1)*F(1I) + C(2)*F(2I) + ..... 0WHERE.. F(N) ARE TRIGONOMETRIC-POWER FUNCTIONS OF THE DIFFRACTOMETER ANGLES OMEGA,TWO-THETA,CHI,AND PHI AND THE REFLECTION INTENSITY , SELECTED TO OBEY THE SYMMETRY OF THE DIFFRACTOMETER, AND C(N) ARE COEFFICIENTS , CALCULATED BY A LEAST-SQUARES METHOD, WHICH GIVE THE BEST REPRESENTATION OF THE ABSORPTION-EXTINCTION-MISALIGNMENT. 0 THIS LEAST-SQUARES METHOD TRIES TO MAKE ALL OF THE MEASUREMENTS OF AN EQUIVALENT REFLECTION AS NEARLY EQUAL AS POSSIBLE UNDER CERTAIN RESTRICTIONS OR CONSTRAINTS WHICH ARE DESCRIBED IN DETAIL BELOW. THE SAME METHOD SHOWS WHICH AND HOW MANY OF THE FUNCTIONS F(N) ARE NECESSARY TO DESCRIBE THE ABSORPTION-EXTINCTION-MISALIGNMENT. 0 0WHAT FUNCTIONS ARE USED FOR CAMCOR ----------------------------------- 0 A TYPICAL FUNCTION F(N) IS 0 F = ((INTENSITY)**H)*SIN(I*OMEGA)*SIN(J*2THETA)*COS(K*CHI)*SIN(L*PHI)) 0WHERE H,I,J,K, AND L ARE THE ORDERS OF THE FUNCTION. 0THE CAMEL METHOD TESTS SEQUENTIALLY A SET OF CANDIDATE FUNCTIONS LIKELY TO BE USEFUL IN REPRESENTING THE CAMEL CORRECTION. IF THE FUNCTION IS SIGNIFICANT IT IS ADDED TO THE LIST OF FUNCTIONS TO BE USED FOR CAMCOR, OTHERWISE IT IS TEMPORARILY REJECTED. THE SET OF CANDIDATE FUNCTIONS IS EXAMINED A MAXIMUM OF THREE TIMES AND THUS A FUNCTION NOT INCLUDED ON THE FIRST CYCLE (EXAMINATION) MAY BE INCLUDED ON A SUBSEQUENT CYCLE. 0THE NUMBER OF CANDIDATE FUNCTIONS EXAMINED IS LIMITED BY SEVERAL MEANS IN THE PROGRAMME. FIRSTLY THE USER HAS TO GIVE MAXIMUM VALUES FOR H,I,J,K, AND L. SECONDLY THE USER HAS TO GIVE A VALUE FOR THE MAXIMUM VALUE OF Q PERMITTED FOR A CANDIDATE FUNCTION WHERE, 0 Q = H/MAXH + I/MAXI + J/MAXJ + K/MAXK + L/MAXL . 0THIRDLY THE USER HAS TO INDICATE THE MAXIMUM NUMBER OF EXAMINATIONS- TRIALS TO BE MADE. 0THE LIST OF CANDIDATE FUNCTIONS IS SORTED ACCORDING TO THE VALUE OF Q IN ORDER THAT THE LOW ORDER FUNCTIONS ARE TRIED FIRST. NORMALLY THE LOW ORDER FUNCTIONS ARE THE MOST IMPORTANT IN THE FIT. THIS MEANS THAT THE ABSORPTION, EXTINCTION AND MISALIGNMENT CORRECTIONS ARE CARRIED OUT SIMULTANEOUSLY. 0A FURTHER TEST IN THE PROGRAMME CALCULATES THE DEGREE OF CORRELATION OF A CANDIDATE FUNCTION WITH THE PREVIOUSLY ACCEPTED FUNCTIONS. IF THE CANDIDATE FUNCTION IS TOO STRONGLY CORRELATED, IT IS DEFINITELY REJECTED FROM THE CAMCOR. 0 0A LIMITATION OF THE CAMEL MEASUREMENTS -------------------------------------- 0 THE MEASUREMENT OF EQUIVALENT REFLECTIONS BY AZIMUTHAL SCANS DOES NOT GIVE ANY INFORMATION ON THE VARIATION OF CAMCOR AS A PURE FUNCTION OF TWO- THETA. IN PHYSICAL TERMS THIS MEANS THAT THESE MEASUREMENTS TELL US NOTHING ABOUT AN ABSORBING SPHERICAL CRYSTAL SUFFERING ISOTROPIC EXTINCTION. THUS THE CAMEL PROGRAMME ALWAYS MULTIPLIES THE CAMEL CORRECTION BY THE ABSORPTION CORRECTION FOR A SPHERE OF RADIUS EQUIVALENT TO THE CRYSTAL UNDER STUDY. TO CORRECT FOR THE PURELY ISOTROPIC PART OF THE EXTINCTION, AN ISOTROPIC EXTINCTION PARAMETER SHOULD BE INCLUDED WITH THE ATOMIC PARAMETERS IN THE FINAL STAGES OF STRUCTURE REFINEMENT BY LEAST-SQUARES. 0 0CONSTRAINTS ----------- 0 TWO TYPES OF CONSTRAINT ARE USED IN THE CAMEL PROGRAMME. 01. THE FIRST CONSTRAINT IS EXACT. IT IS... 0 SUM(CAMCOR(I)) = NUMBER OF OBSERVATIONS 0 THIS RELATION IMPLIES A MEAN CORRECTION OF 1.0 WHICH IN VIEW OF THE INABILITY OF PSI-SCAN MEASUREMENTS TO MEASURE VARIATIONS OF ABSORPTION OR EXTINCTION AS A FUNCTION OF TWO-THETA ONLY,IS A PHYSICALLY REASONABLE CHOICE. THIS CONSTRAINT ACTS AS FIXING A SCALE FACTOR FOR THE CAMEL CORRECTION. WE COULD EQUALLY WELL HAVE CHOSEN A MEAN CORRECTION OF 10.0 (FOR EXAMPLE). HOWEVER WITHOUT THIS CONSTRAINT THE CAMEL CALCULATES ALL CORRECTIONS AS ZERO, GIVING A SUM OF SQUARES OF ZERO. THIS STATISTICALLY HEAVENLY RESULT IS, NEED WE SAY IT, USELESS PHYSICALLY. 0 THIS FIRST CONSTRAINT BEING EXACT, IT IS BUILT DIRECTLY INTO THE MODEL BY LETTING F(0) BE EQUAL TO 1.0 AND CALCULATING C(0) SO THAT THE CONSTRAINT CONDITION IS OBEYED. 02. THE SECOND CONSTRAINT IS APPROXIMATE AND ITS 'STRENGTH' MAY BE VARIED FROM THE DATA CARDS.THE CONSTRAINT MAY BE STATED AS FOLLOWS... WEIGHTED MEAN INTENSITY OF JTH. PARENT REFLECTION BEFORE CORRECTION SHOULD BE APPROXIMATELY EQUAL TO THIS INTENSITY AFTER CORRECTION, FOR ALL PARENTS I.E. LET G(J) BE THE WEIGHTED MEAN VALUE OF THE CORRECTED INTENSITY OF THE J TH. PARENT H(J) BE THE WEIGHTED MEAN VALUE OF THE UNCORRECTED INTENSITY OF THE J TH PARENT, THEN 0 H(J) APPROXIMATELY EQUAL TO G(J) (FOR ALL J). 0 IT WAS FOUND IN EARLIER VERSIONS OF THIS PROGRAMME WHERE THIS SECOND CONSTRAINT WAS NOT IMPLEMENTED, THAT OFTEN THE CAMEL REDUCED THE SUM OF SQUARES BY CHANGING,IN AN UNREASONABLE MANNER, THE PARENT INTENSITY AFTER CORRECTION. ON REFLECTIONS NOT IN THE CAMEL SET AN UNSATISFACTORY RESULT WAS OBTAINED. 0 THE CONSTRAINT IS IMPLEMENTED BY INTRODUCING ADDITIONAL OBSERVATIONAL EQUATIONS INTO THE LEAST SQUARES,FOLLOWING LAWSON AND HANSON. ONE OBSERVATIONAL EQUATION IS INTRODUCED FOR EACH PARENT REFLECTION. THIS EQUATION HAS THE FORM .... 0 DOWNWT*SQRT(W2(J))*H(J) = DOWNWT*SQRT(W2(J))*G(J) 0WHERE H(J) AND G(J) ARE DEFINED ABOVE, W2(J) IS THE WEIGHT ASSOCIATED WITH THE J TH. PARENT REFLECTION AND DOWNWT IS A DOWNWEIGHTING FACTOR TO CONTROL THE STRENGTH OF THESE EXTRA OBSERVATIONAL EQUATIONS. (CLEARLY DOWNWT = 0.0 MEANS THIS CONSTRAINT HAS NO EFFECT.) 0 0BRIEF DESCRIPTION OF THE MATHEMATICAL PROCEDURES ------------------------------------------------ 0 THE FUNCTION MINIMIZED BY THE LEAST-SQUARES IS 0 S = SUM1(W1(I)*(G(IJ)-G(J))**2) + SUM2(DOWNWT**2*W2(J)*(H(J)-G(J))**2) 0WHERE SUM1 INDICATES THE SUM OVER THE REFLECTION OBSERVATIONS, W1(I) IS THE WEIGHT OF THE I TH. OBSERVATION, SUM2 INDICATES A SUM OVER THE PARENT REFLECTIONS. THIS SUM2 ARISES FROM INTRODUCING THE APPROXIMATE CONSTRAINTS AS ADDITIONAL OBSERVATIONAL EQUATIONS. 0 DOING THE ALEGBRA WE ARRIVE AT THE LEAST-SQUARES NORMAL EQUATIONS. HOWEVER THE PROGRAMME WORKS BY TRANSFORMING THE MODEL IN TERMS OF THE COEFFICIENTS C AND FUNCTIONS F INTO AN OTHOGONALIZED MODEL IN TERMS OF COEFFICIENTS A . THIS TRANSFORMATION IS CALLED THE (MODIFIED) GRAM-SCHMIDT TRANSFORMATION AND LEADS TO A DIAGONAL LEAST-SQUARES MATRIX. ONCE FUNCTION TESTING IS COMPLETED THE A COEFFICIENTS ARE CONVERTED INTO C COEFFICIENTS. 0THE PROGRAMME STOPS TRYING TO FIT WHEN THE RELATIVE ERROR HAS REACHED A VALUE SPECIFIED BY THE USER. IN THIS RESPECT THE RELATIVE ERROR IS DEFINED BY 0ERROR = SQRT((RESIDUAL SUM OF SQUARES)/(INITIAL SUM OF SQUARES ABOUT MEANS)) 0A FUNCTION IS CONSIDERED TO BE SIGNIFICANT IN THE DESCRIPTION OF CAMCOR IF THE REDUCTION IN THE WEIGHTED SUM OF SQUARES IT PRODUCES IS GREATER THAN 0(CURRENT RESIDUAL SUM OF SQUARES)/(NUMBER OF FUNCTIONS WANTED - NUMBER ALREADY ACCEPTED) 0THE VARIOUS INTENSITY R VALUES PRINTED BY THE PROGRAMME ARE DEFINED... 0 R(J) BEFORE = SQRT( SUM(((H(IJ)-H(J))/SIGMA(IJ))**2)/SUM((H(IJ)/SIGMA(IJ))**2)) 0 R(J) AFTER = SQRT( SUM(((G(IJ)-G(J))/SIGMA(IJ))**2/SUM((H(IJ)/SIGMA(IJ))**2)) 0 AN EXPECTED VALUE OF R(J) CAN BE CALCULATED BY ASSUMING THAT ONLY STATISTICAL ERRORS ARE PRESENT... 0 R(J) EXPECTED = SQRT(NUMBER OF OBS(J)/SUM((H(IJ)/SIGMA(IJ))**2)) WHERE SIGMA(IJ) IS THE STANDARD DEVIATION OF THE IJ OBSERVATION. 0 0WEIGHTING SCHEMES ----------------- W1(I) = 1.0/(H(IJ)**2) 0 W2(J) = 1.0/(H(J)**2) 0 THESE WEIGHTING SCHEMES HAVE BEEN CHOSEN SO THAT STRONG AND WEAK REFLECTIONS CONTRIBUTE APPROXIMATELY EQUALLY TO THE WEIGHTED SUM OF SQUARES. 0 0ALIGNMENT CORRECTION AND SYMMETRY OF DIFFRACTOMETER --------------------------------------------------- 0 A CONVENTIONAL FOUR CIRCLE DIFFRACTOMETER IS SUCH THAT A REFLECTION MAY BE MEASURED IN ONE OF THE FOLLOWING EIGHT ANGULAR SETTINGS. 0 1. OME, TTH, CHI, PHI 2. OME, -TTH, -CHI, PHI+PI 3. -OME, -TTH, CHI+PI PHI 4. -OME, TTH, -CHI+PI, PHI+PI 5. OME+PI, -TTH, CHI, PHI 6. OME+PI, TTH, -CHI, PHI+PI 7. -OME+PI, TTH, CHI+PI, PHI 8. -OME+PI, -TTH, -CHI+PI, PHI+PI 0 MEASUREMENTS IN THESE EIGHT ANGULARLY EQUIVALENT POSITIONS SHOULD GIVE IDENTICAL INTENSITIES WITHIN EXPERIMENTAL ERROR IF THE DIFFRACTOMETER IS ALIGNED AND THE CRYSTAL CENTRED. THUS IN THE DIFFRACTOMETER =ALIGNED= OPTION, THE PROGRAMME WILL PRODUCE A CAMCOR OBEYING THE ABOVE SYMMETRY RELATIONS. THIS IS ACHIEVED BY USING ONLY THOSE FUNCTIONS WHICH OBEY THE ABOVE RELATIONS. CLEARLY IF THE CRYSTAL IS MISCENTRED OR THE DIFFRACTOMETER MISALIGNED, DIFFERENCES IN INTENSITY WILL OCCUR AMONGST THE EIGHT SETTINGS AND THESE MAY BE USED IN THE CAMEL TO PRODUCE A MISALIGNMENT CORRECTION. IN THE DIFFRACTOMETER =MISALIGNED= OPTION THE CAMCOR IS MADE TO OBEY ONLY THE FOLLOWING SYMMETRICALLY EQUIVALENT SETTINGS. 0 1. OME, TTH, CHI, PHI 2. OME+PI, -TTH, CHI, PHI 0 IN THEORY ONLY THE FIRST WOULD BE NECESSARY FOR A TOTALLY MISALIGNED SYSTEM. HOWEVER CAREFULL STUDY OF THE EIGHT POSITIONS ABOVE WILL SHOW THAT (ON A PHILIPS PW110, SYNTEX P21, AND PICKER) ONLY THE FIRST FOUR ARE MECHANICALLY ATTAINABLE DUE TO RESTRICTED MOVEMENT ON THE OMEGA CIRCLE. HENCE FOR THE =MISALIGNED= OPTION WE ASSUME A SYMMETRY WHICH CANNOT BE EXPERIMENTALLY DISPROVED. (THE READER IS LEFT TO DECIDE WHY THIS IS DONE) 0 0SOME COMPUTATIONAL DETAILS -------------------------- 0 REFER TO THE PROGRAMME LISTING FOR COMPLETE INFORMATION ON THE WAY THE PROGRAMME IS ARRANGED. HOWEVER THREE POINTS ARE WORTH MENTIONING. 0A. THE INTENSITY, PARENT INDEX AND THE COSINE AND SINE OF THE ANGLES OMEGA, TWO-THETA,CHI AND PHI OF THE CAMEL MEASUREMENTS ARE KEPT IN CORE. IN ORDER TO SAVE SPACE LIMITED PRECISION COSINE AND SINE FOR EACH ANGLE ARE PACKED INTO ONE WORD. 0B. THE TRIGONOMETRIC FUNCTIONS OF HIGHER ORDER ANGLES ARE CALCULATED BY AN ITERATIVE PROCEDURE.... 0 COS((N+1)*A) = 2.0*COS(A)*COS(N*A) - COS((N-1)*A) 0 SIN((N+1)*A) = 2.0*COS(A)*SIN(N*A) - SIN((N-1)*A) 0THIS PROCEDURE SAVES A CONSIDERABLE AMOUNT OF COMPUTER TIME. 0C. CAMEL CONTROLS FOR ITSELF THE SIZE OF MEMORY IT NEEDS. IN OTHER PROGRAMMES IN THE X-RAY THIS IS DONE BY USE OF THE CARD =MAXSIZE=. HOWEVER IF AT ANY MOMENT THE =CAMEL= DOES NOT HAVE SUFFICIENT MEMORY AVAILABLE IT SIMULATES THE READING OF A =MAXSIZE= CARD WITH THE NECESSARY MEMORY SPACE INDICATED. AT THE END OF THE PROGRAMME THE MEMORY SIZE IS SET BACK TO ITS ORIGINAL VALUE. 0 0OPERATION OF THE PROGRAMME -------------------------- 0 THE PROGRAMME WORKS ENTIRELY ON THE BINARY DATA FILE. =CAMEL= SHOULD BE RUN BEFORE ANY AVERAGING PERFORMED BY THE PROGRAM =SORTAV=. 0A. THE FILE IS READ PUTTING INTO CORE, THE INTENSITY AND ANGULAR DATA ON EACH MEASUREMENT OF A PARENT REFLECTION. ONLY THOSE MEASUREMENTS WITH INTENSITY GREATER THAN A SPECIFIED NUMBER OF STANDARD DEVIATIONS ARE USED. 0B. THOSE PARENTS OF WHICH THERE ARE LESS THAN A SPECIFIED NUMBER OF MEASUREMENTS ARE ELIMINATED. 0C. A LIST OF CANDIDATE FUNCTIONS IS CONSTRUCTED ACCORDING TO THE MAXIMUM VALUES OF H,I,J,K,L, AND Q GIVEN BY THE USER, AND WHETHER THE DIFFRACTOMETER AND CRYSTAL ARE ASSUMED ALIGNED. THE LIST OF CANDIDATE FUNCTIONS IS SORTED ACCORDING TO THE VALUE OF Q. 0D. THE MULTI-DIMENSIONAL FIT USING THE MODIFIED GRAM-SCHMIDT TRANSFORMATIONS IS PERFORMED. THE FIT ALWAYS INCLUDES ONE PARAMETER FOR EACH PARENT REPRESENTING THE WEIGHTED-MEAN CORRECTED-INTENSITY DIVIDED BY THE MAXIMUM INTENSITY IN THE FILE. FITTING STOPS WHEN THE DESIRED PRECISION IS ATTAINED , OR WHEN THREE CYCLES HAVE BEEN COMPLETED, OR WHEN THE MAXIMUM NUMBER OF FUNCTIONS DESIRED HAS BEEN INCLUDED, OR WHEN THE DESIRED NUMBER OF TRIALS HAS BEEN MADE. 0E. THE COEFFICIENTS A IN THE ORTHOGONALIZED SPACE ARE TRANSFORMED INTO THE COEFFICIENTS C OF THE ORIGINAL MODEL. THE CONSTANT C(0) IS ALSO CALCULATED. 0F. ALL INTENSITY MEASUREMENTS IN =NFILEA= ARE CORRECTED FOR THE CAMEL AND SPHERICAL ABSORPTION CORRECTIONS AND PUT ONTO =NFILEB=. TBAR, THE ABSORPTION AVERAGED PATH LENGTH FOR A SPHERICAL CRYSTAL IS ALSO CALCULATED. 0 0HOW TO CHOOSE THE REFLECTIONS FOR THE CAMEL DATA COLLECTION ------------------------------------------------------------- 0 TWO QUESTIONS OF VITAL IMPORTANCE FOR THE SUCCESS OF THE CAMEL ARE... 0A. WHAT BASIC OR PARENT REFLECTIONS TO CHOOSE... B. WHAT VALUES OF PSIMIN,DELPSI,PSIMAX TO CHOOSE... 0OUR ACCUMULATED WISDOM ( PREJUDICE) TO DATE SHOWS THAT THE FOLLOWING GUIDE LINES SHOULD BE FOLLOWED. THE BASIC OBJECTIVE IS TO COVER THE ANGULAR SPACE (IN OMEGA,TWO-THETA,CHI AND PHI) OF THE STANDARD DATA COLLECTION AS THOROUGHLY AS POSSIBLE. 01. CHOOSE PARENT REFLECTIONS TO HAVE GENERAL MILLER INDICES HKL TO GIVE THE LARGEST POSSIBLE NUMBER OF EQUIVALENT REFLECTIONS. 02. CHOOSE PARENT REFLECTIONS TO COVER THE RANGE OF TWO-THETA OF THE STANDARD DATA COLLECTION. PARENT REFLECTIONS SHOULD BE IN ROUGHLY EQUALLY SPACED INTERVALS OF TWO THETA. 03. IF YOU WANT TO DO ONLY AN ABSORPTION-ALIGNMENT CORRECTION AVOID CHOOSING THE VERY STRONGEST REFLECTIONS AS PARENT REFLECTIONS. 04. IF YOU WANT AN ABSORPTION-EXTINCTION CORRECTION, DOUBLE THE NUMBER OF PARENT REFLECTIONS, TRYING AT EACH VALUE OF TWO-THETA TO CHOOSE A STRONG (OR VERY STRONG) REFLECTION AND A MEDIUM-WEAK REFLECTION. 05. AVOID USING VERY WEAK REFLECTIONS. 06. THE NUMBER OF MEASUREMENTS NECESSARY DEPENDS ON THE STRENGTH AND ANISOTROPY OF THE ABSORPTION-EXTINCTION-MISALIGNMENT. A WEAKLY ABSORBING- EXTINGUISHING ALMOST SPHERICAL CRYSTAL REQUIRES LESS MEASUREMENTS THAN A HIGHLY ABSORBING-EXTINGUISHING THIN PLATELET. 07. LIKEWISE THE NUMBER OF MEASUREMENTS DEPENDS ON THE IMPROVEMENT IN THE ACCURACY (INDICATED BY THE INTENSITY R VALUES) DESIRED. 08. CRYSTALS OF LOW SYMMETRY WILL REQUIRE MORE PARENT REFLECTIONS, EACH MEASURED WITH A SMALLER DELPSI THAN CRYSTALS OF HIGH SYMMETRY. 09. FOR AN ALIGNED DIFFRACTOMETER AND CRYSTAL, THE GEOMETRY IS SUCH THAT PSI = PSI + 180 (IN DEGREES). HENCE A NORMAL CHOICE FOR PSIMIN IS 0 AND FOR PSIMAX IS 179.99. DO NOT WORRY THAT A SIGNIFICANT PROPORTION OF THE DESIRED MEASURING POSITIONS WILL BE INACCESSIBLE TO THE DIFFRACTOMETER DUE TO MECHANICAL RESTRICTIONS. 010. FOR A MISALIGNED DIFFRACTOMETER AND/OR MISCENTERED CRYSTAL, IT WILL BE NECESSARY TO MAKE MEASUREMENTS IN THE FOUR EQUIVALENT ANGULAR SETTINGS OF AN ALIGNED DIFFRACTOMETER. TWO OF THE FOUR POSITIONS ARE ACHIEVED BY LETTING PSI GO FROM 0 TO 360 DEGREES. THE OTHER TWO REQUIRE SOME OTHER DIFFRACTOMETER DEPENDENT DEVICE. 011. IT MAY BE POSSIBLE IN THE CASE OF CRYSTALS WITH VERY HIGH SYMMETRY WHERE THERE ARE A LARGE NUMBER OF EQUIVALENT REFLECTIONS THAT THE PSI SCANS WOULD BE UNNECESSARY. 012. TRY AND CHOOSE AT LEAST ONE REFLECTION WHICH CONTAINS THE DIRECTIONS OF THE GREATEST ANISOTROPY IN THE ABSORPTION( AND IF POSSIBLE, THE EXTINCTION) 013. THE ABOVE INDICATIONS ARE ALL QUALITATIVE. I WILL TRY AND PRODUCE SOMETHING MORE QUANTITATIVE WHEN THE PROGRAMME IS WORKING WELL. 0 0HOW TO CHOOSE THE VALUES OF THE INPUT PARAMETERS ------------------------------------------------- 0 THE SPHERICAL ABSORPTION CORRECTIONS GIVEN ON =ABSBON= CARDS SHOULD BE FOR A SPHERE OF RADIUS EQUIVALENT TO THE CRYSTAL UNDER STUDY. WE HAVE TRIED THREE PRESCRIPTIONS TO CALCULATE THIS EQUIVALENT RADIUS. 01. THE RADIUS OF A SPHERE OF VOLUME EQUAL TO THE CRYSTAL UNDER STUDY. 0 R=(0.75*VOLUME/PI)**(1/3) 02. THE SEMI-DIMENSION OF A CUBE OF VOLUME EQUAL TO THE CRYSTAL UNDER STUDY. 0 R=(0.125*VOLUME)**(1/3) 03. THE MEAN LINEAR DIMENSION OF THE CRYSTAL. 0ON THE CRYSTALS WE HAVE STUDIED PRESCRIPTION 2 SEEMS TO GIVE THE BEST RESULTS AS JUDGED BY THE ISOTROPIC TEMPERATURE FACTORS OBTAINED AFTER LEAST-SQUARES REFINEMENT OF THE ATOMIC PARAMETERS. 0 0 BLANKS ON THE CAMEL CARD WILL PRODUCE DEFAULT SETTING VALUES WHICH CAN BE USED IN A FIRST RUN OF THE CAMEL AND WILL USUALLY PRODUCE SATISFACTORY RESULTS. IF THE RESULTS ARE SATISFACTORY , IN ANY SUBSEQUENT RERUN OF THE =CAMEL= ON THE THE SAME DATA, REDUCE THE NUMBER OF PAGES PRINTED AND LIMIT THE MAXIMUM VALUES OF THE NUMBER OF FUNCTIONS, NUMBER OF TRIALS AND MAXIMUM H,I,J, K AND L TO THOSE FOUND IN THE SATISFACTORY RUN. THIS WILL SAVE A CONSIDERABLE AMOUNT OF TIME AND SOME MEMORY SPACE. 0 IN CASE OF A PRELIMINARY FIT WHICH IS JUDGED TO BE UNSATISFACTORY IT WILL BE NECESSARY TO CHANGE THE VALUE OF SOME OF THE INPUT PARAMETERS. IN THE FOLLOWING WE ATTEMPT TO EXPLAIN THE EFFECT ON THE FIT , THE R VALUES, MACHINE TIME AND MEMORY SPACE OF CHANGING THE INPUT PARAMETERS. 0A. MAXIMUM NUMBER OF FUNCTIONS EXPECTED IN THE FINAL EXPRESSION. INCREASING THIS PARAMETER WILL CAUSE A SLIGHT INCREASE IN MEMORY SPACE(SPACE FOR THIS IS 3*MAX NUMBER OF FUNCTIONS), AND WILL CAUSE FITTING TO TAKE LONGER IF THE PREVIOUS FIT STOPPED BECAUSE THE MAXIMUM NUMBER OF FUNCTIONS HAD BEEN REACHED. IT WILL ALSO CHANGE THE CONDITION FOR ACCEPTANCE OF A CANDIDATE FUNCTION THUS ALLOWING FUNCTIONS WHICH MAKE A SMALLER CONTRIBUTION TO THE REDUCTION IN THE SUM OF SQUARES TO BE ACCEPTED. THE LATTER EFFECT, TOGETHER WITH THE POSSIBLE INCREASE IN THE TOTAL NUMBER OF FUNCTIONS IN THE FINAL FIT WILL MEAN A BETTER FIT AND LOWER INTENSITY R VALUES. 0B. MAXIMUM ORDER IN THE INTENSITY FUNCTION AND THE TRIGONOMETRIC FUNCTIONS. AN INCREASE IN SOME OR ALL OF THESE VALUES WILL CAUSE AN INCREASE IN MEMORY SPACE WHICH IS DIFFICULT TO PREDICT. SINCE THE NUMBER OF CANDIDATE FUNCTIONS INCREASES, THE MACHINE TIME ALSO INCREASES (LINEARLY WITH THE NUMBER OF CANDIDATE FUNCTIONS). A BETTER FIT IS NOT ASSURED SINCE THE EXTRA CANDIDATE FUNCTIONS MAY BE JUDGED NOT SIGNIFICANT AND HENCE IT IS EASY TO WASTE MACHINE TIME UNNECESSARILY. IT IS WORTH TRYING TO INCREASE A MAXIMUM ORDER IF A PREVIOUS FIT DID NOT REDUCE THE INTENSITY R VALUES SUFFICIENTLY AND FUNCTIONS WERE ACCEPTED WITH THE PREVIOUS MAXIMUM ORDER IN THE PARTICULAR FUNCTION. 0 THE MAXIMUM ORDER IN THE INTENSITY FUNCTION CONTROLS WHETHER AN ABSORPTION OR AN ABSORPTION-EXTINCTION CORRECTION IS CARRIED OUT. ONLY ASK FOR AN ABSORPTION-EXTINCTION CORRECTION IF YOU HAVE MADE THE INTENSITY MEASUREMENTS AS DESCRIBED ABOVE FOR ABSORPTION-EXTINCTION. OTHERWISE THE PROGRAMME WILL ALMOST CERTAINLY BLOW ITS HEAD. IF PSI SCAN MEASUREMENTS HAVE NOT BEEN CARRIED OUT, THERE IS NO INFORMATION ON THE VARIATION WITH OMEGA AND HENCE THE MAXIMUM ORDER IN OMEGA SHOULD BE SET TO ZERO. 0C. ALIGNED - MISALIGNED DIFFRACTOMETER AND CRYSTAL THE ALIGNED OPTION GIVES A CAMCOR OBEYING THE FULL DIFFRACTOMETER SYMMETRY BY LIMITING THE CANDIDATE FUNCTIONS. THIS IS THE NORMAL SITUATION. THE MISALIGNED OPTION GIVES A CAMCOR WITH NO OBSERVABLE SYMMETRY. TO USE THE MISALIGNED OPTION REQUIRES INTENSITY MEASURMENTS IN EACH OF THE FOUR POSSIBLE ANGULAR SETTINGS. THE MISALIGNED OPTION PRODUCES MORE TRIAL FUNCTIONS FOR THE FIT AND HENCE MAY TAKE LONGER. THE MEMORY SPACE WILL BE INCREASED A LITTLE. 0D. MAXIMUM NUMBER OF TRIALS(FUNCTIONS) TO BE MADE FOR THE FIT. AN INCREASE IN THIS PARAMETER HAS NO EFFECT ON MEMORY SPACE BUT CONTROLS DIRECTLY THE MACHINE TIME. IT HAS AN INDIRECT EFFECT ON THE FIT AND INTENSITY R VALUES BY STOPPING THE PROCESS BEFORE THREE CYCLES HAVE BEEN CARRIED OUT OR THE DESIRED PRECISION ATTAINED. 0E. RELATIVE ERROR TOLERATED ON THE SAMPLE FIT. THIS PARAMETER CONTROLS DIRECTLY THE REDUCTION IN THE INTENSITY R VALUES THAT MAY BE OBTAINED, GIVEN A SUFFICIENT NUMBER OF FUNCTIONS TO TRY. HOWEVER ONE SHOULD BE CAREFUL NOT TO OVERFIT. WITH AN OVERFIT THE CAMEL REFLECTIONS WILL HAVE VERY SMALL INTENSITY R VALUES BUT THE ABSORPTION- EXTINCTION CORRECTIONS FOR THE STANDARD DATA WILL BE IN ERROR BY A LARGER AMOUNT. WHAT HAS HAPPENED IS THAT THE FIT NOW TAKES CARE OF THE STATISTICAL VARIATIONS IN THE CAMEL DATA WHICH DO NOT CORRESPOND TO AN ABSORPTION-EXTINCTION EFFECT. IN ORDER TO PASS MORE AND MORE NEARLY THROUGH THE EXPERIMENTAL POINTS, THE CAMCOR MAKES A TREMENDOUS NUMBER OF WIGGLES WHICH PROBABLY HAVE NO PHYSICAL MEANING. WE PREFER A SMOOTHER CURVE WHICH PASSES LESS EXACTLY THROUGH THE DATA. EXAMINATION OF THE =EXPECTED= R VALUES AND =EXPECTED= RESIDUAL SUM OF SQUARES WILL ALLOW THIS SITUATION TO BE DETECTED. THE PARAMETER HAS NO EFFECT ON MEMORY SIZE BUT INCREASES THE MACHINE TIME. 0F. CONTROL PARAMETER FOR FUNCTION CHOICE. INCREASING THIS PARAMETER HAS MUCH THE SAME EFFECT AS INCREASING THE MAXIMUM ORDERS IN THE INTENSITY FUNCTION AND TRIGONOMETRIC FUNCTIONS. THE DIFFERENCE IS THAT INCREASING THE MAXIMUM ORDERS WILL PRODUCE MORE CANDIDATE FUNCTIONS WITH A HIGH ORDER IN ONE OF THE ANGLES (I.E. HIGHER ORDER AXIAL FUNCTIONS) WHEREAS THE CONTROL PARAMETER WILL PRODUCE FUNCTIONS WHERE THE SUM OF THE ORDERS IS HIGHER (MORE MIXED FUNCTIONS). 0G. CORRELATION SELECTION PARAMETER. INCREASING THIS PARAMETER WILL MAKE THE PROGRAMME REFUSE MORE FUNCTIONS WHICH ARE STRONGLY CORRELATED WITH THE BEST LINEAR COMBINATION OF THOSE ALREADY ACCEPTED. THIS HAS NO EFFECT ON MEMORY SIZE, BUT INCREASES THE MACHINE TIME BECAUSE IT IS NOW MORE DIFFICULT TO MAKE A FIT. LIKEWISE IT WILL TEND TO DECREASE THE REDUCTION IN THE SUM OF SQUARES. THE PARAMETER IS USEFUL IN ELIMINATING FUNCTIONS WHICH PRODUCE EXCELLENT VALUES OF THE INTENSITY R VALUES FOR AN UTTERLY NON-PHYSICAL ABSORPTION-EXTINCTION CORRECTION. THE CORRELATION SELECTION PARAMETER IS RELATED TO, BUT IS NOT, THE MULTIPLE CORRELATION COEFFICIENT. 0H. DOWNWEIGHTING FACTOR. A VALUE OF ZERO OF THIS FACTOR LEAVES THE MEAN PARENT INTENSITIES AFTER CORRECTION FREE TO VARY AS THEY LIKE. INCREASING THE VALUE FROM ZERO WILL TIE THE MEAN PARENT CORRECTED INTENSITIES MORE AND MORE DOWN TO THEIR VALUES BEFORE CORRECTION. THIS ENABLES A MORE PHYSICAL RESULT TO BE OBTAINED. THE VALUE OF DOWNWT IS SCALED SO THAT A VALUE OF 1.0 DOUBLES THE ORIGINAL SUM OF SQUARES. 0 0WHAT ABOUT MULTIPLE REFLECTIONS ---- ----- -------- ----------- 0 THIS HAS AS YET(JULY 1976) NEVER BEEN TRIED BUT IT SHOULD BE POSSIBLE TO USE THE PROGRAMME FOR THIS PURPOSE SINCE THE VARIATIONS CAUSED BY THE MULTIPLE REFLECTIONS OBEY THE SYMMETRY OF THE FUNCTIONS USED BY CAMEL. MULTIPLE REFLECTIONS CAUSE SHARP SPIKES ON THE PSI SCAN CURVES. HENCE PSISCANS MEASURED WITH =DELPSI= VERY SMALL WOULD BE NECESSARY FOR THE PROGRAMME TO DISTINGUISH BETWEEN THE RAPIDLY VARYING (DUE TO MULTIPLE REFLECTIONS) AND SLOWLY VARYING (DUE TO ABSORPTION-EXTINCTION) REFLECTION INTENSITIES. THE MAXIMUM ORDERS OF THE FUNCTIONS WOULD HAVE TO BE SET RATHER HIGH. 0 0HOW TO KNOW WHETHER THE CAMEL CORRECTION IS GOOD ------------------------------------------------ 0 STUDY THE INTENSITY R VALUES TO SEE IF THERE HAS BEEN A SUITABLE REDUCTION FOR THE PARENT REFLECTIONS. LOOK AS WELL AT THE INDICES OF THE ACCEPTED FUNCTIONS TO MAKE SURE THAT ONLY SENSIBLE FUNCTIONS HAVE BEEN CHOSEN. E.G. FUNCTIONS A OR B (H0J00) SHOULD NEVER BE PRESENT, ONLY FUNCTIONS A OR B (H0JKL) SHOULD BE PRESENT IF PSI SCANS HAVE NOT BEEN CARRIED OUT, ONLY FUNCTIONS A OR B (0IJKL) SHOULD BE PRESENT IF ONLY AN ABSORPTION CORRECTION IS WANTED. LOOK AS WELL AT THE MEAN PARENT INTENSITIES BEFORE AND AFTER CAMEL CORRECTION. FOR EACH PARENT THE VALUES SHOULD BE ABOUT EQUAL. THE VALUE OF THE CONSTRAINT CONSTANT SHOULD BE APPROXIMATELY 1.0 . STUDY ALSO THE EXPECTED RESIDUAL SUM OF SQUARES (BASED ONLY ON MEASUREMENT ERRORS) AND THE RESIDUAL SUM OF SQUARES. 0 0REFERENCES ---------- 0 FLACK,H.D.(1974).ACTA CRYST.A30,569-573 FLACK,H.D.,MOREAU,J.M. AND PARTHE,E.(1974).ACTA CRYST.B30,820-821 FLACK,H.D.(1975).J.APPL.CRYST.8,520-521 FLACK,H.D.(1977). ACTA CRYST. A ( IN THE PRESS) LAWSON,C.L. AND HANSON.R.J.(1974) SOLVING LEAST SQUARES PROBLEMS, PP 148-157 PRENTICE HALL INC. WIND,H.(1972).PROC. 1972 CERN COMPUTING AND DATA PROCESSING SCHOOL, CERN 72-21,PP53-106. ENDELT *DECK,CAMEL2 ELEMENT 1 2.CAMEL -A 0 0 0A. CARD ORDER SUMMARY FOR =CAMEL= PROGRAMME ---- ----- ------- --- ------- --------- 0 0 0 CAMEL PROGRAMME CALLING CARD 0 ABSBON SPHERICAL ABSORPTION CORRECTIONS 0 PARENT INDICATES FORMS OF REFLECTIONS TO BE USED IN CAMEL 0 END END CARD 0 0***** READS =NFILEA= ***** 0***** WRITES =NFILEB= ***** 0***** =NFILEG= AND =NFILEI= ... SCRATCH FILES 0***** LARGE DATA ARRAY REQUIREMENTS IN WORDS - THIS IS THE =MAXCOR= PARAMETER THIS IS AUTOMATICALLY CONTROLLED BY THE PROGRAMME WHICH ASKS FOR MORE FROM THE SUPERVISOR IF NECESSARY. USES 9* NUMBER OF CAMEL REFLECTIONS + A BIT MORE. 0 1 2.CAMEL -B 0B. CARD FORMATS FOR =CAMEL= PROGRAMME ---------------------------------- 0 0OPERATION CARDS ARE DESCRIBED IN SECTION 2.GENERL-A, AND THEIR FORMATS ARE GIVEN IN SECTION 2.GENERL-B. THE POSITIONING OF THESE CARDS IS DICTATED BY THEIR FUNCTION. 0CAMEL - PROGRAMME CALLING CARD. FORMAT(A2,A4,1X,A2,A4,2I2,I3,6I2,I4,6F7.2) 3 COLS SPECIFIED PUNCHING OR FUNCTION OF THE FIELD 1-5 CAMEL 8-13 COMPOUND IDENTIFICATION CODE 14-15 FOR LIST REFLECTIONS (0 = ONLY THOSE USED BY CAMEL),(1 = ALL), (2 = NONE) 16-17 NUMBER OF MEASUREMENTS OF THE SAME EQUIVALENT REFLECTION NECESSARY TO DEFINE IT AS A MEASUREMENT TO USE IN THE CAMEL (BLANK = 25) 18-20 MAXIMUM NUMBER OF FUNCTIONS EXPECTED IN THE FINAL EXPRESSION (BLANK = 40) 21-22 MAXIMUM ORDER IN THE INTENSITY FUNCTION (=0 MEANS CONSIDER ABSORPTION ONLY, =N MEANS TRY HIGHER POWERS OF EXTINCTION) (BLANK = 0) 23-24 MAXIMUM ORDER IN TRIGONOMETRIC FUNCTIONS OF OMEGA (BLANK= 3) 25-26 MAXIMUM ORDER IN TRIGONOMETRIC FUNCTIONS OF 2-THETA (BLANK=3) 27-28 MAXIMUM ORDER IN TRIGONOMETRIC FUNCTIONS OF CHI (BLANK= 6) 29-30 MAXIMUM ORDER IN TRIGONOMETRIC FUNCTIONS OF PHI (BLANK= 6) 31-32 CRYSTAL AND DIFFRACTOMETER ALIGNMENT (0 = ALIGNED),(1=MISALIGNED) (BLANK=0) 33-36 MAXIMUM NUMBER OF TRIALS (FUNCTIONS) TO BE MADE FOR THE FIT (BLANK= 500) 37-43 RELATIVE ERROR TOLERATED ON THE SAMPLE FIT (BLANK= 0.10) 44-50 CONTROL PARAMETER FOR FUNCTION CHOICE. FUNCTIONS WITH SUM (ORDER/MAX. ORDER) LESS THAN THIS PARAMETER WILL BE TRIED (BLANK = 1.0 ) 51-57 THIS FUNCTION SELECTION PARAMETER ALLOWS THE PROGRAMME TO DECIDE IF A FUNCTION IS TOO STRONGLY CORRELATED WITH THE OTHERS (BLANK = 0.01) 58-64 LINEAR ABSORPTION COEFFICENT IN CM**-1 (BLANK = 30.0) 65-71 CUTOFF. REFLECTIONS WITH INTENSITY LESS THAN CUTOFF*STANDARD DEVIATION ARE NOT USED BY THE CAMEL. (BLANK = 5.0) 72-78 DOWNWEIGHTING FACTOR TO REGULATE THE STRENGTH WITH WHICH THE APPROXIMATE CONSTRAINTS ON THE PARENT REFLECTION INTENSITIES WILL BE ENFORCED. ( BLANK = 0.5) 0ABSBON - SPHERICAL ABSORPTION CORRECTION CARD - REQUIRES ONE FOR EACH ENTRY IN TABLE (TOTAL = 19 CARDS) FORMAT(A2,A4,7X,F4.0,2X,3F10.3) 3 COLS SPECIFIED PUNCHING OR FUNCTION OF THE FIELD 1-6 ABSBON 14-17 THETA. SEE W.L.BOND IN INTERNATIONAL TABLES,VOL 2, PP 291-306 USE TABLE 5.3.6B FOR SPHERE (P302-305). 20-29 ABSORPTION CORRECTION AS LISTED IN TABLE 30-39 VALUE OF ASTAR**-1(DASTAR/D(MU*R)) 40-49 VALUE OF MU*R 0PARENT - MILLER INDICES OF FORMS OF REFLECTIONS FOR CAMEL FORMAT(A2,A4,7X,3I4) 0 COLS SPECIFIED PUNCHING OR FUNCTION OF THE FIELD 1-6 PARENT 14-17 H INDEX OF FORM ( USE REFLECTION INDICES PRINTED 18-21 K INDEX OF FORM ( IN =DATRDN=. THESE MAY BE DIFFERENT 22-25 L INDEX OF FORM ( FROM THOSE IN =DATCO1= 0END - END CARD FORMAT(A2,A4) 3 COLS SPECIFIED PUNCHING OR FUNCTION OF THE FIELD 1-3 END 4-6 BLANK ENDELT