C NEUTRON POWDER RETRIEVAL AND REFINEMENT, C A.W.HEWAT 1 JAN 1978 C TYPE 90 90 FORMAT(' **** ALL USE CAN BE ACKNOWLEDGED IN PUBLICATIONS **** ' 1 /' BY REFERENCE TO A.W.HEWAT POWDER PREPARATION PROGRAM ' 2 //' FOR INFORMATION ON HOW TO USE THE PROGRAM TYPE "?(CR)"') 91 TYPE 919 919 FORMAT(/' MASTER OPTION NUMBER ?') ACCEPT 9,MOPT 9 FORMAT(8A5) 99 FORMAT(I) IF(MOPT.EQ.1H ) CALL EXIT IF(MOPT.NE.1H?) GO TO 92 C INFORMATION ON MASTER OPTIONS TYPE 939 939 FORMAT(/' MASTER OPTIONS ARE:'/ 1' 1 GET DATA FROM DISK OR TAPE'/ 2' 2 MANIPULATE DATA, E.G ADD THE COUNTERS'/ 3' 3 PLOT PROFILES'/ 4' 4 GENERATE H,K,L AND MULTIPLICITY LIST'/ 5' 5 SET UP AND EDIT FILES '/ 6' 6 SET UP DATA FOR XRAY OR CAMBRIDGE SYSTEM'/ 7' 7 SET UP CELL IDENTIFICATION - "TAUPIN" PROG'/ 7' 8 COMPLAINTS AND SUGGESTIONS'/ 8' CALL EXIT'/ 9' TYPE ''?'' FOR MORE INFORMATION'// 9' MASTER OPTION NUMBER ?') ACCEPT 9,MOPT IF(MOPT.EQ.1H ) CALL EXIT IF(MOPT.NE.1H?) GO TO 92 C MORE INFORMATION ON POWDER PROGRAM TYPE 949 949 FORMAT(/' PROGRAM CAN BE USED WITHOUT PREVIOUS KNOWLEDGE OF IT.' 1 /' GENERAL RULE: IF IN DOUBT, TYPE "? CR"' 2 /' IF NO MORE INFORMATION, A STANDARD OPTION IS CHOSEN' 3 /' ALWAYS TERMINATE YOUR REPLY WITH "CR"' 4 /' TYPE ONLY "CR" TO RETURN TO PREVIOUS OPTION CHOICE' 5 /' NOTIFY A.W.HEWAT OF ANY PROBLEMS AND SUGGESTIONS' 6 //' MASTER OPTION NUMBER ?') ACCEPT 9,MOPT IF(MOPT.EQ.1H ) CALL EXIT IF(MOPT.EQ.1H?) MOPT='1' C GO TO CHOSEN MASTER OPTION 92 DECODE(5,99,MOPT) MOPTN IF(MOPTN.GE.1.AND.MOPTN.LE.6) GO TO 93 IF(MOPTN.EQ.8) GO TO 93 TYPE 959,MOPT 959 FORMAT(' MASTER OPTION NUMBER ',A5,' IS NOT YET ACCEPTABLE') GO TO 91 93 CALL OPTION(MOPTN) GO TO 91 END SUBROUTINE OPTION(MOPTN) DIMENSION VIN(14),U(3),V(3),W(3),NC(10),NCC(10) DIMENSION TTMIN(10),CMON(10) INTEGER POPTN,COUNTS(10) DIMENSION TITLE(14) COMPLEX FILET,FILED,FILE1,FILE2 GO TO (1,2,3,4,5,6,7,8),MOPTN C GET DATA FROM DISK OR TAPE 1 TYPE 119 119 FORMAT(' 1. GET DATA FROM DISK OR TAPE ? Y OR N ?') ACCEPT 9,IFOK IF(IFOK.EQ.1H?) IFOK='Y' IF(IFOK.NE.1HY) GO TO 91 CALL DATOUT RETURN C ADD PROFILES 2 TYPE 219 219 FORMAT(' 2. MANIPULATE DATA ? Y OR N ?') ACCEPT 9,IFOK IF(IFOK.NE.1HY) RETURN 28 TYPE 259 259 FORMAT(' DATA OPTION NUMBER ?') ACCEPT 9,POPT IF(POPT.EQ.1H ) RETURN IF(POPT.NE.1H?) GO TO 20 TYPE 269 269 FORMAT(/' DATA OPTIONS ARE:' 1 /' 1. SUM THE COUNTERS' 2 /' 2. ADD OR SUBTRACT TWO PROFILES' A /' 3. RECALCULATE COUNTER EFFICIENCIES'/ 3 /' DATA OPTION NUMBER ?') ACCEPT 9,POPT IF(POPT.EQ.1H ) RETURN IF(POPT.EQ.1H?) POPT='1' C DECODE DATA OPTION 20 DECODE(5,309,POPT) POPTN IF(POPTN.GE.1.AND.POPTN.LE.3) GO TO 200 TYPE 2009,POPT 2009 FORMAT(' DATA OPTION ',A5,' IS NOT AVAILABLE') GO TO 28 200 IF(POPTN.EQ.1) TYPE 291 IF(POPTN.EQ.2) TYPE 292 IF(POPTN.EQ.3) TYPE 293 291 FORMAT(' 1. SUM THE COUNTERS ? Y OR N ?') 292 FORMAT(' 2. ADD OR SUBTRACT TWO PROFILES ? Y OR N ?') 293 FORMAT(' 3. RECALCULATE COUNTER EFFICIENCIES ? Y OR N ?') ACCEPT 9,IFOK IF(IFOK.EQ.1H?) IFOK='Y' IF(IFOK.NE.1HY) GO TO 28 C GET DATA FILES 2000 TYPE 229 229 FORMAT(' DATA FILE NAME ?') ACCEPT 9,FILE1 IF(FILE1.EQ.1H ) RETURN IF(FILE1.EQ.1H?) FILE1='COUNT' CALL FILEOK(FILE1,IERROR) IF(IERROR.NE.0) GO TO 2000 GO TO (21,22,25),POPTN 21 SUMM='.SUM' FILE2=CMPLX(REAL(FILE1),SUMM) TYPE 239 239 FORMAT(' COUNTERS TO ADD ? EG 1,2,5,8 OR 0=ALL') ACCEPT 249,NC 249 FORMAT(10I) IF(NC(1).LE.0.OR.NC(1).GE.11) GO TO 220 DO210I=1,10 210 NCC(I)=0 DO211I=1,10 K=NC(I) 211 IF(K.GT.0.AND.K.LT.11) NCC(K)=1 GO TO 24 220 DO221I=1,10 221 NCC(I)=1 24 CALL SUMP(FILE1,FILE2,NCC) TYPE 289,FILE2 289 FORMAT(' SUMMED PROFILE IS IN FILE "',2A5,'"') RETURN C ADD OR SUBTRACT TWO PROFILES 22 TYPE 279 279 FORMAT(' SECOND DATA FILE NAME ?') ACCEPT 9,FILE2 IF(FILE2.EQ.1H ) GO TO 28 IF(FILE2.NE.1H?) GO TO 23 TYPE 2309 2309 FORMAT(' THIS FILE WILL BE ADDED OR SUBTRACTED FROM THE FIRST') GO TO 22 23 CALL FILEOK(FILE2,IERROR) IF(IERROR.NE.0) GO TO 22 TYPE 2319 2319 FORMAT(' ADD FACTOR ? +1=ADD, -1=SUBTRACT') ACCEPT 9,POPT IF(POPT.EQ.1H ) GO TO 22 IF(POPT.EQ.1H?) POPT='1' DECODE (5,3099,POPT) FAC 3099 FORMAT(F) CALL ADDSUB(FILE1,FILE2,FAC) RETURN C RECALCULATE COUNTER EFFICIENCIES 25 TYPE 859 859 FORMAT(' ANGULAR RANGE FOR COUNTER COMPARISON ? ', 1 '(CR MEANS MAXIMUM)') ACCEPT 869,TTF,TTL 869 FORMAT(2F) CALL EFFIC(FILE1,TTF,TTL) RETURN C PLOT PROFILES 3 TYPE 319 319 FORMAT(' 3. PLOT PROFILES ? Y OR N ?') ACCEPT 9,IFOK IF(IFOK.EQ.1H?) IFOK='Y' IF(IFOK.NE.1HY) RETURN 38 TYPE 329 329 FORMAT(' PLOT OPTION NUMBER ?') ACCEPT 9,POPT IF(POPT.EQ.1H ) RETURN IF(POPT.NE.1H?) GO TO 30 C INFORMATION ON PLOT OPTIONS TYPE 339 339 FORMAT(/' PLOT OPTIONS ARE:' 1 /' 1. LINE PRINTER PLOT' 2 /' 2. "NEWTRA" CALCOMP PLOT' 3 /' 3. DECGRAPHIC DISPLAY' B /' 4. TEKTRONIX DISPLAY (**RECOMMENDED**)' C /' 5. CALCOMP PLOT' D /' 6. VERSATEK PLOT' E /' 7. BENSON PLOT (**RECOMMENDED**)' 4 //' PLOT OPTION NUMBER ?') ACCEPT 9,POPT IF(POPT.EQ.1H ) RETURN IF(POPT.EQ.1H?) POPT='1' C DECODE PLOT OPTION 30 DECODE(5,309,POPT) POPTN 309 FORMAT(I) IF(POPTN.GE.1.AND.POPTN.LE.7) GO TO 300 TYPE 3009,POPT 3009 FORMAT(' PLOT OPTION ',A5,' IS NOT AVAILABLE') GO TO 38 300 IF(POPTN.EQ.1) TYPE 391 IF(POPTN.EQ.2) TYPE 392 IF(POPTN.EQ.3) TYPE 393 IF(POPTN.EQ.4) TYPE 394 IF(POPTN.EQ.5) TYPE 395 IF(POPTN.EQ.6) TYPE 396 IF(POPTN.EQ.7) TYPE 397 391 FORMAT(' 1. LINE PRINTER PLOT ? Y OR N ?') 392 FORMAT(' 2. "NEWTRA" CALCOMP PLOT ? Y OR N ?') 393 FORMAT(' 3. DECGRAPHIC DISPLAY ? Y OR N ?') 394 FORMAT(' 4. TEKTRONIX DISPLAY ? Y OR N ?') 395 FORMAT(' 5. NORMAL CALCOMP PLOT ? Y OR N ?') 396 FORMAT(' 6. VERSATEC PLOT ? Y OR N ?') 397 FORMAT(' 7. BENSON PLOT ? Y OR N ?') ACCEPT 9,IFOK IF(IFOK.EQ.1H?) IFOK='Y' IF(IFOK.NE.1HY) GO TO 38 C GET DATA FILE FOR PLOT 301 TYPE 3019 3019 FORMAT(' DATA FILE NAME ?') ACCEPT 9,FILE1 IF(FILE1.EQ.1H ) GO TO 38 IF(FILE1.NE.1H?) GO TO 3000 TYPE 3029 3029 FORMAT(/' THIS IS THE 5 LETTER NAME GIVEN TO THE FILE CREATED BY' 1 /' MASTER OPTION 1 (E.G "COUNT")' 2 //' DATA FILE NAME ?') ACCEPT 9,FILE1 IF(FILE1.EQ.1H ) GO TO 3 IF(FILE1.EQ.1H?) FILE1='COUNT' 3000 CALL FILEOK(FILE1,IERROR) IF(IERROR.NE.0) GO TO 301 CALL IFILE(30,FILE1) 313 GO TO (31,32,33,34,35,36,37),POPTN C LINE PRINTER PLOT 31 TYPE 3139,FILE1 3139 FORMAT(' FILE ',2A5,' BEING USED TO CREATE FILE *.LPT' 1 /' PLEASE WAIT') CALL PLOTL(30) CALL RELEAS(30) GO TO 91 C "NEWTRA" CALCOMP PLOT 32 CALL PLOTCC(30) CALL RELEAS(30) GO TO 91 C DECGRAPHIC DISPLAY PLOT 33 CALL PLOTG(30) CALL RELEAS(30) GO TO 91 C TEKTRONIX DISPLAY 34 CALL PLOTT(30) CALL RELEAS(30) GO TO 91 C NORMAL CALCOMP PLOT 35 CALL PLOTK(30) CALL RELEAS(30) GO TO 91 C VERSATEC PLOT 36 CALL PLOTV(30) CALL RELEAS(30) GO TO 91 C BENSON PLOT 37 CALL PLOTB(30) CALL RELEAS(30) GO TO 91 C GENERATE H,K,L AND MULTIPLICITY LIST 4 TYPE 419 419 FORMAT(' 4. GENERATE H,K,L AND MULTIPLICITY LIST ? Y OR N ?') ACCEPT 9,IFOK IF(IFOK.EQ.1H?) IFOK='Y' IF(IFOK.NE.1HY) GO TO 91 401 TYPE 429 429 FORMAT(' TITLE ?') ACCEPT 9,TITLE IF(TITLE(1).EQ.1H ) GO TO 91 402 TYPE 439 439 FORMAT(' CELL DIMENSIONS AND ANGLES ?') ACCEPT 9,VIN IF(VIN(1).EQ.1H ) GO TO 401 IF(VIN(1).NE.1H?) GO TO 403 TYPE 449 449 FORMAT(/' E.G 15.142 4.338 12.899 90. 108.35 90. '/) GO TO 402 403 DECODE(70,4039,VIN) A,B,C,ALPHA,BETA,GAMMA 4039 FORMAT(9F) 407 TYPE 459 459 FORMAT(' WAVELENGTH, MAX 2THETA, LAUE GROUP, LATTICE TYPE ?') ACCEPT 9,VIN IF(VIN(1).EQ.1H ) GO TO 402 IF(VIN(1).NE.1H?) GO TO 404 TYPE 469 469 FORMAT(/' CODE IS' 1 /' LAUE GROUP LATTICE TYPE' 2 /' 1 TRICLINIC 1 PRIMITIVE' 3 /' 2 MONOCLINIC(B-AXIS UNIQUE) 2 A-FACE CENTRED' 4 /' 3 ORTHORHOMBIC 3 B-FACE CENTRED' 5 /' 4 TETRAGONAL 4/M 4 C-FACE CENTRED' 6 /' 5 TETRAGONAL 4/MMM 5 ALL FACES CENTRED' 7 /' 6 TRIGONAL BAR 3 6 BODY CENTRED' 8 /' 7 TRIGONAL BAR 3/M 7 RHOMBOHEDRAL (HEX. IND)' 9 /' 8 HEXAGONAL 6/M' X /' 9 HEXAGONAL 6/MMM' A /' 10 CUBIC M3' B /' 11 CUBIC M3M' C /' 12 MONOCLINIC(C-AXIS UNIQUE)' D /' E.G 1.384 160. 2 1'/) GO TO 407 404 DECODE(70,4049,VIN) WAVEL,TTMAX,NLAUE,NLAT,IOP,ANORM 4049 FORMAT(2F,3I,F) MM=0 DATA U,V,W/9*0./ 408 TYPE 479 479 FORMAT(' DO YOU WANT A PERMANENT FILE OF RESULTS ? Y OR N ?') ACCEPT 9,IFOK IF(IFOK.EQ.1H ) GO TO 403 IF(IFOK.EQ.1H?) IFOK='Y' IF(IFOK.NE.1HY) GO TO 4990 IOP=1 TYPE 489 489 FORMAT(' NAME FOR THIS FILE ? (E.G "HKL")') ACCEPT 9,FILE2 IF(FILE2.EQ.1H ) GO TO 408 IF(FILE2.EQ.1H?) FILE2='HKL' 4990 TYPE 499 499 FORMAT(' PLEASE WAIT') FILE1='HKLIN' CALL OFILE(32,FILE1) WRITE(32,4019) TITLE,A,B,C,ALPHA,BETA,GAMMA,WAVEL,TTMAX,NLAUE,NLAT 1 ,IOP,ANORM,MM,(U(I),V(I),W(I),I=1,3) 4019 FORMAT(14A5/6F8.4/2F8.4,3I8,F8.4/I8/9F8.4) REWIND 32 CALL RELEAS(32) CALL RELEAS(33) CALL IFILE(32,FILE1) CALL OFILE(33,FILE2) CALL HKL(32,33) CALL RELEAS(32) CALL RELEAS(33) GO TO 91 C SET UP AND EDIT FILES USING TITLE ASSISTED EDITOR "TITLED" 5 TYPE 519 519 FORMAT(' 5 SET UP AND EDIT FILES ? Y OR N ?') ACCEPT 9,IFOK IF(IFOK.EQ.1H?) IFOK='Y' IF(IFOK.NE.1HY) GO TO 91 51 TYPE 529 529 FORMAT(' NAME OF TITLES FILE ? (EG PROF1.DAT)') ACCEPT 59,FILET 59 FORMAT(2A5) IF(FILET.EQ.1H ) RETURN IF(FILET.NE.1H?) GO TO 53 TYPE 539 539 FORMAT(' EXIT AND DO ".COPY PROF1.DAT=PROF1.DAT[10,25]"' 1 /' AND ALSO ".COPY PROF2.DAT=PROF2.DAT[10,25]"' 2 /' TO OBTAIN TITLES FILES SUITABLE FOR EDITING DATA FILES' 3 /' "TEST1.DAT" AND "TEST2.DAT" (ALSO ON [10,25]).' 4 /' THESE DATA FILES TEST THE PROFILE REFINEMENT PROGRAMS' 5 /' "PROF1.SAV[10,25]" AND "PROF2.SAV[10,25]"'/) GO TO 5 53 TYPE 549 549 FORMAT(' NAME OF DATA FILE ? (EG TEST1.DAT)') ACCEPT 59,FILED IF(FILED.EQ.1H ) GO TO 51 CALL TITLED(FILET,FILED) RETURN 6 TYPE 619 619 FORMAT(' 6. SET UP DATA FOR XRAY OR CAMBRIDGE SYSTEM ? Y OR N ?') ACCEPT 9,IFOK IF(IFOK.EQ.1H?) IFOK='Y' IF(IFOK.NE.'Y') GO TO 91 601 TYPE 629 629 FORMAT(' SYSTEM OPTION NUMBER ? (XRAY=1, CAMBS=2)') ACCEPT 9,POPT IF(POPT.EQ.1H ) RETURN IF(POPT.EQ.1H?) POPT='2' DECODE(5,309,POPT) POPTN IF(POPTN.GE.1.AND.POPTN.LE.2) GO TO 602 TYPE 6009,POPT 6009 FORMAT(' SYSTEM OPTION ',A5,' IS NOT YET AVAILABLE') GO TO 601 602 IF(POPTN.EQ.1) TYPE 691 691 FORMAT(' 1. XRAY SYSTEM ? Y OR N ?') IF(POPTN.EQ.2) TYPE 692 692 FORMAT(' 2. CAMBRIDGE SYSTEM ? Y OR N ?') ACCEPT 9,IFOK IF(IFOK.EQ.1H?) IFOK='Y' IF(IFOK.NE.1HY) GO TO 601 GO TO (61,62),POPTN 61 CALL XRAY70 RETURN 62 CALL CAMBS 7 RETURN 8 CALL CRITIC 91 RETURN 9 FORMAT(14A5) END SUBROUTINE CRITIC C C STORES CRITICISMS OF THE SYSTEM IN FILE POWDER.MOD[10,25] C DIMENSION WORD(15) TYPE 59 59 FORMAT(/' LIST EARLIER CRITICISMS ? Y OR N ?'/) ACCEPT 69,IFLIST 69 FORMAT(A5) IF(IFLIST.NE.'Y') GO TO 2 OPEN(UNIT=38,FILE='POWDER.MOD',DIRECT='10,25',ACCESS='SEQIN') TYPE 9 9 FORMAT(/' ***EARLIER CRITICISMS NOT YET CORRECTED INCLUDE'/) 1 READ(38,END=20,19) WORD 19 FORMAT(A1,A4,13A5) TYPE 29,WORD 29 FORMAT(1X,A1,A4,13A5) GO TO 1 20 CLOSE(UNIT=38) 2 OPEN(UNIT=38,FILE='POWDER.MOD',DIRECT='10,25',ACCESS='APPEND') TYPE 39 39 FORMAT(/' *** TYPE YOUR NAME AND THE DATE PLEASE,'/ 1' *** FOLLOWED BY YOUR COMMENTS ON AS MANY LINES AS NEEDED'/ 2' *** (TYPE "! RETURN" ON A NEW LINE TO FINISH)'/) 3 ACCEPT 19,WORD IF(WORD(1).EQ.1H!) GO TO 4 WRITE(38,19) WORD GO TO 3 4 WRITE(38,19) CLOSE(UNIT=38) RETURN END SUBROUTINE DATOUT C C THIS GETS POWDER DATA FROM A FILE ON DISK OR TAPE C IT IS A CONVERSATIONAL PROGRAM AND CAN ONLY BE RUN FROM A TERMINAL C A FILE CAN ALSO BE CREATED (FORMAT 10I8) FOR PLOTTING OR REFINEMENT C DOUBLE PRECISION FILE1 DIMENSION ISET(22000),ISSET(10),TTDIF(10,3),TTS(10),RSCALE(10,3), 1 RS(10),INFEFF(16) DIMENSION ICDESC(12),VALSET(1600) DIMENSION ICCO(30),VALCO(30),MESCO(21),ICDEF(5),VALDEF(5) DIMENSION ATAB1(15),FTAB1(13),FTAB2(2),DATA1(1440) DIMENSION NOMEXP(2),IDATE(4) EQUIVALENCE (MESCO(1),ATAB1(1)),(VALCO(1),FTAB1(1)) EQUIVALENCE (VALDEF(1),FTAB2(1)),(VALSET(1),DATA1(1)) EQUIVALENCE (MESCO(19),IDATE(1)) C ....LAST CHECKED ON FE3O4 44K PEAK FEB81 DATA TTDIF/0.067,5.985,11.850,18.075,23.935, A 29.980,35.980,41.975,47.985,53.985, 1 0.,6.05,11.985,17.99,0.,0.,0.,0.,0.,0.,10*0./ C BEFORE 18NOV80 DATA TTDIF/ 0.065,5.980,11.875,18.055,23.945, C A 29.985,35.970,41.975,47.980,53.985, C BEFORE 18NOV80 DATA RSCALE/.9418,.9872,.9180,1.1305,.9887, C A .9623,1.0683,.9479,1.1183,.9316, DATA RSCALE/0.86706,0.90601,0.83459,1.15606,0.92369, A 1.03456,1.13221,0.98941,1.16561,0.99330, 1 1.0170,1.0276,0.9745,0.9809,6*1.0,10*1./ DATA MESCO/21*5H / DATA NOMEXP/' '/,IDATE/' '/ 1 TYPE 109 109 FORMAT(' INSTRUMENT NAME (E.G. D1A OR D1AOLD) ?') ACCEPT 119,INST,OLD 119 FORMAT(2A3) IF(INST.EQ.1H ) RETURN IF(INST.EQ.'D1A'.OR.INST.EQ.'D1B'.OR.INST.EQ.'D2') GO TO 2 INST='D1A' TYPE 129 129 FORMAT(' D1A SELECTED') 2 TYPE 209 209 FORMAT(' DEVICE NAME (E.G. SPCT OR HCB01) ?') ACCEPT 139,LIEN 139 FORMAT(3A5) IF(LIEN.EQ.1H ) GO TO 1 IF(LIEN.NE.1H?) GO TO 3 LIEN='SPCT' TYPE 229 229 FORMAT(' SPCT SELECTED') 3 IF(LIEN.NE.'SPCT') TYPE 339 339 FORMAT(' FOR DATA ON TAPE HCB, FIRST DO ".MOUNT MTA HCB/VID:HCB"' 1 /' CONSULT CARINE FOLDER IN ROOM 02 FOR CONTENTS OF FILES'/) 31 TYPE 309 309 FORMAT(' NUMBER OF THE FIRST BLOCK ?') ACCEPT 139,NS 319 FORMAT(I) IF(NS.EQ.1H ) GO TO 2 IF(NS.NE.1H?) GO TO 4 TYPE 329 329 FORMAT(' BLOCK NUMBERS ARE GIVEN ON DIFFRACTOMETER PRINT-OUT' 1 /' NUMBER OF THE FIRST BLOCK ? ( ? FOR MORE INFORMATION)') ACCEPT 139,NS IF(NS.EQ.1H ) GO TO 2 IF(NS.NE.1H?) GO TO 4 CALL LISDAT(INST,OLD,LIEN,0,99999) GO TO 31 4 DECODE(5,319,NS) NSTART TYPE 409 409 FORMAT(' NUMBER OF THE LAST BLOCK ?') ACCEPT 139,NE IF(NE.EQ.1H ) GO TO 3 IF(NE.NE.1H?) GO TO 41 CALL LISDAT(INST,OLD,LIEN,NSTART,999999) GO TO 31 41 DECODE(5,319,NE) NEND 5 TYPE 509 509 FORMAT(' DO YOU WANT TO CREATE A DATA FILE (10I8) ? Y OR N ?') ACCEPT 139,IFCARD IF(IFCARD.EQ.1H ) GO TO 4 IF(IFCARD.EQ.1HN) GO TO 608 6 IF(IFCARD.EQ.1HY) TYPE 639 639 FORMAT(' 5CHAR DATA FILE NAME ? USE STANDARD COUNTER EFFICIENCIES 1? Y OR N ? (CR=Y)') DO611II=1,12400 611 ISET(II)=1 ACCEPT 139,FILE1,IFEFF IF(FILE1.EQ.1H ) GO TO 5 IF(FILE1.EQ.1H?) FILE1='COUNT' CALL OFILE(30,FILE1) 608 TYPE 609 609 FORMAT(' SEARCHING FOR YOUR DATA') 649 FORMAT(1X,11A5,A4,I5,'TO',I5/ 2 6X,'10',7X,'0',F8.2,7X,'1',7X,'0',7X,'0'/10F8.3/ 1 10F8.0) WRITE(6,999) 999 FORMAT(1H1) L=0 LTT100=0 IGAP=0 ILAP=0 IF(NEND.LT.NSTART) NEND=9999+NEND C NUMOR=NSTART DO61NBLOCK=NSTART,NEND NUMOR=NBLOCK C IF(NUMOR.GE.10000) NUMOR=NUMOR-9999 IF(INST.EQ.'D1A'.AND.OLD.NE.'OLD') GO TO 610 CALL MEDOR(INST,LIEN,NUMOR,KCTRL,N1,ICCO,VALCO, 1 MESCO,MANIP,N2,ICDEF,VALDEF,M,N3,ICDESC,VALSET) GO TO 612 610 CALL MEDIR(INST,LIEN,NUMOR,NOMEXP,IDATE,ATAB1,KCTRL,N1, 1 FTAB1,MANIP,FTAB2,M,DATA1) N3=12 612 IF(NUMOR.NE.-1) GO TO 7 TYPE 79,NBLOCK,INST,LIEN 79 FORMAT(' BLOCK ',I5,' FOR ',A5,' NOT FOUND ON ',A5) GO TO 61 7 WRITE(6,39) (MESCO(I),I=1,14),(MESCO(I),I=19,21),VALCO(11) 39 FORMAT(/1X,14A5,20X,3A5,1X,'MVOLT',4X,F7.0) WRITE(6,19) NUMOR NB=1 TTHETA=VALDEF(1) DO70I=1,M II=I NE=NB+N3-1 WRITE(6,49)TTHETA,(VALSET(J),J=NB,NE) IF(INST.NE.'D1A') GO TO 701 IF(ABS(TTHETA-VALSET(NE)).LT.0.10) GO TO 701 DO7000J=NB,NE 7000 VALSET(J)=0. TYPE 7019,TTHETA 7019 FORMAT(' ****WARNING**** DATA FOR 2THETA=',F6.2,' IGNORED') 701 TTHETA=TTHETA+VALDEF(2) 70 NB=NE+1 49 FORMAT(X,F6.2,11F8.0,F8.2) 19 FORMAT(X,'2THETA',5X,'#1',6X,'#2',6X,'#3',6X,'#4',6X,'#5',6X,'#6', 1 6X,'#7',6X,'#8',6X,'#9',5X,'#10', 2 5X,'MON',4X,'TIME',5X,'BLOCK',5X,I5/) IF(IFCARD.NE.1HY) GO TO 61 C CARD OUTPUT IF REQUIRED J=1 IF(NBLOCK.NE.NSTART) GO TO 700 LP=VALDEF(2)*100.+0.5 LS=(VALDEF(1)*100+0.5)/LP LMAX=0 NINST=1 IF(INST.EQ.'D2') NINST=2 IF(INST.EQ.'D1B') NINST=3 ICC=ICCO(4) CMON=VALSET(N3-1) IF(INST.EQ.'D1A') CMON=FTAB1(6) IF(CMON.LE.0.) CMON=VALSET(N3) IF(CMON.GT.950000.) CMON=CMON/1000. IF(IFEFF.NE.'N'.AND.IFEFF.NE.' N'.AND.IFEFF.NE.' NO') GO TO 8000 TYPE 8009 8009 FORMAT(' USING COUNTER EFFICIENCIES IN YOUR FILE', 1 ' POWDER.CAL (DATA OPTION 3)') OPEN(UNIT=29,FILE='POWDER.CAL',ACCESS='SEQIN') GO TO 8001 8000 OPEN(UNIT=29,FILE='POWDER.CAL',DIRECTORY='10,25',ACCESS='SEQIN') 8001 READ(29,809) (INFEFF(I),I=1,16),(RSCALE(I,NINST),I=1,10) 809 FORMAT(16A5/10F8.5) TYPE 819,(INFEFF(I),I=1,15) 819 FORMAT(1X,15A5) CLOSE(UNIT=29) DO702I=1,N3-2 RS(I)=CMON*RSCALE(I,NINST) 702 TTS(I)=VALDEF(1)-TTDIF(I,NINST) WRITE(30,649) (MESCO(I),I=1,12),NSTART,NEND,VALDEF(2), 1 (TTS(I),I=1,10),(RS(I),I=1,10) 700 L=(VALDEF(1)*100+0.5)/LP-LS 739 L=L+1 IF(L.GT.LMAX) LMAX=L NB=N3*(J-1) DO731I=1,N3-2 NB=NB+1 IF(VALSET(NB).GT.130000) VALSET(NB)=130000 IV=VALSET(NB) 731 CALL ECRMC2(IV,L,I,3600,10,ISET) 749 IF(J.EQ.M) GO TO 61 J=J+1 GO TO 739 61 CONTINUE C 61 NUMOR=0 71 IF(IFCARD.NE.1HY) GO TO 72 DO801K=1,N3-2 IF(LMAX.LE.0) GO TO 801 I=0 802 DO803IK=1,10 I=I+1 803 CALL LECMC2(ISSET(IK),I,K,3600,10,ISET) WRITE(30,29) ISSET IF(I.LT.LMAX) GO TO 802 801 WRITE(30,659) 29 FORMAT(10(' 1',I6)) 659 FORMAT(' -1000',71X,' ') WRITE(30,669) 669 FORMAT(' -10000',71X' ') 72 CALL RELEAS(30) TYPE 619 619 FORMAT(' YOUR PRINT OUTPUT IS IN A FILE CALLED *.LPT') IF(IFCARD.EQ.1HY) TYPE 629,FILE1 629 FORMAT(' YOUR DATA IS IN A PERMANENT FILE CALLED ',2A5) RETURN END SUBROUTINE LISDAT(INST,OLD,LIEN,NBEG,NEND) C C LISTS DATA FOR INSTRUMENT 'INST' ON DEVICE 'LIEN' C INTEGER DATBEG(3),DATEND(3),TITLE(21),MESCO(21),USER(2) DIMENSION ICDESC(12),VALSET(1600),ICCO(30),VALCO(30),ICDEF(5) DIMENSION VALDEF(5) DIMENSION ATAB1(15),FTAB1(13),FTAB2(2),DATA1(1440) DIMENSION NOMEXP(2),IDATE(4) EQUIVALENCE (MESCO(1),ATAB1(1)),(VALCO(1),FTAB1(1)) EQUIVALENCE (VALDEF(1),FTAB2(1)),(VALSET(1),DATA1(1)) EQUIVALENCE (MESCO(19),IDATE(1)) NUMBEG=0 NUMEND=0 IFP='N' TYPE 29 29 FORMAT(' TYPE AS WELL AS PRINT DATA LIST ? Y OR N ? 1 (OR P=PRINT PARTIAL LIST)') ACCEPT 39,IFT 39 FORMAT(A5) IF(IFT.EQ.1H ) RETURN IF(IFT.NE.'P') GO TO 10 IFT='N' IFP='Y' 10 WRITE(6,999) 999 FORMAT(1H1) WRITE(6,9) INST,LIEN IF(IFT.EQ.'Y') WRITE(8,9) INST,LIEN IF(IFT.NE.'Y') WRITE(8,49) 49 FORMAT(' PLEASE WAIT') 9 FORMAT(/2X,'BLOCKS / 2THETA',3X,'TITLE OF DATA FOR ',A5,' ON ',A5, 1 5X,'DATE',5X,'HOUR'/) NUMOR=NBEG 11 IF(INST.EQ.'D1A'.AND.OLD.NE.'OLD') GO TO 110 CALL MEDOR(INST,LIEN,NUMOR,KCTRL,N1,ICCO,VALCO, 1 MESCO,MANIP,N2,ICDEF,VALDEF,M,N3,ICDESC,VALSET) GO TO 112 110 CALL MEDIR(INST,LIEN,NUMOR,NOMEXP,IDATE,ATAB1,KCTRL,N1, 1 FTAB1,MANIP,FTAB2,M,DATA1) N3=12 112 IF(NUMOR.NE.-1) GO TO 111 IF(NUMEND.GT.0) GO TO 14 NUMOR=NBEG+1 GO TO 11 111 IF(NUMBEG.EQ.0) GO TO 17 DO13I=1,14 13 IF(MESCO(I).NE.TITLE(I)) GO TO 14 IF(NUMOR.NE.(NUMEND+1)) GO TO 14 IF(IFP.EQ.'Y'.OR.MANIP.NE.1) GO TO 131 IF(ABS(VALDEF(1)-TTEND-VALDEF(2)).GE.0.01) GO TO 14 131 TTEND=VALDEF(1)+(M-1)*VALDEF(2) NUMEND=NUMOR DO12I=1,3 12 DATEND(I)=MESCO(I+18) IF(NUMEND.GE.NEND) GO TO 14 NUMOR=0 GO TO 11 14 WRITE(6,19) NUMBEG,NUMEND,(TITLE(I),I=1,7),(DATBEG(I),I=1,3), 1 TTBEG,TTEND,(TITLE(I),I=8,14),(DATEND(I),I=1,3), 2 WAVE,MON,ITIME,ITEMP,USER,NOMEXP IF(IFT.EQ.'Y') 1WRITE(8,19) NUMBEG,NUMEND,(TITLE(I),I=1,7),(DATBEG(I),I=1,3), 2 TTBEG,TTEND,(TITLE(I),I=8,14),(DATEND(I),I=1,3), 3 WAVE,MON,ITIME,ITEMP,USER,NOMEXP 19 FORMAT(1X,I7,' TO',I7,2X,7A5,2X,3A5/ 1 1X,F7.2,' TO',F7.2,2X,7A5,2X,3A5/ 2 20X,F5.3,'A M=',I6,'=',I4,'S T=',I4,X,A5,A1,5X,2A5/) 17 NUMBEG=NUMOR NUMEND=NUMOR TTEND=VALDEF(1)+(M-1)*VALDEF(2) DO16I=1,3 DATEND(I)=' ' 16 DATBEG(I)=MESCO(I+18) TTBEG=VALDEF(1) DO15I=1,21 15 TITLE(I)=MESCO(I) WAVE=VALCO(5) MON=VALSET(11) IF(INST.EQ.'D1A') MON=FTAB1(6) ITEMP=VALCO(3) ITIME=0.01*VALSET(12) USER(1)=MESCO(17) USER(2)=MESCO(18) IF(NUMOR.EQ.-1) RETURN NUMOR=0 IF(NUMEND.LT.NEND) GO TO 11 END SUBROUTINE FILEOK(FILE1,IERROR) COMPLEX FILE1 INTEGER COUNTS(10),NCOUNT(10) DIMENSION TITLE(15),VIN(15),TTMIN(10),CMON(10) CALL RELEAS(30) 1 CALL IFILE(30,FILE1) IERROR=0 IFNEWF=0 READ(30,3089) TITLE 3089 FORMAT(14A5,A2) 304 TYPE 3039,TITLE 3039 FORMAT(1X,14A5,A2/' ABOVE TITLE OK ? Y OR N ?') ACCEPT 9,IFOK 9 FORMAT(14A5,A2) IF(IFOK.EQ.1H ) GO TO 301 IF(IFOK.EQ.1H?) IFOK='Y' IF(IFOK.EQ.1HY) GO TO 302 TYPE 3049 3049 FORMAT(' NEW TITLE IS ?') ACCEPT 9,VIN IF(VIN(1).EQ.1H ) GO TO 301 IF(VIN(1).EQ.1H?) GO TO 302 IFNEWF=1 DO3001I=1,15 3001 TITLE(I)=VIN(I) 302 READ(30,3099) ISCALE,CMIN,TTSTEP,NSETS,IFCALC,CBACK 3099 FORMAT(2I8,F8.2,3I8) 3021 TYPE 3059,ISCALE,CMIN,TTSTEP,NSETS,IFCALC,CBACK 3059 FORMAT(' ISCALE, CMIN, TTSTEP, NSETS, IFCALC, CBACK' 1 /1X,2I6,F8.2,2I7,I10 2 /' OK ? Y OR N ?') ACCEPT 9,IFOK IF(IFOK.EQ.1HY) GO TO 303 IF(IFOK.EQ.1H ) GO TO 301 IF(IFOK.NE.1H?) GO TO 3022 TYPE 3109 3109 FORMAT(/' ISCALE =NUMBER OF COUNTS PER LINE (121 LINES) -LP PLOT' 1 /' CMIN =MINIMUM COUNT TO BE PLOTTED ON LINE PRINTER -LP' 2 /' TTSTEP =2THETA STEP IN DEGREES' 3 /' NSETS =NUMBER OF DATA SETS IN FILE (NO. OF COUNTERS)' 4 /' IFCALC =1 IF CALCULATED PROFILE ON EVERY SECOND LINE' 5 /' CBACK =BACKGROUND LEVEL TO BE ADDED TO EACH COUNT'/) GO TO 3021 3022 TYPE 3069 3069 FORMAT(' NEW PARAMETERS ARE ?' 1 /' ISCALE, CMIN, TTSTEP, NSETS, IFCALC, CBACK') ACCEPT 9,VIN IF(VIN(1).EQ.1H ) GO TO 301 IF(VIN(1).EQ.1H?) GO TO 303 IFNEWF=1 DECODE(70,3079,VIN) ISCALE,CMIN,TTSTEP,NSETS,IFCALC,CBACK 3079 FORMAT(2I,F,3I) 303 READ(30,3189) TTMIN,CMON 3189 FORMAT(10F8.3/10F8.0) 3031 TYPE 3339, TTMIN,CMON 3339 FORMAT(' TTMIN1, TTMIN2, ...ETC' 1 /10F8.3, 2 /' CMON1, CMON2, ...ETC' 3 /10F8.0, 4 /' OK ? Y OR N ?') ACCEPT 9,IFOK IF(IFOK.EQ.1HY) GO TO 370 IF(IFOK.EQ.1H ) GO TO 301 IF(IFOK.NE.1H?) GO TO 3032 TYPE 349 349 FORMAT(/' TTMIN1 =2THETA MINIMUM FOR DATA SET 1 ...ETC' 1 /' CMON1 =MONITOR COUNT FOR DATA SET 1 ...ETC'/) GO TO 3031 3032 TYPE 359 359 FORMAT(' NEW PARAMETERS ARE ?' 1 /' TTMIN1, TTMIN2, ...ETC ?') ACCEPT 9,VIN IF(VIN(1).EQ.1H ) GO TO 301 IF(VIN(1).EQ.1H?) GO TO 360 IFNEWF=1 DECODE(70,3509,VIN) TTMIN 3509 FORMAT(10F) 360 TYPE 369 369 FORMAT(' CMON1, CMON2, ...ETC ?') ACCEPT 9,VIN IF(VIN(1).EQ.1H ) GO TO 301 IF(VIN(1).EQ.1H?) GO TO 370 IFNEWF=1 DECODE(70,3509,VIN) CMON 370 IF(IFNEWF.NE.0) GO TO 312 CALL RELEAS(30) RETURN 312 CALL RELEAS(31) TYPE 3119,FILE1 3119 FORMAT(' FILE ',2A5,' BEING UPDATED' 1 /' PLEASE WAIT') CALL OFILE(31,FILE1) WRITE(31,3089) TITLE WRITE(31,3099) ISCALE,CMIN,TTSTEP,NSETS,IFCALC,CBACK WRITE(31,3189) TTMIN,CMON 311 READ(30,3129) (NCOUNT(I),COUNTS(I),I=1,10) 3129 FORMAT(10(I2,I6)) WRITE(31,3129) (NCOUNT(I),COUNTS(I),I=1,10) IF(COUNTS(1).NE.-10000) GO TO 311 IF(IFCALC.EQ.0) GO TO 314 READ(30,3149) NREFS WRITE(31,3149) NREFS DO315I=1,NREFS READ(30,3149) KCODE,IH,IK,IL,MULT,TT,FN,FM 315 WRITE(31,3149) KCODE,IH,IK,IL,MULT,TT,FN,FM 3149 FORMAT(5I8,3F8.2) 314 CALL RELEAS(30) CALL RELEAS(31) GO TO 1 RETURN 301 IERROR=1 RETURN END SUBROUTINE EFFIC(FILEN,TTF,TTL) C C CALCULATES EFFECTIVE MONITOR COUNTS (EFFICIENCIES) FROM FILE 'FILEN' C USING DATA BETWEEN THE ANGULAR RANGES TTF & TTL C COMPLEX FILEN,BAKUP DIMENSION C(10),TTS(10),CA(10),LINE1(16),LINE2(16),LINE3(16) OPEN(UNIT=36,ACCESS='SEQIN',FILE=FILEN) READ(36,119)LINE1 119 FORMAT(16A5) READ(36,129) X,X,TTINT READ(36,129) TTS 129 FORMAT(10F8.0) READ(36,129) CA TYPE 19,CA 19 FORMAT(' OLD RECIPROCAL COUNTER EFFICIENCIES ARE'/10F7.0) CMON=0. DO13K=1,10 13 CMON=CMON+CA(K) CMON=CMON/10. DO58K=1,10 C C FIND CA(K) TOTAL COUNT IN COUNTER K BETWEEN TTF &TTL C************************************************************************** C C SKIP TO CARD CONTAINING TTF COUNT C IF(TTF.NE.0.) GO TO 50 TTF=TTS(1) IF(TTL.NE.0.) GO TO 50 TTL=90. TYPE 509,TTF,TTL 509 FORMAT(' CALCULATING RELATIVE EFFICIENCIES IN RANGE '/ 1 ' ',F7.2,' TO ',F7.2) 50 TT=TTS(K)-10.*TTINT 51 TT=TT+10.*TTINT READ(36,519) C 519 FORMAT(10(2X,F6.0)) IF(C(1).EQ.-1000.) GO TO 518 IF(TTF-TT.GT.10.*TTINT) GO TO 51 C SKIP TO TTF COUNT ON CARD DO52I=1,10 IF(TTF-TT.LE.TTINT) GO TO 53 52 TT=TT+TTINT C START ADDING UNTIL TTL COUNT 53 NP=0 CA(K)=0. 54 IF(TTL-TT.LT.TTINT) GO TO 55 NP=NP+1 CA(K)=CA(K)+C(I) TT=TT+TTINT I=I+1 IF(I.LE.10) GO TO 54 I=1 READ(36,519) C IF(C(1).EQ.-1000.) GO TO 518 GO TO 54 C FINISHED CA(K) FOR THIS COUNTER 55 IF(K.NE.1.AND.NP.NE.NPOLD) GO TO 528 NPOLD=NP 56 READ(36,519) C IF(C(1).NE.-1000.) GO TO 56 C******************************************************************* 58 CONTINUE CLOSE(UNIT=36) CAV=0. DO61K=1,10 61 CAV=CAV+CA(K) CAV=CAV/10. DO62K=1,10 62 CA(K)=CMON*CA(K)/CAV TYPE 69,CA 69 FORMAT(' NEW RECIPROCAL COUNTER EFFICIENCIES ARE '/10F7.0/ 1 ' OK ? Y OR N ?') ACCEPT 619,IFOK 619 FORMAT(A1) IF(IFOK.NE.'Y') CALL EXIT C UPDATE FILE AND WRITE FILE OF EFFICIENCIES 'EFFIC.CAL' OPEN(UNIT=36,ACCESS='SEQIN',FILE=FILEN) OPEN(UNIT=37,ACCESS='SEQOUT',FILE='TEMP.DAT') READ(36,119) LINE1,LINE2,LINE3 WRITE(37,119) LINE1,LINE2,LINE3 READ(36,119) LINE2 WRITE(37,129) CA OPEN(UNIT=38,ACCESS='SEQOUT',FILE='EFFIC.CAL') DO621I=1,10 621 CA(I)=CA(I)/CMON WRITE(38,629) (LINE1(I),I=1,8),(LINE1(I),I=12,15),CA 629 FORMAT('CALIBRATED WITH',11A5,A2/10F8.5) CLOSE(UNIT=38) 71 READ(36,119) LINE2 WRITE(37,119) LINE2 IF(LINE2(1).NE.' -10.') GO TO 71 EXTEN='.BAK' BAKUP=CMPLX(REAL(FILEN),EXTEN) CLOSE(UNIT=36,FILE=BAKUP) CLOSE(UNIT=37,DISPOSE='RENAME',FILE=FILEN) RETURN 518 TYPE 5189,K 5189 FORMAT(' EOD ON COUNTER #',I2,' BEFORE RANGE TTF TO TTL FOUND') CALL EXIT 528 TYPE 5289,K 5289 FORMAT(' NUMBER OF POINTS FOR COUNTER #',I2, 1 ' NOT EQUAL TO NUMBER FOR PREV. COUNTER') CALL EXIT END SUBROUTINE XRAY70 C C PREPARES A FILE XRY.CDR FOR THE XRAY70 SYSTEM C USES FILES PROFD.DAT & PROFF.DAT FROM POWDER PROFILE PROGRAM PROF2 C IN PARTICULAR, THE FOURIER AND ORTEP2 ROUTINES IN XRAY70 ARE USED C COMPLEX FILED DIMENSION BETA(6),EQ(12,24),LABEL(6),BL(6),ALAT(6),CARD(16),DX(3) DIMENSION S(2,4),SS(7,3),EQV(4,3,24),IN(16),TITLE(13),DLAT(6) COMMON/LAT/A,B,C,D,E,F EQUIVALENCE (ALAT,A),(EQ,EQV) DATA EQ/288*0./ DATA S/'+X','-X','+Y','-Y','+Z','-Z','+','-'/ OPEN(UNIT=30,FILE='XRY.CDR',ACCESS='SEQOUT') WRITE(30,9) 9 FORMAT('FILES 5 6 3 4 1 6 10 11 12 13 14 15') C******READ PROFD.DAT AND WRITE LOADAT MODULE****** TYPE 319 319 FORMAT(' NAME OF PROF2 DATA FILE ? (CR=SKIP TO ORTEP)') ACCEPT 329,FILED 329 FORMAT(16A5) IF(FILED.EQ.1H ) GO TO 520 OPEN(UNIT=31,FILE=FILED,ACCESS='SEQIN') OPEN(UNIT=32,FILE='XRY.TMP',ACCESS='SEQOUT') READ(31,339) TITLE,IDENT 339 FORMAT(13A5/A5) WRITE(32,349) IDENT 349 FORMAT('MAXSIZ 2000' 1 /'LOADAT ',A5,22X,'1') READ(31,359) IFCENT,NE,NTYPE,NFORM,NATOM,NROT,WAVE 359 FORMAT(6I8,F8.4) EQ(1,1)=1. EQ(6,1)=1. EQ(11,1)=1. IF(NE.LE.0) GO TO 311 DO311I=1,NE READ(31,3619) (EQ(J,I+1),J=1,12) 3619 FORMAT(12F6.2) 369 FORMAT( ) IF(NROT.LE.0) GO TO 311 DO311J=1,NROT READ(31,369) 311 CONTINUE NE=NE+1 READ(31,3629) (BL(I),I=1,NTYPE) 3629 FORMAT(6F8.5,6F4.0) IF(NFORM.LE.0) GO TO 314 DO313I=1,NFORM 312 READ(31,379) FORM 379 FORMAT(2F8.3) 313 IF(FORM.NE.-100.) GO TO 312 314 READ(31,369) READ(31,369) DO315I=1,NATOM READ(31,309) LABEL1,LABEL2,NTYPE,MTYPE,MROT,X,Y,Z,B,PN,BETA,DX 309 FORMAT(A1,A2,X,3I4,5F8.5/9F8.5) IF(PN.LE.0.1) GO TO 315 DO310J=1,6 310 IF(LABEL1.EQ.LABEL(J)) GO TO 316 LABEL(NTYPE)=LABEL1 316 BTYPE='BIJ' IF(BETA(1).LT.0.1) BTYPE='BETA' WRITE(32,389) LABEL1,LABEL2,X,Y,Z,B,PN,DX IF(B.LE.0.01) WRITE(32,3819) BTYPE,LABEL1,LABEL2,BETA 315 CONTINUE 389 FORMAT('ATOM',3X,A1,3X,A2,3F8.5,F6.4,F5.2,3F8.5) 3819 FORMAT(A5,2X,A1,3X,A2,6F8.5) WRITE(32,399) 399 FORMAT('END') CLOSE(UNIT=32) C******READ PROFD.DAT AND WRITE "DATDRN" MODULE READ(31,369) READ(31,419) DIR 419 FORMAT(I8) READ(31,3629) ALAT,DLAT IF(DIR.EQ.-1.) GO TO 42 C CONVERT RECIPROCAL CELL PARAMETERS TO REAL CELL PARAMETERS IF(ALAT(1).GE.1.) GO TO 42 RAD=3.14159265/180. A=SQRT(A) B=SQRT(B) C=SQRT(C) COSA=D/(2.*B*C) COSB=E/(2.*A*C) COSC=F/(2.*A*B) SINA=SQRT(1.-COSA*COSA) SINB=SQRT(1.-COSB*COSB) SINC=SQRT(1.-COSC*COSC) V=A*B*C*SQRT(1.-COSA*COSA-COSB*COSB-COSC*COSC+2.*COSA*COSB*COSC) AS=B*C*SINA/V BS=C*A*SINB/V CS=A*B*SINC/V COSAS=(COSB*COSC-COSA)/(SINB*SINC) COSBS=(COSC*COSA-COSB)/(SINC*SINA) COSCS=(COSA*COSB-COSC)/(SINA*SINB) A=AS B=BS C=CS D=ATAN2(SQRT(1.-COSAS*COSAS),COSAS)/RAD E=ATAN2(SQRT(1.-COSBS*COSBS),COSBS)/RAD F=ATAN2(SQRT(1.-COSCS*COSCS),COSCS)/RAD C WRITE "DATRDN" MODULE 42 DO421I=1,3 DLAT(I)=0.0001*DLAT(I) 421 DLAT(I+3)=0.0001*DLAT(I+3)*SIND(ALAT(I+3)) WRITE(30,439) IDENT,TITLE,IDENT,ALAT,IDENT,DLAT 439 FORMAT('DATRDN ',A5 1 /'LABEL ',12A5,A4 2 /'CELL',3X,A5,X,3F8.5,3F9.5 3 /'CELLSD ',A5,X,3F8.5,3F9.5) CLOSE(UNIT=31) WRITE(30,449) (LABEL(I),BL(I),I=1,NTYPE) 449 FORMAT('FORMFN',1X,A1,10X,F8.3) CENT='C' IF(IFCENT.EQ.1) CENT='A' TYPE 4419 4419 FORMAT(' LATTICE TYPE ? (P,R,A,B,C,I OR F. CR=P)') ACCEPT 4429,TYPE 4429 FORMAT(A1) IF(TYPE.EQ.' ') TYPE='P' WRITE(30,479) CENT,TYPE 479 FORMAT('LATICE',2X,A1,2X,A1) C INTERPRET EQUIVALENT POSITIONS FOR XRAY70 SYSTEM DO463K=1,NE DO462J=1,3 DO461I=1,4 SS(I,J)=' ' IF(EQV(I,J,K).EQ.0.) GO TO 461 IF(EQV(I,J,K).GT .0.1) SS(I,J)=S(1,I) IF(EQV(I,J,K).LT.-0.1) SS(I,J)=S(2,I) 461 CONTINUE IE=12.*EQV(4,J,K) ID=12 SS(5,J)=' ' SS(6,J)=' ' SS(7,J)=' ' IF(IE.EQ.0) GO TO 462 4611 IF(2*(IE/2).NE.IE) GO TO 4612 IE=IE/2 ID=ID/2 GO TO 4611 4612 IF(3*(IE/3).NE.IE) GO TO 4613 IE=IE/3 ID=ID/3 4613 ENCODE(1,4619,SS(5,J))IE 4619 FORMAT(I1) ENCODE(1,4619,SS(7,J))ID SS(6,J)='/' 462 CONTINUE 463 WRITE(30,4639) ((SS(I,J),I=1,7),J=1,3) 4639 FORMAT('SYMTRY ',3A2,4A1,',',3A2,4A1, ',',3A2,4A1) WRITE(30,4649) IDENT,WAVE 4649 FORMAT('CONDIT ',A5,X,F8.5,' 1.',15X,'2') IF(FILED.NE.'PROFD.DAT') GO TO 5 C******READ PROFF.DAT AND WRITE STRUCTURE FACTORS****** TYPE 4709 4709 FORMAT(' INCLUDE STRUCTURE FACTORS (PROFF) ? Y OR N ?') ACCEPT 4429,IFF IF(IFF.NE.'Y') GO TO 5 OPEN(UNIT=33,FILE='PROFF.DAT',ACCESS='SEQIN') READ(33,4719) NHKL 4719 FORMAT(I8/) DO48I=1,NHKL READ(33,4729) H,K,L,FCS,FOS 4729 FORMAT(3I8,2F8.4) 48 WRITE(30,4739) IDENT,H,K,L,FOS 4739 FORMAT('HKL',4X,A5,X,3I3,5X,'1',2X,'1',F9.4) 5 WRITE(30,399) C******NOW INCLUDE ATOM COORDINATES FROM PROFD.DAT****** 51 OPEN(UNIT=32,FILE='XRY.TMP',ACCESS='SEQIN') 510 READ(32,519) CARD 519 FORMAT(16A5) WRITE(30,519) CARD IF(CARD(1).NE.'END') GO TO 510 CLOSE(UNIT=32,DISPOSE='DELETE') IF(IFF.NE.'Y') GO TO 52 TYPE 489 489 FORMAT(' FOURIER TYPE ? (CR=SKIP FOURIER)', 1 /' 2=PATTERSON 6=FOBS 7=FCALC', 2 /' 11=DELTAF 14=EMAP OR OTHERS') ACCEPT 4829,IFF 4829 FORMAT(I5) IF(IFF.LE.0.OR.IFF.GT.14) GO TO 52 WRITE(30,4839) IDENT,IFF 4839 FORMAT('FOURR',2X,A5,6X,'1',2X,'1',I3/'END') GO TO 52 C******SET UP ORTEP2 MODULE****** 520 TYPE 5209 5209 FORMAT(' COMPOUND IDENTITY ?') ACCEPT 329,IDENT 52 TYPE 529 529 FORMAT(' ORTEP PLANE ? E.G A-B (CR=SKIP ORTEP)') ACCEPT 539,A,B 539 FORMAT(A1,X,A1) IF(A.EQ.' ') GO TO 6 IF(A.NE.'A') GO TO 521 LP=1 IF(B.EQ.'C') LP=4 GO TO 53 521 IF(A.NE.'B') GO TO 522 LP=2 IF(B.EQ.'C') LP=5 GO TO 53 522 LP=3 IF(B.EQ.'B') LP=6 53 WRITE(30,549) IDENT,IDENT,LP 549 FORMAT('ORTEP2 ',A5 1 /'EXEC ',A5,X,' 310',I1,'44010 2 1.6 .031.54 34. 34. ' 2 ,'-1. 0.9 0.0 0.0 0.0 0.0 0.4' 3 /'END') 6 WRITE(30,499) 499 FORMAT('FINISH') CLOSE(UNIT=30) TYPE 599 599 FORMAT(' NOW EXIT AND DO....' 1 /' .ASS DSK 3' 2 /' .ASS DSK 4' 3 /' .SET CDR XRY' 4 /' .RUN XRYATS[10,25]' 5 /' .PLOT *.PLT/FORMS:BLANC') RETURN END SUBROUTINE PLOTL(NFILE) C C THIS PLOTS GRAPHS ON THE LINE PRINTER C DATA(10I8) IS PRECEEDED BY THE FOUR FOLLOWING CARDS C (20A4) ANY TITLE C (I8,3F8,I8,F8) COUNT MAX/120, COUNT MIN, 2THETA STEP, N DATA SETS C 1 IF EACH DATA CARD IS FOLLOWED BY A CARD OF CALCULATED COUNTS, C BACKGROUND TO BE ADDED TO ALL COUNTS C (10F8.2) 2THETA MIN FOR EACH DATA SET C (10F8.0) MONITOR COUNT FOR EACH DATA SET C EACH DATA SET IS TERMINATED BY -1000 C FILE IS TERMINATED BY -10000 C DIMENSION COUNT(3600,3),CSTORE(10,360,3),TITLE(20),LABEL(12) EQUIVALENCE (COUNT(1,1),CSTORE(1,1,1)) DIMENSION IOUT(150),M(2) DIMENSION TMIN(10),CMON(10) DATA ISPACE/1H /,IDOT/1H./,ISTAR/1H*/,IPLUS/1H+/,IMINUS/1H-/ 11 READ(NFILE,9) TITLE 9 FORMAT(20A4) J=0 IF(NFILE.LE.0) NFILE=5 READ(NFILE,19) ISCALE,CMIN,TSTEP,NSETS,IFCALC,CBACK 19 FORMAT(I8,2F8.2,2I8,F8.0) CEND=FLOAT(INT((CBACK-1000.5))) READ(NFILE,99) TMIN,CMON 99 FORMAT(10F8.2/10F8.0) NCURVE=2 IF(IFCALC.GT.0) NCURVE=3 DO10I=1,12 10 LABEL(I)=INT(CMIN)+10*I*ISCALE WRITE(6,100) TITLE,LABEL 100 FORMAT(1H1,30X,20A4//3X,12I10) I=0 1 J=J+1 IF(J.GT.360) GO TO 2 READ(NFILE,29) (CSTORE(K,J,1),K=1,10) IF(CSTORE(1,J,1).LT.-999.) GO TO 2 DO12K=1,10 CSTORE(K,J,1)=CSTORE(K,J,1)+CBACK 12 IF(CSTORE(K,J,1).LT.0.) CSTORE(K,J,1)=0. IF(IFCALC.EQ.0) GO TO 1 READ(NFILE,29) (CSTORE(K,J,3),K=1,10) IF(CSTORE(1,J,3).LT.-999.) GO TO 2 DO13K=1,10 CSTORE(K,J,3)=CSTORE(K,J,3)+CBACK 13 IF(CSTORE(K,J,3).LT.0.) CSTORE(K,J,3)=0. 29 FORMAT(10(2X,F6.0)) GO TO 1 2 I=I+1 IF(COUNT(I,1).EQ.CEND) GO TO 80 IP=I-1 COUNT(I,2)=COUNT(I,1) IF(I.LE.1.OR.COUNT(I+1,1).EQ.CEND) GO TO 21 COUNT(I,2)=0.25*(2.*COUNT(I,1)+COUNT(I+1,1)+COUNT(I-1,1)) 21 DO3J=1,121 3 IOUT(J)=ISPACE IOUT(1)=IDOT IOUT(121)=IDOT DO5J=1,NCURVE MOUT=(COUNT(I,J)-CMIN)/FLOAT(ISCALE)+1.5 ISDEV=0.5+0.75*SQRT(COUNT(I,J))/FLOAT(ISCALE) IF(MOUT.LT.1) GO TO 5 500 IF(MOUT.LE.121) GO TO 50 MOUT=135 C MOUT=MOUT-121 IOUT(121)=IMINUS C GO TO 500 50 GO TO (51,52,53),J 51 IOUT(MOUT)=IMINUS DO511K=1,ISDEV IF(MOUT+K.GT.150) GO TO 511 IOUT(MOUT+K)=IMINUS 511 IF(MOUT.GT.K) IOUT(MOUT-K)=IMINUS GO TO 5 52 IOUT(MOUT)=IPLUS GO TO 5 53 IOUT(MOUT)=ISTAR 5 CONTINUE IF((FLOAT(IP)/50.).NE.FLOAT(IP/50)) GO TO 8 80 DO4J=1,13 4 IOUT(10*J-9)=IDOT 8 IF((FLOAT(IP)/10.).NE.FLOAT(IP/10)) GO TO 55 TLABEL=TMIN(1)+TSTEP*FLOAT(IP) WRITE(6,101) (IOUT(J),J=1,121),TLABEL GO TO 6 55 WRITE(6,101) (IOUT(J),J=1,121) 6 IF(COUNT(I,1).EQ.CEND) GO TO 7 GO TO 2 101 FORMAT(1H*,121A1,F6.2) 7 WRITE(6,102) LABEL 102 FORMAT(3X,12I10) RETURN END SUBROUTINE PLOTCC(NFILE) C SETS UP FILE "FILEN" FOR CALCOMP PROGRAM "NEWTRA[10,25]" DIMENSION TITLE(16),COUNTS(10),TTMIN(10),CMON(10) DIMENSION CALC(10),DIFF(10),ICODE(10) DIMENSION TTREF(999),FNUC(999),FMAG(999) TYPE 9 9 FORMAT(' INCLUDE PLOTS ALREADY IN PLOT FILE FOR04.DAT ? Y OR N ?') ACCEPT 109,IFINC 109 FORMAT(A5) TYPE 19 IF(IFINC.EQ.1HN) GO TO 1000 1001 READ(40,39) A,B,IEND IF(IEND.NE.-1000) GO TO 1001 BACKSPACE 40 19 FORMAT(' FILE FOR40.DAT BEING PREPARED' 1 /' PLEASE WAIT') 1000 CMIN=10000. DMIN=0. DMAX=0. CMAX=0. READ(NFILE,3089) TITLE 3089 FORMAT(16A5) READ(NFILE,3079)ISCALE,CMIN,TTSTEP,NSETS,IFCALC,CBACK,TTMIN,CMON 3079 FORMAT(I8,F8.0,F8.2,2I8,F8.0/10F8.2/10F8.0) IF(IFCALC.EQ.0) GO TO 100 TYPE 1009 1009 FORMAT(' PLOT DIFFERENCE BETWEEN OBS & CALC PROFILES ? Y OR N ?') ACCEPT 109,IFOK TYPE 3099 3099 FORMAT(' PLEASE WAIT') CALL OFILE(35,'CALCP.TMP') IF(IFOK.EQ.'N') GO TO 100 CALL OFILE(36,'DIFFP.TMP') 100 TTHETA=TTMIN(1)-TTSTEP COUNT=0. CAL=-1000. DIF=-1000. THETA1=0. THETA2=0. THETA3=0. 1 READ(NFILE,3129) COUNTS 3129 FORMAT(10(2X,F6.0)) IF(IFCALC.EQ.0) GO TO 11 READ(NFILE,3129) CALC IF(IFOK.EQ.'N') GO TO 11 DO101I=1,10 101 DIFF(I)=COUNTS(I)-CALC(I) 11 IF(COUNTS(1).LE.-999.) GO TO 2 DO10I=1,10 TTLAST=TTHETA TTHETA=TTHETA+TTSTEP C PLOT OBSERVED PROFILE IF((COUNTS(I)+CBACK).EQ.COUNT) GO TO 12 IC=1 IF(COUNT.GT.999999.) COUNT=999999. IF(THETA1.EQ.0.) GO TO 121 WRITE(40,39)(THETA1,COUNT,IC) IF(TTLAST.GT.THETA1) WRITE(40,39)(TTLAST,COUNT,IC) 39 FORMAT(1X,F9.2,1X,F9.0,1X,I9) 121 THETA1=TTHETA COUNT=COUNTS(I)+CBACK 12 IF(IFCALC.EQ.0) GO TO 14 C PLOT CALCULATED PROFILE IF((CALC(I)+CBACK).EQ.CAL) GO TO 13 IC=2 IF(CAL.GT.999999.) CAL=999999. IF(THETA2.EQ.0.) GO TO 131 WRITE(35,39)(THETA2,CAL,IC) IF(TTLAST.GT.THETA3) WRITE(35,39)(TTLAST,CAL,IC) 131 THETA2=TTHETA CAL=CALC(I)+CBACK C PLOT (OBS-CALC) DIFFERENCES 13 IF(IFOK.EQ.'N') GO TO 14 IF(DIFF(I).EQ.DIF) GO TO 14 IC=3 IF(THETA3.EQ.0.) GO TO 141 IF(DIF.GT.999999.) DIF=999999. IF(DF.LT.-99999.) DIF=-99999. WRITE(36,39)(THETA3,DIF,IC) IF(TTLAST.GT.THETA3) WRITE(36,39)(TTLAST,DIF,IC) 141 THETA3=TTHETA DIF=DIFF(I) IF(DIFF(I).LT.DMIN) DMIN=DIFF(I) IF(DIFF(I).GT.DMAX) DMAX=DIFF(I) 14 IF(COUNTS(I).LT.CMIN) CMIN=COUNTS(I) IF(COUNTS(I).GT.CMAX) CMAX=COUNTS(I) 10 CONTINUE GO TO 1 2 IF(IFCALC.EQ.0) GO TO 22 WRITE(35,49) WRITE(36,49) CALL RELEAS(35) CALL RELEAS(36) CALL IFILE(35,'CALCP.TMP') C PLOT CALCULATED PROFILE 21 READ(35,39) TT,CT,IC IF(IC.EQ.-100) GO TO 210 WRITE(40,39) TT,CT,IC GO TO 21 210 CALL RELEAS(35) POS=CMIN-DMAX C DRAW (OBS-CALC) LINE IF(IFOK.EQ.'N') GO TO 24 CALL IFILE(36,'DIFFP.TMP') READ(36,39) TT,CT,IC IC=0 CT=CT+POS WRITE(40,39) TT,CT,IC BACKSPACE 36 23 READ(36,39) TT,CT,IC IF(IC.EQ.-100) GO TO 230 CT=CT+POS WRITE(40,39) TT,CT,IC GO TO 23 230 CALL RELEAS(36) C MARK REFLEXION POSITIONS, ABOVE AXIS FOR FNUC, BELOW FOR FMAG C POS=0.5*(POS+CBACK) 24 POS=0. READ(NFILE,209) NREFS IF(NREFS.EQ.0) GO TO 22 209 FORMAT(I) DPOS=CMAX/3. FMAX=0. J=1 TTREF(1)=0. DO200I=1,NREFS FNUC(I+1)=0. FMAG(I+1)=0. TTREF(I+1)=0. READ(NFILE,219) KCODE,IH,IK,IL,MULT,TT,FN,FM 219 FORMAT(5I8,F8.2,2F8.1) IF((FN+FM).LT.0.1) GO TO 200 C IF THIS LINE IS NOT TOO CLOSE TO PREVIOUS LINE, DRAW A NEW LINE IF((TT-TTREF(J)).GE.0.1) J=J+1 FNUC(J)=FNUC(J)+FN FMAG(J)=FMAG(J)+FM TTREF(J)=TTREF(J)+(TT-TTREF(J))*(FN+FM)/(FNUC(J)+FMAG(J)) FMAX=AMAX1(FMAX,FNUC(J),FMAG(J)) 200 CONTINUE FMAX=FMAX NLINES=J TT=TTMIN(1) CT=POS IC=0 WRITE(40,39) TT,CT,IC IC=4 WRITE(40,39) TT,CT,IC DO220I=2,NLINES TT=TTREF(I) CT=POS WRITE(40,39) TT,CT,IC CT=POS+DPOS*FNUC(I)/FMAX WRITE(40,39) TT,CT,IC CT=POS-DPOS*FMAG(I)/FMAX WRITE(40,39) TT,CT,IC CT=POS 220 WRITE(40,39) TT,CT,IC TT=TTHETA CT=POS WRITE(40,39) TT,CT,IC 22 WRITE(40,49) 49 FORMAT(' 1.00 1.00 -100' 1 /' 1.00 1.00 -1000') BACKSPACE 40 TYPE 409 409 FORMAT(' DO YOU WANT TO MAKE MORE PLOTS ? Y OR N ?') ACCEPT 109,IFOK IF(IFOK.EQ.1HY) RETURN TYPE 509 509 FORMAT(/' ON EXIT DO' A /' ".RUN NEWTRA[10,25]"' 1 /' FILENAME="FOR40.DAT"' 2 /' MODE="0"' B /' DEVICE="DSK"' C /' DIAGRAM SKIP FACTOR="0"' D /' OPTION(H FOR HELP)="1"' 3 /' ***WARNING***. "NEWTRA" IS NOT PART OF THIS SYSTEM' 4 /' IN PARTICULAR, IT DOES NOT ACCEPT "?"' 5 /' FOR INFORMATION, CONTACT P.WOLFERS') IF(IFCALC.NE.0) TYPE 609 609 FORMAT(/' CODE TRACE(1=LIGNE,2=POINT,3=LIGNE *,4=+) :' 1 /' CBN= 1= 4 FOR 1ST CURVE (OBS POINTS)' 2 /' CBN= 2= 1 FOR 2ND CURVE (CALC PROFILE)' 3 /' CBN= 3= 2 FOR 3RD CURVE (DIFF OBS-CALC)' 4 /' CBN= 4= 1 FOR 4TH CURVE (HKL POSITIONS)') CALL RELEAS(34) CALL EXIT END SUBROUTINE PLOTG(NFILE) C C PLOTS POWDER PROFILES ON GT40 C DIMENSION X(4002),Y(4002),ER(4000),YC(4002),YD(4002) DIMENSION TTHETA(4000),COBS(10,400),CALC(10,400),DIFF(10,400) DIMENSION TITLE(16),TTMIN(10),CMON(10),NTX(4),NTY(2) DIMENSION XYLIM(4),XYB(4),DIN(14),IN(14) EQUIVALENCE (X(1),TTHETA(1)),(X(4001),XMIN),(X(4002),XMAX) EQUIVALENCE (Y(1),COBS(1,1)),(Y(4001),YMIN),(Y(4002),YMAX) EQUIVALENCE (YC(1),CALC(1,1)),(YD(1),DIFF(1,1)) DATA NTX/' 2THETA IN DEGREES '/,NTY/' COUNT '/ C READ FILE TITLE AND SETUP DATA REWIND NFILE READ(NFILE,119) TITLE 119 FORMAT(16A5) READ(NFILE,129) ISCALE,CMIN,TTSTEP,NSETS,IFCALC,CBACK,TTMIN,CMON 129 FORMAT(2I8,F8.2,3I8/10F8.3/10F8.0) TTMINI=TTMIN(1) DO100I=1,NSETS 100 IF(TTMIN(I).LT.TTMINI) TTMINI=TTMIN(I) MCODE=0 IFX=1 IERCAL=0 NPLT=1 XYB(1)=TTMINI XYB(2)=150. XYB(3)=CMIN XYB(4)=5000. C ASK FOR LIMITS 12 TYPE 139 139 FORMAT(' 2THETA LIMITS ? XMIN,XMAX=') ACCEPT 119,DIN IF(DIN(1).EQ.1H ) GO TO 8 XMIN=XYB(1) XMAX=XYB(2) IF(DIN(1).NE.1H?) DECODE(70,149,DIN) XMIN,XMAX 149 FORMAT(2F) TYPE 159 159 FORMAT(' COUNT LIMITS ? YMIN,YMAX=') ACCEPT 119,DIN IF(DIN(1).EQ.1H ) GO TO 12 YMIN=XYB(3) YMAX=XYB(4) IF(DIN(1).NE.1H?) DECODE(70,149,DIN) YMIN,YMAX C DRAW AXES APPROPRIATE TO LIMITS Y(1)=YMIN Y(2)=YMAX IF(MCODE.EQ.0) GO TO 300 DO800I=1,NPLT ISC=11+ISN-I 800 CALL DELETE(ISC) DO801I=1,5 801 CALL DELETE(I+58) 300 CALL PLTGT(X,Y,ER,0,-4000,-1,-1,NTX,NTY,TITLE,0,0) ISN=0 IF(MCODE.NE.0) GO TO 5 MCODE=1 N=0 3 N=N+1 IF(IFX.EQ.0) GO TO 30 X(1)=TTMIN(N) DO301I=2,4000 301 X(I)=X(I-1)+TTSTEP C GET COUNT DATA FOR NTH GRAPH 30 KMIN=((TTMIN(N)-TTMINI)/TTSTEP)-0.5 K=0 31 K=K+1 READ(NFILE,319) (COBS(I,K),I=1,10) 319 FORMAT(10(2X,F6.0)) IF(COBS(1,K).EQ.-1000.) GO TO 33 IF(COBS(1,K).EQ.-10000.) GO TO 8 DO311I=1,10 IF(N.EQ.1) GO TO 311 IF(CMON(N).NE.0.) COBS(I,K)=COBS(I,K)*CMON(1)/CMON(N) 311 COBS(I,K)=COBS(I,K)+CBACK IF(IFCALC.EQ.0) GO TO 31 READ(NFILE,319) (CALC(I,K),I=1,10) DO312I=1,10 CALC(I,K)=CALC(I,K)+CBACK 312 DIFF(I,K)=COBS(I,K)-CALC(I,K) GO TO 31 33 KMAX=K-1 JMIN=10*KMIN JMAX=10*KMAX C SET REMAINING POINTS OUT OF BOUNDS DO331K=1,400 IF(K.GE.KMIN.OR.K.LE.KMAX) GO TO 331 DO331I=1,10 COBS(I,K)=-1000. IF(IFCALC.EQ.0) GO TO 331 CALC(I,K)=-1000. DIFF(I,K)=-1000. 331 CONTINUE C ASK CODE FOR PLOT CHARACTERS AND ERROR BARS 41 TYPE 419 419 FORMAT(' CODE FOR PLOT ? (0 TO 10) AND ERROR BARS ? Y OR N ?') ACCEPT 119,IN IF(IN(1).EQ.1H ) GO TO 12 IF(IN(1).NE.1H?) GO TO 42 TYPE 429 429 FORMAT(' CODES ARE' 2/' 1 OBLIQUE CROSSES 3 SQUARES 5 TRIANGLES' 3/' 2 VERTICAL CROSSES 4 DIAMONDS 6 CIRCLES' 4/' 0 LINE PLOT 10 POINT PLOT 10+N LINE+CHAR N PLOT') GO TO 41 42 DECODE(70,439,IN) ILUM,IFER 439 FORMAT(I,A5) IER=0 IF(IFER.NE.1HY) GO TO 44 IER=1 IF(IERCAL.NE.0) GO TO 44 IERCAL=1 DO431I=1,4000 ER(I)=0. IF(Y(I).GT.0.) ER(I)=SQRT(Y(I)) 431 CONTINUE 44 IF(MCODE.NE.4) GO TO 5 45 DO802I=1,NPLT ISC=11+ISN-I 802 CALL DELETE(ISC) DO803I=1,5 803 CALL DELETE(I+58) C DISPLAY NTH GRAPH 5 CALL PLTGT(X,Y,ER,-1,-4000,-1,-1,NTX,NTY,NTEX,ILUM,IER) ISN=ISN+1 NPLT=1 C PLOT CALCULATED PROFILE AND DIFFERENCES IF AVAILABLE IF(IFCALC.EQ.0) GO TO 51 YC(4001)=YMIN YC(4002)=YMAX YD(4001)=YMIN YD(4002)=YMAX CALL PLTGT(X,YC,ER,-1,-4000,-1,-1,NTX,NTY,NTEX,0,0) CALL PLTGT(X,YD,ER,-1,-4000,-1,-1,NTX,NTY,NTEX,0,0) ISN=ISN+2 NPLT=3 51 XYLIM(1)=XMIN XYLIM(2)=XMAX XYLIM(3)=YMIN XYLIM(4)=YMAX CALL BOUNDS(XYLIM,XYB) TYPE 519 519 FORMAT(' MODIFY THIS PLOT ? Y OR N ?') ACCEPT 119,IN IF(IN(1).EQ.1H )GO TO 8 IF(IN(1).EQ.1HN) GO TO 3 52 TYPE 529 529 FORMAT(' MOD OPTION ? (1 LIMITS, 2 ORIGIN, 3 SCALE, 4 CODE)') ACCEPT 119,IN IF(IN(1).EQ.1H ) GO TO 51 IF(IN(1).EQ.1H?) GO TO 3 DECODE(5,439,IN) MCODE IF(MCODE.LT.1.OR.MCODE.GT.4) GO TO 52 GO TO (12,62,63,41),MCODE C SHIFT ORIGIN 62 TYPE 629 629 FORMAT(' SHIFT ORIGIN ? N OR DX,DY=') ACCEPT 119,DIN IF(DIN(1).EQ.1HN) GO TO 52 DECODE(70,149,DIN) DX,DY IF(ABS(DX).LT.0.01) GO TO 622 DO621J=JMIN,JMAX 621 X(J)=X(J)+DX IFX=1 GO TO 624 622 IF(ABS(DY).LT.0.001) GO TO 52 624 DO623J=JMIN,JMAX 623 Y(J)=Y(J)+DY GO TO 45 C MULTIPLY SCALES 63 TYPE 639 639 FORMAT(' MULTIPLY SCALES ? N OR SX,SY=') ACCEPT 119,DIN IF(DIN(1).EQ.1HN) GO TO 52 DECODE(70,149,DIN) SX,SY IF(ABS(1.-SX).LT.0.001) GO TO 632 DO631J=JMIN,JMAX 631 X(J)=X(J)*SX IFX=1 GO TO 634 632 IF(ABS(1.-SY).LT.0.001) GO TO 52 634 DO633J=JMIN,JMAX 633 Y(J)=Y(J)*SY GO TO 45 8 DO81I=8,ISN+10 IS=I 81 CALL DELETE(IS) DO811I=1,5 811 CALL DELETE(I+58) CALL CLEAR(1,1) RETURN END SUBROUTINE PLTGT(X,Y,ER,NCUR,NPT,ISX,ISY,NTX,NTY,NTEX,ILUM,IER) C X ABCISSES C Y ORDONNEES NPT*NCUR VALEURS C ER NPT*NCUR ERREURS (SIPAS DE BARRES D'ERREUR Y EN PARAMETRE C NCU NOMBRE DE COURBES , SI <0 SUPERPOSEES C NPT NOMBRE DE POINTS DE CHAQUE COURBE C >0 PLOTGT CALCULE MIN ET MAX C <0 MINX=X(NPT+1) MAXX=X(NPT+2) C MINY=Y(NPT*NCUR+1) MAXY=Y(NPT*NCUR+2) C ISX,ISY >0 ECHELLES 10**EXP C <0 ECHELLES NORMALES (NOMBRE EXACT C NTX TEXTE AXES DES X TERMINE PAR $ C NTY TEXTE AXE Y C NTEX TEXTE TITRE GENERAL C ILUM 0 TRACE LIGNE CONTINUE C 1 TRACE POINTS C IER 0 PAS DE BARRES D'ERREUR C 1 BARRES D'ERREUR C C C DIMENSION NTX(1),NTY(1),NTEX(1),TXT(3),TXT1(1),ILUM(1),IER(1) DIMENSION ITAT(5),IXP(3),IYP(3),XX(3),YY(3) DIMENSION X(1),Y(1),ER(1) DIMENSION F22(2) DATA F22/'(F7.3',') '/,IXP/25,430,830/,IYP/100,350,575/ DATA ITAT/16384,32768,131072,16384,65536/,ISN/0/ ISN=ISN+1 INT=3 NPO=IABS(NPT) NCU=IABS(NCUR) IF(NCUR.LT.0)GOTO 100 ISN=1 YMAX=Y(1) YMIN=Y(1) XMIN=X(1) XMAX=X(NPO) IF(NPT.GT.0)GOTO 9 YMIN=Y(NPO*NCU+1) YMAX=Y(NPO*NCU+2) XMIN=X(NPO+1) XMAX=X(NPO+2) GOTO 20 9 DO 10 I=1,NPO*NCU YMAX=AMAX1(YMAX,Y(I)) YMIN=AMIN1(YMIN,Y(I)) 10 CONTINUE DO 8 I=1,NPO XMIN=AMIN1(XMIN,X(I)) 8 XMAX=AMAX1(XMAX,X(I)) 20 CONTINUE CALL SCROLL(5) C C C TRACER LES AXES C C C CALCUL ECHELLE AXE DES X IF(ISX)1,1,2 1 XL=XMIN XMINR=XMIN XU=XMAX XMAXR=XMAX DSX=ABS(XMAX-XMIN)/800. GOTO 3 2 CALL TDLMR(XMIN,XMAX,800.,XMINR,XMAXR,DSX,XPX,NPT) XL=XMINR*10.**XPX XU=XMAXR*10.**XPX 3 IF(ISY)4,4,5 4 YL=YMIN YMINR=YMIN YU=YMAX YMAXR=YMAX DSY=ABS(YMAX-YMIN)/500. GOTO 27 5 CALL TDLMR(YMIN,YMAX,500.,YMINR,YMAXR,DSY,YPY,NPT) YL=YMINR*10.**YPY YU=YMAXR*10.**YPY C DRAW AND LABEL AXES 27 IST=8 CALL MAKPIC(IST,27293,0) CALL SCROLL(5) CALL SCALE(XL,YL,XU,YU) CALL SCREEN(100,100,900,600) XX(1)=XMINR XX(2)=XMINR+400.*DSX XX(3)=XMAXR YY(1)=YMINR YY(2)=YMINR+250.*DSY YY(3)=YMAXR DO 12 I=1,3 IXI=IXP(I) XI=XX(I) F22(1)='(F7.1' IF(ISX.GT.0)F22(1)='(F7.3' ENCODE(7,F22,TXT)XI CALL RPOINT(IXI,70,1) CALL TEXT(TXT) 12 CONTINUE DO 13 I=1,3 IYI=IYP(I) YI=YY(I) F22(1)='(F7.1' IF(ISY.GT.0)F22(1)='(F7.3' ENCODE(7,F22,TXT)YI CALL RPOINT(0,IYI,1) CALL TEXT(TXT) 13 CONTINUE CALL RPOINT(700,40,1) CALL TEXT(NTX) IF(ISX.LT.0)GOTO 2000 140 ITX=XPX IF (XPX.LT.0.)ITX=XPX-0.2 IF (ITX)1000,2000,1000 1000 CALL RPOINT(905,100,1) CALL TEXT('10') ENCODE(3,1010,TXT1)ITX 1010 FORMAT(I3) CALL RPOINT(935,110,1) CALL TEXT(TXT1) 2000 CONTINUE IF(ISY.LT.0)GOTO 150 ITY=YPY IF(YPY.LT.0.)ITY=YPY-0.2 IF(ITY)3000,150,3000 3000 CALL RPOINT(0,610,1) CALL TEXT('10') ENCODE(3,3010,TXT2)ITY 3010 FORMAT(I3) CALL RPOINT(40,620,1) CALL TEXT(TXT2) 150 CALL RPOINT(90,610,1) CALL TEXT(NTY) C DRAW BOUNDARY LINES AND TITLE IST=9 CALL MAKPIC(IST,27293,0) CALL SCALE(XL,YL,XU,YU) CALL SCREEN(100,100,900,600) CALL LINE(XL,YL,XU,YL) CALL LINE(XU,YL,XU,YU) CALL LINE(XU,YU,XL,YU) CALL LINE(XL,YU,XL,YL) CALL RPOINT(100,15,1) CALL TEXT(NTEX) IST=10 CALL MAKPIC(IST,27291,0) CALL SCALE(XL,YL,XU,YU) CALL SCREEN(100,100,900,600) DX=ABS(XU-XL)/4. DY=ABS(YU-YL)/4. DO 11 I=1,3 XI=XL+DX*I YI=YL+DY*I CALL LINE(XI,YL,XI,YU) CALL LINE(XL,YI,XU,YI) 11 CONTINUE CALL DISPLY(8) CALL DISPLY(9) CALL DISPLY(10) IF(NCU.EQ.0) RETURN C C C C PLOT DES NCU COURBES C C C 100 DO 14 I=1,NCU ISTAT=ITAT(I)+6749 IST=IST+1 CALL MAKPIC(IST,ISTAT,0) CALL DISPLY(IST) CALL SCALE(XL,YL,XU,YU) CALL SCREEN(100,100,900,600) F1=800./(XU-XL) F2=500./(YU-YL) DO 31 K=1,NPO IF((X(K).LT.XL).OR.(X(K).GT.XU)) GOTO 31 Y1=Y(K+(I-1)*NPO) IF((Y1.LT.YL).OR.(Y1.GT.YU)) GOTO 31 IX2=((X(K)-XL)*F1+.5)+100 IY2=((Y1-YL)*F2+0.5)+100 CALL RPOINT(IX2 ,IY2 ,1) IX2=(X(K)*F1+0.5) IY2=(Y1*F2+0.5) GOTO 32 31 CONTINUE 32 CONTINUE IF (ILUM(I).NE.0)CALL CHARGT(ILUM(I),4) AER=ER(K+(I-1)*NPO) IF(IER(I).NE.0)CALL BARGT(IST,AER) 19 X3=X(K+1) IF(X3.GT.XU) GOTO 15 Y3=Y(K+1+(I-1)*NPO) IF((Y3.LT.YL).OR.(Y3.GT.YU)) GOTO 16 17 IX3=(X3*F1+0.5) IY3=(Y3*F2+0.5) IX1=IX3-IX2 IY1=IY3-IY2 CALL RVECT(IX1,IY1,ILUM(I)) IX2=IX3 IY2=IY3 X2=X3 Y2=Y3 AER=ER(K+1+(I-1)*NPO) IF (IER(I).NE.0)CALL BARGT(IST,AER) IF (ILUM(I).NE.0)CALL CHARGT(ILUM(I),4) GOTO 15 16 IF(ILUM(I).EQ.1)GOTO 15 Y1=YU IF(Y3.LT.YL)Y1=YL IY3=(Y1*F2+0.5) X1=(Y1-Y2)*(X3-X2)/(Y3-Y2)+X2 IX3=(X1*F1+0.5) IX1=IX3-IX2 IY1=IY3-IY2 CALL RVECT(IX1,IY1,ILUM(I)) IX2=IX3 IY2=IY3 X2=X1 Y2=Y1 DO 18 J=K,NPO-1 X3=X(J+1) IF(X3.GT.XU)GOTO 18 Y3=Y(J+1+(I-1)*NPO) IF((Y3.LT.YL).OR.(Y3.GT.YU)) GOTO 18 X1=X3+(Y2-Y3)*(X(J)-X3)/(Y(J+(I-1)*NPO)-Y3) IX3=(X1*F1+0.5) IX1=IX3-IX2 CALL RVECT(IX1,0,ILUM(I)) IX2=IX3 X2=X3 K=J GOTO 17 18 CONTINUE 15 K=K+1 IF(K.LT.NPO)GOTO 19 14 CONTINUE RETURN END SUBROUTINE BOUNDS(XYLIM,XYB) C C GT40 TRACER OF UPPER AND LOWER BOUNDS ON A "PLTGT" PLOT C THESE BOUNDS CAN BE MOVED TO ENCLOSE ANY PORTION OF THE PLOT C OR TO COINCIDE WITH THE POSITION OF ANY FEATURE C THE BOUND CO-ORDINATES ARE PRINTED ON THE SCREEN C AND ARE RETURNED AS ARGUMENTS "XYB" C ON ENTERING, "XYLIM" MUST CONTAIN THE PLOT LIMITS C DIMENSION XYLIM(4),XYB(4),XB(4,4),LABEL(4),BOUND(2),LPOSX(4) DIMENSION STP(2) DATA LABEL/'XL=$','XU=$','YL=$','YU=$'/ DATA LPOSX/100,250,400,550/,LPOSY/40/,NB/1/ DO111I=1,4 XYB(I)=XYLIM(I) DO111J=1,4 111 XB(I,J)=XYB(I) XB(1,2)=XYB(2) XB(3,4)=XYB(4) 10 STEP=1. IF(NB.GT.2) STEP=100. IF(NB.EQ.2.OR.NB.EQ.4) STEP=-STEP 11 NBO=NB TYPE 119 119 FORMAT(' STEP BOUNDS ?') ACCEPT 129,ACT,STP 129 FORMAT(A1,2A5) C TEST FOR CHANGE OF BOUND SETTING, (NB=1-4 FOR XL,XU,YL,YU) 120 IF(ACT.EQ.1HN) RETURN IF(ACT.NE.1H?) GO TO 13 CALL SCROLL(30) TYPE 139 139 FORMAT(///////25X,' RESPONSES ARE:' 1 /25X,' N NO, LEAVE BOUNDS AS THEY ARE' 2 /25X,' XL SET X LOWER BOUND' 3 /25X,' XU SET X UPPER BOUND' 4 /25X,' YL SET Y LOWER BOUND' 5 /25X,' YU SET Y UPPER BOUND' 6 /25X,' STEP AGAIN IN SAME DIRECTION' 7 /25X,' + STEP AGAIN IN POSITIVE DIRECTION' 8 /25X,' - STEP AGAIN IN NEGATIVE DIRECTION' 9 /25X,' +N STEP BY "N" UNITS IN +VE DIRECTION' A /25X,' -N STEP BY "N" UNITS IN -VE DIRECTION' B /25X,' *N MULTIPLY STEP BY "N"' C /25X,' /N DIVIDE STEP BY "N"'/) TYPE 119 ACCEPT 129,ACT,STP CALL SCROLL(5) GO TO 120 13 IF(ACT.EQ.1HX) NB=1 IF(ACT.EQ.1HY) NB=3 IF(STP(1).EQ.1HU) NB=NB+1 IF(NB.NE.NBO) GO TO 10 C INTERPRET STEP SIZE OR STEP FACTOR DECODE(10,219,STP) SF 219 FORMAT(F) IF(SF.LT.0.001) GO TO 22 IF(ACT.EQ.1H/) STEP=STEP/SF IF(ACT.EQ.1H*) STEP=STEP*SF IF(ACT.EQ.1H-) STEP=-SF IF(ACT.EQ.1H+) STEP=SF IF(ACT.EQ.1H ) STEP=SF GO TO 31 22 IF(ACT.EQ.1H-) STEP=-ABS(STEP) IF(ACT.EQ.1H+) STEP=+ABS(STEP) C STEP BOUND CO-ORDINATES 31 IF(NB.GT.2) GO TO 32 XB(1,NB)=XB(1,NB)+STEP IF(XB(1,NB).LT.XYLIM(1)) XB(1,NB)=XYLIM(1) IF(XB(1,NB).GT.XYLIM(2)) XB(1,NB)=XYLIM(2) XB(2,NB)=XB(1,NB) XYB(NB)=XB(1,NB) ENCODE(6,319,BOUND) XYB(NB) 319 FORMAT(F6.2) GO TO 41 32 XB(3,NB)=XB(3,NB)+STEP IF(XB(3,NB).LT.XYLIM(3)) XB(3,NB)=XYLIM(3) IF(XB(3,NB).GT.XYLIM(4)) XB(3,NB)=XYLIM(4) XB(4,NB)=XB(3,NB) XYB(NB)=XB(3,NB) ENCODE(6,329,BOUND) XYB(NB) 329 FORMAT(F5.0) C DRAW SUBPICTURE "NB" 41 ISN=59+NB CALL MAKPIC(ISN,27293,0) CALL SCREEN(100,100,900,600) CALL SCALE(XYLIM(1),XYLIM(3),XYLIM(2),XYLIM(4)) CALL LINE(XB(1,NB),XB(3,NB),XB(2,NB),XB(4,NB),0) CALL RPOINT(LPOSX(NB),LPOSY,1) CALL TEXT(LABEL(NB)) CALL RPOINT(LPOSX(NB)+45,LPOSY,1) CALL TEXT(BOUND) CALL DISPLY(ISN) GO TO 11 END SUBROUTINE PLOTT(NFILE) C C PLOTS POWDER PROFILES ON TEKTRONIX C DIMENSION X(4002),Y(4002),ER(4000),YC(4002),YD(4002) DIMENSION TTHETA(4000),COBS(10,400),CALC(10,400),DIFF(10,400) DIMENSION TITLE(16),TTMIN(10),CMON(10),NTX(4),NTY(2) DIMENSION XYLIM(4),XYB(4),DIN(14),IN(14) EQUIVALENCE (X(1),TTHETA(1)),(X(4001),XMIN),(X(4002),XMAX) EQUIVALENCE (Y(1),COBS(1,1)),(Y(4001),YMIN),(Y(4002),YMAX) EQUIVALENCE (YC(1),CALC(1,1)),(YD(1),DIFF(1,1)) DATA NTX/' 2THETA IN DEGREES '/,NTY/' COUNT '/ C READ FILE TITLE AND SETUP DATA N=0 1 REWIND NFILE NN=0 READ(NFILE,119) TITLE 119 FORMAT(16A5) READ(NFILE,129) ISCALE,CMIN,TTSTEP,NSETS,IFCALC,CBACK,TTMIN,CMON 129 FORMAT(2I8,F8.2,3I8/10F8.3/10F8.0) ICUR=1 TTMINI=TTMIN(1) DO100I=1,NSETS 100 IF(TTMIN(I).LT.TTMINI) TTMINI=TTMIN(I) MCODE=0 IFX=1 IERCAL=0 NPLT=1 XYB(1)=TTMINI XYB(2)=150. XYB(3)=CMIN XYB(4)=5000. IF(N.NE.0) GO TO 3000 C ASK FOR LIMITS 12 TYPE 139 139 FORMAT(' 2THETA LIMITS ? XMIN,XMAX=') ACCEPT 119,DIN IF(DIN(1).EQ.1H ) GO TO 8 XMIN=XYB(1) XMAX=XYB(2) IF(DIN(1).NE.1H?) DECODE(70,149,DIN) XMIN,XMAX 149 FORMAT(2F) TYPE 159 159 FORMAT(' COUNT LIMITS ? YMIN,YMAX=') ACCEPT 119,DIN IF(DIN(1).EQ.1H ) GO TO 12 YMIN=XYB(3) YMAX=XYB(4) IF(DIN(1).NE.1H?) DECODE(70,149,DIN) YMIN,YMAX C DRAW AXES APPROPRIATE TO LIMITS Y(1)=YMIN Y(2)=YMAX IF(MCODE.EQ.0) GO TO 300 300 CALL PLTGT(X,Y,ER,0,-4000,-1,-1,NTX,NTY,TITLE,0,0) ISN=0 IF(MCODE.NE.0) GO TO 5 MCODE=1 3 N=N+1 3000 IF(IFX.EQ.0) GO TO 30 X(1)=TTMIN(N) DO301I=2,4000 301 X(I)=X(I-1)+TTSTEP C GET COUNT DATA FOR NTH GRAPH 30 KMIN=((TTMIN(N)-TTMINI)/TTSTEP)-0.5 302 NN=NN+1 IF(NN.GT.N) GO TO 1 K=0 31 K=K+1 READ(NFILE,319) (COBS(I,K),I=1,10) 319 FORMAT(10(2X,F6.0)) IF(COBS(1,K).EQ.-1000.) GO TO 33 IF(COBS(1,K).EQ.-10000.) GO TO 8 DO311I=1,10 IF(N.EQ.1) GO TO 311 IF(CMON(1).NE.0.) COBS(I,K)=COBS(I,K)*CMON(1)/CMON(N) 311 COBS(I,K)=COBS(I,K)+CBACK IF(IFCALC.EQ.0) GO TO 31 READ(NFILE,319) (CALC(I,K),I=1,10) DO312I=1,10 CALC(I,K)=CALC(I,K)+CBACK 312 DIFF(I,K)=COBS(I,K)-CALC(I,K)+0.75*(YMAX-YMIN)+YMIN GO TO 31 33 IF(NN.NE.N) GO TO 302 KMAX=K-1 JMIN=10*KMIN JMAX=10*KMAX C SET REMAINING POINTS OUT OF BOUNDS DO331K=1,400 IF(K.GE.KMIN.OR.K.LE.KMAX) GO TO 331 DO331I=1,10 COBS(I,K)=-1000. IF(IFCALC.EQ.0) GO TO 331 CALC(I,K)=-1000. DIFF(I,K)=-1000. 331 CONTINUE C ASK CODE FOR PLOT CHARACTERS AND ERROR BARS 41 TYPE 419 419 FORMAT(' CODE FOR PLOT ? & ERROR BARS OR DIFF PLOT? Y OR N ?') ACCEPT 119,IN IF(IN(1).EQ.1H ) GO TO 12 IF(IN(1).NE.1H?) GO TO 42 TYPE 429 429 FORMAT(' CODES ARE' 2/' 1 OBLIQUE CROSSES 3 SQUARES 5 TRIANGLES' 3/' 2 VERTICAL CROSSES 4 DIAMONDS 6 CIRCLES' 4/' 0 LINE PLOT 10 POINT PLOT 10+N LINE+CHAR N PLOT') GO TO 41 42 DECODE(70,439,IN) ILUM,IFER 439 FORMAT(I,A5) IER=0 IF(IFCALC.EQ.1) GO TO 44 IF(IFER.NE.1HY) GO TO 44 IER=1 IF(IERCAL.NE.0) GO TO 44 IERCAL=1 DO431I=1,4000 ER(I)=0. IF(Y(I).GT.0.) ER(I)=SQRT(Y(I)) 431 CONTINUE 44 IF(MCODE.NE.4) GO TO 5 45 CONTINUE C DISPLAY NTH GRAPH 5 IF(IFCALC.NE.0) ICUR=0 CALL PLTGT(X,Y,ER,-1,-4000,-1,-1,NTX,NTY,NTEX,ILUM,IER,ICUR) ISN=ISN+1 NPLT=1 C PLOT CALCULATED PROFILE AND DIFFERENCES IF AVAILABLE IF(IFCALC.EQ.0) GO TO 51 YC(4001)=YMIN YC(4002)=YMAX YD(4001)=YMIN YD(4002)=YMAX IF(IFER.NE.'Y') ICUR=1 CALL PLTGT(X,YC,ER,-1,-3600,-1,-1,NTX,NTY,NTEX,0,0,ICUR) IF(IFER.NE.'Y') GO TO 50 ICUR=1 CALL PLTGT(X,YD,ER,-1,-3600,-1,-1,NTX,NTY,NTEX,0,0,ICUR) 50 ISN=ISN+2 NPLT=3 51 XYLIM(1)=XMIN XYLIM(2)=XMAX XYLIM(3)=YMIN XYLIM(4)=YMAX C CALL BOUNDS(XYLIM,XYB) TYPE 519 519 FORMAT(' MODIFY THIS PLOT ? Y OR N ?') ACCEPT 119,IN IF(IN(1).EQ.1H )GO TO 8 IF(IN(1).EQ.1HY) GO TO 52 IF(IFCALC.EQ.1) GO TO 8 TYPE 5119 5119 FORMAT(' COUNTER NUMBER TO PLOT ? "CR"=NEXT COUNTER') ACCEPT 119,IN IF(IN(1).EQ.' ') GO TO 3 DECODE(70,439,IN) N GO TO 3000 52 TYPE 529 529 FORMAT(' MOD OPTION ? (1 LIMITS, 2 ORIGIN, 3 SCALE, 4 CODE)') ACCEPT 119,IN IF(IN(1).EQ.1H ) GO TO 51 IF(IN(1).EQ.1H?) GO TO 3 DECODE(5,439,IN) MCODE IF(MCODE.LT.1.OR.MCODE.GT.4) GO TO 52 GO TO (12,62,63,41),MCODE C SHIFT ORIGIN 62 TYPE 629 629 FORMAT(' SHIFT ORIGIN ? N OR DX,DY=') ACCEPT 119,DIN IF(DIN(1).EQ.1HN) GO TO 52 DECODE(70,149,DIN) DX,DY IF(ABS(DX).LT.0.01) GO TO 622 DO621J=JMIN,JMAX 621 X(J)=X(J)+DX IFX=1 GO TO 624 622 IF(ABS(DY).LT.0.001) GO TO 52 624 DO623J=JMIN,JMAX 623 Y(J)=Y(J)+DY GO TO 45 C MULTIPLY SCALES 63 TYPE 639 639 FORMAT(' MULTIPLY SCALES ? N OR SX,SY=') ACCEPT 119,DIN IF(DIN(1).EQ.1HN) GO TO 52 DECODE(70,149,DIN) SX,SY IF(ABS(1.-SX).LT.0.001) GO TO 632 DO631J=JMIN,JMAX 631 X(J)=X(J)*SX IFX=1 GO TO 634 632 IF(ABS(1.-SY).LT.0.001) GO TO 52 634 DO633J=JMIN,JMAX 633 Y(J)=Y(J)*SY GO TO 45 8 CONTINUE C CALL CLEAR(1,1) RETURN END SUBROUTINE PLTGT(X,Y,ER,NCUR,NPT,ISX,ISY,NTX,NTY,NTEX,ILUM,IER) C X ABCISSES C Y ORDONNEES NPT*NCUR VALEURS C ER NPT*NCUR ERREURS (SIPAS DE BARRES D'ERREUR Y EN PARAMETRE C NCU NOMBRE DE COURBES , SI <0 SUPERPOSEES C NPT NOMBRE DE POINTS DE CHAQUE COURBE C >0 PLOTGT CALCULE MIN ET MAX C <0 MINX=X(NPT+1) MAXX=X(NPT+2) C MINY=Y(NPT*NCUR+1) MAXY=Y(NPT*NCUR+2) C ISX,ISY >0 ECHELLES 10**EXP C <0 ECHELLES NORMALES (NOMBRE EXACT C NTX TEXTE AXES DES X TERMINE PAR $ C NTY TEXTE AXE Y C NTEX TEXTE TITRE GENERAL C ILUM 0 TRACE LIGNE CONTINUE C 1 TRACE POINTS C 2 POINTILLE C IER 0 PAS DE BARRES D'ERREUR C 1 BARRES D'ERREUR C ICUR 0 PAS DE FENETRE C 1 FENETRE C C C DIMENSION NTX(1),NTY(1),NTEX(1),TXT(3) DIMENSION ITAT(5),IXP(3),IYP(3),XX(3),YY(3),JXP(3),JYP(3) DIMENSION X(1),Y(1),ER(1) DIMENSION F22(3) DATA IXP/30,430,830/,IYP/100,350,580/ DATA F22/'( ' ,'F7.3,',' )'/ DATA ITEN/' '/ CALL NARG(ICUR) IF(NCUR.LT.0) CALL INIT(240) IF(NCUR.GE.0) CALL INITT(240) NPO=IABS(NPT) NCU=IABS(NCUR) IF(NCUR.LT.0)GOTO 150 CALL INITT(240) YMAX=Y(1) YMIN=Y(1) XMIN=X(1) XMAX=X(NPO) IF(NPT.GT.0)GOTO 9 YMIN=Y(NPO*NCU+1) YMAX=Y(NPO*NCU+2) XMIN=X(NPO+1) XMAX=X(NPO+2) GOTO 20 9 DO 10 I=1,NPO*NCU ICA=I YMAX=AMAX1(YMAX,Y(I)) YMIN=AMIN1(YMIN,Y(I)) 10 CONTINUE DO 8 I=1,NPO XMIN=AMIN1(XMIN,X(I)) 8 XMAX=AMAX1(XMAX,X(I)) 20 CONTINUE C C C TRACER LES AXES C C C CALCUL ECHELLE AXE DES X 4000 IF(ISX)1,1,2 1 XL=XMIN XMINR=XMIN XU=XMAX XMAXR=XMAX DSX=ABS(XMAX-XMIN)/800. GOTO 3 2 CALL TDLMR(XMIN,XMAX,800.,XMINR,XMAXR,DSX,XPX,NPT) XL=XMINR*10.**XPX XU=XMAXR*10.**XPX 3 IF(ISY)4,4,5 4 YL=YMIN YMINR=YMIN YU=YMAX YMAXR=YMAX DSY=ABS(YMAX-YMIN)/500. GOTO 27 5 CALL TDLMR(YMIN,YMAX,500.,YMINR,YMAXR,DSY,YPY,NPT) YL=YMINR*10.**YPY YU=YMAXR*10.**YPY 27 DRX=800./ABS(XU-XL) DRY=500./ABS(YU-YL) XX(1)=XMINR XX(2)=XMINR+400.*DSX XX(3)=XMAXR YY(1)=YMINR YY(2)=YMINR+250.*DSY YY(3)=YMAXR C C TRACE DU CADRE C CALL MOVABS(0,15) C CALL ANMODE CALL AOUTST(72,NTEX) CALL MOVABS(100,100) CALL DRWABS(900,100) CALL DRWABS(900,600) CALL DRWABS(100,600) CALL DRWABS(100,100) IDX=200 IDY=125 DO 11 I=1,3 IXI=100+IDX*I IYI=100+IDY*I CALL MOVABS(IXI,100) CALL DRWABS(IXI,600) CALL MOVABS(100,IYI) CALL DRWABS(900,IYI) 11 CONTINUE DO 12 I=1,3 IXI=IXP(I) XI=XX(I) F22(2)='F7.1,' IF(ISX.GT.0)F22(2)='F7.3,' CALL MOVABS(IXI,70) ENCODE(7,F22,TXT)XI CALL AOUTST(7,TXT) 12 CONTINUE DO 13 I=1,3 IYI=IYP(I) YI=YY(I) F22(2)='F7.1,' IF(ISY.GT.0)F22(2)='F7.3,' CALL MOVABS(1,IYI) C CALL ANMODE C TYPE F22,YI ENCODE(7,F22,TXT)YI CALL AOUTST(7,TXT) 13 CONTINUE CALL MOVABS(650,40) C CALL ANMODE CALL AOUTST(20,NTX) IF(ISX.LT.0)GOTO 2000 140 ITX=XPX IF (XPX.LT.0.)ITX=XPX-0.2 IF (ITX)1000,2000,1000 1000 CALL MOVABS(905,100) ITEN='10 ' C TYPE 331,ITEN CALL AOUTST(2,ITEN) 331 FORMAT(1H+,I2,$) CALL MOVABS(935,110) C CALL ANMODE C TYPE 332,ITX ENCODE(3,332,TXT1) ITX CALL AOUTST(3,TXT1) 332 FORMAT(I3,$) 2000 CONTINUE CALL MOVABS(10,620) C CALL ANMODE C TYPE 333,NTY CALL AOUTST(10,NTY) 333 FORMAT(1H+,3A5) IF(ISY.LT.0)GOTO 150 ITY=YPY IF(YPY.LT.0.)ITY=YPY-0.2 IF(ITY)3000,150,3000 3000 CALL MOVABS(1,610) C CALL ANMODE C TYPE 331,ITEN CALL AOUTST(2,ITEN) CALL MOVABS(31,620) C CALL ANMODE C TYPE 332,ITY ENCODE (3,332,TXT1)ITY CALL AOUTST(3,TXT1) C C C C C PLOT DES NCU COURBES C C C 150 IF(NCU.EQ.0) GO TO 400 CALL SWINDO(100,800,100,500) CALL DWINDO(XL,XU,YL,YU) DO 14 I=1,NCU F1=800./(XU-XL) F2=500./(YU-YL) DO 31 K=1,NPO IF((X(K).LT.XL).OR.(X(K).GT.XU)) GOTO 31 Y1=Y(K+(I-1)*NPO) IF((Y1.LT.YL).OR.(Y1.GT.YU)) GOTO 31 IX2=((X(K)-XL)*F1+.5)+100 IY2=((Y1-YL)*F2+0.5)+100 CALL MOVABS(IX2 ,IY2 ) GOTO 32 31 CONTINUE 32 CONTINUE IF (ILUM.EQ.1)CALL PNTABS(IX2,IY2) AER=ER(K+(I-1)*NPO) IF(IER.EQ.1)CALL BARTEK(AER) 19 X3=X(K+1) IF(X3.GT.XU) GOTO 15 Y3=Y(K+1+(I-1)*NPO) IF((Y3.LT.YL).OR.(Y3.GT.YU)) GOTO 16 17 IX3=((X3-XL)*F1+.5)+100 IY3=((Y3-YL)*F2+0.5)+100 IF(ILUM.EQ.0) CALL DRWABS(IX3,IY3) IF(ILUM.EQ.1)CALL PNTABS(IX3,IY3) II=I IF(ILUM.EQ.2)CALL DSHABS(IX3,IY3,II) IX2=IX3 IY2=IY3 X2=X3 Y2=Y3 AER=ER(K+1+(I-1)*NPO) IF (IER.EQ.1)CALL BARTEK(AER) GOTO 15 16 IF(ILUM.EQ.1)GOTO 15 Y1=YU IF(Y3.LT.YL)Y1=YL X1=(Y1-Y2)*(X3-X2)/(Y3-Y2)+X2 IY3=((Y1-YL)*F2+0.5)+100 IX3=((X1-XL)*F1+.5)+100 IX1=IX3-IX2 IY1=IY3-IY2 IF(ILUM.EQ.0) CALL DRWABS(IX3,IY3) II=I IF(ILUM.EQ.2) CALL DSHABS(IX3,IY3,II) IX2=IX3 IY2=IY3 X2=X1 Y2=Y1 DO 18 J=K,NPO-1 X3=X(J+1) IF(X3.GT.XU)GOTO 18 Y3=Y(J+1+(I-1)*NPO) IF((Y3.LT.YL).OR.(Y3.GT.YU)) GOTO 18 X1=X3+(Y2-Y3)*(X(J)-X3)/(Y(J+(I-1)*NPO)-Y3) IX3=((X1-XL)*F1+.5)+100 IF(ILUM.EQ.0) CALL DRWABS(IX3,IY3) II=I IF(ILUM.EQ.2) CALL DSHABS(IX3,IY3,II) IX2=IX3 X2=X3 K=J GOTO 17 18 CONTINUE 15 K=K+1 IF(K.LT.NPO)GOTO 19 14 CONTINUE IF(ICUR.EQ.0) GO TO 400 OPEN(UNIT=38,FILE='FILEP.DAT',ACCESS='APPEND') OPEN(UNIT=39,FILE='FILEB.DAT',ACCESS='APPEND') 501 CALL VCURSR(ICH1,XMIN,YMIN) IF(ICH1.EQ.69) GO TO 401 IF(ICH1.NE.63) GO TO 503 CALL MOVABS(0,730) CALL ANMODE TYPE 509 GO TO 501 503 IF(ICH1.NE.88.AND.ICH1.NE.89.AND.ICH1.NE.80.AND.ICH1.NE.66)GOTO502 CALL POSIT(ICH1,XMIN,YMIN) IF(ICH1.EQ.66) CALL FILEBK(39,XMIN,YMIN) IF(ICH1.EQ.80) CALL FILEPK(38,XMIN,YMIN) GO TO 501 502 CALL VCURSR(ICH2,XMAX,YMAX) IF(ICH2.EQ.69) GO TO 401 IF(ICH2.NE.88.AND.ICH2.NE.89.AND.ICH2.NE.80.AND.ICH2.NE.66)GOTO404 CALL POSIT(ICH2,XMAX,YMAX) IF(ICH2.EQ.66) CALL FILEBK(39,XMAX,YMAX) IF(ICH2.EQ.80) CALL FILEPK(38,XMAX,YMAX) GO TO 502 509 FORMAT(30X,'SET CURSOR, TYPE A CHARACTER AND RETURN'/ 1 30X,'E =EXIT FROM CURSOR MODE'/ 2 30X,'X =X-POSITION OF CURSOR'/ 2 30X,'Y =Y-POSITION OF CURSOR'/ 3 30X,'P =X,Y POSITION PUT IN "FILEP.DAT"'/ 3 30X,'B =X,Y POSITION PUT IN "FILEB.DAT"'/ 4 30X,'ANY OTHER CHAR =SET PLOT LIMITS') 404 CALL ERASE GO TO 4000 401 CLOSE(UNIT=38) CLOSE(UNIT=39) 400 CALL IOWAIT(5) CALL FINITT(0,767) RETURN END SUBROUTINE FILEBK(N,X,Y) IX=100.*X+0.5 IY=Y+0.5 WRITE(N,19) IX,IY 19 FORMAT(2I8) RETURN END SUBROUTINE FILEPK(N,X,Y) WRITE(N,19) X,Y 19 FORMAT(F8.3,F8.2) RETURN END SUBROUTINE POSIT(ICH,X,Y) DIMENSION PX(2),PY(2) CALL MOVEA(X,Y) IF(ICH.EQ.89) GO TO 21 C DRAW X-MARKER CALL MOVREL(0,-10) CALL DRWREL(0,20) CALL MOVREL(-65,5) ENCODE(7,119,PX) X 119 FORMAT(F7.2) CALL AOUTST(7,PX) CALL MOVEA(X,Y) 21 IF(ICH.EQ.88) GO TO 31 C DRAW Y-MARKER CALL MOVREL(-10,0) CALL DRWREL(20,0) CALL MOVREL(-60,-30) ENCODE(7,129,PY) Y 129 FORMAT(F7.0) CALL AOUTST(7,PY) CALL MOVEA(X,Y) 31 RETURN END SUBROUTINE PLOTK(NFILE) C C PLOTS POWDER PROFILES ON CALCOMP C DIMENSION X(4002),Y(4002),ER(4000),YC(4002),YD(4002) DIMENSION TTHETA(4000),COBS(10,400),CALC(10,400),DIFF(10,400) DIMENSION TITLE(10),TTMIN(10),CMON(10),NTX(4),NTY(4) DIMENSION XYLIM(4),XYB(4),DIN(14),IN(14) EQUIVALENCE (X(1),TTHETA(1)),(X(4001),XMIN),(X(4002),XMAX) EQUIVALENCE (Y(1),COBS(1,1)),(Y(4001),YMIN),(Y(4002),YMAX) EQUIVALENCE (YC(1),CALC(1,1)),(YD(1),DIFF(1,1)) DATA NTX/' 2THETA IN DEGREES'/,NTY/' COUNT'/ DATA HAUT,M,HPT/0.8,-1,0.2/ C READ FILE TITLE AND SETUP DATA REWIND NFILE READ(NFILE,119) TITLE 119 FORMAT(16A5) READ(NFILE,129) ISCALE,CMIN,TTSTEP,NSETS,IFCALC,CBACK,TTMIN,CMON 129 FORMAT(2I8,F8.2,3I8/10F8.3/10F8.0) TTMINI=TTMIN(1) DO100I=1,NSETS 100 IF(TTMIN(I).LT.TTMINI) TTMINI=TTMIN(I) MCODE=0 IFX=1 IERCAL=0 NPLT=1 XYB(1)=TTMINI XYB(2)=160. XYB(3)=CMIN XYB(4)=4000. C ASK FOR LIMITS 12 TYPE 139 139 FORMAT(' 2THETA LIMITS ? XMIN,XMAX=') ACCEPT 119,DIN IF(DIN(1).EQ.1H ) GO TO 8 XMIN=XYB(1) XMAX=XYB(2) IF(DIN(1).NE.1H?) DECODE(70,149,DIN) XMIN,XMAX 149 FORMAT(2F) 14 TYPE 159 159 FORMAT(' COUNT LIMITS ? YMIN,YMAX=') ACCEPT 119,DIN IF(DIN(1).EQ.1H ) GO TO 12 YMIN=XYB(3) YMAX=XYB(4) IF(DIN(1).NE.1H?) DECODE(70,149,DIN) YMIN,YMAX C DRAW AXES APPROPRIATE TO LIMITS Y(1)=YMIN Y(2)=YMAX TYPE 309 309 FORMAT(' PLOT SIZE (CM) ? X,Y=') ACCEPT 119,DIN IF(DIN(1).EQ.1H ) GO TO 14 ISX=XMAX-XMIN ISY=(YMAX-YMIN)/100. IF(DIN(1).NE.1H?) DECODE(70,169,DIN) ISX,ISY ISX=-ISX ISY=-ISY 169 FORMAT(2I) 300 CALL PLTCAL(X,Y,ER,0,-4000,ISX,ISY,NTX,NTY,TITLE,HAUT,M,HPT,0,0) ISN=0 IF(MCODE.NE.0) GO TO 5 MCODE=1 N=0 3 N=N+1 IF(IFX.EQ.0) GO TO 30 X(1)=TTMIN(N) DO301I=2,4000 301 X(I)=X(I-1)+TTSTEP C GET COUNT DATA FOR NTH GRAPH 30 KMIN=((TTMIN(N)-TTMINI)/TTSTEP)-0.5 K=0 31 K=K+1 READ(NFILE,319) (COBS(I,K),I=1,10) 319 FORMAT(10(2X,F6.0)) IF(COBS(1,K).EQ.-1000.) GO TO 33 IF(COBS(1,K).EQ.-10000.) GO TO 8 DO311I=1,10 IF(N.EQ.1) GO TO 311 IF(CMON(N).NE.0.) COBS(I,K)=COBS(I,K)*CMON(1)/CMON(N) 311 COBS(I,K)=COBS(I,K)+CBACK IF(IFCALC.EQ.0) GO TO 31 READ(NFILE,319) (CALC(I,K),I=1,10) DO312I=1,10 CALC(I,K)=CALC(I,K)+CBACK 312 DIFF(I,K)=COBS(I,K)-CALC(I,K) GO TO 31 33 KMAX=K-1 JMIN=10*KMIN JMAX=10*KMAX C SET REMAINING POINTS OUT OF BOUNDS DO331K=1,400 IF(K.GE.KMIN.OR.K.LE.KMAX) GO TO 331 DO331I=1,10 COBS(I,K)=-1000. IF(IFCALC.EQ.0) GO TO 331 CALC(I,K)=-1000. DIFF(I,K)=-1000. 331 CONTINUE C ASK CODE FOR PLOT CHARACTERS AND ERROR BARS 41 TYPE 419 419 FORMAT(' CODE FOR PLOT ? (0 TO 10) AND ERROR BARS ? Y OR N ?') ACCEPT 119,IN IF(IN(1).EQ.1H ) GO TO 12 IF(IN(1).NE.1H?) GO TO 42 TYPE 429 429 FORMAT(' CODES ARE' 2/' 1 OBLIQUE CROSSES 3 SQUARES 5 TRIANGLES' 3/' 2 VERTICAL CROSSES 4 DIAMONDS 6 CIRCLES' 4/' 0 LINE PLOT 10 POINT PLOT 10+N LINE+CHAR N PLOT') GO TO 41 42 DECODE(70,439,IN) ILUM,IFER 439 FORMAT(I,A5) IER=0 IF(IFER.NE.1HY) GO TO 44 IER=1 IF(IERCAL.NE.0) GO TO 44 IERCAL=1 DO431I=1,4000 ER(I)=0. IF(Y(I).GT.0.) ER(I)=SQRT(Y(I)) 431 CONTINUE 44 IF(MCODE.NE.4) GO TO 5 45 CONTINUE C DISPLAY NTH GRAPH 5 CALL PLTCAL(X,Y,ER,-1,-4000,ISX,ISY,NTX,NTY,NTEX,HAUT,M,HPT, 1 ILUM,IER) ISN=ISN+1 NPLT=1 C PLOT CALCULATED PROFILE AND DIFFERENCES IF AVAILABLE IF(IFCALC.EQ.0) GO TO 51 YC(4001)=YMIN YC(4002)=YMAX YD(4001)=YMIN YD(4002)=YMAX CALL PLTCAL(X,YC,ER,-1,-4000,ISX,ISY,NTX,NTY,NTEX,HAUT,M,HPT,0,0) CALL PLTCAL(X,YD,ER,-1,-4000,ISX,ISY,NTX,NTY,NTEX,HAUT,M,HPT,0,0) ISN=ISN+2 NPLT=3 51 XYLIM(1)=XMIN XYLIM(2)=XMAX XYLIM(3)=YMIN XYLIM(4)=YMAX C CALL BOUNDS(XYLIM,XYB) TYPE 519 519 FORMAT(' MODIFY THIS PLOT ? Y OR N ?') ACCEPT 119,IN IF(IN(1).EQ.1H )GO TO 8 IF(IN(1).EQ.1HN) GO TO 3 52 TYPE 529 529 FORMAT(' MOD OPTION ? (1 LIMITS, 2 ORIGIN, 3 SCALE, 4 CODE)') ACCEPT 119,IN IF(IN(1).EQ.1H ) GO TO 51 IF(IN(1).EQ.1H?) GO TO 3 DECODE(5,439,IN) MCODE IF(MCODE.LT.1.OR.MCODE.GT.4) GO TO 52 GO TO (12,62,63,41),MCODE C SHIFT ORIGIN 62 TYPE 629 629 FORMAT(' SHIFT ORIGIN ? N OR DX,DY=') ACCEPT 119,DIN IF(DIN(1).EQ.1HN) GO TO 52 DECODE(70,149,DIN) DX,DY IF(ABS(DX).LT.0.01) GO TO 622 DO621J=JMIN,JMAX 621 X(J)=X(J)+DX IFX=1 GO TO 624 622 IF(ABS(DY).LT.0.001) GO TO 52 624 DO623J=JMIN,JMAX 623 Y(J)=Y(J)+DY GO TO 45 C MULTIPLY SCALES 63 TYPE 639 639 FORMAT(' MULTIPLY SCALES ? N OR SX,SY=') ACCEPT 119,DIN IF(DIN(1).EQ.1HN) GO TO 52 DECODE(70,149,DIN) SX,SY IF(ABS(1.-SX).LT.0.001) GO TO 632 DO631J=JMIN,JMAX 631 X(J)=X(J)*SX IFX=1 GO TO 634 632 IF(ABS(1.-SY).LT.0.001) GO TO 52 634 DO633J=JMIN,JMAX 633 Y(J)=Y(J)*SY GO TO 45 8 RETURN END SUBROUTINE PLTCAL(X,Y,ER,NCUR,K,ISX,ISY,NTX,NTY,NTEX,HAUT, 1M,HPT,ILUM,IER) C DIMENSION X(1),Y(1),ER(1),NTX(1),NTY(1),NTEX(1),NEXT(12) DIMENSION XOR(10),YOR(10) C DATA NBLANK/' '/ DATA XOR/10*0./,YOR/10*0./ C C X=ABSCISSES DES POINTS A TRACER C Y=ORDONNEES DES POINTS A TRACER C ER=ERREUR ABSOLUE SUR LES ORDONNEES C NCUR NOMBRE DE COURBES,SI <0 COURBES SUPERPOSEES AVEC C APPEL PRECEDENT A PLTCAL C VALEUR ABSOLUE DE K= NOMBRE DE POINTS A TRACER C SI K EST NEGATIF DONNER K+2 VALEURS: C X(K+1)=VALEUR MINIMUM DE X C X(K+2)=VALEUR MAXIMUM DE X C Y(K*NCU+1)=VALEUR MINIMUM DE Y C Y(K*NCU+2)=VALEUR MAXIMUM DE Y C ISX=DIMENSION DU GRAPHIQUE SUIVANT X C ISY=DIMENSION DU GRAPHIQUE SUIVANT Y C NTX=TEXTE SUIVANT L'AXE DES X (10 CARACTERES MAXIMUM) C NTY=TEXTE SUIVANT L'AXE DES Y (10 CARACTERES MAXIMUM) C NTEX=TEXTE PRINCIPAL (M LIGNES DE 50 CARACTERES) C HAUT HAUTEUR EN CM DES CARACTERES TEXTE PRINCIPAL C M=NOMBRE DE LIGNES DU TEXTE PRINCIPAL C SI M EST NEGATIF TRACER D'UN CADRE C HPT=HAUTEUR DU SYMBOLE UTILISE EN CM C ILUM = 0 TRACE CONTINU C 1 TRACE PONINTS C IER = 0 PAS DE BARRE D'ERREUR C 1 BARRE D'ERREUR C PX=IABS(ISX) PY=IABS(ISY) HN=HAUT/2 N=IABS(K) NCU=IABS(NCUR) NY=N*NCU IF(NCUR)1,19,19 19 IF(IPLOT)20,20,22 20 CALL PLOTS(IFREE) LX=PX+8*HAUT+3 26 LY=PY+(2*IABS(M)+2)*HAUT+2.3 NTRY=70/LY IF(NTRY.GT.0)GOTO 28 PY=PY-1 WRITE(8,800)PY 800 FORMAT(' PY TROP GRAND ESSAI AVEC :',F) GOTO 26 28 XOR(1)=LX IF(NTRY.EQ.1)GOTO 25 YOR(1)=-(NTRY-1)*LY DO 27 I=2,NTRY 27 YOR(I)=LY 25 YMIN=(2*IABS(M)+1)*HAUT+1.3 XMIN=6*HAUT GOTO 29 22 I=MOD(IPLOT,NTRY) XMIN=XOR(I+1) YMIN=YOR(I+1) 29 IPLOT=IPLOT+1 C IF(K.LT.0)GO TO 60 SMAX=X(1) SMIX=X(1) SMAY=Y(1) SMIY=Y(1) DO 10 I=1,NY SMIY=AMIN1(SMIY,Y(I)) SMAY=AMAX1(SMAY,Y(I)) 10 CONTINUE DO 100 I=1,N SMIX=AMIN1(SMIX,X(I)) SMAX=AMAX1(SMAX,X(I)) 100 CONTINUE GO TO 61 60 CONTINUE SMIX=X(N+1) SMAX=X(N+2) SMIY=Y(NY+1) SMAY=Y(NY+2) 61 CONTINUE C 2 CALL PLOT(XMIN,YMIN,-3) C C DETERMINATION DES ECHELLES SUR LES 2 AXES (ARRONDIES) C CALL TDLMR(SMIX,SMAX,PX,SMIRX,SMARX,DSX,EXPX,K) ECHX=DSX*10.**EXPX CALL TDLMR(SMIY,SMAY,PY,SMIRY,SMARY,DSY,EXPY,K) ECHY=DSY*10.**EXPY C C TRACER DES AXES ET DU CADRE C CALL AXIST4(0.,0.,DSX,DSY,EXPX,EXPY,NTX,NTY,ISX,ISY, 1 SMIRX,SMARY,HN) C C C ECRIRURE DU TEXTE PRINCIPAL C IF(M.EQ.0)GO TO 74 M1=IABS(M) DO 11 J=1,M1 YD=-(J*2*HAUT+0.7) XD=0. J2=10*(J-1) DO 13 J1=1,10 12 NEXT(J1)=NBLANK 13 NEXT(J1)=NTEX(J2+J1) CALL SYMBOL(XD,YD,HAUT,NEXT,0.,50) 11 CONTINUE C IF(M.GE.0)GO TO 74 XD=-6*HAUT CALL PLOT(XD,YD-HAUT,3) CALL PLOT(PX+2*HAUT,YD-HAUT,2) CALL PLOT(PX+2*HAUT,PY+HAUT,2) CALL PLOT(XD,PY+HAUT,2) CALL PLOT(XD,YD-HAUT,2) 74 CONTINUE C 1 IF(ILUM)54,54,51 C C C TRACER D'UN NUAGE DE POINTS SANS BARRE D'ERREUR C 51 DO 53 I=1,N XX=X(I)/ECHX-SMIRX/DSX IF((XX.GT.PX).OR.(XX.LT.0.))GO TO 53 DO 53 J=1,NCU YY=Y(I+(J-1)*N)/ECHY-SMIRY/DSY IF((YY.GT.PY).OR.(YY.LT.0.))GO TO 53 JIN=J CALL POINTS(XX,YY,HPT,JIN) C C TRACE AVEC BARRES D'ERREUR C IF(IER.EQ.0)GOTO 53 ERS=ER(I)/ECHY IF(ERS.LT.0.17)GO TO 52 N1=-1 56 YE=YY+0.17*N1 CALL PLOT(XX,YE,3) YE=YY+ERS*N1 IF(YE.GT.PY)YE=PY IF(YE.LT.0.)YE=0. CALL PLOT(XX,YE,2) XE=XX-0.12 CALL PLOT(XE,YE,3) CALL PLOT(XE+0.24,YE,2) N1=N1+2 GO TO(56,52,52)N1 52 CONTINUE 53 CONTINUE C PLUME HAUTE AU RETURN GOTO 999 C C TRACER D'UNE COURBE CONTINUE C 54 I=1 NX=N IPEN=3 K3=1 DO 99 J=1,NCU 90 YY=Y(I+(J-1)*N)/ECHY-SMIRY/DSY XX=X(I)/ECHX-SMIRX/DSX IF((XX.GT.PX).OR.(XX.LT.0.))GO TO 98 IF((YY.GE.0.).AND.(YY.LE.PY))GOTO 97 IPEN=1 93 Y2=PY IF(YY.LT.0.)Y2=0. X1=X(I-K3)/ECHX-SMIRX/DSX Y1=Y(I+(J-1)*N-K3)/ECHY-SMIRY/DSY X2=(X1-XX)/(Y1-YY)*(Y2-YY)+XX CALL PLOT(X2,Y2,IPEN) IF(IPEN.EQ.3)GOTO 977 95 I=I+K3 IF(I.EQ.NX)GOTO 96 XX=X(I)/ECHX-SMIRX/DSX YY=Y(I+(J-1)*N)/ECHY-SMIRY/DSY IF((YY.LT.0.).OR.(YY.GT.PY))GOTO 95 IPEN=3 GOTO 93 977 IPEN=2 97 CALL PLOT(XX,YY,IPEN) IPEN=2 C C TRACE LIGNE CONTINUE ET BARRES D'ERREUR C IF(IER.EQ.0)GOTO 98 ERS=ER(I+(J-1)*N)/ECHY N1=-1 X1=XX-0.12 X2=XX+0.12 91 Y1=YY+ERS*N1 IF(Y1.GT.PY)Y1=PY IF(Y1.LT.0.)Y1=0. CALL PLOT(X1,Y1,3) CALL PLOT(X2,Y1,2) CALL PLOT(XX,Y1,3) CALL PLOT(XX,YY,2) N1=N1+2 GOTO(91)N1 98 IF(I.EQ.NX)GOTO 96 I=I+K3 GOTO 90 96 K3=-K3 NX=MAX0(1,K3*N) 99 CONTINUE C 999 CALL WHERE(XX,YY,RFACT) CALL PLOT(XX,YY,3) RETURN END SUBROUTINE TDLMR(SMIX,SMAX,DAP,SMIR,SMAR,DS,XP,K) DIMENSION A(36) DATA A/1.1,1.2,1.3,1.4,1.5,1.6,1.7,1.8,1.9,2.,2.2,2.4,2.5,2.6,2. 18,3.,3.2,3.4,3.5,3.6,3.8,4.,4.5,5.,5.5,6.,6.5,7.,7.5,8.,8.5,9.,9 2.5,10.,11.,12./ IF((SMIX.LT.SMAX).AND.(DAP.GT.0.))GO TO 10 WRITE(6,11)SMIX,SMAX,DAP 11 FORMAT(///10X,'SMI =',E13.5,5X,'SMA =',E13.5,10X,'DIMENSION ='E13. 15) STOP 10 SMA=AMAX1(ABS(SMAX),ABS(SMIX)) SMI=0. DAM=1. 9 IF(SMA-SMI-DAM) 2,2,1 1 DO 3 I=1,75 J=1-I IF(((SMA-SMI)*10.**(-I)).LT.DAM) GO TO 4 3 CONTINUE 2 DO 5 I=1,75 J=I-1 IF(((SMA-SMI)*10.**J).GT.DAM) GO TO 4 5 CONTINUE 4 IP=-J IF(DAM.EQ.1.) GO TO 8 IF(K.GT.0)GO TO 30 DS=(SMA-SMI)/DAM SMIR=SMI SMAR=SMA RETURN 30 DO 6 I=1,36 DS=A(I)*10.**IP SMIR=AINT(SMI/DS)*DS IF(SMI.LT.0)SMIR=SMIR-DS SMAR=SMIR+DAM*DS SM1=SMIR-SMI SM2=SMA-SMAR IF((SM1.LT.1.E-05).AND.(SM2.LT.1.E-05))RETURN 6 CONTINUE 8 EX=10.**IP SMI=SMIX/EX SMA=SMAX/EX DAM=DAP XP=IP GO TO 9 RETURN END SUBROUTINE POINTS(X,Y,H,N) A=0.5*H B=0.3333*H C=2.*B TET=0.7854 GO TO (1,2,3,4,5,1,7,8,9)N 1 CALL PLOT(X+A,Y-A,3) CALL PLOT(X-A,Y+A,2) CALL PLOT(X-A,Y-A,3) CALL PLOT(X+A,Y+A,2) IF(N.NE.6)GO TO 11 2 CALL PLOT(X,Y-A,3) CALL PLOT(X,Y+A,2) CALL PLOT(X-A,Y,3) CALL PLOT(X+A,Y,2) GO TO 11 3 CALL PLOT(X+A,Y-B,3) CALL PLOT(X,Y+C,2) CALL PLOT(X-A,Y-B,2) CALL PLOT(X+A,Y-B,2) GO TO 11 4 CALL PLOT(X+A,Y-A,3) CALL PLOT(X+A,Y+A,2) CALL PLOT(X-A,Y+A,2) CALL PLOT(X-A,Y-A,2) CALL PLOT(X+A,Y-A,2) GO TO 11 5 CALL PLOT(X,Y-A,3) CALL PLOT(X+A,Y,2) CALL PLOT(X,Y+A,2) CALL PLOT(X-A,Y,2) CALL PLOT(X,Y-A,2) GO TO 11 7 CALL PLOT(X+A,Y-A,3) CALL PLOT(X-A,Y+A,2) CALL PLOT(X+A,Y+A,2) CALL PLOT(X-A,Y-A,2) CALL PLOT(X+A,Y-A,2) GO TO 11 8 CALL PLOT(X+A,Y-A,3) CALL PLOT(X-A,Y+A,2) CALL PLOT(X-A,Y-A,2) CALL PLOT(X+A,Y+A,2) CALL PLOT(X+A,Y-A,2) GO TO 11 9 CALL PLOT(X+A,Y,3) DO 10 I=1,8 TETA=I*TET U=X+A*COS(TETA) V=Y+A*SIN(TETA) CALL PLOT(U,V,2) 10 CONTINUE 11 CALL PLOT(X,Y,3) RETURN END SUBROUTINE AXIST4(XD,YD,PSX,PSY,EXPX,EXPY,NTX,NTY,IPX,IPY,PMIRX, 1 PMARY,HN) DIMENSION NTX(1),NTY(1) DATA DIX/'10010'/ X=XD Y=YD PX=IABS(IPX) PY=IABS(IPY) IF(IPX)13,13,14 13 SMIRX=PMIRX*10**EXPX DSX=PSX*10**EXPX GOTO 15 14 SMIRX=PMIRX DSX=PSX 15 IF(IPY)16,16,17 16 SMARY=PMARY*10**EXPY DSY=PSY*10**EXPY GOTO 18 17 SMARY=PMARY DSY=PSY 18 IX=IABS(IPX) IY=IABS(IPY) HT=HN*6/5 HP=HN*4/5 K=1 N=1 CALL PLOT(X,Y,3) XI=X-2.5*HN YI=Y-2*HN CALL NUMBER(XI,YI,HN,SMIRX,0.,3) 1 DO 10 I=1,IX CALL PLOT(X,Y,3) X=X+N CALL PLOT(X,Y,2) J=I IF(N.LT.0)J=IX-I IF((MOD(J,5)).EQ.0)GO TO 11 YI=Y+0.1*N CALL PLOT(X,YI,2) GO TO 10 11 YI=Y+0.3*N CALL PLOT(X,YI,2) GO TO (20,10),K 20 XI=X-2.5*HN YI=Y-2*HN S=SMIRX+I*DSX CALL NUMBER(XI,YI,HN,S,0.,3) 10 CONTINUE GO TO(3,12)K C C ECRITURE DE L'ECHELLE SUR L'AXE OX C 3 NEX=1 IF(IPX.LT.0)GOTO 8 ITX=EXPX+0.2 IF(EXPX.LT.0.)ITX=EXPX-0.2 IF((IABS(ITX)).GE.10)NEX=2 IF(ITX)7,8,9 7 NEX=NEX+1 9 XI=PX-(HT*2+NEX*HP)+XD YI=-4*HN+YD CALL SYMBOL(XI,YI,HT,DIX,0.,2) XI=XI+2*HT YI=YI+HT/2 CALL NUMBER(XI,YI,HP,EXPX,0.,-1) 8 XI=PX-(20*HT+HT*2+NEX*HP)+XD YI=-4*HN+YD CALL SYMBOL(XI,YI,HT,NTX,0.,20) GO TO 2 C C ECRITURE DE L'ECHELLE SUR L'AXE OY C 12 NEX=1 IF(IPY.LT.0)GOTO 5 ITY=EXPY+0.2 IF(EXPY.LT.0.)ITY=EXPY-0.2 IF((IABS(ITY)).GE.10)NEX=2 IF(ITY)4,5,6 4 NEX=NEX+1 6 YI=PY-(HT*2+NEX*HP)+YD XI=-8*HN+XD CALL SYMBOL(XI,YI,HT,DIX,90.,2) XI=XI-HT/2 YI=YI+2*HT CALL NUMBER(XI,YI,HP,EXPY,90.,-1) 5 YI=PY-(20*HT+2*HT+NEX*HP)+YD XI=-9*HN+XD CALL SYMBOL(XI,YI,HT,NTY,90.,20) C IF(MOD(IY,5))2,60,2 60 CALL PLOT(X,Y,3) XI=X-6.5*HN YI=Y-HN/2 S=SMARY CALL NUMBER(XI,YI,HN,S,0.,3) 2 DO 30 I=1,IY CALL PLOT(X,Y,3) Y=Y+N CALL PLOT(X,Y,2) J=I IF(N.LT.0)J=IY-I IF((MOD(J,5)).EQ.0)GO TO 31 XI=X-0.1*N CALL PLOT(XI,Y,2) GO TO 30 31 XI=X-0.3*N CALL PLOT(XI,Y,2) GO TO (30,40)K 40 XI=X-6.5*HN YI=Y-HN/2 S=SMARY-I*DSY CALL NUMBER(XI,YI,HN,S,0.,3) 30 CONTINUE K=K+1 N=-N GO TO (1,1,50),K 50 RETURN END SUBROUTINE PLOTV(I) TYPE 99 99 FORMAT(' VERSATEK PLOT NOT YET AVAILABLE') RETURN END SUBROUTINE PLOTB(NFILE) C C PLOTS POWDER PROFILES ON BENSON C C PLTCAL MODIFIED TO ACCEPT ILUM>1 (S51 AFTER JIN=J / IF(ILUM.GT.1)JIN=ILUM) DIMENSION X(4002),Y(4002),ER(4000),YC(4002),YD(4002) DIMENSION TTHETA(4000),COBS(10,400),CALC(10,400),DIFF(10,400) DIMENSION TITLE(10),TTMIN(10),CMON(10),NTX(4),NTY(4) DIMENSION XYLIM(4),XYB(4),DIN(14),IN(14) EQUIVALENCE (X(1),TTHETA(1)),(X(4001),XMIN),(X(4002),XMAX) EQUIVALENCE (Y(1),COBS(1,1)),(Y(4001),YMIN),(Y(4002),YMAX) EQUIVALENCE (YC(1),CALC(1,1)),(YD(1),DIFF(1,1)) DATA NTX/' 2THETA IN DEGREES'/,NTY/' COUNT'/ DATA HAUT,M,HPT/0.8,-1,0.2/ C READ FILE TITLE AND SETUP DATA REWIND NFILE READ(NFILE,119) TITLE 119 FORMAT(16A5) READ(NFILE,129) ISCALE,CMIN,TTSTEP,NSETS,IFCALC,CBACK,TTMIN,CMON 129 FORMAT(2I8,F8.2,3I8/10F8.3/10F8.0) TTMINI=TTMIN(1) DO100I=1,NSETS 100 IF(TTMIN(I).LT.TTMINI) TTMINI=TTMIN(I) MCODE=0 IFX=1 IERCAL=0 NPLT=1 XYB(1)=TTMINI XYB(2)=160. XYB(3)=CMIN XYB(4)=4000. C ASK FOR LIMITS 12 TYPE 139 139 FORMAT(' 2THETA LIMITS ? XMIN,XMAX=') ACCEPT 119,DIN IF(DIN(1).EQ.1H ) GO TO 8 XMIN=XYB(1) XMAX=XYB(2) IF(DIN(1).NE.1H?) DECODE(70,149,DIN) XMIN,XMAX 149 FORMAT(2F) 14 TYPE 159 159 FORMAT(' COUNT LIMITS ? YMIN,YMAX=') ACCEPT 119,DIN IF(DIN(1).EQ.1H ) GO TO 12 YMIN=XYB(3) YMAX=XYB(4) IF(DIN(1).NE.1H?) DECODE(70,149,DIN) YMIN,YMAX C DRAW AXES APPROPRIATE TO LIMITS Y(1)=YMIN Y(2)=YMAX TYPE 309 309 FORMAT(' PLOT SIZE (CM) ? X,Y=') ACCEPT 119,DIN IF(DIN(1).EQ.1H ) GO TO 14 ISX=XMAX-XMIN ISY=(YMAX-YMIN)/100. IF(DIN(1).NE.1H?) DECODE(70,169,DIN) ISX,ISY ISX=-ISX ISY=-ISY 169 FORMAT(2I) 300 CALL PLTCAL(X,Y,ER,0,-4000,ISX,ISY,NTX,NTY,TITLE,HAUT,M,HPT,0,0) ISN=0 IF(MCODE.NE.0) GO TO 5 MCODE=1 N=0 3 N=N+1 IF(IFX.EQ.0) GO TO 30 X(1)=TTMIN(N) DO301I=2,4000 301 X(I)=X(I-1)+TTSTEP C GET COUNT DATA FOR NTH GRAPH 30 KMIN=((TTMIN(N)-TTMINI)/TTSTEP)-0.5 K=0 31 K=K+1 READ(NFILE,END=8,319) (COBS(I,K),I=1,10) 319 FORMAT(10(2X,F6.0)) IF(COBS(1,K).EQ.-1000.) GO TO 33 IF(COBS(1,K).EQ.-10000.) GO TO 8 DO311I=1,10 IF(N.EQ.1) GO TO 311 IF(CMON(N).NE.0.) COBS(I,K)=COBS(I,K)*CMON(1)/CMON(N) 311 COBS(I,K)=COBS(I,K)+CBACK IF(IFCALC.EQ.0) GO TO 31 READ(NFILE,319) (CALC(I,K),I=1,10) DO312I=1,10 CALC(I,K)=CALC(I,K)+CBACK 312 DIFF(I,K)=COBS(I,K)-CALC(I,K)+0.75*(YMAX-YMIN)+YMIN GO TO 31 33 KMAX=K-1 JMIN=10*KMIN JMAX=10*KMAX C SET REMAINING POINTS OUT OF BOUNDS DO331K=1,400 IF(K.GE.KMIN.OR.K.LE.KMAX) GO TO 331 DO331I=1,10 COBS(I,K)=-1000. IF(IFCALC.EQ.0) GO TO 331 CALC(I,K)=-1000. DIFF(I,K)=-1000. 331 CONTINUE C ASK CODE FOR PLOT CHARACTERS AND ERROR BARS 41 TYPE 419 419 FORMAT(' CODE FOR PLOT ? & ERROR BARS OR DIFF PLOT ? Y OR N ?') ACCEPT 119,IN IF(IN(1).EQ.1H ) GO TO 12 IF(IN(1).NE.1H?) GO TO 42 TYPE 429 429 FORMAT(' CODES ARE' 2/' 1 OBLIQUE CROSSES 4 SQUARES 7 HOURGLASSES' 3/' 2 VERTICAL CROSSES 5 DIAMONDS 8 BOWTIES' 4/' 3 INV TRIANGLES 6 STARS 9 CIRCLES' 5/' 0 LINE PLOT 10 POINT PLOT 10+N LINE+CHAR N PLOT') GO TO 41 42 DECODE(70,439,IN) ILUM,IFER 439 FORMAT(I,A5) IER=0 IF(IFCALC.EQ.1) GO TO 44 IF(IFER.NE.1HY) GO TO 44 IER=1 IF(IERCAL.NE.0) GO TO 44 IERCAL=1 DO431I=1,4000 ER(I)=0. IF(Y(I).GT.0.) ER(I)=SQRT(Y(I)) 431 CONTINUE 44 IF(MCODE.NE.4) GO TO 5 45 CONTINUE C DISPLAY NTH GRAPH 5 CALL PLTCAL(X,Y,ER,-1,-4000,ISX,ISY,NTX,NTY,NTEX,HAUT,M,HPT, 1 ILUM,IER) ISN=ISN+1 NPLT=1 C PLOT CALCULATED PROFILE AND DIFFERENCES IF REQUIRED IF(IFCALC.EQ.0) GO TO 51 YC(4001)=YMIN YC(4002)=YMAX YD(4001)=YMIN YD(4002)=YMAX CALL PLTCAL(X,YC,ER,-1,-4000,ISX,ISY,NTX,NTY,NTEX,HAUT,M,HPT,0,0) IF(IFER.EQ.1HY) 1CALL PLTCAL(X,YD,ER,-1,-4000,ISX,ISY,NTX,NTY,NTEX,HAUT,M,HPT,0,0) ISN=ISN+2 NPLT=3 C C **** PLOT POSITIONS OF HKL LINES **** C PX=IABS(ISX) PY=IABS(ISY) CALL TDLMR(XMIN,XMAX,PX,SMIRX,SMARX,DSX,EXPX,-4000) ECHX=DSX*10.**EXPX CALL TDLMR(YMIN,YMAX,PY,SMIRY,SMARY,DSY,EXPY,-4000) ECHY=DSY*10.**EXPY READ(NFILE,509) MINUS READ(NFILE,509) NHKL 509 FORMAT(5I8,F8.3,F8.0) 50 READ(NFILE,END=51,509) MULT,H,K,L,NF,TT,FHKL IF(TT.LT.XMIN.OR.TT.GT.XMAX) GO TO 50 FHKL=FHKL*(YMAX-YMIN)/40000.0 XH=TT/ECHX-SMIRX/DSX YH=FHKL/ECHY CALL PLOT(XH,0.,3) CALL PLOT(XH,YH,2) GO TO 50 C C **** MODIFY ETC AS DEMANDED 51 XYLIM(1)=XMIN XYLIM(2)=XMAX XYLIM(3)=YMIN XYLIM(4)=YMAX C CALL BOUNDS(XYLIM,XYB) TYPE 519 519 FORMAT(' MODIFY THIS PLOT ? Y OR N ?') ACCEPT 119,IN IF(IN(1).EQ.1H )GO TO 8 IF(IN(1).EQ.1HN) GO TO 3 52 TYPE 529 529 FORMAT(' MOD OPTION ? (1 LIMITS, 2 ORIGIN, 3 SCALE, 4 CODE)') ACCEPT 119,IN IF(IN(1).EQ.1H ) GO TO 51 IF(IN(1).EQ.1H?) GO TO 3 DECODE(5,439,IN) MCODE IF(MCODE.LT.1.OR.MCODE.GT.4) GO TO 52 GO TO (12,62,63,41),MCODE C SHIFT ORIGIN 62 TYPE 629 629 FORMAT(' SHIFT ORIGIN ? N OR DX,DY=') ACCEPT 119,DIN IF(DIN(1).EQ.1HN) GO TO 52 DECODE(70,149,DIN) DX,DY IF(ABS(DX).LT.0.01) GO TO 622 DO621J=JMIN,JMAX 621 X(J)=X(J)+DX IFX=1 GO TO 624 622 IF(ABS(DY).LT.0.001) GO TO 52 624 DO623J=JMIN,JMAX 623 Y(J)=Y(J)+DY GO TO 45 C MULTIPLY SCALES 63 TYPE 639 639 FORMAT(' MULTIPLY SCALES ? N OR SX,SY=') ACCEPT 119,DIN IF(DIN(1).EQ.1HN) GO TO 52 DECODE(70,149,DIN) SX,SY IF(ABS(1.-SX).LT.0.001) GO TO 632 DO631J=JMIN,JMAX 631 X(J)=X(J)*SX IFX=1 GO TO 634 632 IF(ABS(1.-SY).LT.0.001) GO TO 52 634 DO633J=JMIN,JMAX 633 Y(J)=Y(J)*SY GO TO 45 8 CALL PLOT(0,0,999) RETURN END SUBROUTINE PLTCAL(X,Y,ER,NCUR,K,ISX,ISY,NTX,NTY,NTEX,HAUT, 1M,HPT,ILUM,IER) C C*** MOD FOR ILUM>0 (S51 AFTER JIN=J / IF(ILUM.GT.1)JIN=ILUM) **** DIMENSION X(1),Y(1),ER(1),NTX(1),NTY(1),NTEX(1),NEXT(12) DIMENSION XOR(10),YOR(10) C DATA NBLANK/' '/ DATA XOR/10*0./,YOR/10*0./ DATA IPLOT/0/ C C X=ABSCISSES DES POINTS A TRACER C Y=ORDONNEES DES POINTS A TRACER C ER=ERREUR ABSOLUE SUR LES ORDONNEES C NCUR NOMBRE DE COURBES,SI <0 COURBES SUPERPOSEES AVEC C APPEL PRECEDENT A PLTCAL C VALEUR ABSOLUE DE K= NOMBRE DE POINTS A TRACER C SI K EST NEGATIF DONNER K+2 VALEURS: C X(K+1)=VALEUR MINIMUM DE X C X(K+2)=VALEUR MAXIMUM DE X C Y(K*NCU+1)=VALEUR MINIMUM DE Y C Y(K*NCU+2)=VALEUR MAXIMUM DE Y C ISX=DIMENSION DU GRAPHIQUE SUIVANT X C ISY=DIMENSION DU GRAPHIQUE SUIVANT Y C NTX=TEXTE SUIVANT L'AXE DES X (10 CARACTERES MAXIMUM) C NTY=TEXTE SUIVANT L'AXE DES Y (10 CARACTERES MAXIMUM) C NTEX=TEXTE PRINCIPAL (M LIGNES DE 50 CARACTERES) C HAUT HAUTEUR EN CM DES CARACTERES TEXTE PRINCIPAL C M=NOMBRE DE LIGNES DU TEXTE PRINCIPAL C SI M EST NEGATIF TRACER D'UN CADRE C HPT=HAUTEUR DU SYMBOLE UTILISE EN CM C ILUM = 0 TRACE CONTINU C >0 TRACE POINTS C IER = 0 PAS DE BARRE D'ERREUR C 1 BARRE D'ERREUR C PX=IABS(ISX) PY=IABS(ISY) HN=HAUT/2 N=IABS(K) NCU=IABS(NCUR) NY=N*NCU IF(NCUR)1,19,19 19 IF(IPLOT)20,20,22 20 CALL PLOTS(IFREE,0,0,'USE',1,0,2.5) LX=PX+8*HAUT+3 26 LY=PY+(2*IABS(M)+2)*HAUT+2.3 NTRY=70/LY IF(NTRY.GT.0)GOTO 28 PY=70-(2*IABS(M)+2)*HAUT-3 WRITE(8,800)PY 800 FORMAT(' PY TROP GRAND ESSAI AVEC :',F) GOTO 26 28 XOR(1)=LX IF(NTRY.EQ.1)GOTO 25 YOR(1)=-(NTRY-1)*LY DO 27 I=2,NTRY 27 YOR(I)=LY 25 YMIN=(2*IABS(M)+1)*HAUT+1.3 XMIN=6*HAUT GOTO 29 22 I=MOD(IPLOT,NTRY) XMIN=XOR(I+1) YMIN=YOR(I+1) 29 IPLOT=IPLOT+1 C IF(K.LT.0)GO TO 60 SMAX=X(1) SMIX=X(1) SMAY=Y(1) SMIY=Y(1) DO 10 I=1,NY SMIY=AMIN1(SMIY,Y(I)) SMAY=AMAX1(SMAY,Y(I)) 10 CONTINUE DO 100 I=1,N SMIX=AMIN1(SMIX,X(I)) SMAX=AMAX1(SMAX,X(I)) 100 CONTINUE GO TO 61 60 CONTINUE SMIX=X(N+1) SMAX=X(N+2) SMIY=Y(NY+1) SMAY=Y(NY+2) 61 CONTINUE C 2 CALL PLOT(XMIN,YMIN,-3) C C DETERMINATION DES ECHELLES SUR LES 2 AXES (ARRONDIES) C CALL TDLMR(SMIX,SMAX,PX,SMIRX,SMARX,DSX,EXPX,K) ECHX=DSX*10.**EXPX CALL TDLMR(SMIY,SMAY,PY,SMIRY,SMARY,DSY,EXPY,K) ECHY=DSY*10.**EXPY C C TRACER DES AXES ET DU CADRE C CALL AXIST4(0.,0.,DSX,DSY,EXPX,EXPY,NTX,NTY,ISX,ISY, 1 SMIRX,SMARY,HN) C C C ECRIRURE DU TEXTE PRINCIPAL C IF(M.EQ.0)GO TO 74 M1=IABS(M) DO 11 J=1,M1 YD=-(J*2*HAUT+1.0) XD=0. J2=10*(J-1) DO 13 J1=1,10 12 NEXT(J1)=NBLANK 13 NEXT(J1)=NTEX(J2+J1) CALL SYMBOL(XD,YD,HAUT,NEXT,0.,50) 11 CONTINUE C IF(M.GE.0)GO TO 74 XD=-6*HAUT CALL PLOT(XD,YD-HAUT,3) CALL PLOT(PX+2*HAUT,YD-HAUT,2) CALL PLOT(PX+2*HAUT,PY+HAUT,2) CALL PLOT(XD,PY+HAUT,2) CALL PLOT(XD,YD-HAUT,2) 74 CONTINUE C 1 IF(ILUM)54,54,51 C C C TRACER D'UN NUAGE DE POINTS SANS BARRE D'ERREUR C 51 DO 53 I=1,N XX=X(I)/ECHX-SMIRX/DSX IF((XX.GT.PX).OR.(XX.LT.0.))GO TO 53 DO 53 J=1,NCU YY=Y(I+(J-1)*N)/ECHY-SMIRY/DSY IF((YY.GT.PY).OR.(YY.LT.0.))GO TO 53 NBSYM=MAX0(J,ILUM) CALL POINTS(XX,YY,HPT,NBSYM) C C TRACE AVEC BARRES D'ERREUR C IF(IER.EQ.0)GOTO 53 ERS=ER(I+(J-1)*N)/ECHY IF(ERS.LT.0.17)GO TO 52 N1=-1 56 YE=YY+0.17*N1 CALL PLOT(XX,YE,3) YE=YY+ERS*N1 IF(YE.GT.PY)YE=PY IF(YE.LT.0.)YE=0. CALL PLOT(XX,YE,2) XE=XX-0.12 CALL PLOT(XE,YE,3) CALL PLOT(XE+0.24,YE,2) N1=N1+2 GO TO(56,52,52)N1 52 CONTINUE 53 CONTINUE C PLUME HAUTE AU RETURN GOTO 999 C C TRACER D'UNE COURBE CONTINUE C 54 I=1 NX=N IPEN=3 K3=1 DO 99 J=1,NCU 90 YY=Y(I+(J-1)*N)/ECHY-SMIRY/DSY XX=X(I)/ECHX-SMIRX/DSX IF((XX.GT.PX).OR.(XX.LT.0.))GO TO 98 IF((YY.GE.0.).AND.(YY.LE.PY))GOTO 97 IPEN=1 93 Y2=PY IF(YY.LT.0.)Y2=0. X1=X(I-K3)/ECHX-SMIRX/DSX Y1=Y(I+(J-1)*N-K3)/ECHY-SMIRY/DSY X2=(X1-XX)/(Y1-YY)*(Y2-YY)+XX CALL PLOT(X2,Y2,IPEN) IF(IPEN.EQ.3)GOTO 977 95 IF(I.EQ.NX)GOTO 96 I=I+K3 XX=X(I)/ECHX-SMIRX/DSX YY=Y(I+(J-1)*N)/ECHY-SMIRY/DSY IF((YY.LT.0.).OR.(YY.GT.PY))GOTO 95 IPEN=3 GOTO 93 977 IPEN=2 97 CALL PLOT(XX,YY,IPEN) IPEN=2 C C TRACE LIGNE CONTINUE ET BARRES D'ERREUR C IF(IER.EQ.0)GOTO 98 ERS=ER(I+(J-1)*N)/ECHY N1=-1 X1=XX-0.12 X2=XX+0.12 91 Y1=YY+ERS*N1 IF(Y1.GT.PY)Y1=PY IF(Y1.LT.0.)Y1=0. CALL PLOT(X1,Y1,3) CALL PLOT(X2,Y1,2) CALL PLOT(XX,Y1,3) CALL PLOT(XX,YY,2) N1=N1+2 GOTO(91)N1 98 IF(I.EQ.NX)GOTO 96 I=I+K3 GOTO 90 96 K3=-K3 NX=MAX0(1,K3*N) 99 CONTINUE C 999 CALL WHERE(XX,YY,RFACT) CALL PLOT(XX,YY,3) RETURN END SUBROUTINE TDLMR(SMIX,SMAX,DAP,SMIR,SMAR,DS,XP,K) DIMENSION A(36) DATA A/1.1,1.2,1.3,1.4,1.5,1.6,1.7,1.8,1.9,2.,2.2,2.4,2.5,2.6,2. 18,3.,3.2,3.4,3.5,3.6,3.8,4.,4.5,5.,5.5,6.,6.5,7.,7.5,8.,8.5,9.,9 2.5,10.,11.,12./ IF((SMIX.LT.SMAX).AND.(DAP.GT.0.))GO TO 10 WRITE(6,11)SMIX,SMAX,DAP 11 FORMAT(///10X,'SMI =',E13.5,5X,'SMA =',E13.5,10X,'DIMENSION ='E13. 15) STOP 10 SMA=AMAX1(ABS(SMAX),ABS(SMIX)) SMI=0. DAM=1. 9 IF(SMA-SMI-DAM) 2,2,1 1 DO 3 I=1,75 J=1-I IF(((SMA-SMI)*10.**(-I)).LT.DAM) GO TO 4 3 CONTINUE 2 DO 5 I=1,75 J=I-1 IF(((SMA-SMI)*10.**J).GT.DAM) GO TO 4 5 CONTINUE 4 IP=-J IF(DAM.EQ.1.) GO TO 8 IF(K.GT.0)GO TO 30 DS=(SMA-SMI)/DAM SMIR=SMI SMAR=SMA RETURN 30 DO 6 I=1,36 DS=A(I)*10.**IP SMIR=AINT(SMI/DS)*DS IF(SMI.LT.0)SMIR=SMIR-DS SMAR=SMIR+DAM*DS SM1=SMIR-SMI SM2=SMA-SMAR IF((SM1.LT.1.E-05).AND.(SM2.LT.1.E-05))RETURN 6 CONTINUE 8 EX=10.**IP SMI=SMIX/EX SMA=SMAX/EX DAM=DAP XP=IP GO TO 9 RETURN END SUBROUTINE POINTS(X,Y,H,N) A=0.5*H B=0.3333*H C=2.*B TET=0.7854 GO TO (1,2,3,4,5,1,7,8,9)N 1 CALL PLOT(X+A,Y-A,3) CALL PLOT(X-A,Y+A,2) CALL PLOT(X-A,Y-A,3) CALL PLOT(X+A,Y+A,2) IF(N.NE.6)GO TO 11 2 CALL PLOT(X,Y-A,3) CALL PLOT(X,Y+A,2) CALL PLOT(X-A,Y,3) CALL PLOT(X+A,Y,2) GO TO 11 3 CALL PLOT(X+A,Y-B,3) CALL PLOT(X,Y+C,2) CALL PLOT(X-A,Y-B,2) CALL PLOT(X+A,Y-B,2) GO TO 11 4 CALL PLOT(X+A,Y-A,3) CALL PLOT(X+A,Y+A,2) CALL PLOT(X-A,Y+A,2) CALL PLOT(X-A,Y-A,2) CALL PLOT(X+A,Y-A,2) GO TO 11 5 CALL PLOT(X,Y-A,3) CALL PLOT(X+A,Y,2) CALL PLOT(X,Y+A,2) CALL PLOT(X-A,Y,2) CALL PLOT(X,Y-A,2) GO TO 11 7 CALL PLOT(X+A,Y-A,3) CALL PLOT(X-A,Y+A,2) CALL PLOT(X+A,Y+A,2) CALL PLOT(X-A,Y-A,2) CALL PLOT(X+A,Y-A,2) GO TO 11 8 CALL PLOT(X+A,Y-A,3) CALL PLOT(X-A,Y+A,2) CALL PLOT(X-A,Y-A,2) CALL PLOT(X+A,Y+A,2) CALL PLOT(X+A,Y-A,2) GO TO 11 9 CALL PLOT(X+A,Y,3) DO 10 I=1,8 TETA=I*TET U=X+A*COS(TETA) V=Y+A*SIN(TETA) CALL PLOT(U,V,2) 10 CONTINUE 11 CALL PLOT(X,Y,3) RETURN END SUBROUTINE AXIST4(XD,YD,PSX,PSY,EXPX,EXPY,NTX,NTY,IPX,IPY,PMIRX, 1 PMARY,HN) DIMENSION NTX(1),NTY(1) DATA DIX/'10010'/ X=XD Y=YD PX=IABS(IPX) PY=IABS(IPY) IF(IPX)13,13,14 13 SMIRX=PMIRX*10**EXPX DSX=PSX*10**EXPX GOTO 15 14 SMIRX=PMIRX DSX=PSX 15 IF(IPY)16,16,17 16 SMARY=PMARY*10**EXPY DSY=PSY*10**EXPY GOTO 18 17 SMARY=PMARY DSY=PSY 18 IX=IABS(IPX) IY=IABS(IPY) HT=HN*6/5 HP=HN*4/5 K=1 N=1 CALL PLOT(X,Y,3) XI=X-1.5*HN YI=Y-2*HN CALL NUMBER(XI,YI,HN,SMIRX,0.,-1) 1 DO 10 I=1,IX CALL PLOT(X,Y,3) X=X+N CALL PLOT(X,Y,2) J=I IF(N.LT.0)J=IX-I IF((MOD(J,5)).EQ.0)GO TO 11 YI=Y+0.1*N CALL PLOT(X,YI,2) GO TO 10 11 YI=Y+0.3*N CALL PLOT(X,YI,2) GO TO (20,10),K 20 XI=X-1.5*HN YI=Y-2*HN S=SMIRX+I*DSX CALL NUMBER(XI,YI,HN,S,0.,-1) 10 CONTINUE GO TO(3,12)K C C ECRITURE DE L'ECHELLE SUR L'AXE OX C 3 NEX=1 IF(IPX.LT.0)GOTO 8 ITX=EXPX+0.2 IF(EXPX.LT.0.)ITX=EXPX-0.2 IF((IABS(ITX)).GE.10)NEX=2 IF(ITX)7,8,9 7 NEX=NEX+1 9 XI=PX-(HT*2+NEX*HP)+XD YI=-4*HN+YD CALL SYMBOL(XI,YI,HT,DIX,0.,2) XI=XI+2*HT YI=YI+HT/2 CALL NUMBER(XI,YI,HP,EXPX,0.,-1) 8 XI=PX-(20*HT+HT*2+NEX*HP)+XD YI=-4*HN+YD CALL SYMBOL(XI,YI,HT,NTX,0.,20) GO TO 2 C C ECRITURE DE L'ECHELLE SUR L'AXE OY C 12 NEX=1 IF(IPY.LT.0)GOTO 5 ITY=EXPY+0.2 IF(EXPY.LT.0.)ITY=EXPY-0.2 IF((IABS(ITY)).GE.10)NEX=2 IF(ITY)4,5,6 4 NEX=NEX+1 6 YI=PY-(HT*2+NEX*HP)+YD XI=-8*HN+XD CALL SYMBOL(XI,YI,HT,DIX,90.,2) XI=XI-HT/2 YI=YI+2*HT CALL NUMBER(XI,YI,HP,EXPY,90.,-1) 5 YI=PY-(20*HT+2*HT+NEX*HP)+YD XI=-6.5*HN+XD CALL SYMBOL(XI,YI,HT,NTY,90.,20) C IF(MOD(IY,5))2,60,2 60 CALL PLOT(X,Y,3) XI=X-5.0*HN YI=Y-HN/2 S=SMARY CALL NUMBER(XI,YI,HN,S,0.,-1) 2 DO 30 I=1,IY CALL PLOT(X,Y,3) Y=Y+N CALL PLOT(X,Y,2) J=I IF(N.LT.0)J=IY-I IF((MOD(J,5)).EQ.0)GO TO 31 XI=X-0.1*N CALL PLOT(XI,Y,2) GO TO 30 31 XI=X-0.3*N CALL PLOT(XI,Y,2) GO TO (30,40)K 40 XI=X-5.0*HN YI=Y-HN/2 S=SMARY-I*DSY CALL NUMBER(XI,YI,HN,S,0.,-1) 30 CONTINUE K=K+1 N=-N GO TO (1,1,50),K 50 RETURN END SUBROUTINE SUMP(FILEN,FILES,NC) COMPLEX FILEN,FILES INTEGER S DIMENSION NC(10),TITLE(16),ST(10),SF(10) DIMENSION S(4400),NS(4400),IP(4400),IPI(4400),NN(4400) OPEN(UNIT=30,ACCESS='SEQIN',FILE=FILEN) OPEN(UNIT=31,ACCESS='SEQOUT',FILE=FILES) TYPE 9,FILEN 9 FORMAT(' PROFILES IN FILE "',2A5,'" BEING SUMMED. PLEASE WAIT') DO10I=1,4400 NS(I)=0 10 S(I)=0. DO100I=1,4400 IP(I)=0 IPI(I)=0 100 NN(I)=0 C READ STEP 'DS', START ANGLES 'ST' AND MONITOR SCALES READ(30,19) TITLE,ISC,IB,DS,NS1,NS2,NS3,ST,SF 19 FORMAT(16A5/2I8,F8.4,3I8/10F8.3/10F8.0) C FIND LOW ANGLE COUNTER NUMBER 'NMIN' STMIN=ST(1) SF1=0 NCT=0 DO111I=1,10 IF(NC(I).LE.0) GO TO 111 IF(SF(I).LT.0.) GO TO 110 IF(SF(I).EQ.0.) GO TO 111 SF1=SF1+SF(I) NCT=NCT+1 110 IF(ST(I).GT.STMIN) GO TO 111 NMIN=I STMIN=ST(I) 111 CONTINUE SF1=SF1/FLOAT(NCT) C FIND STARTING POINT 'IS' OF PROFILE 'NP' AND DECLAGE 'D' ISM=0 NP=0 11 NP=NP+1 IF(NP.GT.10) GO TO 51 IF(NC(NP).LE.0) GO TO 22 IF(SF(NP).EQ.0.) GO TO 22 IS=(ST(NP)-ST(NMIN))/DS DELTAS=(ST(NP)-ST(1))/DS IS1=DELTAS D=-(DELTAS-IS1) IF(NP.EQ.NMIN) STS=STMIN+D*DS C READ IN PROFILE 'NP' 20 JS=-9 21 IF(JS.LE.4381) GO TO 210 22 READ(30,29) NNN,IPP IF(IPP.EQ.-10000) GO TO 51 IF(IPP.NE.-1000) GO TO 22 GO TO 11 210 JS=JS+10 READ(30,29) ((NN(J),IP(J)),J=JS,JS+9) 29 FORMAT(10(I2,I6)) IF(IP(JS).EQ.-10000) GO TO 51 IF(IP(JS).EQ.-1000) GO TO 220 C RESET ANY BAD POINTS TO ZERO DO2100J=JS,JS+9 2100 IF(NN(J).LE.0) IP(J)=1 GO TO 21 C ITERPOLATE THIS PROFILE 220 JSL=JS-10 DO211JSS=JSL,JSL+9 211 IF(IP(JSS).GT.0) JS=JSS CALL INTPOL(IP,IPI,JS,D) C ADD INTERPOLATED PROFILE ONTO SUM 'S' 40 I=IS J=0 DO411J=1,JS I=I+1 IF(NN(J).LE.0) GO TO 411 IF(IPI(J).LE.1) GO TO 411 S(I)=S(I)+IPI(J)*(SF1/SF(NP)) IF(SF(NP).GT.0.) NS(I)=NS(I)+NN(J)+1000 411 CONTINUE IF(I.GT.ISM) ISM=I C LOOP TO NEXT PROFILE GO TO 11 C WRITE FILE CONTAINING SUMMED PROFILE 51 ST(1)=STS WRITE(31,19) TITLE,ISC,IB,DS,NS1,NS2,NS3,ST,SF KS=1 511 DO510K=KS,KS+9 IF(NS(K).EQ.0) GO TO 510 NSS=NS(K)/1000 S(K)=S(K)/NSS NS(K)=NS(K)-1000*NSS 510 CONTINUE WRITE(31,29) ((NS(K),S(K)),K=KS,KS+9) KS=KS+10 IF(KS.LE.ISM) GO TO 511 WRITE(31,529) 529 FORMAT(3X,'-1000',71X,' '/2X,'-10000',71X,' ') CLOSE(UNIT=30) CLOSE(UNIT=31) RETURN END SUBROUTINE INTPOL(IP,IPI,N,D) C INTERPOLATION OF PROFIL 'IP' CONTAINING 'N' POINTS C INTERPOLATED PROFILE 'IPI' IS DISPLACED BY 'D' FROM ORIGINAL DIMENSION IP(4400),IPI(4400) DO12I=1,N-1 IPI(I)=1 IF(IP(I).GT.1.AND.IP(I+1).GT.1) GO TO 11 IF(IP(I).LE.1.AND.IP(I+1).LE.1) GO TO 11 IF(IP(I).LE.1) GO TO 10 C SINCE IP(I+1) LE 1, EXTRAPOLATE FORWARD IF(I.LE.1) GO TO 12 IF(IP(I-1).GT.1) IPI(I)=IP(I)+(IP(I)-IP(I-1))*D GO TO 12 C SINCE IP(I) LE 1, EXTRAPOLATE BACK 10 IF(I+2.GT.N) GO TO 12 IF(IP(I+2).GT.1) IPI(I)=IP(I+1)-(IP(I+2)-IP(I+1))*D GO TO 12 11 IPI(I)=IP(I)+(IP(I+1)-IP(I))*D 12 CONTINUE IPI(N)=1 IF(IP(N).GT.1.AND.IP(N-1).GT.1) IPI(N)=IP(N)+(IP(N)-IP(N-1))*D RETURN END SUBROUTINE ADDSUB(FILE1,FILE2,FAC) C THIS SUBROUTINE ADDS OR SUBTRACTS FAC*FILE2 FROM FILE1 C COMPLEX FILE1,FILE2,FILE3,FILE4 DIMENSION TITLE(8),BLOCK1(3),BLOCK2(3),NC(11),ICOUNT(11),NCC(10) DIMENSION INC(100),INTC(100) EXT='.BAK' FILE3=CMPLX(REAL(FILE1),EXT) CALL RELEAS(30) CALL RELEAS(31) CALL RELEAS(32) CALL IFILE(30,FILE1) CALL IFILE(31,FILE2) CALL OFILE(32,FILE3) NC2=2 SGN=' ' K=0 IF(FAC.GT.0.) SGN='+' TYPE 19,FILE1,SGN,FAC,FILE2 19 FORMAT(' COMPUTING PROFILE (',2A5,A1,F6.2,'*',2A5, 1 '). PLEASE WAIT') READ(31,119) TITLE,BLOCK2 119 FORMAT(8A5,20X,A5,A2,A5) READ(30,119) TITLE,BLOCK1 WRITE(32,129) TITLE,BLOCK1,FAC,BLOCK2 129 FORMAT(8A5,'BLK',A5,A2,A5,F4.1,'*',A5,A2,A5) READ(31,139) ISCALE,IMIN,TTS2 139 FORMAT(2I8,F8.2,I8) READ(30,139) ISCALE,IMIN,TTS1 TSM=(100.*TTS2)/(100.*TTS1) ISM=TSM+0.5 IF(ABS(TSM-FLOAT(ISM)).LE.0.01) GO TO 11 TYPE 149 149 FORMAT(' ERROR.'/ 1' STEP SIZE FOR 2 MUST BE AN INTEGRAL MULTIPLE OF STEP SIZE FOR 1' 2 /' REVERSE THE FILE NAMES AND TRY AGAIN'/) CALL RELEAS(30) CALL RELEAS(31) RETURN 11 WRITE(32,139) ISCALE,IMIN,TTS1,NC2 READ(30,159) TTMIN1,CMON1 159 FORMAT(F8.2/F8.0) READ(31,159) TTMIN2,CMON2 CMON2=CMON2/FAC WRITE(32,169) TTMIN1,TTMIN2,CMON1,CMON2 169 FORMAT(2F8.2/2F8.0) 12 READ(30,179) (NC(I),ICOUNT(I),I=1,10) 179 FORMAT(10(I2,I6)) WRITE(32,179) (NC(I),ICOUNT(I),I=1,10) IF(ICOUNT(1).EQ.-1000) GO TO 13 GO TO 12 13 READ(31,179) (NC(I),ICOUNT(I),I=1,10) IF(ISM.NE.1) GO TO 14 IF(ICOUNT(1).EQ.-1000) GO TO 16 WRITE(32,179) (NC(I),ICOUNT(I),I=1,10) GO TO 13 C INTERPOLATE THE SECOND PROFILE 14 IF(K.EQ.0) GO TO 15 IF(NC(1).LE.0.OR.NC(11).LE.0) GO TO 141 IDIFF=(ICOUNT(11)-ICOUNT(1))/ISM 141 DO142J=1,ISM K=K+1 INC(K)=NC(11) 142 INTC(K)=ICOUNT(11)+(J-1)*IDIFF DO143I=1,10*ISM IF(INTC(I).GT.999999) INTC(I)=999999 143 IF(INTC(I).LT.-99999) INTC(I)=-99999 WRITE(32,179) (INC(I),INTC(I),I=1,10*ISM) 15 IF(ICOUNT(1).EQ.-1000) GO TO 16 K=0 DO151I=1,9 IF(NC(I).LE.0.OR.NC(I+1).LE.0) GO TO 150 IDIFF=(ICOUNT(I+1)-ICOUNT(I))/ISM 150 DO151J=1,ISM K=K+1 INC(K)=NC(I) 151 INTC(K)=ICOUNT(I)+(J-1)*IDIFF ICOUNT(11)=ICOUNT(10) NC(11)=NC(10) GO TO 13 16 WRITE(32,189) 189 FORMAT(3X,'-1000',72X/2X,'-10000',72X) CALL RELEAS(30) CALL RELEAS(31) CALL RELEAS(32) EXT='.ADD' FILE4=CMPLX(REAL(FILE3),EXT) DO161I=3,10 161 NCC(I)=0 NCC(1)=1 NCC(2)=1 CALL SUMP(FILE3,FILE4,NCC) TYPE 1619,FILE4 1619 FORMAT(' ADDED OR SUBTRACTED PROFILE IS IN FILE "',2A5,'"') RETURN END SUBROUTINE CAMBS C C PREPARES FILES CRYST.DAT AND HKLFF.DAT FOR THE CAMBRIDGE SYTEM C USES FILES PROFD.DAT & PROFF.DAT FROM POWDER PROFILE PROGRAM PROF2 C IN PARTICULAR, THE FAST FOURIER AND CONTOUR ROUTINES CAN BE USED C COMPLEX FILED DIMENSION BETA(6),EQ(12,24),LABEL(6),BL(6),ALAT(6),CARD(16) DIMENSION S(2,4),SS(7,3),EQV(4,3,24),IN(16),TITLE(13) DIMENSION IAX(9),FAX(9),CONTL(9) COMMON/LAT/A,B,C,D,E,F EQUIVALENCE (ALAT,A),(EQ,EQV) DATA EQ/288*0./,IFF/0/ DATA S/'+X','-X','+Y','-Y','+Z','-Z','+','-'/ OPEN(UNIT=30,FILE='CRYST.DAT',ACCESS='SEQOUT') OPEN(UNIT=32,FILE='HKLFF.DAT',ACCESS='SEQOUT') C******READ PROFD.DAT AND WRITE CRYST.DAT MODULE****** TYPE 319 319 FORMAT(' NAME OF PROF2 DATA FILE ?') ACCEPT 329,FILED 329 FORMAT(16A5) IF(FILED.EQ.1H ) RETURN IF(REAL(FILED).NE.'PROFD') TYPE 3229 3229 FORMAT(' *WARNING* FILE PROFD.DAT (& PROFF.DAT) FOR FOURIER') OPEN(UNIT=31,FILE=FILED,ACCESS='SEQIN') READ(31,339) TITLE,IDENT 339 FORMAT(13A5/A5) WRITE(30,349) TITLE C******'N' NAME OR TITLE 349 FORMAT('N',13A5) READ(31,359) IFCENT,NE,NTYPE,NFORM,NATOM,NROT,WAVE 359 FORMAT(6I8,F8.4) IF(NE.LE.0) GO TO 311 DO311I=1,NE READ(31,3619) (EQ(J,I),J=1,12) 3619 FORMAT(12F6.2) 369 FORMAT( ) IF(NROT.LE.0) GO TO 311 DO311J=1,NROT READ(31,369) 311 CONTINUE READ(31,3629) (BL(I),I=1,NTYPE) 3629 FORMAT(10F8.4) IF(NFORM.LE.0) GO TO 314 DO313I=1,NFORM 312 READ(31,379) FORM 379 FORMAT(2F8.3) 313 IF(FORM.NE.-100.) GO TO 312 314 READ(31,369) READ(31,369) C******'A' ATOM CO-ORDINATES C STORE BIJ IF GIVEN ON FILE 34 OPEN(UNIT=34,FILE='BIJ.BAK',ACCESS='SEQOUT') DO315I=1,NATOM READ(31,309) LABEL1,LABEL2,NTYPE,MTYPE,MROT,X,Y,Z,B,PN,BETA 309 FORMAT(A1,A2,X,3I4,5F8.5/6F8.5) IF(PN.LE.0.1) GO TO 315 DO310J=1,6 310 IF(LABEL1.EQ.LABEL(J)) GO TO 316 LABEL(NTYPE)=LABEL1 316 NB=2 IF(BETA(1).LT.0.1) NB=4 WRITE(30,389) LABEL1,LABEL2,X,Y,Z,B IF(B.LE.0.01) WRITE(34,3819) LABEL1,LABEL2,NB,BETA 315 CONTINUE 389 FORMAT('A',1X,A1,1X,A2,4F10.4) 3819 FORMAT('T',1X,A1,1X,A2,I5,6F10.4) CLOSE(UNIT=34) C******'T' TEMPERATURE ANISOTROPIC FACTORS OPEN(UNIT=34,FILE='BIJ.BAK',ACCESS='SEQIN') 400 READ(34,3159,END=40) TITLE 3159 FORMAT(13A5) WRITE(30,3159) TITLE GO TO 400 40 CLOSE(UNIT=34) READ(31,369) READ(31,419) DIR 419 FORMAT(I8) READ(31,3629) ALAT IF(DIR.EQ.-1.) GO TO 42 C CONVERT RECIPROCAL CELL PARAMETERS TO REAL CELL PARAMETERS IF(ALAT(1).GE.1.) GO TO 42 RAD=3.14159265/180. A=SQRT(A) B=SQRT(B) C=SQRT(C) COSA=D/(2.*B*C) COSB=E/(2.*A*C) COSC=F/(2.*A*B) SINA=SQRT(1.-COSA*COSA) SINB=SQRT(1.-COSB*COSB) SINC=SQRT(1.-COSC*COSC) V=A*B*C*SQRT(1.-COSA*COSA-COSB*COSB-COSC*COSC+2.*COSA*COSB*COSC) AS=B*C*SINA/V BS=C*A*SINB/V CS=A*B*SINC/V COSAS=(COSB*COSC-COSA)/(SINB*SINC) COSBS=(COSC*COSA-COSB)/(SINC*SINA) COSCS=(COSA*COSB-COSC)/(SINA*SINB) A=AS B=BS C=CS D=ATAN2(SQRT(1.-COSAS*COSAS),COSAS)/RAD E=ATAN2(SQRT(1.-COSBS*COSBS),COSBS)/RAD F=ATAN2(SQRT(1.-COSCS*COSCS),COSCS)/RAD C******'C' CONSTANTS FOR THE LATTICE 42 WRITE(30,439) ALAT 439 FORMAT('C',6F10.4) C******'F' FORM FACTORS WRITE(30,449) (LABEL(I),BL(I),I=1,NTYPE) 449 FORMAT('F',1X,A1,7X,'1',4X,'1',4X,'1',F10.4) C******'I' INSTRUCTION CARD WRITE(30,429) 429 FORMAT('I',5X,'2') C GENERATE CENTER AND LATTICE TYPE SYMMETRY OPERATIONS IF(IFCENT.EQ.1) GO TO 44 NE=NE+1 EQ(1,NE)=-1. EQ(6,NE)=-1. EQ(11,NE)=-1. 44 TYPE 4419 4419 FORMAT(' LATTICE TYPE ? (P,R,A,B,C,I OR F. CR=P)') ACCEPT 4429,TYPE 4429 FORMAT(A1) IF(TYPE.EQ.' ') TYPE='P' IF(TYPE.EQ.'P'.OR.TYPE.EQ.'R') GO TO 46 IFF=0 45 NE=NE+1 EQ(1,NE)=1. EQ(6,NE)=1. EQ(11,NE)=1. EQ(4,NE)=0.5 EQ(8,NE)=0.5 EQ(12,NE)=0.5 IF(TYPE.EQ.'I') GO TO 46 IF(TYPE.EQ.'A') EQ(4,NE)=0. IF(TYPE.EQ.'B') EQ(9,NE)=0. IF(TYPE.EQ.'C') EQ(14,NE)=0. IF(TYPE.NE.'F') GO TO 46 EQ(4,NE)=0.5 EQ(8,NE)=0.5 EQ(4*IFF+4,NE)=0. IFF=IFF+1 IF(IFF.GT.2) GO TO 46 GO TO 45 C******'S' SYMMETRY OPERATIONS C INTERPRET EQUIVALENT POSITIONS FOR CAMBRIDGE SYSTEM 46 DO463K=1,NE DO462J=1,3 DO461I=1,4 SS(I,J)=' ' IF(EQV(I,J,K).EQ.0.) GO TO 461 IF(EQV(I,J,K).GT .0.1) SS(I,J)=S(1,I) IF(EQV(I,J,K).LT.-0.1) SS(I,J)=S(2,I) 461 CONTINUE IE=12.*EQV(4,J,K) ID=12 SS(5,J)=' ' SS(6,J)=' ' SS(7,J)=' ' IF(IE.EQ.0) GO TO 462 4611 IF(2*(IE/2).NE.IE) GO TO 4612 IE=IE/2 ID=ID/2 GO TO 4611 4612 IF(3*(IE/3).NE.IE) GO TO 4613 IE=IE/3 ID=ID/3 4613 ENCODE(1,4619,SS(5,J))IE 4619 FORMAT(I1) ENCODE(1,4619,SS(7,J))ID SS(6,J)='/' 462 CONTINUE 463 WRITE(30,4639) ((SS(I,J),I=1,7),J=1,3) 4639 FORMAT('S',10X,3A2,4A1,10X,3A2,4A1,10X,3A2,4A1) C******'D' DIFFRACTION INFORMATION WRITE(30,4649) WAVE 4649 FORMAT('D',F10.4,4X,'9',4X,'1') IF(REAL(FILED).NE.'PROFD') GO TO 52 C******'R' REFLEXION FORMAT AND EXTENT WRITE(30,4709) 4709 FORMAT('R',4X,'2',4X,' 10.00',5X,'0.000',5X,'1.000') C******READ PROFF.DAT AND WRITE STRUCTURE FACTORS****** OPEN(UNIT=33,FILE='PROFF.DAT',ACCESS='SEQIN') READ(33,4719) NHKL 4719 FORMAT(I8/) DO48I=1,NHKL READ(33,4729) H,K,L,FCS,FOS,ECS,EOS,PHASEN 4729 FORMAT(3I8,4F8.2,2F8.5) FCS=SQRT(FCS) FOS=SQRT(FOS) 48 WRITE(32,4739) H,K,L,FCS,PHASEN,FOS 4739 FORMAT(3I5,3F10.4) C******'M' MAP CARDS (FOURIER) WRITE(8,519) 519 FORMAT(' ZONE AXIS OF FOURIER MAP ? EG 1 0 0, 0 1 0, 0 0 1') ACCEPT 5119,IAX 5119 FORMAT(9I) IF((IABS(IAX(1))+IABS(IAX(2))+IABS(IAX(3))).EQ.0) GO TO 52 WRITE(30,5129) IAX 5129 FORMAT('M',9I5) WRITE(8,529) 529 FORMAT(' INITIAL, FINAL & INCREMENTAL ALONG EACH AXIS ?') ACCEPT 5219,FAX 5219 FORMAT(9F) WRITE(30,5229) FAX 5229 FORMAT('M',9F8.4) TYPE 489 489 FORMAT(' FOURIER DIMENSION, NO. LEVELS & FOURIER TYPE ? TYPES ARE' 1 /' 1=FCALC 2=FOBS 3=MOD(FOBS)*PHASE(FCALC)' 2 /' 4=FOBS-FCALC 5=MOD(FOBS)-MOD(FCALC))*PHASE(FCALC) 6=PATTE 3RSON') ACCEPT 5119,NDIM,NCONT,MODEF IF(MODEF.LE.0.OR.MODEF.GT.6) GO TO 52 NMAP=1 WRITE(30,4839) NDIM,NMAP,NCONT,MODEF 4839 FORMAT('M',4I5/'M',6X,'2.00') 53 NNCONT=NCONT IF(NNCONT.GT.9) NNCONT=9 WRITE(8,539) NNCONT 539 FORMAT(' TYPE ',I1,' CONTOUR LEVELS') ACCEPT 5219,CONTL WRITE(30,5329) CONTL 5329 FORMAT('M',9F8.2) NCONT=NCONT-NNCONT IF(NCONT.GT.0) GO TO 53 52 CLOSE(UNIT=30) TYPE 599 599 FORMAT(' NOW EXIT AND DO....' 1 /' .ASS TTY TEK' 2 /' .RUN FOURTK[10,25]' 3 /' (CRYSTAL FILE = CRYST' 4 /' REFLEXION FILE = HKLFF)') RETURN END