// FO R *IOCS %CARD,TYPEWRITER,DISK) *ONE WORD INTEGERS C STRUCTURE FACTOR PROGRAM PART I. C FOR IBM 1130 R.SHIONO C APRIL 1968 C DIMENSION RCP(6),PRCP(6),AFM(11,51),FM(15) COMMON JCDI,JCDO,JTYP,NDAT COMMON LCYC,NRFM,NPAR,NOBS,LATM,LCEN,LSYM,LTEM,LANM COMMON PRCP DEFINE FILE 1 ( 5000, 52, U, NDAT ) 1 FORMAT ( 3F7.3, 4F7.4 ) 2 FORMAT ( 7F10.4 ) 3 FORMAT ( 4I5, 6F8.4 ) 4 FORMAT ( 3I9,2F9.2,F9.0,I5,2F6.3 ) 5 FORMAT( / 3H A=,F8.3,4H, B=,F8.3,4H, C=,F8.3,7H, COSA=,F7.4, 1 7H, COSB=,F7.4,7H, COSC=,F7.4,9H, LAMBDA=,F7.4 / ) 6 FORMAT ( 3F3.0,2F7.2,2F8.2,F7.2,F3.3,F4.3,I2,1X6F4.2 ) 7 FORMAT (3I4,6F7.2,F5.3,I3,F7.2 ) 8 FORMAT ( 23HSIGMA-S PUNCHED ON CARD ) 9 FORMAT ( 26HHUGHES WEIGHTING, FMIN= F6.1 ) 10 FORMAT ( 22HCRUICKSHANK-S WEIGHTS,5H A=E9.3,5H, B=E9.3, 1 5H, C=E9.3 ) 11 FORMAT ( 27HWEIGHT=1/(SIN THETA/LAMBDA) ) 12 FORMAT (/ 14HCONSTANTS USED / / 8X 6E12.3 // ) 14 FORMAT ( 25HATOMIC SCATTERING FACTORS // 10X 10F8.1 ) 15 FORMAT (// 18HNO. OF REFLEXIONS= I6 // ) C DEFINE I/O DEVICES JCDI=2 JTYP=1 JCDO=2 NDAT=1 RA=0.0 RB=0.0 Q=1.0 C READ CELL CONSTANT CARD READ ( JCDI,1 ) A,B,C,CSAA,CSAB,CSAC,WAVE WRITE ( JTYP,5 ) A,B,C,CSAA,CSAB,CSAC,WAVE D=SQRT(1.+2.*CSAA*CSAB*CSAC-CSAA*CSAA-CSAB*CSAB-CSAC*CSAC) D=1./(D*A*B*C) SNAA=SQRT(1.-CSAA*CSAA) SNAB=SQRT(1.-CSAB*CSAB) SNAC=SQRT(1.-CSAC*CSAC) RCP(1)=D*B*C*SNAA RCP(2)=D*C*A*SNAB RCP(3)=D*A*B*SNAC RCP(4)=(CSAB*CSAC-CSAA)/(SNAB*SNAC) RCP(5)=(CSAC*CSAA-CSAB)/(SNAC*SNAA) RCP(6)=(CSAA*CSAB-CSAC)/(SNAA*SNAB) PRCP(1)=RCP(1)*RCP(1)*.25 PRCP(2)=RCP(2)*RCP(2)*.25 PRCP(3)=RCP(3)*RCP(3)*.25 PRCP(4)=RCP(1)*RCP(2)*RCP(6)*.25 PRCP(5)=RCP(1)*RCP(3)*RCP(5)*.25 PRCP(6)=RCP(2)*RCP(3)*RCP(4)*.25 NRFM=0 C READ CONTROL CARD READ ( JCDI,3 ) JA,JW,JD,JC,CA,CB,CC,CD,CE,CF IF ( JW-1 ) 33, 32, 33 32 CA4=4.0*CA 33 JW=JW+1 GO TO ( 65, 66, 67, 68, 69 ), JW 65 WRITE ( JTYP,8 ) GO TO 69 66 WRITE ( JTYP,9 ) CA GO TO 69 67 WRITE ( JTYP,10 ) CA,CB,CC GO TO 69 68 WRITE ( JTYP,11 ) 69 FCAL=0.0 71 WRITE ( JTYP,12 ) CA,CB,CC,CD,CE,CF 70 AO=0.0 JA=JA+1 GO TO ( 34, 34, 35, 59),JA C ORIGINAL CARD INPUT 34 BO=0.0 AC=0. BC=0. DO 31 I=1,11 DO 31 J=1,51 31 AFM(I,J)=0. C READ ATOMIC SCATTERING FACTOR TABLES I=0 20 I=I+1 READ ( JCDI,2 ) (AFM(I,J),J=1,7 ) IF ( AFM(I,1) ) 21, 21, 22 22 READ ( JCDI,2 ) (AFM(I,J), J=8,51 ) NATSC=I GO TO 20 C END OF F TABLE,START READING REFLEXION DATA 21 JBB=1 WRITE (JTYP,14) (AFM(I,1),I=1,NATSC) QSCL=1.0 C INPUT FROM CARDS GO TO ( 60, 52, 35, 59), JA 60 READ ( JCDI,4 ) IH,IK,IL,FOBS,SIG,Q,ID,RA,RB 53 FH=IH FK=IK FL=IL IF (IH) 25, 23, 25 23 IF (IK) 25, 24, 25 24 IF (IL) 25, 50, 25 25 IF ( Q ) 64, 64, 55 55 IF ( Q-QSCL ) 63, 63, 56 56 QSCL=Q GO TO 63 64 Q=1.0 63 RHO=FH*FH*PRCP(1)+FK*FK*PRCP(2)+FL*FL*PRCP(3)+2.*FH*FK*PRCP(4)+ 1 2.*FK*FL*PRCP(6)+2.*FL*FH*PRCP(5) SINT=SQRT(RHO)*WAVE IF ( SINT-1.0 ) 26, 60, 60 26 BRAG=SINT DO 27 I=2,51 BRAG=BRAG-0.02 IF (BRAG) 28, 28, 27 27 CONTINUE 28 I=I-1 FRAC=(BRAG+0.02)*50. DO 29 K=1,10 29 FM(K)=0. DO 30 K=1,NATSC 30 FM(K)=AFM(K,I)+(AFM(K,I+1)-AFM(K,I))*FRAC 38 GO TO ( 49, 41, 42, 43, 44 ), JW 41 IF (FOBS) 45, 45, 46 45 SIG=0. GO TO 49 46 IF ( FOBS-CA4 ) 47, 47, 48 47 SIG=CA4 GO TO 49 48 SIG=FOBS GO TO 49 42 SIG=SQRT(CA+CB*FOBS+CC*FOBS*FOBS) GO TO 49 43 SIG=SQRT(SQRT(RHO)) GO TO 49 44 SIG=1.0 49 IF ( JD-1 ) 40, 57, 40 57 IF ( ID-1 ) 40, 58, 40 58 SIG=0.0 40 WRITE (1'NDAT) FH,FK,FL,FOBS,FCAL,AO,AC,BO,BC,SIG,Q,ID,RHO, 1 SINT,(FM(K),K=1,10),RA,RB GO TO ( 60, 52, 37, 59), JA C FOURIER INPUT, E CARDS 52 READ (JCDI,7 ) IH,IK,IL,FOBS,FCAL,AO,AC,BO,BC,SINT,ID,SIG GO TO 53 C THE SF-LS OUTPUT CARDS WITH ATOMIC F,S 35 Q=1.0 DO 36 K=1,10 36 FM(K)=0.0 AO=0.0 BO=0.0 37 READ (JCDI,6 ) FH,FK,FL,FOBS,FCAL,AC,BC,SIG,SINT,RHO,ID, 1 (FM(K),K=1,6 ) IF ( FH ) 38, 39, 38 39 IF ( FK ) 38, 51, 38 51 IF ( FL ) 38, 50, 38 50 FH=999. WRITE ( 1'NDAT) FH,FK,FL,FOBS,FCAL,AO,AC,BO,BC,SIG,Q,ID,RHO, 1 SINT,(FM(K),K=1,10),RA,RB NSCL=QSCL NREF=NDAT-2 WRITE ( JTYP,15 ) NREF 59 CALL LINK (SF2 ) END // DU P *DUMP WS CD SF1 // JO B // FO R *IOCS %CARD,DISK,TYPEWRITER) *ONE WORD INTEGERS C STRUCTURE FACTOR LEAST SQUARES REFINEMENT PROGRAM C APRIL 1968 C DIMENSION TS(3,24), IS(2,3,24) DIMENSION HJ(6),H(3),HHJ(6) DIMENSION FM(10) DIMENSION PRCP(6) DIMENSION ANM(50), IANM(50), X(50), Y(50), Z(50) DIMENSION BETA(6,50), AOCP(50), KI(500), JSF(50) DIMENSION DADAI(50), DBDAI(50) DIMENSION DADX(3,50), DBDX(3,50), DADB(6,50), DBDB(6,50) DIMENSION DFX(3),DFB(7) DIMENSION XX(9,50), BB(35,50) DIMENSION JPT(50),KIR(50) COMMON JCDI,JCDO,JTYP,NDAT COMMON LCYC,NRFM,NPAR,NOBS,LATM,LCEN,LSYM,LTEM,LANM COMMON PRCP,SCL,SCLR,DMPS,DMPO,DMPP,DMPT COMMON SS1,SS2,SS3,SS4,SS5,SUMD1,SUMD2,SUMF1,SUMF2 COMMON SUMD3,SUMF3,SUMD4,SUMF4 COMMON XX,BB,ANM,IANM,X,Y,Z,BETA,AOCP,KI,JSF,TS,IS COMMON JPT,KIR DEFINE FILE 1( 5000, 52, U, NDAT ) 100 FORMAT (10I5 ) 101 FORMAT ( F11.6,2I2,F11.6,2I2,F11.6,2I2 ) 102 FORMAT ( A4,A2,3X F9.6,4F9.6,14X, I2 ) 103 FORMAT ( 8F9.6 ) 104 FORMAT ( 80I1 ) 105 FORMAT ( 3I4, 3X 6F8.2 ) 120 FORMAT ( 25HNO. OF PARAMETERS REFINED I4 / ) 121 FORMAT ( 12HNO. OF ATOMS I5,19H, NO. OF SYMMETRIES I5 /) 122 FORMAT (21HDAMP FACTORS, SCALE F4.2,8H, OV. T. F4.2,7H, P.P. F4.2 1 ,7H, T.P. F4.2 / ) 123 FORMAT (17HPARTIAL STRUCTURE /) IF ( NRFM ) 209, 209, 207 209 READ (JCDI,100 ) LCEN,LSYM,LTEM READ ( JCDI,100 ) LCYC,LATM,LANM LANM=LANM+1 READ (JCDI,103 ) DMPS,DMPO,DMPP,DMPT C READ SYMMETRY CARDS READ ( JCDI,101 ) ((TS(I,J),(IS(K,I,J),K=1,2),I=1,3),J=1,LSYM) READ ( JCDI,103 ) SCL WRITE (JTYP,121) LATM,LSYM GO TO ( 232, 233), LANM 233 WRITE (JTYP,123) C ATOMIC PARAMETERS IN TWO CARDS 232 DO 200 I=1,LATM READ ( JCDI,102 ) ANM(I),IANM(I),ASF,AOCP(I),X(I),Y(I),Z(I),JPT(I) JSF(I)=ASF 200 READ ( JCDI,103 ) ( BETA(K,I),K=1,6 ) C CONVERT ISOTROPIC TO ANISOTROPIC TEMP. FACTORS IF ( LTEM ) 203, 203, 201 201 DO 202 I=1,LATM IF ( BETA(2,I) ) 216, 216, 202 216 TFI=BETA(1,I) DO 217 K=1,6 217 BETA(K,I)=TFI*PRCP(K) 202 CONTINUE 203 NP=10*LATM NPAR=0 IF ( LCYC ) 214, 214, 206 214 LCYC=-1 GO TO 215 206 READ (JCDI,104 ) ( KI(I),I=1,NP ) C SET UP THE REFINEMENT INDICATORS FOR EACH ATOM DO 222 I=1,LATM KIR(I)=1 KK=I*10-9 K1=0 DO 219 K=1,10 K1=K1+KI(K K) 219 KK=KK+1 IF ( K1 ) 218, 218, 222 218 KIR(I)=0 222 CONTINUE IF ( DMPP ) 234, 234, 235 234 DMPP=0.75 235 IF ( DMPT ) 236, 236, 237 236 DMPT=0.75 237 WRITE (JTYP, 122 ) DMPS,DMPO,DMPP,DMPT DO 208 I=1,NP 208 NPAR=NPAR+KI(I) WRITE ( JTYP, 120 ) NPAR C FEED OUT THE LAST CARD 215 READ ( JCDI, 104 ) C START A CYCLE OF REFINEMENT 207 NRFM=NRFM+1 SCLR=1.0/SCL C CLEAR THE SUM AREA SS1=0.0 SS2=0.0 SS3=0.0 SS4=0.0 SS5=0.0 SUMD1=0.0 SUMD2=0.0 SUMF1=0.0 SUMF2=0.0 SUMD3=0.0 SUMD4=0.0 SUMF3=0.0 SUMF4=0.0 DO 205 I=1,LATM DO 204 K=1,9 204 XX(K,I)=0.0 DO 205 K=1,35 205 BB(K,I)=0.0 NDAT=1 399 READ ( 1'NDAT ) H(1),H(2),H(3),FOBS,FCAL,AO,AC,BO,BC,SIG,Q,ID,RHO, 1 SINT, (FM(K),K=1,10 ), RA,RB IF ( H(1)-999. ) 210, 211, 211 210 DO 212 I=1,LATM DADAI(I)=0.0 DBDAI(I)=0.0 DO 213 K=1,3 DADX(K,I)=0.0 213 DBDX(K,I)=0.0 DO 212 K=1,6 DADB(K,I)=0.0 212 DBDB(K,I)=0.0 C START LOOP THROUGH SYMMETRY DO 300 J=1,LSYM C STORE TRANSFORMED INDICES TSL=0.0 DO 303 I=1,3 HJ(I)=0.0 TSL=TSL+H(I)*TS(I,J) DO 302 K=1,3 DO 301 L=1,2 M=IS(L,K,J) IF ( M-I ) 305, 306, 305 306 HJ(I)=HJ(I)+H(K) GO TO 301 305 IF ( M+I) 301, 304, 301 304 HJ(I)=HJ(I)-H(K) 301 CONTINUE 302 CONTINUE 303 CONTINUE C PRODUCTS OF TRANSFORMED INDICES HHJ(1)=HJ(1)*HJ(1) HHJ(2)=HJ(2)*HJ(2) HHJ(3)=HJ(3)*HJ(3) HHJ(4)=2.0*HJ(1)*HJ(2) HHJ(5)=2.0*HJ(1)*HJ(3) HHJ(6)=2.0*HJ(2)*HJ(3) DO 310 I=1,LATM CALL PATCH (I,TSL,HJ,HHJ ) HX=TSL+HJ(1)*X(I)+HJ(2)*Y(I)+HJ(3)*Z(I) COSIJ=COS(6.28318531*HX) SINIJ=SIN(6.28318531*HX) LBMX=1 IF ( BETA(2,I) ) 311, 311, 315 315 LBMX=2 HHB=0.0 DO 313 K=1,6 313 HHB=HHB+HHJ(K)*BETA(K,I) EXPIJ=EXP(-HHB) COSIJ=COSIJ*EXPIJ SINIJ=SINIJ*EXPIJ C IF ADD OR SUBTRACT THIS ATOM 311 IF ( JPT(I) ) 314, 314, 356 356 COSIJ=-COSIJ SINIJ=-SINIJ 314 DADAI(I)=DADAI(I)+COSIJ IF ( LCYC ) 320, 320, 317 317 DO 316 K=1,3 316 DADX(K,I)=DADX(K,I)+HJ(K)*SINIJ GO TO ( 320, 321), LBMX 321 DO 323 K=1,6 323 DADB(K,I)=DADB(K,I)+HHJ(K)*COSIJ C BYPASS THE REST IF CENTROSYMMETRIC 320 IF ( LCEN ) 310, 310, 324 324 DBDAI(I)=DBDAI(I)+SINIJ IF ( LCYC ) 310, 310, 318 318 DO 325 K=1,3 325 DBDX(K,I)=DBDX(K,I)+HJ(K)*COSIJ GO TO ( 310, 326 ), LBMX 326 DO 328 K=1,6 328 DBDB(K,I)=DBDB(K,I)+HHJ(K)*SINIJ 310 CONTINUE 300 CONTINUE GA=0.0 GB=0.0 DO 347 I=1,LATM II=JSF(I) FI=FM(II) TFI=1.0 LBMX=1 IF ( BETA(2,I) ) 340, 340, 341 340 TFI=EXP(-BETA(1,I)*RHO ) LBMX=0 341 FTAT=FI*TFI*AOCP(I) FTCOS=FTAT*DADAI(I) GA=GA+FTCOS IF ( LCYC ) 346, 346, 319 319 IF ( KIR(I) ) 346, 346, 357 357 DADAI(I)=FI*TFI*DADAI(I) PIFI=-6.28318531*FTAT DO 342 K=1,3 342 DADX(K,I)=PIFI*DADX(K,I) IF ( LBMX ) 344, 344, 343 343 DO 345 K=1,6 345 DADB(K,I)=-FTAT*DADB(K,I) GO TO 346 344 DADB(1,I)=-RHO*FTCOS C COMPUTE B AND ITS DERIVATIVES 346 IF ( LCEN ) 347, 347, 348 348 FTSIN=FTAT*DBDAI(I) GB=GB+FTSIN IF ( LCYC ) 347, 347, 329 329 IF ( KIR(I) ) 347, 347, 358 358 DBDAI(I)=FI*TFI*DBDAI(I) PIFI=-PIFI DO 349 K=1,3 349 DBDX(K,I)=PIFI*DBDX(K,I) IF ( LBMX ) 350, 350, 351 351 DO 352 K=1,6 352 DBDB(K,I)=-FTAT*DBDB(K,I) GO TO 347 350 DBDB(1,I)=-RHO*FTSIN 347 CONTINUE C END OF ATOM LOOP C NEW OR PARTIAL CALCULATUON GO TO ( 353, 354 ), LANM 353 AC=0.0 BC=0.0 354 IF ( LCEN ) 370, 370, 371 370 GA=GA+GA+AC AC=GA CA=SIGN(1.0,GA) CB=0.0 FCAL=ABS(AC) BC=0.0 GO TO 374 371 GA=GA+AC GB=GB+BC FCAL=SQRT(GA*GA+GB*GB) AC=GA BC=GB IF ( FCAL ) 373, 372, 373 372 CA=0.0 CB=0.0 GO TO 374 373 CA=GA/FCAL CB=GB/FCAL 374 CALL DATSW(0,JJ) SFOBS=SCL*FOBS SIG=SIG*SCL AO=SFOBS*CA BO=SFOBS*CB DELF=SFOBS-FCAL CALL RSETW(SFOBS,FCAL,AC,BC,SIG,SINT,ID) IF ( SIG ) 336, 336, 335 335 WGT=1.0/(SIG*SIG) GO TO 337 336 WGT=0.0 337 WDEL=WGT*DELF FCALK=FCAL*SCL RHOCL=-RHO*FCAL SS1=SS1+WGT*FCALK*FCALK SS2=SS2+WGT*FCALK*RHOCL SS3=SS3+WGT*RHOCL*RHOCL SS4=SS4+WDEL*FCALK SS5=SS5+WDEL*RHOCL IF ( ID ) 360, 360, 361 360 SUMD1=SUMD1+ABS(DELF) SUMF1=SUMF1+SFOBS SUMD2=SUMD2+WDEL*DELF SUMF2=SUMF2+WGT*SFOBS*SFOBS GO TO 338 C FOR UNOBSERVED REFLEXIONS ONLY 361 SUMD3=SUMD3+ABS(DELF) SUMF3=SUMF3+SFOBS SUMD4=SUMD4+WDEL*DELF SUMF4=SUMF4+WGT*SFOBS*SFOBS 338 IF ( LCYC ) 229, 229, 339 C SET UP THE NORMAL EQUATION 339 IF ( WGT ) 230, 230, 322 322 DO 330 I=1,LATM IF ( KIR(I) ) 330, 330, 240 240 DAF=CA*DADAI(I)+CB*DBDAI(I) DO 331 K=1,3 331 DFX(K)=CA*DADX(K,I)+CB*DBDX(K,I) IF ( BETA(2,I) ) 332, 332, 333 332 DFB(1)=CA*DADB(1,I)+CB*DBDB(1,I) GO TO 226 333 DO 334 K=1,6 334 DFB(K)=CA*DADB(K,I)+CB*DBDB(K,I) 226 XX(1,I)=XX(1,I)+DFX(1)*DFX(1)*WGT XX(2,I)=XX(2,I)+DFX(1)*DFX(2)*WGT XX(3,I)=XX(3,I)+DFX(1)*DFX(3)*WGT XX(4,I)=XX(4,I)+DFX(2)*DFX(2)*WGT XX(5,I)=XX(5,I)+DFX(2)*DFX(3)*WGT XX(6,I)=XX(6,I)+DFX(3)*DFX(3)*WGT XX(7,I)=XX(7,I)+DFX(1)*WDEL XX(8,I)=XX(8,I)+DFX(2)*WDEL XX(9,I)=XX(9,I)+DFX(3)*WDEL BB(1,I)=BB(1,I)+DAF*DAF*WGT BB(2,I)=BB(2,I)+DAF*DFB(1)*WGT BB(8,I)=BB(8,I)+DFB(1)*DFB(1)*WGT IF ( BETA (2,I) ) 220, 220, 221 221 DO 223 K=2,6 223 BB(K+1,I)=BB(K+1,I)+DAF*DFB(K)*WGT DO 224 K=2,6 224 BB(K+7,I)=BB(K+7,I)+DFB(1)*DFB(K)*WGT K1=14 DO 225 K=2,6 DO 225 KK=K,6 BB(K1,I)=BB(K1,I)+DFB(K)*DFB(KK)*WGT 225 K1=K1+1 220 BB(29,I)=BB(29,I)+DAF*WDEL BB(30,I)=BB(30,I)+DFB(1)*WDEL IF ( BETA(2,I) ) 330, 330, 227 227 K1=31 DO 228 K=2,6 BB(K1,I)=BB(K1,I)+DFB(K)*WDEL 228 K1=K1+1 330 CONTINUE C END OF ATOM LOOP 230 GO TO ( 231, 399 ), JJ 231 IH=H(1) IK=H(2) IL=H(3) WRITE (JTYP,105 ) IH,IK,IL,SFOBS,FCAL,AO,AC,BO,BC GO TO 399 C WRITE OUTPUT ONLY THE FINAL CYCLE 229 NDAT=NDAT-1 FOBS=SFOBS WRITE (1'NDAT) H(1),H(2),H(3),FOBS,FCAL,AO,AC,BO,BC,SIG,Q,ID, 1 RHO,SINT,(FM(K),K=1,10),RA,RB GO TO 230 C END OF ALL REFLEXIONS 211 NDAT=NDAT-1 NOBS=NDAT-1 WRITE (1'NDAT) H(1),H(2),H(3),FOBS,FCAL,AO,AC,BO,BC,SIG,Q,ID, 1 RHO, SINT,(FM(K),K=1,10) C END OF ONE CYCLE LCYC=LCYC-1 IF ( LCYC ) 422, 402, 402 422 LCYC=LCYC+2 C GO TO CALCULATE AGREEMENT CALL LINK( SF4 ) C GO TO SOLVE SHIFTS 402 CALL LINK (SF3 ) END // DU P *DUMP WS CD SF2 // JO B // FO R *IOCS %CARD,TYPEWRITER,DISK) *ONE WORD INTEGERS C LEAST SQUARES PARAMETER SHIFTS CALCULATION C THIS PART SOLVES THE PARAMETER SHIFTS C SF3 C DIMENSION TS(3,24),IS(2,3,24) DIMENSION PRCP(6),DANT(6) DIMENSION ANM(50),IANM(50),X(50),Y(50),Z(50) DIMENSION BETA(6,50),AOCP(50),KI(500),JSF(50) DIMENSION XX(9,50),BB(35,50) DIMENSION AA(7,7),AB(7),ASH(7) DIMENSION DFDX(3,50),DBDX(3,50) DIMENSION JPT(50),KIR(50) COMMON JCDI,JCDO,JTYP,NDAT COMMON LCYC,NRFM,NPAR,NOBS,LATM,LCEN,LSYM,LTEM,LANM COMMON PRCP,SCL,SCLR,DMPS,DMPO,DMPP,DMPT COMMON SS1,SS2,SS3,SS4,SS5,SUMD1,SUMD2,SUMF1,SUMF2 COMMON SUMD3,SUMF3,SUMD4,SUMF4 COMMON XX,BB,ANM,IANM,X,Y,Z,BETA,AOCP,KI,JSF,TS,IS COMMON JPT,KIR DEFINE FILE 1 (5000, 52, U,NDAT ) C 102 FORMAT ( A4,A2,3X,F9.6,4F9.6 ) 103 FORMAT ( 8F9.6 ) 104 FORMAT ( / 37HTEMP. FACTOR IS NOT POSITIVE DEFINITE / ) 105 FORMAT ( // 7H***** , 12HCYCLE NUMBER I4, 7H ***** / ) 106 FORMAT (/16X1HX,9X1HY,9X1HZ,9X1HM,7X6HB(B11),5X3HB22,7X3HB33, 1 7X3HB12,7X3HB13,7X3HB23 / ) 107 FORMAT (/ 53HQUAD. MEAN ERROR SQRT(SUM(W*(FO-FC)**2)/(NOBS-NPAR))= 1 5XE12.4 /) 109 FORMAT (/ 28HFOR OBSERVED REFLEXIONS ONLY /) 110 FORMAT ( 2X5HSHIFT,3X10F10.5 ) 111 FORMAT ( // A4, A2 / ) 112 FORMAT (/7HSUM(FO),5X1H=E12.4,3X7HSUM(DF)5X1H=,E12.4,11X3HR= F7.3 1 //13HSUM(W*FO**2)=E12.4,3X13HSUM(W*DF**2)=E12.4,3X11HWEIGHTED R= 2 F7.3 /) 113 FORMAT (/ 6HSCALE=,F6.3,14H, SCALE SHIFT= F6.3, 1 20H, OVERALL B SHIFT= F6.3 / ) 114 FORMAT (/ 18HFOR ALL REFLEXIONS /) 115 FORMAT (2X6HE.S.D.2X10F10.5 ) 116 FORMAT (2X3HNEW,5X10F10.5 ) C D=SS1*SS3-SS2*SS2 DSL=(SS4*SS3-SS5*SS2)/D*DMPS DTO=((SS1*SS5-SS2*SS4)/D-SS5/SS3)*DMPO VAR=SQRT(SUMD2/FLOAT(NOBS-NPAR) ) WRITE ( JTYP, 105 ) NRFM WRITE (JTYP,107 ) VAR DO 416 I=1,6 416 DANT(I)=DTO*PRCP(I) DO 415 I=1,LATM II=1 DO 405 J=1,3 AB(J)=XX(J+6,I) DO 405 K=J,3 AA(J,K)=XX(II,I) 405 II=II+1 JJ=10*I-9 DO 417 J=1,3 IF ( KI(JJ) ) 418, 418, 417 418 AB(J)=0.0 DO 419 K=1,3 AA(K,J)=0.0 419 AA(J,K)=0.0 AA(J,J)=1.0 417 JJ=JJ+1 DO 406 J=1,2 DO 406 K=J,3 406 AA(K,J)=AA(J,K) CALL MATV(AA,AB,ASH,3 ) C SHIFTS DO 407 J=1,3 IF ( ASH(J) ) 439, 438, 439 438 DFDX(J,I)=0.0 DBDX(J,I)=0.0 GO TO 407 439 DFDX(J,I)=ASH(J)*DMPP DBDX(J,I)=VAR*SQRT(AA(J,J) ) 407 CONTINUE II=1 DO 408 J=1,7 AB(J)=BB(J+28,I) DO 408 K=J,7 AA(J,K)=BB(II,I) 408 II=II+1 DO 409 J=1,6 DO 409 K=J,7 409 AA(K,J)=AA(J,K) C RESET UNVARIED PARAMETERS JJ=10*I-6 DO 410 J=1,7 IF ( KI(JJ) ) 411, 411, 410 411 AB(J)=0.0 DO 412 K=1,7 AA(J,K)=0.0 412 AA(K,J)=0.0 AA(J,J)=1.0 410 JJ=JJ+1 CALL MATV(AA,AB,ASH,7 ) DO 414 J=1,7 IF ( ASH(J) ) 426, 413, 426 413 BB(J,I)=0.0 BB(J+7,I)=0.0 GO TO 414 426 BB(J,I)=ASH(J)*DMPT BB(J+7,I)=VAR*SQRT(AA(J,J) ) 414 CONTINUE IF ( KI(10*I-6) ) 428, 428, 427 427 BB(1,I)=ASH(1)*DMPT-AOCP(I)*DSL/SCLR 428 IF ( BETA(2,I) ) 423, 423, 424 423 IF ( KI(10*I-5) ) 415, 415, 429 429 BB(2,I)=BB(2,I)+DTO GO TO 415 424 DO 425 J=1,6 IF ( BB(J+1,I) ) 422, 425, 422 422 BB(J+1,I)=BB(J+1,I)+DANT(J) 425 CONTINUE 415 CONTINUE NEGT=0 WRITE (JTYP,109 ) R1=SUMD1/SUMF1 R2=SQRT(SUMD2/SUMF2) WRITE (JTYP,112 ) SUMF1,SUMD1,R1,SUMF2,SUMD2,R2 SUMD1=SUMD1+SUMD3 SUMD2=SUMD2+SUMD4 SUMF1=SUMF1+SUMF3 SUMF2=SUMF2+SUMF4 R1=SUMD1/SUMF1 R2=SQRT(SUMD2/SUMF2) WRITE (JTYP,114) WRITE (JTYP,112 ) SUMF1,SUMD1,R1,SUMF2,SUMD2,R2 SCLI=SCL DSL=-DSL/(SCLR*(SCLR+DSL) ) SCL=SCLI+DSL WRITE ( JTYP, 113 ) SCLI,DSL,DTO WRITE ( JCDO, 103 ) SCL WRITE ( JTYP, 106 ) DO 421 I=1,LATM WRITE ( JTYP,111 ) ANM(I),IANM(I) X(I)=X(I)+DFDX(1,I) Y(I)=Y(I)+DFDX(2,I) Z(I)=Z(I)+DFDX(3,I) AOCP(I)=AOCP(I)+BB(1,I) DO 420 J=1,6 ASH(J)=BETA(J,I) 420 BETA(J,I)=BETA(J,I)+BB(J+1,I) ASF=JSF(I) CALL RESTX( I,X,Y,Z) CALL RESTB (I,BETA) IF ( BETA(2,I) ) 401, 404, 401 404 IF ( BETA(1,I) ) 403, 402, 402 403 BETA(1,I)=0.001 GO TO 435 C ANISOTROPIC TEMPERATURE FACTOR 401 DO 430 K=1,3 IF ( BETA(K,I) ) 434, 430, 430 430 CONTINUE IF (BETA(1,I)*BETA(2,I)-BETA(4,I)*BETA(4,I) ) 434, 431, 431 431 IF (BETA(1,I)*BETA(3,I)-BETA(5,I)*BETA(5,I) ) 434, 432, 432 432 IF ( BETA(2,I)*BETA(3,I)-BETA(6,I)*BETA(6,I) ) 434, 433, 433 433 IF ( BETA(1,I)*BETA(2,I)*BETA(3,I)+(BETA(4,I)*BETA(5,I)*BETA(6,I)) 1 *2.0-BETA(1,I)*BETA(6,I)**2-BETA(2,I)*BETA(5,I)**2- 2 BETA(3,I)*BETA(4,I)**2 ) 434, 402, 402 C TEMPERATURE FACTOR NOT POSITIVE DEFINITE 434 DO 445 K=1,6 445 BETA(K,I)=ASH(K) 435 WRITE (JTYP,104 ) NEGT=NEGT+1 402 WRITE ( JCDO,102 ) ANM(I),IANM(I),ASF,AOCP(I),X(I),Y(I),Z(I) WRITE ( JCDO,103 ) (BETA(K,I),K=1,6 ) IF ( BETA(2,I) ) 437, 436, 437 C ISOTROPIC 436 WRITE ( JTYP,110) (DFDX(J,I),J=1,3), (BB(J,I),J=1,2 ) WRITE (JTYP,116) X(I),Y(I),Z(I),AOCP(I),BETA(1,I) WRITE ( JTYP,115 ) (DBDX(J,I),J=1,3), (BB(J+7,I),J=1,2 ) GO TO 421 437 WRITE ( JTYP,110 ) (DFDX(J,I),J=1,3), (BB(J,I),J=1,7 ) WRITE (JTYP,116) X(I),Y(I),Z(I),AOCP(I),(BETA(K,I),K=1,6) WRITE (JTYP,115 ) (DBDX(J,I),J=1,3), (BB(J+7,I),J=1,7 ) 421 CONTINUE IF ( NEGT ) 440, 440, 441 441 GO TO 440 440 CALL LINK (SF2 ) END // DU P *DUMP WS CD SF3 *ONE WORD INTEGERS C SUBROUTINE TO INVERT A MATRIX AND SOLVE THE SHIFTS SUBROUTINE MATV ( A,B,ANS,N ) DIMENSION A(7,7),B(7),ANS(7) DO 150 K=1,N IF ( ABS(A(K,K) )-0.005 ) 150, 150, 151 151 ADIV=1.0/A(K,K) DO 115 J=1,N 115 A(K,J)=A(K,J)*ADIV DO 140 I=1,N IF ( I-K ) 116, 140, 116 116 DO 130 J=1,N IF ( J-K ) 117, 130, 117 117 A(I,J)=A(I,J)-A(I,K)*A(K,J) 130 CONTINUE A(I,K)=-ADIV*A(I,K) 140 CONTINUE A(K,K)=ADIV 150 CONTINUE DO 160 I=1,N ANS(I)=0.0 DO 155 J=1,N 155 ANS(I)=ANS(I)+B(J)*A(I,J) 160 CONTINUE RETURN END *DUMP WS CD MATV *ONE WORD INTEGERS C A SUBROUTINE TO TRANSFORM THE INDICES SUBROUTINE PATCH(I,TSL,HJ,HHJ) DIMENSION HJ(6),HHJ(6) RETURN END // DU P *DUMP WS CD PATCH *ONE WORD INTEGERS C A SUBROUTINE TO RESET THE TEMP. FACTORS SUBROUTINE RESTB(I,BETA) DIMENSION BETA(6,50) RETURN END // DU P *DUMP WS CD RESTB *ONE WORD INTEGERS C A SUBROUTINE TO REST POSITIONAL PARAMETERS SUBROUTINE RESTX(I,X,Y,Z) DIMENSION X(50),Y(50),Z(50) RETURN END // DU P *DUMP WS CD RESTX *ONE WORD INTEGERS C A SUBROUTINE TO MODIFY INDICES FOR A SPECIAL POSITION ETC. SUBROUTINE PATCH(I,TSL,HJ,HHJ ) DIMENSION HJ(6),HHJ(6) RETURN END // DU P *DUMP WS CD PATCH *ONE WORD INTEGERS C A SUBROUTINE TO RESET THE TEMPERATURE PARAMETERS SUBROUTINE RESTB (I,BETA) DIMENSION BETA(6,50) RETURN END // DU P *DUMP WS CD RESTB *ONE WORD INTEGERS C A SUBROUTINE TO RESET XYZ PARAMETERS FOR A SPECIAL POSITIONS ETC. SUBROUTINE RESTX (I,X,Y,Z) DIMENSION X(50),Y(50),Z(50) RETURN END // DU P *DUMP WS CD RESTX // AS M * DUMMY SUBROUTINE RSETW ENT RSETW RSETW DC * RETURN ADDRESS MDX L RSETW,7 SEVEN PARAMETERS BSC I RSETW END // DU P *DUMP WS CD RSETW // AS M * DUMMY SUBROUTINE PATCH ENT PATCH PATCH DC * RETURN ADDRESS MDX L PATCH,4 FOUR PARAMETERS BSC I PATCH END // DU P *DUMP WS CD PATCH // JO B // FO R *IOCS %CARD,TYPEWRITER,DISK) *ONE WORD INTEGERS C STRUCTURE FACTOR PROGRAM CALCULATE AGREEMENT INDICES C TERMINATE JOB AND PRINT OUT VARIOUS STATISTICS C MAY 1968 C DIMENSION MOBS(11),MUNO(11),WDOBS(11),WDUNO(11) DIMENSION MOSN(11),MUSN(11),WDOS(11),WDUS(11) DIMENSION NHKL(11),DHKL(11),SHKL(11),NKLS(11),DKLS(11),SKLS(11) DIMENSION NHKLS(11),DHKLS(11),SHKLS(11) DIMENSION FM(10), IFM(10) DIMENSION X(4) DIMENSION PRCP(6) COMMON JCDI,JCDO,JTYP,NDAT COMMON NC, NRFM,NPAR,NOBS,LATM,LCEN,LSYM,LTEM,LANM COMMON PRCP,SCL,SCLR,DAMP DEFINE FILE 1 ( 5000, 52, U, NDAT ) 10 FORMAT (/14HNO. REFLEXIONS,7X11I9 ) 11 FORMAT (/ 14HAVER. W*DELTSQ, 7X 11F9.3 / ) 12 FORMAT (// 13HF VALUE UP TO, 14X3H10.,6X3H20.,6X3H30.,6X3H40., 1 6X3H50.,6X3H60.,6X3H70.,6X3H80.,6X3H90.,5X4H100.,9H OVER 100 / ) 13 FORMAT (// 16HSINE THETA UP TO, 11X3H0.1,6X3H0.2,6X3H0.3,6X 1 3H0.4,6X3H0.5,6X3H0.6,6X3H0.7,6X3H0.8,6X3H0.9,6X3H1.0 / ) 14 FORMAT ( // 12HEND SF/SF-LS // ) 15 FORMAT ( 3I4,6F7.2,F5.3,I3,F7.2,I2 ) 16 FORMAT ( 3I3,2F7.2, 2F8.2, F7.2,I3,I4,I2,1X,6I4 ) 20 FORMAT ( ///39HDISAGREEMENT INDICES FOR VARIOUS GROUPS / ) 21 FORMAT (/ 27X3HHKL,6X3HHK0,6X3H0KL,6X3HH0L,6X3HH00,6X3H0K0, 1 6X3H00L,6X3HALL / ) 23 FORMAT (/ 8HR FACTOR , 13X 10F9.3 / ) 24 FORMAT (// 27X 3HEEE,6X3HEEO,6X3HEOE,6X3HOEE,6X3HEOO,6X3HOEO, 1 6X3HOOE,6X3HOOO / ) 25 FORMAT (// 9HOBS. ONLY,4X8HSUM FOBS,5X8HSUM FCAL,5X6HSCALE, , 1 3X11HUNOBS. ONLY,4X8HSUM FOBS,5X8HSUM FCAL,5X11HTOTAL SCALE // 2 9XF13.2,F13.2,F10.3,14X F13.2,F13.2,6X F10.3 // ) DO 110 I=1,11 NHKL(I)=0 DHKL(I)=0.0 SHKL(I)=0.0 NHKLS(I)=0 DHKLS(I)=0. SHKLS(I)=0. NKLS(I)=0 DKLS(I)=0.0 SKLS(I)=0.0 MOBS(I)=0 MUNO(I)=0 MOSN(I)=0 MUSN(I)=0 WDOBS(I)=0.0 WDUNO(I)=0.0 WDOS(I)=0.0 110 WDUS(I)=0.0 SUM1=0.0 SUM2=0.0 SUM3=0.0 SUM4=0.0 DSIN=0.1 DSTF=10.0 CALL DATSW ( 2, LSW2 ) NDAT=1 111 READ (1'NDAT) (X(I),I=1,3),YO,YC,AO,A,BO,B,SIGYO,X(4),ID,RHO, 1 SINT,(FM(I),I=1,10) IF ( X(1)-999.0 ) 162, 113, 162 162 IF ( X(1) ) 150, 151, 150 151 IF ( X(2) ) 153, 152, 153 C 00L 152 IREF=7 GO TO 163 153 IF ( X(3) ) 155, 154, 155 154 IREF=6 GO TO 163 155 IREF=3 GO TO 163 150 IF ( X(2) ) 157, 156, 157 156 IF ( X(3) ) 159, 158, 159 158 IREF=5 GO TO 163 159 IREF=4 GO TO 163 157 IF ( X(3) ) 161, 160, 161 160 IREF=2 GO TO 163 161 IREF=1 163 IH=X(1) IK=X(2) IL=X(3) IQ=X(4) SINE=SINT FIDH=IH/2 FIDK=IK/2 FIDL=IL/2 IF ( 0.5*X(1)-FIDH ) 191, 190, 191 190 IF ( 0.5*X(2)-FIDK ) 195, 192, 195 192 IF ( 0.5*X(3)-FIDL ) 194, 193, 194 193 KLAS=1 GO TO 205 194 KLAS=2 GO TO 205 195 IF ( 0.5*X(3)-FIDL ) 197, 196, 197 196 KLAS=3 GO TO 205 197 KLAS=5 GO TO 205 191 IF ( 0.5*X(2)-FIDK ) 199, 198, 199 198 IF ( 0.5*X(3)-FIDL ) 201, 200, 201 200 KLAS=4 GO TO 205 201 KLAS=6 GO TO 205 199 IF ( 0.5*X(3)-FIDL ) 203, 202, 203 202 KLAS=7 GO TO 205 203 KLAS=8 205 DO 131 J=1,10 IF ( SINE-DSIN ) 132, 132, 131 131 SINE=SINE-DSIN 132 IF ( NRFM ) 133, 134, 134 C FOR STRUCTURE FACTOR ONLY PROGRAM 133 YO=YO*SCL AO=AO*SCL BO=BO*SCL 134 DELT=ABS(YO-YC ) NHKLS(J)=NHKLS(J)+1 DHKLS(J)=DHKLS(J)+DELT SHKLS(J)=SHKLS(J)+YO NHKL(IREF)=NHKL(IREF)+1 DHKL(IREF)=DHKL(IREF)+DELT SHKL(IREF)=SHKL(IREF)+YO NKLS(KLAS)=NKLS(KLAS)+1 DKLS(KLAS)=DKLS(KLAS)+DELT SKLS(KLAS)=SKLS(KLAS)+YO IF ( ID ) 165, 164, 165 164 SUM1=SUM1+YO SUM2=SUM2+YC GO TO 166 165 SUM3=SUM3+YO SUM4=SUM4+YC 166 CALL DATSW (1,LSW ) IE=0 IF ( YO-2.0*YC) 187, 187, 186 186 IF (YO-3.0*YC ) 178, 178, 179 178 IE=2 GO TO 187 179 IF ( YO-4.0*YC ) 188, 188, 189 188 IE=3 GO TO 187 189 IE=4 187 GO TO ( 176, 177 ), LSW 176 WRITE( JCDO,15) IH,IK,IL,YO,YC,AO,A,BO,B,SINT,ID,SIGYO,IE GO TO 136 177 GO TO ( 137, 136 ), LSW2 C PUNCH CARD FOR THE INPUT OF REPEAT CALCULATION 137 ISIN=SINT*1000.0 IRHO=RHO*1000.0 DO 138 I=1,6 138 IFM(I)=FM(I)*100.0 WRITE ( JCDO,16 ) IH,IK,IL,YO,YC,A,B,SIGYO,ISIN,IRHO,ID, 1 ( IFM(I),I=1,6) C IF STRUCTURE FACTORS ONLY 136 IF ( NC ) 112, 111, 112 112 IF ( SIGYO ) 118, 114, 118 114 WDELT=0.0 GO TO 121 118 WDELT=((YO-YC)/SIGYO)**2 121 I=1 IF ( YO ) 117, 120, 117 117 DO 115 I=1,11 IF ( YO-DSTF ) 116, 116, 115 115 YO=YO-DSTF I=11 116 IF ( ID ) 120, 119, 120 119 MOBS(I)=MOBS(I)+1 WDOBS(I)=WDOBS(I)+WDELT MOSN(J)=MOSN(J)+1 WDOS(J)=WDOS(J)+WDELT GO TO 135 120 MUNO(I)=MUNO(I)+1 WDUNO(I)=WDUNO(I)+WDELT MUSN(J)=MUSN(J)+1 WDUS(J)=WDUS(J)+WDELT 135 GO TO 111 C C END OF DATA 113 WRITE ( JTYP,20 ) WRITE ( JTYP,13 ) DO 174 I=1,10 IF ( SHKLS(I) ) 174, 174, 175 175 SHKLS(I)=DHKLS(I)/SHKLS(I) 174 CONTINUE WRITE ( JTYP,10 ) (NHKLS(I),I=1,10 ) WRITE ( JTYP,23 ) (SHKLS(I),I=1,10) WRITE ( JTYP,21 ) DO 170 I=1,7 NHKL(8)=NHKL(8)+NHKL(I) DHKL(8)=DHKL(8)+DHKL(I) 170 SHKL(8)=SHKL(8)+SHKL(I) DO 173 I=1,8 IF ( SHKL(I) ) 171, 171, 172 171 DHKL(I)=0.0 GO TO 173 172 DHKL(I)=DHKL(I)/SHKL(I) 173 CONTINUE WRITE ( JTYP,10 ) (NHKL(I),I=1,8 ) WRITE ( JTYP,23 ) ( DHKL(I),I=1,8 ) WRITE ( JTYP, 24 ) DO 169 I=1,8 IF ( SKLS(I) ) 168, 168, 167 168 DKLS(I)=0.0 GO TO 169 167 DKLS(I)=DKLS(I)/SKLS(I) 169 CONTINUE WRITE ( JTYP,10 ) ( NKLS(I),I=1,8 ) WRITE ( JTYP,23 ) ( DKLS(I),I=1,8 ) IF ( SUM1 ) 181, 181, 180 180 SCL1=SUM2/SUM1 GO TO 182 181 SCL1=0.0 182 IF ( SUM1+SUM3 ) 184, 184, 183 183 SCL2=(SUM2+SUM4)/(SUM1+SUM3) GO TO 185 184 SCL2=0.0 185 WRITE (JTYP,25 ) SUM1,SUM2,SCL1,SUM3,SUM4,SCL2 IF ( NC ) 207, 208, 207 207 WRITE ( JTYP,12 ) DO 140 I=1,11 IF ( MOBS(I) ) 141, 140, 141 141 FNUMB=MOBS(I) WDOBS(I)=WDOBS(I)/FNUMB 140 CONTINUE WRITE ( JTYP,10 ) ( MOBS(I),I=1,11 ) WRITE ( JTYP,11 ) ( WDOBS(I),I=1,11 ) DO 142 I=1,11 IF ( MUNO(I) ) 143, 142, 143 143 FNUMB=MUNO(I) WDUNO(I)=WDUNO(I)/FNUMB 142 CONTINUE WRITE ( JTYP,10 ) ( MUNO(I),I=1,11 ) WRITE ( JTYP,11 ) ( WDUNO(I),I=1,11 ) WRITE ( JTYP,13 ) DO 144 I=1,10 IF ( MOSN(I) ) 145, 144, 145 145 FNUMB=MOSN(I) WDOS(I)=WDOS(I)/FNUMB 144 CONTINUE WRITE ( JTYP,10 ) ( MOSN(I),I=1,10 ) WRITE ( JTYP,11 ) ( WDOS(I),I=1,10 ) DO 146 I=1,10 IF ( MUSN(I) ) 147, 146, 147 147 FNUMB=MUSN(I) WDUS(I)=WDUS(I)/FNUMB 146 CONTINUE WRITE ( JTYP,10 ) ( MUSN(I),I=1,10 ) WRITE ( JTYP,11 ) ( WDUS(I),I=1,10 ) 208 WRITE ( JTYP, 14 ) CALL EXIT END // DU P