C**** RAY00010 C**** RAY TRACE - MIT VERSION 1981 (01/28/82) RAY00020 C**** DR. STANLEY KOWALSKI RAY00030 C**** MASS INST OF TECH RAY00040 C**** BLDG 26-427 RAY00050 C**** CAMBRIDGE MASS 02139 RAY00060 C**** PH 617+253-4288 RAY00070 C**** RAY00080 C**** CHANGES ADDED AT LNL ARE MARKED: !JDL 10-NOV-83 C**** IMPLICIT REAL*8(A-H,O-Z) RAY00090 REAL*8 K RAY00100 LOGICAL LPLT c REAL*4 DAET, TYME RAY00101 COMMON /BLCK00/ LPLT include 'rtcomm0.f' COMMON /BLCK 1/ XI, YI, ZI, VXI, VYI, VZI, DELP, DELM !JDL RAY00120 COMMON /BLCK 2/ XO, YO, ZO, VXO, VYO, VZO, RTL(100), RLL(100) RAY00130 COMMON /BLCK 4/ ENERGY, VEL, PMASS, Q0 RAY00140 COMMON /BLCK 5/ XA, YA, ZA, VXA, VYA, VZA RAY00150 COMMON /BLCK 6/ NR, NP, NSKIP, JFOCAL, JMTRX, !JDL 16-MAR-84 RAY00160 1 JNR, NPLT, NRXS, LPAX, !JDL 31-OCT-84 2 NCAX,NHAX, NVAX, MEL, MCS, MCP, !JDL 31-OCT-84 3 DHAX,DVAX !JDL 31-0CT-84 COMMON /BLCK 7/ NCODE RAY00170 COMMON /BLCK10/ BX, BY, BZ, K, TC, DTC RAY00180 COMMON /BLCK11/ EX, EY, EZ, QMC, IVEC RAY00190 COMMON /BLCK15/ TMIN,PMIN,XMAX,TMAX,YMAX,PMAX,DMAX, !JDL RAY00195 1 STMN,SPMN,SXMX,STMX,SYMX,SPMX,SDMX,SUMX, !JDL 2 SEED,SEEP,DXHW,DTHW,DYHW,DPHW,DEHW,DMHW, !JDL 3 SEC1,SEC2,SEC3,SEC4,SEC5,SEC6,SEC7,SEC8 !JDL COMMON /BLCK16/ NLOOP,NPASS,IP,NCSV,KEEP(20), !JDL 17-NOV-83 1 LOOPSV(5,30),HOOPSV(30),HSAVE(30),PMSV(3), !JDL 2 CXXSV(12,3),CSV(36,3),CDSV(6,4,3)!JDL 17-NOV-83 COMMON /BLCK26/ IXS, XSCTR, ZSCTR !JDL 16-MAR-84 COMMON /BLCK60/ GAS,AGAS,ZGAS,ZION,PRESS,GASSIG,QAVER, !***MP 1-JAN-85 1 QFWHM,RHOGAS,GASK,EMASS,GASMFP,JRAY,Q00,NPASG !*** COMMON /BLCK61/ DEDX,ALPHAK,TOLD2,DEDXQ COMMON /BLCK62/ GASENE,GASVEL,TOLD,GASL COMMON /BLCK63/ ISEED include 'rtcomm65.f' COMMON /BLCK66/ tfwopt,taufct,alffct,TBAR,THWHM,tau0 common /blck70/ vel0,en0,pm0 common /blck71/ gasopt,zgas125,zgas18,dreldee,enold,icalc DIMENSION NCOLS(10,6), VECJ(10), VECK(10) !JDL 31-OCT-84 C*JDL DIMENSION DAET(3), TYME(2) RAY00191 C*IBM DIMENSION DAET(5), TYME(2) DIMENSION XO(100), YO(100), ZO(100), VXO(100), VYO(100), VZO(100) RAY00200 DIMENSION XI(100), YI(100), ZI(100), VXI(100), VYI(100), VZI(100),RAY00210 1 DELP(100) RAY00220 C*JDL DIMENSION NWORD(15),DATA( 75,30), IDATA(30),NTITLE(20),ITITLE(30) RAY00230 DIMENSION TC(6), DTC(6), R(6,6), T2(5,6,6) RAY00240 DATA TBAR/0./ DATA NWORD/'SENT', 'DIPO', 'QUAD', 'HEXA', 'OCTA', 'DECA', 'EDIP',RAY00250 1 'VELS', 'POLE', 'MULT', 'SHRT', 'DRIF', 'XXXX', 'SOLE', 'LENS',RAY00260 2 'CHAN'/ !JDL 17-NOV-83 DATA NCOLS /10, 5, 3, 6, 4, 6, 6, 6, 4, 7, !JDL 17-NOV-83 1 9, 5, 4, 6, 6, 0, 0, 0, 0, 0, 2 10, 5, 1, 8, 4, 6, 6, 0, 0, 0, 3 10, 5, 4, 4, 4, 6, 6, 6, 6, 0, 4 9, 4, 5, 4, 6, 6, 0, 0, 0, 0, 5 9, 6, 4, 6, 3, 0, 0, 0, 0, 0/ !JDL 17-NOV-83 DATA C /3.D10/ RAY00270 DATA TYME/ ' ', ' ' / character *4 nt1,nt2,nwd character *2 foil !MP 27-jul-93 DATA NT1, NT2/' RT8','2.0 '/ C data fTab/1.1/ !MP 13-nov-94 fwhmstg(Zab,Aab,Tab,Zio) = 1 dsqrt((Zab/Aab)*Tab*fTab)*Zio*0.924D-3 !MP 12-nov-94 C !MP C****fwhmstg calculates the energy straggling (fwhm) in MeV for an incident !MP C****ion with Z=Zio in a solid Z=Zab, A=Aab of thickness Tab (microg/cm2). !MP C****fwhmstg is used to calculate straggling in target and entrance foil. !MP C****fTab is a fudge factor for target thickness non-uniformity !MP C take fTab = 1.1 C**** RAY00280 C**** RAY00290 100 FORMAT( 8F10.5 ) RAY00300 120 FORMAT( 5F5.0,a2,3x,5F10.5 ) 101 FORMAT( 20A4 ) RAY00310 102 FORMAT(10I5) RAY00320 103 FORMAT( /// 10X, 'KEY WORD DOES NOT MATCH STORED LIST - NWD= 'A4)RAY00330 104 FORMAT( // 10X, ' GO TO STATEMENT IN MAIN FELL THROUGH - I= ' I5/)RAY00340 105 FORMAT( 1H1, 10X, 20A4 ) RAY00350 106 FORMAT( 1H1 ) RAY00360 107 FORMAT( 5F10.5/5F10.5/3F10.5/6F10.5/4F10.5/6F10.5/6F10.5/ !JDL RAY00370 1 6F10.5/ 4F10.5/ 7F10.5/ 7F10.5 )RAY00380 108 FORMAT('1',62X, 'RAY ', I4, // 30X, 'ENERGY=',F8.3,' MEV ', 7X, RAY00390 1 'PMOM=', F8.3, ' MEV/C', 6X, 'VELC=', 1PD11.3, ' CM/SEC' / RAY00400 2 30X, 'DELE/E=', 0PF8.3, ' (PC)', 5X, 'DELP/P=', F8.3, RAY00410 3 ' (PC) ', 4X, 'DELV/V=', F7.3, ' (PC)' /) RAY00420 109 FORMAT( 3F10.5/ 5F10.5/ 4F10.5/ 6F10.5/ 6F10.5 )RAY00430 111 FORMAT( 2F10.5/ 6F10.5/ 2F10.5/ 6F10.5/ 3F10.5 ) RAY00440 112 FORMAT( 3F10.5/ 4F10.5/ 5F10.5/ 4F10.5/ 6F10.5/ 6F10.5 ) RAY00450 113 FORMAT( A4, 16X, A4 ) RAY00460 114 FORMAT( 1F10.5 / 5F10.5 / 2F10.5 ) RAY00470 115 FORMAT( 4F10.5/ 5F10.5/ 4F10.5/ 4F10.5/ 4F10.5/ 6F10.5/ 6F10.5/ RAY00480 1 6F10.5/ 6F10.5 ) RAY00490 C**** !Changes from here... !JDL 10-MAR-84 1115 format( /10x,' Z(target) =', f10.1,/ !MP 30-jul-93 1 10x,' A(target) =', f10.1,/ !MP 30-jul-93 2 10x,' t(target) =', f10.1,' microg/cm2') !MP 30-jul-93 1116 format(//10x,' foil = ',a2,/ !MP 30-jul-93 1 10x,' t(foil) =', f10.1,' microg/cm2') !MP 30-jul-93 11165 format(//10x,' target energy loss (MeV) =', f10.2/ 1 10x,' target fwhm straggling (keV) =', f10.1) 11166 format(//10x,' foil energy loss (MeV) =', f10.2/ 1 10x,' foil fwhm straggling (keV) =', f10.1) 1117 format(//10x,' energy before target =', f10.4,' MeV',/ !MP 27-jul-93 1 10x,' energy after target =', f10.4,' MeV',/ !MP 27-jul-93 2 10x,' energy after foil =', f10.4,' MeV') !MP 27-jul-93 116 FORMAT(//10X, ' PARTICLE ENERGY =', F10.4, ' MEV ', RAY00500 1 15X,'NR =', I4, 7X, 'JNR =', I4,11X, 'ENERGY =', F9.4, / 2 10X, 'PARTICLE MOMENTUM =', F10.4, ' MEV/C ', RAY00510 3 15X,'NP =', I4, 7X, 'NPLT =', I4,11X, 'DEN =', F9.4, / 4 10X, 'PARTICLE VELOCITY =', F10.4, ' CM/NS ', RAY00520 5 15X,'NSKIP =', I4, 7X, 'NRXS =', I4,11X, 'XNEN =', F9.4, / 6 10X, ' MASS =', F10.4, ' AMU ', RAY00530 7 15X,'JFOCAL =', I4, 7X, 'LPAX =', I4,11X, 'PMASS =', F9.4, / 8 10X, ' CHARGE =', F10.4, ' EQ ', RAY00540 9 15X,'JMTRX =', I4, 7X, 12X, 11X, 'Q0 =', F9.4, / X 62X, 12X, 7X, 12X, 11X, 'DMASS =', F9.4 ) 117 FORMAT( 10X, 62X, 3A4, 1X, 2A4) !JDL 10-MAR-84 RAY00541 C**** !...down to here. !JDL 10-MAR-84 C*IBM117 FORMAT( 10X, 3A4, 1X, 2A4, 2A4 ) 118 FORMAT(4F10.5/5F10.5/F10.5/4F10.5/4F10.5/6F10.5/6F10.5) 119 FORMAT( F10.0, 10X, 6F10.5, /, 8F10.5) !JDL 13-OCT-84 C**** RAY00550 c CALL DATE(DAET) RAY00551 c CALL TIME(TYME) RAY00552 C*IBM CALL WHEN(DAET) C**** CALL ERRSET( NUMBER, CONT, COUNT, TYPE, LOG, MAXLIN ) RAY00553 c CALL ERRSET( 63, .TRUE., .FALSE., .FALSE., .FALSE., 2048) c CALL ERRSET( 72, .TRUE., .FALSE., .FALSE., .TRUE., 2560) RAY00560 c CALL ERRSET( 74, .TRUE., .FALSE., .FALSE., .TRUE., 2560) RAY00560 c CALL ERRSET( 88, .TRUE., .FALSE., .FALSE., .TRUE., 2560) RAY00560 c CALL ERRSET( 89, .TRUE., .FALSE., .FALSE., .TRUE., 2560) RAY00570 C*IBM CALL ERRSET( 207, 256, 1 ) C*IBM CALL ERRSET( 208, 256, 1 ) C*IBM CALL ERRSET( 209, 256, 1 ) C*IBM CALL ERRSET( 210, 256, 1 ) RAY00590 C**** RAY00600 C**** RAY00610 5 LPLT = .FALSE. JRAY = 0 NSK1 = 0 NSK2 = 0 T = 0. GASL = 0. TOLD = 0. TOLD2 = 0. NCSV=0 !JDL 18-NOV-83 NLOOP=0 !JDL 17-NOV-83 IVEC = 0 RAY00620 LNEN = 0 RAY00630 NPASG = 0 DLSQR0=0. ALOS0 = 0. DEDX0 = 0. qaver = 0. GSMFP0 = 0. SIGC0 = 0. SIGL0 = 0. tau0 = 0. icalc = 0 DO 1 I=1,30 RAY00640 IDATA(I)= 0 RAY00650 DO 1 J=1,75 RAY00660 DATA(J,I) = 0. RAY00670 1 CONTINUE RAY00680 READ ( 5,101,END=99) NTITLE RAY00690 IF( NTITLE(1) .EQ. 'END ' ) GO TO 99 !JDL 10-MAR-84 NTITLE(19) = NT1 NTITLE(20) = NT2 READ (5,102) NR, IP, NSKIP, JFOCAL, JMTRX, !JDL 11-MAR-84 RAY00700 1 JNR, NPLT, NRXS, LPAX !JDL 31-OCT-84 C*** add input data for target thickness and Z !MP 27-jul-93 READ (5,1022) ENERGY, DEN, ttgt, 2 XNEN, ztgt, PMASS, atgt, Q0, DMASS !JDL 10-NOV-83 RAY00710 C*** ttgt : effective thickness of target in microg/cm2 !MP 27-jul-93 C*** ztgt : Z of target !MP 27-jul-93 C*** atgt : A of target 1022 format(f10.5,6f5.0,2f10.5) !MP 27-jul-93 en00 = energy !MP 27-jul-93 C C*** en00 is used to recall original input energy; will never be changed C IF( NPLT .NE. 0 ) LPLT = .TRUE. IF(( NR .GT. 100).AND.( NRXS/10 .NE. 1 )) NR=100 !JDL 23-MAY-84 RAY00720 C*** C*** C*** add input data for pressure foil and thickness !MP 27-jul-93 READ (5,120) GAS, qopt, !MP 27-jul-93 * AGAS, tfoil, ZGAS, foil, ZION, PRESS, GASopt, * ACAPT,TFWopt !*** MP C C****** qopt = 0.: use Dimitriev formula for qbar C****** = 1.: use Betz gas formula for qbar ! 29-jan-99 C****** = more options : see rtqdist.for C*** tfoil : thickness of pressure foil in microgram/cm2 !MP 27-jul-93 C*** foil = MY : mylar foil !MP 27-jul-93 C*** = PP : polypropylene foil !MP 27-jul-93 C****** TFWopt > 0 : TFWopt = constant FWHM (radians) for mult.scatt C****** TFWopt < 0 : Small angle scattering calculated according C****** to Meyer-Sigmund-Winterbon theory by subroutine SMANGSC; C****** dabs(tfwopt) is then used as fudge factor to the hwhm cal- C****** culated in SMANGSC, i.e. TFWopt = -1. corresponds to the C****** original formula; TFWopt = -1.2 gives a 1.2 factor in cal- C****** culated hwhm. C C*** calculates energy loss in effective target thickness and !MP 27-jul-93 C*** replaces energy value by energy - loss !MP 27-jul-93 C*** This is for initial printing purpose. The actual calcula- C*** tion will be sampled for each ray in the ray loop. ztgt0 = ztgt !MP 27-jul-93 if (ztgt0.le.0.) ztgt = 6. if (ztgt0.le.0.) atgt = 12. dextgt = fsdedx(ztgt,atgt) !MP 28-jul-93 detgt = 0.001*ttgt*dextgt fwhmtgt = fwhmstg(ztgt,atgt,ttgt,zion) energy = energy - detgt en01 = energy ! C !MP 27-jul-93 C*** en01 is used only in PRINT statement C C*** calculates de/dx (MeV/mg/cm2) in foil material (mylar,polypropylene C*** or elemental) C zc = 6. !MP 27-jul-93 acar = 12. !MP 29-jul-93 zh = 1. !MP 27-jul-93 ahy = 1. !MP 29-jul-93 zox = 8. !MP 27-jul-93 aox = 16. !MP 29-jul-93 if (foil.eq.'pp') go to 11111 !MP 08-oct-02 if (foil.eq.'my') go to 11112 !MP 08-oct-02 if (foil.eq.'ti') go to 11113 !MP 08-oct-02 if (foil.eq.'ni') go to 11113 !MP 08-oct-02 go to 11113 11111 continue C*** for polypropylene (CH3CH=CH2)n : !MP 27-jul-93 C*** f(C) = 36/42.08 = 0.856 !MP 27-jul-93 C*** f(H) = 6.08/42.08 = 0.144 !MP 27-jul-93 fcpp = 0.856 !MP 27-jul-93 fhpp = 0.144 !MP 27-jul-93 C zeff = fcpp*zc + fhpp*zh !MP 12-nov-94 aeff = fcpp*acar + fhpp*ahy fwhmfl = fwhmstg(zeff,aeff,tfoil,zion) !MP 13-nov-94 C dexcpp = fsdedx(zc,acar) !MP 28-jul-93 dexhpp = fsdedx(zh,ahy) !MP 28-jul-93 dexf = fcpp*dexcpp + fhpp*dexhpp !MP 27-jul-93 go to 2222 !MP 27-jul-93 11112 continue C*** for mylar (C10H8O4) : !MP 27-jul-93 C*** fcmy = 120/192 = 0.625 !MP 27-jul-93 C*** fhmy = 8/192 = 0.042 !MP 27-jul-93 C*** fomy = 64/192 = 0.333 !MP 27-jul-93 fcmy = 0.625 !MP 27-jul-93 fhmy = 0.042 !MP 27-jul-93 fomy = 0.333 !MP 27-jul-93 C zeff = fcmy*zc + fhmy*zh + fomy*zox !MP 12-nov-94 aeff = fcmy*acar + fhmy*ahy + fomy*aox fwhmfl = fwhmstg(zeff,aeff,tfoil,zion) !MP 13-nov-94 C dexcmy = fsdedx(zc ,acar) !MP 28-jul-93 dexhmy = fsdedx(zh ,ahy ) !MP 28-jul-93 dexomy = fsdedx(zox,aox ) !MP 28-jul-93 dexf = fcmy*dexcmy + fhmy*dexhmy + dexomy*fomy !MP 27-jul-93 go to 2222 C*** elemental foils; default = Ti 11113 continue zfoil = 22. afoil = 47.89 if (foil.eq.'ti') zfoil = 22. if (foil.eq.'ti') afoil = 47.89 if (foil.eq.'ni') zfoil = 28. if (foil.eq.'ni') afoil = 58.69 C********* fwhmfl = fwhmstg(zfoil,afoil,tfoil,zion) dexf = fsdedx(zfoil,afoil) C !MP 27-jul-93 C*** calculates energy loss in foil and !MP 27-jul-93 C*** replaces energy value by energy - loss !MP 27-jul-93 C 2222 continue defoil = 0.001*tfoil*dexf energy = energy - defoil C C GASENE = ENERGY !***MP 1-JAN-85 enold = energy EMASS = PMASS*931.48 RAY00740 ETOT = EMASS + ENERGY RAY00760 VEL = ( DSQRT( ( 2.*EMASS + ENERGY)*ENERGY) / ETOT ) * C RAY00770 VEL0 = VEL RAY00780 EN0 = ENERGY RAY00790 PM0 = PMASS !JDL 12-MAR-84 PMOM0 = DSQRT( (2.*EMASS + EN0)*EN0) RAY00800 HENR = ENERGY !JDL 19-NOV-83 HPMS = PMASS !JDL 19-NOV-83 HPMO = PMOM0 !JDL 19-NOV-83 HVEL = VEL !JDL 19-NOV-83 Q00 = Q0 NEN = XNEN RAY00810 IF( NEN .EQ. 0 ) NEN = 1 RAY00820 THWHM = TFWopt * 0.5 * 1.D-3 IF (ZGAS.EQ.0.) ZGAS = 7. IF (AGAS.EQ.0.) AGAS = 28. IF (ZION.EQ.0.) ZION = 28. IF (GAS.EQ.0.) PRESS = 0. RHOGAS = AGAS*PRESS/(22.4*760.) GASK = (RHOGAS*C**2)/EMASS ALPHAK = .014*DSQRT(ZION*ZGAS/ 1 (ZION**.3333+ZGAS**.3333)) ATBCC = 6.D4*press/(22.4*760.) c ATBCC is 10**-16 * nb. of atoms or molecules ( for molecular gases ) per cc c c initial charge distribution in solid target ( entrance window ) c call sqdist qbars = qbar dsqrs0 = delsqr if (q00.le.0.) q0 = dnint(qbars) c QMC = EMASS/(9.D10*Q0) RAY00750 IF (GAS.EQ.0.) GO TO 6 c c calculation of c capture cross sections and charge distribution in gas c c if (qopt .ne. 0. .and. qopt .ne. 1. .and. qopt .ne. 2.) then c print *,'**** illegal value read for qopt:',qopt c print *,' use qopt = 0. for Dimitriev or qopt = 1. for Betz' c print *,' or qopt = 2. for Rehm (18F-18O) ' c stop 99 c endif zgas125 = zgas**1.25 zgas18 = zgas**1.8 CALL QDIST if (gasopt.le.0.) call sigcap if (gasopt.gt.0.) gassig = gasopt QAVER = QBAR DELQ0 = Q0 - QBAR CALL QSIG(DELQ0) ztil = dsqrt(zion**.6666667 + zgas**.6666667) c ** Oct 17, 1991 c ** added factor gas in following expression of taufct; see doc c ** taufct = gas*41.5/60./(ztil*ztil) alffct = 1.1d-3*zion*zgas*ztil*dabs(tfwopt)/57.296 if (tfwopt.lt.0.) call smangsc DEDX = FDEDX(QAVER) dedxq = dedx*(q0/qbar)**2 DLSQR0 = DELSQR ALOS0 = ALOS DEDX0 = DEDX GSMFP0 = GASMFP SIGC0 = SIGC SIGT0 = SIGT 6 CONTINUE NO = 1 RAY00830 2 READ (5,113) NWD, ITITLE(NO) RAY00840 DO 3 I=1,16 !JDL 17-NOV-83 RAY00850 IF( NWD .EQ. NWORD(I) ) GO TO 4 RAY00860 3 CONTINUE RAY00870 PRINT 103, NWD RAY00880 99 continue close(1) close(2) close(3) print *,'Bye ...' CALL EXIT RAY00890 4 GO TO( 11,12,13,13,13,13,17,18,19,20,21,22,23,24,25,26), I !JDL RAY00900 C**** RAY00910 C**** RAY00920 23 CONTINUE RAY00930 C**** RAY00940 PRINT 104, I RAY00950 CALL EXIT RAY00960 C**** RAY00970 C**** DIPOLE LENS TYPE = 2 RAY00980 C**** RAY00990 12 IDATA(NO) = 2 RAY01000 READ (5,107) ( DATA(J,NO), J=1,5 ), ( DATA(J,NO), J=11,24 ), !JDL RAY01010 1 ( DATA( J,NO ) , J=25,64) RAY01020 NO = NO + 1 RAY01030 GO TO 2 RAY01040 C**** RAY01050 C**** PURE MULTIPOLES RAY01060 C**** QUADRUPOLE LENS TYPE = 3 RAY01070 C**** HEXAPOLE LENS TYPE = 4 RAY01080 C**** OCTAPOLE LENS TYPE = 5 RAY01090 C**** DECAPOLE LENS TYPE = 6 RAY01100 C**** RAY01110 13 IDATA(NO) = I RAY01120 READ (5,109)( DATA( J,NO ) , J=1,3 ), ( DATA( J,NO ), J=10,30 ) RAY01130 NO = NO + 1 RAY01140 GO TO 2 RAY01150 C**** C**** ELECTROSTATIC DEFLECTOR TYPE=7 C**** 17 IDATA(NO) = 7 READ(5,118) (DATA(J, NO), J=1, 4), (DATA(J, NO), J=11,20), 1 (DATA(J, NO), J=25,40) NO = NO + 1 GO TO 2 C**** RAY01160 C**** VELOCITY SELECTOR TYPE = 8 RAY01170 C**** RAY01180 18 IDATA(NO) = 8 RAY01190 READ (5,115) ( DATA(J,NO),J=1,4), (DATA(J,NO), J=11,51 ) RAY01200 NO = NO + 1 RAY01210 GO TO 2 RAY01220 C**** RAY01230 C**** MULTIPOLE (POLES) TYPE = 9 RAY01240 C**** RAY01250 19 IDATA(NO) = 9 RAY01260 READ (5,112) ( DATA( J,NO ) , J=1,3 ), ( DATA( J,NO ), J=10,34 ) RAY01270 NO = NO + 1 RAY01280 GO TO 2 RAY01290 C**** RAY01300 C**** MULTIPOLE LENS TYPE = 10 RAY01310 C**** RAY01320 20 IDATA(NO) = 10 RAY01330 READ (5,111) ( DATA( J,NO ) , J=1,2 ), ( DATA( J,NO ), J=10,17 ), RAY01340 1 ( DATA( J,NO ) , J=20,28 ) RAY01350 NO = NO + 1 RAY01360 GO TO 2 RAY01370 C**** RAY01380 C**** SHIFT AND ROTATE TYPE = 11 RAY01390 C**** RAY01400 21 IDATA(NO) = 11 RAY01410 READ (5,100) ( DATA( J,NO ) , J=1,6 ) RAY01420 NO = NO + 1 RAY01430 GO TO 2 RAY01440 C**** RAY01450 C**** DRIFT TYPE = 12 RAY01460 C**** RAY01470 22 IDATA(NO) = 12 RAY01480 READ (5,100) ( DATA( J,NO ) , J=1,1 ) RAY01490 NO = NO + 1 RAY01500 GO TO 2 RAY01510 C**** RAY01520 C**** SOLENOID TYPE = 14 RAY01530 C**** RAY01540 24 IDATA(NO) = 14 RAY01550 READ (5,114) (DATA(J,NO),J=1,1), ( DATA(J,NO), J=10,16) RAY01560 NO = NO+1 RAY01570 GO TO 2 RAY01580 C**** RAY01590 C**** LENS TYPE = 15 RAY01600 C**** RAY01610 25 IDATA(NO) = 15 RAY01620 READ (5,100) (DATA(J,NO), J=1,8 ) RAY01630 NO = NO+1 RAY01640 GO TO 2 RAY01650 C**** Changes from here ... !JDL 17-NOV-83 C**** C**** CHANGE DATA & REPEAT TYPE = 16 C**** 26 IDATA(NO) = 16 NO=NO+1 IF(NO .GT. 30) GO TO 99 NLOOP=0 NPASS=0 DO 1680 NLP=1,30 READ (5,1605) NWD, IROW, JCOL, KUPLE, ITITLE(NO), HDATA 1605 FORMAT( A4,4X,I2,3X,I2, X,A4, A4, 6X, F10.5) IF(NWD .EQ. NWORD(1)) GO TO 11 !SENTINEL ENCOUNTERED NLOOP=NLOOP+1 IF(HDATA .EQ. 0.0) HDATA=0.01 NN=NO-1 DO 1620 INO=1,NN J=IDATA(INO) IF((NWD .EQ. NWORD(J)) .AND. 1 (ITITLE(NO) .EQ. ITITLE(INO))) GO TO 1630 1620 CONTINUE GO TO 1690 1630 IF((J .EQ. 4) .OR. (J .EQ. 5) .OR. (J .GT. 10)) J=3 IF(J .GT. 3) J=J-3 !COMPRESSES NCOLS(I,J) TABLE TO 6 TYPES. IJ=0 IR=IROW-2 !COUNT OF LINES INCLUDES ELEMENT TITLE AS ROW 1. IF((IR .LT. 0) .OR. (IR .GT. 10)) GO TO 1690 IF(IR .EQ. 0) GO TO 1650 DO 1640 I=1,IR 1640 IJ=IJ+NCOLS(I,J-1) 1650 IJ=IJ+JCOL IF((IJ .LT. 1) .OR. (IJ .GT. 64)) GO TO 1690 LOOPSV(1,NLOOP)=INO LOOPSV(2,NLOOP)=IROW LOOPSV(3,NLOOP)=JCOL LOOPSV(4,NLOOP)=KUPLE LOOPSV(5,NLOOP)=IJ HOOPSV( NLOOP)=HDATA 1680 CONTINUE C**** 1690 PRINT 103, NWD CALL EXIT C**** C**** ... down to here. !JDL 17-NOV-83 C**** C**** C**** RAY01660 C**** SYSTEM END TYPE = 1 RAY01670 C**** RAY01680 11 IDATA(NO) = 1 RAY01690 C**** RAY01700 C**** STANDARD RAYS AUTOMATIC SET-UP RAY01710 C**** IF( NR .GT. JNR ) APPEND ADDITIONAL RAYS FROM INPUT C**** C**** !From here... !JDL 10-MAR-84 MCP = 0 !CONTOUR MCS = 0 !SPECTRUM MEL = 0 !ELLIPSE IF (JNR.EQ.0) GO TO 66 RAY01711 READ (5,100) TMIN,PMIN,XMAX,TMAX,YMAX,PMAX,DMAX RAY01713 IF( NRXS .NE. 0 ) 1 READ (5,100) STMN,SPMN,SXMX,STMX,SYMX,SPMX,SDMX,SUMX CALL RAYS( JNR, NR, NRXS ) !JDL 10-MAR-84 RAY01714 C**** C**** SUBROUTINE RAYS CREATES STANDARD RAY SETS WHEN JNR = 2, 6, 14, 46 C**** USING DATA FROM A SINGLE RAY CARD FOLLOWING SENTINEL. THEN, C**** IF NR < JNR, RAYTRACE WILL USE ONLY THE FIRST NR OF THE JNR TOTAL. C**** HOWEVER, IF NR > JNR, THEN ADDITIONAL RAYS WILL BE APPENDED C**** IN ONE OF THE FOLLOWING OPTIONAL WAYS: C**** C**** NRXS = 0, READ (NR-JNR) MORE RAY CARDS FROM INPUT FILE. C**** C**** 1-9, READ ONE MORE RAY CARD FROM INPUT FILE AND C**** AUTOMATICALLY GENERATE PHASE-SPACE ELLIPSES C**** CONTAINING (NR-JNR) EQUALLY SPACED RAYS USING C**** DIAGONAL SCAN (NRXS=1, X AND Y IN PHASE) OR C**** CIRCULAR SCAN (NRXS=2, X LEADS Y BY 90-DEG) OR C**** ELLIPSOID SCAN (NRXS=3, X ELLIPSE AT EACH Y). C**** C**** 11-19, READ ONE MORE RAY CARD FROM INPUT FILE AND C**** AUTOMATICALLY GENERATE (NR-JNR) RANDOM RAYS C**** STARTING FROM A FIXED SEED (NRXS=11) OR C**** STARTING FROM A RANDOM SEED (NRXS=12). C**** C**** 13, READ TWO DATA CARDS (TOTAL OF 4 AFTER SENTINEL) C**** FOR SEED INPUT AND/OR SPECTRUM ENHANCEMENT. C**** C**** 21-29, READ ONE MORE RAY CARD FROM INPUT FILE AND C**** AUTOMATICALLY GENERATE CONTOUR PLOT FROM A C**** FIXED GRID EXTENDING (NR-JNR) RAYS EACH SIDE C**** OF CENTER IN TWO DIMENSIONS (SELECTED BY LPAX) C**** WITH INCREMENTS FROM THIS CARD. ANY NON-ZERO C**** ENTRIES NOT SELECTED AS AXES GIVE FIXED OFFSETS. C**** C**** C**** IF((NR .LE. JNR) .OR. (NRXS .EQ. 0)) GO TO 66 IF((NRXS .GE. 1) .AND. (NRXS .LE. 9)) MEL = JNR IF((NRXS .GE. 11) .AND. (NRXS .LE. 19)) MCS = NR-JNR IF((NRXS .GE. 21) .AND. (NRXS .LE. 29)) MCP = NR-JNR SEED = 0.0 IF((MEL .NE. 0 ) .OR. ( MCP .NE. 0 )) GO TO 52 IF( MCS .EQ. 0 ) GO TO 66 C**** C**** FOR SPECTRUM ENHANCEMENT OPTION (NRXS = 13) C**** READ TWO MORE DATA CARDS: C**** SEED, DXHW,DTHW,DYHW,DPHW,DEHW,DMHW, C**** SEC1,SEC2,SEC3,SEC4,SEC5,SEC6,SEC7,SEC8 C**** IF( NRXS .EQ. 13 ) READ(5,119) 1 SEED, DXHW,DTHW,DYHW,DPHW,DEHW,DMHW, 2 SEC1,SEC2,SEC3,SEC4,SEC5,SEC6,SEC7,SEC8 c ISEED = INT(100.0*SECNDS(0.0)) ISEED = INT(100.0*SECNDS(0.0)) IF( NRXS .EQ. 11 ) ISEED = 29 IF(( NRXS .NE. 13 ) .OR. ( SEED .EQ. 0.0 )) GO TO 149 IF( SEED .LT. 4.0D9 ) ISEED = IDINT( SEED - 1.0D9 ) IF( SEED .GT. 4.0D9 ) ISEED = IDINT( SEED - 7.0D9 ) 149 SEEP = DFLOAT( ISEED ) + 1.0D9 IF( ISEED .LT. 0 ) SEEP = SEEP + 6.0D9 IF( STMN .EQ. 0.0 ) STMN = 0.1 !DEFAULT TO 0.1 CM PER CHANNEL GO TO 52 C*JDL IF( JNR .GE. NR ) GO TO 52 C*JDL JNRP = JNR+1 C*JDL DO 49 J=JNRP,NR C**49 READ(5,100,END=60) XI(J),VXI(J),YI(J),VYI(J),ZI(J),VZI(J), C*JDL1 DELP(J) C*JDL GO TO 52 RAY01715 C**** C**** INPUT RAYS C**** 66 CONTINUE IF( NR .LE. JNR ) GO TO 52 JNRP = JNR+1 NRMX = NR IF( NRMX .GT. 100 ) NRMX = 100 DO 56 J=JNRP,NRMX !...to here. !JDL 5-MAR-84 RAY01720 READ(5,100,END=60 )XI(J),VXI(J),YI(J),VYI(J),ZI(J),VZI(J),DELP(J) RAY01730 56 CONTINUE RAY01740 GO TO 52 RAY01750 60 NR = J-1 RAY01760 52 CONTINUE !From here ... !JDL 19-NOV-83 ENERGY = HENR PMASS = HPMS PMOM0 = HPMO VEL = HVEL VEL0 = VEL EN0 = ENERGY PM0 = PMASS EMASS = PMASS*931.48 QMC = EMASS/(9.0D10*Q0) ETOT = EMASS + EN0 C**** C**** BEGIN ENERGY-STEP LOOP C**** ! ... to here. !JDL 19-NOV-83 DO 53 JEN=1,NEN !JDL 19-NOV-83 RAY01770 C**** RAY01780 C**** RAY01790 C**** RAY01800 NP = IP RAY01810 IF( (NP .LE. 100) .OR. (NP .GE. 200) ) GO TO 65 RAY01820 IF( JEN .EQ. (NEN/2+1) ) NP = IP-100 RAY01830 65 CONTINUE RAY01840 IF( (NP .GT. 100) .AND. (JEN .NE. 1) ) GO TO 55 RAY01850 IF( (IP .GT. 500) .AND. (NCSV .GT. 0) ) GO TO 55 !JDL 15-NOV-83 PRINT 105, NTITLE RAY01860 PRINT 117, DAET, TYME RAY01861 VNS = VEL0*1.0D-9 !JDL 10-MAR-84 C** C** print 1115, ztgt,atgt,ttgt !MP 30-jul-93 print 1116, foil,tfoil !MP 30-jul-93 print 11165, detgt,1.D3*fwhmtgt print 11166, defoil,1.D3*fwhmfl print 1117, en00,en01,en0 !MP 30-jul-93 PRINT 116, EN0, NR, JNR, HENR, !JDL 10-MAR-84 RAY01870 1 PMOM0, IP, NPLT, DEN, !JDL 10-MAR-84 2 VNS, NSKIP, NRXS, XNEN, !JDL 10-MAR-84 3 PM0, JFOCAL,LPAX, HPMS, !JDL 31-OCT-84 4 Q00, JMTRX, Q00, DMASS !JDL 10-MAR-84,MP SEP-87 PRINT 1160, 1 GAS,AGAS,ZGAS,PRESS, 2 PMASS,ZION, * qbars,dsqrs0, 3 QAVER,DLSQR0, $ qopt, $ TFWopt,thwhm, 4 Q0, * gasopt,ACAPT,ALOS0, 5 GSMFP0,SIGC0,SIGT0, 6 DEDX0 DO 54 NO = 1,30 RAY01880 ITYPE = IDATA(NO) RAY01890 IF( ITYPE .EQ. 1 ) GO TO 151 !JDL 16-MAR-84 RAY01900 54 CALL PRNT( ITYPE, NO ) RAY01910 C**** !Changes from here... !JDL 6-MAR-84 151 CALL PRNTA 55 IF((NP .GT. 100).AND.(IP .LT. 500).AND.(JEN .EQ. 1))PRINT 106!JDL RAY01920 IF(( MCS .NE. 0 ) .OR. ( MCP .NE. 0 )) NR = JNR + 1 NVAX = MOD( LPAX, 10 ) !VERT AXIS FOR LINEPRINTER PLOT NHAX = MOD( LPAX/10, 10 ) !HORZ AXIS NCAX = MOD( LPAX/100, 10 ) !CONTOUR AXIS IF( NVAX .EQ. 0 ) NVAX = 10 IF( NHAX .EQ. 0 ) NHAX = 10 IF((NCAX .EQ. 0 ) .AND. ( MCP .NE. 0 )) NCAX = 10 IF( LPAX .NE. 0 ) GO TO 1552 NCAX = 0 !DEFAULT TO ORIGINAL PLOT (THETA-VERSES-X). NHAX = 1 NVAX = 2 IF( MCP .EQ. 0 ) GO TO 1552 NCAX = 1 !DEFAULT TO X-CONTOURS IN (PHI-VERSES-THETA) PLANE. NHAX = 2 NVAX = 4 1552 CONTINUE C**** C**** BEGIN RAY-TRACE LOOP C**** DO 57 J=1,NR 930 IF(J.GT.JNR) JRAY=1 IF(J .LE. JNR) GO TO 155 IF(MEL .EQ. 0) GO TO 152 NM = 3 !ELLIPSES MAY BE DIVIDED INTO 3 MASS GROUPS. NS = (NR-JNR+NM-1)/NM DELM = SUMX*FLOAT((J-JNR-1)/NS-1) PMASS = (1.0+DELM/100.0)*PM0 152 IF(( MCS .EQ. 0 ) .AND. ( MCP .EQ. 0 )) GO TO 155 C**** C**** MULTI-CHANNEL SPECTRUM OPTION C**** C**** TO USE, SET NR = TOTAL RAYS, JNR = 2, 6, 14 OR 46 AND C**** NRXS = 11 (FIXED SEED) OR 12 (RANDOM START). AFTER SENTINEL, C**** PLACE ON SECOND RAY CARD THE FOLLOWING (8F10.5): C**** C**** STMN = DISPLACEMENT (CM) PER CHANNEL IN SPECTRUM. C**** SPMN = DISPLACEMENT (CM) AT CHANNEL 50 (CENTER). C**** SXMX = SAMPLE LIMITS IN X (CM). C**** STMX = SAMPLE LIMITS IN THETA (MRAD). C**** SYMX = SAMPLE LIMITS IN Y (CM). C**** SPMX = SAMPLE LIMITS IN PHI (MRAD). C**** SDMX = SAMPLE LIMITS IN ENERGY (PERCENT). C**** SUMX = SAMPLE LIMITS IN MASS (PERCENT) (INTEGERS). C**** C**** STARTING RAYS ARE SELECTED AT RANDOM FROM WITHIN PLUS/MINUS C**** RANGE OF SAMPLE LIMITS. STANDARD RAYS BASED ON CHOICE OF JNR C**** ARE USED TO DETERMINE FOCAL PLANE AND DO MATRIX ANALYSIS, C**** BUT ONLY RANDOM RAYS APPEAR IN SPECTRUM LISTINGS AND PLOTS. C**** NRAY = MCS DO 153 I= NR, 100 XI(I) = 0.0 YI(I) = 0.0 ZI(I) = 0.0 VXI(I) = 0.0 VYI(I) = 0.0 VXI(I) = 0.0 DELP(I)= 0.0 XO(I) = 0.0 YO(I) = 0.0 ZO(I) = 0.0 VXO(I) = 0.0 VYO(I) = 0.0 VZO(I) = 0.0 RLL(I) = 0.0 RTL(I) = 0.0 153 CONTINUE IF( MCP .EQ. 0 ) GO TO 154 C**** C**** CONTOUR-MAP OPTION C**** C**** TO USE: SET NRXS=21-29, SELECT CONTOUR AXES USING LPAX, AND C**** SET CORRESPONDING NON-ZERO GRID RANGES ON CARD 2 AFTER SENTINEL. C**** C**** LPAX = C H V (C,H,V) RAYS SPECTRA CONTOURS C**** : : : C**** : : :...VERT AXIS 1 = X(CM) X(CM) SXMX C**** : :.....HORZ AXIS 2 = TH(MR) COUNTS(X) STMX C**** :....CONTOUR AXIS 3 = Y(CM) Y(CM) SYMX C**** 4 = PHI(MR) COUNTS(Y) SPMX C**** NRXS = 21, 1 (a) 5 = DL(CM) ALL-CNTS(X) SDMX C**** 22, 3 (b) NUMBER 6 = DT(NS) COUNTS(T) SUMX C**** 23, 5 (c) OF 7 = DE(PCT) *DE(PCT) 0.0 C**** 24, 7 (d) CONTOURS 8 = DM(PCT) *DM(PCT) 0.0 C**** 25, 9 (e) 9 = ENERGY *ENERGY 0.0 C**** 26, 11 (f) (center 0 = MASS *MASS 0.0 C**** 27, 15 (h) letter) C**** 28, 21 (k) * = ABNORMAL USAGE C**** 29, 25 (m) C**** C**** C**** ...CONTOUR SPACING (CM). C**** : ...CONTOUR CENTER (CM). C**** : : .................................GRID MAXIMA C**** : : : : : : : : (SELECT 2). C**** STMN, SPMN, SXMX, STMX, SYMX, SPMX, SDMX, SUMX C**** * * 1 2 3 4 5 6 = LPAX DIGIT. C**** C**** C**** IF( STMN .EQ. 0.0 ) STMN = 0.1 !DEFAULT O.1CM INTERVALS IF( NHAX .EQ. 5 ) NHAX = 7 !EXTERNAL ENTRIES 5 AND 6 IF( NVAX .EQ. 5 ) NVAX = 7 !BECOME INTERNAL 7 AND 8. IF( NHAX .EQ. 6 ) NHAX = 8 IF( NVAX .EQ. 6 ) NVAX = 8 VECJ(1) = SXMX !LPAX POINTS TO VARIABLES ON AXES. VECJ(2) = STMX !ALL OTHERS ARE CONSTANT OFFSETS. VECJ(3) = SYMX VECJ(4) = SPMX VECJ(5) = 0.0 VECJ(6) = 0.0 VECJ(7) = SDMX VECJ(8) = SUMX VECJ(9) = 0.0 VECJ(10) = 0.0 IF( MCP .GT. 8 ) MCP = 8 IF((MCP .GT. 6 ) .AND. ( JNR .GT. 14 )) MCP = 6 DVAX = DFLOAT( MCP ) DHAX = VECJ(NHAX)/DVAX DVAX = VECJ(NVAX)/DVAX VECJ(NHAX) = 0.0 !AXIS VARIABLES CENTERED ON ZERO. VECJ(NVAX) = 0.0 NCQAD = 4 !SET LOOP INDICES NCHOR = MCP + 1 NCVER = MCP + 1 NCSAV = JNR + 2 C**** GO TO 154 C**** 154 CONTINUE !ENTRY POINT FOR RAY-SAMPLING LOOPS (J=JNR+1) DO 1541 I = J,49 K = 50+J-I XI(K) = XI(K-1) !PUSH USED INPUT RAYS ONTO FIFO STACK. YI(K) = YI(K-1) !SAVE THE LAST (50-JNR) RAY SAMPLES. ZI(K) = ZI(K-1) VXI(K) = VXI(K-1) VYI(K) = VYI(K-1) 1541 DELP(K) = DELP(K-1) IF( MCP .NE. 0 ) GO TO 1545 XI(J) = SXMX*(2.0*RAN(ISEED)-1.0) !RANDOM RAYS FOR SPECTRA YI(J) = SYMX*(2.0*RAN(ISEED)-1.0) ZI(J) = 0.0 VXI(J) = STMX*(2.0*RAN(ISEED)-1.0) VYI(J) = SPMX*(2.0*RAN(ISEED)-1.0) VZI(J) = 0.0 DELP(J)= SDMX*(2.0*RAN(ISEED)-1.0) DELM = SUMX*(2.0*RAN(ISEED)-1.0) PMASS = PM0+ANINT(PM0*DELM/100.0) GO TO 155 1545 XI(J) = VECJ(1) !RAYS FOR CONTOUR GRID YI(J) = VECJ(3) ZI(J) = 0.0 VXI(J) = VECJ(2) VYI(J) = VECJ(4) VZI(J) = 0.0 DELP(J)= VECJ(7) DELM = VECJ(8) PMASS = PM0*( 1.0 + DELM/100.0 ) DHAX = DABS( DHAX ) DVAX = DABS( DVAX ) IF(( NCQAD .EQ. 2 ) .OR. ( NCQAD .EQ. 3 )) DHAX = -DHAX IF(( NCQAD .EQ. 3 ) .OR. ( NCQAD .EQ. 4 )) DVAX = -DVAX C**** GO TO 155 155 CONTINUE !RESUME NORMAL PATH IF (JRAY.NE.0.AND.DMASS.NE.0.) 1 PMASS = PM0 + 0.5*DMASS*RANDOM(1,ISEED) IXS = 0 XSCTR = 0.0 ZSCTR = 0.0 EMASS = PMASS*931.48 TOLD = 0. NSK1 = 0 NSK2 = 0 TOLD2 = 0 GASL = 0. NPASG = 0 tau0 = 0. icalc = 0 C**** !...down to here. !JDL 6-MAR-84 ENERGY = (1.+DELP(J)/100. ) *EN0 RAY01940 IF (JRAY.NE.0.AND.DEN.NE.0.) 1 ENERGY = EN0 + 0.5*DEN*RANDOM(1,ISEED) ETOT = EMASS + ENERGY RAY01950 VEL = ( DSQRT( (2.*EMASS + ENERGY) *ENERGY) /ETOT)*C RAY01960 PMOM = DSQRT( (2.*EMASS + ENERGY) *ENERGY) RAY01970 C*** bypasses previous change of energy !MP 12-nov-94 C C*** initializes energy to input value C energy = en00 C C*** includes now energy loss + straggling in target !MP 12-nov-94 C if (jray.ne.0) 1 energy = energy - detgt + 0.5*fwhmtgt*random(1,iseed) !MP 12-nov-94 C C*** includes now energy loss + straggling in foil !MP 12-nov-94 C*** using Zeff,Aeff values for foil and tfoil !MP 12-nov-94 C if(jray.ne.0) 1 energy = energy - defoil + 0.5*fwhmfl*random(1,iseed) !MP 12-nov-94 C C C*** following initializing lines copied from elsewhere !MP 12-nov-94 C C GASENE = ENERGY !***MP 1-JAN-85 enold = energy EMASS = PMASS*931.48 RAY00740 ETOT = EMASS + ENERGY RAY00760 VEL = ( DSQRT( ( 2.*EMASS + ENERGY)*ENERGY) / ETOT ) * C RAY00770 VEL0 = VEL RAY00780 EN0 = ENERGY RAY00790 PM0 = PMASS !JDL 12-MAR-84 PMOM0 = DSQRT( (2.*EMASS + EN0)*EN0) RAY00800 C Q0 = Q00 IF (Q00.GT.0) GO TO 1542 c c initial charge distribution in solid target ( entrance window ) c c CALL sQDIST c QHWHM = DSQRT(DELSQR)*1.17741 c 1543 Q0 = QBAR + QHWHM*RANDOM(1,ISEED) c Q0 = DNINT(Q0) c c sample charge distribution (Sayer formula, setup by SDQDIST) c 1543 call sqsamp IF (Q0.GT.ZION.OR.Q0.LE.0.) GO TO 1543 ! should never happen! IF (JRAY.EQ.0) Q0 = DNINT(qbars) 1542 CONTINUE QMC = EMASS/(9.D10*Q0) K = (Q0/ETOT)*9.D10 C**** T = 0. JRAYGAS = JRAY*GAS IF (JRAYGAS.EQ.0) GO TO 1551 c c charge distribution in gas c enold = energy CALL QDIST if (gasopt.le.0.) call sigcap DELQ0 = Q0 - QBAR CALL QSIG(DELQ0) call discol0 ! initialise collision distances if (tfwopt.lt.0.) call smangsc DEDX = FDEDX(Q0) dedxq = dedx*(q0/qbar)**2 1551 CONTINUE NUM = 0 XA = XI(J) RAY02010 YA = YI(J) RAY02020 ZA = ZI(J) RAY02030 VXA =VEL*DSIN( VXI(J)/1000. ) * DCOS( VYI(J)/1000. ) RAY02040 VYA =VEL*DSIN( VYI(J)/1000. ) RAY02050 VZA =VEL*DCOS( VXI(J)/1000. ) * DCOS( VYI(J)/1000. ) RAY02060 XDVEL = (VEL-VEL0)*100./VEL0 RAY02070 DELTP = (PMOM-PMOM0)*100./PMOM0 RAY02080 IF( NP .LE. 100) PRINT 108,J, ENERGY,PMOM,VEL,DELP(J),DELTP,XDVEL RAY02090 DO 50 NO =1,30 RAY02100 ITYPE = IDATA(NO ) RAY02110 GO TO(31,32,33,33,33,33,37,38,39,40,41,42,43,44,45,46),ITYPE !JDL RAY02120 43 CALL EXIT !JDL 17-NOV-83 RAY02130 C**** RAY02140 C**** RAY02150 32 CALL DIPOLE ( NO, NP, T, TP ,NUM ) RAY02160 GO TO 51 RAY02170 33 NCODE = ITYPE-2 RAY02180 CALL MULTPL ( NO, NP, T, TP ,NUM ) RAY02190 GO TO 51 RAY02200 37 IVEC = 1 CALL EDIPL(NO, NP, T, TP, NUM) IVEC = 0 GO TO 51 38 IVEC = 1 RAY02210 CALL VELS ( NO, NP, T, TP ,NUM ) RAY02220 IVEC = 0 RAY02230 GO TO 51 RAY02240 39 CALL POLES ( NO, NP, T, TP ,NUM ) RAY02250 GO TO 51 RAY02260 40 CALL MULT ( NO, NP, T, TP ,NUM ) RAY02270 GO TO 51 RAY02280 41 CALL SHROT ( NO, NP, T, TP ,NUM ) RAY02290 GO TO 50 RAY02300 42 CALL DRIFT ( NO, NP, T, TP ,NUM ) RAY02310 GO TO 50 RAY02320 44 CALL SOLND ( NO, NP, T, TP ,NUM ) RAY02330 GO TO 51 RAY02340 45 CALL LENS ( NO, NP, T, TP ,NUM ) RAY02350 GO TO 50 RAY02360 46 GO TO 50 !JDL 17-NOV-83 51 XA = TC(1) RAY02370 YA = TC(2) RAY02380 ZA = TC(3) RAY02390 VXA= TC(4) RAY02400 VYA= TC(5) RAY02410 VZA= TC(6) RAY02420 50 CONTINUE RAY02430 31 CONTINUE RAY02440 CALL OPTIC( J, JFOCAL, NP, T, TP ) RAY02450 IF (LPLT ) CALL PLTOUT ( JEN, J, NUM ) C**** !Changes from here... !JDL 6-MAR-84 IF(((MCS .EQ. 0) .AND. (MCP .EQ. 0)) .OR. (J .LE. JNR)) GO TO 57 IF( MCP .NE. 0 ) GO TO 250 ZI(J) = XSCTR !CENTER COORDINATES AT SLITS. C**** COUNT THE RAYS THAT PASS BETWEEN SLITS IN DIPOLE MAGNET. IF(IXS .EQ. 0) DELP(88) = DELP(88)+1.0 !ERROR, SLITS NOT FOUND IF(IXS .EQ. -2) DELP(91) = DELP(91)+1.0 !RAY LOW IN X IF(IXS .EQ. +1) DELP(92) = DELP(92)+1.0 !RAY THRU SLITS IF(IXS .EQ. -1) DELP(93) = DELP(93)+1.0 !RAY HIGH IN X DELP(100) = DELP(100)+1.0 !ALL RAYS C**** C**** SORT RAYS INTO MULTI-CHANNEL SPECTRA. C**** IF NRXS=13, APPLY SPECTRUM ENHANCEMENT TO X-COORDINATE C**** BASED ON KNOWN CORRELATION OF X WITH THETA AND ENERGY. C**** INCLUDE RANDOM MEASUREMENT UNCERTAINTIES: C**** DXHW(CM) = HALF-WIDTH OF GAUSSIAN NOISE IN X. C**** DTHW(MR) = HALF-WIDTH OF GAUSSIAN NOISE IN THETA. C**** DEHW(%) = HALF-WIDTH OF GAUSSIAN NOISE IN ENERGY. C**** c c write additional multi-channel spectrum file of final state of particle c to use other programs for graphic disply. c x0,y0 [cm] coordinates in focal plane c GASENE [MeV] final energy of particle c q final charge state c t*1E9 [nsec] time of flight throughout instrument c WRITE(3,3333) XO(J),yo(j),GASENE,q0,t*1.E9 3333 FORMAT(5F10.4) IF(NRXS .NE. 13) GO TO 256 K=1 XOJ = XO(J) VXOJ = VXO(J) DEOJ = 100.0*(ENERGY - EN0)/EN0 IF(DXHW .NE. 0.0) XOJ = XOJ +DXHW*RANDOM(K,ISEED) IF(DTHW .NE. 0.0) VXOJ = VXOJ+DTHW*RANDOM(K,ISEED) IF(DEHW .NE. 0.0) DEOJ = DEOJ+DEHW*RANDOM(K,ISEED) VXOT = VXOJ + SEC1*XOJ XO(J) = XOJ + (SEC2*VXOT*VXOT+SEC3*VXOT*DEOJ+SEC4*DEOJ*DEOJ) 1 + (SEC5*VXOT*VXOT+SEC6*VXOT*DEOJ+SEC7*DEOJ*DEOJ)*VXOT 2 + ( SEC8*DEOJ*DEOJ)*DEOJ 256 CONTINUE IX=INT((XO(J)-SPMN)/STMN+50.5) IY=INT((YO(J) )/STMN+50.5) IZ=INT((RTL(J)*1.0D+09/VEL)/STMN+50.5) IF((IX .GE. 1) .AND. (IX .LE. 50)) XI(IX+50) = XI(IX+50) +1.0 IF((IX .GE. 51) .AND. (IX .LE. 100)) VXI(IX) = VXI(IX) +1.0 IF(IXS .LT. 0) GO TO 156 !RAY HIT A SLIT IF((IX .GE. 1) .AND. (IX .LE. 50)) XO(IX+50) = XO(IX+50) +1.0 IF((IX .GE. 51) .AND. (IX .LE. 100)) VXO(IX) = VXO(IX) +1.0 IF((IY .GE. 1) .AND. (IY .LE. 50)) YO(IY+50) = YO(IY+50) +1.0 IF((IY .GE. 51) .AND. (IY .LE. 100)) VYO(IY) = VYO(IY) +1.0 IF((IZ .GE. 1) .AND. (IZ .LE. 50)) RLL(IZ+50)= RLL(IZ+50)+1.0 IF((IZ .GE. 51) .AND. (IZ .LE. 100)) RTL(IZ) = RTL(IZ) +1.0 IF((IX .GE. 1) .AND. (IX .LE. 100)) 1 DELP(97) = DELP(97)+1.0 !RAY WITHIN SPECTRUM IF(IX .LT. 1) DELP(96) = DELP(96)+1.0 !RAY BELOW SPECTRUM IF(IX .GT.100) DELP(98) = DELP(98)+1.0 !RAY ABOVE SPECTRUM 156 NRAY=NRAY-1 IF(NRAY .GT. 0) GO TO 154 !LOCK TO J=(JNR+1) FOR NRAY PASSES GO TO 57 C**** GENERATE RAYS IN RECTANGULAR GRID FOR CONTOUR MAPPING. 250 CONTINUE VECK(1) = XO(J) VECK(2) = VXO(J) VECK(3) = YO(J) VECK(4) = VYO(J) VECK(5) = RLL(J) VECK(6) = RTL(J) VECK(7) = DELP(J) VECK(8) = DELM VECK(9) = ENERGY VECK(10) = MASS XOJ = ( VECK(NCAX) - SPMN ) / STMN !RE-SCALE TO CONTOUR STEPS IF( NCQAD .EQ. 1 ) YO(NCSAV) = XOJ !SAVE BY QUADRANTS IF( NCQAD .EQ. 2 ) VYO(NCSAV) = XOJ IF( NCQAD .EQ. 3 ) RLL(NCSAV) = XOJ IF( NCQAD .EQ. 4 ) RTL(NCSAV) = XOJ NCSAV = NCSAV + 1 VECJ(NHAX) = VECJ(NHAX) + DHAX NCHOR = NCHOR - 1 IF( NCHOR .GT. 0 ) GO TO 154 NCHOR = MCP + 1 VECJ(NHAX) = 0.0 VECJ(NVAX) = VECJ(NVAX) + DVAX NCVER = NCVER - 1 IF( NCVER .GT. 0 ) GO TO 154 NCVER = MCP + 1 VECJ(NVAX) = 0.0 NCSAV = JNR + 2 NCQAD = NCQAD - 1 IF( NCQAD .GT. 0 ) GO TO 154 C**** GO TO 57 C**** !...down to here. !JDL 6-MAR-84 57 CONTINUE RAY02460 C**** C**** END RAY-TRACE LOOP C**** IF(MCS .NE. 0) NR = JNR !JDL 6-MAR-84 ENERGY = EN0 RAY02470 PMASS = PM0 !JDL 12-MAR-84 VEL = VEL0 IF( NP .GT. 100 ) GO TO 59 RAY02480 PRINT 105, NTITLE RAY02490 PRINT 117, DAET,TYME RAY02491 PRINT 116, EN0, NR, JNR, HENR, !JDL 10-MAR-84 RAY02500 1 PMOM0, IP, NPLT, DEN, !JDL 10-MAR-84 2 VNS, NSKIP, NRXS, XNEN, !JDL 10-MAR-84 3 PM0, JFOCAL,LPAX, HPMS, !JDL 31-OCT-84 4 Q00, JMTRX, Q00, DMASS !JDL 10-MAR-84,MP SEP-87 1160 FORMAT(////,' GAS =',F10.0,' AT/MOL', 5X, 1 'AGAS =', F10.0, 13X, * 'ZGAS =', F10.0, 13x, 1 'PRESS = ',F10.2,' TORR',/ 2 ' AION =',F10.0, 13X, 3 'ZION =', F10.0,// * ' window : Qbar = ',f10.3, 10x, * 'Dsqr = ', f10.4,/ 4 ' gas : Qbar = ',F10.3, 10X, 5 'Dsqr = ',F10.4,/, $ ' QDist formula = ',F5.0, $ ' (0.=Dimitriev,1.=Betz)',// 1 ' A1/2 opt =', F10.3,10X, * 'THWHM = ',d10.4,' RAD',/ 6 ' q0 =', F10.0,/ * ' gas opt =', F10.3,10X, * 'ACAP = ',F10.4, 9X, 7 'ALOS0 = ',F10.4,/ 8 ' MFP0 = ',F10.3,' CM ',5X, 9 'SIGC0 =',D10.3, ' A0SQR', 7x, * 'SIGT0 =',D10.3, ' A0SQR', / 1 ' DEDX0 = ',F10.3,' MEV/(MG/CM2)'/) DO 58 NO =1,30 RAY02510 ITYPE = IDATA(NO ) RAY02520 IF ( ITYPE .EQ. 1 ) GO TO 158 !JDL 16-MAR-84 RAY02530 58 CALL PRNT( ITYPE, NO ) RAY02540 158 CALL PRNTA !JDL 16-MAR-84 59 CONTINUE RAY02550 C**** !Changes from here... !JDL 10-MAR-84 C*JDL IF( NSKIP .NE. 0 ) GO TO 61 RAY02560 C*JDL IF( NR .GE. 46 ) GO TO 62 RAY02570 C*JDL IF( NR .GE. 14 ) GO TO 63 RAY02580 C*JDL IF( NR .GE. 6 ) GO TO 64 RAY02590 IF( NSKIP .NE. 0 ) GO TO 161 XO1SV = XO(1) YO1SV = YO(1) VXO1SV = VXO(1) VYO1SV = VYO(1) DO 162 I = 1, NR XO(I) = XO(I) - XO1SV !TO GIVE MATRICES NORMALIZED DATA YO(I) = YO(I) - YO1SV VXO(I) = VXO(I) - VXO1SV 162 VYO(I) = VYO(I) - VYO1SV MM = NR IF( JNR .NE. 0) MM = JNR !MIT PROTOCOL ALSO REQUIRES (NRXS .NE. 0) IF( MM .GE. 46 ) GO TO 62 IF( MM .GE. 2 ) GO TO 63 C**** !...down to here. !JDL 10-MAR-84 GO TO 61 RAY02600 62 CALL MATRIX(R,T2) RAY02610 GO TO 61 RAY02620 63 IF((IP .GT. 500) .AND. (NEN .GT. 1)) GO TO 163 !JDL 21-NOV-83 PRINT 105, NTITLE RAY02630 PRINT 117, DAET, TYME RAY02631 163 CALL MTRX1( MM, JEN, NEN, NR, ENERGY, PMASS ) !JDL 10-MAR-84 RAY02640 LNEN = 1 RAY02650 GO TO 61 RAY02660 C**64 IF((IP .GT. 500) .AND. (NEN .GT. 1)) GO TO 164 !JDL 21-NOV-83 C*JDL PRINT 105, NTITLE RAY02670 C*JDL PRINT 117, DAET, TYME RAY02671 C*164 CALL MTRX1( 1, JEN, NEN, NR, ENERGY, PMASS ) !JDL 10-NOV-83 RAY02680 C*JDL LNEN = 1 RAY02690 C**** !Changes from here... !JDL 6-MAR-84 61 CONTINUE DO 166 I = 1, NR XO(I) = XO(I) + XO1SV !RESTORE OUTPUT ARRAYS YO(I) = YO(I) + YO1SV VXO(I) = VXO(I) + VXO1SV 166 VYO(I) = VYO(I) + VYO1SV 161 IF(MCS .EQ. 0) GO TO 261 C**** C**** 100-CHANNEL SPECTRA REPLACE RAYS IN PRINTED OUTPUT: C**** C**** LABEL ARRAY CONTENT C**** C**** X = XI(I) = STANDARD INPUT RAYS FROM JNR = 2, 6, 14, OR 46. C**** THETA = VXI(I) = (USED TO DETERMINE FOCAL PLANE ORIENTATION AND C**** Y = YI(I) = TO DO MATRIX ANALYSIS BASED ON STANDARD RAYS. C**** PHI = VYI(I) = THESE RAYS NOT INCLUDED IN SPECTRA.) C**** ZI = ZI(I) = C**** DELE = DELP(I) = ERR-88;SX1-91,THRU-92,SX2-93,LO-96,CTS-97,HI-98,ALL-100 C**** XO = XO(I) = CHANNEL VALUE IN X (CM). C**** XS = VXO(I) = COUNTS PER X-CHANNEL (RAYS THRU SLITS). C**** YO = YO(I) = CHANNEL VALUE IN Y (CM). C**** YS = VYO(I) = COUNTS PER Y-CHANNEL (RAYS THRU SLITS). C**** L(CM) = RLL(I) = COUNTS PER X-CHANNEL (ALL RAYS). C**** T(NS) = RTL(I) = COUNTS PER T-CHANNEL (RAYS THRU SLITS). C**** NR=100 DO 160 I=1,100 IF(I .GT. 50) GO TO 159 VXO(I)=XO(I+50) !UNFOLD SPECTRA VYO(I)=YO(I+50) RTL(I)=RLL(I+50) RLL(I)=XI(I+50) RLL(I+50)=VXI(I+50) XI(I+50) =0.0 VXI(I+50)=0.0 159 YO(I)=FLOAT(I-50)*STMN XO(I)=YO(I)+SPMN 160 CONTINUE 261 N1 = MEL + 1 C**** !...down to here. !JDL 6-MAR-84 CALL PRNT1 ( N1, NR, JEN, NEN, WIDTH ) !JDL 1-NOV-84 RAY02700 EN0 = EN0 + DEN RAY02710 ENERGY = EN0 RAY02720 C**** PM0 = PM0 + DMASS !MP FEB 85 !JDL 10-NOV-83 PMASS = PM0 !JDL 10-NOV-83 EMASS = PMASS*931.48 !JDL 10-NOV-83 QMC = EMASS/(9.0D10*Q0) !JDL 10-NOV-83 ETOT = EMASS + EN0 RAY02730 VEL0 = ( DSQRT( ( 2.*EMASS + EN0)*EN0 ) /ETOT)*C RAY02740 PMOM0 = DSQRT( (2.*EMASS + EN0)*EN0) RAY02750 53 CONTINUE RAY02760 C**** C**** END ENERGY-STEP LOOP C**** C**** Changes from here ... !JDL 31-OCT-84 IF( LNEN .EQ. 0 ) GO TO 9600 !JDL 1-DEC-83 RAY02770 IF((NEN .EQ. 1 ) .AND. (NLOOP .EQ. 0)) GO TO 9600 PRINT 105, NTITLE RAY02780 CALL TIME(TYME) PRINT 117, DAET, TYME RAY02781 C*IBM CALL WHEN(DAET) CALL MPRNT( NEN, WIDTH ) !JDL 1-DEC-83 RAY02790 9600 CONTINUE IF( MCS .EQ. 0 ) GO TO 9602 NH = NHAX NV = NVAX IF( NHAX .EQ. 5 ) NHAX = 12 !CHANGE SPECTRUM LABEL TO COUNTS IF( NVAX .EQ. 5 ) NVAX = 12 IF((NHAX .EQ. 2) .OR. (NHAX .EQ. 4) .OR. (NHAX .EQ. 6)) NHAX = 11 IF((NVAX .EQ. 2) .OR. (NVAX .EQ. 4) .OR. (NVAX .EQ. 6)) NVAX = 11 IF((NHAX .EQ. 1) .AND. (NV .EQ. 6)) NHAX = 6 !LABEL DT(NS) IF((NVAX .EQ. 1) .AND. (NH .EQ. 6)) NVAX = 6 NCAX = 0 9602 JEN = NEN CALL PRNT1A( JEN ) C*JDL PRINT 106 !JDL 1-DEC-83 RAY02800 C**** C**** C**** CHANGE DATA & REPEAT ITYPE = 16 (EXECUTION) C**** IF((NLOOP .EQ. 0) .OR. (LNEN .EQ. 0)) GO TO 5 IF(NPASS .EQ. 0) GO TO 9650 9610 KUPLE=LOOPSV(4,NPASS) IF(KUPLE .EQ. 0) GO TO 9650 DO 9620 J=NPASS,NLOOP IF(LOOPSV(4,J) .NE. KUPLE) GO TO 9620 IF((KUPLE .EQ. 4H ) .AND. (J .NE. NPASS)) GO TO 9620 IF(SPASS .EQ. 0.0) LOOPSV(4,J)=0 INO=LOOPSV(1,J) IJ= LOOPSV(5,J) IF(SPASS .GT. 0.0) HSAVE(J)=DATA(IJ,INO) DATA(IJ,INO)=HSAVE(J)+SPASS*HOOPSV(J) 9620 CONTINUE C**** IF(SPASS) 9640,9650,9630 C**** 9630 SPASS=-1.0 !JUST DID PLUS SETUP (MINUS SETUP NEXT) GO TO 52 !GO DO POSITIVE-INCREMENT PASS C**** 9640 SPASS= 0.0 !JUST DID MINUS SETUP (RESET COMES NEXT) GO TO 52 !GO DO NEGATIVE-INCREMENT PASS C**** 9650 SPASS=+1.0 !JUST DID A RESET (PLUS SETUP NEXT) NPASS=NPASS+1 IF(NPASS .LE. NLOOP) GO TO 9610 C**** C**** ... down to here. !JDL 17-NOV-83 GO TO 5 RAY02810 END RAY02820 SUBROUTINE BDIP RAY06270 C**** RAY06280 C**** RAY06290 C**** MTYP=1 : UNIFORM FIELD STANDARD APPROXIMATION RAY06300 C**** MTYP=2 : UNIFORM FIELD MODIFIED ITERATIVE PROCEDURE RAY06310 C**** MTYP=3 : NONUNIFORM FIELD STANDARD APPROXIMATION RAY06320 C**** MTYP=4 : NONUNIFORM FIELD B=BF/(1+N*DR/R) RAY06330 C**** MTYP=5 : UNIFORM FIELD, CIRCULAR POLE OPTION RAY06340 C**** RAY06350 C**** THE RELATIONSHIP BETWEEN B0, ......... B12 AND B(I,J) RELATIVE TO RAY06360 C**** AXES (Z,X) IS GIVEN BY RAY06370 C**** RAY06380 C**** RAY06390 C**** RAY06400 C**** B0 = B( 0, 0 ) RAY06410 C**** B1 = B( 1, 0 ) RAY06420 C**** B2 = B( 2, 0 ) RAY06430 C**** B3 = B( 1, 1 ) RAY06440 C**** B4 = B( 1,-1 ) RAY06450 C**** B5 = B( 0, 1 ) RAY06460 C**** B6 = B( 0, 2 ) RAY06470 C**** B7 = B( 0,-1 ) RAY06480 C**** B8 = B( 0,-2 ) RAY06490 C**** B9 = B(-1, 0 ) RAY06500 C**** B10 = B(-2, 0 ) RAY06510 C**** B11 = B(-1, 1 ) RAY06520 C**** B12 = B(-1,-1 ) RAY06530 C**** RAY06540 C**** RAY06550 IMPLICIT REAL*8(A-H,O-Z) RAY06560 REAL*8 NDX, K RAY06570 COMMON /BLCK10/ BX, BY, BZ, K, TC, DTC RAY06580 COMMON /BLCK20/ NDX,BET1,GAMA,DELT,CSC RAY06590 COMMON /BLCK21/ RCA,DELS,BR,S2,S3,S4,S5,S6,S7,S8,SCOR RAY06600 COMMON /BLCK22/ D, DG, S, BF, BT RAY06610 COMMON /BLCK23/ C0, C1, C2, C3, C4, C5 RAY06620 COMMON /BLCK24/ RB, XC, ZC RAY06630 COMMON /BLCK25/ IN, MTYP RAY06640 DIMENSION TC(6), DTC(6) RAY06650 DIMENSION XX(11), ZZ(11), DD(11) RAY06660 DATA PI2 / 1.570796325D0 / RAY06670 DATA PI4 / .7853981625D0 / RAY06680 DATA RT2 / 1.41421356D0 / RAY06690 C**** RAY06700 C**** RAY06710 GO TO ( 10,10,6,6,10 ) ,MTYP RAY06720 CALL EXIT RAY06730 RETURN RAY06740 6 CALL NDIP RAY06750 RETURN RAY06760 C**** RAY06770 C**** MTYP = 1 , 2, 5 RAY06780 C**** UNIFORM FIELD MAGNETS RAY06790 C**** RAY06800 10 CONTINUE RAY06810 GO TO( 2, 1, 2, 4 ) , IN RAY06820 7 PRINT 8, IN RAY06830 8 FORMAT( 35H0 ERROR -GO TO - IN BFUN IN= I5 ) RAY06840 1 BX = 0. RAY06850 BY = BF RAY06860 BZ = 0. RAY06870 BT = BF RAY06880 RETURN RAY06890 2 X = TC(1) RAY06900 Y = TC(2) RAY06910 Z = TC(3) RAY06920 IF( MTYP .NE. 2 ) GO TO 9 RAY06930 C**** RAY06940 C**** MTYP=2 : UNIFORM FIELD MODIFIED ITERATIVE PROCEDURE RAY06950 C**** RAY06960 XP = X RAY06970 XP2 = XP*XP RAY06980 XP3 = XP2*XP RAY06990 XP4 = XP3 * XP RAY07000 ZP = -(S2*XP2 + S3*XP3 + S4*XP4 + S5*XP4*XP + S6*XP4*XP2 + RAY07010 1 S7*XP4*XP3 + S8*XP4*XP4 ) RAY07020 AZ = (Z-ZP)/5.D0 RAY07030 DO 11 I=1,11 RAY07040 XP = X + AZ*(I-6) RAY07050 XP2 = XP*XP RAY07060 XP3 = XP2*XP RAY07070 XP4 = XP3*XP RAY07080 ZP = -(S2*XP2 + S3*XP3 + S4*XP4 + S5*XP4*XP + S6*XP4*XP2 + RAY07090 1 S7*XP4*XP3 + S8*XP4*XP4 ) RAY07100 XXP = X-XP RAY07110 ZZP = Z-ZP RAY07120 XX(I) = XP RAY07130 ZZ(I) = ZP RAY07140 DD(I) = DSQRT( XXP*XXP + ZZP*ZZP ) RAY07150 11 CONTINUE RAY07160 C**** RAY07170 C**** SEARCH FOR SHORTEST OF THE 11 DISTANCES RAY07180 C**** RAY07190 XP = XX(1) RAY07200 ZP = ZZ(1) RAY07210 DP = DD(1) RAY07220 DO 12 I=2,11 RAY07230 IF( DD(I) .GE. DP ) GO TO 12 RAY07240 XP = XX(I) RAY07250 ZP = ZZ(I) RAY07260 DP = DD(I) RAY07270 12 CONTINUE RAY07280 C**** C**** DIVIDE INTERVAL AND REPEAT FOR MORE EXACT C**** SHORTEST DISTANCE. C**** AZ = AZ/5.D0 X1 = XP DO 13 I=1,11 RAY07040 XP = X1+ AZ*(I-6) RAY07050 XP2 = XP*XP RAY07060 XP3 = XP2*XP RAY07070 XP4 = XP3*XP RAY07080 ZP = -(S2*XP2 + S3*XP3 + S4*XP4 + S5*XP4*XP + S6*XP4*XP2 + RAY07090 1 S7*XP4*XP3 + S8*XP4*XP4 ) RAY07100 XXP = X-XP RAY07110 ZZP = Z-ZP RAY07120 XX(I) = XP RAY07130 ZZ(I) = ZP RAY07140 DD(I) = DSQRT( XXP*XXP + ZZP*ZZP ) RAY07150 13 CONTINUE RAY07160 C**** RAY07170 C**** SEARCH FOR SHORTEST OF THE 11 DISTANCES RAY07180 C**** RAY07190 XP = XX(1) RAY07200 ZP = ZZ(1) RAY07210 DP = DD(1) RAY07220 DO 15 I=2,11 RAY07230 IF( DD(I) .GE. DP ) GO TO 15 RAY07240 XP = XX(I) RAY07250 ZP = ZZ(I) RAY07260 DP = DD(I) RAY07270 15 CONTINUE RAY07280 C**** RAY07290 C**** ITERATION LOOP FOR MORE EXACT SHORTEST DISTANCE RAY07300 C**** RAY07310 C* ZSIGN = Z-ZP RAY07320 C* XP2 = XP*XP RAY07321 C* XP3 = XP2*XP RAY07322 C* XP4 = XP3*XP RAY07323 C* DO 13 I=1,3 RAY07330 C**** RAY07340 C**** SLOPE OF CURVE AT XP, ZP RAY07350 C**** RAY07360 C* DZDXC = -(2.*S2*XP + 3.*S3*XP2+ 4.*S4*XP3 + 5.*S5*XP4 + RAY07370 C* 1 6.*S6*XP4*XP + 7.*S7*XP4*XP2 + 8.*S8*XP4*XP3 ) RAY07380 C**** RAY07390 C**** NEXT APPROXIMATION TO CLOSEST POINT IS RAY07400 C**** RAY07410 C* XP = ( DZDXC*(Z-ZP) + DZDXC*DZDXC*XP + X ) / (1.+DZDXC*DZDXC) RAY07420 C* IF( I .EQ. 1 ) XP = (3.*XP + X ) / 4. RAY07430 C* XP2 = XP*XP RAY07440 C* XP3 = XP2*XP RAY07450 C* XP4 = XP3*XP RAY07460 C* ZP = -( S2*XP2 + S3*XP3 + S4*XP4 + S5*XP4*XP + S6*XP4*XP2 + RAY07470 C* 1 S7*XP4*XP3 + S8*XP4*XP4 ) RAY07480 C* 13 CONTINUE RAY07490 C* XXP = X-XP RAY07500 C* ZZP = Z-ZP RAY07510 C**** C**** ZSIGN = Z-ZP XP2 = XP*XP XP3 = XP2*XP XP4 = XP3*XP S = DSIGN( 1.D0,ZSIGN) * DP / D - DELS RAY07520 SCON = S RAY07530 C**** RAY07540 C**** TRIM CORRECTION FOR EFFECTIVE EDGE CURVATURE RAY07550 C**** RAY07560 DZDXC = -(2.*S2*XP + 3.*S3*XP2+ 4.*S4*XP3 + 5.*S5*XP4 + RAY07570 1 6.*S6*XP4*XP + 7.*S7*XP4*XP2 + 8.*S8*XP4*XP3 ) RAY07580 DZDXC2= -(2.*S2+6.*S3*XP +12.*S4*XP2 +20.*S5*XP3 +30.*S6*XP4 + RAY07590 1 42.*S7*XP4*XP +56.*S8*XP4*XP2 ) RAY07600 RCR = DZDXC2 / DSQRT( 1.D0 + DZDXC*DZDXC ) **3 RAY07610 S = S + SCOR*D*RCR RAY07620 S0 = S RAY07630 CALL BDPP( B0, Z, X, Y ) RAY07640 IF( Y .NE. 0. ) GO TO 14 RAY07650 BX = 0. RAY07660 BY = B0 RAY07670 BZ = 0. RAY07680 BT = B0 RAY07690 RETURN RAY07700 14 GD = DG/D RAY07710 DELTA = DATAN(DZDXC) RAY07720 SCON = (1.D0 + SCON*D*RCR) *GD*DG*RCR/2.D0 RAY07730 DCS = DCOS( DELTA ) RAY07740 S = S0- SCON*( 1.D0 - DCS*DCS ) + GD*DCS RAY07750 CALL BDPP( B1 , Z, X, Y ) RAY07760 S =S0-4.*SCON*( 1.D0 - DCS*DCS ) + 2.*GD*DCS RAY07770 CALL BDPP( B2 , Z, X, Y ) RAY07780 S = S0- SCON*( 1.D0 - DCS*DCS ) - GD*DCS RAY07790 CALL BDPP( B9 , Z, X, Y ) RAY07800 S =S0-4.*SCON*( 1.D0 - DCS*DCS ) - 2.*GD*DCS RAY07810 CALL BDPP( B10, Z, X, Y ) RAY07820 DCS = DCOS( DELTA + PI4 ) RAY07830 S =S0-2.*SCON*( 1.D0 - DCS*DCS ) + RT2*GD*DCS RAY07840 CALL BDPP( B3 , Z, X, Y ) RAY07850 S =S0-2.*SCON*( 1.D0 - DCS*DCS ) - RT2*GD*DCS RAY07860 CALL BDPP( B12, Z, X, Y ) RAY07870 DCS = DCOS( DELTA - PI4 ) RAY07880 S =S0-2.*SCON*( 1.D0 - DCS*DCS ) + RT2*GD*DCS RAY07890 CALL BDPP( B4 , Z, X, Y ) RAY07900 S =S0-2.*SCON*( 1.D0 - DCS*DCS ) - RT2*GD*DCS RAY07910 CALL BDPP( B11, Z, X, Y ) RAY07920 DCS = DCOS( DELTA + PI2 ) RAY07930 S = S0- SCON*( 1.D0 - DCS*DCS ) + GD*DCS RAY07940 CALL BDPP( B5 , Z, X, Y ) RAY07950 S =S0-4.*SCON*( 1.D0 - DCS*DCS ) + 2.*GD*DCS RAY07960 CALL BDPP( B6 , Z, X, Y ) RAY07970 S = S0- SCON*( 1.D0 - DCS*DCS ) - GD*DCS RAY07980 CALL BDPP( B7 , Z, X, Y ) RAY07990 S =S0-4.*SCON*( 1.D0 - DCS*DCS ) - 2.*GD*DCS RAY08000 CALL BDPP( B8 , Z, X, Y ) RAY08010 GO TO 5 RAY08020 9 CALL BDPP ( B0, Z, X, Y ) RAY08030 S0 = S RAY08040 IF( Y .NE. 0. ) GO TO 3 RAY08050 BX = 0. RAY08060 BY = B0 RAY08070 BZ = 0. RAY08080 BT = B0 RAY08090 RETURN RAY08100 3 CALL BDPP ( B1 , Z + DG, X , Y ) RAY08110 CALL BDPP ( B2 , Z + 2.*DG, X , Y ) RAY08120 CALL BDPP ( B3 , Z + DG, X + DG , Y ) RAY08130 CALL BDPP ( B4 , Z + DG, X - DG , Y ) RAY08140 CALL BDPP ( B5 , Z , X + DG , Y ) RAY08150 CALL BDPP ( B6 , Z , X + 2.*DG , Y ) RAY08160 CALL BDPP ( B7 , Z , X - DG , Y ) RAY08170 CALL BDPP ( B8 , Z , X - 2.*DG , Y ) RAY08180 CALL BDPP ( B9 , Z - DG, X , Y ) RAY08190 CALL BDPP ( B10, Z - 2.*DG, X , Y ) RAY08200 CALL BDPP ( B11, Z - DG, X + DG , Y ) RAY08210 CALL BDPP ( B12, Z - DG, X - DG , Y ) RAY08220 5 CONTINUE RAY08230 S = S0 RAY08240 YG1 = Y/DG RAY08250 YG2 = YG1**2 RAY08260 YG3 = YG1**3 RAY08270 YG4 = YG1**4 RAY08280 BX = YG1 * ( (B5-B7)*2./3. - (B6-B8)/12. ) + RAY08290 1 YG3*( (B5-B7)/6. - (B6-B8)/12. - RAY08300 2 (B3 + B11 - B4 - B12 - 2.*B5 + 2.*B7 ) / 12. ) RAY08310 BY = B0 - YG2*( ( B1 + B9 + B5 + B7 - 4.*B0 ) *2./3. - RAY08320 1 ( B2 + B10 + B6 + B8 - 4.*B0 ) / 24. ) + RAY08330 2 YG4* (-( B1 + B9 + B5 + B7 - 4.*B0 ) / 6. + RAY08340 3 ( B2 + B10 + B6 + B8 - 4.*B0 ) / 24. + RAY08350 4 ( B3 + B11 + B4 + B12 - 2.*B1 - 2.*B9 - RAY08360 5 2.*B5 - 2.*B7 + 4.*B0 ) / 12. ) RAY08370 BZ = YG1*( (B1 - B9 ) *2./3. - ( B2 - B10 ) /12. ) + RAY08380 1 YG3*( ( B1 - B9 ) / 6. - ( B2 - B10 ) / 12. - RAY08390 2 ( B3 + B4 - B11 - B12 - 2.*B1 + 2.*B9 ) / 12. ) RAY08400 BT = DSQRT(BX*BX + BY*BY + BZ*BZ) RAY08410 RETURN RAY08420 4 BX = 0. RAY08430 BY = BR RAY08440 BZ = 0. RAY08450 BT = BR RAY08460 RETURN RAY08470 END RAY08480 SUBROUTINE BDPP ( BFLD, Z, X, Y ) RAY08490 C**** RAY08500 C**** RAY08510 C**** RAY08520 C**** MTYP=1 : UNIFORM FIELD STANDARD APPROXIMATION RAY08530 C**** MTYP=2 : UNIFORM FIELD MODIFIED ITERATIVE PROCEDURE RAY08540 C**** MORE ACCURATE 3'RD AND HIGHER ORDER CURVATURES RAY08550 C**** MTYP=5 : UNIFORM FIELD, CIRCULAR POLE OPTION RAY08560 C**** RAY08570 C**** RAY08580 IMPLICIT REAL*8(A-H,O-Z) RAY08590 REAL*8 NDX, K RAY08600 COMMON /BLCK10/ BX, BY, BZ, K, TC, DTC RAY08610 COMMON /BLCK20/ NDX,BET1,GAMA,DELT,CSC RAY08620 COMMON /BLCK21/ RCA,DELS,BR,S2,S3,S4,S5,S6,S7,S8,SCOR RAY08630 COMMON /BLCK22/ D, DG, S, BF, BT RAY08640 COMMON /BLCK23/ C0, C1, C2, C3, C4, C5 RAY08650 COMMON /BLCK24/ RB, XC, ZC RAY08660 COMMON /BLCK25/ IN, MTYP RAY08670 DIMENSION TC(6), DTC(6) RAY08680 C**** RAY08690 GO TO (10,13,6,6,11 ) ,MTYP RAY08700 6 CALL EXIT RAY08710 RETURN RAY08720 C**** RAY08730 C**** MTYP=1 : UNIFORM FIELD STANDARD APPROXIMATION RAY08740 C**** RAY08750 10 X2=X*X RAY08760 X3=X*X2 RAY08770 X4=X*X3 RAY08780 S = ( Z +S2*X2 + S3*X3 + S4*X4 + S5*X*X4 + S6*X2*X4 + RAY08790 1 S7*X3*X4 + S8*X4*X4 ) / D - DELS RAY08800 GO TO 13 RAY08810 C**** RAY08820 C**** MTYP=5 : UNIFORM FIELD, CIRCULAR POLE OPTION RAY08830 C**** RAY08840 11 IF( DABS(RCA) .GE. 1.D-08 ) GO TO 12 RAY08850 S = Z/D - DELS RAY08860 GO TO 13 RAY08870 12 A = 1./RCA RAY08880 S = ( DSIGN(1.D0,A) * DSQRT( (Z+A)**2 + X*X ) - A ) / D - DELS RAY08890 13 CS=C0+S*(C1+S*(C2+S*(C3+S*(C4+S*C5)))) RAY08900 IF( DABS(CS) .GT. 70. ) CS =DSIGN( 70.D0 ,CS ) RAY08910 E=DEXP(CS) RAY08920 P0 = 1.0 + E RAY08930 DB=BF-BR RAY08940 BFLD=BR + DB/P0 RAY08950 C**** C**** PRINT 100, X, Y, Z, DR, S, BFLD C*100 FORMAT( 1P6D15.4 ) C**** RETURN RAY08960 END RAY08970 SUBROUTINE BEFN (F,Z,X,Y,IBEX) RAY20040 C**** RAY20050 C**** RAY20060 C**** CALCULATES S, THEN DETERMINES B (OR E) FIELD. RAY20070 C**** RAY20080 C**** RAY20090 IMPLICIT REAL*8 (A-H,O-Z) RAY20100 COMMON /BLCK71/ CB0,CB1,CB2,CB3,CB4,CB5 RAY20110 COMMON /BLCK72/ CE0,CE1,CE2,CE3,CE4,CE5 RAY20120 COMMON /BLCK73/ IN RAY20130 COMMON /BLCK74/ BF,EF,S,DG RAY20140 COMMON /BLCK75/ BC2,BC4,EC2,EC4 RAY20150 COMMON /BLCK76/ DB,DE,WB,WE RAY20160 C**** RAY20170 IF (IBEX .NE. 0 ) GO TO 10 RAY20180 F1 = BF RAY20190 D = DB RAY20200 C02 = BC2 RAY20210 C04 = BC4 RAY20220 W2 = WB*WB RAY20230 C0 = CB0 RAY20240 C1 = CB1 RAY20250 C2 = CB2 RAY20260 C3 = CB3 RAY20270 C4 = CB4 RAY20280 C5 = CB5 RAY20290 GO TO 20 RAY20300 C**** RAY20310 10 F1 = EF RAY20320 IF( IN .EQ. 1 ) F1 = -EF RAY20330 D = DE RAY20340 C02 = EC2 RAY20350 C04 = EC4 RAY20360 W2 = WE*WE RAY20370 C0 = CE0 RAY20380 C1 = CE1 RAY20390 C2 = CE2 RAY20400 C3 = CE3 RAY20410 C4 = CE4 RAY20420 C5 = CE5 RAY20430 20 ZD1 = Z/D RAY20440 ZD2 = C02*ZD1*X*X/W2 RAY20450 W4 = W2*W2 RAY20460 ZD3 = C04*(X**4)/W4 RAY20470 S = ZD1+ZD2+ZD3 RAY20480 CS = C0+S*(C1+S*(C2+S*(C3+S*(C4+S*C5)))) RAY20490 IF ( DABS(CS) .GT. 70. ) CS = DSIGN ( 70.D0,CS ) RAY20500 E = DEXP(CS) RAY20510 P0 = 1.0+E RAY20520 F = F1/P0 RAY20530 RETURN RAY20540 END RAY20550 SUBROUTINE BEVC RAY20980 C**** RAY20990 C**** CALCULATES B AND E FIELDS RAY21000 C**** RAY21010 C**** RAY21020 IMPLICIT REAL*8 (A-H,O-Z) RAY21030 REAL*8 K RAY21040 COMMON /BLCK10/ BX, BY, BZ, K, TC, DTC RAY21050 COMMON /BLCK11/ EX, EY, EZ, QMC, IVEC RAY21060 COMMON /BLCK71/ CB0,CB1,CB2,CB3,CB4,CB5 RAY21070 COMMON /BLCK72/ CE0,CE1,CE2,CE3,CE4,CE5 RAY21080 COMMON /BLCK73/ IN RAY21090 COMMON /BLCK74/ BF,EF,S,DG RAY21100 DIMENSION TC(6),DTC(6),BEF(3) RAY21110 C**** RAY21120 GO TO (2,1,2) , IN RAY21130 PRINT 100,IN RAY21140 100 FORMAT ( 35H0 ERROR -GO TO - IN BFUN IN= I5 ) RAY21150 1 BX = 0. RAY21160 BY = BF RAY21170 BZ = 0. RAY21180 EX = EF RAY21190 EY = 0. RAY21200 EZ = 0. RAY21210 RETURN RAY21220 C**** RAY21230 C**** IN THE FRINGE: FIND B AND E FIELDS RAY21240 C**** RAY21250 2 X = TC(1) RAY21260 Y = TC(2) RAY21270 Z = TC(3) RAY21280 IF ( Y .EQ. 0. ) GO TO 3 RAY21290 CALL BEY( BEF,Z,X,Y,0 ) RAY21300 BX = BEF(1) RAY21310 BY = BEF(2) RAY21320 BZ = BEF(3) RAY21330 GO TO 4 RAY21340 C**** RAY21350 3 CALL BEFN(B0,Z,X,Y,0) RAY21360 BX = 0. RAY21370 BY = B0 RAY21380 BZ = 0. RAY21390 C**** RAY21400 C**** NOW FIND E FIELD RAY21410 C**** RAY21420 4 IF ( X .EQ. 0 ) GO TO 5 RAY21430 CALL BEY( BEF,Z,Y,X,1 ) RAY21440 EX = BEF(2) RAY21450 EY = BEF(1) RAY21460 EZ = BEF(3) RAY21470 RETURN RAY21480 5 CALL BEFN ( B1,Z,Y,X,1 ) RAY21490 EX = B1 RAY21500 EY = 0. RAY21510 EZ = 0. RAY21520 RETURN RAY21530 END RAY21540 SUBROUTINE BEY (BEF,Z,X,Y,IBEX ) RAY20560 C**** RAY20570 C**** CALCULATE B OR E FIELD OFF THE MEDIAN PLANE RAY20580 C**** RAY20590 C**** RAY20600 IMPLICIT REAL*8 (A-H,O-Z) RAY20610 COMMON /BLCK74/ BF,EF,S,DG RAY20620 DIMENSION BEF(3) RAY20630 C**** RAY20640 CALL BEFN(F0,Z,X,Y,IBEX ) RAY20650 CALL BEFN(F1,Z+DG,X,Y,IBEX ) RAY20660 CALL BEFN(F2,Z+2.*DG,X,Y,IBEX ) RAY20670 CALL BEFN(F3,Z+DG,X+DG,Y,IBEX ) RAY20680 CALL BEFN(F4,Z+DG,X-DG,Y,IBEX ) RAY20690 CALL BEFN(F5,Z ,X+DG,Y,IBEX ) RAY20700 CALL BEFN(F6,Z,X+2.*DG,Y,IBEX ) RAY20710 CALL BEFN(F7,Z,X-DG,Y,IBEX ) RAY20720 CALL BEFN(F8,Z,X-2.*DG,Y,IBEX ) RAY20730 CALL BEFN(F9,Z-DG,X,Y,IBEX ) RAY20740 CALL BEFN(F10,Z-2.*DG,X,Y,IBEX ) RAY20750 CALL BEFN(F11,Z-DG,X+DG,Y,IBEX ) RAY20760 CALL BEFN(F12,Z-DG,X-DG,Y,IBEX ) RAY20770 C**** RAY20780 YG1 = Y/DG RAY20790 YG2 = YG1**2 RAY20800 YG3 = YG1**3 RAY20810 YG4 = YG1**4 RAY20820 C**** RAY20830 BEF(1) = YG1 * ( (F5-F7)*2./3. - (F6-F8)/12. ) + RAY20840 1 YG3 * ( (F5-F7)/6. - (F6-F8)/12. - RAY20850 2 ( F3 + F11 - F4 - F12 - 2.*F5 + 2.*F7 )/12. ) RAY20860 BEF(2) = F0 - YG2*( (F1 + F9 + F5 + F7 - 4.*F0) * 2./3. - RAY20870 1 ( F2 + F10 + F6 + F8 - 4.*F0 )/24. ) + RAY20880 2 YG4 * (-( F1 + F9 + F5 + F7 - 4.*F0 )/6. + RAY20890 3 ( F2 + F10 + F6 + F8 - 4.*F0 )/24. + RAY20900 4 ( F3 + F11 + F4 + F12 - 2.*F1 - 2.*F9 - RAY20910 5 2.*F5 - 2.*F7 + 4.*F0 )/12. ) RAY20920 BEF(3) = YG1 * ( (F1 - F9)*2./3. - (F2 - F10)/12. ) + RAY20930 1 YG3 * ( (F1 - F9)/6. - (F2 - F10)/12. - RAY20940 2 (F3 + F4 - F11 - F12 - 2.*F1 + 2.*F9)/12. ) RAY20950 RETURN RAY20960 END RAY20970 SUBROUTINE BFLD RAY13540 C**** RAY13550 C**** CALCULATION OF FIELD COMPONENTS FOR EACH PURE MULTIPOLE RAY13560 C**** RAY13570 IMPLICIT REAL*8(A-H,O-Z) RAY13580 REAL*8 K RAY13590 COMMON /BLCK 7/ NCODE RAY13600 COMMON /BLCK10/ BX, BY, BZ, K, TC, DTC RAY13610 COMMON /BLCK50/ D, GRAD, S, BT RAY13620 COMMON /BLCK51/ C0, C1, C2, C3, C4, C5 RAY13630 COMMON /BLCK52/ IN RAY13640 COMMON /BLCK60/ GAS,AGAS,ZGAS,ZION,PRESS,GASSIG,QAVER, !***MP 1-JAN-85 1 QFWHM,RHOGAS,GASK,EMASS,GASMFP,JRAY,Q00,NPASG !*** DIMENSION TC(6), DTC(6) RAY13650 JRAYGAS = JRAY*GAS X = TC(1) RAY13660 Y = TC(2) RAY13670 Z = TC(3) RAY13680 GO TO ( 11, 12, 13, 14 ) , NCODE RAY13690 C**** RAY13700 C**** QUADRUPOLE RAY13710 C**** RAY13720 11 CONTINUE RAY13730 GO TO ( 2, 1, 2 ) , IN RAY13740 PRINT 3, IN RAY13750 3 FORMAT( ' ERROR IN BQUAD IN= ' I5 ///) RAY13760 CALL EXIT RAY13770 1 BX = GRAD*Y RAY13780 BY = GRAD*X RAY13790 BZ = 0. RAY13800 BT = DSQRT( BX*BX + BY*BY ) RAY13810 RETURN RAY13820 2 S = Z/D RAY13830 CS = C0 + C1*S + C2*S**2 + C3*S**3 + C4*S**4 + C5*S**5 RAY13840 CSP = C1 + 2.*C2*S + 3.*C3*S**2 + 4.*C4*S**3 + 5.*C5*S**4 RAY13850 CSPP = 2.*C2 + 6.*C3*S + 12.*C4*S**2 + 20.*C5*S**3 RAY13860 IF( DABS(CS) .GT. 70. ) CS = DSIGN(70.D0, CS ) RAY13870 E = DEXP(CS) RAY13880 RE = 1./(1. + E) RAY13890 CB1 = GRAD*RE RAY13900 CB2 = CB1*E*RE*( CSP**2 + CSPP - 2.*E*RE*CSP**2 )/(12.*D*D ) RAY13910 BX = CB1*Y + CB2*( 3.*X*X + Y*Y ) * Y RAY13920 BY = CB1*X + CB2*( 3.*Y*Y + X*X ) * X RAY13930 BZ = -CB1*E*CSP*RE*X*Y / D RAY13940 BT = DSQRT( BX*BX + BY*BY + BZ*BZ ) RAY13950 RETURN RAY13960 C**** RAY13970 C**** HEXAPOLE RAY13980 C**** RAY13990 12 BA2 = GRAD RAY14000 GO TO ( 22, 21, 22 ) , IN RAY14010 PRINT 23, IN RAY14020 23 FORMAT( ' ERROR IN BHEX IN= ' I5 ///) RAY14030 CALL EXIT RAY14040 21 BX = 2.*BA2*X*Y RAY14050 BY = BA2*( X*X - Y*Y ) RAY14060 BZ = 0. RAY14070 BT = DSQRT( BX*BX + BY*BY ) RAY14080 RETURN RAY14090 22 S = Z/D RAY14100 IF( S .LT. 0. ) GO TO 21 RAY14110 BX = 0. RAY14120 BY = 0. RAY14130 BZ = 0. RAY14140 BT = 0. RAY14150 RETURN RAY14160 C**** RAY14170 C**** OCTAPOLE RAY14180 C**** RAY14190 13 BA3 = GRAD RAY14200 GO TO ( 32, 31, 32 ) , IN RAY14210 PRINT 33, IN RAY14220 33 FORMAT( ' ERROR IN BOCT IN= ' I5 ///) RAY14230 CALL EXIT RAY14240 31 BX = BA3*( 3.*X*X*Y - Y**3 ) RAY14250 BY = BA3*( X**3 - 3.*X*Y*Y ) RAY14260 BZ = 0. RAY14270 BT = DSQRT( BX*BX + BY*BY ) RAY14280 RETURN RAY14290 32 S = Z/D RAY14300 IF( S .LT. 0. ) GO TO 31 RAY14310 BX = 0. RAY14320 BY = 0. RAY14330 BZ = 0. RAY14340 BT = 0. RAY14350 RETURN RAY14360 C**** RAY14370 C**** DECAPOLE RAY14380 14 BA4 = GRAD RAY14390 GO TO ( 42, 41, 42 ) , IN RAY14400 PRINT 43, IN RAY14410 43 FORMAT( ' ERROR IN BDEC IN= ' I5 ///) RAY14420 CALL EXIT RAY14430 41 BX = 4.D0*BA4*( X**3 *Y - X*(Y**3) ) RAY14440 BY = BA4*( X**4 - 6.D0* X*X*Y*Y + Y**4 ) RAY14450 BZ = 0. RAY14460 BT = DSQRT( BX*BX + BY*BY ) RAY14470 RETURN RAY14480 42 S = Z/D RAY14490 IF( S .LT. 0. ) GO TO 41 RAY14500 BX = 0. RAY14510 BY = 0. RAY14520 BZ = 0. RAY14530 BT = 0. RAY14540 RETURN RAY14550 END RAY14560 SUBROUTINE BMULT RAY22910 C**** RAY22920 C**** RAY22930 C**** THE RELATIONSHIP BETWEEN B0, ......... B12 AND B(I,J) RELATIVE TO RAY22940 C**** AXES (Z,X) IS GIVEN BY RAY22950 C**** RAY22960 C**** RAY22970 C**** RAY22980 C**** B0 = B( 0, 0 ) RAY22990 C**** B1 = B( 1, 0 ) RAY23000 C**** B2 = B( 2, 0 ) RAY23010 C**** B3 = B( 1, 1 ) RAY23020 C**** B4 = B( 1,-1 ) RAY23030 C**** B5 = B( 0, 1 ) RAY23040 C**** B6 = B( 0, 2 ) RAY23050 C**** B7 = B( 0,-1 ) RAY23060 C**** B8 = B( 0,-2 ) RAY23070 C**** B9 = B(-1, 0 ) RAY23080 C**** B10 = B(-2, 0 ) RAY23090 C**** B11 = B(-1, 1 ) RAY23100 C**** B12 = B(-1,-1 ) RAY23110 C**** RAY23120 C**** RAY23130 IMPLICIT REAL*8(A-H,O-Z) RAY23140 REAL*8 K, L RAY23150 COMMON /BLCK10/ BX, BY, BZ, K, TC, DTC RAY23160 COMMON /BLK100/ W, L, D, DG, S, BF, BT RAY23170 COMMON /BLK101/ C0, C1, C2, C3, C4, C5, C6, C7, C8 RAY23180 DIMENSION TC(6), DTC(6) RAY23190 X = TC(1) RAY23200 Y = TC(2) RAY23210 Z = TC(3) RAY23220 CALL MLTT ( B0, Z, X, Y ) RAY23230 CALL MLTT ( B1 , Z + DG, X , Y ) RAY23240 CALL MLTT ( B2 , Z + 2.*DG, X , Y ) RAY23250 CALL MLTT ( B3 , Z + DG, X + DG , Y ) RAY23260 CALL MLTT ( B4 , Z + DG, X - DG , Y ) RAY23270 CALL MLTT ( B5 , Z , X + DG , Y ) RAY23280 CALL MLTT ( B6 , Z , X + 2.*DG , Y ) RAY23290 CALL MLTT ( B7 , Z , X - DG , Y ) RAY23300 CALL MLTT ( B8 , Z , X - 2.*DG , Y ) RAY23310 CALL MLTT ( B9 , Z - DG, X , Y ) RAY23320 CALL MLTT ( B10, Z - 2.*DG, X , Y ) RAY23330 CALL MLTT ( B11, Z - DG, X + DG , Y ) RAY23340 CALL MLTT ( B12, Z - DG, X - DG , Y ) RAY23350 YG1 = Y/DG RAY23360 YG2 = YG1**2 RAY23370 YG3 = YG1**3 RAY23380 YG4 = YG1**4 RAY23390 BX = YG1 * ( (B5-B7)*2./3. - (B6-B8)/12. ) + RAY23400 1 YG3*( (B5-B7)/6. - (B6-B8)/12. - RAY23410 2 (B3 + B11 - B4 - B12 - 2.*B5 + 2.*B7 ) / 12. ) RAY23420 BY = B0 - YG2*( ( B1 + B9 + B5 + B7 - 4.*B0 ) *2./3. - RAY23430 1 ( B2 + B10 + B6 + B8 - 4.*B0 ) / 24. ) + RAY23440 2 YG4* (-( B1 + B9 + B5 + B7 - 4.*B0 ) / 6. + RAY23450 3 ( B2 + B10 + B6 + B8 - 4.*B0 ) / 24. + RAY23460 4 ( B3 + B11 + B4 + B12 - 2.*B1 - 2.*B9 - RAY23470 5 2.*B5 - 2.*B7 + 4.*B0 ) / 12. ) RAY23480 BZ = YG1*( (B1 - B9 ) *2./3. - ( B2 - B10 ) /12. ) + RAY23490 1 YG3*( ( B1 - B9 ) / 6. - ( B2 - B10 ) / 12. - RAY23500 2 ( B3 + B4 - B11 - B12 - 2.*B1 + 2.*B9 ) / 12. ) RAY23510 BT =DSQRT(BX*BX + BY*BY + BZ*BZ) RAY23520 RETURN RAY23530 END RAY23540 SUBROUTINE BPOLES RAY16740 C**** RAY16750 C**** CALCULATION OF MULTIPOLE(POLES) FIELD COMPONENTS RAY16760 C**** RAY16770 C**** RAY16780 C**** RAY16790 C**** 2 - QUADRUPOLE (GRAD1) RAY16800 C**** 3 - HEXAPOLE (GRAD2) RAY16810 C**** 4 - OCTAPOLE (GRAD3) RAY16820 C**** 5 - DECAPOLE (GRAD4) RAY16830 C**** 6 - DODECAPOLE (GRAD5) RAY16840 C**** RAY16850 C**** RAY16860 IMPLICIT REAL*8(A-H,O-Z) RAY16870 REAL*8 K RAY16880 COMMON /BLCK10/ BX, BY, BZ, K, TC, DTC RAY16890 COMMON /BLCK90/ D, S, BT, GRAD1,GRAD2,GRAD3,GRAD4,GRAD5 RAY16900 COMMON /BLCK91/ C0, C1, C2, C3, C4, C5 RAY16910 COMMON /BLCK92/ IN RAY16920 DIMENSION TC(6), DTC(6) RAY16930 X = TC(1) RAY16940 Y = TC(2) RAY16950 Z = TC(3) RAY16960 X2 = X*X RAY16970 X3 = X2*X RAY16980 X4 = X3*X RAY16990 X5 = X4*X RAY17000 Y2 = Y*Y RAY17010 Y3 = Y2*Y RAY17020 Y4 = Y3*Y RAY17030 Y5 = Y4*Y RAY17040 GO TO ( 2, 1, 2 ) , IN RAY17050 PRINT 3, IN RAY17060 3 FORMAT( ' ERROR IN BPOLES IN= ' I5 ///) RAY17070 CALL EXIT RAY17080 1 CONTINUE RAY17090 B2X = GRAD1*Y RAY17100 B2Y = GRAD1*X RAY17110 B3X = GRAD2*2.*X*Y RAY17120 B3Y = GRAD2*(X2-Y2) RAY17130 B4X = GRAD3*(3.*X2*Y-Y3) RAY17140 B4Y = GRAD3*(X3-3.*X*Y2) RAY17150 B5X = GRAD4*4.*(X3*Y-X*Y3) RAY17160 B5Y = GRAD4*(X4-6.*X2*Y2+Y4) RAY17170 B6X = GRAD5*(5.*X4*Y-10.*X2*Y3+Y5) RAY17180 B6Y = GRAD5*(X5-10.*X3*Y2+5.*X*Y4) RAY17190 BX = B2X + B3X + B4X + B5X + B6X RAY17200 BY = B2Y + B3Y + B4Y + B5Y + B6Y RAY17210 BZ = 0. RAY17220 BT = DSQRT( BX*BX + BY*BY ) RAY17230 RETURN RAY17240 2 S = Z/D RAY17250 CS = C0 + C1*S + C2*S**2 + C3*S**3 + C4*S**4 + C5*S**5 RAY17260 CP1 =(C1 + 2.*C2*S + 3.*C3*S**2 + 4.*C4*S**3 + 5.*C5*S**4) / D RAY17270 CP2 = (2.*C2 + 6.*C3*S + 12.*C4*S**2 + 20.*C5*S**3 ) / (D*D) RAY17280 CP3 = ( 6.*C3 + 24.*C4*S + 60.*C5*S*S ) / (D**3) RAY17290 CP4 = ( 24.*C4 + 120.*C5*S ) / (D**4) RAY17300 IF( DABS(CS) .GT. 70. ) CS = DSIGN(70.D0, CS ) RAY17310 E = DEXP(CS) RAY17320 RE = 1./(1. + E) RAY17330 ERE = E*RE RAY17340 ERE2= ERE*ERE RAY17350 ERE3= ERE*ERE2 RAY17360 ERE4= ERE*ERE3 RAY17370 CP12 = CP1*CP1 RAY17380 CP22 = CP2*CP2 RAY17390 CP13 = CP1**3 RAY17400 CP14 = CP1**4 RAY17410 G1 = -CP1*ERE*RE RAY17420 G2 =-( CP2+CP12 )*ERE*RE + 2.*CP12 * ERE2*RE RAY17430 G3 =-(CP3 + 3.*CP1*CP2 + CP13 ) * ERE*RE + RAY17440 1 6.*(CP1*CP2 + CP13)*ERE2*RE - 6.*CP13*ERE3*RE RAY17450 G4 = -(CP4 + 4.*CP1*CP3 + 3.*CP22 + 6.*CP12*CP2 + CP14)*ERE*RE+ RAY17460 1 (8.*CP1*CP3 + 36.*CP12*CP2 + 6.*CP22 + 14.*CP14)*ERE2*RE - RAY17470 2 36.*(CP12*CP2 + CP14)*ERE3*RE + 24.*CP14*ERE4*RE RAY17480 B2X = GRAD1*( RE*Y - (G2/12.)*(3.*X2*Y + Y3) + RAY17490 1 (G4/384.)*(5.*X4*Y + 6.*X2*Y3 + Y5 ) ) RAY17500 B2Y = GRAD1*( RE*X - (G2/12.)*(X3 + 3.*X*Y2) + RAY17510 1 (G4/384.)*(X5 + 6.*X3*Y2 + 5.*X*Y4 ) ) RAY17520 B2Z = GRAD1*( G1*X*Y - (G3/12.)*(X3*Y + X*Y3 ) ) RAY17530 B3X = GRAD2*( RE*2.*X*Y - (G2/48.)*(12.*X3*Y + 4.*X*Y3 ) ) RAY17540 B3Y = GRAD2*( RE*(X2-Y2) - (G2/48.)*(3.*X4 + 6.*X2*Y2 - 5.*Y4 ) ) RAY17550 B3Z = GRAD2*( G1*(X2*Y - Y3/3.) - (G3/48.)*(3.*X4*Y+2.*X2*Y3-Y5)) RAY17560 B4X = GRAD3*( RE*(3.*X2*Y - Y3) - (G4/80.)*(20.*X4*Y - 4.*Y5 ) ) RAY17570 B4Y = GRAD3*( RE*(X3 - 3.*X*Y2) - (G4/80.)*(4.*X5-20.*X*Y4 ) ) RAY17580 B4Z = GRAD3*G1*(X3*Y - X*Y3 ) RAY17590 B5X = GRAD4*RE*(4.*X3*Y - 4.*X*Y3) RAY17600 B5Y = GRAD4*RE*(X4 - 6.*X2*Y2 + Y4 ) RAY17610 B5Z = GRAD4*G1*(X4*Y - 2.*X2*Y3 + Y5/5. ) RAY17620 B6X = GRAD5*RE*(5.*X4*Y - 10.*X2*Y3 + Y5 ) RAY17630 B6Y = GRAD5*RE*(X5 - 10.*X3*Y2 + 5.*X*Y4 ) RAY17640 B6Z = 0. RAY17650 BX = B2X + B3X + B4X + B5X + B6X RAY17660 BY = B2Y + B3Y + B4Y + B5Y + B6Y RAY17670 BZ = B2Z + B3Z + B4Z + B5Z + B6Z RAY17680 BT = DSQRT( BX*BX + BY*BY + BZ*BZ ) RAY17690 RETURN RAY17700 END RAY17710 SUBROUTINE BSOL RAY26530 C**** RAY26540 C**** RAY26550 C**** ROUTINE VALID FOR FIELDS OUTSIDE CENTRAL ZONE OF ELEMENTAL RAY26560 C**** SOLENOID RAY26570 C**** BF = FIELD AT CENTER OF INFINITE SOLENOID; CURR. DEN. (NI/M) RAY26580 C**** M.W.GARRETTT JOURNAL OF APP. PHYS. 34,(1963),P2567 RAY26590 C**** RAY26600 C**** RAY26610 IMPLICIT REAL*8(A-H,O-Z) RAY26620 REAL*8 K RAY26630 DIMENSION TC(6), DTC(6) RAY26640 COMMON /BLCK10/ BX, BY, BZ, K, TC, DTC RAY26650 COMMON /BLCK30/ BF , AL, RAD RAY26660 COMMON /BLCK31/ S, BT RAY26670 COMMON /BLCK32/ IN RAY26680 C**** RAY26690 C**** RAY26700 DATA PI4/12.566370616D0 / RAY26710 C**** RAY26720 C**** RAY26730 C**** RAY26740 X = TC(1) RAY26750 Y = TC(2) RAY26760 Z = TC(3) RAY26770 R =DSQRT( X **2 + Y**2 ) RAY26780 IF( R .LT. (RAD/1.D4) ) GO TO 5 RAY26790 RADR = RAD+R RAY26800 AAPR = 4.D0*RAD/RADR RAY26810 AAMR = (RAD-R)/(2.D0*RAD) RAY26820 RCSQ = 4.D0*RAD*R/(RADR*RADR) RAY26830 C**** RAY26840 C**** SOLENOID LEFT HAND SOURCE RAY26850 C**** RAY26860 ZZ = -(AL+Z) RAY26870 R1SQ = RADR*RADR + ZZ*ZZ RAY26880 R1 = DSQRT(R1SQ) RAY26890 RKSQ = 4.D0*RAD*R/R1SQ RAY26900 CALL FB01AD(RKSQ, VKS, VES ) RAY26910 CALL FB03AD(RCSQ, RKSQ, P ) RAY26920 BZS1 = AAPR*ZZ*(VKS+AAMR*(P-VKS) ) /R1 RAY26930 BRS1 = R1*(2.D0*(VKS-VES) - RKSQ*VKS) RAY26940 C**** RAY26950 C**** SOLENOID RIGHT HAND SOURCE RAY26960 C**** RAY26970 ZZ = AL-Z RAY26980 R1SQ = RADR*RADR + ZZ*ZZ RAY26990 R1 = DSQRT(R1SQ) RAY27000 RKSQ = 4.D0*RAD*R/R1SQ RAY27010 CALL FB01AD(RKSQ, VKS, VES ) RAY27020 CALL FB03AD(RCSQ, RKSQ, P ) RAY27030 BZS2 = AAPR*ZZ*(VKS+AAMR*(P-VKS) ) /R1 RAY27040 BRS2 = R1*(2.D0*(VKS-VES) - RKSQ*VKS) RAY27050 BZ = BF*( BZS2-BZS1 )/PI4 RAY27060 BR = BF*( BRS2-BRS1 )/(R*PI4) RAY27070 BX = BR * X /R RAY27080 BY = BR * Y/R RAY27090 BT =DSQRT( BX**2 + BY**2 + BZ**2 ) RAY27100 RETURN RAY27110 5 CONTINUE RAY27120 C**** RAY27130 C**** RAY27140 C**** RAY27150 COSA = (AL-Z) / DSQRT( RAD*RAD + (AL-Z)**2 ) RAY27160 COSB =-(AL+Z) / DSQRT( RAD*RAD + (AL+Z)**2 ) RAY27170 BX = 0. RAY27180 BY = 0. RAY27190 BZ = BF*(COSA-COSB)/2.D0 RAY27200 BT = DABS(BZ) RAY27210 RETURN RAY27220 END RAY27230 SUBROUTINE DERIV( BFUN,T,bflag ) RAY37960 C**** RAY37970 C**** RAY37980 C**** RAY37990 IMPLICIT REAL*8(A-H,O-Z) RAY38000 integer bflag REAL*8 K RAY38010 COMMON /BLCK 4/ ENERGY, VEL, PMASS, Q0 RAY38020 COMMON /BLCK10/ BX, BY, BZ, K, TC, DTC RAY38030 COMMON /BLCK11/ EX, EY, EZ, QMC, IVEC RAY38040 COMMON /BLCK60/ GAS,AGAS,ZGAS,ZION,PRESS,GASSIG,QAVER, !***MP 1-JAN-85 1 QFWHM,RHOGAS,GASK,EMASS,GASMFP,JRAY,Q00,NPASG !*** COMMON /BLCK61/ DEDX,ALPHAK,TOLD2,DEDXQ COMMON /BLCK62/ GASENE,GASVEL,TOLD,GASL include 'rtcomm65.f' DIMENSION DTCGAS(3) DIMENSION TC(6), DTC(6) RAY38050 DATA C /3.D10 /,NSK2MX/10/ RAY38060 C**** RAY38070 C**** RAY38080 C****GASK = RHOGAS(MG/CM**3)*C**2(CM2/SEC2)/(3.*EMASS(MEV)) !***MP 1-JAN-85 if (bflag.ne.0) then CALL BFUN RAY38090 endif DTC(1) = TC(4) RAY38100 DTC(2) = TC(5) RAY38110 DTC(3) = TC(6) RAY38120 IF( IVEC .NE. 0 ) GO TO 4 RAY38130 DTC(4) = K * ( TC(5) * BZ - TC(6) * BY ) RAY38140 DTC(5) = K * ( TC(6) * BX - TC(4) * BZ ) RAY38150 DTC(6) = K * ( TC(4) * BY - TC(5) * BX ) RAY38160 IF (GAS*JRAY.EQ.0.)RETURN !***MP 1-JAN-85 VEL = DSQRT( TC(4)**2 + TC(5)**2 + TC(6)**2 ) !*** GAMMA = 1./DSQRT(1.-VEL*VEL/(C*C) ) !*** G3= GAMMA**3 !*** GASENE = EMASS*( GAMMA-1.) !*** ENERGY = GASENE 200 DTCGAS(1) = -GASK*TC(4)*DEDXQ / (VEL*G3) !*** DTCGAS(2) = -GASK*TC(5)*DEDXQ / (VEL*G3) !*** DTCGAS(3) = -GASK*TC(6)*DEDXQ / (VEL*G3) !*** DTC(4) = DTC(4) + DTCGAS(1) DTC(5) = DTC(5) + DTCGAS(2) !*** DTC(6) = DTC(6) + DTCGAS(3) !***MP 1-JAN-85 RETURN RAY38170 4 VEL = DSQRT( TC(4)**2 + TC(5)**2 + TC(6)**2 ) RAY38180 GAMMA = 1./DSQRT( 1.-VEL*VEL/(C*C) ) RAY38190 K = 1./(QMC*GAMMA) RAY38200 AK = K/(9.D13) RAY38210 ETERM = (EX*TC(4)+EY*TC(5)+EZ*TC(6) )*AK RAY38220 DTC(4) = K*( TC(5)*BZ - TC(6)*BY + EX*1.D7 ) - TC(4)*ETERM RAY38230 DTC(5) = K*( TC(6)*BX - TC(4)*BZ + EY*1.D7 ) - TC(5)*ETERM RAY38240 DTC(6) = K*( TC(4)*BY - TC(5)*BX + EZ*1.D7 ) - TC(6)*ETERM RAY38250 RETURN RAY38260 END RAY38270 SUBROUTINE DIPOLE ( NO, NP, T, TP ,NUM ) RAY02830 C**** RAY02840 C**** RAY02850 C**** SINGLE MAGNET RAY TRACING BY NUMERICAL INTEGRATION OF DIFFERENTIALRAY02860 C**** EQUATIONS OF MOTION. RAY02870 C T = TIME RAY02880 C TC(1) TO TC(6) = ( X, Y, Z, VX, VY, VZ ) RAY02890 C DTC(1) TO DTC(6) = ( VX, VY, VZ, VXDOT, VYDOT, VZDOT ) RAY02900 C**** RAY02910 C**** RAY02920 IMPLICIT REAL*8(A-H,O-Z) RAY02930 c REAL*4 DAET, TYME !JDL 31-OCT-84 REAL*8 LF1, LF2, LU1, K, NDX RAY02940 EXTERNAL BDIP RAY02950 include 'rtcomm0.f' COMMON /BLCK 4/ ENERGY, VEL, PMASS, Q0 RAY02970 COMMON /BLCK 5/ XA, YA, ZA, VXA, VYA, VZA RAY02980 COMMON /BLCK10/ BX, BY, BZ, K, TC, DTC RAY02990 COMMON /BLCK20/ NDX,BET1,GAMA,DELT,CSC RAY03000 COMMON /BLCK21/ RCA,DELS,BR,S2,S3,S4,S5,S6,S7,S8,SCOR RAY03010 COMMON /BLCK22/ D, DG, S, BF, BT RAY03020 COMMON /BLCK23/ C0, C1, C2, C3, C4, C5 RAY03030 COMMON /BLCK24/ RB, XC, ZC RAY03040 COMMON /BLCK25/ IN, MTYP RAY03050 COMMON /BLCK26/ IXS, XSCTR, ZSCTR !JDL 16-MAR-84 COMMON /BLCK60/ GAS,AGAS,ZGAS,ZION,PRESS,GASSIG,QAVER, !***MP 1-JAN-85 1 QFWHM,RHOGAS,GASK,EMASS,GASMFP,JRAY,Q00,NPASG !*** C*JDL DIMENSION DATA( 75,30 ), ITITLE(30) !JDL 17-NOV-83 RAY03060 DIMENSION TC(6), DTC(6), DS(6), ES(6) RAY03070 C**** DATA C/ 3.D10/ RAY03080 C**** RAY03090 JRAYGAS = JRAY*GAS LF1 = DATA( 1,NO ) RAY03100 LU1 = DATA( 2,NO ) RAY03110 LF2 = DATA( 3,NO ) RAY03120 DG = DATA( 4,NO ) RAY03130 MTYP = DATA( 5,NO ) RAY03140 A = DATA( 11,NO ) RAY03150 B = DATA( 12,NO ) RAY03160 D = DATA( 13,NO ) RAY03170 RB = DATA( 14,NO ) RAY03180 BF = DATA( 15,NO ) RAY03190 PHI = DATA( 16,NO ) RAY03200 ALPHA= DATA( 17,NO ) RAY03210 BETA = DATA( 18,NO ) RAY03220 NDX = DATA( 19,NO ) RAY03230 BET1 = DATA( 20,NO ) RAY03240 GAMA = DATA( 21,NO ) RAY03250 DELT = DATA( 22,NO ) RAY03260 XS1 = DATA( 23,NO ) !JDL 6-MAR-84 XS2 = DATA( 24,NO ) !JDL 6-MAR-84 Z11 = DATA( 25,NO ) RAY03270 Z12 = DATA( 26,NO ) RAY03280 Z21 = DATA( 27,NO ) RAY03290 Z22 = DATA( 28,NO ) RAY03300 BR1 = DATA( 41,NO ) RAY03310 BR2 = DATA( 42,NO ) RAY03320 XCR1 = DATA( 43,NO ) RAY03330 XCR2 = DATA( 44,NO ) RAY03340 IF( MTYP .EQ. 0 ) MTYP = 1 RAY03350 DTF1= LF1/ VEL RAY03360 DTF2= LF2/ VEL RAY03370 DTU = LU1/ VEL RAY03380 BX = 0. RAY03390 BY = 0. RAY03400 BZ = 0. RAY03410 BT = 0. RAY03420 S = 0. RAY03430 BR = BR1 RAY03440 IF(IXS .GT. 0) IXS=0 !JDL 6-MAR-84 IF( NP .GT. 100 ) GO TO 5 RAY03450 PRINT 100, ITITLE(NO) RAY03460 100 FORMAT( ' DIPOLE **** ', A4,' ****************************'/) RAY03470 PRINT 101 RAY03480 101 FORMAT( 8H T CM ,18X, 4HX CM , 7X, 2HBX, 8X, 4HY CM , 7X, 2HBY,RAY03490 1 8X, 4HZ CM, 7X, 2HBZ, 8X, 6HVELZ/C , 6X, 8HTHETA MR , 5X, RAY03500 2 6HPHI MR , 6X, 1HB ) RAY03510 IF (JRAYGAS.NE.0) PRINT 1010 1010 FORMAT(14X,4H/Q ,7X,2H/E,8X,4H/QB ,6X,3H/D2,8X,4H/MFP,6X, 1 3H/SC,8X,6H / ST ,6X,8H/ ACAP ,5X,6H/ ALOS,7X,6H /DEDX) CALL PRNT2 ( T,S,XA ,YA ,ZA ,BX,BY,BZ,BT,VXA ,VYA ,VZA )RAY03520 IF (JRAYGAS.NE.0) CALL PRNT2A PRINT 103 RAY03530 103 FORMAT( '0COORDINATE TRANSFORMATION TO B AXIS SYSTEM ' ) RAY03540 109 FORMAT( '0COORDINATE TRANSFORMATION TO D AXIS SYSTEM ' ) RAY03550 C**** TRANSFORM FROM INITIAL ENTRANCE COORDINATES TO VFB COORD. RAY03560 C**** RAY03570 5 COSA =DCOS( ALPHA/57.29578) RAY03580 SINA =DSIN( ALPHA/57.29578) RAY03590 TC(1) = ( A-ZA ) * SINA - ( XA + XCR1 ) * COSA RAY03600 TC(2) = YA RAY03610 TC(3) = ( A-ZA ) * COSA + ( XA + XCR1 ) * SINA RAY03620 TC(4) = -VZA * SINA - VXA * COSA RAY03630 TC(5) = VYA RAY03640 TC(6) = -VZA * COSA + VXA * SINA RAY03650 CALL PRNT2 ( T,S,TC(1),TC(2),TC(3),BX,BY,BZ,BT,TC(4),TC(5),TC(6) )RAY03660 IF (JRAYGAS.NE.0) CALL PRNT2A NUM = NUM+1 TPAR = T*VEL NBR = 2 CALL PLT1 ( NUM, NO, NBR, TPAR ) C**** RAY03670 C**** TRANSLATE PARTICLE TO START OF FIRST FRINGE FIELD RAY03680 C**** RAY03690 C**** RAY03700 IF( BR1 .EQ. 0. ) GO TO 20 RAY03710 IN = 4 RAY03720 XDTF1 = DTF1 RAY03730 IF( Z11 .GT. TC(3) ) XDTF1 = -DTF1 RAY03740 IF( NP .LE. 100) PRINT 108 RAY03750 108 FORMAT(/ ' CONSTANT FIELD CORRECTION IN FRINGE FIELD REGION ' )RAY03760 NSTEP = 0 RAY03770 CALL FNMIRK( 6, T,XDTF1,TC, DTC, DS, ES, BDIP, 0 ) RAY03780 21 CALL PRNT2 ( T,S,TC(1),TC(2),TC(3),BX,BY,BZ,BT,TC(4),TC(5),TC(6) )RAY03790 IF (JRAYGAS.NE.0) CALL PRNT2A DO 22 I=1,NP RAY03800 CALL FNMIRK( 6, T,XDTF1,TC, DTC, DS, ES, BDIP, 1 ) RAY03810 NSTEP = NSTEP + 1 RAY03820 NUM = NUM+1 TPAR = T*VEL NBR = 2 CALL PLT1 ( NUM, NO, NBR, TPAR ) IF (NSTEP .GT. 10000) GO TO 99 RAY03821 IF( XDTF1 .LT. 0. ) GO TO 23 RAY03830 IF( Z11 .GE. TC(3) ) GO TO 24 RAY03840 GO TO 22 RAY03850 23 IF( Z11 .LE. TC(3) ) GO TO 24 RAY03860 22 CONTINUE RAY03870 GO TO 21 RAY03880 24 DO 2 I=1,2 RAY03890 XDTF1 = (TC(3) - Z11) / DABS(TC(6)) RAY03900 CALL FNMIRK( 6, T,XDTF1,TC, DTC, DS, ES, BDIP, 0 ) RAY03910 2 CALL FNMIRK( 6, T,XDTF1,TC, DTC, DS, ES, BDIP, 1 ) RAY03920 CALL PRNT2 ( T,S,TC(1),TC(2),TC(3),BX,BY,BZ,BT,TC(4),TC(5),TC(6) )RAY03930 IF (JRAYGAS.NE.0) CALL PRNT2A NUM = NUM+1 TPAR = T*VEL NBR = 2 CALL PLT1 ( NUM, NO, NBR, TPAR ) IF( NP .LE. 100) PRINT 105, NSTEP RAY03940 C**** RAY03950 C**** RAY03960 C**** RAY03970 20 TDT = ( TC(3) - Z11 ) /DABS( TC(6) ) RAY03980 TC(1) = TC(1) + TDT * TC(4) RAY03990 TC(2) = TC(2) + TDT * TC(5) RAY04000 TC(3) = TC(3) + TDT * TC(6) RAY04010 T = T + TDT RAY04020 IF (Q00.LT.0.) TOLD=T NUM = NUM+1 TPAR = T*VEL NBR = 2 CALL PLT1 ( NUM, NO, NBR, TPAR ) C**** RAY04030 C**** IN DESIGNATES MAGNET REGIONS FOR BFUN RAY04040 C**** RAY04050 IN = 1 RAY04060 XC= RB*DCOS( ALPHA/ 57.29578 ) RAY04070 ZC=-RB*DSIN( ALPHA/ 57.29578 ) RAY04080 C**** RAY04090 C0 = DATA( 29,NO ) RAY04100 C1 = DATA( 30,NO ) RAY04110 C2 = DATA( 31,NO ) RAY04120 C3 = DATA( 32,NO ) RAY04130 C4 = DATA( 33,NO ) RAY04140 C5 = DATA( 34,NO ) RAY04150 DELS = DATA( 45,NO ) RAY04160 RCA = DATA( 47,NO ) RAY04170 CSC = DCOS( ALPHA/57.29578 ) RAY04180 SCOR = DATA(49,NO) RAY04190 S2 = DATA( 51,NO ) / RB + RCA/2.D0 RAY04200 S3 = DATA( 52,NO ) / RB**2 RAY04210 S4 = DATA( 53,NO ) / RB**3 + RCA**3/8.D0 RAY04220 S5 = DATA( 54,NO ) / RB**4 RAY04230 S6 = DATA( 55,NO ) / RB**5 + RCA**5/16.D0 RAY04240 S7 = DATA( 56,NO ) / RB**6 RAY04250 S8 = DATA( 57,NO ) / RB**7 + RCA**7/25.6D0 RAY04260 IF( NP .LE. 100) PRINT 104 RAY04270 104 FORMAT( 22H0FRINGING FIELD REGION ) RAY04280 CALL FNMIRK( 6, T, DTF1,TC, DTC, DS, ES, BDIP, 0 ) RAY04290 NSTEP = 0 RAY04300 6 CALL PRNT2 ( T,S,TC(1),TC(2),TC(3),BX,BY,BZ,BT,TC(4),TC(5),TC(6) )RAY04310 IF (JRAYGAS.NE.0) CALL PRNT2A DO 7 I = 1, NP RAY04320 CALL FNMIRK( 6, T, DTF1,TC, DTC, DS, ES, BDIP, 1 ) RAY04330 NSTEP = NSTEP + 1 RAY04340 NUM = NUM+1 TPAR = T*VEL NBR = 2 CALL PLT1 ( NUM, NO, NBR, TPAR ) IF (NSTEP .GT. 10000) GO TO 99 RAY04341 IF( Z12 .GE. TC(3) ) GO TO 8 RAY04350 7 CONTINUE RAY04360 GO TO 6 RAY04370 8 CONTINUE RAY04380 XDTF1 =-( Z12 - TC(3) ) /DABS( TC(6) ) RAY04390 CALL FNMIRK( 6, T,XDTF1,TC, DTC, DS, ES, BDIP, 0 ) RAY04400 CALL FNMIRK( 6, T,XDTF1,TC, DTC, DS, ES, BDIP, 1 ) RAY04410 CALL PRNT2 ( T,S,TC(1),TC(2),TC(3),BX,BY,BZ,BT,TC(4),TC(5),TC(6) )RAY04420 IF (JRAYGAS.NE.0) CALL PRNT2A NUM = NUM+1 TPAR = T*VEL NBR = 2 CALL PLT1 ( NUM, NO, NBR, TPAR ) IF( NP .LE. 100) PRINT 105, NSTEP RAY04430 105 FORMAT( 10H NSTEPS= I5 ) RAY04440 C*** RAY04450 C*** UNIFORM FIELD REGION RAY04460 C**** TRANSFORM TO SECOND VFB COORD SYSTEM RAY04470 C*** RAY04480 COPAB =DCOS( (PHI-ALPHA-BETA)/57.29578) RAY04490 SIPAB =DSIN( (PHI-ALPHA-BETA)/57.29578) RAY04500 COSPB =DCOS( (PHI/2.-BETA)/57.29578 ) RAY04510 SINPB =DSIN( (PHI/2.-BETA)/57.29578 ) RAY04520 SIP2 =DSIN( (PHI/2.)/57.29578 ) RAY04530 XT = TC(1) RAY04540 ZT = TC(3) RAY04550 VXT = TC(4) RAY04560 VZT = TC(6) RAY04570 TC(3) = - ZT *COPAB + XT *SIPAB -2.*RB*SIP2*COSPB RAY04580 TC(1) = - ZT *SIPAB - XT *COPAB -2.*RB*SIP2*SINPB RAY04590 TC(6) = - VZT *COPAB + VXT *SIPAB RAY04600 TC(4) = - VZT *SIPAB - VXT *COPAB RAY04610 C**** RAY04620 C**** RAY04630 C**** UNIFORM FIELD INTEGRATION REGION RAY04640 C**** RAY04650 C**** RAY04660 IN = 2 RAY04670 XC=-RB*DCOS( BETA / 57.29578 ) RAY04680 ZC=-RB*DSIN( BETA / 57.29578 ) RAY04690 IF( NP .LE. 100) PRINT 106 RAY04700 106 FORMAT( '0UNIFORM FIELD REGION IN C AXIS SYSTEM ' ) RAY04710 IF( TC(3) .LT. Z21 ) GO TO 15 RAY04720 C**** RAY04730 C**** THIS SECTION CORRECTS FOR MAGNETS WHOSE FRINGING FIELDS INTERSECT RAY04740 C**** RAY04750 IF( NP .LE. 100) PRINT 102 RAY04760 102 FORMAT( / ' INTEGRATE BACKWARDS ' ) RAY04770 CALL FNMIRK( 6, T,-DTU ,TC, DTC, DS, ES, BDIP, 0 ) RAY04780 NSTEP = 0 RAY04790 16 CALL PRNT2 ( T,S,TC(1),TC(2),TC(3),BX,BY,BZ,BT,TC(4),TC(5),TC(6) )RAY04800 IF (JRAYGAS.NE.0) CALL PRNT2A DO 17 I =1, NP RAY04810 CALL FNMIRK( 6, T,-DTU, TC, DTC, DS, ES, BDIP, 1 ) RAY04820 NSTEP = NSTEP + 1 RAY04830 NUM = NUM+1 TPAR = T*VEL NBR = 3 CALL PLT1 ( NUM, NO, NBR, TPAR ) IF (NSTEP .GT. 10000) GO TO 99 RAY04831 IF( TC(3) .LE. Z21 ) GO TO 18 RAY04840 17 CONTINUE RAY04850 GO TO 16 RAY04860 18 CONTINUE RAY04870 XDTU = ( Z21 - TC(3) ) /DABS( TC(6) ) RAY04880 CALL FNMIRK( 6, T,XDTU ,TC, DTC, DS, ES, BDIP, 0 ) RAY04890 CALL FNMIRK( 6, T,XDTU ,TC, DTC, DS, ES, BDIP, 1 ) RAY04900 CALL PRNT2 ( T,S,TC(1),TC(2),TC(3),BX,BY,BZ,BT,TC(4),TC(5),TC(6) )RAY04910 IF (JRAYGAS.NE.0) CALL PRNT2A NUM = NUM+1 TPAR = T*VEL NBR = 3 CALL PLT1 ( NUM, NO, NBR, TPAR ) IF( NP .LE. 100) PRINT 105, NSTEP RAY04920 IF( NP .LE. 100) PRINT 107 RAY04930 107 FORMAT( / ) RAY04940 GO TO 19 RAY04950 C**** RAY04960 C**** RAY04970 15 CONTINUE RAY04980 CALL FNMIRK( 6, T, DTU ,TC, DTC, DS, ES, BDIP, 0 ) RAY04990 NSTEP = 0 RAY05000 9 CALL PRNT2 ( T,S,TC(1),TC(2),TC(3),BX,BY,BZ,BT,TC(4),TC(5),TC(6) )RAY05010 IF (JRAYGAS.NE.0) CALL PRNT2A DO 10 I =1, NP RAY05020 CALL FNMIRK( 6, T, DTU, TC, DTC, DS, ES, BDIP, 1 ) RAY05030 NSTEP = NSTEP + 1 RAY05040 NUM = NUM+1 TPAR = T*VEL NBR = 3 CALL PLT1 ( NUM, NO, NBR, TPAR ) IF (NSTEP .GT. 10000) GO TO 99 RAY05041 IF( TC(3) .GE. Z21 ) GO TO 11 RAY05050 C**** !Changes from here... !JDL 6-MAR-84 C**** C**** FIND THE X-COORDINATE (XSCTR) AT PHI/2 (ZSCTR) AND INDICATE IF: C**** C**** IXS = 0, SLITS NOT FOUND IN UNIFORM FIELD REGION. C**** -1, RAY OUTSIDE (MORE POSITIVE THAN XS1 AND XS2). C**** +1, RAY PASSES (BETWEEN SLITS AT XS1 AND XS2). C**** -2, RAY INSIDE (MORE NEGATIVE THAN XS1 AND XS2). C**** C**** DATA CARD 5 NOW CONTAINS: NDX, BET1, GAMA, DELT, XS1, XS2. C**** IF(IXS .NE. 0) GO TO 10 ZSCTR=TC(1)*SINPB+TC(3)*COSPB+RB*SIP2 IF(ZSCTR .LT. 0.0) GO TO 10 IXS=1 IF((XS1 .EQ. 0.0) .AND. (XS2 .EQ. 0.0)) GO TO 10 XSCTR=TC(1)*COSPB-TC(3)*SINPB-RB*(1.0-DCOS((PHI/2.0)/57.29578)) IF((XSCTR .GT. XS1) .AND. (XSCTR .GT. XS2)) IXS=-1 IF((XSCTR .LT. XS1) .AND. (XSCTR .LT. XS2)) IXS=-2 C**** !...down to here. !JDL 6-MAR-84 10 CONTINUE RAY05060 GO TO 9 RAY05070 11 CONTINUE RAY05080 XDTU = ( Z21 - TC(3) ) /DABS( TC(6) ) RAY05090 CALL FNMIRK( 6, T,XDTU ,TC, DTC, DS, ES, BDIP, 0 ) RAY05100 CALL FNMIRK( 6, T,XDTU ,TC, DTC, DS, ES, BDIP, 1 ) RAY05110 CALL PRNT2 ( T,S,TC(1),TC(2),TC(3),BX,BY,BZ,BT,TC(4),TC(5),TC(6) )RAY05120 IF (JRAYGAS.NE.0) CALL PRNT2A NUM = NUM+1 TPAR = T*VEL NBR = 3 CALL PLT1 ( NUM, NO, NBR, TPAR ) IF( NP .LE. 100) PRINT 105, NSTEP RAY05130 19 CONTINUE RAY05140 C*** RAY05150 C*** RAY05160 C**** SETUP FOR SECOND FRINGE FIELD AND INTEGRATION RAY05170 C**** RAY05180 C**** RAY05190 BR = BR2 RAY05200 C0 = DATA( 35,NO ) RAY05210 C1 = DATA( 36,NO ) RAY05220 C2 = DATA( 37,NO ) RAY05230 C3 = DATA( 38,NO ) RAY05240 C4 = DATA( 39,NO ) RAY05250 C5 = DATA( 40,NO ) RAY05260 DELS = DATA( 46,NO ) RAY05270 RCA = DATA( 48,NO ) RAY05280 SCOR = DATA(50,NO) RAY05290 CSC = DCOS( BETA /57.29578 ) RAY05300 S2 = DATA( 58,NO ) / RB + RCA/2.D0 RAY05310 S3 = DATA( 59,NO ) / RB**2 RAY05320 S4 = DATA( 60,NO ) / RB**3 + RCA**3/8.D0 RAY05330 S5 = DATA( 61,NO ) / RB**4 RAY05340 S6 = DATA( 62,NO ) / RB**5 + RCA**5/16.D0 RAY05350 S7 = DATA( 63,NO ) / RB**6 RAY05360 S8 = DATA( 64,NO ) / RB**7 + RCA**7/25.6D0 RAY05370 IN = 3 RAY05380 IF( NP .LE. 100) PRINT 104 RAY05390 CALL FNMIRK( 6, T, DTF2,TC, DTC, DS, ES, BDIP, 0 ) RAY05400 NSTEP = 0 RAY05410 12 CALL PRNT2 ( T,S,TC(1),TC(2),TC(3),BX,BY,BZ,BT,TC(4),TC(5),TC(6) )RAY05420 IF (JRAYGAS.NE.0) CALL PRNT2A DO 13 I =1, NP RAY05430 CALL FNMIRK( 6, T, DTF2,TC, DTC, DS, ES, BDIP, 1 ) RAY05440 NSTEP = NSTEP + 1 RAY05450 NUM = NUM+1 TPAR = T*VEL NBR = 3 CALL PLT1 ( NUM, NO, NBR, TPAR ) IF (NSTEP .GT. 10000) GO TO 99 RAY05451 IF( TC(3) .GE. Z22 ) GO TO 14 RAY05460 13 CONTINUE RAY05470 GO TO 12 RAY05480 14 CONTINUE RAY05490 XDTF2 = ( Z22 - TC(3) ) /DABS( TC(6) ) RAY05500 CALL FNMIRK( 6, T,XDTF2,TC, DTC, DS, ES, BDIP, 0 ) RAY05510 CALL FNMIRK( 6, T,XDTF2,TC, DTC, DS, ES, BDIP, 1 ) RAY05520 CALL PRNT2 ( T,S,TC(1),TC(2),TC(3),BX,BY,BZ,BT,TC(4),TC(5),TC(6) )RAY05530 IF (JRAYGAS.NE.0) CALL PRNT2A NUM = NUM+1 TPAR = T*VEL NBR = 3 CALL PLT1 ( NUM, NO, NBR, TPAR ) IF( NP .LE. 100) PRINT 105, NSTEP RAY05540 C**** RAY05550 C**** TRANSFORM TO OUTPUT SYSTEM COORD. RAY05560 C**** RAY05570 COSB =DCOS( BETA/57.29578 ) RAY05580 SINB =DSIN( BETA/57.29578 ) RAY05590 XT = TC(1) RAY05600 ZT = TC(3) RAY05610 VXT = TC(4) RAY05620 VZT = TC(6) RAY05630 TC(3) = ZT*COSB - XT*SINB - B RAY05640 TC(1) = ZT*SINB + XT*COSB - XCR2 RAY05650 TC(6) = VZT*COSB - VXT*SINB RAY05660 TC(4) = VZT*SINB + VXT*COSB RAY05670 IF( NP .LE. 100) PRINT 109 RAY05680 CALL PRNT2 ( T,S,TC(1),TC(2),TC(3),BX,BY,BZ,BT,TC(4),TC(5),TC(6) )RAY05690 IF (JRAYGAS.NE.0) CALL PRNT2A C**** RAY05700 C**** TRANSLATE PARTICLE TO OUT SYSTEM COORD. RAY05710 C**** RAY05720 IF( BR2 .EQ. 0. ) GO TO 30 RAY05730 IN = 4 RAY05740 XDTF2 = DTF2 RAY05750 IF( TC(3) .GT. 0. ) XDTF2 = -DTF2 RAY05760 IF( NP .LE. 100) PRINT 108 RAY05770 NSTEP = 0 RAY05780 CALL FNMIRK( 6, T,XDTF2,TC, DTC, DS, ES, BDIP, 0 ) RAY05790 31 CALL PRNT2 ( T,S,TC(1),TC(2),TC(3),BX,BY,BZ,BT,TC(4),TC(5),TC(6) )RAY05800 IF (JRAYGAS.NE.0) CALL PRNT2A DO 32 I=1,NP RAY05810 CALL FNMIRK( 6, T,XDTF2,TC, DTC, DS, ES, BDIP, 1 ) RAY05820 NSTEP = NSTEP + 1 RAY05830 NUM = NUM+1 TPAR = T*VEL NBR = 4 CALL PLT1 ( NUM, NO, NBR, TPAR ) IF (NSTEP .GT. 10000) GO TO 99 RAY05831 IF( XDTF2 .LT. 0. ) GO TO 33 RAY05840 IF( TC(3) .GE. 0. ) GO TO 34 RAY05850 GO TO 32 RAY05860 33 IF( TC(3) .LE. 0. ) GO TO 34 RAY05870 32 CONTINUE RAY05880 GO TO 31 RAY05890 34 DO 3 I=1,2 RAY05900 XDTF2 = -TC(3) / DABS(TC(6)) RAY05910 CALL FNMIRK( 6, T,XDTF2,TC, DTC, DS, ES, BDIP, 0 ) RAY05920 3 CALL FNMIRK( 6, T,XDTF2,TC, DTC, DS, ES, BDIP, 1 ) RAY05930 CALL PRNT2 ( T,S,TC(1),TC(2),TC(3),BX,BY,BZ,BT,TC(4),TC(5),TC(6) )RAY05940 IF (JRAYGAS.NE.0) CALL PRNT2A NUM = NUM+1 TPAR = T*VEL NBR = 4 CALL PLT1 ( NUM, NO, NBR, TPAR ) IF( NP .LE. 100) PRINT 105, NSTEP RAY05950 C**** RAY05960 C**** RAY05970 C**** RAY05980 30 TDT = -TC(3) /DABS( TC(6) ) RAY05990 TC(1) = TC(1) + TDT * TC(4) RAY06000 TC(2) = TC(2) + TDT * TC(5) RAY06010 TC(3) = TC(3) + TDT * TC(6) RAY06020 T = T + TDT RAY06030 TP = T * VEL RAY06040 BX = 0. RAY06050 BY = 0. RAY06060 BZ = 0. RAY06070 BT = 0. RAY06080 S = 0. RAY06090 VXF = 1000. *DATAN2( TC(4), TC(6) ) RAY06100 VYF = 1000. *DASIN ( TC(5)/ VEL ) RAY06110 VZF = TC(6) / VEL RAY06120 IF( NP .LE. 100) PRINT 115,TP,TC(1),TC(2),TC(3),VZF,VXF,VYF RAY06130 115 FORMAT( F10.4, 10X, F10.3, 11X, F10.3, 11X, F10.3, 11X, RAY06140 1 F13.5, F13.2, F11.2 ) RAY06150 NUM = NUM+1 TPAR = T*VEL NBR = 4 CALL PLT1 ( NUM, NO, NBR, TPAR ) C**** RAY06160 C**** CALCULATE INTERCEPTS IN SYSTEM D RAY06170 C**** RAY06180 Z0X = -TC(1)/ ( TC(4) / TC(6) + 1.E-10 ) RAY06190 Z0Y = -TC(2)/ ( TC(5) / TC(6) + 1.E-10 ) RAY06200 IF( NP .LE. 100) PRINT 111, VXF, VYF, Z0X, Z0Y RAY06210 111 FORMAT( / ' INTERSECTIONS WITH VER. AND HOR. PLANES ' , RAY06220 X /15X, 5H XP=F10.4, 10H MR YP= F10.4, 3H MR / RAY06230 1 15X, 5H Z0X=F10.2, 10H CM Z0Y= F10.2, 3H CM / )RAY06240 RETURN RAY06250 99 CALL PRNT4(NO, IN) RAY06251 RETURN RAY06252 END RAY06260 SUBROUTINE DISCOL(DT,H,IQSW) c c Entry points: c DISCOL Determine distance to charge changing collision c If distance to go in this FNMIRK integration step is less than c remaining distance to next collision, update integration step c size, signal collision to FNMIRK and compute distance to next c charge changing collision. c c DISCOL0 Initialisation for new ray c (Re)sets "distance since last collision" counter and c determines distance to next collision c c Parameters: c dt default FNMIRK integration (time) step size c h (time) step size FNMIRK going to use, c initially .eq.dt, updated if collision c iqsw charge changing collision at end of this step c c Called by c FNMIRK Runge-Kutta integration routine c RAYTRACE Main program before ray is launched c c Calls c RAN FORTRAN RTL random number generator c c Global Variables c vel velocity of ion c gasmfp mean free path length in gas c iseed random generator seed c c Comment c one possible optimisation is to have coldst, curdst in time domain. c would save 1/ in collision, 1* when no collision, c but velocity changes might give wrong results (though small: c velocity changes high: lots of gas --> lots of collisions c thin gas: velocity changes between charge changing is small) c IMPLICIT REAL*8(A-H,O-Z) RAY00090 COMMON /BLCK 4/ ENERGY, VEL, PMASS, Q0 RAY00140 COMMON /BLCK60/ GAS,AGAS,ZGAS,ZION,PRESS,GASSIG,QAVER, !***MP 1-JAN-85 1 QFWHM,RHOGAS,GASK,EMASS,GASMFP,JRAY,Q00,NPASG !*** COMMON /BLCK63/ ISEED c COMMON /BLCK65/QBAR,DELSQR,ACAPT,ALOS,NSK1,NSK2,SIGC,SIGT,ATBCC DATA NPASG/0/ c real*8 curdst ! distance since previous collision real*8 curodst ! to remember where this step starts real*8 coldst ! distance between prev and next c ! collision real*8 r ! temp for random generator c c***** c if we are here the first time, we have to setup first collision c (could GOTO r=ran(iseed), and save some instructions, but what if c first coldst .le. vel*dt ? OK, than we have lots of collisions ...) c curodst=curdst ! remember where we are curdst=curdst+vel*dt ! where will this integration step end? if (curdst.lt.coldst) return ! short of next collision is ok. h=(coldst-curodst)/vel ! Don't go that far. iqsw=1 ! tell it there'll be a collision curdst=0. ! we just had one next time r = ran(iseed) ! where will be the following one? coldst = -dlog(1.0D0-r)*gasmfp return c c initialisation routine for next ray c entry discol0 c curdst=0. ! we just are starting coldst=-dlog(1.0D0-ran(iseed))*gasmfp ! there will be the 1st collision return c c***** c previous algorithm: remembered very small step size when c collision occured at approximation of field boundary, c so that integration didn't terminate within 10000 steps. c c IF (NPASG.GT.0) GO TO 10 c IQSW = 1 c R = RAN(ISEED) c DIST = -DLOG(1.-R)*GASMFP c H = DIST/VEL c IF (H.LE.DT) RETURN c NP = JIDINT(H/DT) +1 c HP = H/NP c10 IQSW = 0 c H = HP c NPASG = NPASG + 1 c IF (NPASG.LT.NP) RETURN c NPASG = 0 c IQSW = 1 c RETURN END C******** C******** C******** C START CHARGE CHANGE ROUTINES MP 1-JAN-85 C C C******** SUBROUTINE DRIFT( NO, NP,T, TP ,NUM ) RAY24920 C**** RAY24930 C**** RAY24940 C**** Z-AXIS DRIFT ROUTINE RAY24950 C**** RAY24960 C**** RAY24970 IMPLICIT REAL*8(A-H,O-Z) RAY24980 c REAL*4 DAET, TYME !JDL 31-OCT-84 include 'rtcomm0.f' COMMON /BLCK 4/ ENERGY, VEL, PMASS, Q0 RAY25000 COMMON /BLCK 5/ XA, YA, ZA, VXA, VYA, VZA RAY25010 C*JDL DIMENSION DATA( 75,30 ), ITITLE(30) !JDL 17-NOV-83 RAY25020 C**** DATA C/ 3.D10/ RAY25030 100 FORMAT( / ' Z-AXIS DRIFT **** ', A4, '****************',// RAY25040 1' T CM', 18X, 'X CM', 7X, 'Y CM', 7X, 'Z CM' , ' VELZ/C'RAY25050 2 , ' THETA MR PHI MR' / ) RAY25060 103 FORMAT( F10.4, 11X, 3F11.3, F12.5, 2F12.3 ) RAY25070 NUM = NUM+1 TPAR = T*VEL NBR = 1 CALL PLT2 ( NUM, NO, NBR, TPAR ) IF( NP .LE. 100) PRINT 100, ITITLE(NO) RAY25080 VXP = 1000. *DATAN2( VXA,VZA ) RAY25090 VYP = 1000. *DASIN ( VYA/VEL ) RAY25100 VZP = VZA / VEL RAY25110 TP = T*VEL RAY25120 IF( NP .LE. 100) PRINT 103, TP, XA, YA, ZA, VZP, VXP, VYP RAY25130 TDT =(DATA(1,NO) - ZA) / DABS(VZA) RAY25140 T = T + TDT RAY25150 TP = T*VEL RAY25160 XA = XA + TDT*VXA RAY25170 YA = YA + TDT*VYA RAY25180 ZA = 0. RAY25190 IF( NP .LE. 100) PRINT 103, TP, XA, YA, ZA, VZP, VXP, VYP RAY25200 NUM = NUM+1 TPAR = T*VEL NBR = 2 CALL PLT2 ( NUM, NO, NBR, TPAR ) RETURN RAY25210 END RAY25220 SUBROUTINE EDIP C**** C**** CALCULATES E-FIELD COMPONENTS FOR A CYLINDRICAL C**** ELECTROSTATIC DEFLECTOR C**** IMPLICIT REAL*8 (A-H, O-Z) REAL*8 K COMMON /BLCK10/ BX, BY, BZ, K, TC, DTC RAY02990 COMMON /BLCK11/ EX, EY, EZ, QMC, IVEC RAY00190 COMMON /BLCK20/ EC2, EC4, WE, WC COMMON /BLCK22/ D, DG, S, EF, ET RAY03020 COMMON /BLCK23/ C0, C1, C2, C3, C4, C5 RAY03030 COMMON /BLCK24/ RB, XC, ZC RAY03040 COMMON /BLCK25/ IN, MTYP RAY03050 DIMENSION TC(6), DTC(6) C**** C**** X = TC(1) Y = TC(2) Z = TC(3) DX = X - XC DZ = Z RP2 = DX * DX + Z * Z RP = DSQRT(RP2) GO TO (1, 2, 3) , IN 100 FORMAT( ' ERROR -GO TO- IN EDIP IN = ', I5) PRINT 100, IN C**** C**** UNIFORM FIELD REGION C**** 2 EX = - EF * RB * DX / RP2 EY = 0. EZ = - EF * RB * Z / RP2 ET = DSQRT(EX * EX + EZ * EZ) RETURN C**** C**** FRINGE FIELD REGION C**** 1 CONTINUE 3 CONTINUE ZP1 = DZ + DG ZP2 = DZ + 2. * DG ZM1 = DZ - DG ZM2 = DZ - 2. * DG DRP1 = DSQRT( DX * DX + ZP1 * ZP1 ) DRP2 = DSQRT( DX * DX + ZP2 * ZP2 ) DRM1 = DSQRT( DX * DX + ZM1 * ZM1 ) DRM2 = DSQRT( DX * DX + ZM2 * ZM2 ) CALL EDPP (F0, Z , X, Y , RP ) S0 = S CALL EDPP (F1, ZP1 , X, Y , DRP1 ) CALL EDPP (F2, ZP2 , X, Y , DRP2 ) CALL EDPP (F3, ZP1 , X, Y+DG , DRP1 ) CALL EDPP (F4, ZP1 , X, Y-DG , DRP1 ) CALL EDPP (F5, Z , X, Y+DG , RP ) CALL EDPP (F6, Z , X, Y+2.*DG, RP ) CALL EDPP (F7, Z , X, Y-DG , RP ) CALL EDPP (F8, Z , X, Y-2.*DG, RP ) CALL EDPP (F9, ZM1 , X, Y , DRM1 ) CALL EDPP (F10, ZM2 , X, Y , DRM2 ) CALL EDPP (F11, ZM1 , X, Y+DG , DRM1 ) CALL EDPP (F12, ZM1 , X, Y-DG , DRM1 ) S = S0 XG1 = X/DG RAY20790 XG2 = XG1*XG1 RAY20800 XG3 = XG2*XG1 RAY20810 XG4 = XG3*XG1 RAY20820 C**** RAY20830 EY = XG1 * ( (F5-F7)*2./3. - (F6-F8)/12. ) + RAY20840 1 XG3 * ( (F5-F7)/6. - (F6-F8)/12. - RAY20850 2 ( F3 + F11 - F4 - F12 - 2.*F5 + 2.*F7 )/12. ) RAY20860 EX = F0 - XG2*( (F1 + F9 + F5 + F7 - 4.*F0) * 2./3. - RAY20870 1 ( F2 + F10 + F6 + F8 - 4.*F0 )/24. ) + RAY20880 2 XG4 * (-( F1 + F9 + F5 + F7 - 4.*F0 )/6. + RAY20890 3 ( F2 + F10 + F6 + F8 - 4.*F0 )/24. + RAY20900 4 ( F3 + F11 + F4 + F12 - 2.*F1 - 2.*F9 - RAY20910 5 2.*F5 - 2.*F7 + 4.*F0 )/12. ) RAY20920 EZ = XG1 * ( (F1 - F9)*2./3. - (F2 - F10)/12. ) + RAY20930 1 XG3 * ( (F1 - F9)/6. - (F2 - F10)/12. - RAY20940 2 (F3 + F4 - F11 - F12 - 2.*F1 + 2.*F9)/12. ) RAY20950 ET = DSQRT( EX * EX + EY * EY + EZ * EZ) RETURN END SUBROUTINE EDIPL( NO, NP, T, TP ,NUM ) RAY02830 C**** RAY02840 C**** RAY02850 C**** SINGLE MAGNET RAY TRACING BY NUMERICAL INTEGRATION OF DIFFERENTIALRAY02860 C**** EQUATIONS OF MOTION. RAY02870 C T = TIME RAY02880 C TC(1) TO TC(6) = ( X, Y, Z, VX, VY, VZ ) RAY02890 C DTC(1) TO DTC(6) = ( VX, VY, VZ, VXDOT, VYDOT, VZDOT ) RAY02900 C**** RAY02910 C**** RAY02920 IMPLICIT REAL*8(A-H,O-Z) RAY02930 c REAL*4 DAET, TYME !JDL 31-OCT-84 REAL*8 LF1, LF2, LU1, K RAY02940 EXTERNAL EDIP RAY02950 include 'rtcomm0.f' COMMON /BLCK 4/ ENERGY, VEL, PMASS, Q0 RAY02970 COMMON /BLCK 5/ XA, YA, ZA, VXA, VYA, VZA RAY02980 COMMON /BLCK10/ BX, BY, BZ, K, TC, DTC RAY02990 COMMON /BLCK11/ EX, EY, EZ, QMC, IVEC RAY00190 COMMON /BLCK20/ EC2, EC4, WE, WC COMMON /BLCK22/ D, DG, S, EF, ET RAY03020 COMMON /BLCK23/ C0, C1, C2, C3, C4, C5 RAY03030 COMMON /BLCK24/ RB, XC, ZC RAY03040 COMMON /BLCK25/ IN, MTYP RAY03050 COMMON /BLCK26/ IXS, XSCTR, ZSCTR !JDL 25-MAY-84 C*JDL DIMENSION DATA( 75,30 ), ITITLE(30) !JDL 17-NOV-83 RAY03060 DIMENSION TC(6), DTC(6), DS(6), ES(6) RAY03070 C**** DATA C/ 3.D10/ RAY03080 C**** RAY03090 LF1 = DATA( 1,NO ) RAY03100 LU1 = DATA( 2,NO ) RAY03110 LF2 = DATA( 3,NO ) RAY03120 DG = DATA( 4,NO ) RAY03130 A = DATA( 11,NO ) RAY03150 B = DATA( 12,NO ) RAY03160 D = DATA( 13,NO ) RAY03170 RB = DATA( 14,NO ) RAY03180 EF = DATA( 15,NO ) RAY03190 PHI = DATA( 16,NO ) RAY03200 EC2 = DATA( 17,NO ) EC4 = DATA( 18,NO ) WE = DATA( 19,NO ) WC = DATA( 20,NO ) Z11 = DATA( 25,NO ) RAY03270 Z12 = DATA( 26,NO ) RAY03280 Z21 = DATA( 27,NO ) RAY03290 Z22 = DATA( 28,NO ) RAY03300 DTF1= LF1/ VEL RAY03360 DTF2= LF2/ VEL RAY03370 DTU = LU1/ VEL RAY03380 IF (WE .EQ. 0.) WE = 1000. * RB BX = 0. BY = 0. BZ = 0. EX = 0. RAY03390 EY = 0. RAY03400 EZ = 0. RAY03410 ET = 0. RAY03420 S = 0. RAY03430 XS2 = +D/2.0 !JDL 25-MAY-84 XS1 = -XS2 !JDL 25-MAY-84 IF( IXS .GT. 0 ) IXS = 0 !JDL 25-MAY-84 IF( NP .GT. 100 ) GO TO 5 RAY03450 PRINT 100, ITITLE(NO) RAY03460 100 FORMAT( ' E.S.-DIPOLE ****', A4,' ***************************'/)RAY03470 PRINT 101 RAY03480 101 FORMAT( 8H T CM ,18X, 4HX CM , 7X, 2HEX, 8X, 4HY CM , 7X, 2HEY,RAY03490 1 8X, 4HZ CM, 7X, 2HEZ, 8X, 6HVELZ/C , 6X, 8HTHETA MR , 5X, RAY03500 2 6HPHI MR , 6X, 1HE ) RAY03510 CALL PRNT5 ( T,S,XA ,YA ,ZA ,EX,EY,EZ,ET,VXA ,VYA ,VZA )RAY03520 PRINT 103 RAY03530 103 FORMAT( '0COORDINATE TRANSFORMATION TO B AXIS SYSTEM ' ) RAY03540 109 FORMAT( '0COORDINATE TRANSFORMATION TO D AXIS SYSTEM ' ) RAY03550 C**** TRANSFORM FROM INITIAL ENTRANCE COORDINATES TO EFB COORD. RAY03560 C**** RAY03570 5 CONTINUE RAY03580 TC(1) = - XA RAY03600 TC(2) = YA RAY03610 TC(3) = ( A-ZA ) RAY03620 TC(4) = - VXA RAY03630 TC(5) = VYA RAY03640 TC(6) = -VZA RAY03650 CALL PRNT5 ( T,S,TC(1),TC(2),TC(3),EX,EY,EZ,ET,TC(4),TC(5),TC(6) )RAY03660 NUM = NUM+1 TPAR = T*VEL NBR = 2 CALL PLT1 ( NUM, NO, NBR, TPAR ) C**** RAY03950 C**** RAY03960 C**** RAY03970 20 TDT = ( TC(3) - Z11 ) /DABS( TC(6) ) RAY03980 TC(1) = TC(1) + TDT * TC(4) RAY03990 TC(2) = TC(2) + TDT * TC(5) RAY04000 TC(3) = TC(3) + TDT * TC(6) RAY04010 T = T + TDT RAY04020 NUM = NUM+1 TPAR = T*VEL NBR = 2 CALL PLT1 ( NUM, NO, NBR, TPAR ) C**** RAY04030 C**** IN DESIGNATES MAGNET REGIONS FOR BFUN RAY04040 C**** RAY04050 IN = 1 RAY04060 XC = RB RAY04070 ZC = 0.0 RAY04080 C**** RAY04090 C0 = DATA( 29,NO ) RAY04100 C1 = DATA( 30,NO ) RAY04110 C2 = DATA( 31,NO ) RAY04120 C3 = DATA( 32,NO ) RAY04130 C4 = DATA( 33,NO ) RAY04140 C5 = DATA( 34,NO ) RAY04150 IF( NP .LE. 100) PRINT 104 RAY04270 104 FORMAT( 22H0FRINGING FIELD REGION ) RAY04280 CALL FNMIRK( 6, T, DTF1,TC, DTC, DS, ES, EDIP, 0 ) RAY04290 NSTEP = 0 RAY04300 6 CALL PRNT5 ( T,S,TC(1),TC(2),TC(3),EX,EY,EZ,ET,TC(4),TC(5),TC(6) )RAY04310 DO 7 I = 1, NP RAY04320 CALL FNMIRK( 6, T, DTF1,TC, DTC, DS, ES, EDIP, 1 ) RAY04330 NSTEP = NSTEP + 1 RAY04340 NUM = NUM+1 TPAR = T*VEL NBR = 2 CALL PLT1 ( NUM, NO, NBR, TPAR ) IF (NSTEP .GT. 10000) GO TO 99 RAY04341 IF( Z12 .GE. TC(3) ) GO TO 8 RAY04350 7 CONTINUE RAY04360 GO TO 6 RAY04370 8 CONTINUE RAY04380 XDTF1 =-( Z12 - TC(3) ) /DABS( TC(6) ) RAY04390 CALL FNMIRK( 6, T,XDTF1,TC, DTC, DS, ES, EDIP, 0 ) RAY04400 CALL FNMIRK( 6, T,XDTF1,TC, DTC, DS, ES, EDIP, 1 ) RAY04410 CALL PRNT5 ( T,S,TC(1),TC(2),TC(3),EX,EY,EZ,ET,TC(4),TC(5),TC(6) )RAY04420 NUM = NUM + 1 TPAR = T*VEL NBR = 2 CALL PLT1 ( NUM, NO, NBR, TPAR ) IF( NP .LE. 100) PRINT 105, NSTEP RAY04430 105 FORMAT( 10H NSTEPS= I5 ) RAY04440 XSTC1 = TC(1) !JDL 25-MAY-84 C*** RAY04450 C*** UNIFORM FIELD REGION RAY04460 C**** TRANSFORM TO SECOND EFB COORD SYSTEM RAY04470 C*** RAY04480 COPAB =DCOS( (PHI)/57.29578) RAY04490 SIPAB =DSIN( (PHI)/57.29578) RAY04500 COSPB =DCOS( (PHI/2.)/57.29578 ) RAY04510 SINPB =DSIN( (PHI/2.)/57.29578 ) RAY04520 SIP2 =DSIN( (PHI/2.)/57.29578 ) RAY04530 XT = TC(1) RAY04540 ZT = TC(3) RAY04550 VXT = TC(4) RAY04560 VZT = TC(6) RAY04570 TC(3) = - ZT *COPAB + XT *SIPAB -2.*RB*SIP2*COSPB RAY04580 TC(1) = - ZT *SIPAB - XT *COPAB -2.*RB*SIP2*SINPB RAY04590 TC(6) = - VZT *COPAB + VXT *SIPAB RAY04600 TC(4) = - VZT *SIPAB - VXT *COPAB RAY04610 C**** RAY04620 C**** RAY04630 C**** UNIFORM FIELD INTEGRATION REGION RAY04640 C**** RAY04650 C**** RAY04660 IN = 2 RAY04670 XC = -RB RAY04680 ZC = 0.0 RAY04690 IF( NP .LE. 100) PRINT 106 RAY04700 106 FORMAT( '0UNIFORM FIELD REGION IN C AXIS SYSTEM ' ) RAY04710 IF( TC(3) .LT. Z21 ) GO TO 15 RAY04720 C**** RAY04730 C**** THIS SECTION CORRECTS FOR MAGNETS WHOSE FRINGING FIELDS INTERSECT RAY04740 C**** RAY04750 IF( NP .LE. 100) PRINT 102 RAY04760 102 FORMAT( / ' INTEGRATE BACKWARDS ' ) RAY04770 CALL FNMIRK( 6, T,-DTU ,TC, DTC, DS, ES, EDIP, 0 ) RAY04780 NSTEP = 0 RAY04790 16 CALL PRNT5 ( T,S,TC(1),TC(2),TC(3),EX,EY,EZ,ET,TC(4),TC(5),TC(6) )RAY04800 DO 17 I =1, NP RAY04810 CALL FNMIRK( 6, T,-DTU, TC, DTC, DS, ES, EDIP, 1 ) RAY04820 NSTEP = NSTEP + 1 RAY04830 NUM = NUM+1 TPAR = T*VEL NBR = 3 CALL PLT1 ( NUM, NO, NBR, TPAR ) IF (NSTEP .GT. 10000) GO TO 99 RAY04831 IF( TC(3) .LE. Z21 ) GO TO 18 RAY04840 17 CONTINUE RAY04850 GO TO 16 RAY04860 18 CONTINUE RAY04870 XDTU = ( Z21 - TC(3) ) /DABS( TC(6) ) RAY04880 CALL FNMIRK( 6, T,XDTU ,TC, DTC, DS, ES, EDIP, 0 ) RAY04890 CALL FNMIRK( 6, T,XDTU ,TC, DTC, DS, ES, EDIP, 1 ) RAY04900 CALL PRNT5 ( T,S,TC(1),TC(2),TC(3),EX,EY,EZ,ET,TC(4),TC(5),TC(6) )RAY04910 NUM = NUM+1 TPAR = T*VEL NBR = 3 CALL PLT1 ( NUM, NO, NBR, TPAR ) IF( NP .LE. 100) PRINT 105, NSTEP RAY04920 IF( NP .LE. 100) PRINT 107 RAY04930 107 FORMAT( / ) RAY04940 GO TO 19 RAY04950 C**** RAY04960 C**** RAY04970 15 CONTINUE RAY04980 CALL FNMIRK( 6, T, DTU ,TC, DTC, DS, ES, EDIP, 0 ) RAY04990 NSTEP = 0 RAY05000 9 CALL PRNT5 ( T,S,TC(1),TC(2),TC(3),EX,EY,EZ,ET,TC(4),TC(5),TC(6) )RAY05010 DO 10 I =1, NP RAY05020 CALL FNMIRK( 6, T, DTU, TC, DTC, DS, ES, EDIP, 1 ) RAY05030 NSTEP = NSTEP + 1 RAY05040 NUM = NUM+1 TPAR = T*VEL NBR = 3 CALL PLT1 ( NUM, NO, NBR, TPAR ) IF (NSTEP .GT. 10000) GO TO 99 RAY05041 IF( TC(3) .GE. Z21 ) GO TO 11 RAY05050 10 CONTINUE RAY05060 GO TO 9 RAY05070 11 CONTINUE RAY05080 XDTU = ( Z21 - TC(3) ) /DABS( TC(6) ) RAY05090 CALL FNMIRK( 6, T,XDTU ,TC, DTC, DS, ES, EDIP, 0 ) RAY05100 CALL FNMIRK( 6, T,XDTU ,TC, DTC, DS, ES, EDIP, 1 ) RAY05110 CALL PRNT5 ( T,S,TC(1),TC(2),TC(3),EX,EY,EZ,ET,TC(4),TC(5),TC(6) )RAY05120 NUM = NUM+1 TPAR = T*VEL NBR = 3 CALL PLT1 ( NUM, NO, NBR, TPAR ) IF( NP .LE. 100) PRINT 105, NSTEP RAY05130 C**** !Changes from here... !JDL 25-MAY-84 C**** C**** FIND X-COORDINATES AT ENDS OF UNIFORM REGION AND INDICATE IF: C**** C**** IXS = 0, NO REGION OF UNIFORM FIELD. C**** -1, RAY OUTSIDE (MORE POSITIVE THAN +D/2). C**** +1, RAY PASSES (BETWEEN ELECTRODES). C**** -2, RAY INSIDE (MORE NEGATIVE THAN -D/2). C**** C**** IF(IXS .NE. 0) GO TO 19 IXS=1 IF(XSTC1 .GT. XS2) IXS=-1 IF(XSTC1 .LT. XS1) IXS=-2 IF(IXS .LT. 0) GO TO 19 XSTC1=TC(1) IF(XSTC1 .GT. XS2) IXS=-1 IF(XSTC1 .LT. XS1) IXS=-2 C**** !...down to here. !JDL 25-MAY-84 19 CONTINUE RAY05140 C*** RAY05150 C*** RAY05160 C**** SETUP FOR SECOND FRINGE FIELD AND INTEGRATION RAY05170 C**** RAY05180 C**** RAY05190 C0 = DATA( 35,NO ) RAY05210 C1 = DATA( 36,NO ) RAY05220 C2 = DATA( 37,NO ) RAY05230 C3 = DATA( 38,NO ) RAY05240 C4 = DATA( 39,NO ) RAY05250 C5 = DATA( 40,NO ) RAY05260 IN = 3 RAY05380 IF( NP .LE. 100) PRINT 104 RAY05390 CALL FNMIRK( 6, T, DTF2,TC, DTC, DS, ES, EDIP, 0 ) RAY05400 NSTEP = 0 RAY05410 12 CALL PRNT5 ( T,S,TC(1),TC(2),TC(3),EX,EY,EZ,ET,TC(4),TC(5),TC(6) )RAY05420 DO 13 I =1, NP RAY05430 CALL FNMIRK( 6, T, DTF2,TC, DTC, DS, ES, EDIP, 1 ) RAY05440 NSTEP = NSTEP + 1 RAY05450 NUM = NUM+1 TPAR = T*VEL NBR = 3 CALL PLT1 ( NUM, NO, NBR, TPAR ) IF (NSTEP .GT. 10000) GO TO 99 RAY05451 IF( TC(3) .GE. Z22 ) GO TO 14 RAY05460 13 CONTINUE RAY05470 GO TO 12 RAY05480 14 CONTINUE RAY05490 XDTF2 = ( Z22 - TC(3) ) /DABS( TC(6) ) RAY05500 CALL FNMIRK( 6, T,XDTF2,TC, DTC, DS, ES, EDIP, 0 ) RAY05510 CALL FNMIRK( 6, T,XDTF2,TC, DTC, DS, ES, EDIP, 1 ) RAY05520 CALL PRNT5 ( T,S,TC(1),TC(2),TC(3),EX,EY,EZ,ET,TC(4),TC(5),TC(6) )RAY05530 NUM = NUM+1 TPAR = T*VEL NBR = 3 CALL PLT1 ( NUM, NO, NBR, TPAR ) IF( NP .LE. 100) PRINT 105, NSTEP RAY05540 C**** RAY05550 C**** TRANSFORM TO OUTPUT SYSTEM COORD. RAY05560 C**** RAY05570 XT = TC(1) RAY05600 ZT = TC(3) RAY05610 VXT = TC(4) RAY05620 VZT = TC(6) RAY05630 TC(3) = ZT - B RAY05640 TC(1) = XT RAY05650 TC(6) = VZT RAY05660 TC(4) = VXT RAY05670 IF( NP .LE. 100) PRINT 109 RAY05680 CALL PRNT5 ( T,S,TC(1),TC(2),TC(3),EX,EY,EZ,ET,TC(4),TC(5),TC(6) )RAY05690 C**** RAY05700 C**** TRANSLATE PARTICLE TO OUT SYSTEM COORD. RAY05710 C**** RAY05720 C**** RAY05960 C**** RAY05970 C**** RAY05980 30 TDT = -TC(3) /DABS( TC(6) ) RAY05990 TC(1) = TC(1) + TDT * TC(4) RAY06000 TC(2) = TC(2) + TDT * TC(5) RAY06010 TC(3) = TC(3) + TDT * TC(6) RAY06020 T = T + TDT RAY06030 TP = T * VEL RAY06040 EX = 0. RAY06050 EY = 0. RAY06060 EZ = 0. RAY06070 ET = 0. RAY06080 S = 0. RAY06090 VXF = 1000. *DATAN2( TC(4), TC(6) ) RAY06100 VYF = 1000. *DASIN ( TC(5)/ VEL ) RAY06110 VZF = TC(6) / VEL RAY06120 IF( NP .LE. 100) PRINT 115,TP,TC(1),TC(2),TC(3),VZF,VXF,VYF RAY06130 115 FORMAT( F10.4, 10X, F10.3, 11X, F10.3, 11X, F10.3, 11X, RAY06140 1 F13.5, F13.2, F11.2 ) RAY06150 NUM = NUM+1 TPAR = T*VEL NBR = 4 CALL PLT1 ( NUM, NO, NBR, TPAR ) C**** RAY06160 C**** CALCULATE INTERCEPTS IN SYSTEM D RAY06170 C**** RAY06180 Z0X = -TC(1)/ ( TC(4) / TC(6) + 1.E-10 ) RAY06190 Z0Y = -TC(2)/ ( TC(5) / TC(6) + 1.E-10 ) RAY06200 IF( NP .LE. 100) PRINT 111, VXF, VYF, Z0X, Z0Y RAY06210 111 FORMAT( / ' INTERSECTIONS WITH VER. AND HOR. PLANES ' , RAY06220 X /15X, 5H XP=F10.4, 10H MR YP= F10.4, 3H MR / RAY06230 1 15X, 5H Z0X=F10.2, 10H CM Z0Y= F10.2, 3H CM / )RAY06240 RETURN RAY06250 99 CALL PRNT4(NO, IN) RAY06251 RETURN RAY06252 END RAY06260 SUBROUTINE EDPP( EFLD, Z, X, Y, DRP ) C**** C**** CALCULATE S; DETERMINE E-FIELD IN FRINGE REGIONS C**** IMPLICIT REAL*8(A-H,O-Z) REAL*8 K COMMON /BLCK20/ EC2, EC4, WE, WC COMMON /BLCK22/ D, DG, S, EF, ET RAY03020 COMMON /BLCK23/ C0, C1, C2, C3, C4, C5 RAY03030 COMMON /BLCK24/ RB, XC, ZC RAY03040 COMMON /BLCK25/ IN, MTYP RAY03050 FEF = -EF IF ( IN .EQ. 1 ) FEF = +EF W2 = WE * WE ZD1 = Z / D ZD2 = EC2 * ZD1 * Y * Y / W2 W4 = W2 * W2 ZD3 = EC4 * (Y**4) / W4 S = ZD1 + ZD2 + ZD3 CS = C0 + S * (C1 + S * (C2 + (S * (C3 + S * (C4 +S * C5))))) IF (DABS(CS) .GT. 70.) CS = DSIGN(70.D0, CS) E = DEXP(CS) P0 = 1.0 + E EFLD = (FEF / P0) * (RB / DRP) RETURN END SUBROUTINE FB01AD(C, VK,VE) RAY27240 IMPLICIT REAL*8(A-H,O-Z) RAY27250 C*IBM REAL*8 XLG/ Z7FFFFFFFFFFFFFFF / RAY27251 REAL * 8 XLG/'7FFFFFFFFFFFFFFF'X/ RAY27260 D=1D0-C RAY27270 IF(D .GT. 0D0)E=-DLOG(D) RAY27280 C**** HARWELL VERSION OF FB01AD RAY27290 IF(C .GE. 1D0)GO TO 2 RAY27300 VE=E*(((((((((( RAY27310 A 3.18591956555015718D-5*D +.989833284622538479D-3)*D RAY27320 B +.643214658643830177D-2)*D +.16804023346363385D-1)*D RAY27330 C +.261450147003138789D-1)*D +.334789436657616262D-1)*D RAY27340 D +.427178905473830956D-1)*D +.585936612555314917D-1)*D RAY27350 E +.937499997212031407D-1)*D +.249999999999901772D0)*D) RAY27360 F +((((((((( RAY27370 G .149466217571813268D-3*D +.246850333046072273D-2)*D RAY27380 H +.863844217360407443D-2)*D+.107706350398664555D-1)*D RAY27390 I +.782040406095955417D-2)*D +.759509342255943228D-2)*D RAY27400 J +.115695957452954022D-1)*D +.218318116761304816D-1)*D RAY27410 K +.568051945675591566D-1)*D +.443147180560889526D0)*D RAY27420 L +1D0 RAY27430 C**** RAY27440 C**** ROUTINE MODIFIED TO CALCULATE VK AND VE ALWAYS RAY27450 C**** RAY27460 C**** RAY27470 VK=E*(((((((((( RAY27480 A .297002809665556121D-4*D +.921554634963249846D-3)*D RAY27490 B +.597390429915542916D-2)*D +.155309416319772039D-1)*D RAY27500 C +.239319133231107901D-1)*D +.301248490128989303D-1)*D RAY27510 D +.373777397586236041D-1)*D +.48828041906862398D-1)*D RAY27520 E +.703124997390383521D-1)*D +.124999999999908081D0)*D RAY27530 F +.5D0)+((((((((( RAY27540 G .139308785700664673D-3*D +.229663489839695869D-2)*D RAY27550 H +.800300398064998537D-2)*D +.984892932217689377D-2)*D RAY27560 I +.684790928262450512D-2)*D +.617962744605331761D-2)*D RAY27570 J +.878980187455506468D-2)*D +.149380135326871652D-1)*D RAY27580 K +.308851462713051899D-1)*D +.965735902808562554D-1)*D RAY27590 L +1.38629436111989062D0 RAY27600 RETURN RAY27610 2 VE=1D0 RAY27620 VK=XLG RAY27630 RETURN RAY27640 END RAY27650 SUBROUTINE FB02AD(CAYSQ,SINP,COSP,E,F) RAY27660 C RAY27670 IMPLICITREAL*8(A-H,O-Z) RAY27680 PHI=DATAN(SINP/COSP) RAY27690 IF(CAYSQ*SINP*SINP-0.5D0)1,1,5 RAY27700 1 H=1.0D0 RAY27710 A=PHI RAY27720 N=0 RAY27730 SIG1=0.D0 RAY27740 SIG2=0.D0 RAY27750 SIN2=SINP*SINP RAY27760 TERM=SINP*COSP*0.5D0 RAY27770 CRIT=PHI RAY27780 2 N=N+1 RAY27790 RECIP=1.0D0/N RAY27800 FACT=(N-.5D0)*RECIP RAY27810 H1=H RAY27820 H=FACT*CAYSQ*H RAY27830 A=FACT*A-TERM*RECIP RAY27840 TERM=TERM*SIN2 RAY27850 CRIT=CRIT*SIN2 RAY27860 DEL1=H*A RAY27870 DEL2=-.5D0*RECIP*CAYSQ*H1*A RAY27880 SIG1=SIG1+DEL1 RAY27890 SIG2=SIG2+DEL2 RAY27900 IF(DABS(DEL1)-4.0D-16)4,3,3 RAY27910 3 IF(DABS(CRIT)-DABS(A))4,2,2 RAY27920 4 F=PHI+SIG1 RAY27930 E=PHI+SIG2 RAY27940 GO TO 8 RAY27950 5 CFI=1.D0 RAY27960 CFJ=1.D0 RAY27970 CFL=0.D0 RAY27980 CFM=0.D0 RAY27990 CFN=0.D0 RAY28000 SIG1=0.D0 RAY28010 SIG2=0.D0 RAY28020 SIG3=0.D0 RAY28030 SIG4=0.D0 RAY28040 N=0 RAY28050 FACT1=1.0D0-CAYSQ*SINP*SINP RAY28060 FACTOR=.5D0*COSP*DSQRT(CAYSQ/FACT1) RAY28070 FACTRO=FACTOR+FACTOR RAY28080 CAYDSQ=1.0D0-CAYSQ RAY28090 6 N=N+1 RAY28100 RECIP=1.0D0/N RAY28110 FACTN=RECIP*(N-.5D0) RAY28120 FACTM=(N+.5D0)/(N+1.0D0) RAY28130 FACTOR=FACTOR*FACT1 RAY28140 CFI1=CFI RAY28150 CFJ1=CFJ RAY28160 CFI=CFI*FACTN RAY28170 CFJ=CFJ*FACTN*FACTN*CAYDSQ RAY28180 CFL=CFL+.5D0/(N*(N-.5D0)) RAY28190 CFM=(CFM-FACTOR*RECIP*CFI)*FACTM*FACTM*CAYDSQ RAY28200 CFN=(CFN-FACTOR*RECIP*CFI1)*FACTN*FACTM*CAYDSQ RAY28210 DEL1=CFM-CFJ*CFL RAY28220 DEL2=CFN-(FACTN*CFL-.25D0*RECIP*RECIP)*CAYDSQ *CFJ1 RAY28230 DEL3=CFJ RAY28240 DEL4=FACTM*CFJ RAY28250 SIG1=SIG1+DEL1 RAY28260 SIG2=SIG2+DEL2 RAY28270 SIG3=SIG3+DEL3 RAY28280 SIG4=SIG4+DEL4 RAY28290 IF(DABS (DEL1)-4.0D-16)7,6,6 RAY28300 7 CAYMOD=DSQRT(CAYSQ) RAY28310 FLOG1=DLOG(4.0D0/(DSQRT(FACT1)+CAYMOD*COSP)) RAY28320 T1=(1.0D0+SIG3)*FLOG1+FACTRO*DLOG(.5D0+.5D0*CAYMOD*DABS (SINP)) RAY28330 T2=(.5D0+SIG4)*CAYDSQ*FLOG1+1.0D0-FACTRO*(1.0D0-CAYMOD*DABS(SINP))RAY28340 F=T1+SIG1 RAY28350 E=T2+SIG2 RAY28360 8 RETURN RAY28370 END RAY28380 SUBROUTINE FB03AD( GN,CACA,P ) RAY28390 C====== 23/03/72 LAST LIBRARY UPDATE RAY28400 IMPLICITREAL*8(A-H,O-Z) RAY28410 IF(GN)1,2,2 RAY28420 1 IF(CACA)3,3,4 RAY28430 3 P=1.5707963268/DSQRT(1.D0-GN) RAY28440 RETURN RAY28450 4 STH=DSQRT(-GN/(CACA-GN)) RAY28460 CTH=DSQRT(1.D0-STH*STH) RAY28470 CADA=1.D0-CACA RAY28480 CALLFB01AD(CACA, CAPK,CAPE) RAY28490 CALLFB02AD(CADA,STH,CTH,E,F) RAY28500 BR=CAPE*F-CAPK*(F-E) RAY28510 P=CAPK*CTH*CTH+STH*BR/DSQRT(1.D0-GN) RAY28520 RETURN RAY28530 2 IF(GN-CACA)10,30,20 RAY28540 10 STH=DSQRT(GN/CACA) RAY28550 CTH=DSQRT(1.D0-STH*STH) RAY28560 CALLFB01AD(CACA, CAPK,CAPE) RAY28570 CALLFB02AD(CACA,STH,CTH,E,F) RAY28580 BR=CAPK*E-CAPE*F RAY28590 P=CAPK+BR*STH/(CTH*DSQRT(1.D0-GN)) RAY28600 RETURN RAY28610 30 CALLFB01AD(CACA, CAPK,CAPE) RAY28620 P=CAPE/(1.D0-CACA) RAY28630 RETURN RAY28640 20 CADA=1.D0-CACA RAY28650 PI=3.1415926536 RAY28660 STH=DSQRT((1.D0-GN)/CADA) RAY28670 CTH=DSQRT(1.D0-STH*STH) RAY28680 CALLFB01AD(CACA, CAPK,CAPE) RAY28690 CALLFB02AD(CADA,STH,CTH,E,F) RAY28700 BR=PI/2.+CAPK*(F-E)-CAPE*F RAY28710 P=CAPK+BR*DSQRT(GN)/(CADA*STH*CTH) RAY28720 RETURN RAY28730 END RAY28740 FUNCTION FDEDX( QION ) IMPLICIT REAL*8(A-H,O-Z) REAL*4 stop,IZ,IM,IEIN,IZTGT RAYANL01 DIMENSION SC(92) RAYANL02 COMMON /SHELLC/SC RAYANL03 COMMON /BLCK60/ GAS,AGAS,ZGAS,ZION,PRESS,GASSIG,QAVER, !***MP 1-JAN-85 1 QFWHM,RHOGAS,GASK,EMASS,GASMFP,JRAY,Q00,NPASG !*** COMMON /BLCK 4/ ENERGY, VEL, PMASS, Q0 RAY00140 COMMON /BLCK61/ DEDX,ALPHAK,TOLD2,DEDXQ COMMON /BLCK62/ GASENE,GASVEL,TOLD,GASL COMMON /BLCK63/ ISEED include 'rtcomm65.f' DATA VEL1/0./,DEDX2/1./,C/3.D10/,PROTM/938.211/ C C**** C**** C CALL SHLLCO RAYANL05 C C FDEDX IN MEV/(MG/CM2) C C IZ = ZION IM = PMASS IEIN = GASENE IZTGT = ZGAS FDEDX = STOP(IZ,IM,IZTGT,IEIN) RAYANL06 RETURN END C**************************************************** C TO ADD ENELOSS.FOR;3 BY WFH JULY 26/1985 * RAYANL00 C**************************************************** C SUBROUTINE FNMIRK(N,X,DT,Y,DY,D,E,BFUN, NDEX) RAY38280 IMPLICIT REAL*8(A-H,O-Z) RAY38290 EXTERNAL BFUN RAY38300 COMMON /BLCK60/ GAS,AGAS,ZGAS,ZION,PRESS,GASSIG,QAVER, !***MP 1-JAN-85 1 QFWHM,RHOGAS,GASK,EMASS,GASMFP,JRAY,Q00,NPASG !*** COMMON /BLCK63/ ISEED COMMON /BLCK66/ tfwopt,taufct,alffct,TBAR,THWHM,tau0 DIMENSION Y(6),DY(6),D(6),E(6) RAY38310 DIMENSION VTMP(3) real tprevb, tnextb, tfactor ! BSK 11/24/91 parameter (tfactor=0.33) DATA PI2/6.28318/ IQSW = 0 5 H = DT IQSW = 0 IF( NDEX.NE.0) GO TO 20 RAY38320 DO 10 I=1,N RAY38330 D(I)=Y(I) RAY38340 10 CONTINUE RAY38350 CALL DERIV ( BFUN,X,1 ) RAY38360 HALFH=0.5*H RAY38370 tnextb = x+tfactor*dt tprevb = x-tfactor*dt RETURN RAY38380 20 IF (JRAY*GAS.EQ.0.) GO TO 25 c IF (DT.LE.0.) GO TO 25 ! negative is ok for discol BSK CALL DISCOL(DT,H,IQSW) HALFH = 0.5*H 25 CONTINUE DO 30 I=1,N RAY38390 T=HALFH*DY(I) RAY38400 Y(I)=D(I)+T RAY38410 E(I)=T RAY38420 30 CONTINUE RAY38430 XZERO=X RAY38440 X=X+HALFH RAY38450 if (x.le.tprevb .or. x.ge.tnextb) then tprevb=x-dt*tfactor tnextb=x+dt*tfactor call deriv( bfun,x,1 ) else CALL DERIV ( BFUN,X,0 ) RAY38460 endif DO 40 I=1,N RAY38470 T=HALFH*DY(I) RAY38480 Y(I)=D(I)+T RAY38490 E(I)=E(I)+2.0*T RAY38500 40 CONTINUE RAY38510 if (x.le.tprevb .or. x.ge.tnextb) then tprevb=x-dt*tfactor tnextb=x+dt*tfactor call deriv( bfun,x,1 ) else CALL DERIV ( BFUN,X,0 ) RAY38520 endif DO 50 I=1,N RAY38530 T=H*DY(I) RAY38540 Y(I)=D(I)+T RAY38550 E(I)=E(I)+T RAY38560 50 CONTINUE RAY38570 X=XZERO+H RAY38580 if (x.le.tprevb .or. x.ge.tnextb) then tprevb=x-dt*tfactor tnextb=x+dt*tfactor call deriv( bfun,x,1 ) else CALL DERIV ( BFUN,X,0 ) RAY38590 endif DO 60 I=1,N RAY38600 Y(I)=D(I)+(E(I)+HALFH*DY(I))*.333333333 RAY38610 D(I)=Y(I) RAY38620 60 CONTINUE RAY38630 if (x.le.tprevb .or. x.ge.tnextb) then tprevb=x-dt*tfactor tnextb=x+dt*tfactor call deriv( bfun,x,1 ) else CALL DERIV ( BFUN,X,0 ) endif IF ( JRAY*GAS*IQSW*DT.LE.0. ) RETURN CALL GASINT DTETA = (TBAR + THWHM * RANDOM(1,ISEED)) DPSI = (TBAR + THWHM * RANDOM(1,ISEED)) DPHI = (TBAR + THWHM * RANDOM(1,ISEED)) VTMP(1) = Y(4) + (DPHI-DPSI)*Y(5) + DTETA*Y(6) VTMP(2) = Y(5) + (DPSI-DPHI)*Y(4) VTMP(3) = Y(6) - DTETA*Y(4) DO 100 J=1,3 Y(3+J) = VTMP(J) D(3+J) = VTMP(J) DY(J) = VTMP(J) 100 CONTINUE RETURN RAY38650 END RAY38660 FUNCTION FSDEDX( ztgt,atgt ) IMPLICIT REAL*8(A-H,O-Z) REAL*4 stops,IZ,IM,IEIN,IZTGT,iatgt !MP 29-jul-93 DIMENSION SC(92) RAYANL02 COMMON /SHELLC/SC RAYANL03 COMMON /BLCK60/ GAS,AGAS,ZGAS,ZION,PRESS,GASSIG,QAVER, !***MP 1-JAN-85 1 QFWHM,RHOGAS,GASK,EMASS,GASMFP,JRAY,Q00,NPASG !*** COMMON /BLCK 4/ ENERGY, VEL, PMASS, Q0 RAY00140 COMMON /BLCK61/ DEDX,ALPHAK,TOLD2,DEDXQ COMMON /BLCK62/ GASENE,GASVEL,TOLD,GASL COMMON /BLCK63/ ISEED include 'rtcomm65.f' DATA VEL1/0./,DEDX2/1./,C/3.D10/,PROTM/938.211/ C C**** C**** C CALL SHLLCO RAYANL05 C C FSDEDX IN MEV/(MG/CM2) C C IZ = ZION IM = PMASS IEIN = energy IZTGT = ztgt iatgt = atgt !MP 29-jul-93 FSDEDX = STOPS(IZ,IM,IZTGT,iatgt,IEIN) !MP 29-jul-93 RETURN END C**************************************************** C TO ADD ENELOSS.FOR;3 BY WFH JULY 26/1985 * RAYANL00 C**************************************************** C FUNCTION fwhmstg( ztgt,atgt,ttgt,zion ) IMPLICIT REAL*8(A-H,O-Z) fw = dsqrt((ztgt/atgt)*ttgt)*zion*0.924d-3 fwhmstg = fw RETURN END SUBROUTINE GASINT IMPLICIT REAL*8(A-H,O-Z) REAL*8 K COMMON /BLCK 4/ ENERGY, VEL, PMASS, Q0 RAY00140 COMMON /BLCK10/ BX, BY, BZ, K, TC, DTC RAY00180 COMMON /BLCK11/ EX, EY, EZ, QMC, IVEC RAY00190 COMMON /BLCK60/ GAS,AGAS,ZGAS,ZION,PRESS,GASSIG,QAVER, !***MP 1-JAN-85 1 QFWHM,RHOGAS,GASK,EMASS,GASMFP,JRAY,Q00,NPASG !*** COMMON /BLCK61/ DEDX,ALPHAK,TOLD2,DEDXQ COMMON /BLCK62/ GASENE,GASVEL,TOLD,GASL COMMON /BLCK63/ ISEED include 'rtcomm65.f' COMMON /BLCK66/ tfwopt,taufct,alffct,TBAR,THWHM,tau0 common /blck71/ gasopt,zgas125,zgas18,dreldee,enold,icalc data drel0,dee0/0.05,0.005/ C*** THERE WAS A CHARGE CHANGE DECISION CALL QCG (Q0,Q1) Q0 = Q1 QMC = EMASS / (9.D10*Q0 ) ETOT = EMASS+GASENE K = (Q0/ETOT)*9.D10 C***** C***** C***** c c Capture cross sections and charge state distribution are updated c whenever the relative change in cross section is larger than drel0. c Relative change in cross section is calculated from Schlachter et al. c scaling law. See subroutine sigcap for Ref. c c Calculate now relative change in cross sections. dee = (enold - gasene)/enold drel = dabs(dreldee*dee) c c 29 october 1991 : c Modify criterion for updating de/dx. qdist, sigcap c Following statement was corrected on 8-jul-82 according to c Bernhard Schneck's comment c if (dee.lt.dee0.and.drel.le.drel0) go to 100 c c Update gassig,acapt,qbar,delsqr,small ang. scat.,dedx CALL QDIST if ( gasopt.le.0.and.drel.ge.drel0) call sigcap DQ = Q0 - QBAR CALL QSIG(DQ) if ( tfwopt.lt.0.) call smangsc dedx = fdedx(q0) dedxq = dedx*(q0/qbar)**2 enold = gasene c NSK1 = 0 RETURN c C **CALCULATE NEW SIGC,SIGL,SIGT for charge state Q0=Q1 c 100 DQ = Q0 - QBAR CALL QSIG(DQ) dedxq = dedx*(q0/qbar)**2 RETURN END FUNCTION IRND(X) C C*********************************** C IS=-1 IF(X.GE.0.) IS=1 H=ABS(X) I=IFIX(H) IF((H-FLOAT(I)).GE.0.5) I=I+1 IRND=IS*I RETURN END C C****************************************************** C SUBROUTINE LENS ( NO, NP,T, TP ,NUM ) RAY23740 C**** RAY23750 C**** RAY23760 C**** THIN LENS ROUTINE RAY23770 C**** RAY23780 C**** RAY23790 IMPLICIT REAL*8(A-H,O-Z) RAY23800 c REAL*4 DAET, TYME !JDL 31-OCT-84 include 'rtcomm0.f' COMMON /BLCK 4/ ENERGY, VEL, PMASS, Q0 RAY23820 COMMON /BLCK 5/ XA, YA, ZA, VXA, VYA, VZA RAY23830 C*JDL DIMENSION DATA( 75,30 ), ITITLE(30) !JDL 17-NOV-83 RAY23840 C**** DATA C/ 3.D10/ RAY23850 C**** RAY23860 100 FORMAT( / ' THIN LENS **** ', A4, '****************',// RAY23870 1' T CM', 18X, 'X CM', 7X, 'Y CM', 7X, 'Z CM' , ' VELZ/C'RAY23880 2 , ' THETA MR PHI MR' / ) RAY23890 103 FORMAT( F10.4, 11X, 3F11.3, F12.5, 2F12.3 ) RAY23900 C**** RAY23910 NUM = NUM+1 TPAR = T*VEL NBR = 1 CALL PLT2 ( NUM, NO, NBR, TPAR ) IF( NP .LE. 100) PRINT 100, ITITLE(NO) RAY23920 VXP = 1000. *DATAN2( VXA,VZA ) RAY23930 VYP = 1000. *DASIN ( VYA/VEL ) RAY23940 VZP = VZA / VEL RAY23950 TP = T*VEL RAY23960 IF( NP .LE. 100) PRINT 103, TP, XA, YA, ZA, VZP, VXP, VYP RAY23970 XXA = XA RAY23980 YYA = YA RAY23990 XA =XXA*DATA(1,NO) + VXP*DATA(2,NO) RAY24000 VXP =XXA*DATA(3,NO) + VXP*DATA(4,NO) RAY24010 YA =YYA*DATA(5,NO) + VYP*DATA(6,NO) RAY24020 VYP =YYA*DATA(7,NO) + VYP*DATA(8,NO) RAY24030 VXA = VEL*DSIN( VXP/1000.D0 ) RAY24040 VYA = VEL*DSIN( VYP/1000.D0 ) RAY24050 VZA = DSQRT(VEL*VEL -VXA*VXA-VYA*VYA) RAY24060 VZP = VZA/VEL RAY24070 IF( NP .LE. 100) PRINT 103, TP, XA, YA, ZA, VZP, VXP, VYP RAY24080 NUM = NUM+1 TPAR = T*VEL NBR = 2 CALL PLT2 ( NUM, NO, NBR, TPAR ) RETURN RAY24090 END RAY24100 SUBROUTINE MATRIX( R, T2 ) RAY33300 C**** RAY33310 C**** RAY33320 C**** RAY33330 IMPLICIT REAL*8(A-H,O-Z) RAY33340 COMMON /BLCK 1/ XI, YI, ZI, VXI, VYI, VZI, DELP, DELM !JDL RAY33350 COMMON /BLCK 2/ XO, YO, ZO, VXO, VYO, VZO, RTL(100), RLL(100) RAY33360 DIMENSION XI(100), YI(100), ZI(100), VXI(100), VYI(100), VZI(100),RAY33370 1 DELP(100) RAY33380 DIMENSION XO(100), YO(100), ZO(100), VXO(100), VYO(100), VZO(100) RAY33390 DIMENSION R(6,6) , T2(5,6,6), TT(5,6,6) RAY33400 DO 21 I1= 1,6 RAY33410 DO 21 I2= 1,6 RAY33420 R(I1,I2) = 0. RAY33430 DO 21 I3= 1,5 RAY33440 21 T2(I3,I1,I2) = 0. RAY33450 C**** RAY33460 C**** RAY33470 C**** CALCULATE COEFFICIENTS RAY33480 C**** RAY33490 R(1,1) = ( XO(3) - XO(4) ) / ( XI(3) - XI(4) ) RAY33500 R(1,2) = ( XO(5) - XO(6) ) / (VXI(5) - VXI(6) ) RAY33510 R(1,3) = ( XO(7) - XO(8) ) / ( YI(7) - YI(8) ) RAY33520 R(1,4) = ( XO(9) - XO(10)) / (VYI(9) - VYI(10)) RAY33530 R(1,6) = ( XO(11)- XO(12) )/ (DELP(11) - DELP(12) ) RAY33540 R(2,1) = (VXO(3) - VXO(4) ) / ( XI(3) - XI(4) ) RAY33550 R(2,2) = (VXO(5) - VXO(6) ) / (VXI(5) - VXI(6) ) RAY33560 R(2,3) = (VXO(7) - VXO(8) ) / ( YI(7) - YI(8) ) RAY33570 R(2,4) = (VXO(9) - VXO(10)) / (VYI(9) - VYI(10)) RAY33580 R(2,6) = (VXO(11)- VXO(12) )/ (DELP(11) - DELP(12) ) RAY33590 R(3,1) = ( YO(3) - YO(4) ) / ( XI(3) - XI(4) ) RAY33600 R(3,2) = ( YO(5) - YO(6) ) / (VXI(5) - VXI(6) ) RAY33610 R(3,3) = ( YO(7) - YO(8) ) / ( YI(7) - YI(8) ) RAY33620 R(3,4) = ( YO(9) - YO(10)) / (VYI(9) - VYI(10)) RAY33630 R(3,6) = ( YO(11)- YO(12) )/ (DELP(11) - DELP(12) ) RAY33640 R(4,1) = (VYO(3) - VYO(4) ) / ( XI(3) - XI(4) ) RAY33650 R(4,2) = (VYO(5) - VYO(6) ) / (VXI(5) - VXI(6) ) RAY33660 R(4,3) = (VYO(7) - VYO(8) ) / ( YI(7) - YI(8) ) RAY33670 R(4,4) = (VYO(9) - VYO(10)) / (VYI(9) - VYI(10)) RAY33680 R(4,6) = (VYO(11)- VYO(12) )/ (DELP(11) - DELP(12) ) RAY33690 R( 5,5 ) = 1. RAY33700 R( 6,6 ) = 1. RAY33710 R(5,1) = (RTL(3) - RTL(4) ) / ( XI(3) - XI(4) ) RAY33720 R(5,2) = (RTL(5) - RTL(6) ) / (VXI(5) - VXI(6) ) RAY33730 R(5,6) = (RTL(11)- RTL(12) )/ (DELP(11) - DELP(12) ) RAY33740 C**** RAY33750 C**** RAY33760 T2(1,1,1)= ( XO(3) + XO(4) ) /(2.*XI(3)**2 ) RAY33770 T2(1,2,2)= ( XO(5) + XO(6) ) /(2.*VXI(5)**2) RAY33780 T2(1,3,3)= ( XO(7) + XO(8) ) /(2.*YI(7)**2 ) RAY33790 T2(1,4,4)= ( XO(9) + XO(10) ) /(2.*VYI(9)**2 ) RAY33800 T2(1,6,6)= ( XO(11) + XO(12) ) /(2.*DELP(11)**2 ) RAY33810 T2(1,1,2)= ( XO(13)+XO(14)-2.*T2(1,1,1)*XI(13)**2-2.*T2(1,2,2)* RAY33820 1 VXI(13)**2 ) /(2.*XI(13)*VXI(13) ) RAY33830 T2(1,1,6)= ( XO(15) + XO(16) -2.*T2(1,1,1)*XI(15)**2 - RAY33840 1 2.*T2(1,6,6)*DELP(15)**2 ) /(2.*XI(15)*DELP(15) ) RAY33850 T2(1,2,6)= ( XO(17) + XO(18) -2.*T2(1,2,2)*VXI(17)**2 - RAY33860 1 2.*T2(1,6,6)*DELP(17)**2 ) /(2.*VXI(17)*DELP(17) ) RAY33870 T2(1,3,4)= ( XO(19)- XO(20) ) /(2.*YI(19)*VYI(19) ) RAY33880 T2(2,1,1)= (VXO(3) +VXO(4) ) /(2.*XI(3)**2 ) RAY33890 T2(2,2,2)= (VXO(5) +VXO(6) ) /(2.*VXI(5)**2) RAY33900 T2(2,3,3)= (VXO(7) +VXO(8) ) /(2.*YI(7)**2 ) RAY33910 T2(2,4,4)= (VXO(9) +VXO(10) ) /(2.*VYI(9)**2 ) RAY33920 T2(2,6,6)= (VXO(11) +VXO(12) ) /(2.*DELP(11)**2 ) RAY33930 T2(2,1,2)=(VXO(13)+VXO(14)-2.*T2(2,1,1)*XI(13)**2-2.*T2(2,2,2)* RAY33940 1 VXI(13)**2 ) /(2.*XI(13)*VXI(13) ) RAY33950 T2(2,1,6)= (VXO(15) +VXO(16) -2.*T2(2,1,1)*XI(15)**2 - RAY33960 1 2.*T2(2,6,6)*DELP(15)**2 ) /(2.*XI(15)*DELP(15) ) RAY33970 T2(2,2,6)= (VXO(17) +VXO(18) -2.*T2(2,2,2)*VXI(17)**2 - RAY33980 1 2.*T2(2,6,6)*DELP(17)**2 ) /(2.*VXI(17)*DELP(17) ) RAY33990 T2(2,3,4)= (VXO(19)-VXO(20) ) /(2.*YI(19)*VYI(19) ) RAY34000 T2(3,1,3)= ( YO(21) - YO(22) ) /(2.*XI(21)*YI(21) ) RAY34010 T2(3,1,4)= ( YO(23) - YO(24) ) /(2.*XI(23)*VYI(23) ) RAY34020 T2(3,2,3)= ( YO(25) - YO(26) ) /(2. *VXI(25)*YI(25) ) RAY34030 T2(3,2,4)= ( YO(27) - YO(28) ) /(2.*VXI(27)*VYI(27) ) RAY34040 T2(3,3,6)= ( YO(29) - YO(30) ) /(2.*YI(29)*DELP(29) ) RAY34050 T2(3,4,6)= ( YO(31) - YO(32) ) /(2.*VYI(31)*DELP(31) ) RAY34060 T2(4,1,3)= (VYO(21) -VYO(22) ) /(2.*XI(21)*YI(21) ) RAY34070 T2(4,1,4)= (VYO(23) -VYO(24) ) /(2.*XI(23)*VYI(23) ) RAY34080 T2(4,2,3)= (VYO(25) -VYO(26) ) /(2. *VXI(25)*YI(25) ) RAY34090 T2(4,2,4)= (VYO(27) -VYO(28) ) /(2.*VXI(27)*VYI(27) ) RAY34100 T2(4,3,6)= (VYO(29) -VYO(30) ) /(2.*YI(29)*DELP(29) ) RAY34110 T2(4,4,6)= (VYO(31) -VYO(32) ) /(2.*VYI(31)*DELP(31) ) RAY34120 C**** RAY34130 C**** PATH LENGTH TERMS RAY34140 C**** RAY34150 T2(5,1,1) = ( RTL(3) + RTL(4) - 2*RTL(1) ) /( 2* XI(3)**2 ) RAY34160 T2(5,2,2) = ( RTL(5) + RTL(6) - 2*RTL(1) ) /( 2*VXI(5)**2 ) RAY34170 T2(5,3,3) = ( RTL(7) + RTL(8) - 2*RTL(1) ) /( 2* YI(7)**2 ) RAY34180 T2(5,4,4) = ( RTL(9) + RTL(10)- 2*RTL(1) ) /( 2*VYI(9)**2 ) RAY34190 T2(5,6,6) = ( RTL(11)+ RTL(12)- 2*RTL(1) ) /( 2*DELP(11)**2 ) RAY34200 T2(5,1,2) = ( RTL(13)+ RTL(14)- 2*RTL(1) - 2*T2(5,1,1)* XI(13)**2-RAY34210 1 2*T2(5,2,2)*VXI(13)**2 ) / ( 2* XI(13)*VXI(13) ) RAY34220 T2(5,1,6) = ( RTL(15)+ RTL(16)- 2*RTL(1) - 2*T2(5,1,1)* XI(15)**2-RAY34230 1 2*T2(5,6,6)*DELP(15)**2) / ( 2* XI(15)*DELP(15)) RAY34240 T2(5,2,6) = ( RTL(17)+ RTL(18)- 2*RTL(1) - 2*T2(5,2,2)*VXI(17)**2-RAY34250 1 2*T2(5,6,6)*DELP(17)**2) / ( 2*VXI(17)*DELP(17)) RAY34260 T2(5,3,4) = ( RTL(19)- RTL(20) ) /( 2* YI(19)*VYI(19) ) RAY34270 C**** RAY34280 C**** RAY34290 PRINT 22, ( ( R(IR, IJ), IJ=1,6), IR=1,6) RAY34300 22 FORMAT(1H1, / 51X, 15H *TRANSFORM* 1 , / 6(25X, 6F10.5/) ) RAY34310 PRINT 120 RAY34320 120 FORMAT( /46X, 25H *2ND ORDER TRANSFORM* ) RAY34330 DO 24 I1= 1,5 RAY34340 DO 25 I2= 1,6 RAY34350 PRINT 121, ( I1,I3,I2, T2(I1,I3,I2), I3=1,I2 ) RAY34360 121 FORMAT( 6(I4,I2,I1, 1PE11.3) ) RAY34370 25 CONTINUE RAY34380 PRINT 122 RAY34390 122 FORMAT( 1H ) RAY34400 24 CONTINUE RAY34410 XTTT=((XO(33)- XO(34) )/2. - R(1,2)*VXI(33) )/VXI(33)**3 RAY34420 XTPP = (XO(27) - XO(28) + XO(6) -XO(5))/(2.*VXI(27)*VYI(27)**2) RAY34430 XXTT = (XO(37) - XO(36) + XO(35)-XO(38)- 2.*(XO( 3) - XO( 4) ) )/RAY34440 1 (4.*XI(35) * VXI(35)**2 ) RAY34450 XXXT = (XO(35) - XO(37) + XO(36)-XO(38)- 2.*(XO(33) - XO(34) ) )/RAY34460 1 (4.*XI(35)**2*VXI(35)) RAY34470 XTTD = (XO(39) - XO(40) + XO(41)-XO(42)- 2.*(XO(11) - XO(12) ) )/RAY34480 1 (4.*VXI(39)**2*DELP(39)) RAY34490 XTDD = (XO(39) - XO(41) + XO(40)-XO(42)- 2.*(XO(33) - XO(34) ) )/RAY34500 1 (4.*VXI(39)*DELP(39)**2) RAY34510 XXPP = (XO(23) - XO(24) + XO( 4)-XO( 3))/(2.*XI(23)*VYI(23)**2 )RAY34520 XPPD = (XO(31) - XO(32) + XO(12)-XO(11))/(2.*VYI(31)**2*DELP(31))RAY34530 XTTTT=((XO(33)+XO(34) )/2. - T2(1,2,2)*VXI(33)**2)/ VXI(33)**4 RAY34540 XTTPP = (XO(27) - XO( 5) + XO(28)-XO( 6) - 2.*XO( 9) ) / RAY34550 1 ( 2.*VXI(27)**2*VYI(27)**2 ) RAY34560 XPPDD = (XO(31) - XO(11) + XO(32)-XO(12) - 2.*XO( 9) ) / RAY34570 1 ( 2.*VYI(31)**2 * DELP(31)**2 ) RAY34580 XPPPP =(XO(43) -T2(1,4,4)*VYI(43)**2) / VYI(43)**4 RAY34590 ZDDD = ( (RTL(45) - RTL(46) )/2. - R(5,6)*DELP(45) )/DELP(45)**3 RAY34600 ZDDDD = ( (RTL(45)+RTL(46)-2*RTL(1) )/2. -T2(5,6,6)*DELP(45)**2)/ RAY34610 1 DELP(45)**4 RAY34620 XDDD = (( XO(45)- XO(46))/2. - R(1,6)*DELP(45) ) / DELP(45)**3 RAY34630 XDDDD= (( XO(45)+ XO(46))/2. - T2(1,6,6)*DELP(45)**2 )/DELP(45)**4RAY34640 TDDD = ((VXO(45)-VXO(46))/2. - R(2,6)*DELP(45) ) / DELP(45)**3 RAY34650 TDDDD= ((VXO(45)+VXO(46))/2. - T2(2,6,6)*DELP(45)**2 )/DELP(45)**4RAY34660 PRINT 26, XTTT, XTPP, XXTT, XXXT, XTTD, XTDD, XXPP, XPPD, RAY34670 1 XTTTT, XTTPP, XPPDD, XPPPP, RAY34680 2 XDDD, XDDDD, TDDD, TDDDD, ZDDD, ZDDDD RAY34690 26 FORMAT('1',/15X, 'X/THETA**3 =' 1PE11.3 / RAY34700 1 15X, 'X/THETA.PHI**2 =' 1PE11.3 / RAY34710 2 15X, 'X/X.THETA**2 =' 1PE11.3 / RAY34720 3 15X, 'X/X**2.THETA =' 1PE11.3 / RAY34730 4 15X, 'X/THETA**2.DELTA =' 1PE11.3 / RAY34740 5 15X, 'X/THETA.DELTA**2 =' 1PE11.3 / RAY34750 6 15X, 'X/X.PHI**2 =' 1PE11.3 / RAY34760 7 15X, 'X/PHI**2.DELTA =' 1PE11.3 // RAY34770 8 15X, 'X/THETA**4 =' 1PE11.3 / RAY34780 9 15X, 'X/THETA**2.PHI**2=' 1PE11.3 / RAY34790 A 15X, 'X/PHI**2.DELTA**2=' 1PE11.3 / RAY34800 B 15X, 'X/PHI**4 =' 1PE11.3 // RAY34810 C 15X, 'X/DELTA*3 =' 1PE11.3 / RAY34820 D 15X, 'X/DELTA*4 =' 1PE11.3 / RAY34830 E 15X, 'THETA/DELTA*3 =' 1PE11.3 / RAY34840 F 15X, 'THETA/DELTA*4 =' 1PE11.3 / RAY34850 H 15X, 'Z/DELTA*3 =' 1PE11.3 / RAY34860 I 15X, 'Z/DELTA*4 =' 1PE11.3 ) RAY34870 DO 1 I1=1,5 RAY34880 DO 1 I2=1,6 RAY34890 DO 1 I3=1,6 RAY34900 1 TT(I1,I2,I3) = T2(I1,I2,I3) RAY34910 DO 2 I=1,12 RAY34920 PSI = 5. * FLOAT(I) RAY34930 TPSI = .001*DTAN( PSI/57.29578 ) RAY34940 TT(1,1,1) = T2(1,1,1) + R(2,1) * R(1,1) * TPSI RAY34950 TT(1,1,2) = T2(1,1,2) + ( R(2,1)*R(1,2) + R(2,2)*R(1,1) ) * TPSI RAY34960 TT(1,2,2) = T2(1,2,2) + R(2,2) * R(1,2) * TPSI RAY34970 TT(1,1,6) = T2(1,1,6) + ( R(2,1)*R(1,6) + R(2,6)*R(1,1) ) * TPSI RAY34980 TT(1,2,6) = T2(1,2,6) + ( R(2,2)*R(1,6) + R(2,6)*R(1,2) ) * TPSI RAY34990 TT(1,6,6) = T2(1,6,6) + R(2,6) * R(1,6) * TPSI RAY35000 TT(3,1,3) = T2(3,1,3) + R(1,1) * R(4,3) * TPSI RAY35010 TT(3,1,4) = T2(3,1,4) + R(1,1) * R(4,4) * TPSI RAY35020 TT(3,2,3) = T2(3,2,3) + R(1,2) * R(4,3) * TPSI RAY35030 TT(3,2,4) = T2(3,2,4) + R(1,2) * R(4,4) * TPSI RAY35040 TT(3,3,6) = T2(3,3,6) + R(1,6) * R(4,3) * TPSI RAY35050 TT(3,4,6) = T2(3,4,6) + R(1,6) * R(4,4) * TPSI RAY35060 CTTT=XTTT+ ( R(1,2)*T2(2,2,2) + R(2,2)*T2(1,2,2) ) * TPSI RAY35070 CTPP=XTPP+ ( R(1,2)*T2(2,4,4) + R(2,2)*T2(1,4,4) ) * TPSI RAY35080 CXTT=XXTT+ ( R(1,1)*T2(2,2,2) + R(1,2)*T2(2,1,2) + RAY35090 1 R(2,1)*T2(1,2,2) + R(2,2)*T2(1,1,2) ) * TPSI RAY35100 CXXT=XXXT+ ( R(1,1)*T2(2,1,2) + R(1,2)*T2(2,1,1) + RAY35110 1 R(2,1)*T2(1,1,2) + R(2,2)*T2(1,1,1) ) * TPSI RAY35120 CTTD=XTTD+ ( R(1,2)*T2(2,2,6) + R(1,6)*T2(2,2,2) + RAY35130 1 R(2,2)*T2(1,2,6) + R(2,6)*T2(1,2,2) ) * TPSI RAY35140 CTDD=XTDD+ ( R(1,2)*T2(2,6,6) + R(1,6)*T2(2,2,6) + RAY35150 1 R(2,2)*T2(1,6,6) + R(2,6)*T2(1,2,6) ) * TPSI RAY35160 CXPP=XXPP+ ( R(1,1)*T2(2,4,4) + R(2,1)*T2(1,4,4) ) * TPSI RAY35170 CPPD=XPPD+ ( R(1,6)*T2(2,4,4) + R(2,2)*T2(1,4,4) ) * TPSI RAY35180 PRINT 27, PSI RAY35190 27 FORMAT(1H1, 35X,'FOCAL PLANE TILT ANGLE= ' F07.2, ' DEGREES ' )RAY35200 PRINT 28, ( ( R(IR, IJ), IJ=1,6), IR=1,6) RAY35210 28 FORMAT( / 51X, 15H *TRANSFORM* 1 , / 6(25X, 6F10.5/) ) RAY35220 PRINT 120 RAY35230 DO 29 I1= 1,5 RAY35240 DO 30 I2= 1,6 RAY35250 PRINT 121, ( I1,I3,I2, TT(I1,I3,I2), I3=1,I2 ) RAY35260 30 CONTINUE RAY35270 PRINT 122 RAY35280 29 CONTINUE RAY35290 PRINT 26, CTTT, CTPP, CXTT, CXXT, CTTD, CTDD, CXPP, CPPD, RAY35300 1 XTTTT, XTTPP, XPPDD, XPPPP, RAY35310 2 XDDD, XDDDD, TDDD, TDDDD, ZDDD, ZDDDD RAY35320 2 CONTINUE RAY35330 RETURN RAY35340 END RAY35350 SUBROUTINE MLTT ( BFLD, Z, X, Y ) RAY23550 C**** RAY23560 C**** RAY23570 C**** RAY23580 C**** RAY23590 IMPLICIT REAL*8(A-H,O-Z) RAY23600 REAL*8 K, L RAY23610 COMMON /BLCK10/ BX, BY, BZ, K, TC, DTC RAY23620 COMMON /BLK100/ W, L, D, DG, S, BF, BT RAY23630 COMMON /BLK101/ C0, C1, C2, C3, C4, C5, C6, C7, C8 RAY23640 DIMENSION TC(6), DTC(6) RAY23650 U = 2.*X/W RAY23660 S = 2.*Z/L RAY23670 DL2 = (L/D)**2 RAY23680 W1 = C0 + C1*U + C2*U*U + C3*U**3 + C4*U**4 + C5*U**5 RAY23690 W2 = 1. + C7*( S**4 + DL2*C8*S**8 ) / ( 1. + DL2*C8 ) RAY23700 BFLD = BF*W1 / W2 RAY23710 RETURN RAY23720 END RAY23730 SUBROUTINE MTRX1( M, JEN, NEN, NR, ENERGY, AMASS ) !JDL 15-NOV-83 RAY35360 C**** RAY35370 C**** !Changes from here... !JDL 10-MAR-84 RAY35380 C**** MM=14, 14 RAYS ARE USED TO EVALUATE THE ABERRATION COEFFICIENTS RAY35390 C**** FOR A POINT SOURCE OBJECT THROUGH 4'TH ORDER. RAY35400 C**** MM= 6, 6 RAYS ARE USED TO EVALUATE THE ABERRATION COEFFICIENTS RAY35410 C**** FOR A POINT SOURCE THROUGH 4'TH ORDER; MIDPLANE ONLY. RAY35420 C**** MM= 2, 2 RAYS ARE USED TO EVALUATE THE FOCAL PLANE ONLY. C**** (FOR OTHER MM VALUES, THE NEXT LOWER NUMBER IS USED.) C**** !...down to here. !JDL 10-MAR-84 C**** RAY35430 C**** RAY35440 IMPLICIT REAL*8(A-H,O-Z) RAY35450 c REAL*4 DAET, TYME !JDL 31-OCT-84 character *4 nwd REAL*8 KT, LP RAY35460 REAL*8 L(2,50), LX(2,12), LD(6) !JDL 15-NOV-83 RAY35470 LOGICAL LPLT COMMON /BLCK00/ LPLT include 'rtcomm0.f' COMMON /BLCK 1/ XI, YI, ZI, VXI, VYI, VZI, DELP, DELM !JDL RAY35480 COMMON /BLCK 2/ XO, YO, ZO, VXO, VYO, VZO, RTL(100), RLL(100) RAY35490 COMMON /BLCK 3/ XINT, YINT, ZINT, TH0, PH0, TL1 RAY35500 COMMON /BLCK16/ NLOOP,NPASS,IP,NCSV,KEEP(20), !JDL 17-NOV-83 1 LOOPSV(5,30),HOOPSV(30),HSAVE(30),PMSV(3), 2 CXXSV(12,3),CSV(36,3),CDSV(6,4,3)!JDL 17-NOV-83 DIMENSION XI(100), YI(100), ZI(100), VXI(100), VYI(100), VZI(100),RAY35510 1 DELP(100) RAY35520 DIMENSION XO(100), YO(100), ZO(100), VXO(100), VYO(100), VZO(100) RAY35530 DIMENSION CXX(12,10), IX(12), CD(6,4), LFACT(50), C(50,10) RAY35540 DIMENSION DXX(21,10), DXY(21,10) RAY35541 DIMENSION PMASS(10) !JDL 29-NOV-83 DATA KEEP / 3, 8,14,18,19,24,25,50,51,52, !JDL 15-NOV-83 1 54,55,58,66,99,99,99,99,99,99/ !JDL 17-NOV-83 DATA IX/ 1,2,5,7,11,13,19,22,29,32,35,36 / RAY35550 DATA LFACT / 1,0,1,0,2*4,2*3,4,3,2*7,2*6,2*7,2*6,3*10,3*9, RAY35560 1 2*10,2*9,3*13,3*12,4,7,14*0 / RAY35570 DATA L / 'X/TH ',' =','T/TH ',' =', RAY35580 1 'Y/PH ',' =','P/PH ',' =', RAY35590 2 'X/TH**2 ',' =','X/PH**2 ',' =', RAY35600 3 'T/TH**2 ',' =','T/PH**2 ',' =', RAY35610 4 'Y/TH*PH ',' =','P/TH*PH ',' =', RAY35620 5 'X/TH**3 ',' =','X/TH*PH*','*2 =', RAY35630 6 'T/TH**3 ',' =','T/TH*PH*','*2 =', RAY35640 7 'Y/PH**3 ',' =','Y/TH**2*','PH =', RAY35650 8 'P/PH**3 ',' =','P/TH**2*','PH =', RAY35660 9 'X/TH**4 ',' =','X/TH**2*','PH**2 =', RAY35670 A 'X/PH**4 ',' =','T/TH**4 ',' =', RAY35680 B 'T/TH**2*','PH**2 =','T/PH**4 ',' =', RAY35690 C 'Y/TH**3*','PH =','Y/TH*PH*','*3 =', RAY35700 D 'P/TH**3*','PH =','P/TH*PH*','*3 =', RAY35710 E 'X/TH**5 ',' =','X/TH**3*','PH**2 =', RAY35720 F 'X/TH*PH*','*4 =','T/TH**5 ',' =', RAY35730 G 'T/TH**3*','PH**2 =','T/TH*PH*','*4 =', RAY35740 H 'X/T**2+T','2*X/T**4','X/T**3+T','2*X/T**5',28*0./ RAY35750 DATA LX / 'ENERGY(M','EV) =','XINT(CM)',' =', RAY35760 1 'YINT(CM)',' =','ZINT(CM)',' =', RAY35770 2 'TH (MR)',' =','PHI (MR)',' =', RAY35771 3 '!XMAX!(C','M) =','2!YMAX!(','CM) =', RAY35780 4 '!X-WAIST','!(cm) =','X(X-WAIS','T) =', RAY35781 5 'Z(X-WAIS','T) =','LENGTH(C','M) =' / RAY35782 DATA LD / 'X/ ','X/T ','X/T**2 ','X/T**3 ', 1 'X/P**2 ','X/T*P**2'/ !JDL 15-NOV-83 C**** RAY35790 MM=M RAY35791 C**** RAY35800 I = JEN RAY35810 IF( I .GT. 10 ) I = 10 RAY35820 C**** RAY35830 C**** RAY35840 XMIN = XO(1) RAY35850 XMAX = XO(1) RAY35860 YMAX = DABS(YO(1)) RAY35870 DO 4 J=2,NR RAY35880 IF( XO(J) .GT. XMAX ) XMAX = XO(J) RAY35890 IF( XO(J) .LT. XMIN ) XMIN = XO(J) RAY35900 IF( DABS(YO(J) ) .GT. YMAX ) YMAX = DABS(YO(J)) RAY35910 4 CONTINUE RAY35920 PMASS(I) = AMASS !JDL 10-NOV-83 CXX(1,I ) = ENERGY RAY35930 CXX(2,I ) = XINT RAY35940 CXX(3,I ) = YINT RAY35950 CXX(4,I ) = ZINT RAY35960 CXX(5,I ) = TH0 RAY35961 CXX(6,I ) = PH0 RAY35962 CXX(7,I ) = DABS(XMAX-XMIN) RAY35970 CXX(8,I ) = 2.*YMAX RAY35980 C**** RAYK1500 C**** CALCULATE BEAM WIDTH AT TEN EQUALLY SPACED (5MM) RAYK1510 C**** DISTANCES EACH SIDE OF ZINT RAYK1520 C**** RAYK1530 DO 20 JJ=1,21 RAYK1540 XMIN = XO(1) + 0.00050 * VXO(1) * (JJ-11) RAYK1550 XMAX = XMIN RAYK1560 DO 21 J = 2, 6 RAYK1570 XJJ = XO(J) + 0.00050 *VXO(J) * (JJ-11) RAYK1580 IF (XJJ.GT.XMAX) XMAX = XJJ RAYK1590 IF (XJJ.LT.XMIN) XMIN = XJJ RAYK1600 21 CONTINUE RAYK1610 DXX(JJ,I) = DABS( XMAX - XMIN) RAYK1620 DXY(JJ,I) = 0. RAYK1630 IF (NR.LE.6) GOTO 20 RAYK1640 DO 22 J=7,NR RAYK1650 XJJ = XO(J) + 0.00050* VXO(J) * (JJ-11) RAYK1660 IF ( XJJ.GT.XMAX ) XMAX = XJJ RAYK1670 IF ( XJJ.LT.XMIN ) XMIN = XJJ RAYK1680 22 CONTINUE RAYK1690 DXY(JJ,I) = DABS( XMAX - XMIN) RAYK1700 20 CONTINUE RAYK1710 C**** RAYK1720 C**** CALCULATE POSITION OF MINIMUM BEAM WIDTH RAYK1730 C**** WITHIN 10.0 CM OF ZINT RAYK1740 XMX = 1.0D20 RAYK1750 DO 25 JJ=1, 101 RAYK1760 XMIN = XO(1) + 0.00020 * VXO(1) * (JJ-51) RAYK1770 XMAX = XMIN RAYK1780 DO 26 J=2, 6 RAYK1790 XJJ = XO(J) + 0.00020 * VXO(J) * (JJ-51) RAYK1800 IF ( XJJ.GT.XMAX ) XMAX = XJJ RAYK1810 IF ( XJJ.LT.XMIN ) XMIN = XJJ RAYK1820 26 CONTINUE RAYK1830 DXMAX = DABS( XMAX - XMIN ) RAYK1840 IF ( DXMAX.GE.XMX ) GO TO 25 RAYK1850 XMX = DXMAX RAYK1860 ZMX = 0.20 * (JJ - 51) RAYK1870 25 CONTINUE RAYK1880 IF ( DABS( ZMX ).GT.9.9 ) ZMX = 1.0D20 RAYK1890 CXX( 9, I) = XMX RAYK1900 CXX(10, I) = .001*TH0*ZMX + XINT RAYK1901 CXX(11, I) = ZMX+ZINT RAYK1910 CXX(12, I) = TL1 C**** RAY35990 C**** IF( MM .LT. 6 ) GO TO 1 !JDL 10-MAR-84 IF( VXI(2) .EQ. 0. ) VXI(2) = 1.D-30 IF( VXI(3) .EQ. 0. ) VXI(3) = 1.D-30 RAY36010 KT = VXI(5)/VXI(3) RAY36020 DTH = VXI(3) RAY36030 TMAX = VXI(5) RAY36040 XT=XO(2)/VXI(2) RAY36050 TT=(KT**3*(VXO(3)-VXO(4))- VXO(5)+VXO(6))/(2.* (KT**3-KT)*DTH) RAY36060 XTT = ( KT**4*(XO(3) + XO(4)) - (XO(5)+XO(6) )) / RAY36070 1 (2.*(KT**4-KT**2) *DTH*DTH) RAY36080 TTT = ( KT**4*(VXO(3)+VXO(4)) -(VXO(5)+VXO(6))) / RAY36090 1 (2.*(KT**4-KT**2) *DTH*DTH) RAY36100 XTTT = ( KT**5 * ( XO(3) - XO(4) - 2.*XT*DTH ) - RAY36110 1 ( XO(5) - XO(6) -2.*KT*XT*DTH) ) / (2.*(KT**5 - KT**3) *DTH**3 ) RAY36120 TTTT = (-KT * (VXO(3) -VXO(4)) + (VXO(5) -VXO(6) ) ) / RAY36130 1 (2.*(KT**3 - KT ) *DTH**3 ) RAY36140 XTTTT = ( (XO(5)+XO(6))-KT*KT*(XO(3)+XO(4) ) ) / RAY36150 1 (2.*(KT**4 - KT*KT)*DTH**4 ) RAY36160 TTTTT =((VXO(5)+VXO(6))-KT*KT*(VXO(3)+VXO(4))) / RAY36170 1 (2.*(KT**4 - KT*KT)*DTH**4 ) RAY36180 XTTTTT= ( XO(5) - XO(6) - 2.*KT*XT*DTH - KT**3*( XO(3) - XO(4) - RAY36190 1 2.*XT*DTH) ) / ( 2.*(KT**5 - KT**3) *DTH**5 ) RAY36200 TTTTTT= 0. RAY36210 C**** RAY36220 C**** RAY36230 C( 1,I) = XT*10. RAY36240 C( 2,I) = TT RAY36250 C( 5,I) = XTT*10.**4 RAY36260 C( 7,I) = TTT*10.**3 RAY36270 C(11,I) = XTTT*10.**7 RAY36280 C(13,I) = TTTT*10.**6 RAY36290 C(19,I) = XTTTT*10.**10 RAY36300 C(22,I) = TTTTT*10.**09 RAY36310 C(29,I) = XTTTTT*10.**13 RAY36320 C(32,I) = TTTTTT*10.**12 RAY36330 C(35,I) = (XTT + XTTTT*TMAX*TMAX)*10.**4 RAY36340 C(36,I) = (XTTT+XTTTTT*TMAX*TMAX)*10.**7 RAY36350 C**** RAY36360 C**** RAY36370 IF( MM .LT. 14 ) GO TO 1 !JDL 10-MAR-84 RAY36380 LP = VYI(12)/VYI(7) RAY36390 DPH = VYI(7) RAY36400 XPP = (LP**4*XO(7) - XO(12)) /((LP**4 - LP*LP)*DPH*DPH ) RAY36410 TPP = (LP**4*VXO(7)-VXO(12)) /((LP**4 - LP*LP)*DPH*DPH ) RAY36420 XPPPP = (XO(12)-LP*LP*XO(7) ) /((LP**4-LP*LP)*DPH**4) RAY36430 TPPPP =(VXO(12)-LP*LP*VXO(7)) /((LP**4-LP*LP)*DPH**4) RAY36440 XTPP = (LP**4*( XO(8) - XO(9)) - ( XO(13) - XO(14)) - (LP**4-1.)*RAY36450 1 ( XO(3) - XO(4)) -(( XO(10) - XO(11)) - KT*( XO(8) - XO(9) ) - RAY36460 2 ( XO(5) - XO(6) ) + KT*( XO(3) - XO(4) ) ) * RAY36470 3 ( ( LP**4 - LP*LP) / (KT**3-KT) ))/(2.*(LP**4-LP*LP)* RAY36480 4 DTH*DPH*DPH ) RAY36490 TTPP = 0. RAY36500 XTTPP = ( ( XO(8)+XO(9) ) - ( XO(3)+XO(4) ) - 2.*XO(7)) / RAY36510 1 (2.*DTH*DTH*DPH*DPH) RAY36520 TTTPP = ( (VXO(8)+VXO(9)) - (VXO(3)+VXO(4)) -2.*VXO(7)) / RAY36530 1 (2.*DTH*DTH*DPH*DPH) RAY36540 YP = ( LP**3 * YO(7) - YO(12) ) / ( (LP**3 - LP)*DPH ) RAY36550 PP = ( LP**3 *VYO(7) -VYO(12) ) / ( (LP**3 - LP)*DPH ) RAY36560 YPPP = (YO(12) - LP*YO(7)) /((LP**3-LP)*DPH**3 ) RAY36570 PPPP =(VYO(12) -LP*VYO(7)) /((LP**3-LP)*DPH**3 ) RAY36580 YTTP = ( YO(8) + YO(9) - 2.*YO(7) ) / (2.*DTH*DTH*DPH ) RAY36590 PTTP = (VYO(8) +VYO(9) - 2.*VYO(7)) / (2.*DTH*DTH*DPH ) RAY36600 YTPPP = ( YO(13) - LP*YO(8) - YO(12) + LP*YO(7) ) / RAY36610 1 ((LP**3 - LP)*DTH*DPH**3 ) RAY36620 PTPPP = (VYO(13) - LP*VYO(8)-VYO(12) + LP*VYO(7)) / RAY36630 1 ((LP**3 - LP)*DTH*DPH**3 ) RAY36640 YTTTP = ( YO(10) - YO(11) -KT*(YO(8)-YO(9) ) ) / RAY36650 1 (2.*(KT**3-KT) * DTH**3*DPH ) RAY36660 PTTTP = (VYO(10) -VYO(11) -KT*(VYO(8)-VYO(9))) / RAY36670 1 (2.*(KT**3-KT) * DTH**3*DPH ) RAY36680 YTP = ( (YO(10)-YO(11) -KT**3*(YO(8)-YO(9) ) ) /(2.*(KT-KT**3))-RAY36690 1 YTPPP*DTH*DPH**3 ) /(DTH*DPH) RAY36700 PTP = ((VYO(10)-VYO(11)-KT**3*(VYO(8)-VYO(9))) /(2.*(KT-KT**3))-RAY36710 1 PTPPP*DTH*DPH**3 ) /(DTH*DPH) RAY36720 XTTTPP= ( XO(10) - XO(11) - KT*( XO(8) - XO(9)) - ( XO(5) - XO(6))RAY36730 1 +KT*( XO(3) - XO(4) ) ) / (2.*(KT**3-KT) * DTH**3*DPH*DPH ) RAY36740 TTTTPP= 0. RAY36750 XTPPPP= ( XO(13) - XO(14) - LP*LP*( XO(8) - XO(9)) + (LP*LP-1.) * RAY36760 1 ( XO(3) - XO(4) ) ) / (2.*(LP**4-LP*LP) * DTH*DPH**4 ) RAY36770 TTPPPP= 0. RAY36780 C( 3,I) = YP*10. RAY36790 C( 4,I) = PP RAY36800 C( 6,I) = XPP*10.**4 RAY36810 C( 8,I) = TPP*10.**3 RAY36820 C( 9,I) = YTP*10.**4 RAY36830 C(10,I) = PTP*10.**3 RAY36840 C(12,I) = XTPP*10.**7 RAY36850 C(14,I) = TTPP*10.**6 RAY36860 C(15,I) = YPPP*10.**7 RAY36870 C(16,I) = YTTP*10.**7 RAY36880 C(17,I) = PPPP*10.**6 RAY36890 C(18,I) = PTTP*10.**6 RAY36900 C(20,I) = XTTPP*10.**10 RAY36910 C(21,I) = XPPPP*10.**10 RAY36920 C(23,I) = TTTPP*10.**09 RAY36930 C(24,I) = TPPPP*10.**09 RAY36940 C(25,I) = YTTTP*10.**10 RAY36950 C(26,I) = YTPPP*10.**10 RAY36960 C(27,I) = PTTTP*10.**09 RAY36970 C(28,I) = PTPPP*10.**09 RAY36980 C(30,I) = XTTTPP*10.**13 RAY36990 C(31,I) = XTPPPP*10.**13 RAY37000 C(33,I) = TTTTPP*10.**12 RAY37010 C(34,I) = TTPPPP*10.**12 RAY37020 C**** RAY37030 C**** RAY37040 IF((IP .GT. 500) .AND. (NEN .GT. 1)) RETURN !JDL 19-NOV-83 13 FORMAT( 2I5 ) 14 FORMAT( ) RAY37050 151 FORMAT( //, 15X, 2A8, F9.4 ) !JDL 11-MAR-84 RAY37060 152 FORMAT( 15X, 16HMASS(AMU) =, F9.4, / ) !JDL 11-MAR-84 153 FORMAT( 7( 15X, 2A8, F9.4 / ) /,3( 15X, 2A8, F8.3/)) !JDL RAY37060 16 FORMAT( 15X, 2A8, 1PE12.3, 0PF15.4 ) RAY37070 PRINT 151, ( LX(J,1),J=1,2), CXX(1,I) !JDL 11-MAR-84 PRINT 152, AMASS !JDL 11-MAR-84 PRINT 153,( ( LX(J,K),J=1,2), CXX(K,I), K=2,12) !JDL 11-MAR-84 RAY37080 DO 2 JJ=1,36 RAY37090 COEF = C(JJ,I)/ 10.**LFACT(JJ) RAY37100 IF( (JJ.EQ. 5).OR.(JJ.EQ. 11).OR.(JJ.EQ.19).OR.(JJ.EQ.29))PRINT 14RAY37110 2 PRINT 16, (L(J,JJ), J=1,2), COEF, C(JJ,I) RAY37120 GO TO 23 RAY37130 C**** RAY37140 C**** RAY37150 1 CONTINUE RAY37160 IF((IP .GT. 500) .AND. (NEN .GT. 1)) RETURN !JDL 19-NOV-83 PRINT 151, ( LX(J,1),J=1,2), CXX(1,I) !JDL 11-MAR-84 PRINT 152, AMASS !JDL 11-MAR-84 PRINT 153,( ( LX(J,K),J=1,2), CXX(K,I), K=2,12) !JDL 11-MAR-84 RAY37170 IF( MM .LT. 6) RETURN !JDL 11-MAR-84 DO 3 JJ=1,12 RAY37180 K = IX(JJ) RAY37190 COEF = C(K,I)/10.**LFACT(K) RAY37200 3 PRINT 16, ( L(J,K),J=1,2), COEF, C(K,I) RAY37210 C**** RAYK2000 C**** PRINT OUT BEAM WIDTH RAYK2010 C**** RAYK2020 23 CONTINUE RAYK2030 IF(IP .GT. 500) RETURN !JDL 19-NOV-83 PRINT 29 RAYK2040 DO 24 JJ=1, 21 RAYK2050 DZ = 0.50 * (JJ-11) RAYK2060 PRINT 30, DZ, DXX(JJ,I), DXY(JJ,I) RAYK2070 24 CONTINUE RAYK2080 29 FORMAT ('1', 3X, 'IMAGE SIZE !XMAX!(CM)', //2X, 'DZ (CM)', RAYK2090 1 2X, ' 1-6 ', 2X, ' 1-NR') RAYK2100 30 FORMAT (F8.2, 2F9.3) RAYK2110 RETURN RAY37220 C**** RAY37230 C**** RAY37240 ENTRY MPRNT( NEN, WIDTH ) !JDL 1-DEC-83 RAY37250 C**** RAY37260 DO 44 J=1,NEN !JDL 29-NOV-83 44 CXX(7,J) = WIDTH !JDL 1-DEC-83 IF( NEN .EQ. 1 ) GO TO 200 !JDL 17-NOV-83 IF( LPLT) WRITE(2,13) NEN, MM 181 FORMAT( 4X, 16HMASS(AMU) =, 10F11.3 ) !JDL 10-NOV-83 18 FORMAT( 4X, 2A8, 10F11.3 ) RAY37270 IF( NEN .GT. 10 ) NEN = 10 RAY37280 PRINT 14 RAY37290 DO 8 K=1,8 RAY37300 IF( LPLT ) WRITE(2,18)(LX(J,K),J=1,2),(CXX(K,I),I=1,NEN) PRINT 18, ( LX(J,K),J=1,2),(CXX(K,I),I=1,NEN) !JDL 10-MAR-84 RAY37310 IF( K .NE. 1 ) GO TO 8 !JDL 10-MAR-84 IF( LPLT ) WRITE(2,18) ( PMASS(I),I=1,NEN ) !JDL 10-MAR-84 PRINT 181, ( PMASS(I),I=1,NEN ) !JDL 10-MAR-84 PRINT 14 !JDL 10-MAR-84 8 CONTINUE !JDL 10-MAR-84 PRINT 14 RAY37320 C**** RAY37330 IF(MM .LT. 6 ) GO TO 200 !JDL 10-MAR-84 IF(MM .LT. 14 ) GO TO 5 !JDL 10-MAR-84 RAY37340 DO 7 K=1,36 RAY37350 IF( (K .EQ. 5).OR.(K .EQ. 11).OR.(K .EQ.19).OR.(K .EQ.29))PRINT 14RAY37360 IF( LPLT ) WRITE(2,18) (L(J,K),J=1,2),(C(K,I),I=1,NEN ) 7 PRINT 18, ( L(J,K),J=1,2),(C(K,I),I=1,NEN ) RAY37370 GO TO 19 RAY37380 5 DO 6 JJ=1,12 RAY37390 K = IX(JJ) RAY37400 IF( LPLT ) WRITE(2,18) ( L(J,K),J=1,2), ( C(K,I), I=1,NEN) 6 PRINT 18, ( L(J,K),J=1,2),(C(K,I), I=1,NEN ) RAY37410 C**** RAY37420 C**** CHROMATIC ABERRATION COEFFICIENTS RAY37430 C**** CALCULATED ONLY FOR CASE OF NEN= 5 ENERGIES RAY37440 C**** RAY37450 19 CONTINUE RAY37460 IF( NEN .NE. 5 ) GO TO 200 !JDL 17-NOV-83 RAY37470 DEL = CXX(1,4)/CXX(1,3) - 1. RAY37480 DO 9 I=1,6 RAY37490 C**** IF( I .EQ. 1 ) K=2 !From here ... !JDL 15-NOV-83 RAY37500 C**** IF( I .EQ. 2 ) GO TO 10 RAY37510 C**** IF( I .EQ. 3 ) K=5 RAY37520 C**** IF( I .EQ. 4 ) K=11 RAY37530 C**** IF( I .EQ. 5 ) K=19 RAY37540 C**** IF( I .EQ. 6 ) K=29 RAY37550 C**** IF( I .GT. 2 ) GO TO 11 RAY37560 IF( I .EQ. 1 ) K=2 RAY37500 IF( I .EQ. 2 ) K=1 IF( I .EQ. 3 ) K=5 RAY37520 IF( I .EQ. 4 ) K=11 RAY37530 IF( I .EQ. 5 ) K=6 IF( I .EQ. 6 ) K=12 IF( I .NE. 1 ) GO TO 11 ! ... to here. !JDL 15-NOV-83 X1 =(CXX(K,1) - CXX(K,3))/100. RAY37570 X2 =(CXX(K,2) - CXX(K,3))/100. RAY37580 X4 =(CXX(K,4) - CXX(K,3))/100. RAY37590 X5 =(CXX(K,5) - CXX(K,3))/100. RAY37600 GO TO 12 RAY37610 11 X1 = C(K,1) - C(K,3) RAY37620 X2 = C(K,2) - C(K,3) RAY37630 X4 = C(K,4) - C(K,3) RAY37640 X5 = C(K,5) - C(K,3) RAY37650 12 CD(I,1) = (8. *(X4-X2) - (X5-X1) )/(12. *DEL) RAY37660 CD(I,2) = (16.* (X4+X2) - (X5+X1) )/(24. *DEL*DEL) RAY37670 CD(I,3) = ( (X5-X1) - 2.*(X4-X2) )/(12. *DEL**3) RAY37680 CD(I,4) = ( (X5+X1) - 4.*(X4+X2) )/(24. *DEL**4) RAY37690 GO TO 9 RAY37700 10 Z1 =(CXX(4,1) - CXX(4,3))/100. RAY37710 Z2 =(CXX(4,2) - CXX(4,3))/100. RAY37720 Z4 =(CXX(4,4) - CXX(4,3))/100. RAY37730 Z5 =(CXX(4,5) - CXX(4,3))/100. RAY37740 TPSI = (8.* (Z4-Z2) - (Z5-Z1) ) / (8.* (X4-X2) - (X5-X1) ) RAY37750 PSI = 57.29578D0 * DATAN(TPSI) RAY37760 DZ1 = Z1 - X1*TPSI RAY37770 DZ2 = Z2 - X2*TPSI RAY37780 DZ4 = Z4 - X4*TPSI RAY37790 DZ5 = Z5 - X5*TPSI RAY37800 CD(I,1) = -C(2,3)*( 8.*(DZ4-DZ2) - (DZ5-DZ1) )/(12. *DEL) RAY37810 CD(I,2) = -C(2,3)*( 16.*(DZ4+DZ2) - (DZ5+DZ1) )/(24. *DEL*DEL) RAY37820 CD(I,3) = -C(2,3)*( (DZ5-DZ1) - 2.*(DZ4-DZ2) )/(12. *DEL**3) RAY37830 CD(I,4) = -C(2,3)*( (DZ5+DZ1) - 4.*(DZ4+DZ2) )/(24. *DEL**4) RAY37840 9 CONTINUE RAY37850 PRINT 14 RAY37860 PRINT 17, PSI, (I,I=1,4), ( (CD(K,I),I=1,4), K=1,6 ) RAY37870 IF( LPLT ) WRITE(2,17) PSI, (I,I=1,4), ( ( CD(K,I),I=1,4), K=1,6 ) 17 FORMAT(4X,'PSI =', F11.3,/4X,'N =',4(I7, RAY37880 1 4X),/4X,'X/D**N =',4F11.3,/4X,'X/T*D**N =',4F11.3,RAY37890 2 /4X,'X/T**2*D**N =',4X,1P4E11.3, RAY37900 3 /4X,'X/T**3*D**N =',4X,1P4E11.3, RAY37910 4 /4X,'X/P**2*D**N =',4X,1P4E11.3, !JDL 15-NOV-83 RAY37920 5 /4X,'X/T*P**2*D**N =',4X,1P4E11.3 ) !JDL 15-NOV-83 RAY37930 C**** New code added from here... !JDL 15-NOV-83 C**** C**** C**** STORE DATA FOR INITIAL CENTRAL ENERGY AND SUBSEQUENT PAIRS OF C**** RUNS HAVING PARAMETER SHIFTS OF +STEP AND -STEP. AFTER EVERY C**** TWO SUCH PAIRS, PRINT CENTRAL VALUE PLUS FIRST AND SECOND C**** DIFFERENTIAL CHANGES. C**** 200 IF(NLOOP .EQ. 0) GO TO 260 NCSV=NCSV+1 IF(NCSV .NE. 3) GO TO 206 IF(NEN .EQ. 5) PRINT 270, NTITLE PRINT 271 KUPLE=LOOPSV(4,NPASS) DO 204 J=NPASS,NLOOP IF(LOOPSV(4,J) .NE. KUPLE) GO TO 204 IF((KUPLE .EQ. 4H ) .AND. (J .NE. NPASS)) GO TO 204 INO =LOOPSV(1,J) IROW=LOOPSV(2,J) ICOL=LOOPSV(3,J) IJ =LOOPSV(5,J) NWD=NWORD(IDATA(INO)) A0=HSAVE(J) A1=A0+HOOPSV(J) A2=A0-HOOPSV(J) PRINT 272, NWD, ITITLE(INO), IROW, ICOL, KUPLE, A2, A0, A1 204 CONTINUE PRINT 273 HDATA=HOOPSV(NPASS) 206 JJ=1 KK=1 NCTR=(NEN+1)/2 NP5=MOD(IP,10) PMSV(NCSV)=PMASS(NCTR) IF(NCSV .NE. 3) GO TO 210 IF((KEEP(JJ) .GT. KK) .AND. (NP5 .EQ. 5)) GO TO 210 JJ=JJ+1 A0=PMSV(1) A1=(PMSV(2)-PMSV(3))/(2.0*HDATA) A2=(PMSV(2)+PMSV(3)-2.0*PMSV(1))/(HDATA**2) PRINT 274, A0,A1,A2 210 CONTINUE DO 220 I=1,12 KK=KK+1 CXXSV(I,NCSV)=CXX(I,NCTR) IF(NCSV .NE. 3) GO TO 220 IF((KEEP(JJ) .GT. KK) .AND. (NP5 .EQ. 5)) GO TO 220 JJ=JJ+1 A0=CXXSV(I,1) A1=(CXXSV(I,2)-CXXSV(I,3))/(2.0*HDATA) A2=(CXXSV(I,2)+CXXSV(I,3)-2.0*CXXSV(I,1))/(HDATA**2) PRINT 276, (LX(K,I),K=1,2),A0,A1,A2 220 CONTINUE DO 230 I=1,36 KK=KK+1 CSV(I,NCSV)=C(I,NCTR) IF(NCSV .NE. 3) GO TO 230 IF((KEEP(JJ) .GT. KK) .AND. (NP5 .EQ. 5)) GO TO 230 JJ=JJ+1 A0=CSV(I,1) A1=(CSV(I,2)-CSV(I,3))/(2.0*HDATA) A2=(CSV(I,2)+CSV(I,3)-2.0*CSV(I,1))/(HDATA**2) PRINT 276, (L(K,I),K=1,2),A0,A1,A2 230 CONTINUE IF(NEN .NE. 5) GO TO 250 DO 240 I=1,6 DO 240 J=1,4 KK=KK+1 CDSV(I,J,NCSV)=CD(I,J) IF(NCSV .NE. 3) GO TO 240 IF((KEEP(JJ) .GT. KK) .AND. (NP5 .EQ. 5)) GO TO 240 JJ=JJ+1 A0=CDSV(I,J,1) A1=(CDSV(I,J,2)-CDSV(I,J,3))/(2.0*HDATA) A2=(CDSV(I,J,2)+CDSV(I,J,3)-2.0*CDSV(I,J,1))/(HDATA**2) PRINT 278, LD(I),J,A0,A1,A2 240 CONTINUE 250 IF(NCSV .LT. 3) RETURN NCSV=1 !SEQUENCE: (1,2,3);(1,4,5);ETC. C**** 260 CONTINUE 270 FORMAT( 1H1, 10X, 20A4 ) 271 FORMAT( /,4X,'DIFFERENTIALS CALCULATED FROM THREE ', 1 'DATA RUNS: (CENTER-STEP, DATA CENTER, CENTER+STEP)',/) 272 FORMAT( 4X,A4,' (',A4,') [LINE',I2,', ENTRY',I2, 1 ', GROUP (',A4,')] ',3F13.6 ) 273 FORMAT( /,4X,24X,'A0',14X,'A1',14X,'A2',/) 274 FORMAT( 4X, 'MASS(AMU) =',1P,3E16.6 ) 276 FORMAT( 4X,2A8,1P,3E16.6 ) 278 FORMAT( 4X, A8,'D**',I1,' =',1P,3E16.6 ) C**** C**** ...down to here. !JDL 15-NOV-83 RETURN RAY37940 END RAY37950 SUBROUTINE MULT ( NO, NP, T, TP ,NUM ) RAY21550 C**** RAY21560 C**** RAY21570 C**** MULTIPOLE RAY TRACING BY NUMERICAL INTEGRATION OF DIFFERENTIALRAY21580 C**** EQUATIONS OF MOTION. RAY21590 C T = TIME RAY21600 C TC(1) TO TC(6) = ( X, Y, Z, VX, VY, VZ ) RAY21610 C DTC(1) TO DTC(6) = ( VX, VY, VZ, VXDOT, VYDOT, VZDOT ) RAY21620 C**** RAY21630 C**** RAY21640 IMPLICIT REAL*8(A-H,O-Z) RAY21650 c REAL*4 DAET, TYME !JDL 31-OCT-84 REAL*8 LF, K, L RAY21660 include 'rtcomm0.f' COMMON /BLCK 4/ ENERGY, VEL, PMASS, Q0 RAY21680 COMMON /BLCK 5/ XA, YA, ZA, VXA, VYA, VZA RAY21690 COMMON /BLCK60/ GAS,AGAS,ZGAS,ZION,PRESS,GASSIG,QAVER, !***MP 1-JAN-85 1 QFWHM,RHOGAS,GASK,EMASS,GASMFP,JRAY,Q00,NPASG !*** COMMON /BLCK10/ BX, BY, BZ, K, TC, DTC RAY21700 COMMON /BLK100/ W, L, D, DG, S, BF, BT RAY21710 COMMON /BLK101/ C0, C1, C2, C3, C4, C5, C6, C7, C8 RAY21720 C*JDL DIMENSION DATA( 75,30 ), ITITLE(30) !JDL 17-NOV-83 RAY21730 DIMENSION TC(6), DTC(6), DS(6), ES(6) RAY21740 EXTERNAL BMULT RAY21750 C**** DATA C/ 3.D10/ RAY21760 C**** RAY21770 JRAYGAS = JRAY*GAS LF = DATA( 1,NO ) RAY21780 DG = DATA( 2,NO ) RAY21790 A = DATA( 10,NO ) RAY21800 B = DATA( 11,NO ) RAY21810 L = DATA( 12,NO ) RAY21820 W = DATA( 13,NO ) RAY21830 D = DATA( 14,NO ) RAY21840 BF = DATA( 15,NO ) RAY21850 Z1 = DATA( 16,NO ) RAY21860 Z2 = DATA( 17,NO ) RAY21870 C0 = DATA( 20,NO ) RAY21880 C1 = DATA( 21,NO ) RAY21890 C2 = DATA( 22,NO ) RAY21900 C3 = DATA( 23,NO ) RAY21910 C4 = DATA( 24,NO ) RAY21920 C5 = DATA( 25,NO ) RAY21930 C6 = DATA( 26,NO ) RAY21940 C7 = DATA( 27,NO ) RAY21950 C8 = DATA( 28,NO ) RAY21960 DTF = LF/VEL RAY21970 BX = 0. RAY21980 BY = 0. RAY21990 BZ = 0. RAY22000 BT = 0. RAY22010 S = 0. RAY22020 C**** RAY22030 IF( NP .GT. 100 ) GO TO 5 RAY22040 PRINT 100, ITITLE(NO) RAY22050 100 FORMAT( ' MULTIPOLE **** ', A4,' *************************'/) RAY22060 PRINT 101 RAY22070 101 FORMAT( 8H T CM ,18X, 4HX CM , 7X, 2HBX, 8X, 4HY CM , 7X, 2HBY,RAY22080 1 8X, 4HZ CM, 7X, 2HBZ, 8X, 6HVELZ/C , 6X, 8HTHETA MR , 5X, RAY22090 2 6HPHI MR , 6X, 1HB ) RAY22100 CALL PRNT2 ( T,S,XA ,YA ,ZA ,BX,BY,BZ,BT,VXA ,VYA ,VZA )RAY22110 IF (JRAYGAS.NE.0) CALL PRNT2A PRINT 103 RAY22120 103 FORMAT( '0COORDINATE TRANSFORMATION TO CENTERED AXIS SYSTEM ' ) RAY22130 109 FORMAT( '0COORDINATE TRANSFORMATION TO D AXIS SYSTEM ' ) RAY22140 C**** TRANSFORM FROM INITIAL ENTRANCE COORDINATES TO VFB COORD. RAY22150 C**** RAY22160 5 TC(1) = XA RAY22170 TC(2) = YA RAY22180 TC(3) = ZA - (A+L/2.) RAY22190 TC(4) = VXA RAY22200 TC(5) = VYA RAY22210 TC(6) = VZA RAY22220 CALL PRNT2 ( T,S,TC(1),TC(2),TC(3),BX,BY,BZ,BT,TC(4),TC(5),TC(6) )RAY22230 IF (JRAYGAS.NE.0) CALL PRNT2A NUM = NUM+1 TPAR = T*VEL NBR = 2 CALL PLT1 ( NUM, NO, NBR, TPAR ) C**** RAY22240 C**** TRANSLATE PARTICLE TO START OF FIRST FRINGE FIELD RAY22250 C**** RAY22260 TDT = ( Z1 - TC(3) ) /DABS( TC(6) ) RAY22270 C**** RAY22280 TC(1) = TC(1) + TDT * TC(4) RAY22290 TC(2) = TC(2) + TDT * TC(5) RAY22300 TC(3) = TC(3) + TDT * TC(6) RAY22310 T = T + TDT RAY22320 NUM = NUM+1 TPAR = T*VEL NBR = 2 CALL PLT1 ( NUM, NO, NBR, TPAR ) C**** RAY22330 IF( NP .LE. 100) PRINT 104 RAY22340 104 FORMAT( 24H0MULTIPOLE FIELD REGION ) RAY22350 CALL FNMIRK( 6, T, DTF ,TC, DTC, DS, ES, BMULT, 0 ) RAY22360 NSTEP = 0 RAY22370 6 CALL PRNT2 ( T,S,TC(1),TC(2),TC(3),BX,BY,BZ,BT,TC(4),TC(5),TC(6) )RAY22380 IF (JRAYGAS.NE.0) CALL PRNT2A DO 7 I = 1, NP RAY22390 CALL FNMIRK( 6, T, DTF ,TC, DTC, DS, ES, BMULT, 1 ) RAY22400 NSTEP = NSTEP + 1 RAY22410 NUM = NUM+1 TPAR = T*VEL NBR = 2 CALL PLT1 ( NUM, NO, NBR, TPAR ) IF (NSTEP .GT. 10000) GO TO 99 RAY22411 IF( Z2 .LE. TC(3) ) GO TO 8 RAY22420 7 CONTINUE RAY22430 GO TO 6 RAY22440 8 CONTINUE RAY22450 XDTF =-( TC(3) - Z2 ) /DABS( TC(6) ) RAY22460 CALL FNMIRK( 6, T,XDTF ,TC, DTC, DS, ES,BMULT, 0 ) RAY22470 CALL FNMIRK( 6, T,XDTF ,TC, DTC, DS, ES,BMULT, 1 ) RAY22480 CALL PRNT2 ( T,S,TC(1),TC(2),TC(3),BX,BY,BZ,BT,TC(4),TC(5),TC(6) )RAY22490 IF (JRAYGAS.NE.0) CALL PRNT2A NUM = NUM+1 TPAR = T*VEL NBR = 2 CALL PLT1 ( NUM, NO, NBR, TPAR ) IF( NP .LE. 100) PRINT 105, NSTEP RAY22500 105 FORMAT( 10H NSTEPS= I5 ) RAY22510 C**** RAY22520 C**** TRANSFORM TO OUTPUT SYSTEM COORD. RAY22530 C**** RAY22540 TC(3) = TC(3) - (B+L/2.) RAY22550 IF( NP .LE. 100) PRINT 109 RAY22560 CALL PRNT2 ( T,S,TC(1),TC(2),TC(3),BX,BY,BZ,BT,TC(4),TC(5),TC(6) )RAY22570 IF (JRAYGAS.NE.0) CALL PRNT2A C**** RAY22580 C**** TRANSLATE PARTICLE TO OUT SYSTEM COORD. RAY22590 C**** RAY22600 TDT = -TC(3) /DABS( TC(6) ) RAY22610 TC(1) = TC(1) + TDT * TC(4) RAY22620 TC(2) = TC(2) + TDT * TC(5) RAY22630 TC(3) = TC(3) + TDT * TC(6) RAY22640 T = T + TDT RAY22650 TP = T * VEL RAY22660 BX = 0. RAY22670 BY = 0. RAY22680 BZ = 0. RAY22690 BT = 0. RAY22700 S = 0. RAY22710 VXF = 1000. *DATAN2( TC(4), TC(6) ) RAY22720 VYF = 1000. *DASIN ( TC(5)/ VEL ) RAY22730 VZF = TC(6) / VEL RAY22740 IF( NP .LE. 100) PRINT 115,TP,TC(1),TC(2),TC(3),VZF,VXF,VYF RAY22750 115 FORMAT( F10.4, 10X, F10.3, 11X, F10.3, 11X, F10.3, 11X, RAY22760 1 F13.5, F13.2, F11.2 ) RAY22770 NUM = NUM+1 TPAR = T*VEL NBR = 3 CALL PLT1 ( NUM, NO, NBR, TPAR ) C**** RAY22780 C**** CALCULATE INTERCEPTS IN SYSTEM D RAY22790 C**** RAY22800 C**** RAY22810 C**** RAY22820 Z0X = -TC(1)/ ( TC(4) / TC(6) + 1.E-10 ) RAY22830 Z0Y = -TC(2)/ ( TC(5) / TC(6) + 1.E-10 ) RAY22840 IF( NP .LE. 100) PRINT 111, VXF, VYF, Z0X, Z0Y RAY22850 111 FORMAT( / ' INTERSECTIONS WITH VER. AND HOR. PLANES ' , RAY22860 X /15X, 5H XP=F10.4, 10H MR YP= F10.4, 3H MR / RAY22870 1 15X, 5H Z0X=F10.2, 10H CM Z0Y= F10.2, 3H CM / )RAY22880 RETURN RAY22890 99 CALL PRNT4(NO, IN) RAY22891 RETURN RAY22892 END RAY22900 SUBROUTINE MULTPL ( NO, NP, T, TP ,NUM ) RAY11400 C**** RAY11410 C**** RAY11420 C**** QUADRUPOLE RAY TRACING BY NUMERICAL INTEGRATION OF DIFFERENTIALRAY11430 C**** EQUATIONS OF MOTION. RAY11440 C T = TIME RAY11450 C TC(1) TO TC(6) = ( X, Y, Z, VX, VY, VZ ) RAY11460 C DTC(1) TO DTC(6) = ( VX, VY, VZ, VXDOT, VYDOT, VZDOT ) RAY11470 C**** RAY11480 C**** RAY11490 IMPLICIT REAL*8(A-H,O-Z) RAY11500 c REAL*4 DAET, TYME !JDL 31-OCT-84 REAL*8 LF1, LF2, LU1, K, L RAY11510 include 'rtcomm0.f' COMMON /BLCK 4/ ENERGY, VEL, PMASS, Q0 RAY11530 COMMON /BLCK 5/ XA, YA, ZA, VXA, VYA, VZA RAY11540 COMMON /BLCK 7/ NCODE RAY11550 COMMON /BLCK10/ BX, BY, BZ, K, TC, DTC RAY11560 COMMON /BLCK50/ D,BGRAD, S, BT RAY11570 COMMON /BLCK51/ C0, C1, C2, C3, C4, C5 RAY11580 COMMON /BLCK52/ IN RAY11590 COMMON /BLCK60/ GAS,AGAS,ZGAS,ZION,PRESS,GASSIG,QAVER, !***MP 1-JAN-85 1 QFWHM,RHOGAS,GASK,EMASS,GASMFP,JRAY,Q00,NPASG !*** C*JDL DIMENSION DATA( 75,30 ), ITITLE(30) !JDL 17-NOV-83 RAY11600 DIMENSION TC(6), DTC(6), DS(6), ES(6) RAY11610 EXTERNAL BFLD RAY11620 C**** DATA C/ 3.D10/ RAY11630 C**** RAY11640 JRAYGAS = JRAY*GAS LF1 = DATA( 1,NO ) RAY11650 LU1 = DATA( 2,NO ) RAY11660 LF2 = DATA( 3,NO ) RAY11670 A = DATA( 10,NO ) RAY11680 B = DATA( 11,NO ) RAY11690 L = DATA( 12,NO ) RAY11700 RAD = DATA( 13,NO ) RAY11710 BF = DATA( 14,NO ) RAY11720 Z11 = DATA( 15,NO ) RAY11730 Z12 = DATA( 16,NO ) RAY11740 Z21 = DATA( 17,NO ) RAY11750 Z22 = DATA( 18,NO ) RAY11760 DTF1= LF1/ VEL RAY11770 DTF2= LF2/ VEL RAY11780 DTU = LU1/ VEL RAY11790 D = 2. * RAD RAY11800 BGRAD = (-1)**NCODE * BF/RAD**NCODE RAY11810 BX = 0. RAY11820 BY = 0. RAY11830 BZ = 0. RAY11840 BT = 0. RAY11850 S = 0. RAY11860 C**** RAY11870 IF( NP .GT. 100 ) GO TO 5 RAY11880 201 FORMAT( ' QUADRUPOLE **** ', A4, ' ***********************'/) RAY11890 202 FORMAT( ' HEXAPOLE **** ', A4, ' ***********************'/) RAY11900 203 FORMAT( ' OCTAPOLE **** ', A4, ' ***********************'/) RAY11910 204 FORMAT( ' DECAPOLE **** ', A4, ' ***********************'/) RAY11920 GO TO ( 21, 22, 23, 24 ) , NCODE RAY11930 21 PRINT 201, ITITLE(NO) RAY11940 GO TO 25 RAY11950 22 PRINT 202, ITITLE(NO) RAY11960 GO TO 25 RAY11970 23 PRINT 203, ITITLE(NO) RAY11980 GO TO 25 RAY11990 24 PRINT 204, ITITLE(NO) RAY12000 25 PRINT 101 RAY12010 101 FORMAT( 8H T CM ,18X, 4HX CM , 7X, 2HBX, 8X, 4HY CM , 7X, 2HBY,RAY12020 1 8X, 4HZ CM, 7X, 2HBZ, 8X, 6HVELZ/C , 6X, 8HTHETA MR , 5X, RAY12030 2 6HPHI MR , 6X, 1HB ) RAY12040 CALL PRNT2 ( T,S,XA ,YA ,ZA ,BX,BY,BZ,BT,VXA ,VYA ,VZA )RAY12050 IF (JRAYGAS.NE.0) CALL PRNT2A PRINT 103 RAY12060 103 FORMAT( '0COORDINATE TRANSFORMATION TO B AXIS SYSTEM ' ) RAY12070 109 FORMAT( '0COORDINATE TRANSFORMATION TO D AXIS SYSTEM ' ) RAY12080 C**** TRANSFORM FROM INITIAL ENTRANCE COORDINATES TO VFB COORD. RAY12090 C**** RAY12100 5 TC(1) = -XA RAY12110 TC(2) = YA RAY12120 TC(3) = A - ZA RAY12130 TC(4) = -VXA RAY12140 TC(5) = VYA RAY12150 TC(6) = -VZA RAY12160 CALL PRNT2 ( T,S,TC(1),TC(2),TC(3),BX,BY,BZ,BT,TC(4),TC(5),TC(6) )RAY12170 IF (JRAYGAS.NE.0) CALL PRNT2A NUM = NUM+1 TPAR = T*VEL NBR = 2 CALL PLT1 ( NUM, NO, NBR, TPAR ) C**** RAY12180 C**** TRANSLATE PARTICLE TO START OF FIRST FRINGE FIELD RAY12190 C**** RAY12200 TDT = ( TC(3) - Z11 ) /DABS( TC(6) ) RAY12210 C**** RAY12220 TC(1) = TC(1) + TDT * TC(4) RAY12230 TC(2) = TC(2) + TDT * TC(5) RAY12240 TC(3) = TC(3) + TDT * TC(6) RAY12250 T = T + TDT RAY12260 NUM = NUM+1 TPAR = T*VEL NBR = 2 CALL PLT1 ( NUM, NO, NBR, TPAR ) C**** RAY12270 C**** IN DESIGNATES FIELD REGIONS FOR QUADRUPOLE RAY12280 C**** RAY12290 IN = 1 RAY12300 C0 = DATA( 19,NO ) RAY12310 C1 = DATA( 20,NO ) RAY12320 C2 = DATA( 21,NO ) RAY12330 C3 = DATA( 22,NO ) RAY12340 C4 = DATA( 23,NO ) RAY12350 C5 = DATA( 24,NO ) RAY12360 IF( NP .LE. 100) PRINT 104 RAY12370 104 FORMAT( 22H0FRINGING FIELD REGION ) RAY12380 CALL FNMIRK( 6, T, DTF1,TC, DTC, DS, ES, BFLD , 0 ) RAY12390 NSTEP = 0 RAY12400 6 CALL PRNT2 ( T,S,TC(1),TC(2),TC(3),BX,BY,BZ,BT,TC(4),TC(5),TC(6) )RAY12410 IF (JRAYGAS.NE.0) CALL PRNT2A DO 7 I = 1, NP RAY12420 CALL FNMIRK( 6, T, DTF1,TC, DTC, DS, ES, BFLD , 1 ) RAY12430 NSTEP = NSTEP + 1 RAY12440 NUM = NUM+1 TPAR = T*VEL NBR = 2 CALL PLT1 ( NUM, NO, NBR, TPAR ) IF (NSTEP .GT. 10000) GO TO 99 RAY12441 IF( Z12 .GE. TC(3) ) GO TO 8 RAY12450 7 CONTINUE RAY12460 GO TO 6 RAY12470 8 CONTINUE RAY12480 XDTF1 =-( Z12 - TC(3) ) /DABS( TC(6) ) RAY12490 CALL FNMIRK( 6, T,XDTF1,TC, DTC, DS, ES,BFLD , 0 ) RAY12500 CALL FNMIRK( 6, T,XDTF1,TC, DTC, DS, ES,BFLD , 1 ) RAY12510 CALL PRNT2 ( T,S,TC(1),TC(2),TC(3),BX,BY,BZ,BT,TC(4),TC(5),TC(6) )RAY12520 IF (JRAYGAS.NE.0) CALL PRNT2A NUM = NUM+1 TPAR = T*VEL NBR = 2 CALL PLT1 ( NUM, NO, NBR, TPAR ) IF( NP .LE. 100) PRINT 105, NSTEP RAY12530 105 FORMAT( 10H NSTEPS= I5 ) RAY12540 C*** RAY12550 C*** UNIFORM FIELD REGION RAY12560 C**** TRANSFORM TO SECOND VFB COORD SYSTEM RAY12570 C*** RAY12580 BGRAD = (-1)**NCODE * BGRAD RAY12590 TC(1) = -TC(1) RAY12600 TC(3) = -TC(3) - L RAY12610 TC(4) = -TC(4) RAY12620 TC(6) = -TC(6) RAY12630 C**** RAY12640 C**** RAY12650 C**** UNIFORM FIELD INTEGRATION REGION RAY12660 C**** RAY12670 C**** RAY12680 IN = 2 RAY12690 IF( NP .LE. 100) PRINT 106 RAY12700 106 FORMAT( '0UNIFORM FIELD REGION IN C AXIS SYSTEM ' ) RAY12710 IF( TC(3) .LT. Z21 ) GO TO 15 RAY04720 C**** RAY04730 C**** THIS SECTION CORRECTS FOR MAGNETS WHOSE FRINGING FIELDS INTERSECT RAY04740 C**** RAY04750 IF( NP .LE. 100) PRINT 102 RAY04760 102 FORMAT( / ' INTEGRATE BACKWARDS ' ) RAY04770 CALL FNMIRK( 6, T,-DTU ,TC, DTC, DS, ES, BFLD, 0 ) RAY04780 NSTEP = 0 RAY04790 16 CALL PRNT2 ( T,S,TC(1),TC(2),TC(3),BX,BY,BZ,BT,TC(4),TC(5),TC(6) )RAY04800 IF (JRAYGAS.NE.0) CALL PRNT2A DO 17 I =1, NP RAY04810 CALL FNMIRK( 6, T,-DTU, TC, DTC, DS, ES, BFLD, 1 ) RAY04820 NSTEP = NSTEP + 1 RAY04830 NUM = NUM+1 TPAR = T*VEL NBR = 3 CALL PLT1 ( NUM, NO, NBR, TPAR ) IF (NSTEP .GT. 10000) GO TO 99 RAY04831 IF( TC(3) .LE. Z21 ) GO TO 18 RAY04840 17 CONTINUE RAY04850 GO TO 16 RAY04860 18 CONTINUE RAY04870 XDTU = ( Z21 - TC(3) ) /DABS( TC(6) ) RAY04880 CALL FNMIRK( 6, T,XDTU ,TC, DTC, DS, ES, BFLD, 0 ) RAY04890 CALL FNMIRK( 6, T,XDTU ,TC, DTC, DS, ES, BFLD, 1 ) RAY04900 CALL PRNT2 ( T,S,TC(1),TC(2),TC(3),BX,BY,BZ,BT,TC(4),TC(5),TC(6) )RAY04910 IF (JRAYGAS.NE.0) CALL PRNT2A NUM = NUM+1 TPAR = T*VEL NBR = 3 CALL PLT1 ( NUM, NO, NBR, TPAR ) IF( NP .LE. 100) PRINT 105, NSTEP RAY04920 IF( NP .LE. 100) PRINT 107 RAY04930 107 FORMAT( / ) RAY04940 GO TO 19 RAY04950 C**** RAY04960 C**** RAY04970 15 CONTINUE RAY04980 CALL FNMIRK( 6, T, DTU ,TC, DTC, DS, ES, BFLD , 0 ) RAY12720 NSTEP = 0 RAY12730 9 CALL PRNT2 ( T,S,TC(1),TC(2),TC(3),BX,BY,BZ,BT,TC(4),TC(5),TC(6) )RAY12740 IF (JRAYGAS.NE.0) CALL PRNT2A DO 10 I =1, NP RAY12750 CALL FNMIRK( 6, T, DTU ,TC, DTC, DS, ES, BFLD , 1 ) RAY12760 NSTEP = NSTEP + 1 RAY12770 NUM = NUM+1 TPAR = T*VEL NBR = 3 CALL PLT1 ( NUM, NO, NBR, TPAR ) IF (NSTEP .GT. 10000) GO TO 99 RAY12771 19 CONTINUE RAY05140 IF( TC(3) .GE. Z21 ) GO TO 11 RAY12780 10 CONTINUE RAY12790 GO TO 9 RAY12800 11 CONTINUE RAY12810 XDTU = ( Z21 - TC(3) ) /DABS( TC(6) ) RAY12820 CALL FNMIRK( 6, T,XDTU ,TC, DTC, DS, ES,BFLD , 0 ) RAY12830 CALL FNMIRK( 6, T,XDTU ,TC, DTC, DS, ES,BFLD , 1 ) RAY12840 CALL PRNT2 ( T,S,TC(1),TC(2),TC(3),BX,BY,BZ,BT,TC(4),TC(5),TC(6) )RAY12850 IF (JRAYGAS.NE.0) CALL PRNT2A NUM = NUM+1 TPAR = T*VEL NBR = 3 CALL PLT1 ( NUM, NO, NBR, TPAR ) IF( NP .LE. 100) PRINT 105, NSTEP RAY12860 C*** RAY12870 C*** RAY12880 C**** SETUP FOR SECOND FRINGE FIELD AND INTEGRATION RAY12890 C**** RAY12900 C**** RAY12910 C0 = DATA( 25,NO ) RAY12920 C1 = DATA( 26,NO ) RAY12930 C2 = DATA( 27,NO ) RAY12940 C3 = DATA( 28,NO ) RAY12950 C4 = DATA( 29,NO ) RAY12960 C5 = DATA( 30,NO ) RAY12970 IN = 3 RAY12980 IF( NP .LE. 100) PRINT 104 RAY12990 CALL FNMIRK( 6, T, DTF2,TC, DTC, DS, ES, BFLD , 0 ) RAY13000 NSTEP = 0 RAY13010 12 CALL PRNT2 ( T,S,TC(1),TC(2),TC(3),BX,BY,BZ,BT,TC(4),TC(5),TC(6) )RAY13020 IF (JRAYGAS.NE.0) CALL PRNT2A DO 13 I =1, NP RAY13030 CALL FNMIRK( 6, T, DTF2,TC, DTC, DS, ES, BFLD , 1 ) RAY13040 NSTEP = NSTEP + 1 RAY13050 NUM = NUM+1 TPAR = T*VEL NBR = 3 CALL PLT1 ( NUM, NO, NBR, TPAR ) IF (NSTEP .GT. 10000) GO TO 99 RAY13051 IF( TC(3) .GE. Z22 ) GO TO 14 RAY13060 13 CONTINUE RAY13070 GO TO 12 RAY13080 14 CONTINUE RAY13090 XDTF2 = ( Z22 - TC(3) ) / TC(6) RAY13100 CALL FNMIRK( 6, T,XDTF2,TC, DTC, DS, ES, BFLD , 0 ) RAY13110 CALL FNMIRK( 6, T,XDTF2,TC, DTC, DS, ES, BFLD , 1 ) RAY13120 CALL PRNT2 ( T,S,TC(1),TC(2),TC(3),BX,BY,BZ,BT,TC(4),TC(5),TC(6) )RAY13130 IF (JRAYGAS.NE.0) CALL PRNT2A NUM = NUM+1 TPAR = T*VEL NBR = 3 CALL PLT1 ( NUM, NO, NBR, TPAR ) IF( NP .LE. 100) PRINT 105, NSTEP RAY13140 C**** RAY13150 C**** TRANSFORM TO OUTPUT SYSTEM COORD. RAY13160 C**** RAY13170 TC(3) = TC(3) - B RAY13180 IF( NP .LE. 100) PRINT 109 RAY13190 CALL PRNT2 ( T,S,TC(1),TC(2),TC(3),BX,BY,BZ,BT,TC(4),TC(5),TC(6) )RAY13200 IF (JRAYGAS.NE.0) CALL PRNT2A C**** RAY13210 C**** TRANSLATE PARTICLE TO OUT SYSTEM COORD. RAY13220 C**** RAY13230 TDT = -TC(3) /DABS( TC(6) ) RAY13240 TC(1) = TC(1) + TDT * TC(4) RAY13250 TC(2) = TC(2) + TDT * TC(5) RAY13260 TC(3) = TC(3) + TDT * TC(6) RAY13270 T = T + TDT RAY13280 TP = T * VEL RAY13290 BX = 0. RAY13300 BY = 0. RAY13310 BZ = 0. RAY13320 BT = 0. RAY13330 S = 0. RAY13340 VXF = 1000. *DATAN2( TC(4), TC(6) ) RAY13350 VYF = 1000. *DASIN ( TC(5)/ VEL ) RAY13360 VZF = TC(6) / VEL RAY13370 IF( NP .LE. 100) PRINT 115,TP,TC(1),TC(2),TC(3),VZF,VXF,VYF RAY13380 115 FORMAT( F10.4, 10X, F10.3, 11X, F10.3, 11X, F10.3, 11X, RAY13390 1 F13.5, F13.2, F11.2 ) RAY13400 NUM = NUM+1 TPAR = T*VEL NBR = 4 CALL PLT1 ( NUM, NO, NBR, TPAR ) C**** RAY13410 C**** CALCULATE INTERCEPTS IN SYSTEM D RAY13420 C**** RAY13430 C**** RAY13440 C**** RAY13450 Z0X = -TC(1)/ ( TC(4) / TC(6) + 1.E-10 ) RAY13460 Z0Y = -TC(2)/ ( TC(5) / TC(6) + 1.E-10 ) RAY13470 IF( NP .LE. 100) PRINT 111, VXF, VYF, Z0X, Z0Y RAY13480 111 FORMAT( / ' INTERSECTIONS WITH VER. AND HOR. PLANES ' , RAY13490 X /15X, 5H XP=F10.4, 10H MR YP= F10.4, 3H MR / RAY13500 1 15X, 5H Z0X=F10.2, 10H CM Z0Y= F10.2, 3H CM / )RAY13510 RETURN RAY13520 99 CALL PRNT4 (NO, IN) RAY13521 RETURN RAY13522 END RAY13530 SUBROUTINE NDIP RAY08980 C**** RAY08990 C**** RAY09000 C**** MTYP = 3 OR 4 RAY09010 C**** THIS VERSION OF BFUN IS MAINLY FOR NONUNIFORM FIELD MAGNETS RAY09020 C**** THE CENTRAL FIELD REGION IS REPRESENTED TO 3'RD ORDER ON-AND- RAY09030 C**** OFF THE MIDPLANE BY ANALYTIC EXPRESSIONS. SEE SLAC NO. 75 RAY09040 C**** FRINGE FIELD REGIONS REPRESENTED BY FERMI TYPE FALL-OFF RAY09050 C**** ALONG WITH RADIAL FALL-OFF RAY09060 C**** COMPONENTS OF 'B' IN FRINGE REGION EVALUATED BY NUMERICAL METHODS RAY09070 C**** RAY09080 C**** RAY09090 C**** THE RELATIONSHIP BETWEEN B0, ......... B12 AND B(I,J) RELATIVE TO RAY09100 C**** AXES (Z,X) IS GIVEN BY RAY09110 C**** RAY09120 C**** RAY09130 C**** B0 = B( 0, 0 ) RAY09140 C**** B1 = B( 1, 0 ) RAY09150 C**** B2 = B( 2, 0 ) RAY09160 C**** B3 = B( 1, 1 ) RAY09170 C**** B4 = B( 1,-1 ) RAY09180 C**** B5 = B( 0, 1 ) RAY09190 C**** B6 = B( 0, 2 ) RAY09200 C**** B7 = B( 0,-1 ) RAY09210 C**** B8 = B( 0,-2 ) RAY09220 C**** B9 = B(-1, 0 ) RAY09230 C**** B10 = B(-2, 0 ) RAY09240 C**** B11 = B(-1, 1 ) RAY09250 C**** B12 = B(-1,-1 ) RAY09260 C**** RAY09270 C**** RAY09280 IMPLICIT REAL*8(A-H,O-Z) RAY09290 REAL*8 NDX, K RAY09300 COMMON /BLCK10/ BX, BY, BZ, K, TC, DTC RAY09310 COMMON /BLCK20/ NDX,BET1,GAMA,DELT,CSC RAY09320 COMMON /BLCK21/ RCA,DELS,BR,S2,S3,S4,S5,S6,S7,S8,SCOR RAY09330 COMMON /BLCK22/ D, DG, S, BF, BT RAY09340 COMMON /BLCK23/ C0, C1, C2, C3, C4, C5 RAY09350 COMMON /BLCK24/ RB, XC, ZC RAY09360 COMMON /BLCK25/ IN, MTYP RAY09370 DIMENSION TC(6), DTC(6) RAY09380 X = TC(1) RAY09390 Y = TC(2) RAY09400 Z = TC(3) RAY09410 DX = X - XC RAY09420 DZ = Z - ZC RAY09430 RP =DSQRT( DX**2 + DZ**2 ) RAY09440 DR = RP - RB RAY09450 GO TO ( 1, 2, 3, 14 ), IN RAY09460 7 PRINT 8, IN, MTYP RAY09470 CALL EXIT RAY09480 8 FORMAT ( '0 ERROR -GO TO - IN BFUN IN=', I3, ' MTYP=',I4 )RAY09490 2 DRR1 = DR/RB RAY09500 DRR2 = DRR1*DRR1 RAY09510 DRR3 = DRR2*DRR1 RAY09520 DRR4 = DRR3*DRR1 RAY09530 IF( Y .NE. 0. ) GO TO 4 RAY09540 BX = 0. RAY09550 BY = 0. RAY09560 IF( MTYP .EQ. 3) BY= RAY09570 1 BF* ( 1. - NDX*DRR1 + BET1*DRR2 + GAMA*DRR3 + DELT*DRR4 ) RAY09580 IF( MTYP .EQ. 4) BY= BF/ (1. + NDX*DRR1 ) RAY09590 BZ = 0. RAY09600 BT = BY RAY09610 RETURN RAY09620 4 YR1 = Y/RB RAY09630 YR2 = YR1*YR1 RAY09640 YR3 = YR2*YR1 RAY09650 YR4 = YR3*YR1 RAY09660 RR1 = RB/RP RAY09670 RR2 = RR1*RR1 RAY09680 RR3 = RR2*RR1 RAY09690 IF( MTYP .EQ. 3 ) GO TO 11 RAY09700 IF( MTYP .EQ. 4 ) GO TO 12 RAY09710 GO TO 7 RAY09720 11 BRR = BF*( ( -NDX + 2.*BET1*DRR1 + 3.*GAMA*DRR2 + 4.*DELT*DRR3 ) RAY09730 1 *YR1 - (NDX*RR2 + 2.*BET1*RR1*(1.-RR1*DRR1) + RAY09740 2 3.*GAMA*( 2. + 2.*RR1*DRR1 - RR2*DRR2 ) + RAY09750 3 4.*DELT*( 6.*DRR1 + 3.*RR1*DRR2 - RR2*DRR3 ))*YR3/6. ) RAY09760 BY = BF* ( 1. - NDX*DRR1 + BET1*DRR2 + GAMA*DRR3 + DELT*DRR4 - RAY09770 1 .5*YR2*( -NDX*RR1 + 2.*BET1*( 1. + RR1*DRR1) + RAY09780 2 3.*GAMA*DRR1*( 2. + RR1*DRR1) + 4.*DELT*DRR2*(3. + RR1*DRR1) ) RAY09790 3 + YR4*( -NDX*RR3 + 2.*BET1*( RR3*DRR1 - RR2) + RAY09800 4 3.*GAMA*( 4.*RR1 - 2.*RR2*DRR1 + RR3*DRR2 ) + RAY09810 5 4.*DELT*( 6. + 12.*RR1*DRR1 - 3.*RR2*DRR2 + RR3*DRR3 ) )/24. ) RAY09820 GO TO 13 RAY09830 12 DNR1 = 1. + NDX*DRR1 RAY09840 DNR2 = DNR1*DNR1 RAY09850 DNR3 = DNR2*DNR1 RAY09860 DNR4 = DNR3*DNR1 RAY09870 DNR5 = DNR4*DNR1 RAY09880 BRR = BF*NDX*( -YR1/DNR2 + YR3*( 6.*NDX*NDX/DNR4 - RAY09890 1 2.*NDX*RR1/DNR3 - RR2/DNR2 ) /6. ) RAY09900 BY = BF*( 1./DNR1 + .5*YR2*NDX*( -2.*NDX/DNR3 + RR1/DNR2) + RAY09910 2 YR4*NDX*( 24.*NDX**3 /DNR5 - 12.*NDX*NDX*RR1/DNR4 - RAY09920 3 2.*NDX*RR2/DNR3 - RR3/DNR2 ) /24. ) RAY09930 13 BX = BRR*DX/RP RAY09940 BZ = BRR*DZ/RP RAY09950 BT =DSQRT(BX*BX + BY*BY + BZ*BZ) RAY09960 RETURN RAY09970 C**** RAY09980 C**** RAY09990 1 SINE = -1. RAY10000 GO TO 5 RAY10010 3 SINE = 1. RAY10020 5 IF( Z .GT. 0. ) DR = X * SINE*CSC RAY10030 CALL NDPP( B0, Z, X, Y, DR ) RAY10040 IF( Y .NE. 0. ) GO TO 6 RAY10050 BX = 0. RAY10060 BY = B0 RAY10070 BZ = 0. RAY10080 BT = B0 RAY10090 RETURN RAY10100 C**** RAY10110 C**** RAY10120 6 IF( Z .GT. 0. ) GO TO 9 RAY10130 DR1 = (DSQRT( DX**2 + (DZ+DG)**2 ) - RB ) RAY10140 DR2 = (DSQRT( DX**2 + (DZ+2.*DG)**2 ) - RB ) RAY10150 DR3 = (DSQRT( (DX+DG)**2 + (DZ+DG)**2 ) - RB ) RAY10160 DR4 = (DSQRT( (DX-DG)**2 + (DZ+DG)**2 ) - RB ) RAY10170 DR5 = (DSQRT( (DX+DG)**2 + DZ**2 ) - RB ) RAY10180 DR6 = (DSQRT( (DX+ 2.*DG)**2 + DZ**2 ) - RB ) RAY10190 DR7 = (DSQRT( (DX-DG)**2 + DZ**2 ) - RB ) RAY10200 DR8 = (DSQRT( (DX- 2.*DG)**2 + DZ**2 ) - RB ) RAY10210 DR9 = (DSQRT( DX**2 + (DZ-DG)**2 ) - RB ) RAY10220 DR10 = (DSQRT( DX**2 + (DZ-2.*DG)**2 ) - RB ) RAY10230 DR11 = (DSQRT( (DX+DG)**2 + (DZ-DG)**2 ) - RB ) RAY10240 DR12 = (DSQRT( (DX-DG)**2 + (DZ-DG)**2 ) - RB ) RAY10250 GO TO 10 RAY10260 9 DR1 = SINE* X*CSC RAY10270 DR2 = DR1 RAY10280 DR9 = DR1 RAY10290 DR10 = DR1 RAY10300 DR3 = SINE* ( X + DG )*CSC RAY10310 DR5 = DR3 RAY10320 DR11 = DR3 RAY10330 DR4 = SINE*( X - DG )*CSC RAY10340 DR7 = DR4 RAY10350 DR12 = DR4 RAY10360 DR6 = SINE* ( X + 2.*DG )*CSC RAY10370 DR8 = SINE* ( X - 2.*DG )*CSC RAY10380 C**** RAY10390 C**** RAY10400 10 CALL NDPP ( B1 , Z + DG, X , Y , DR1 ) RAY10410 CALL NDPP ( B2 , Z + 2.*DG, X , Y , DR2 ) RAY10420 CALL NDPP ( B3 , Z + DG, X + DG , Y , DR3 ) RAY10430 CALL NDPP ( B4 , Z + DG, X - DG , Y , DR4 ) RAY10440 CALL NDPP ( B5 , Z , X + DG , Y, DR5 ) RAY10450 CALL NDPP ( B6 , Z , X + 2.*DG , Y , DR6 ) RAY10460 CALL NDPP ( B7 , Z , X - DG , Y, DR7 ) RAY10470 CALL NDPP ( B8 , Z , X - 2.*DG , Y , DR8 ) RAY10480 CALL NDPP ( B9 , Z - DG, X , Y , DR9 ) RAY10490 CALL NDPP ( B10, Z - 2.*DG, X, Y, DR10 ) RAY10500 CALL NDPP ( B11, Z - DG, X + DG , Y , DR11 ) RAY10510 CALL NDPP ( B12, Z - DG, X - DG , Y , DR12 ) RAY10520 YG1 = Y/DG RAY10530 YG2 = YG1**2 RAY10540 YG3 = YG1**3 RAY10550 YG4 = YG1**4 RAY10560 BX = YG1 * ( (B5-B7)*2./3. - (B6-B8)/12. ) + RAY10570 1 YG3*( (B5-B7)/6. - (B6-B8)/12. - RAY10580 2 (B3 + B11 - B4 - B12 - 2.*B5 + 2.*B7 ) / 12. ) RAY10590 BY = B0 - YG2*( ( B1 + B9 + B5 + B7 - 4.*B0 ) *2./3. - RAY10600 1 ( B2 + B10 + B6 + B8 - 4.*B0 ) / 24. ) + RAY10610 2 YG4* (-( B1 + B9 + B5 + B7 - 4.*B0 ) / 6. + RAY10620 3 ( B2 + B10 + B6 + B8 - 4.*B0 ) / 24. + RAY10630 4 ( B3 + B11 + B4 + B12 - 2.*B1 - 2.*B9 - RAY10640 5 2.*B5 - 2.*B7 + 4.*B0 ) / 12. ) RAY10650 BZ = YG1*( (B1 - B9 ) *2./3. - ( B2 - B10 ) /12. ) + RAY10660 1 YG3*( ( B1 - B9 ) / 6. - ( B2 - B10 ) / 12. - RAY10670 2 ( B3 + B4 - B11 - B12 - 2.*B1 + 2.*B9 ) / 12. ) RAY10680 BT =DSQRT(BX*BX + BY*BY + BZ*BZ) RAY10690 RETURN RAY10700 14 BX = 0. RAY10710 BY = BR RAY10720 BZ = 0. RAY10730 BT = BR RAY10740 RETURN RAY10750 END RAY10760 SUBROUTINE NDPP ( BFLD, Z, X, Y , DR ) RAY10770 C**** RAY10780 C**** RAY10790 C**** RAY10800 C**** RAY10810 IMPLICIT REAL*8(A-H,O-Z) RAY10820 REAL*8 NDX, K RAY10830 COMMON /BLCK10/ BX, BY, BZ, K, TC, DTC RAY10840 COMMON /BLCK20/ NDX,BET1,GAMA,DELT,CSC RAY10850 COMMON /BLCK21/ RCA,DELS,BR,S2,S3,S4,S5,S6,S7,S8,SCOR RAY10860 COMMON /BLCK22/ D, DG, S, BF, BT RAY10870 COMMON /BLCK23/ C0, C1, C2, C3, C4, C5 RAY10880 COMMON /BLCK24/ RB, XC, ZC RAY10890 COMMON /BLCK25/ IN, MTYP RAY10900 DIMENSION TC(6), DTC(6) RAY10910 DRR1 = DR/RB RAY10920 DRR2 = DRR1*DRR1 RAY10930 DRR3 = DRR2*DRR1 RAY10940 DRR4 = DRR3*DRR1 RAY10950 C**** RAY06940 C**** MTYP : MODIFIED ITERATIVE PROCEDURE RAY06950 C**** RAY06960 XP = X RAY06970 XP2 = XP*XP RAY06980 XP3 = XP2*XP RAY06990 XP4 = XP3 * XP RAY07000 ZP = -(S2*XP2 + S3*XP3 + S4*XP4 + S5*XP4*XP + S6*XP4*XP2 + RAY07010 1 S7*XP4*XP3 + S8*XP4*XP4 ) RAY07020 AZ = (Z-ZP)/10.D0 RAY07030 AZMAX = DSQRT( X*X + Z*Z ) IF( AZ .GT. AZMAX ) AZ = AZMAX ZSIGN = Z-ZP RINV4 = 0. DO 11 I=1,21 RAY07040 XP = X + AZ*(I-11) RAY07050 XP2 = XP*XP RAY07060 XP3 = XP2*XP RAY07070 XP4 = XP3*XP RAY07080 ZP = -(S2*XP2 + S3*XP3 + S4*XP4 + S5*XP4*XP + S6*XP4*XP2 + RAY07090 1 S7*XP4*XP3 + S8*XP4*XP4 ) RAY07100 XXP = X-XP RAY07110 ZZP = Z-ZP RAY07120 DD = XXP*XXP + ZZP*ZZP IF( DD .LT. 1.D-15 ) DD = 1.D-15 IF( DD .GT. 1.D15 ) DD = 1.D15 RINV4 = RINV4 + 1.0D0 / (DD*DD ) 11 CONTINUE RAY07160 DP = DSQRT( 1.D0/RINV4 ) DP = DSQRT( DP ) S = 1.9023D0* DSIGN( 1.D0, ZSIGN ) * DP/D - DELS C**** RAY10960 C**** FIRST GUESS FOR CLOSEST POINT IS RAY10970 C**** RAY10980 C* XP = X RAY10990 C* XP2 = XP*XP RAY11000 C* XP3 = XP2*XP RAY11010 C* XP4 = XP3*XP RAY11020 C**** RAY11030 C**** CALCULATE ZP ON CURVE FOR CORRESPONDING XP RAY11040 C**** RAY11050 C* ZP = -( S2*XP2 + S3*XP3 + S4*XP4 + S5*XP4*XP + S6*XP4*XP2 + RAY11060 C* 1 S7*XP4*XP3 + S8*XP4*XP4 ) RAY11070 C* ZSIGN = Z-ZP RAY11080 C**** RAY11090 C**** SLOPE OF CURVE AT XP, ZP RAY11100 C**** RAY11110 C* DO 4 I=1,3 RAY11120 C* DZDXC = -(2.*S2*XP + 3.*S3*XP2+ 4.*S4*XP3 + 5.*S5*XP4 + RAY11130 C* 1 6.*S6*XP4*XP + 7.*S7*XP4*XP2 + 8.*S8*XP4*XP3 ) RAY11140 C**** RAY11150 C**** NEXT APPROXIMATION TO CLOSEST POINT IS RAY11160 C**** RAY11170 C* XP = ( DZDXC*(Z-ZP) + DZDXC*DZDXC*XP + X ) / (1.+DZDXC*DZDXC) RAY11180 C* IF( I .EQ. 1 ) XP = (3.*XP + X ) / 4. RAY11190 C* XP2 = XP*XP RAY11200 C* XP3 = XP2*XP RAY11210 C* XP4 = XP3*XP RAY11220 C* ZP = -( S2*XP2 + S3*XP3 + S4*XP4 + S5*XP4*XP + S6*XP4*XP2 + RAY11230 C* 1 S7*XP4*XP3 + S8*XP4*XP4 ) RAY11240 C* 4 CONTINUE RAY11250 C* XXP = X-XP RAY11260 C* ZZP = Z-ZP RAY11270 C* S = DSIGN( 1.D0,ZSIGN) * DSQRT( XXP*XXP + ZZP*ZZP) / D - DELS RAY11280 C**** C**** C**** C**** CS=C0+S*(C1+S*(C2+S*(C3+S*(C4+S*C5)))) RAY11290 IF( DABS(CS) .GT. 70. ) CS =DSIGN( 70.D0 ,CS ) RAY11300 E=DEXP(CS) RAY11310 P0 = 1.0 + E RAY11320 DB=BF-BR RAY11330 BFLD = 0. RAY11340 IF( MTYP .EQ. 3 ) BFLD = RAY11350 1 BR +( 1. - NDX*DRR1 + BET1*DRR2+GAMA*DRR3+DELT*DRR4)*DB/P0 RAY11360 IF( MTYP .EQ. 4 ) BFLD = BR + ( 1./(1. +NDX*DRR1) )*DB/P0 RAY11370 C**** C**** PRINT 100, X, Y, Z, DR, S, BFLD C*100 FORMAT( 1P6D15.4 ) C**** RETURN RAY11380 END RAY11390 SUBROUTINE OPTIC( J, JFOCAL, NP, T, TP ) RAY28750 C**** RAY28760 C**** RAY28770 C**** RAY28780 IMPLICIT REAL*8(A-H,O-Z) RAY28790 COMMON /BLCK 2/ XO, YO, ZO, VXO, VYO, VZO, RTL(100), RLL(100) RAY28800 COMMON /BLCK 3/ XINT, YINT, ZINT, TH0, PH0, TL1 RAY28810 COMMON /BLCK 4/ ENERGY, VEL, PMASS, Q0 RAY28820 COMMON /BLCK 5/ XA, YA, ZA, VXA, VYA, VZA RAY28830 DIMENSION XO(100), YO(100), ZO(100), VXO(100), VYO(100), VZO(100) RAY28840 C**** DATA C/ 3.D10/ RAY28850 C**** RAY28860 C**** RAY28870 100 FORMAT( / ' INTERSECTION POINT IN XZ-PLANE OF CENTRAL RAY AND THIRAY28880 1S RAY ' ) RAY28890 101 FORMAT( ' (IN D AXIS SYSTEM ) ' ) RAY28900 102 FORMAT( ' (IN OPTIC AXIS SYSTEM ) ' ) RAY28910 103 FORMAT( / ' RAY PARAMETERS AT THE FOCAL AXIS SYSTEM ' ) RAY28920 104 FORMAT( / ' COORDINATE TRANSFORMATION TO OPTIC AXIS SYSTEM ' ) RAY28930 C**** RAY28940 C**** RAY28950 C**** RAY28960 105 FORMAT( / ' *****************************************************RAY28970 1************************************************************'/ ) RAY28980 IF( NP .LE. 100) PRINT 105 RAY28990 IF( J .GT. 2 ) GO TO 19 RAY29000 IF( J .EQ. 1 ) GO TO 15 RAY29010 IF( J .EQ. 2) GO TO 18 RAY29020 CALL EXIT RAY29030 15 B1X = XA RAY29040 B1Y = YA RAY29050 S1X = VXA/VZA RAY29060 S1Y = VYA/VZA RAY29070 TT = T VEL1 = VEL VZA1 = VZA S1XP = DATAN2( VXA,VZA ) RAY29080 COS1 =DCOS(S1XP) RAY29090 SIN1 =DSIN(S1XP) RAY29100 ZZZZ = 0. RAY29110 TT1 = TT*1.0D+09 TL1 = TT*VEL TH0 = 1000. * S1XP RAY29111 PH0 = 1000. * DASIN (VYA/VEL) RAY29112 GO TO 17 RAY29120 18 B2X = XA RAY29130 B2Y = YA RAY29140 S2X = VXA/VZA RAY29150 S2Y = VYA/VZA RAY29160 C**** RAY29170 C**** CALCULATE CENTRAL AND PARAXIAL RAY INTERCEPTS IN SYSTEM - D RAY29180 C**** RAY29190 DSX = S1X-S2X RAY29200 IF( DSX .EQ. 0. ) DSX = 1.D-30 RAY29210 ZINT = ( B2X-B1X) / DSX RAY29220 XINT = ( B2X*S1X - B1X*S2X ) / DSX RAY29230 YINT = S2Y*ZINT + B2Y RAY29240 IF( NP .GT. 100 ) GO TO 5 RAY29330 PRINT 100 RAY29420 PRINT 101 RAY29430 PRINT 114, XINT, YINT, ZINT RAY29440 114 FORMAT( 14X, 6HXXINT= F11.4, 3H CM , / RAY29450 1 14X, 6HYYINT= F11.4, 3H CM , / RAY29460 2 14X, 6HZZINT= F11.4, 3H CM , / ) RAY29470 115 FORMAT( F10.4, 10X, F10.3, 11X, F10.3, 11X, F10.3, 11X, RAY29480 1 F13.5, F13.2, F11.2 ) RAY29490 C**** RAY29500 C**** ALTERATION OF INTERCEPTS TO OPTIC AXIS SYSTEM RAY29510 C**** RAY29520 5 ZINTZ = ZINT*COS1 + (XINT-B1X) *SIN1 RAY29530 XINTX =-ZINT*SIN1 + (XINT-B1X) *COS1 RAY29540 ZZZZ = ZINTZ RAY29550 IF( JFOCAL .NE. 0 ) ZZZZ = 0. RAY29560 C**** C**** FLIGHT PATH AND TIME FOR RAY-1 IN FOCAL AXIS SYSTEM C**** TT = TT + ZZZZ/DABS(VZA1) TT1 = TT*1.0D+09 TL1 = TT*VEL1 IF( NP .GT. 100 ) GO TO 17 RAY29570 PRINT 102 RAY29580 PRINT 114, XINTX, YINT, ZINTZ RAY29590 GO TO 17 RAY29600 C**** C**** GENERAL RAY INTERCEPTS IN D-AXIS SYSTEM C**** 19 BJX = XA RAY29610 BJY = YA RAY29620 SJX = VXA/VZA RAY29630 SJY = VYA/VZA RAY29640 DSX = S1X-SJX RAY29650 IF( DSX .EQ. 0. ) DSX = 1.D-30 RAY29660 XINT1 = ( BJX*S1X - B1X*SJX ) / DSX RAY29670 ZINT1 = ( BJX - B1X ) / DSX RAY29680 YINT1 = SJY*ZINT1 + BJY RAY29690 IF( NP .GT. 100 ) GO TO 17 RAY29740 PRINT 100 RAY29790 PRINT 101 RAY29800 PRINT 114, XINT1, YINT1, ZINT1 RAY29810 C**** RAY29820 C**** TRANSFORM SYSTEM-D TO OPTIC AXIS SYSTEM RAY29830 C**** TRANSLATE TO (B1X,0) AND ROTATE BY (S1X,0) RAY29840 C**** RAY29850 17 XT = XA RAY29860 ZT = ZA RAY29870 VXT = VXA RAY29880 VZT = VZA RAY29890 IF(JFOCAL .EQ. 3) GO TO 217 !NO CHANGE IN COORDS.!JDL 6-MAR-84 XA = XT - B1X !JDL 6-MAR-84 IF(JFOCAL .EQ. 2) GO TO 217 !TRANSLATE IN X ONLY !JDL 6-MAR-84 ZA = ZT*COS1 + ( XT-B1X ) *SIN1 RAY29900 XA =-ZT*SIN1 + ( XT-B1X ) *COS1 RAY29910 VZA = VZT*COS1 + VXT*SIN1 RAY29920 VXA =-VZT*SIN1 + VXT*COS1 RAY29930 217 CONTINUE !JDL 6-MAR-84 VXP = 1000. *DATAN2( VXA,VZA ) RAY29940 VYP = 1000. * DASIN( VYA/VEL ) RAY29950 VZP = VZA / VEL RAY29960 TP = T * VEL RAY29970 IF( NP .GT. 100 ) GO TO 16 RAY29980 PRINT 104 RAY29990 C**** RAY30000 PRINT 115, TP, XA, YA, ZA, VZP, VXP, VYP RAY30010 16 TDT = -ZA /DABS( VZA ) RAY30020 XA = XA + TDT * VXA RAY30030 YA = YA + TDT * VYA RAY30040 ZA = ZA + TDT * VZA RAY30050 T = T + TDT RAY30060 VXP = 1000. *DATAN2( VXA,VZA ) RAY30070 VYP = 1000. * DASIN( VYA/VEL ) RAY30080 VZP = VZA / VEL RAY30090 TP = T * VEL RAY30100 C**** C**** TRANSLATE PARTICLE TO FOCAL AXIS SYSTEM C**** XINT2= XA + ZZZZ* VXA/VZA RAY30110 YINT2= YA + ZZZZ* VYA/VZA RAY30120 ZINT2 = 0. C**** C**** TT = T + ZZZZ/DABS(VZA) TTJ = TT*1.0D+09 TLJ = TT*VEL C**** C**** PATH LENGTHS AND TIMES RELATIVE TO RAY-1 C**** TTJ1 = TTJ - TT1 TLJ1 = TLJ - TL1 C**** C**** XO(J) = XINT2 RAY30200 YO(J) = YINT2 RAY30210 ZO(J) = ZA RAY30220 VXO(J) = VXP RAY30230 VYO(J) = VYP RAY30240 VZO(J) = VZP RAY30250 C**** C**** SAVE TIME DIFFERENCES IN UNITS OF VELOCITY OF RAY-1 C**** RTL(J) = TTJ1*VEL1*1.0D-09 RAY30260 RLL(J) = TLJ1 IF( NP .GT. 100 ) RETURN RAY30270 PRINT 115, TP, XA, YA, ZA, VZP, VXP, VYP RAY30140 PRINT 103 RAY30150 PRINT 116, XINT2,VXP, YINT2,VYP,ZINT2,TLJ,TLJ1,TTJ,TTJ1 RAY30160 116 FORMAT( / 20X, 'X=', F10.4, ' CM', 5X, 'VX=',F10.4,' MR', / RAY30170 1 20X, 'Y=', F10.4, ' CM', 5X, 'VY=',F10.4,' MR', / RAY30180 2 20X, 'Z=', F10.4, ' CM' / RAY30190 3 20X, 'L=', F10.4, ' CM', 5X,'DL=',F10.4, ' CM' / 4 20X, 'T=', F10.4, ' NS', 5X,'DT=',F10.4, ' NS' ) IF( JFOCAL .NE. 0 ) PRINT 99 RAY30280 99 FORMAT( / ' FOCAL POS FIXED BY INPUT DATA = IMAGE DISTANCE '/ )RAY30290 RETURN RAY30300 END RAY30310 SUBROUTINE PLTOUT ( JEN, J, NUM ) C**** C**** C**** THIS ROUTINE STORES STEP-BY-STEP POSITION INFORMATION FOR EACH C**** RAY FOR USE BY PLOTTING ROUTINES. C**** C**** IMPLICIT REAL*8 (A-H,O-Z) integer maxpoint parameter (maxpoint=5000) REAL*8 K LOGICAL LPLT COMMON /BLCK00/ LPLT COMMON /BLCK 5/ XA, YA, ZA, VXA, VYA, VZA COMMON /BLCK10/ BX, BY, BZ, K, TC, DTC DIMENSION TC(6), DTC(6) DIMENSION GRAPH(4,maxpoint), ICOR(maxpoint,2) C**** C**** C**** IF( NUM .GT. maxpoint ) NUM = maxpoint WRITE (1) JEN, J, NUM WRITE (1) ( GRAPH(1,IK),IK=1,NUM), ( GRAPH(2,IK),IK=1,NUM), 1 ( GRAPH(3,IK),IK=1,NUM), ( GRAPH(4,IK),IK=1,NUM) WRITE (1) ( ICOR(IK,1),IK=1,NUM), ( ICOR(IK,2),IK=1,NUM) RETURN C**** C**** ENTRY PLT1( NUM, NO, NBR, TPAR ) C**** C**** IF( .NOT. LPLT ) RETURN IF( NUM .GT. maxpoint ) RETURN GRAPH( 1,NUM) = TC(1) GRAPH( 2,NUM) = TC(2) GRAPH( 3,NUM) = TC(3) GRAPH( 4,NUM) = TPAR ICOR ( NUM,1) = NO ICOR ( NUM,2) = NBR RETURN C**** C**** ENTRY PLT2( NUM, NO, NBR, TPAR ) C**** C**** IF( .NOT. LPLT ) RETURN IF( NUM .GT. maxpoint ) RETURN GRAPH( 1,NUM) = XA GRAPH( 2,NUM) = YA GRAPH( 3,NUM) = ZA GRAPH( 4,NUM) = TPAR ICOR ( NUM,1) = NO ICOR ( NUM,2) = NBR RETURN END SUBROUTINE POLES ( NO, NP, T, TP ,NUM ) RAY14570 C**** RAY14580 C**** RAY14590 C**** MULTIPOLE RAY TRACING BY NUMERICAL INTEGRATION OF DIFFERENTIALRAY14600 C**** EQUATIONS OF MOTION. RAY14610 C T = TIME RAY14620 C TC(1) TO TC(6) = ( X, Y, Z, VX, VY, VZ ) RAY14630 C DTC(1) TO DTC(6) = ( VX, VY, VZ, VXDOT, VYDOT, VZDOT ) RAY14640 C**** RAY14650 C**** RAY14660 IMPLICIT REAL*8(A-H,O-Z) RAY14670 c REAL*4 DAET, TYME !JDL 31-OCT-84 REAL*8 LF1, LF2, LU1, K, L RAY14680 include 'rtcomm0.f' COMMON /BLCK 4/ ENERGY, VEL, PMASS, Q0 RAY14700 COMMON /BLCK 5/ XA, YA, ZA, VXA, VYA, VZA RAY14710 COMMON /BLCK10/ BX, BY, BZ, K, TC, DTC RAY14720 COMMON /BLCK60/ GAS,AGAS,ZGAS,ZION,PRESS,GASSIG,QAVER, !***MP 1-JAN-85 1 QFWHM,RHOGAS,GASK,EMASS,GASMFP,JRAY,Q00,NPASG !*** COMMON /BLCK90/ D, S, BT, GRAD1,GRAD2,GRAD3,GRAD4,GRAD5 RAY14730 COMMON /BLCK91/ C0, C1, C2, C3, C4, C5 RAY14740 COMMON /BLCK92/ IN RAY14750 C*JDL DIMENSION DATA( 75,30 ), ITITLE(30) !JDL 17-NOV-83 RAY14760 DIMENSION TC(6), DTC(6), DS(6), ES(6) RAY14770 EXTERNAL BPOLES RAY14780 C**** DATA C/ 3.D10/ RAY14790 C**** RAY14800 JRAYGAS = JRAY*GAS LF1 = DATA( 1,NO ) RAY14810 LU1 = DATA( 2,NO ) RAY14820 LF2 = DATA( 3,NO ) RAY14830 A = DATA( 10,NO ) RAY14840 B = DATA( 11,NO ) RAY14850 L = DATA( 12,NO ) RAY14860 RAD = DATA( 13,NO ) RAY14870 BQD = DATA( 14,NO ) RAY14880 BHX = DATA( 15,NO ) RAY14890 BOC = DATA( 16,NO ) RAY14900 BDC = DATA( 17,NO ) RAY14910 BDD = DATA( 18,NO ) RAY14920 Z11 = DATA( 19,NO ) RAY14930 Z12 = DATA( 20,NO ) RAY14940 Z21 = DATA( 21,NO ) RAY14950 Z22 = DATA( 22,NO ) RAY14960 DTF1= LF1/ VEL RAY14970 DTF2= LF2/ VEL RAY14980 DTU = LU1/ VEL RAY14990 D = 2. * RAD RAY15000 GRAD1 = -BQD/RAD RAY15010 GRAD2 = BHX/RAD**2 RAY15020 GRAD3 = -BOC/RAD**3 RAY15030 GRAD4 = BDC/RAD**4 RAY15040 GRAD5 = -BDD/RAD**5 RAY15050 BX = 0. RAY15060 BY = 0. RAY15070 BZ = 0. RAY15080 BT = 0. RAY15090 S = 0. RAY15100 C**** RAY15110 IF( NP .GT. 100 ) GO TO 5 RAY15120 PRINT 100, ITITLE(NO) RAY15130 100 FORMAT( ' MULTIPOLE(POLES) **** ', A4,' ******************'/) RAY15140 C**** RAY15150 PRINT 101 RAY15160 101 FORMAT( 8H T CM ,18X, 4HX CM , 7X, 2HBX, 8X, 4HY CM , 7X, 2HBY,RAY15170 1 8X, 4HZ CM, 7X, 2HBZ, 8X, 6HVELZ/C , 6X, 8HTHETA MR , 5X, RAY15180 2 6HPHI MR , 6X, 1HB ) RAY15190 CALL PRNT2 ( T,S,XA ,YA ,ZA ,BX,BY,BZ,BT,VXA ,VYA ,VZA )RAY15200 IF (JRAYGAS.NE.0) CALL PRNT2A PRINT 103 RAY15210 103 FORMAT( '0COORDINATE TRANSFORMATION TO B AXIS SYSTEM ' ) RAY15220 109 FORMAT( '0COORDINATE TRANSFORMATION TO D AXIS SYSTEM ' ) RAY15230 C**** TRANSFORM FROM INITIAL ENTRANCE COORDINATES TO VFB COORD. RAY15240 C**** RAY15250 5 TC(1) = -XA RAY15260 TC(2) = YA RAY15270 TC(3) = A - ZA RAY15280 TC(4) = -VXA RAY15290 TC(5) = VYA RAY15300 TC(6) = -VZA RAY15310 CALL PRNT2 ( T,S,TC(1),TC(2),TC(3),BX,BY,BZ,BT,TC(4),TC(5),TC(6) )RAY15320 IF (JRAYGAS.NE.0) CALL PRNT2A NUM = NUM+1 TPAR = T*VEL NBR = 2 CALL PLT1 ( NUM, NO, NBR, TPAR ) C**** RAY15330 C**** TRANSLATE PARTICLE TO START OF FIRST FRINGE FIELD RAY15340 C**** RAY15350 TDT = ( TC(3) - Z11 ) /DABS( TC(6) ) RAY15360 C**** RAY15370 TC(1) = TC(1) + TDT * TC(4) RAY15380 TC(2) = TC(2) + TDT * TC(5) RAY15390 TC(3) = TC(3) + TDT * TC(6) RAY15400 T = T + TDT RAY15410 NUM = NUM+1 TPAR = T*VEL NBR = 2 CALL PLT1 ( NUM, NO, NBR, TPAR ) C**** RAY15420 C**** IN DESIGNATES FIELD REGIONS FOR MULTIPOLE RAY15430 C**** RAY15440 IN = 1 RAY15450 C0 = DATA( 23,NO ) RAY15460 C1 = DATA( 24,NO ) RAY15470 C2 = DATA( 25,NO ) RAY15480 C3 = DATA( 26,NO ) RAY15490 C4 = DATA( 27,NO ) RAY15500 C5 = DATA( 28,NO ) RAY15510 IF( NP .LE. 100) PRINT 104 RAY15520 104 FORMAT( 22H0FRINGING FIELD REGION ) RAY15530 CALL FNMIRK( 6, T, DTF1,TC, DTC, DS, ES, BPOLES,0 ) RAY15540 NSTEP = 0 RAY15550 6 CALL PRNT2 ( T,S,TC(1),TC(2),TC(3),BX,BY,BZ,BT,TC(4),TC(5),TC(6) )RAY15560 IF (JRAYGAS.NE.0) CALL PRNT2A DO 7 I = 1, NP RAY15570 CALL FNMIRK( 6, T, DTF1,TC, DTC, DS, ES, BPOLES,1 ) RAY15580 NSTEP = NSTEP + 1 RAY15590 NUM = NUM+1 TPAR = T*VEL NBR = 2 CALL PLT1 ( NUM, NO, NBR, TPAR ) IF (NSTEP .GT. 10000) GO TO 99 RAY15591 IF( Z12 .GE. TC(3) ) GO TO 8 RAY15600 7 CONTINUE RAY15610 GO TO 6 RAY15620 8 CONTINUE RAY15630 XDTF1 =-( Z12 - TC(3) ) /DABS( TC(6) ) RAY15640 CALL FNMIRK( 6, T,XDTF1,TC, DTC, DS, ES,BPOLES, 0 ) RAY15650 CALL FNMIRK( 6, T,XDTF1,TC, DTC, DS, ES,BPOLES, 1 ) RAY15660 CALL PRNT2 ( T,S,TC(1),TC(2),TC(3),BX,BY,BZ,BT,TC(4),TC(5),TC(6) )RAY15670 IF (JRAYGAS.NE.0) CALL PRNT2A NUM = NUM+1 TPAR = T*VEL NBR = 2 CALL PLT1 ( NUM, NO, NBR, TPAR ) IF( NP .LE. 100) PRINT 105, NSTEP RAY15680 105 FORMAT( 10H NSTEPS= I5 ) RAY15690 C*** RAY15700 C*** UNIFORM FIELD REGION RAY15710 C**** TRANSFORM TO SECOND VFB COORD SYSTEM RAY15720 C*** RAY15730 GRAD1 = -GRAD1 RAY15740 GRAD2 = GRAD2 RAY15750 GRAD3 = -GRAD3 RAY15760 GRAD4 = GRAD4 RAY15770 GRAD5 = -GRAD5 RAY15780 TC(1) = -TC(1) RAY15790 TC(3) = -TC(3) - L RAY15800 TC(4) = -TC(4) RAY15810 TC(6) = -TC(6) RAY15820 C**** RAY15830 C**** RAY15840 C**** UNIFORM FIELD INTEGRATION REGION RAY15850 C**** RAY15860 C**** RAY15870 IN = 2 RAY15880 IF( NP .LE. 100) PRINT 106 RAY15890 106 FORMAT( '0UNIFORM FIELD REGION IN C AXIS SYSTEM ' ) RAY15900 IF( TC(3) .LT. Z21 ) GO TO 15 RAY04720 C**** RAY04730 C**** THIS SECTION CORRECTS FOR MAGNETS WHOSE FRINGING FIELDS INTERSECT RAY04740 C**** RAY04750 IF( NP .LE. 100) PRINT 102 RAY04760 102 FORMAT( / ' INTEGRATE BACKWARDS ' ) RAY04770 CALL FNMIRK( 6, T,-DTU ,TC, DTC, DS, ES,BPOLES, 0 ) RAY04780 NSTEP = 0 RAY04790 16 CALL PRNT2 ( T,S,TC(1),TC(2),TC(3),BX,BY,BZ,BT,TC(4),TC(5),TC(6) )RAY04800 IF (JRAYGAS.NE.0) CALL PRNT2A DO 17 I =1, NP RAY04810 CALL FNMIRK( 6, T,-DTU, TC, DTC, DS, ES,BPOLES, 1 ) RAY04820 NSTEP = NSTEP + 1 RAY04830 NUM = NUM+1 TPAR = T*VEL NBR = 3 CALL PLT1 ( NUM, NO, NBR, TPAR ) IF (NSTEP .GT. 10000) GO TO 99 RAY04831 IF( TC(3) .LE. Z21 ) GO TO 18 RAY04840 17 CONTINUE RAY04850 GO TO 16 RAY04860 18 CONTINUE RAY04870 XDTU = ( Z21 - TC(3) ) /DABS( TC(6) ) RAY04880 CALL FNMIRK( 6, T,XDTU ,TC, DTC, DS, ES,BPOLES, 0 ) RAY04890 CALL FNMIRK( 6, T,XDTU ,TC, DTC, DS, ES,BPOLES, 1 ) RAY04900 CALL PRNT2 ( T,S,TC(1),TC(2),TC(3),BX,BY,BZ,BT,TC(4),TC(5),TC(6) )RAY04910 IF (JRAYGAS.NE.0) CALL PRNT2A NUM = NUM+1 TPAR = T*VEL NBR = 3 CALL PLT1 ( NUM, NO, NBR, TPAR ) IF( NP .LE. 100) PRINT 105, NSTEP RAY04920 IF( NP .LE. 100) PRINT 107 RAY04930 107 FORMAT( / ) RAY04940 GO TO 19 RAY04950 C**** RAY04960 C**** RAY04970 15 CONTINUE RAY04980 CALL FNMIRK( 6, T, DTU ,TC, DTC, DS, ES, BPOLES,0 ) RAY15910 NSTEP = 0 RAY15920 9 CALL PRNT2 ( T,S,TC(1),TC(2),TC(3),BX,BY,BZ,BT,TC(4),TC(5),TC(6) )RAY15930 IF (JRAYGAS.NE.0) CALL PRNT2A DO 10 I =1, NP RAY15940 CALL FNMIRK( 6, T, DTU ,TC, DTC, DS, ES, BPOLES,1 ) RAY15950 NSTEP = NSTEP + 1 RAY15960 NUM = NUM+1 TPAR = T*VEL NBR = 3 CALL PLT1 ( NUM, NO, NBR, TPAR ) IF (NSTEP .GT. 10000) GO TO 99 RAY15961 IF( TC(3) .GE. Z21 ) GO TO 11 RAY15970 10 CONTINUE RAY15980 GO TO 9 RAY15990 11 CONTINUE RAY16000 XDTU = ( Z21 - TC(3) ) /DABS( TC(6) ) RAY16010 CALL FNMIRK( 6, T,XDTU ,TC, DTC, DS, ES,BPOLES, 0 ) RAY16020 CALL FNMIRK( 6, T,XDTU ,TC, DTC, DS, ES,BPOLES, 1 ) RAY16030 CALL PRNT2 ( T,S,TC(1),TC(2),TC(3),BX,BY,BZ,BT,TC(4),TC(5),TC(6) )RAY16040 IF (JRAYGAS.NE.0) CALL PRNT2A NUM = NUM+1 TPAR = T*VEL NBR = 3 CALL PLT1 ( NUM, NO, NBR, TPAR ) IF( NP .LE. 100) PRINT 105, NSTEP RAY16050 19 CONTINUE RAY05140 C*** RAY16060 C*** RAY16070 C**** SETUP FOR SECOND FRINGE FIELD AND INTEGRATION RAY16080 C**** RAY16090 C**** RAY16100 C0 = DATA( 29,NO ) RAY16110 C1 = DATA( 30,NO ) RAY16120 C2 = DATA( 31,NO ) RAY16130 C3 = DATA( 32,NO ) RAY16140 C4 = DATA( 33,NO ) RAY16150 C5 = DATA( 34,NO ) RAY16160 IN = 3 RAY16170 IF( NP .LE. 100) PRINT 104 RAY16180 CALL FNMIRK( 6, T, DTF2,TC, DTC, DS, ES, BPOLES,0 ) RAY16190 NSTEP = 0 RAY16200 12 CALL PRNT2 ( T,S,TC(1),TC(2),TC(3),BX,BY,BZ,BT,TC(4),TC(5),TC(6) )RAY16210 IF (JRAYGAS.NE.0) CALL PRNT2A DO 13 I =1, NP RAY16220 CALL FNMIRK( 6, T, DTF2,TC, DTC, DS, ES, BPOLES,1 ) RAY16230 NSTEP = NSTEP + 1 RAY16240 NUM = NUM+1 TPAR = T*VEL NBR = 3 CALL PLT1 ( NUM, NO, NBR, TPAR ) IF (NSTEP .GT. 10000) GO TO 99 RAY16241 IF( TC(3) .GE. Z22 ) GO TO 14 RAY16250 13 CONTINUE RAY16260 GO TO 12 RAY16270 14 CONTINUE RAY16280 XDTF2 = ( Z22 - TC(3) ) / TC(6) RAY16290 CALL FNMIRK( 6, T,XDTF2,TC, DTC, DS, ES, BPOLES,0 ) RAY16300 CALL FNMIRK( 6, T,XDTF2,TC, DTC, DS, ES, BPOLES,1 ) RAY16310 CALL PRNT2 ( T,S,TC(1),TC(2),TC(3),BX,BY,BZ,BT,TC(4),TC(5),TC(6) )RAY16320 IF (JRAYGAS.NE.0) CALL PRNT2A NUM = NUM+1 TPAR = T*VEL NBR = 3 CALL PLT1 ( NUM, NO, NBR, TPAR ) IF( NP .LE. 100) PRINT 105, NSTEP RAY16330 C**** RAY16340 C**** TRANSFORM TO OUTPUT SYSTEM COORD. RAY16350 C**** RAY16360 TC(3) = TC(3) - B RAY16370 IF( NP .LE. 100) PRINT 109 RAY16380 CALL PRNT2 ( T,S,TC(1),TC(2),TC(3),BX,BY,BZ,BT,TC(4),TC(5),TC(6) )RAY16390 IF (JRAYGAS.NE.0) CALL PRNT2A C**** RAY16400 C**** TRANSLATE PARTICLE TO OUT SYSTEM COORD. RAY16410 C**** RAY16420 TDT = -TC(3) /DABS( TC(6) ) RAY16430 TC(1) = TC(1) + TDT * TC(4) RAY16440 TC(2) = TC(2) + TDT * TC(5) RAY16450 TC(3) = TC(3) + TDT * TC(6) RAY16460 T = T + TDT RAY16470 TP = T * VEL RAY16480 BX = 0. RAY16490 BY = 0. RAY16500 BZ = 0. RAY16510 BT = 0. RAY16520 S = 0. RAY16530 VXF = 1000. *DATAN2( TC(4), TC(6) ) RAY16540 VYF = 1000. *DASIN ( TC(5)/ VEL ) RAY16550 VZF = TC(6) / VEL RAY16560 IF( NP .LE. 100) PRINT 115,TP,TC(1),TC(2),TC(3),VZF,VXF,VYF RAY16570 115 FORMAT( F10.4, 10X, F10.3, 11X, F10.3, 11X, F10.3, 11X, RAY16580 1 F13.5, F13.2, F11.2 ) RAY16590 NUM = NUM+1 TPAR = T*VEL NBR = 4 CALL PLT1 ( NUM, NO, NBR, TPAR ) C**** RAY16600 C**** CALCULATE INTERCEPTS IN SYSTEM D RAY16610 C**** RAY16620 C**** RAY16630 C**** RAY16640 C**** RAY16650 Z0X = -TC(1)/ ( TC(4) / TC(6) + 1.E-10 ) RAY16660 Z0Y = -TC(2)/ ( TC(5) / TC(6) + 1.E-10 ) RAY16670 IF( NP .LE. 100) PRINT 111, VXF, VYF, Z0X, Z0Y RAY16680 111 FORMAT( / ' INTERSECTIONS WITH VER. AND HOR. PLANES ' , RAY16690 X /15X, 5H XP=F10.4, 10H MR YP= F10.4, 3H MR / RAY16700 1 15X, 5H Z0X=F10.2, 10H CM Z0Y= F10.2, 3H CM / )RAY16710 RETURN RAY16720 99 CALL PRNT4 (NO, IN) RAY16721 RETURN RAY16722 END RAY16730 SUBROUTINE PPLOT (X,Y1,Y2,NFOLD1,NFOLD2,N,XLABEL,NPLOT,D) !JDL C C PPLOT PREPARES A GRAPHICAL DISPLAY OF N SETS OF DATA POINTS C IN 55 ROWS AND 120 COLUMNS ON ONE PRINTED PAGE. DATA NEED NOT C BE ARRANGED IN NUMERICAL ORDER. SCALES ARE SELECTED AUTOMATICALLY C IF D(1) THRU D(4) ARE ZERO; OTHERWISE, D(1) THRU D(4) SET SCALES. C THREE KINDS OF DISPLAY ARE PERMITTED: C NPLOT DISPLAY CHARACTER C C 1 X(I) VS. Y1(I) + C 2 X(I) VS. Y2(I) * C 3 X(I) VS. Y1(I),Y2(I) +,* C C WHEN NFOLD1 AND/OR NFOLD2 ARE NOT ZERO (OR ONE), +/* CHARACTERS C ARE REPLACED BY SUCCESSIVE LETTERS OF THE ALPHABET (UPPER CASE C FOR Y(1), LOWER CASE FOR Y2(I)), A NEW CHARACTER BEING USED C FOR EACH FOLDING OF THE DATA IN MULTIPLES OF NFOLD. C INTEGER XLABEL,A DIMENSION X(N),Y1(N),Y2(N),XLABEL(16),LCHAR1(27),LCHAR2(27) DIMENSION A(119),XNL(13),YNL(13),D(4),LABL(4) DATA LABL/1H ,1H.,1H+,1H*/ C DATA LCHAR1/1HA,1HB,1HC,1HD,1HE,1HF,1HG,1HH,1HI,1HJ, 1 1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,1HS,1HT, 2 1HU,1HV,1HW,1HX,1HY,1HZ,1H+/ DATA LCHAR2/1Ha,1Hb,1Hc,1Hd,1He,1Hf,1Hg,1Hh,1Hi,1Hj, 1 1Hk,1Hl,1Hm,1Hn,1Ho,1Hp,1Hq,1Hr,1Hs,1Ht, 2 1Hu,1Hv,1Hw,1Hx,1Hy,1Hz,1H*/ C C (1). FIND XMIN,XMAX,YMIN, AND YMAX. C IF((D(1) .EQ. 0.0) .AND. (D(2) .EQ. 0.0) .AND. 1 (D(3) .EQ. 0.0) .AND. (D(4) .EQ. 0.0)) GO TO 10 XMAX=AMAX1(D(1),D(3)) XMIN=AMIN1(D(1),D(3)) YMAX=AMAX1(D(2),D(4)) YMIN=AMIN1(D(2),D(4)) GO TO 60 C 10 XMIN=X(1) YMIN=Y1(1) IF(NPLOT .EQ. 2) YMIN=Y2(1) XMAX=XMIN YMAX=YMIN DO 50 J=1,N IF( X(J) .LT. XMIN) XMIN=X(J) IF( X(J) .GT. XMAX) XMAX=X(J) IF(NPLOT .EQ. 2) GO TO 20 IF(Y1(J) .LT. YMIN) YMIN=Y1(J) IF(Y1(J) .GT. YMAX) YMAX=Y1(J) IF(NPLOT .NE. 3) GO TO 50 20 IF(Y2(J) .LT. YMIN) YMIN=Y2(J) IF(Y2(J) .GT. YMAX) YMAX=Y2(J) 50 CONTINUE C C (2). COMPUTE NUMBER OF X AND Y UNITS PER SCALE DIVISION. C 60 DMIN=ABS(XMAX-XMIN)/120.0 L=1 GO TO 130 120 DMIN=ABS(YMAX-YMIN)/55.0 L=2 130 EX=1.0E+30 DO 140 I=1,60 IF(DMIN .LT. EX) GO TO 140 DM=DMIN/EX GO TO 150 140 EX=EX/10.0 DR=EX GO TO 160 150 J=12 IF(DM .GT. 1.2) J=15 IF(DM .GT. 1.5)J=20 IF(DM .GT. 2.0) J=25 IF(DM .GT. 2.5) J=INT(DM+1.0)*10 IF(J .EQ. 70) J=80 IF(J .EQ. 90) J=100 DR=FLOAT(J)*EX/10.0 160 IF(L .NE. 1) GO TO 170 C C (2A). COMPUTE SLOPE BX, MAJOR DIVISION BIGDX AND FIDUCIAL C DXR=DR XEX=EX BX=1.0/DXR BIGDX=10.0*DXR UNX=120.0*DXR-ABS(XMAX-XMIN) FXM=(XMIN-UNX/2.0)/BIGDX FX=FXM*BIGDX IF(ABS(FXM) .LT. 1.0E6) 1 FX=FLOAT(INT(FXM+SIGN(0.5,FXM)))*BIGDX IF(INT(BX*(XMIN-FX)+0.5) .LT. 1) FX=FX-BIGDX IF(INT(BX*(XMAX-FX)+0.5) .LT. 119) GO TO 120 GO TO 180 C C (2B). COMPUTE SLOPE BY, MAJOR DIVISION BIGDY AND FIDUCIAL C 170 DYR=DR YEX=EX BY=1.0/DYR BIGDY=5.0*DYR UNY= 55.0*DYR-ABS(YMAX-YMIN) FYM=(YMIN-UNY/2.0)/BIGDY FY=FYM*BIGDY IF(ABS(FYM) .LT. 1.0E6) 1 FY=FLOAT(INT(FYM+SIGN(0.5,FYM)))*BIGDY IF(INT(BY*(YMAX-FY)+0.5) .LT. 55) GO TO 200 C C (2C). PLOT EXCEEDS SPACE, CHANGE SCALE AND REPEAT. C 180 DM=1.10*DM GO TO 150 C C (4). DETERMINE SCALE FACTORS FOR X AND Y. C 200 CONTINUE AFX=ABS(FX+12.0*BIGDX) IF(ABS(FX) .GT. AFX) AFX=ABS(FX) 210 IF((AFX/XEX) .LT. 100.0) GO TO 220 XEX=XEX*10.0 GO TO 210 220 AFY=ABS(FY+11.0*BIGDY) IF(ABS(FY) .GT. AFY) AFY=ABS(FY) 230 IF((AFY/YEX) .LT. 100.0) GO TO 240 YEX=YEX*10.0 GO TO 230 240 CONTINUE C C (5). TRANSFORM X AND Y ARRAYS TO SCALE DIVISIONS. C DO 260 I=1,N NX=BX*(X(I)-FX)+.5 X(I)=NX IF(NPLOT .EQ. 2) GO TO 250 NY=BY*(Y1(I)-FY)+.5 Y1(I)=NY IF(NPLOT .NE. 3) GO TO 260 250 NY=BY*(Y2(I)-FY)+.5 Y2(I)=NY 260 CONTINUE C C (7). PREPARE NUMERICAL LABELS FOR AXES. C JDOT=0 DO 360 I=1,13 XNL(I)=(FX+BIGDX*FLOAT(I-1))/XEX YNL(I)=(FY+BIGDY*FLOAT(I-1))/YEX IF(XNL(I) .EQ. 0.0) JDOT=10*(I-1) 360 CONTINUE C C (8). PRINT TOP BORDER OF GRAPH. C PRINT 450, YNL(12) 450 FORMAT( 2H ,F6.2, 12(10HX+++++++++), 1HX ) C C (9). PRINT 55 LINES OF DATA AND Y-AXIS LABELS. C XI=0 DO 600 I=1,54 XI=XI+1 JJ=12-(I/5) DO 460 J=1,119 A(J)=LABL(1) IF((MOD(I,5) .EQ. 0) .AND. (YNL(JJ) .EQ. 0.0)) A(J)=LABL(2) 460 CONTINUE IF(JDOT .NE. 0) A(JDOT)=LABL(2) IF(NPLOT .EQ. 2) GO TO 480 DO 470 L=1,N IF(ABS(Y1(L)-(55.0-XI)) .GT. 1.0E-3) GO TO 470 KK=27 IF(NFOLD1 .GT. 1) KK=MOD(((L-1)/NFOLD1+1),26) LL=X(L)+.01 IF((LL .GE. 1) .AND. (LL .LE. 119)) A(LL)=LCHAR1(KK) 470 CONTINUE IF(NPLOT .NE. 3) GO TO 500 480 DO 490 L=1,N IF(ABS(Y2(L)-(55.0-XI)) .GT. 1.0E-3) GO TO 490 KK=27 IF(NFOLD2 .GT. 1) KK=MOD(((L-1)/NFOLD2+1),26) LL=X(L)+.01 IF((LL .GE. 1) .AND. (LL .LE. 119)) A(LL)=LCHAR2(KK) 490 CONTINUE 500 CONTINUE C*JDL IF(I .EQ. 2) GO TO 530 !REMOVE "RADIANS" LABEL ON Y-AXIS. IF(MOD(I,5) .EQ. 0) GO TO 580 IF(I .NE. 1) GO TO 550 YEX=ALOG10(YEX) J=INT(YEX+SIGN(0.1,YEX)) PRINT 520, J,A 520 FORMAT(1H ,2X,2H E,I3,1H+,119A1,1H+) GO TO 600 C*530 PRINT 540, A C*540 FORMAT(1H ,8HRADIANS+,119A1,1H+) C*JDL GO TO 600 550 PRINT 560, A 560 FORMAT(1H ,6X,2H +,119A1,1H+) GO TO 600 580 CONTINUE PRINT 590, YNL(JJ),A 590 FORMAT( 1H ,1X,F6.2,1HX,119A1,1HX) 600 CONTINUE C C (10). PRINT LOWER BORDER OF GRAPH AND X-AXIS LABEL. C PRINT 450, YNL(1) PRINT 690, (XNL(L),L=1,13) 690 FORMAT (1H ,13(4X,F6.2)) XEX=ALOG10(XEX) J=INT(XEX+SIGN(0.1,XEX)) 700 PRINT 710, XLABEL,J 710 FORMAT(1H ,20X,16A4,41X,2H E,I3) RETURN END C C SUBROUTINE PRNT( J,NO ) RAY30320 C**** RAY30330 C**** RAY30340 IMPLICIT REAL*8(A-H,O-Z) RAY30350 c REAL*4 DAET, TYME !JDL 31-OCT-84 character *4 nwd REAL*4 HORSV(1000), VERSV(1000), DD(4) !JDL 1-DEC-83 include 'rtcomm0.f' COMMON /BLCK 1/ XI, YI, ZI, VXI, VYI, VZI, DELP, DELM !JDL RAY30370 COMMON /BLCK 2/ XO, YO, ZO, VXO, VYO, VZO, RTL(100),RLL(100) RAY30380 COMMON /BLCK 3/ XINT, YINT, ZINT, TH0, PH0, TL1 !JDL 1-DEC-83 COMMON /BLCK 4/ ENERGY, VEL, PMASS, Q0 RAY30390 COMMON /BLCK 6/ NR, NP, NSKIP, JFOCAL, JMTRX, !JDL 16-MAR-84 RAY30400 1 JNR, NPLT, NRXS, LPAX, !JDL 31-OCT-84 2 NCAX,NHAX, NVAX, MEL, MCS, MCP, !JDL 31-OCT-84 3 DHAX,DVAX !JDL 31-0CT-84 COMMON /BLCK15/ TMIN,PMIN,XMAX,TMAX,YMAX,PMAX,DMAX, !JDL 1 STMN,SPMN,SXMX,STMX,SYMX,SPMX,SDMX,SUMX, !JDL 2 SEED,SEEP,DXHW,DTHW,DYHW,DPHW,DEHW,DMHW, !JDL 3 SEC1,SEC2,SEC3,SEC4,SEC5,SEC6,SEC7,SEC8 !JDL COMMON /BLCK16/ NLOOP,NPASS,IP,NCSV,KEEP(20), !JDL 17-NOV-83 1 LOOPSV(5,30),HOOPSV(30),HSAVE(30),PMSV(3), 2 CXXSV(12,3),CSV(36,3),CDSV(6,4,3)!JDL 17-NOV-83 COMMON /BLCK60/ GAS,AGAS,ZGAS,ZION,PRESS,GASSIG,QAVER, !***MP 1-JAN-85 1 QFWHM,RHOGAS,GASK,EMASS,GASMFP,JRAY,Q00,NPASG !*** COMMON /BLCK62/ GASENE,GASVEL,TOLD,GASL COMMON /BLCK61/ DEDX,ALPHAK,TOLD2,DEDXQ include 'rtcomm65.f' C*JDL DIMENSION DATA( 75,30 ), ITITLE(30) !JDL 17-NOV-83 RAY30410 DIMENSION VECK(10), JV(8), NBIN(26) !JDL 31-OCT-84 DIMENSION LABEL(48), NLNS(9) !JDL 31-OCT-84 DATA LABEL/ 4HRAY ,4HPLOT,4H: ,4H X(C, !JDL 31-OCT-84 1 4HM) ,4H ,4H ,4H , 2 4H^^ ,4H TH(,4HMR) ,4H VER, 3 4HSES ,4H X(C,4HM) ,4H >>, 4 4H X(C,4HM) ,4H TH(,4HMR) , 5 4H Y(C,4HM) ,4H PHI,4H(MR), 6 4H DL(,4HCM) ,4H DT(,4HNS) , 7 4H DE(,4HPCT),4H DM(,4HPCT), 8 4H ENE,4HRGY ,4H MA,4HSS , 9 4H COU,4HNTS ,4HALL-,4HCNTS, X 4HRAY ,4HPLOT,4HELLI,4HPSES, 1 4HSPEC,4HTRUM,4HCONT,4HOURS/ !JDL 31-OCT-84 DATA NLNS/ 1, 3, 5, 7, 9, 11, 15, 21, 25 / DIMENSION XO(100), YO(100), ZO(100), VXO(100), VYO(100), VZO(100) RAY30420 DIMENSION XI(100), YI(100), ZI(100), VXI(100), VYI(100), VZI(100),RAY30430 1 DELP(100) RAY30440 REAL*8 LX(14) RAY30450 REAL*4 LCM RAY30460 C**** !Changes from here... !JDL 10-MAR-84 INTEGER ID2(54), ID3(21), ID4(41), ID5(25), ID6(17),ID7(7),ID8(26)RAY30470 DATA ID2 / 11, 19, 29, 41, 51, 12, 20, 30, 42, 52, 13, 21, 31, RAY30480 1 43, 53, 14, 22, 32, 44, 54, 15, 23, 33, 45, 55, 16, 24, 34, RAY30490 2 46, 56, 17, 25, 35, 47, 57, 18, 26, 36, 48, 58, 27, 37, RAY30500 3 49, 59, 28, 38, 50, 60, 39, 61, 40, 4 62, 63, 64 / RAY30510 C**** !...down to here. !JDL 10-MAR-84 DATA ID3 / 10, 15, 19, 25, 11, 16, 20, 26, 12, 17, 21, 27, 13, RAY30520 1 18, 22, 28, 14, 23, 29, 24, 30 / RAY30530 DATA ID4 / 11, 20, 28, 34, 12, 21, 29, 35, 13, 22, 30, 36, 14, RAY30540 1 23, 31, 37, 15, 24, 32, 38, 16, 25, 33, 39, 17, 26, 40, 46, RAY30550 2 18, 27, 41, 47, 19, 42, 48, 43, 49, 44, 50, 45, 51 / RAY30560 DATA ID5 / 10, 14, 19, 23, 29, 11, 15, 20, 24, 30, 12, 16, 21, RAY30570 1 25, 31, 13, 17, 22, 26, 32, 18, 27, 33, 28, 34 / RAY30580 DATA ID6 / 10, 16, 20, 26, 11, 17, 21, 27, 12, 22, 28, 13, 23, RAY30590 1 14, 24, 15, 25 / RAY30600 DATA ID7 / 10, 15, 11, 16, 12, 13, 14 / RAY30610 DATA ID8 / 11, 16, 25, 29, 35, 12, 17, 26, 30, 36, 13, 18, 27, 1 31, 37, 14, 19, 28, 32, 38, 15, 20, 33, 39, 34, 40 / DATA LCM / ' CM ' / RAY30620 DATA LX/ ' ENTR FL','D STEP =',' UNIF FL','D STEP =', RAY30630 1 ' EXIT FL','D STEP =',' DIFF/MI','D STEP =', RAY30640 2 ' ',' RHO =',' ',' MTYP =', RAY30650 3 ' FIELD',' STEP =' / RAY30660 C**** RAY30670 C**** RAY30680 GO TO ( 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16 ),J !JDL 17-NOV-83 RAY30690 PRINT 109, J RAY30700 109 FORMAT(// ' GO TO FELL THROUGH IN ROUTINE PRNT J= ' I5 /// )RAY30710 CALL EXIT RAY30720 C**** RAY30730 1 RETURN RAY30740 13 RETURN RAY30760 C**** RAY30770 C**** DIPOLE DATA RAY30780 C**** RAY30790 100 FORMAT( // 20X, '***DIPOLE MAGNET ***', A4 / ) RAY30800 C**** !Changes from here... !JDL 10-MAR-84 101 FORMAT( RAY30810 1 5X,' A =', F9.4, 5X,'NDX =', F9.4, 5X,'C01 =', F9.4, RAY30820 2 5X,'BR1 =', F9.4, 5X,'S02 =',1PE12.3,5X, 2A8,0PF8.3,A4,/RAY30830 3 5X,' B =', F9.4, 5X,'BET1=', F9.4, 5X,'C02 =', F9.4, RAY30840 4 5X,'BR2 =', F9.4, 5X,'S03 =',1PE12.3,5X, 2A8,0PF8.3,A4,/RAY30850 5 5X,' D =', F9.4, 5X,'GAMA=', F9.4, 5X,'C03 =', F9.4, RAY30860 6 5X,'XCR1=', F9.4, 5X,'S04 =',1PE12.3,5X, 2A8,0PF8.3,A4,/RAY30870 7 5X,' R =', F9.4, 5X,'DELT=', F9.4, 5X,'C04 =', F9.4, RAY30880 8 5X,'XCR2=', F9.4, 5X,'S05 =',1PE12.3,5X, 2A8,0PF8.3,A4,/RAY30890 9 5X,' BF =', F9.4, 5X,'XS1 =', F9.4, 5X,'C05 =', F9.4, RAY30900 A 5X,'DLS1=', F9.4, 5X,'S06 =',1PE12.3,5X, 2A8, I4 ,/RAY30910 B 5X,'PHI =',0PF9.4, 5X,'XS2 =', F9.4, 5X,'C06 =', F9.4, RAY30920 C 5X,'DLS2=', F9.4, 5X,'S07 =',1PE12.3,5X, 2A8,0PF8.3,A4 )RAY30930 102 FORMAT( RAY30940 1 5X,'ALPH=', F9.4, 5X,'Z11 =', F9.4, 5X,'C11 =', F9.4, RAY30950 2 5X,'RAP1=', F9.4, 5X,'S08 ='1PE12.3/, 5X,'BETA=',0PF9.4, RAY30960 3 5X,'Z12 =', F9.4, 5X,'C12 =', F9.4, 5X,'RAP2=', F9.4, RAY30970 4 5X,'S12 =',1PE12.3/ 24X,'Z21 =',0PF9.4, 5X,'C13 =',0PF9.4, RAY30980 X 5X,'SCR1=', F9.4, 5X,'S13 =',1PE12.3/, RAY30990 5 24X,'Z22 =',0PF9.4, 5X,'C14 =',0PF9.4, 5X,'SCR2=', F9.4, RAY31000 Y 5X,'S14 ='1PE12.3,/43X,'C15 =',0PF9.4, RAY31010 6 24X,'S15 =',1PE12.3/ 43X,'C16 =' 0PF9.4, 24X,'S16 =',1PE12.3/, RAY31020 7 81X,'S17 =',1PE12.3/ 81X,'S18 =' 1PE12.3 ) RAY31030 C**** !...down to here. !JDL 10-MAR-84 C**** RAY31040 C**** RAY31050 2 RHO = 1.D30 RAY31060 IF( DATA(15,NO) .NE. 0 ) RAY31070 1RHO = DSQRT( (2.*931.48*PMASS+ENERGY)*ENERGY)/(3.*DATA(15,NO)*Q0) RAY31080 MTYP = DATA(5,NO) RAY31090 PRINT 100, ITITLE(NO) RAY31100 PRINT 101,(DATA(ID2(I),NO),I= 1,5 ),LX( 1),LX( 2),DATA(1,NO),LCM, RAY31110 1 (DATA(ID2(I),NO),I= 6,10),LX( 3),LX( 4),DATA(2,NO),LCM, RAY31120 2 (DATA(ID2(I),NO),I=11,15),LX( 5),LX( 6),DATA(3,NO),LCM, RAY31130 3 (DATA(ID2(I),NO),I=16,20),LX( 7),LX( 8),DATA(4,NO),LCM, RAY31140 4 (DATA(ID2(I),NO),I=21,25),LX(11),LX(12),MTYP , RAY31150 5 (DATA(ID2(I),NO),I=26,30),LX( 9),LX(10),RHO, LCM RAY31160 PRINT 102,(DATA(ID2(I),NO),I=31,54) RAY31170 RETURN RAY31180 C**** RAY31190 C**** QUADRUPOLE, HEXAPOLE, OCTAPOLE, DECAPOLE DATA RAY31200 C**** RAY31210 200 FORMAT( // 20X, '***QUADRUPOLE ***', A4 / ) RAY31220 400 FORMAT( // 20X, '***SEXTUPOLE ***', A4 / ) RAY31230 500 FORMAT( // 20X, '***OCTUPOLE ***', A4 / ) RAY31240 600 FORMAT( // 20X, '***DECAPOLE ***', A4 / ) RAY31250 C**** FORMAT at 120 made compatible with FORMAT at 101. !JDL 11-MAR-84 C**** (F9.4, 8X, 2A8 to agree with E12.3, 5X, 2A8) !JDL 11-MAR-84 120 FORMAT( RAY31260 1 5X,' A =', F9.4, 5X,'Z11 =', F9.4, 5X,'C01 =', F9.4, RAY31270 2 5X,'C11 =', F9.4, 8X, 2A8,0PF8.3,A4,/ RAY31280 3 5X,' B =', F9.4, 5X,'Z12 =', F9.4, 5X,'C02 =', F9.4, RAY31290 4 5X,'C12 =', F9.4, 8X, 2A8,0PF8.3,A4,/ RAY31300 5 5X,' L =', F9.4, 5X,'Z21 =', F9.4, 5X,'C03 =', F9.4, RAY31310 6 5X,'C13 =', F9.4, 8X, 2A8,0PF8.3,A4,/ RAY31320 7 5X,'RAD =', F9.4, 5X,'Z22 =', F9.4, 5X,'C04 =', F9.4, RAY31330 8 5X,'C14 =', F9.4,/5X,' BF =', F9.4,24X,'C05 =', F9.4, RAY31340 9 5X,'C15 =', F9.4,/ 43X,'C06 =', F9.4, RAY31350 A 5X,'C16 =', F9.4 ) RAY31360 C**** RAY31370 C**** RAY31380 3 PRINT 200, ITITLE(NO) RAY31390 GO TO 21 RAY31400 4 PRINT 400, ITITLE(NO) RAY31410 GO TO 21 RAY31420 5 PRINT 500, ITITLE(NO) RAY31430 GO TO 21 RAY31440 6 PRINT 600, ITITLE(NO) RAY31450 21 PRINT 120,(DATA(ID3(I),NO),I= 1,4 ),LX( 1),LX( 2),DATA(1,NO),LCM, RAY31460 1 (DATA(ID3(I),NO),I= 5,8 ),LX( 3),LX( 4),DATA(2,NO),LCM, RAY31470 2 (DATA(ID3(I),NO),I= 9,12),LX( 5),LX( 6),DATA(3,NO),LCM, RAY31480 3 (DATA(ID3(I),NO),I=13,21) RAY31490 RETURN RAY31500 C**** RAY30770 C**** ELECTROSTATIC DEFLECTOR DATA RAY30780 C**** RAY30790 190 FORMAT( // 20X, '***ELECTROSTATIC DEF***', A4 / ) !JDL RAY30800 C**** FORMAT at 191 made compatible with FORMAT at 101. !JDL 11-MAR-84 191 FORMAT( RAY30810 1 5X,' A =', F9.4, 5X,'PHI =', F9.4, 5X,'Z11 =', F9.4, RAY30820 2 5X,'C01 =', F9.4, 5X,'C11 =', F9.4, 8X, 2A8,0PF8.3,A4,/RAY30830 3 5X,' B =', F9.4, 5X,'EC2 =', F9.4, 5X,'Z12 =', F9.4, RAY30840 4 5X,'C02 =', F9.4, 5X,'C12 =', F9.4, 8X, 2A8,0PF8.3,A4,/RAY30850 5 5X,' D =', F9.4, 5X,'EC4 =', F9.4, 5X,'Z21 =', F9.4, RAY30860 6 5X,'C03 =', F9.4, 5X,'C13 =', F9.4, 8X, 2A8,0PF8.3,A4,/RAY30870 7 5X,' R =', F9.4, 5X,'WE =', F9.4, 5X,'Z22 =', F9.4, RAY30880 8 5X,'C04 =', F9.4, 5X,'C14 =', F9.4, 8X, 2A8,0PF8.3,A4,/RAY30890 9 5X,' EF =', F9.4, 5X,'WC =', F9.4,24X,'C05 =', F9.4, RAY30900 A 5X,'C15 =', F9.4, 8X, 2A8,0PF8.3,A4,/RAY30910 B 62X,'C06 =',0PF9.4, 5X,'C16 =', F9.4 ) RAY30920 C**** RAY31040 C**** RAY31050 7 RHO = 1.D30 RAY31060 EMASS = PMASS * 931.48 ETOT = EMASS + ENERGY VC2 = (2.*EMASS + ENERGY)*ENERGY / (ETOT*ETOT) GAMMA = 1. / DSQRT(1. - VC2) IF( DATA(15,NO) .NE. 0 ) RAY31070 1RHO = GAMMA * EMASS * VC2 * 1000. / (DATA(15,NO) * Q0) RAY31080 PRINT 190, ITITLE(NO) RAY31100 PRINT 191,(DATA(ID8(I),NO),I= 1,5 ),LX( 1),LX( 2),DATA(1,NO),LCM, RAY31110 1 (DATA(ID8(I),NO),I= 6,10),LX( 3),LX( 4),DATA(2,NO),LCM, RAY31120 2 (DATA(ID8(I),NO),I=11,15),LX( 5),LX( 6),DATA(3,NO),LCM, RAY31130 3 (DATA(ID8(I),NO),I=16,20),LX( 7),LX( 8),DATA(4,NO),LCM, RAY31140 4 (DATA(ID8(I),NO),I=21,24),LX( 9),LX(10),RHO,LCM , RAY31150 5 (DATA(ID8(I),NO),I=25,26) RAY31160 RETURN RAY31180 C**** RAY31510 C**** VELOCITY SELECTOR DATA RAY31520 C**** RAY31530 132 FORMAT( // 20X, '***VELOCITY SELECTOR***', A4 / ) RAY31540 C**** FORMAT at 130 made compatible with FORMAT at 101. !JDL 11-MAR-84 130 FORMAT( RAY31550 1 5X,' A =', F9.4, 5X,'Z11 =', F9.4, 5X,'CB00=', F9.4, RAY31560 2 5X,'CE00=', F9.4, 8X, 2A8,0PF8.3,A4,/ RAY31570 3 5X,' B =', F9.4, 5X,'Z12 =', F9.4, 5X,'CB01=', F9.4, RAY31580 4 5X,'CE01=', F9.4, 8X, 2A8,0PF8.3,A4,/ RAY31590 5 5X,' L =', F9.4, 5X,'Z21 =', F9.4, 5X,'CB02=', F9.4, RAY31600 6 5X,'CE02=', F9.4, 8X, 2A8,0PF8.3,A4,/ RAY31610 7 5X,' BF =', F9.4, 5X,'Z22 =', F9.4, 5X,'CB03=', F9.4, RAY31620 8 5X,'CE03=', F9.4, 8X, 2A8,0PF8.3,A4,/ RAY31630 9 5X,' BE =', F9.4, 5X,'CB2 =', F9.4, 5X,'CB04=', F9.4, RAY31640 A 5X,'CE04=', F9.4, 8X, 2A8,0PF8.3,A4 ) RAY31650 131 FORMAT( RAY31660 1 5X,' DB =', F9.4, 5X,'CB4 =', F9.4, 5X,'CB05=', F9.4, RAY31670 2 5X,'CE05=', F9.4,/5X,' DE =', F9.4, 5X,'CE2 =', F9.4, RAY31680 3 5X,'CB10=', F9.4, 5X,'CE10=', F9.4,/5X,' WB =', F9.4, RAY31690 4 5X,'CE4 =', F9.4, 5X,'CB11=', F9.4, 5X,'CE11=', F9.4,/ RAY31700 5 5X,' WE =', F9.4,24X,'CB12=', F9.4, 5X,'CE12=', F9.4,/ RAY31710 6 43X,'CB13=', F9.4, 5X,'CE13=', F9.4,/ RAY31720 7 43X,'CB14=', F9.4, 5X,'CE14=', F9.4,/ RAY31730 8 43X,'CB15=', F9.4, 5X,'CE15=', F9.4 ) RAY31740 C**** RAY31750 C**** RAY31760 8 RHO = 1.D30 RAY31770 IF( DATA(14,NO) .NE. 0. ) RAY31780 1RHO = DSQRT( (2.*931.48*PMASS+ENERGY)*ENERGY)/(3.*DATA(14,NO)*Q0) RAY31790 PRINT 132,ITITLE(NO) RAY31800 PRINT 130,(DATA(ID4(I),NO),I= 1,4 ),LX( 1),LX( 2),DATA(1,NO),LCM, RAY31810 1 (DATA(ID4(I),NO),I= 5,8 ),LX( 3),LX( 4),DATA(2,NO),LCM, RAY31820 2 (DATA(ID4(I),NO),I= 9,12),LX( 5),LX( 6),DATA(3,NO),LCM, RAY31830 3 (DATA(ID4(I),NO),I=13,16),LX( 7),LX( 8),DATA(4,NO),LCM, RAY31840 4 (DATA(ID4(I),NO),I=17,20),LX( 9),LX(10),RHO,LCM RAY31850 PRINT 131,(DATA(ID4(I),NO),I=21,41) RAY31860 RETURN RAY31870 C**** RAY31880 C**** MULTIPOLE (POLES) DATA RAY31890 C**** RAY31900 141 FORMAT( // 20X, '***MULTIPOLES ***', A4 / ) RAY31910 C**** FORMAT at 140 was compatible with FORMAT at 101. !JDL 11-MAR-84 140 FORMAT( RAY31920 1 5X,' A =', F9.4, 3X,'BQUAD =',F9.4, 5X,'Z11 =', F9.4, RAY31930 2 5X,'C01 =', F9.4, 5X,'C11 =', F9.4, 8X, 2A8,0PF8.3,A4,/ RAY31940 3 5X,' B =', F9.4, 3X,'BHEX =',F9.4, 5X,'Z12 =', F9.4, RAY31950 4 5X,'C02 =', F9.4, 5X,'C12 =', F9.4, 8X, 2A8,0PF8.3,A4,/ RAY31960 5 5X,' L =', F9.4, 3X,'BOCT =',F9.4, 5X,'Z21 =', F9.4, RAY31970 6 5X,'C03 =', F9.4, 5X,'C13 =', F9.4, 8X, 2A8,0PF8.3,A4,/ RAY31980 7 5X,'RAD =', F9.4, 3X,'BDEC =',F9.4, 5X,'Z22 =', F9.4, RAY31990 8 5X,'C04 =', F9.4, 5X,'C14 =', F9.4,/ RAY32000 9 22X,'BDDEC =',F9.4,24X,'C05 =', F9.4, RAY32010 A 5X,'C15 =', F9.4/62X,'C06 =', F9.4, 5X,'C16 =', F9.4 ) RAY32020 C**** RAY32030 C**** RAY32040 9 PRINT 141, ITITLE(NO) RAY32050 PRINT 140,(DATA(ID5(I),NO),I= 1,5 ),LX( 1),LX( 2),DATA(1,NO),LCM, RAY32060 1 (DATA(ID5(I),NO),I= 6,10),LX( 3),LX( 4),DATA(2,NO),LCM, RAY32070 2 (DATA(ID5(I),NO),I=11,15),LX( 5),LX( 6),DATA(3,NO),LCM, RAY32080 3 (DATA(ID5(I),NO),I=16,25) RAY32090 RETURN RAY32100 C**** RAY32110 C**** MULTIPOLE DATA RAY32120 C**** RAY32130 151 FORMAT( // 20X, '***MULTIPOLE(HE) ***', A4 / ) RAY32140 C**** FORMAT at 150 made compatible with FORMAT at 101. !JDL 11-MAR-84 150 FORMAT( RAY32150 1 5X,' A =', F9.4, 5X,' Z1 =', F9.4, 5X,' C0 =', F9.4, RAY32160 2 5X,' C6 =', F9.4, 8X, 2A8,0PF8.3,A4,/ RAY32170 3 5X,' B =', F9.4, 5X,' Z2 =', F9.4, 5X,' C1 =', F9.4, RAY32180 4 5X,' C7 =', F9.4, 8X, 2A8,0PF8.3,A4,/ RAY32190 5 5X,' L =', F9.4,24X,' C2 =', F9.4, 5X,' C8 =', F9.4/ RAY32200 6 5X,' W =', F9.4,24X,' C3 =', F9.4,/ RAY32210 7 5X,' D =', F9.4,24X,' C4 =', F9.4,/ RAY32220 8 5X,' BF =', F9.4,24X,' C5 =', F9.4 ) RAY32230 C**** RAY32240 C**** RAY32250 10 PRINT 151, ITITLE(NO) RAY32260 PRINT 150,(DATA(ID6(I),NO),I= 1,4 ),LX( 1),LX( 2),DATA(1,NO),LCM, RAY32270 1 (DATA(ID6(I),NO),I= 5,8 ),LX( 7),LX( 8),DATA(2,NO),LCM, RAY32280 2 (DATA(ID6(I),NO),I= 9,17) RAY32290 RETURN RAY32300 C**** RAY32310 C**** TRANSLATE - ROTATE DATA RAY32320 C**** RAY32330 170 FORMAT( // 20X, '***TRANSLATE-ROTATE ***', A4 / ) RAY32340 171 FORMAT( 5X, 5H X0 = F9.4, 5X,5H Y0 = F9.4, RAY32350 1 5X, 5H Z0 = F9.4, / 1X,9HTHETA X = F9.4, RAY32360 2 1X,9HTHETA Y =F9.4, 1X,9HTHETA Z = F9.4 )RAY32370 C**** RAY32380 C**** RAY32390 11 PRINT 170, ITITLE(NO) RAY32400 PRINT 171, ( DATA(I,NO) , I=1,6 ) RAY32410 RETURN RAY32420 C**** RAY32430 C**** DRIFT SECTION DATA RAY32440 C**** RAY32450 12 PRINT 175, ITITLE(NO) RAY32460 PRINT 176, ( DATA(I,NO) , I=1,1 ) RAY32470 175 FORMAT( // 20X, '***DRIFT ***', A4 / ) RAY32480 176 FORMAT( 19X, ' Z-DRIFT =' F9.4, ' CM' ) RAY32490 RETURN RAY32500 C**** RAY32510 C**** SOLENOID DATA RAY32520 C**** RAY32530 161 FORMAT( // 20X, '***SOLENOID ***', A4 / ) RAY32540 C**** FORMAT at 160 made compatible with FORMAT at 101. !JDL 11-MAR-84 160 FORMAT( RAY32550 1 5X,' A =', F9.4, 5X,'Z11 =', F9.4, 8X,2A8,0PF8.3,A4,/ RAY32560 2 5X,' B =', F9.4, 5X,'Z22 =', F9.4,/5X,' L =', F9.4,/ RAY32570 3 5X,'DIA =', F9.4,/5X,' BF =', F9.4 ) RAY32580 C**** RAY32590 C**** RAY32600 14 PRINT 161, ITITLE(NO) RAY32610 PRINT 160,(DATA(ID7(I),NO),I= 1,2 ),LX(13),LX(14),DATA(1,NO),LCM, RAY32620 1 (DATA(ID7(I),NO),I= 3, 7) RAY32630 RETURN RAY32640 C**** RAY32650 C**** LENS DATA RAY32660 C**** RAY32670 180 FORMAT( // 20X, '***LENS ***', A4 / ) RAY32680 181 FORMAT( 3X, 7H(X/X) = ,F9.4, 6H CM/CM RAY32690 1 16X, 7H(X/T) = ,F9.4, 6H CM/MR / RAY32700 2 3X, 7H(T/X) = ,F9.4, 6H MR/CM RAY32710 3 16X, 7H(T/T) = ,F9.4, 6H MR/MR / RAY32720 4 3X, 7H(Y/Y) = ,F9.4, 6H CM/CM RAY32730 5 16X, 7H(Y/P) = ,F9.4, 6H CM/MR / RAY32740 6 3X, 7H(P/Y) = ,F9.4, 6H MR/CM RAY32750 7 16X, 7H(P/P) = ,F9.4, 6H MR/MR / ) RAY32760 C**** RAY32770 C**** RAY32780 15 PRINT 180, ITITLE(NO) RAY32790 PRINT 181, ( DATA(I,NO) , I=1,8 ) RAY32800 RETURN RAY32810 C**** C**** Changes from here ... !JDL 17-NOV-83 C**** C**** CHANGE DATA C**** 183 FORMAT( // 20X, '***CHANGE AND REPEAT***', A4 / ) 184 FORMAT( 5X,A4,' (',A4,') [LINE',I2,', ENTRY',I2, 1 ', GROUP (',A4,')] STEP =',F13.6 ) 16 PRINT 183, ITITLE(NO) DO 185 J=1,NLOOP INO=LOOPSV(1,J) NWD=NWORD(IDATA(INO)) PRINT 184, NWD, ITITLE(INO), (LOOPSV(I,J),I=2,4), HOOPSV(J) 185 CONTINUE RETURN C**** C**** AUTOMATIC RAY GENERATION C**** ENTRY PRNTA IF( JNR .EQ. 0 ) RETURN 196 FORMAT( //, 20X, '***AUTORAY GENERATOR***', //, 1 9X, 4X, 'TMIN', 6X, 'PMIN', 9X, 'XMAX', 6X, 'TMAX', 2 6X, 'YMAX', 6X, 'PMAX', 9X, 'DMAX', 6X, 'UMAX', / ) 197 FORMAT( 1X, 'JNR=', I4, 2F10.4, 3X, 4F10.4, 3X, 2F10.4 ) 198 FORMAT( 1X, 'NRXS=', I3, 2F10.4, 3X, 4F10.4, 3X, 2F10.4, 1 1X, 8X, 'STARTING SEED = ', F11.0 ) 199 FORMAT( 1X, 8X, F11.0, 9X, 3X, 4F10.4, 3X, 2F10.4, /, 1 1X, 8X, 2F10.4, 3X, 4F10.4, 3X, 2F10.4 ) PRINT 196 PRINT 197, JNR, TMIN, PMIN, XMAX, TMAX, YMAX, PMAX, DMAX IF( NRXS .EQ. 0 ) RETURN PRINT 198, NRXS, STMN, SPMN, SXMX, STMX, SYMX, SPMX, SDMX, SUMX, 1 SEEP IF( NRXS .NE. 13 ) RETURN PRINT 199, SEED, DXHW, DTHW, DYHW, DPHW, DEHW, DMHW, 1 SEC1, SEC2, SEC3, SEC4, SEC5, SEC6, SEC7, SEC8 RETURN C**** C**** ...down to here. !JDL 13-OCT-84 C**** RAY32820 C**** RAY32830 ENTRY PRNT1 ( N1, NN, JEN, NEN, WIDTH ) !JDL 1-NOV-84 RAY32840 C**** RAY32850 C**** RAY32860 IF( IP .GT. 500 ) GO TO 1190 !JDL 4-NOV-84 IF((MCS .EQ. 0) .AND. (MCP .EQ. 0)) PRINT 110 !JDL 4 NOV-84 RAY32870 IF( MCS .NE. 0 ) PRINT 1110 !JDL 4-NOV-84 IF( MCP .NE. 0 ) PRINT 1120 !JDL 4-NOV-84 110 FORMAT( 1H1, 15X, '****COORDINATES OPTIC AXIS SYSTEM****' // RAY32880 1 10X, 45HX THETA Y PHI ZI DELE ,5X, RAY32890 2 12HXO XS , 11X, 12HYO YS , 6X, 'L(CM)', 5X, RAY32900 3 'T(NS)' /) RAY32910 1110 FORMAT( 1H1, 15X, '****AUTORAY INPUT COORDINATES****', 12X, !JDL 1 '****MULTI-CHANNEL SPECTRA FROM RANDOM RAYS****', //, 2 10X, 45HX THETA Y PHI XSCTR DELE , 3 'X(CM)/T(NS)', 2X, 'X-COUNTS', 6X, 'Y(CM)', 3X, 'Y-COUNTS', 4 4X, 'ALL-X', 4X, 'T-COUNTS', / ) 1120 FORMAT( 1H1, 15X, '****CONTOUR INPUT COORDINATES****', 12X, !JDL 1 '****CENTRAL CONTOUR AND GRID VALUES****', //, 2 10X, 45HX THETA Y PHI XSCTR DELE , 3 4X, 'HORZ-CENTER-VERT', 6X, 'QUAD1', 5X, 'QUAD2', 4 6X, 'QUAD3', 5X, 'QUAD4', / ) C**** !From here... !JDL 31-OCT-84 1190 CONTINUE N = NN NRSV = N IF( JEN .EQ. 1 ) XMAXSV = XO(1) IF( JEN .EQ. 1 ) XMINSV = XMAXSV KK = N*(JEN-1) NRMAX = N + KK IF( MCP .EQ. 0 ) GO TO 890 C**** C**** CONTOUR MAP INTERPOLATED FROM RECTANGULAR GRID. C**** IF( JEN .GT. 1 ) GO TO 804 DO 802 II = 1, 26 802 NBIN(I) = 0 !CLEAR BIN COUNTERS NLINES = NLNS( NRXS - 20 ) LIMIT = NLINES/2 NBMAX = ( 1000 - JNR - 1 ) / NLINES IF( NBMAX .GT. 100*NEN ) NBMAX = 100*NEN MCP1 = MCP + 1 804 JV(5) = 3 !CORNERS OF MESH (SECOND NODE OF PAIR) JV(6) = 2 JV(7) = 3 JV(8) = 4 LCT = 0 C**** DO 850 NM = 1, 4 !NM = MESH INDEX (DIAG, HOR, VER, DIAG) DO 840 NJ = 2, MCP1 !NJ = VERT INDEX (NCVER) DO 830 NI = 2, MCP1 !NI = HORZ INDEX (NCHOR) DO 820 NK = 1, 4 !NK = QUAD INDEX (NCQAD) DHAX = DABS( DHAX ) DVAX = DABS( DVAX ) IF(( NK .EQ. 2 ) .OR. ( NK .EQ. 3 )) DHAX = -DHAX IF(( NK .EQ. 3 ) .OR. ( NK .EQ. 4 )) DVAX = -DVAX C**** LOCATE FOUR CORNERS ON RECTANGULAR MESH(I,J) IN QUADRANT(K). JV(1) = (NJ-1)*MCP1 + NI + JNR + 1 !REFERENCE NODE JV(2) = JV(1) - 1 !BACK 1 IN HORZ JV(3) = JV(1) - MCP1 !BACK 1 IN VERT JV(4) = JV(1) - MCP1 - 1 !BACK 1 IN EACH DO 806 II = 1, 4 JJ = JV(II) JV(II) = 1 !CORNERS OF MESH (FIRST NODE) VECK(5) = YO(JJ) VECK(6) = VYO(JJ) VECK(7) = RLL(JJ) VECK(8) = RTL(JJ) 806 VECK(II) = VECK(NK+4) !GET 4 NODES FROM ONE QUADRANT. JV(1) = 2 !CORNER FOR DOWN-DIAGONAL C**** C**** FIND INTERSECTIONS OF CONTOURS WITH FOUR LINE SEGMENTS C**** BETWEEN NODES (TWO DIAGONALS, OUTER ROW, OUTER COLUMN). C**** USE AVERAGE BETWEEN NODE VALUES AS A TEMPORARY COORDINATE C**** REFERENCE. NOTE THAT NODE VALUES ALREADY ARE NORMALIZED C**** TO CONTOUR SEPARATION AND CENTERING. C**** II = JV(NM) !SELECT A PAIR OF NODES (FIRST AND SECOND). JJ = JV(NM + 4) IF( VECK(II) .EQ. VECK(JJ) ) GO TO 820 AVG = 0.5*(VECK(II) + VECK(JJ)) NAVG = IDNINT(AVG) ANAVG = DFLOAT(NAVG) !NEXT, TEST FOR CONTOURS BETWEEN NODES. IF(DABS(ANAVG - AVG) .GT. DABS(VECK(II) - AVG)) GO TO 820 !NONE L1 = IDINT(VECK(II) - ANAVG) + NAVG !L1 THRU L2 INCLUDES ALL L2 = IDINT(VECK(JJ) - ANAVG) + NAVG !CONTOURS IN BETWEEN NODES IF((L1 .GT. +LIMIT) .AND. (L2 .GT. +LIMIT)) GO TO 820 !ALL HIGH IF((L1 .LT. -LIMIT) .AND. (L2 .LT. -LIMIT)) GO TO 820 !ALL LOW IF( L1 .GT. +LIMIT) L1 = +LIMIT !RESTRICT CONTOURS TO LIMITS IF( L2 .GT. +LIMIT) L2 = +LIMIT IF( L1 .LT. -LIMIT) L1 = -LIMIT IF( L2 .LT. -LIMIT) L2 = -LIMIT NL = L1 IF( L2 .LT. NL ) L1 = L2 !POSITIVE-GOING LOOP INDEX IF( L2 .LT. NL ) L2 = NL DO 810 NL = L1, L2 !SCAN CONTOURS L1 THRU L2 DV = ( DFLOAT(NL) - VECK(II) ) / ( VECK(JJ) - VECK(II) ) DH = DV IF( NM .EQ. 1 ) DH = 1.0 - DV !FALLING DIAGONAL IF( NM .EQ. 2 ) DV = 0.0 !HORIZIOTAL LINE IF( NM .EQ. 3 ) DH = 0.0 !VERTICAL LINE C**** IF( NM .EQ. 4 ) DH = DV !RISING DIAGONAL IT = NL + LIMIT + 1 IF( NBIN(IT) .GE. NBMAX ) GO TO 810 !BIN IS FULL NBIN(IT) = NBIN(IT) + 1 JT = (IT-1)*NBMAX + NBIN(IT) HORSV(JT) = ( DFLOAT(NI-1) - DH ) * DHAX !STORE INTERCEPT VERSV(JT) = ( DFLOAT(NJ-1) - DV ) * DVAX !COORDINATES IF( NL .NE. 0 ) GO TO 810 LCT = LCT + 1 IF( LCT .GT. 100 ) GO TO 810 XO(LCT) = HORSV(JT) !COORDINATES OF CENTRAL CONTOUR VXO(LCT) = VERSV(JT) !SENT TO PRINT LIST. 810 CONTINUE !END NL -- CONTOURS LOOP 820 CONTINUE !END NK -- QUADRANT LOOP 830 CONTINUE !END NI -- HORIZONTAL LOOP 840 CONTINUE !END NJ -- VERTICAL LOOP 850 CONTINUE !END NM -- MESH LOOP N = MIN( MAX( MCP1*MCP1, LCT ), 100 - JNR - 1 ) DO 854 II = 1, N JJ = II + JNR + 1 YO(II) = YO(JJ) VYO(II) = VYO(JJ) RLL(II) = RLL(JJ) 854 RTL(II) = RTL(JJ) IF( JEN .LT. NEN ) GO TO 890 C**** FILL BINS TO TOP WITH REDUNDANT COORDINATES. IT = 0 NRMAX = NLINES*NBMAX DO 870 II = 1, NLINES !SCAN BIN COUNTERS JJ = NLINES - II + 1 IF(( NBIN(JJ) .NE. 0 ) .OR. ( IT .NE. 0 )) GO TO 864 NRMAX = NRMAX - NBMAX !DISCARD EMPTY OUTER BINS GO TO 870 864 IT = 1 NL = (JJ-1)*NBMAX + NBIN(JJ) IF( NBIN(JJ) .EQ. 0 ) GO TO 866 !INTERIOR BIN IS EMPTY DH = HORSV(NL) !PICK UP SOME VALID VALUES DV = VERSV(NL) 866 L1 = NL + 1 L2 = NL + NBMAX - NBIN(JJ) IF( L1 .GT. L2 ) GO TO 870 DO 868 NL = L1, L2 HORSV(NL) = DH !FILL UP EMPTY LOCATIONS (FOR CLEAN PLOT) 868 VERSV(NL) = DV 870 CONTINUE C**** GO TO 890 890 DO 20 I=1,N RAY32920 X1 = XO(I) IF( X1 .GT. XMAXSV ) XMAXSV = X1 IF( X1 .LT. XMINSV ) XMINSV = X1 IF( MCP .NE. 0 ) GO TO 22 II = N - I +1 JJ = II + KK IF( II .LT. N1 ) GO TO 23 !FILL FROM I=1 TO N1-1 WITH RAY NL. VECK(1) = XO(II) VECK(2) = VXO(II) VECK(3) = YO(II) VECK(4) = VYO(II) VECK(5) = RLL(II) VECK(6) = RTL(II) VECK(7) = DELP(II) VECK(8) = DELM VECK(9) = ENERGY VECK(10) = MASS IF((MCS .EQ. 0) .AND. (MCP .EQ. 0)) VECK(6) = RTL(II)*1.0D+09/VEL 23 HORSV(JJ) = VECK(NHAX) VERSV(JJ) = VECK(NVAX) 22 IF( IP .GT. 500 ) GO TO 20 !...to here. !JDL 31-OCT-84 C**** C**** CALCULATE TIME IN (NS) C**** TLJ1 = RTL(I) !JDL 4-NOV-84 IF((MCS .EQ. 0) .AND. (MCP .EQ. 0)) TLJ1 = RTL(I)*1.0D+09/VEL!JDL PRINT 111, I, XI(I), VXI(I), YI(I), VYI(I), ZI(I), DELP(I), RAY32970 1 XO(I), VXO(I), YO(I), VYO(I), RLL(I), TLJ1 RAY32980 111 FORMAT( I5, 6F8.2, 2X, F10.4, F10.4, 2X, F10.4, RAY32990 1 F10.4 , F10.3, F10.3 /) RAY33000 20 CONTINUE RAY33010 FNPLT = N WRITE (2,2220) FNPLT 2220 FORMAT(///1F8.0) DXPLT = XO(2) - XO(1) WRITE(2,2222) XO(1),DXPLT 2222 FORMAT(10F8.0) WRITE(2,2222) (RLL(I),I=1,N) WIDTH = DABS( XMAXSV - XMINSV ) !JDL 1-DEC-83 RETURN RAY33020 C**** !From here... !JDL 1-DEC-83 C**** ENTRY PRNT1A ( NEN ) C**** IF(MOD(IP/10,10) .EQ. 5) RETURN !TEMPORARY COMPATIBILITY IF(( NCAX .EQ. NHAX) .AND. ( NHAX .EQ. NVAX )) RETURN DD(1)=0.0 DD(2)=0.0 DD(3)=0.0 DD(4)=0.0 IF( MCP .EQ. 0 ) GO TO 898 DD(1) = DHAX * DFLOAT( MCP ) !CORNERS OF GRID DD(2) = DVAX * DFLOAT( MCP ) DD(3) = -DD(1) DD(4) = -DD(2) 898 CONTINUE KK = 2*(( NRXS + 9 ) / 10 ) + 40 LABEL(1) = LABEL(KK+1) LABEL(2) = LABEL(KK+2) LABEL(4) = LABEL(8) !BLANK LABEL(5) = LABEL(8) IF( NCAX .NE. 0 ) LABEL(4) = LABEL(2*NCAX+15) IF( NCAX .NE. 0 ) LABEL(5) = LABEL(2*NCAX+16) LABEL(10) = LABEL(2*NVAX+15) LABEL(11) = LABEL(2*NVAX+16) LABEL(14) = LABEL(2*NHAX+15) LABEL(15) = LABEL(2*NHAX+16) J=2 NFOLD=NRSV IF( NEN .EQ. 1 ) NFOLD = 1 IF( MCP .NE. 0 ) NFOLD = NBMAX PRINT 188, NTITLE, DAET, TYME CALL PPLOT( HORSV,VERSV,VERSV, NFOLD,NFOLD, NRMAX, LABEL, J, DD ) 188 FORMAT( 1H1, 10X, 20A4, 1X, 12H JDL/84.11 ,3X, 3A4, 2X, 2A4 ) RETURN !...to here. !JDL 1-DEC-83 C**** RAY33030 C**** RAY33040 ENTRY PRNT2 ( T, S, X, Y, Z, BX, BY, BZ, BT, VX, VY, VZ )RAY33050 C**** RAY33060 IF( NP .GT. 100 ) RETURN RAY33070 VXP = 1000. *DATAN2( VX ,VZ ) RAY33080 VYP = 1000. * DASIN( VY /VEL ) RAY33090 VZP = VZ / VEL RAY33100 TP = T * VEL RAY33110 PRINT 112,TP,S,X, BX, Y, BY, Z, BZ, VZP, VXP, VYP, BT RAY33120 112 FORMAT(2F10.4, F10.3, F11.4, F10.3, F11.4, F10.3, F11.4, RAY33130 1 F13.5, F13.2, F11.2, F10.4 ) RAY33140 RETURN RAY33150 C**** C**** ENTRY PRNT2A IF (NP.GE.500) RETURN PRINT 1121, Q0,GASENE,QBAR,DELSQR,GASMFP,SIGC,SIGT,ACAPT,ALOS 1 , DEDXQ 1121 FORMAT(9X,F10.4,F10.3,F11.4,F10.3,4X,F10.4,F11.5,F11.5,F10.4,5X, 1 F10.4,F10.3) RETURN C**** C**** RAY33160 ENTRY PRNT3 (TDIST,X,Y,Z,BX,BY,BZ,EX,EY,EZ,VX,VY,VZ) RAY33170 C**** RAY33180 114 FORMAT( 2F9.3, 2F10.4,F9.3, 2F10.4,F9.3, 2F10.4,2F11.3, -9PF9.5 ) RAY33190 C**** RAY33200 C**** RAY33210 IF( NP .GT. 100 ) RETURN RAY33220 VXP = 1000. *DATAN2( VX ,VZ ) RAY33230 VYP = 1000. * DASIN( VY /VEL ) RAY33240 VZP = VZ / VEL RAY33250 TP = T * VEL RAY33260 PRINT 114, TDIST,X,BX,EX,Y,BY,EY,Z,BZ,EZ,VXP,VYP,VEL RAY33270 RETURN RAY33280 C**** RAY33281 C**** RAY33282 C**** RAY33283 ENTRY PRNT4(NO, IN) RAY33284 C**** RAY33285 115 FORMAT (///, 10X, 'MAXIMUM STEPS EXCEEDED', /10X, RAY33286 1 'ELEMENT = ', I4, /10X, 'REGION = ', I4 ///) RAY33287 PRINT 115, NO, IN RAY33288 RETURN RAY33290 C**** RAY33030 C**** RAY33040 ENTRY PRNT5 ( T, S, X, Y, Z, EX, EY, EZ, ET, VX, VY, VZ )RAY33050 C**** RAY33060 IF( NP .GT. 100 ) RETURN RAY33070 VXP = 1000. *DATAN2( VX ,VZ ) RAY33080 VYP = 1000. * DASIN( VY /VEL ) RAY33090 VZP = VZ / VEL RAY33100 TP = T * VEL RAY33110 PRINT 112,TP,S,X, EX, Y, EY, Z, EZ, VZP, VXP, VYP, ET RAY33120 RETURN RAY33150 END RAY33291 SUBROUTINE QCG(Q0,Q1) IMPLICIT REAL*8 (A-H,O-Z) c common /blck60/ gas,agas,zgas,zion,press,gassig,qaver, !***mp 1-jan-85 1 qfwhm,rhogas,gask,emass,gasmfp,jray,q00,npasg !*** COMMON /BLCK63/ ISEED include 'rtcomm65.f' C***** C***** C***** P1 = SIGC/SIGT R = RAN(ISEED) C Q1 = Q0 - 1. IF (R.GT.P1) Q1 = Q0 + 1. c C**** C****THERE IS A BUG HERE : MINIMUM CHARGE STATE IS SET TO 0 !MP AUG-2-93 C****SHOULD BE MODIFIED TOFORGET ABOUT IONS WHICH GET NEUTRAL!MP AUG-2-93 C**** if (q1.le.0.) q1=1. ! no negative ions if (q1.gt.zion) q1=zion ! no 'positronic' ions RETURN END SUBROUTINE QDIST c c calculate charge distribution in gas c c 911204 MP/BS add new input parameter 'qopt' to select different c formulas for calculating qbar in gas c qopt = 0. Dimitriev c qopt = 1. Betz c qopt = 2. Rehm (NIM 95) c qopt = 3. ref. Reiner Kruecken (Yale), V. Ninov (Berkeley) c expression for low velocities c IMPLICIT REAL*8(A-H,O-Z) COMMON /BLCK 4/ ENERGY, VEL, PMASS, Q0 RAY00140 COMMON /BLCK60/ GAS,AGAS,ZGAS,ZION,PRESS,GASSIG,QAVER, !***MP 1-JAN-85 1 QFWHM,RHOGAS,GASK,EMASS,GASMFP,JRAY,Q00,NPASG !*** include 'rtcomm65.f' c DATA V0/2.189D8/ DATA A/0.555/,DEL/1.175/,GAM/0.607/ DATA Ar/1.571/,DELr/0.6/,GAMr/0.61/ c if (qopt .eq. 0.) then c c Dimitriev and Nikolaev (1964) (from Betz-Paper) c VBV0 = VEL/V0 qbar=zion*dlog(2.43*vbv0/(zion**0.4))/dlog(7.*(zion**0.3)) tmp=0.32*(zion**0.45) delsqr=tmp*tmp c else if (qopt .eq. 1.) then c c From: H.D. Betz, Heavy Ion Charge States, c in: Applied Atomic Collision Physics, Vol. 4 (Acad. Press 1983) c VBV0 = VEL/V0 TMP = -A*(VBV0**DEL)/(ZION**GAM) QBAR = ZION*(1.-DEXP(TMP)) DELSQR = .0729 * ZION c else if (qopt .eq. 2.) then c c From: E. Rehm : based on Betz's expression but fit of parameters c to position of 18O,15N, etc... groups in 18F + CH2 expt. c c VBV0 = VEL/V0 TMP = -Ar*(VBV0**DELr)/(ZION**GAMr) QBAR = ZION*(1.-DEXP(TMP)) DELSQR = .0729 * ZION c c else if (qopt .eq. 3.) then c***** ref. Reiner Kruecken : expressions for low velocities c from Ninov c vbv0 = vel/v0 Q1=ZION*(1.0-1.04*exp(-0.91*vbv0*ZION**-0.66667)) Q2=(0.394*vbv0*ZION**0.33333) +1.65 qbar = Q1 if (vbv0.le.4. and. Q2.gt.Q1) qbar = Q2 c***** delsqr taken from Betz DELSQR = .0729 * ZION c c***** put other formulas here ... c c endif c RETURN END SUBROUTINE QSIG (DQ) IMPLICIT REAL*8(A-H,O-Z) COMMON /BLCK 4/ ENERGY, VEL, PMASS, Q0 COMMON /BLCK60/ GAS,AGAS,ZGAS,ZION,PRESS,GASSIG,QAVER, !***MP 1-JAN-85 1 QFWHM,RHOGAS,GASK,EMASS,GASMFP,JRAY,Q00,NPASG !*** COMMON /BLCK62/ GASENE,GASVEL,TOLD,GASL COMMON /BLCK63/ ISEED include 'rtcomm65.f' common /blck70/ vel0,en0,pm0 common /blck71/ gasopt,zgas125,zgas18,dreldee,enold,icalc c data v0/2.188d8/ c***************************************************************** c** Velocity dependence of capture cross section is taken as v**-7 c which is valid in the high velocity regime ( v > v0 ). c See Knudsen, Haugen and Hvelplund, Phys. Rev. A 23 (1981) 597. c c if (vel.le.v0) go to 10 !! THIS VERSION !! c sgsig = gassig / ((vel/vel0)**7) !! IS CANCELLED !! c***************************************************************** c c Capture cross section are updated as function of energy c using scaling law of Schlachter et al. See Ref in subroutine sigcap. c Scaling law is used to calculate relative change in sigma(capture) c for q = qbar. c Capture cross sections are updated whenever this relative change is c larger than drel. drel presently taken as 15%. c Check for updating condition is done in subroutine gasint c C** CALCULATE SIGL FROM QBAR,DELSQR AND SIGC C C** ATBCC = NB. ATOMS BY CC * 1.E-16 ALOS = 1./DELSQR - ACAPT ACL1 = (ACAPT-ALOS)/2.0-ALOS*DQ SIGL = GASSIG*DEXP(ACL1) SIGC = GASSIG*DEXP(ACAPT*DQ) SIGT = SIGC + SIGL GASMFP = 1./(SIGT*ATBCC) RETURN END C FUNCTION RANDOM(K,ISEED) C C RANDOM DISTRIBUTION SELECTION C K=0, FLAT DISTRIBUTION BETWEEN -1.0 AND +1.0 C K=1, GAUSSIAN DISTRIBUTION WITH HALF-MAX AT -1.0 AND +1.0 C (CONSTANT A1 = 0.5*SQRT(PI/(2.0*LOG(2.0))) C PARAMETER (A1=0.75269185) PARAMETER (A2=-0.15625983,A4=+0.021262254,A6=-0.024505330) PARAMETER (B0=1.0-(A2+A4+A6),B2=-0.14234502,B4=-0.016316285) REAL*8 RANDOM C RANDOM=2.0*RAN(ISEED)-1.0 IF(K .EQ. 0) RETURN RAND=RANDOM Y=RAND**2 S1=SQRT(1.0-Y) X=RAND*((((A6*Y+A4)*Y+A2)*Y)+B0+B2*S1+B4*SQRT(S1)) RANDOM=A1*LOG((1.0+X)/(1.0-X)) RETURN END C C SUBROUTINE RAYS( JNR, NR, NRXS ) !JDL 10-MAR-84 RAYK0010 C**** RAYK0020 IMPLICIT REAL*8(A-H,O-Z) RAYK0030 COMMON /BLCK 1/ XI, YI, ZI, VXI, VYI, VZI, DELP, DELM !JDL RAY00120 COMMON /BLCK15/ TMIN,PMIN,XMAX,TMAX,YMAX,PMAX,DMAX, !JDL RAY00195 1 STMN,SPMN,SXMX,STMX,SYMX,SPMX,SDMX,SUMX, !JDL 2 SEED,SEEP,DXHW,DTHW,DYHW,DPHW,DEHW,DMHW, !JDL 3 SEC1,SEC2,SEC3,SEC4,SEC5,SEC6,SEC7,SEC8 !JDL DIMENSION XI(100), YI(100), ZI(100), VXI(100), VYI(100), VZI(100),RAYK0060 1 DELP(100) RAYK0070 100 FORMAT (///10X, 'JNR = ', I10 ///) RAYK0080 C**** RAYK0090 C**** RAYK0100 DO 1 I=1,100 RAYK0110 XI(I)=0. RAYK0120 YI(I)=0. RAYK0130 ZI(I)=0. RAYK0140 VXI(I)=0. RAYK0150 VYI(I)=0. RAYK0160 VZI(I)=0. RAYK0170 DELP(I)=0. RAYK0180 1 CONTINUE RAYK0190 IF (TMIN.EQ.0.) TMIN=1.0 RAYK0200 IF (PMIN.EQ.0.) PMIN=1.0 RAYK0210 TMAX2 = TMAX/2.0 RAYK0220 TMAX3 = TMAX/3.0 RAYK0230 PMAX2 = PMAX/2.0 RAYK0240 PMAX3 = 2.*PMAX/3.0 RAYK0250 IF (JNR .EQ. 2) GO TO 2 !JDL 10-MAR-84 IF (JNR .EQ. 6) GO TO 2 !JDL 10-MAR-84 RAYK0260 IF (JNR .EQ. 14) GO TO 2 !JDL 10-MAR-84 RAYK0270 IF (JNR .EQ. 46) GO TO 3 !JDL 10-MAR-84 RAYK0280 PRINT 100, JNR !JDL 10-MAR-84 RAYK0290 CALL EXIT RAYK0300 2 VXI(2)=TMIN RAYK0310 VYI(2)=PMIN RAYK0320 IF (JNR .EQ. 2) GO TO 5 !JDL 10-MAR-84 RAYK0260 VXI(3)=TMAX2 RAYK0330 VXI(4)=-TMAX2 RAYK0340 VXI(5)=TMAX RAYK0350 VXI(6)=-TMAX RAYK0360 IF (JNR .EQ. 6) GO TO 5 !JDL-10-MAR-84 RAYK0370 VYI(7)=PMAX2 RAYK0380 VXI(8)=TMAX2 RAYK0390 VYI(8)=PMAX2 RAYK0400 VXI(9)=-TMAX2 RAYK0410 VYI(9)=PMAX2 RAYK0420 VXI(10)=TMAX RAYK0430 VYI(10)=PMAX2 RAYK0440 VXI(11)=-TMAX RAYK0450 VYI(11)=PMAX2 RAYK0460 VYI(12)=PMAX RAYK0470 VXI(13)=TMAX2 RAYK0480 VYI(13)=PMAX RAYK0490 VXI(14)=-TMAX2 RAYK0500 VYI(14)=PMAX RAYK0510 C**** C**** C**** 5 DO 4 I=1,JNR !JDL 10-MAR-84 XI(I) = XMAX YI(I) = YMAX 4 DELP(I) = DMAX GO TO 10 !JDL 10-MAR-84 RAYK0520 C**** RAYK0530 C**** RAYK0540 C**** RAYK0550 3 VXI(2)=TMIN RAYK0560 VYI(2)=PMIN RAYK0570 XI(3)=XMAX RAYK0580 XI(4)=-XMAX RAYK0590 VXI(5)=TMAX3 RAYK0600 VXI(6)=-TMAX3 RAYK0610 YI(7)=YMAX RAYK0620 YI(8)=-YMAX RAYK0630 VYI(9)=PMAX3 RAYK0640 VYI(10)=-PMAX3 RAYK0650 DELP(11)=DMAX RAYK0660 DELP(12)=-DMAX RAYK0670 XI(13)=XMAX RAYK0680 VXI(13)=TMAX3 RAYK0690 XI(14)=-XMAX RAYK0700 VXI(14)=-TMAX3 RAYK0710 XI(15)=XMAX RAYK0720 DELP(15)=DMAX RAYK0730 XI(16)=-XMAX RAYK0740 DELP(16)=-DMAX RAYK0750 VXI(17)=TMAX3 RAYK0760 DELP(17)=DMAX RAYK0770 VXI(18)=-TMAX3 RAYK0780 DELP(18)=-DMAX RAYK0790 YI(19)=YMAX RAYK0800 VYI(19)=PMAX3 RAYK0810 YI(20)=-YMAX RAYK0820 VYI(20)=PMAX3 RAYK0830 XI(21)=XMAX RAYK0840 YI(21)=YMAX RAYK0850 XI(22)=-XMAX RAYK0860 YI(22)=YMAX RAYK0870 XI(23)=XMAX RAYK0880 VYI(23)=PMAX3 RAYK0890 XI(24)=-XMAX RAYK0900 VYI(24)=PMAX3 RAYK0910 VXI(25)=TMAX3 RAYK0920 YI(25)=YMAX RAYK0930 YI(26)=YMAX RAYK0940 VXI(27)=TMAX3 RAYK0950 VYI(27)=PMAX3 RAYK0960 VXI(28)=-TMAX3 RAYK0970 VYI(28)=PMAX3 RAYK0980 YI(29)=YMAX RAYK0990 DELP(29)=DMAX RAYK1000 YI(30)=YMAX RAYK1010 DELP(30)=-DMAX RAYK1020 VYI(31)=PMAX3 RAYK1030 DELP(31)=DMAX RAYK1040 VYI(32)=PMAX3 RAYK1050 DELP(32)=-DMAX RAYK1060 VXI(33)=TMAX RAYK1070 VXI(34)=-TMAX RAYK1080 XI(35)=XMAX RAYK1090 VXI(35)=TMAX RAYK1100 XI(36)=-XMAX RAYK1110 VXI(36)=TMAX RAYK1120 XI(37)=XMAX RAYK1130 VXI(37)=-TMAX RAYK1140 XI(38)=-XMAX RAYK1150 VXI(38)=-TMAX RAYK1160 VXI(39)=TMAX RAYK1170 DELP(39)=DMAX RAYK1180 VXI(40)=TMAX RAYK1190 DELP(40)=-DMAX RAYK1200 VXI(41)=-TMAX RAYK1210 DELP(41)=DMAX RAYK1220 VXI(42)=-TMAX RAYK1230 DELP(42)=-DMAX RAYK1240 VYI(43)=PMAX RAYK1250 VXI(44)=TMAX RAYK1260 VYI(44)=PMAX RAYK1270 DELP(45)=3.*DMAX RAYK1280 DELP(46)=-3.*DMAX RAYK1290 C**** !Changes from here... !JDL 10-MAR-84 10 IF(NR .LE. JNR) RETURN IF((NRXS .LT. 1) .OR. (NRXS .GT. 9)) RETURN C**** C**** PHASE-SPACE ELLIPSE GENERATOR C**** ADDS (NR-JNR) RAYS DISTRIBUTED UNIFORMLY AROUND ELLIPSES C**** IN REAL AND PHASE SPACE. C**** NRXS = 1, "DIAGONAL SCAN" (X AND Y IN PHASE). C**** 2, "CIRCLE SCAN" (X LEADS Y BY 90-DEGREES). C**** 3, "ELLIPSOID SCAN" (X ELLIPSE AT EACH Y POINT). C**** C**** ELLIPSES MAY BE DIVIDED INTO 3 ENERGY OR MASS GROUPS. C**** NE = 1 IF((SDMX .NE. 0.0) .OR. (SUMX .NE. 0.0)) NE = 3 NS = (NR-JNR+NE-1)/NE TWOPI = 6.283185307D0 DAX = TWOPI/FLOAT(NS) IF(NRXS .NE. 3) GO TO 15 NY = 2 IF(NS .GE. 32) NY = 4 IF(NS .GE. 64) NY = 8 DAX = DAX*FLOAT(NY) DAY = (TWOPI/FLOAT(NY))/2.0 15 AAX = -DAX N1 = JNR+1 DO 20 I=N1,NR AAX = AAX + DAX SAX = DSIN(AAX) CAX = DCOS(AAX) XI(I) = SXMX*CAX YI(I) = SYMX*CAX VXI(I) = STMX*SAX VYI(I) = SPMX*SAX DELP(I) = SDMX*FLOAT((I-JNR-1)/NS-1) IF(NRXS .EQ. 1) GO TO 20 !DIAGONAL SCAN (IN PHASE) YI(I) = +SYMX*SAX VYI(I) = -SPMX*CAX IF(NRXS .EQ. 2) GO TO 20 !CIRCULAR SCAN (X LEADS Y) AAY = DAY*AINT((AAX+0.001)/TWOPI) YI(I) = -SYMX*DSIN(AAY) !ELLIPSOID SCAN (ONE DISCRETE STEP VYI(I) = +SPMX*DCOS(AAY) !IN Y PER 2-PI REVOLUTION IN X.) 20 CONTINUE C**** !...down to here. !JDL 10-MAR-84 RETURN RAYK1300 END RAYK1310 SUBROUTINE SHLLCO C C SHELL CORRECTIONS FOR BETHE FORMULA C FOR HYDROGEN AS PROJECTILE. C C***************************************** C DIMENSION SC(92) COMMON /SHELLC/ SC SC(1)=4. SC(2)=-3. SC(3)=-9. SC(4)=-8. SC(5)=-7. SC(6)=-9. SC(7)=-6. SC(8)=-9. SC(9)=-10. SC(10)=-11. DO 10 I=11,50 Z=FLOAT(I) Z2=Z*Z Z3=Z*Z2 Z4=Z2*Z2 Z5=Z*Z4 10 SC(I)=-21.258+2.1282*Z-0.099659*Z2+0.0011623*Z3 1 +0.000024822*Z4-0.0000004405*Z5 DO 20 I=51,92 Z=FLOAT(I) Z2=Z*Z Z3=Z2*Z Z4=Z2*Z2 Z5=Z4*Z 20 SC(I)=1089.1-85.686*Z+2.6457*Z2-0.040082*Z3 1 +0.0002976*Z4-0.00000086478*Z5 RETURN END C C*************************************** C BLOCK DATA C C TABLES OF COEFFICIENTS C C*************************************** C DIMENSION AH1(92),AH2(92),AH3(92),AH4(92), 1 AH5(92),AH6(92),AH7(92) DIMENSION A1(92),A2(92),A3(92),A4(92),A5(92),A6(92),A7(92), 1 A8(92),A9(92) DIMENSION B1(92),B2(92),B3(92),B4(92),B5(92),B6(92),B7(92), 1 B8(92),B9(92) COMMON /DATAD/ AH1,AH2,AH3,AH4,AH5,AH6,AH7, 1 A1,A2,A3,A4,A5,A6,A7,A8,A9, 1 B1,B2,B3,B4,B5,B6,B7,B8,B9 C C COEFFICIENTS FOR H IN SOLID AND GASEOUS MATTER C DATA AH1( 1),AH2( 1),AH3( 1),AH4( 1),AH5( 1),AH6( 1),AH7( 1) 1 ,AH1( 2),AH2( 2),AH3( 2),AH4( 2),AH5( 2),AH6( 2),AH7( 2) 1 ,AH1( 3),AH2( 3),AH3( 3),AH4( 3),AH5( 3),AH6( 3),AH7( 3) 1 ,AH1( 4),AH2( 4),AH3( 4),AH4( 4),AH5( 4),AH6( 4),AH7( 4) 1 ,AH1( 5),AH2( 5),AH3( 5),AH4( 5),AH5( 5),AH6( 5),AH7( 5) 1 ,AH1( 6),AH2( 6),AH3( 6),AH4( 6),AH5( 6),AH6( 6),AH7( 6) 1 ,AH1( 7),AH2( 7),AH3( 7),AH4( 7),AH5( 7),AH6( 7),AH7( 7) 1 ,AH1( 8),AH2( 8),AH3( 8),AH4( 8),AH5( 8),AH6( 8),AH7( 8) 1 ,AH1( 9),AH2( 9),AH3( 9),AH4( 9),AH5( 9),AH6( 9),AH7( 9) 1 ,AH1(10),AH2(10),AH3(10),AH4(10),AH5(10),AH6(10),AH7(10) 1 /1.262, 1.440, 242.6,12000.0,0.115900,0.000510,54360.0, 1 1.229, 1.397, 484.5, 5873.0,0.052250,0.001020,24510.0, 1 1.411, 1.600, 725.6, 3013.0,0.045780,0.001530,21470.0, 1 2.248, 2.590, 966.0, 153.8,0.034750,0.002039,16300.0, 1 2.474, 2.815, 1206.0, 1060.0,0.028550,0.002549,13450.0, 1 2.631, 2.989, 1445.0, 957.2,0.028190,0.003059,13220.0, 1 2.954, 3.350, 1683.0, 1900.0,0.025130,0.003569,11790.0, 1 2.652, 3.000, 1920.0, 2000.0,0.022300,0.004079,10460.0, 1 2.085, 2.352, 2157.0, 2634.0,0.018160,0.004589, 8517.0, 1 1.951, 2.199, 2393.0, 2699.0,0.015680,0.005099, 7353.0/ DATA AH1(11),AH2(11),AH3(11),AH4(11),AH5(11),AH6(11),AH7(11) 1 ,AH1(12),AH2(12),AH3(12),AH4(12),AH5(12),AH6(12),AH7(12) 1 ,AH1(13),AH2(13),AH3(13),AH4(13),AH5(13),AH6(13),AH7(13) 1 ,AH1(14),AH2(14),AH3(14),AH4(14),AH5(14),AH6(14),AH7(14) 1 ,AH1(15),AH2(15),AH3(15),AH4(15),AH5(15),AH6(15),AH7(15) 1 ,AH1(16),AH2(16),AH3(16),AH4(16),AH5(16),AH6(16),AH7(16) 1 ,AH1(17),AH2(17),AH3(17),AH4(17),AH5(17),AH6(17),AH7(17) 1 ,AH1(18),AH2(18),AH3(18),AH4(18),AH5(18),AH6(18),AH7(18) 1 ,AH1(19),AH2(19),AH3(19),AH4(19),AH5(19),AH6(19),AH7(19) 1 ,AH1(20),AH2(20),AH3(20),AH4(20),AH5(20),AH6(20),AH7(20) 1 /2.542, 2.869, 2628.0, 1854.0,0.014720,0.005609, 6905.0, 1 3.792, 4.293, 2862.0, 1009.0,0.013970,0.006118, 6551.0, 1 4.154, 4.739, 2766.0, 164.5,0.020230,0.006628, 6309.0, 1 4.150, 4.700, 3329.0, 550.0,0.013210,0.007138, 6194.0, 1 3.232, 3.647, 3561.0, 1560.0,0.012670,0.007648, 5942.0, 1 3.447, 3.891, 3792.0, 1219.0,0.012110,0.008158, 5678.0, 1 5.047, 5.714, 4023.0, 878.6,0.011780,0.008668, 5524.0, 1 5.731, 6.500, 4253.0, 530.0,0.011230,0.009178, 5268.0, 1 5.151, 5.833, 4482.0, 545.7,0.011290,0.009687, 5295.0, 1 5.521, 6.252, 4710.0, 553.3,0.011120,0.010200, 5214.0/ DATA AH1(21),AH2(21),AH3(21),AH4(21),AH5(21),AH6(21),AH7(21) 1 ,AH1(22),AH2(22),AH3(22),AH4(22),AH5(22),AH6(22),AH7(22) 1 ,AH1(23),AH2(23),AH3(23),AH4(23),AH5(23),AH6(23),AH7(23) 1 ,AH1(24),AH2(24),AH3(24),AH4(24),AH5(24),AH6(24),AH7(24) 1 ,AH1(25),AH2(25),AH3(25),AH4(25),AH5(25),AH6(25),AH7(25) 1 ,AH1(26),AH2(26),AH3(26),AH4(26),AH5(26),AH6(26),AH7(26) 1 ,AH1(27),AH2(27),AH3(27),AH4(27),AH5(27),AH6(27),AH7(27) 1 ,AH1(28),AH2(28),AH3(28),AH4(28),AH5(28),AH6(28),AH7(28) 1 ,AH1(29),AH2(29),AH3(29),AH4(29),AH5(29),AH6(29),AH7(29) 1 ,AH1(30),AH2(30),AH3(30),AH4(30),AH5(30),AH6(30),AH7(30) 1 /5.201, 5.884, 4938.0, 560.9,0.009995,0.010710, 4688.0, 1 4.862, 5.496, 5165.0, 568.5,0.009474,0.011220, 4443.0, 1 4.480, 5.055, 5391.0, 952.3,0.009117,0.011730, 4276.0, 1 3.983, 4.489, 5616.0, 1336.0,0.008413,0.012240, 3946.0, 1 3.469, 3.907, 5725.0, 1461.0,0.008829,0.012750, 3785.0, 1 3.519, 3.963, 6065.0, 1243.0,0.007782,0.013260, 3650.0, 1 3.140, 3.535, 6288.0, 1372.0,0.007361,0.013770, 3453.0, 1 3.553, 4.004, 6205.0, 555.1,0.008763,0.014280, 3297.0, 1 3.696, 4.175, 4673.0, 387.8,0.021880,0.014790, 3174.0, 1 4.210, 4.750, 6953.0, 295.2,0.006809,0.015300, 3194.0/ DATA AH1(31),AH2(31),AH3(31),AH4(31),AH5(31),AH6(31),AH7(31) 1 ,AH1(32),AH2(32),AH3(32),AH4(32),AH5(32),AH6(32),AH7(32) 1 ,AH1(33),AH2(33),AH3(33),AH4(33),AH5(33),AH6(33),AH7(33) 1 ,AH1(34),AH2(34),AH3(34),AH4(34),AH5(34),AH6(34),AH7(34) 1 ,AH1(35),AH2(35),AH3(35),AH4(35),AH5(35),AH6(35),AH7(35) 1 ,AH1(36),AH2(36),AH3(36),AH4(36),AH5(36),AH6(36),AH7(36) 1 ,AH1(37),AH2(37),AH3(37),AH4(37),AH5(37),AH6(37),AH7(37) 1 ,AH1(38),AH2(38),AH3(38),AH4(38),AH5(38),AH6(38),AH7(38) 1 ,AH1(39),AH2(39),AH3(39),AH4(39),AH5(39),AH6(39),AH7(39) 1 ,AH1(40),AH2(40),AH3(40),AH4(40),AH5(40),AH6(40),AH7(40) 1 /5.041, 5.697, 7173.0, 202.6,0.006725,0.015810, 3154.0, 1 5.554, 6.300, 6496.0, 110.0,0.009689,0.016320, 3097.0, 1 5.323, 6.012, 7611.0, 292.5,0.006447,0.016830, 3024.0, 1 5.874, 6.656, 7395.0, 117.5,0.007684,0.017340, 3006.0, 1 5.611, 6.335, 8046.0, 365.2,0.006244,0.017850, 2928.0, 1 6.411, 7.250, 8262.0, 220.0,0.006087,0.018360, 2855.0, 1 5.694, 6.429, 8478.0, 292.9,0.006087,0.018860, 2855.0, 1 6.339, 7.159, 8693.0, 330.3,0.006003,0.019370, 2815.0, 1 6.407, 7.234, 8907.0, 367.8,0.005889,0.019880, 2762.0, 1 6.734, 7.603, 9120.0, 405.2,0.005765,0.020390, 2700.0/ DATA AH1(41),AH2(41),AH3(41),AH4(41),AH5(41),AH6(41),AH7(41) 1 ,AH1(42),AH2(42),AH3(42),AH4(42),AH5(42),AH6(42),AH7(42) 1 ,AH1(43),AH2(43),AH3(43),AH4(43),AH5(43),AH6(43),AH7(43) 1 ,AH1(44),AH2(44),AH3(44),AH4(44),AH5(44),AH6(44),AH7(44) 1 ,AH1(45),AH2(45),AH3(45),AH4(45),AH5(45),AH6(45),AH7(45) 1 ,AH1(46),AH2(46),AH3(46),AH4(46),AH5(46),AH6(46),AH7(46) 1 ,AH1(47),AH2(47),AH3(47),AH4(47),AH5(47),AH6(47),AH7(47) 1 ,AH1(48),AH2(48),AH3(48),AH4(48),AH5(48),AH6(48),AH7(48) 1 ,AH1(49),AH2(49),AH3(49),AH4(49),AH5(49),AH6(49),AH7(49) 1 ,AH1(50),AH2(50),AH3(50),AH4(50),AH5(50),AH6(50),AH7(50) 1 /6.902, 7.791, 9333.0, 442.7,0.005587,0.020900, 2621.0, 1 6.425, 7.248, 9545.0, 480.2,0.005367,0.021410, 2517.0, 1 6.799, 7.671, 9756.0, 517.6,0.005315,0.021920, 2493.0, 1 6.108, 6.887, 9966.0, 555.1,0.005151,0.022430, 2416.0, 1 5.924, 6.677,10180.0, 592.5,0.004919,0.022940, 2307.0, 1 5.238, 5.900,10380.0, 630.0,0.004758,0.023450, 2231.0, 1 5.623, 6.354, 7160.0, 337.6,0.013940,0.023960, 2193.0, 1 5.814, 6.554,10800.0, 355.5,0.004626,0.024470, 2170.0, 1 6.230, 7.024,11010.0, 370.9,0.004540,0.024980, 2129.0, 1 6.410, 7.227,11210.0, 386.4,0.004474,0.025490, 2099.0/ DATA AH1(51),AH2(51),AH3(51),AH4(51),AH5(51),AH6(51),AH7(51) 1 ,AH1(52),AH2(52),AH3(52),AH4(52),AH5(52),AH6(52),AH7(52) 1 ,AH1(53),AH2(53),AH3(53),AH4(53),AH5(53),AH6(53),AH7(53) 1 ,AH1(54),AH2(54),AH3(54),AH4(54),AH5(54),AH6(54),AH7(54) 1 ,AH1(55),AH2(55),AH3(55),AH4(55),AH5(55),AH6(55),AH7(55) 1 ,AH1(56),AH2(56),AH3(56),AH4(56),AH5(56),AH6(56),AH7(56) 1 ,AH1(57),AH2(57),AH3(57),AH4(57),AH5(57),AH6(57),AH7(57) 1 ,AH1(58),AH2(58),AH3(58),AH4(58),AH5(58),AH6(58),AH7(58) 1 ,AH1(59),AH2(59),AH3(59),AH4(59),AH5(59),AH6(59),AH7(59) 1 ,AH1(60),AH2(60),AH3(60),AH4(60),AH5(60),AH6(60),AH7(60) 1 /7.500, 8.480, 8608.0, 348.0,0.009074,0.026000, 2069.0, 1 6.979, 7.871,11620.0, 392.4,0.004402,0.026510, 2065.0, 1 7.725, 8.716,11830.0, 394.8,0.004376,0.027020, 2052.0, 1 8.231, 9.289,12030.0, 397.3,0.004384,0.027530, 2056.0, 1 7.287, 8.218,12230.0, 399.7,0.004447,0.028040, 2086.0, 1 7.899, 8.911,12430.0, 402.1,0.004511,0.028550, 2116.0, 1 8.041, 9.071,12630.0, 404.5,0.004540,0.029060, 2129.0, 1 7.489, 8.444,12830.0, 406.9,0.004420,0.029570, 2073.0, 1 7.291, 8.219,13030.0, 409.3,0.004298,0.030080, 2016.0, 1 7.098, 8.000,13230.0, 411.8,0.004182,0.030590, 1962.0/ DATA AH1(61),AH2(61),AH3(61),AH4(61),AH5(61),AH6(61),AH7(61) 1 ,AH1(62),AH2(62),AH3(62),AH4(62),AH5(62),AH6(62),AH7(62) 1 ,AH1(63),AH2(63),AH3(63),AH4(63),AH5(63),AH6(63),AH7(63) 1 ,AH1(64),AH2(64),AH3(64),AH4(64),AH5(64),AH6(64),AH7(64) 1 ,AH1(65),AH2(65),AH3(65),AH4(65),AH5(65),AH6(65),AH7(65) 1 ,AH1(66),AH2(66),AH3(66),AH4(66),AH5(66),AH6(66),AH7(66) 1 ,AH1(67),AH2(67),AH3(67),AH4(67),AH5(67),AH6(67),AH7(67) 1 ,AH1(68),AH2(68),AH3(68),AH4(68),AH5(68),AH6(68),AH7(68) 1 ,AH1(69),AH2(69),AH3(69),AH4(69),AH5(69),AH6(69),AH7(69) 1 ,AH1(70),AH2(70),AH3(70),AH4(70),AH5(70),AH6(70),AH7(70) 1 /6.910, 7.786,13430.0, 414.2,0.004058,0.031100, 1903.0, 1 6.728, 7.580,13620.0, 416.6,0.003976,0.031610, 1865.0, 1 6.551, 7.380,13820.0, 419.0,0.003877,0.032120, 1819.0, 1 6.739, 7.592,14020.0, 421.4,0.003863,0.032630, 1812.0, 1 6.212, 7.996,14210.0, 423.9,0.003725,0.033140, 1747.0, 1 5.517, 6.210,14440.0, 426.3,0.003632,0.033650, 1703.0, 1 5.219, 5.874,14600.0, 428.7,0.003498,0.034160, 1640.0, 1 5.071, 5.706,14790.0, 433.0,0.003405,0.034670, 1597.0, 1 4.926, 5.542,14980.0, 433.5,0.003342,0.035180, 1567.0, 1 4.787, 5.386,15170.0, 435.9,0.003292,0.035690, 1544.0/ DATA AH1(71),AH2(71),AH3(71),AH4(71),AH5(71),AH6(71),AH7(71) 1 ,AH1(72),AH2(72),AH3(72),AH4(72),AH5(72),AH6(72),AH7(72) 1 ,AH1(73),AH2(73),AH3(73),AH4(73),AH5(73),AH6(73),AH7(73) 1 ,AH1(74),AH2(74),AH3(74),AH4(74),AH5(74),AH6(74),AH7(74) 1 ,AH1(75),AH2(75),AH3(75),AH4(75),AH5(75),AH6(75),AH7(75) 1 ,AH1(76),AH2(76),AH3(76),AH4(76),AH5(76),AH6(76),AH7(76) 1 ,AH1(77),AH2(77),AH3(77),AH4(77),AH5(77),AH6(77),AH7(77) 1 ,AH1(78),AH2(78),AH3(78),AH4(78),AH5(78),AH6(78),AH7(78) 1 ,AH1(79),AH2(79),AH3(79),AH4(79),AH5(79),AH6(79),AH7(79) 1 ,AH1(80),AH2(80),AH3(80),AH4(80),AH5(80),AH6(80),AH7(80) 1 /4.893, 5.505,15360.0, 438.4,0.003243,0.036200, 1521.0, 1 5.028, 5.657,15550.0, 440.8,0.003195,0.036710, 1499.0, 1 4.738, 5.329,15740.0, 443.2,0.003186,0.037220, 1494.0, 1 4.574, 5.144,15930.0, 442.4,0.003144,0.037730, 1475.0, 1 5.200, 5.851,16120.0, 441.6,0.003122,0.038240, 1464.0, 1 5.070, 5.704,16300.0, 440.9,0.003082,0.038750, 1446.0, 1 4.945, 5.563,16490.0, 440.1,0.002965,0.039260, 1390.0, 1 4.476, 5.034,16670.0, 439.3,0.002871,0.039770, 1347.0, 1 4.856, 5.460,18320.0, 438.5,0.002542,0.040280, 1354.0, 1 4.308, 4.843,17040.0, 487.8,0.002882,0.040790, 1352.0/ DATA AH1(81),AH2(81),AH3(81),AH4(81),AH5(81),AH6(81),AH7(81) 1 ,AH1(82),AH2(82),AH3(82),AH4(82),AH5(82),AH6(82),AH7(82) 1 ,AH1(83),AH2(83),AH3(83),AH4(83),AH5(83),AH6(83),AH7(83) 1 ,AH1(84),AH2(84),AH3(84),AH4(84),AH5(84),AH6(84),AH7(84) 1 ,AH1(85),AH2(85),AH3(85),AH4(85),AH5(85),AH6(85),AH7(85) 1 ,AH1(86),AH2(86),AH3(86),AH4(86),AH5(86),AH6(86),AH7(86) 1 ,AH1(87),AH2(87),AH3(87),AH4(87),AH5(87),AH6(87),AH7(87) 1 ,AH1(88),AH2(88),AH3(88),AH4(88),AH5(88),AH6(88),AH7(88) 1 ,AH1(89),AH2(89),AH3(89),AH4(89),AH5(89),AH6(89),AH7(89) 1 ,AH1(90),AH2(90),AH3(90),AH4(90),AH5(90),AH6(90),AH7(90) 1 /4.723, 5.311,17220.0, 537.0,0.002913,0.041300, 1366.0, 1 5.319, 5.982,17400.0, 586.3,0.002871,0.041810, 1347.0, 1 5.956, 6.700,17800.0, 677.0,0.002660,0.042320, 1336.0, 1 6.158, 6.928,17770.0, 586.3,0.002813,0.042830, 1319.0, 1 6.204, 6.979,17950.0, 586.3,0.002776,0.043340, 1302.0, 1 6.181, 6.954,18120.0, 586.3,0.002748,0.043850, 1289.0, 1 6.949, 7.820,18300.0, 586.3,0.002737,0.044360, 1284.0, 1 7.506, 8.448,18480.0, 586.3,0.002727,0.044870, 1279.0, 1 7.649, 8.609,18660.0, 586.3,0.002697,0.045380, 1265.0, 1 7.710, 8.679,18830.0, 586.3,0.002641,0.045890, 1239.0/ DATA AH1(91),AH2(91),AH3(91),AH4(91),AH5(91),AH6(91),AH7(91) 1 ,AH1(92),AH2(92),AH3(92),AH4(92),AH5(92),AH6(92),AH7(92) 1 /7.407, 8.336,19010.0, 586.3,0.002603,0.046400, 1221.0, 1 7.290, 8.204,19180.0, 586.3,0.002573,0.046910, 1207.0/ C C COEFFICIENTS FOR HE IN SOLID MATTER, LOW ENERGIES C DATA A1( 1),A2( 1),A3( 1),A4( 1),A5( 1) 1 ,A1( 2),A2( 2),A3( 2),A4( 2),A5( 2) 1 ,A1( 3),A2( 3),A3( 3),A4( 3),A5( 3) 1 ,A1( 4),A2( 4),A3( 4),A4( 4),A5( 4) 1 ,A1( 5),A2( 5),A3( 5),A4( 5),A5( 5) 1 ,A1( 6),A2( 6),A3( 6),A4( 6),A5( 6) 1 ,A1( 7),A2( 7),A3( 7),A4( 7),A5( 7) 1 ,A1( 8),A2( 8),A3( 8),A4( 8),A5( 8) 1 ,A1( 9),A2( 9),A3( 9),A4( 9),A5( 9) 1 ,A1(10),A2(10),A3(10),A4(10),A5(10) 1 /0.9661, 0.4126, 6.9200, 8.8310, 2.5820, 1 2.0270, 0.2931, 26.3400, 6.6600, 0.3409, 1 1.4200, 0.4900, 12.2500, 32.0000, 9.1610, 1 2.2060, 0.5100, 15.3200, 0.2500, 8.9950, 1 3.6910, 0.4128, 18.4800, 50.7200, 9.0000, 1 4.2320, 0.3877, 22.9900, 35.0000, 7.9930, 1 2.5100, 0.4752, 38.2600, 13.0200, 1.8920, 1 1.7660, 0.5261, 37.1100, 15.2400, 2.8040, 1 1.5330, 0.5310, 40.4400, 18.4100, 2.7180, 1 1.1830, 0.5500, 39.8300, 17.4900, 4.0010/ DATA A1(11),A2(11),A3(11),A4(11),A5(11) 1 ,A1(12),A2(12),A3(12),A4(12),A5(12) 1 ,A1(13),A2(13),A3(13),A4(13),A5(13) 1 ,A1(14),A2(14),A3(14),A4(14),A5(14) 1 ,A1(15),A2(15),A3(15),A4(15),A5(15) 1 ,A1(16),A2(16),A3(16),A4(16),A5(16) 1 ,A1(17),A2(17),A3(17),A4(17),A5(17) 1 ,A1(18),A2(18),A3(18),A4(18),A5(18) 1 ,A1(19),A2(19),A3(19),A4(19),A5(19) 1 ,A1(20),A2(20),A3(20),A4(20),A5(20) 1 /9.8940, 0.3081, 23.6500, 0.3840, 92.9300, 1 4.3000, 0.4700, 34.3000, 3.3000, 12.7400, 1 2.5000, 0.6250, 45.7000, 0.1000, 4.3590, 1 2.1000, 0.6500, 49.3400, 1.7880, 4.1330, 1 1.7290, 0.6562, 53.4100, 2.4050, 3.8450, 1 1.4020, 0.6791, 58.9800, 3.5280, 3.2110, 1 1.1170, 0.7044, 69.6900, 3.7050, 2.1560, 1 0.9172, 0.7240, 79.4400, 3.6480, 1.6460, 1 8.5540, 0.3817, 83.6100, 11.8400, 1.8750, 1 6.2970, 0.4622, 65.3900, 10.1400, 5.0360/ DATA A1(21),A2(21),A3(21),A4(21),A5(21) 1 ,A1(22),A2(22),A3(22),A4(22),A5(22) 1 ,A1(23),A2(23),A3(23),A4(23),A5(23) 1 ,A1(24),A2(24),A3(24),A4(24),A5(24) 1 ,A1(25),A2(25),A3(25),A4(25),A5(25) 1 ,A1(26),A2(26),A3(26),A4(26),A5(26) 1 ,A1(27),A2(27),A3(27),A4(27),A5(27) 1 ,A1(28),A2(28),A3(28),A4(28),A5(28) 1 ,A1(29),A2(29),A3(29),A4(29),A5(29) 1 ,A1(30),A2(30),A3(30),A4(30),A5(30) 1 /5.3070, 0.4918, 61.7400, 12.4000, 6.6650, 1 4.7100, 0.5087, 65.2800, 8.8060, 5.9480, 1 6.1510, 0.4524, 83.0000, 18.3100, 2.7100, 1 6.5700, 0.4322, 84.7600, 15.5300, 2.7790, 1 5.7380, 0.4492, 84.6100, 14.1800, 3.1010, 1 5.0310, 0.4707, 85.5800, 16.5500, 3.2110, 1 4.3200, 0.4947, 76.1400, 10.8500, 5.4410, 1 4.6520, 0.4571, 80.7300, 22.0000, 4.9520, 1 3.1140, 0.5236, 76.6700, 7.6200, 6.3850, 1 3.1140, 0.5236, 76.6700, 7.6200, 7.5020/ DATA A1(31),A2(31),A3(31),A4(31),A5(31) 1 ,A1(32),A2(32),A3(32),A4(32),A5(32) 1 ,A1(33),A2(33),A3(33),A4(33),A5(33) 1 ,A1(34),A2(34),A3(34),A4(34),A5(34) 1 ,A1(35),A2(35),A3(35),A4(35),A5(35) 1 ,A1(36),A2(36),A3(36),A4(36),A5(36) 1 ,A1(37),A2(37),A3(37),A4(37),A5(37) 1 ,A1(38),A2(38),A3(38),A4(38),A5(38) 1 ,A1(39),A2(39),A3(39),A4(39),A5(39) 1 ,A1(40),A2(40),A3(40),A4(40),A5(40) 1 /3.1140, 0.5236, 76.6700, 7.6200, 8.5140, 1 5.7460, 0.4662, 79.2400, 1.1850, 7.9930, 1 2.7920, 0.6346,106.1000, 0.2986, 2.3310, 1 4.6670, 0.5095,124.3000, 2.1020, 1.6670, 1 2.4400, 0.6346,105.0000, 0.8300, 2.8510, 1 1.4910, 0.7118,120.6000, 1.1010, 1.8770, 1 11.7200, 0.3826,102.8000, 9.2310, 4.3710, 1 7.1260, 0.4804,119.3000, 5.7840, 2.4540, 1 11.6100, 0.3955,146.7000, 7.0310, 1.4230, 1 10.9900, 0.4100,163.9000, 7.1000, 1.0520/ DATA A1(41),A2(41),A3(41),A4(41),A5(41) 1 ,A1(42),A2(42),A3(42),A4(42),A5(42) 1 ,A1(43),A2(43),A3(43),A4(43),A5(43) 1 ,A1(44),A2(44),A3(44),A4(44),A5(44) 1 ,A1(45),A2(45),A3(45),A4(45),A5(45) 1 ,A1(46),A2(46),A3(46),A4(46),A5(46) 1 ,A1(47),A2(47),A3(47),A4(47),A5(47) 1 ,A1(48),A2(48),A3(48),A4(48),A5(48) 1 ,A1(49),A2(49),A3(49),A4(49),A5(49) 1 ,A1(50),A2(50),A3(50),A4(50),A5(50) 1 /9.2410, 0.4275,163.1000, 7.9540, 1.1020, 1 9.2760, 0.4180,157.1000, 8.0380, 1.2900, 1 3.9990, 0.6152, 97.6000, 1.2970, 5.7920, 1 4.3060, 0.5658, 97.9900, 5.5140, 5.7540, 1 3.6150, 0.6197, 86.2600, 0.3330, 8.6890, 1 5.8000, 0.4900,147.2000, 6.9030, 1.2890, 1 5.6000, 0.4900,130.0000, 10.0000, 2.8440, 1 3.5500, 0.6068,124.7000, 1.1120, 3.1190, 1 3.6000, 0.6200,105.8000, 0.1692, 6.0260, 1 5.4000, 0.5300,103.1000, 3.9310, 7.7670/ DATA A1(51),A2(51),A3(51),A4(51),A5(51) 1 ,A1(52),A2(52),A3(52),A4(52),A5(52) 1 ,A1(53),A2(53),A3(53),A4(53),A5(53) 1 ,A1(54),A2(54),A3(54),A4(54),A5(54) 1 ,A1(55),A2(55),A3(55),A4(55),A5(55) 1 ,A1(56),A2(56),A3(56),A4(56),A5(56) 1 ,A1(57),A2(57),A3(57),A4(57),A5(57) 1 ,A1(58),A2(58),A3(58),A4(58),A5(58) 1 ,A1(59),A2(59),A3(59),A4(59),A5(59) 1 ,A1(60),A2(60),A3(60),A4(60),A5(60) 1 /3.9700, 0.6459,131.8000, 0.2233, 2.7230, 1 3.6500, 0.6400,126.8000, 0.6834, 3.4110, 1 3.1180, 0.6519,164.9000, 1.2080, 1.5100, 1 2.0310, 0.7181,153.1000, 1.3620, 1.9580, 1 14.4000, 0.3923,152.5000, 8.3540, 2.5970, 1 10.9900, 0.4599,138.4000, 4.8110, 3.7260, 1 16.6000, 0.3773,224.1000, 6.2800, 0.9121, 1 10.5400, 0.4533,159.3000, 4.8320, 2.5290, 1 10.3300, 0.4502,162.0000, 5.1320, 2.4440, 1 10.1500, 0.4471,165.6000, 5.3780, 2.3280/ DATA A1(61),A2(61),A3(61),A4(61),A5(61) 1 ,A1(62),A2(62),A3(62),A4(62),A5(62) 1 ,A1(63),A2(63),A3(63),A4(63),A5(63) 1 ,A1(64),A2(64),A3(64),A4(64),A5(64) 1 ,A1(65),A2(65),A3(65),A4(65),A5(65) 1 ,A1(66),A2(66),A3(66),A4(66),A5(66) 1 ,A1(67),A2(67),A3(67),A4(67),A5(67) 1 ,A1(68),A2(68),A3(68),A4(68),A5(68) 1 ,A1(69),A2(69),A3(69),A4(69),A5(69) 1 ,A1(70),A2(70),A3(70),A4(70),A5(70) 1 /9.9760, 0.4439,168.0000, 5.7210, 2.2580, 1 9.8040, 0.4408,176.2000, 5.6750, 1.9970, 1 14.2200, 0.3630,228.4000, 7.0240, 1.0160, 1 9.9520, 0.4318,233.5000, 5.0650, 0.9244, 1 9.2720, 0.4345,210.0000, 4.9110, 1.2580, 1 10.1300, 0.4146,225.7000, 5.5250, 1.0550, 1 8.9490, 0.4304,213.3000, 5.0710, 1.2210, 1 11.9400, 0.3783,247.2000, 6.6550, 0.8490, 1 8.4720, 0.4405,195.5000, 4.0510, 1.6040, 1 8.3010, 0.4399,203.7000, 3.6670, 1.4590/ DATA A1(71),A2(71),A3(71),A4(71),A5(71) 1 ,A1(72),A2(72),A3(72),A4(72),A5(72) 1 ,A1(73),A2(73),A3(73),A4(73),A5(73) 1 ,A1(74),A2(74),A3(74),A4(74),A5(74) 1 ,A1(75),A2(75),A3(75),A4(75),A5(75) 1 ,A1(76),A2(76),A3(76),A4(76),A5(76) 1 ,A1(77),A2(77),A3(77),A4(77),A5(77) 1 ,A1(78),A2(78),A3(78),A4(78),A5(78) 1 ,A1(79),A2(79),A3(79),A4(79),A5(79) 1 ,A1(80),A2(80),A3(80),A4(80),A5(80) 1 /6.5670, 0.4858,193.0000, 2.6500, 1.6600, 1 5.9510, 0.5016,196.1000, 2.6620, 1.5890, 1 7.4950, 0.4523,251.4000, 3.4330, 0.8619, 1 6.3350, 0.4825,255.1000, 2.8340, 0.8228, 1 4.3140, 0.5558,214.8000, 2.3540, 1.2630, 1 4.0200, 0.5681,219.9000, 2.4020, 1.1910, 1 3.8360, 0.5765,210.2000, 2.7420, 1.3050, 1 4.6800, 0.5247,244.7000, 2.7490, 0.8962, 1 3.2230, 0.5883,232.7000, 2.9540, 1.0500, 1 2.8920, 0.6204,208.6000, 2.4150, 1.4160/ DATA A1(81),A2(81),A3(81),A4(81),A5(81) 1 ,A1(82),A2(82),A3(82),A4(82),A5(82) 1 ,A1(83),A2(83),A3(83),A4(83),A5(83) 1 ,A1(84),A2(84),A3(84),A4(84),A5(84) 1 ,A1(85),A2(85),A3(85),A4(85),A5(85) 1 ,A1(86),A2(86),A3(86),A4(86),A5(86) 1 ,A1(87),A2(87),A3(87),A4(87),A5(87) 1 ,A1(88),A2(88),A3(88),A4(88),A5(88) 1 ,A1(89),A2(89),A3(89),A4(89),A5(89) 1 ,A1(90),A2(90),A3(90),A4(90),A5(90) 1 /4.7280, 0.5522,217.0000, 3.0910, 1.3860, 1 6.1800, 0.5200,170.0000, 4.0000, 3.2240, 1 9.0000, 0.4700,198.0000, 3.8000, 2.0320, 1 2.3240, 0.6997,216.0000, 1.5990, 1.3990, 1 1.9610, 0.7286,223.0000, 1.6210, 1.2960, 1 1.7500, 0.7427,350.1001, 0.9789, 0.5507, 1 10.3100, 0.4613,261.2000, 4.7380, 0.9899, 1 7.9620, 0.5190,235.7000, 4.3470, 1.3130, 1 6.2270, 0.5645,231.9000, 3.9610, 1.3790, 1 5.2460, 0.5947,228.6000, 4.0270, 1.4320/ DATA A1(91),A2(91),A3(91),A4(91),A5(91) 1 ,A1(92),A2(92),A3(92),A4(92),A5(92) 1 /5.4080, 0.5811,235.7000, 3.9610, 1.3580, 1 5.2180, 0.5828,245.0000, 3.8380, 1.2500/ C C COEFFICIENTS FOR HE IN GASEOUS MATTER, LOW ENERGIES C DATA B1( 1),B2( 1),B3( 1),B4( 1),B5( 1) 1 ,B1( 2),B2( 2),B3( 2),B4( 2),B5( 2) 1 ,B1( 3),B2( 3),B3( 3),B4( 3),B5( 3) 1 ,B1( 4),B2( 4),B3( 4),B4( 4),B5( 4) 1 ,B1( 5),B2( 5),B3( 5),B4( 5),B5( 5) 1 ,B1( 6),B2( 6),B3( 6),B4( 6),B5( 6) 1 ,B1( 7),B2( 7),B3( 7),B4( 7),B5( 7) 1 ,B1( 8),B2( 8),B3( 8),B4( 8),B5( 8) 1 ,B1( 9),B2( 9),B3( 9),B4( 9),B5( 9) 1 ,B1(10),B2(10),B3(10),B4(10),B5(10) 1 /0.39, 0.63, 4.17, 85.55, 19.55, 1 0.58, 0.59, 6.3, 130., 44.07, 1 15.23, 0.1076, 10.14, 1232., 31.24, 1 2.2060, 0.5100, 15.3200, 0.2500, 8.9950, 1 3.6910, 0.4128, 18.4800, 50.7200, 9.0000, 1 3.47,0.4485, 22.37, 36.41, 7.993, 1 2.0, 0.548, 29.82, 18.11, 4.37, 1 2.717, 0.4858, 32.88, 25.88, 4.336, 1 2.616, 0.4708, 41.2, 28.07, 2.458, 1 2.303, 0.4861, 37.01, 37.96, 5.092/ DATA B1(11),B2(11),B3(11),B4(11),B5(11) 1 ,B1(12),B2(12),B3(12),B4(12),B5(12) 1 ,B1(13),B2(13),B3(13),B4(13),B5(13) 1 ,B1(14),B2(14),B3(14),B4(14),B5(14) 1 ,B1(15),B2(15),B3(15),B4(15),B5(15) 1 ,B1(16),B2(16),B3(16),B4(16),B5(16) 1 ,B1(17),B2(17),B3(17),B4(17),B5(17) 1 ,B1(18),B2(18),B3(18),B4(18),B5(18) 1 ,B1(19),B2(19),B3(19),B4(19),B5(19) 1 ,B1(20),B2(20),B3(20),B4(20),B5(20) 1 /13.03, 0.2685, 35.65, 44.18, 9.175, 1 4.3000, 0.4700, 34.3000, 3.3000, 12.7400, 1 2.5000, 0.6250, 45.7000, 0.1000, 4.3590, 1 2.1000, 0.6500, 49.3400, 1.7880, 4.1330, 1 1.7290, 0.6562, 53.4100, 2.4050, 4.8450, 1 3.116, 0.5988, 53.71, 5.632, 4.536, 1 3.365, 0.571, 63.67, 6.182, 2.969, 1 2.291, 0.6284, 73.88, 4.478, 2.066, 1 16.6, 0.3095, 99.1, 10.98, 1.092, 1 6.2970, 0.4622, 65.3900, 10.1400, 5.0360/ DATA B1(21),B2(21),B3(21),B4(21),B5(21) 1 ,B1(22),B2(22),B3(22),B4(22),B5(22) 1 ,B1(23),B2(23),B3(23),B4(23),B5(23) 1 ,B1(24),B2(24),B3(24),B4(24),B5(24) 1 ,B1(25),B2(25),B3(25),B4(25),B5(25) 1 ,B1(26),B2(26),B3(26),B4(26),B5(26) 1 ,B1(27),B2(27),B3(27),B4(27),B5(27) 1 ,B1(28),B2(28),B3(28),B4(28),B5(28) 1 ,B1(29),B2(29),B3(29),B4(29),B5(29) 1 ,B1(30),B2(30),B3(30),B4(30),B5(30) 1 /5.3070, 0.4918, 61.7400, 12.4000, 6.6650, 1 4.7100, 0.5087, 65.2800, 8.8060, 5.9480, 1 6.1510, 0.4524, 83.0000, 18.3100, 2.7100, 1 6.5700, 0.4322, 84.7600, 15.5300, 2.7790, 1 5.7380, 0.4492, 84.6100, 14.1800, 3.1010, 1 5.0310, 0.4707, 85.5800, 16.5500, 3.2110, 1 4.3200, 0.4947, 76.1400, 10.8500, 5.4410, 1 4.6520, 0.4571, 80.7300, 22.0000, 4.9520, 1 3.1140, 0.5236, 76.6700, 7.6200, 6.3850, 1 3.1140, 0.5236, 76.6700, 7.6200, 7.5020/ DATA B1(31),B2(31),B3(31),B4(31),B5(31) 1 ,B1(32),B2(32),B3(32),B4(32),B5(32) 1 ,B1(33),B2(33),B3(33),B4(33),B5(33) 1 ,B1(34),B2(34),B3(34),B4(34),B5(34) 1 ,B1(35),B2(35),B3(35),B4(35),B5(35) 1 ,B1(36),B2(36),B3(36),B4(36),B5(36) 1 ,B1(37),B2(37),B3(37),B4(37),B5(37) 1 ,B1(38),B2(38),B3(38),B4(38),B5(38) 1 ,B1(39),B2(39),B3(39),B4(39),B5(39) 1 ,B1(40),B2(40),B3(40),B4(40),B5(40) 1 /3.1140, 0.5236, 76.6700, 7.6200, 8.5140, 1 5.7460, 0.4662, 79.2400, 1.1850, 7.9930, 1 2.7920, 0.6346,106.1000, 0.2986, 2.3310, 1 4.6670, 0.5095,124.3000, 2.1020, 1.6670, 1 1.65, 0.7, 148.1, 1.47, 0.9686, 1 1.413, 0.7377, 147.9, 1.466, 1.016, 1 11.7200, 0.3826,102.8000, 9.0000, 4.3710, 1 7.1260, 0.4804,119.3000, 5.7840, 2.4540, 1 11.6100, 0.3955,146.7000, 7.0310, 1.4230, 1 10.9900, 0.4100,163.9000, 7.1000, 1.0520/ DATA B1(41),B2(41),B3(41),B4(41),B5(41) 1 ,B1(42),B2(42),B3(42),B4(42),B5(42) 1 ,B1(43),B2(43),B3(43),B4(43),B5(43) 1 ,B1(44),B2(44),B3(44),B4(44),B5(44) 1 ,B1(45),B2(45),B3(45),B4(45),B5(45) 1 ,B1(46),B2(46),B3(46),B4(46),B5(46) 1 ,B1(47),B2(47),B3(47),B4(47),B5(47) 1 ,B1(48),B2(48),B3(48),B4(48),B5(48) 1 ,B1(49),B2(49),B3(49),B4(49),B5(49) 1 ,B1(50),B2(50),B3(50),B4(50),B5(50) 1 /9.2410, 0.4275,163.1000, 7.9540, 1.1020, 1 9.2760, 0.4180,157.1000, 8.0380, 1.2900, 1 3.9990, 0.6152, 97.6000, 1.2970, 5.7920, 1 4.3020, 0.5658, 97.9900, 5.5140, 5.7540, 1 3.6150, 0.6197, 86.2600, 0.3330, 8.6890, 1 5.8000, 0.4900,147.2000, 6.9030, 1.2890, 1 5.6000, 0.4900,130.0000, 10.0000, 2.8440, 1 3.5500, 0.6068,124.7000, 1.1120, 3.1190, 1 3.6000, 0.6200,105.8000, 0.1692, 6.0260, 1 5.4000, 0.5300,103.1000, 3.9310, 7.7670/ DATA B1(51),B2(51),B3(51),B4(51),B5(51) 1 ,B1(52),B2(52),B3(52),B4(52),B5(52) 1 ,B1(53),B2(53),B3(53),B4(53),B5(53) 1 ,B1(54),B2(54),B3(54),B4(54),B5(54) 1 ,B1(55),B2(55),B3(55),B4(55),B5(55) 1 ,B1(56),B2(56),B3(56),B4(56),B5(56) 1 ,B1(57),B2(57),B3(57),B4(57),B5(57) 1 ,B1(58),B2(58),B3(58),B4(58),B5(58) 1 ,B1(59),B2(59),B3(59),B4(59),B5(59) 1 ,B1(60),B2(60),B3(60),B4(60),B5(60) 1 /3.9700, 0.6459,131.8000, 0.2233, 2.7230, 1 3.6500, 0.6400,126.8000, 0.6834, 3.4110, 1 4.13, 0.6177, 152.0, 2.516, 1.938, 1 3.949, 0.6209, 200.5, 1.878, 0.9126, 1 25.94, 0.3139, 335.1, 2.946, 0.3347, 1 10.9900, 0.4599,138.4000, 4.8110, 3.7260, 1 16.6000, 0.3773,224.1000, 6.2800, 0.9121, 1 10.5400, 0.4533,159.3000, 4.8320, 2.5290, 1 10.3300, 0.4502,162.0000, 5.1320, 2.4440, 1 10.1500, 0.4471,165.6000, 5.3780, 2.3280/ DATA B1(61),B2(61),B3(61),B4(61),B5(61) 1 ,B1(62),B2(62),B3(62),B4(62),B5(62) 1 ,B1(63),B2(63),B3(63),B4(63),B5(63) 1 ,B1(64),B2(64),B3(64),B4(64),B5(64) 1 ,B1(65),B2(65),B3(65),B4(65),B5(65) 1 ,B1(66),B2(66),B3(66),B4(66),B5(66) 1 ,B1(67),B2(67),B3(67),B4(67),B5(67) 1 ,B1(68),B2(68),B3(68),B4(68),B5(68) 1 ,B1(69),B2(69),B3(69),B4(69),B5(69) 1 ,B1(70),B2(70),B3(70),B4(70),B5(70) 1 /9.9760, 0.4439,168.0000, 5.7210, 2.2580, 1 9.8040, 0.4408,176.2000, 5.6750, 1.9970, 1 14.2200, 0.3630,228.4000, 7.0240, 1.0160, 1 9.9520, 0.4318,233.5000, 5.0650, 0.9244, 1 9.2720, 0.4345,210.0000, 4.9110, 1.2580, 1 10.1300, 0.4146,225.7000, 5.5250, 1.0550, 1 8.9490, 0.4304,213.3000, 5.0710, 1.2210, 1 11.9400, 0.3783,247.2000, 6.6550, 0.8490, 1 8.4720, 0.4405,195.5000, 4.0510, 1.6040, 1 8.3010, 0.4399,203.7000, 3.6670, 1.4590/ DATA B1(71),B2(71),B3(71),B4(71),B5(71) 1 ,B1(72),B2(72),B3(72),B4(72),B5(72) 1 ,B1(73),B2(73),B3(73),B4(73),B5(73) 1 ,B1(74),B2(74),B3(74),B4(74),B5(74) 1 ,B1(75),B2(75),B3(75),B4(75),B5(75) 1 ,B1(76),B2(76),B3(76),B4(76),B5(76) 1 ,B1(77),B2(77),B3(77),B4(77),B5(77) 1 ,B1(78),B2(78),B3(78),B4(78),B5(78) 1 ,B1(79),B2(79),B3(79),B4(79),B5(79) 1 ,B1(80),B2(80),B3(80),B4(80),B5(80) 1 /6.5670, 0.4858,193.0000, 2.6500, 1.6600, 1 5.9510, 0.5016,196.1000, 2.6620, 1.5890, 1 7.4950, 0.4523,251.4000, 3.4330, 0.8619, 1 6.3350, 0.4825,255.1000, 2.8340, 0.8228, 1 4.3140, 0.5558,214.8000, 2.3540, 1.2630, 1 4.0200, 0.5681,219.9000, 2.4020, 1.1910, 1 3.8360, 0.5765,210.2000, 2.7420, 1.3050, 1 4.6800, 0.5247,244.7000, 2.7490, 0.9862, 1 3.2230, 0.5883,232.7000, 2.9540, 1.0500, 1 8.15, 0.4745, 269.2, 2.392, 0.7467/ DATA B1(81),B2(81),B3(81),B4(81),B5(81) 1 ,B1(82),B2(82),B3(82),B4(82),B5(82) 1 ,B1(83),B2(83),B3(83),B4(83),B5(83) 1 ,B1(84),B2(84),B3(84),B4(84),B5(84) 1 ,B1(85),B2(85),B3(85),B4(85),B5(85) 1 ,B1(86),B2(86),B3(86),B4(86),B5(86) 1 ,B1(87),B2(87),B3(87),B4(87),B5(87) 1 ,B1(88),B2(88),B3(88),B4(88),B5(88) 1 ,B1(89),B2(89),B3(89),B4(89),B5(89) 1 ,B1(90),B2(90),B3(90),B4(90),B5(90) 1 /4.7280, 0.5522,217.0000, 3.0910, 1.3860, 1 6.1800, 0.5200,170.0000, 4.0000, 3.2240, 1 9.0000, 0.4700,198.0000, 3.8000, 2.0320, 1 2.3240, 0.6997,216.0000, 1.5990, 1.3990, 1 1.9610, 0.7286,223.0000, 1.6210, 1.2960, 1 4.822, 0.605, 418.3, 0.8335, 0.3865, 1 10.3100, 0.4613,261.2000, 4.7380, 0.9899, 1 7.9620, 0.5190,235.7000, 4.3470, 1.3130, 1 6.2270, 0.5645,231.9000, 3.9610, 1.3790, 1 5.2460, 0.5947,228.6000, 4.0270, 1.4320/ DATA B1(91),B2(91),B3(91),B4(91),B5(91) 1 ,B1(92),B2(92),B3(92),B4(92),B5(92) 1 /5.4080, 0.5811,235.7000, 3.9610, 1.3580, 1 5.2180, 0.5828,245.0000, 3.8380, 1.2500/ C C COEFFICIENTS FOR HE IN GASEOUS AND SOLID MATTER, HIGH ENERGIES C DATA A6( 1),A7( 1),A8( 1),A9( 1) 1 ,A6( 2),A7( 2),A8( 2),A9( 2) 1 ,A6( 3),A7( 3),A8( 3),A9( 3) 1 ,A6( 4),A7( 4),A8( 4),A9( 4) 1 ,A6( 5),A7( 5),A8( 5),A9( 5) 1 ,A6( 6),A7( 6),A8( 6),A9( 6) 1 ,A6( 7),A7( 7),A8( 7),A9( 7) 1 ,A6( 8),A7( 8),A8( 8),A9( 8) 1 ,A6( 9),A7( 9),A8( 9),A9( 9) 1 ,A6(10),A7(10),A8(10),A9(10) 1 /2.371000, 0.546200,-0.079320,-0.006853, 1 2.809000, 0.484700,-0.087560,-0.007281, 1 3.095000, 0.443400,-0.092590,-0.007459, 1 3.280000, 0.418800,-0.095640,-0.007604, 1 3.426000, 0.400000,-0.097960,-0.007715, 1 3.588000, 0.392100,-0.099350,-0.007804, 1 3.759000, 0.409400,-0.096460,-0.007661, 1 3.782000, 0.373400,-0.101100,-0.007874, 1 3.816000, 0.350400,-0.104600,-0.008074, 1 3.863000, 0.334200,-0.107200,-0.008231/ DATA A6(11),A7(11),A8(11),A9(11) 1 ,A6(12),A7(12),A8(12),A9(12) 1 ,A6(13),A7(13),A8(13),A9(13) 1 ,A6(14),A7(14),A8(14),A9(14) 1 ,A6(15),A7(15),A8(15),A9(15) 1 ,A6(16),A7(16),A8(16),A9(16) 1 ,A6(17),A7(17),A8(17),A9(17) 1 ,A6(18),A7(18),A8(18),A9(18) 1 ,A6(19),A7(19),A8(19),A9(19) 1 ,A6(20),A7(20),A8(20),A9(20) 1 /3.898000, 0.319100,-0.108600,-0.008271, 1 3.961000, 0.314000,-0.109100,-0.008297, 1 4.024000, 0.311300,-0.109300,-0.008306, 1 4.077000, 0.307400,-0.108900,-0.008219, 1 4.124000, 0.302300,-0.109400,-0.008240, 1 4.164000, 0.296400,-0.110100,-0.008267, 1 4.210000, 0.293600,-0.110300,-0.008270, 1 4.261000, 0.299400,-0.108500,-0.008145, 1 4.300000, 0.290300,-0.110300,-0.008259, 1 4.344000, 0.289700,-0.110200,-0.008245/ DATA A6(21),A7(21),A8(21),A9(21) 1 ,A6(22),A7(22),A8(22),A9(22) 1 ,A6(23),A7(23),A8(23),A9(23) 1 ,A6(24),A7(24),A8(24),A9(24) 1 ,A6(25),A7(25),A8(25),A9(25) 1 ,A6(26),A7(26),A8(26),A9(26) 1 ,A6(27),A7(27),A8(27),A9(27) 1 ,A6(28),A7(28),A8(28),A9(28) 1 ,A6(29),A7(29),A8(29),A9(29) 1 ,A6(30),A7(30),A8(30),A9(30) 1 /4.327000, 0.270700,-0.112700,-0.008370, 1 4.340000, 0.261800,-0.113800,-0.008420, 1 4.361000, 0.255900,-0.114500,-0.008447, 1 4.349000, 0.240000,-0.116600,-0.008550, 1 4.362000, 0.232700,-0.117400,-0.008588, 1 4.375000, 0.225300,-0.118500,-0.008648, 1 4.362000, 0.206900,-0.121400,-0.008815, 1 4.346000, 0.185700,-0.124900,-0.009021, 1 4.355000, 0.180000,-0.125500,-0.009045, 1 4.389000, 0.180600,-0.125300,-0.009028/ DATA A6(31),A7(31),A8(31),A9(31) 1 ,A6(32),A7(32),A8(32),A9(32) 1 ,A6(33),A7(33),A8(33),A9(33) 1 ,A6(34),A7(34),A8(34),A9(34) 1 ,A6(35),A7(35),A8(35),A9(35) 1 ,A6(36),A7(36),A8(36),A9(36) 1 ,A6(37),A7(37),A8(37),A9(37) 1 ,A6(38),A7(38),A8(38),A9(38) 1 ,A6(39),A7(39),A8(39),A9(39) 1 ,A6(40),A7(40),A8(40),A9(40) 1 /4.407000, 0.175900,-0.125800,-0.009054, 1 4.419000, 0.169400,-0.126700,-0.009094, 1 4.412000, 0.154500,-0.128900,-0.009202, 1 4.419000, 0.144800,-0.130300,-0.009269, 1 4.436000, 0.144300,-0.129900,-0.009229, 1 4.478000, 0.160800,-0.126200,-0.008983, 1 4.489000, 0.151700,-0.127800,-0.009078, 1 4.514000, 0.155100,-0.126800,-0.009005, 1 4.533000, 0.156800,-0.126100,-0.008945, 1 4.548000, 0.157200,-0.125600,-0.008901/ DATA A6(41),A7(41),A8(41),A9(41) 1 ,A6(42),A7(42),A8(42),A9(42) 1 ,A6(43),A7(43),A8(43),A9(43) 1 ,A6(44),A7(44),A8(44),A9(44) 1 ,A6(45),A7(45),A8(45),A9(45) 1 ,A6(46),A7(46),A8(46),A9(46) 1 ,A6(47),A7(47),A8(47),A9(47) 1 ,A6(48),A7(48),A8(48),A9(48) 1 ,A6(49),A7(49),A8(49),A9(49) 1 ,A6(50),A7(50),A8(50),A9(50) 1 /4.553000, 0.154400,-0.125500,-0.008883, 1 4.548000, 0.148500,-0.125900,-0.008889, 1 4.489000, 0.112800,-0.130900,-0.009107, 1 4.402000, 0.066560,-0.137500,-0.009421, 1 4.292000, 0.010120,-0.145900,-0.009835, 1 4.187000,-0.045390,-0.154200,-0.010250, 1 4.577000, 0.130000,-0.128500,-0.009067, 1 4.583000, 0.125300,-0.129100,-0.009084, 1 4.580000, 0.117400,-0.130100,-0.009129, 1 4.581000, 0.111000,-0.130900,-0.009161/ DATA A6(51),A7(51),A8(51),A9(51) 1 ,A6(52),A7(52),A8(52),A9(52) 1 ,A6(53),A7(53),A8(53),A9(53) 1 ,A6(54),A7(54),A8(54),A9(54) 1 ,A6(55),A7(55),A8(55),A9(55) 1 ,A6(56),A7(56),A8(56),A9(56) 1 ,A6(57),A7(57),A8(57),A9(57) 1 ,A6(58),A7(58),A8(58),A9(58) 1 ,A6(59),A7(59),A8(59),A9(59) 1 ,A6(60),A7(60),A8(60),A9(60) 1 /4.582000, 0.104600,-0.131700,-0.009193, 1 4.600000, 0.105200,-0.131500,-0.009178, 1 4.614000, 0.104300,-0.131500,-0.009175, 1 4.619000, 0.097690,-0.132500,-0.009231, 1 4.671000, 0.113600,-0.129800,-0.009078, 1 4.706000, 0.120600,-0.128700,-0.009009, 1 4.732000, 0.124400,-0.128000,-0.008968, 1 4.722000, 0.115600,-0.129200,-0.009030, 1 4.710000, 0.106000,-0.130500,-0.009100, 1 4.698000, 0.096470,-0.131900,-0.009169/ DATA A6(61),A7(61),A8(61),A9(61) 1 ,A6(62),A7(62),A8(62),A9(62) 1 ,A6(63),A7(63),A8(63),A9(63) 1 ,A6(64),A7(64),A8(64),A9(64) 1 ,A6(65),A7(65),A8(65),A9(65) 1 ,A6(66),A7(66),A8(66),A9(66) 1 ,A6(67),A7(67),A8(67),A9(67) 1 ,A6(68),A7(68),A8(68),A9(68) 1 ,A6(69),A7(69),A8(69),A9(69) 1 ,A6(70),A7(70),A8(70),A9(70) 1 /4.681000, 0.085360,-0.133500,-0.009252, 1 4.676000, 0.078190,-0.134500,-0.009302, 1 4.663000, 0.068670,-0.135800,-0.009373, 1 4.676000, 0.068610,-0.135700,-0.009363, 1 4.649000, 0.053620,-0.137900,-0.009480, 1 4.634000, 0.043350,-0.139400,-0.009558, 1 4.603000, 0.026790,-0.141800,-0.009690, 1 4.584000, 0.014940,-0.143600,-0.009783, 1 4.576000, 0.007043,-0.144700,-0.009841, 1 4.571000, 0.000705,-0.145600,-0.009886/ DATA A6(71),A7(71),A8(71),A9(71) 1 ,A6(72),A7(72),A8(72),A9(72) 1 ,A6(73),A7(73),A8(73),A9(73) 1 ,A6(74),A7(74),A8(74),A9(74) 1 ,A6(75),A7(75),A8(75),A9(75) 1 ,A6(76),A7(76),A8(76),A9(76) 1 ,A6(77),A7(77),A8(77),A9(77) 1 ,A6(78),A7(78),A8(78),A9(78) 1 ,A6(79),A7(79),A8(79),A9(79) 1 ,A6(80),A7(80),A8(80),A9(80) 1 /4.566000,-0.005626,-0.146400,-0.009930, 1 4.561000,-0.011970,-0.147300,-0.009975, 1 4.572000,-0.012000,-0.147200,-0.009965, 1 4.569000,-0.017550,-0.148000,-0.010000, 1 4.573000,-0.019920,-0.148200,-0.010010, 1 4.570000,-0.025470,-0.149000,-0.010050, 1 4.528000,-0.046130,-0.152100,-0.010220, 1 4.494000,-0.063700,-0.154800,-0.010370, 1 4.564000,-0.027000,-0.147100,-0.009852, 1 4.546000,-0.049630,-0.152300,-0.010220/ DATA A6(81),A7(81),A8(81),A9(81) 1 ,A6(82),A7(82),A8(82),A9(82) 1 ,A6(83),A7(83),A8(83),A9(83) 1 ,A6(84),A7(84),A8(84),A9(84) 1 ,A6(85),A7(85),A8(85),A9(85) 1 ,A6(86),A7(86),A8(86),A9(86) 1 ,A6(87),A7(87),A8(87),A9(87) 1 ,A6(88),A7(88),A8(88),A9(88) 1 ,A6(89),A7(89),A8(89),A9(89) 1 ,A6(90),A7(90),A8(90),A9(90) 1 /4.594000,-0.033390,-0.149600,-0.010060, 1 4.608000,-0.028860,-0.148500,-0.009990, 1 4.624000,-0.026390,-0.148100,-0.009971, 1 4.636000,-0.024220,-0.147700,-0.009939, 1 4.648000,-0.021720,-0.147100,-0.009903, 1 4.662000,-0.119200,-0.175200,-0.011960, 1 4.690000,-0.009867,-0.144900,-0.009771, 1 4.715000,-0.002113,-0.143500,-0.009689, 1 4.729000, 0.001392,-0.142800,-0.009644, 1 4.729000,-0.000598,-0.143000,-0.009647/ DATA A6(91),A7(91),A8(91),A9(91) 1 ,A6(92),A7(92),A8(92),A9(92) 1 /4.738000, 0.001075,-0.142500,-0.009618, 1 4.751000, 0.004244,-0.141900,-0.009576/ END SUBROUTINE SHROT ( NO, NP, T, TP ,NUM ) RAY24110 C**** RAY24120 C**** RAY24130 C**** SUBROUTINE DOES TRANSLATIONS FIRST ALONG AXES X, Y, Z IN ORDER, RAY24140 C**** FOLLOWED BY ROTATIONS ABOUT X, Y, Z . RAY24150 C**** RAY24160 IMPLICIT REAL*8(A-H,O-Z) RAY24170 c REAL*4 DAET, TYME !JDL 31-OCT-84 include 'rtcomm0.f' COMMON /BLCK 4/ ENERGY, VEL, PMASS, Q0 RAY24190 COMMON /BLCK 5/ XA, YA, ZA, VXA, VYA, VZA RAY24200 C*JDL DIMENSION DATA( 75,30 ), ITITLE(30) !JDL 17-NOV-83 RAY24210 C**** DATA C/ 3.D10/ RAY24220 NUM = NUM+1 TPAR = T*VEL NBR = 1 CALL PLT2 ( NUM, NO, NBR, TPAR ) X0 = DATA( 1,NO ) RAY24230 Y0 = DATA( 2,NO ) RAY24240 Z0 = DATA( 3,NO ) RAY24250 CX = DCOS( DATA(4,NO)/57.29578 ) RAY24260 SX = DSIN( DATA(4,NO)/57.29578 ) RAY24270 CY = DCOS( DATA(5,NO)/57.29578 ) RAY24280 SY = DSIN( DATA(5,NO)/57.29578 ) RAY24290 CZ = DCOS( DATA(6,NO)/57.29578 ) RAY24300 SZ = DSIN( DATA(6,NO)/57.29578 ) RAY24310 100 FORMAT( / '*** TRANSLATE-ROTATE **** ', A4,' **************'// RAY24320 1' T CM', 18X, 'X CM', 7X, 'Y CM', 7X, 'Z CM' , ' VELZ/C'RAY24330 2 , ' THETA MR PHI MR' / ) RAY24340 101 FORMAT( ' TRANSLATE ' ) RAY24350 102 FORMAT( ' ROTATE ' ) RAY24360 103 FORMAT( F10.4, 11X, 3F11.3, F12.5, 2F12.3 ) RAY24370 IF( NP .LE. 100) PRINT 100,ITITLE(NO) RAY24380 VXP = 1000. *DATAN2( VXA,VZA ) RAY24390 VYP = 1000. *DASIN ( VYA/VEL ) RAY24400 VZP = VZA / VEL RAY24410 IF( NP .LE. 100) PRINT 103, TP, XA, YA, ZA, VZP, VXP, VYP RAY24420 IF( (X0 .EQ. 0.) .AND. (Y0 .EQ. 0.) .AND. (Z0 .EQ. 0.) ) GO TO 1 RAY24430 IF( NP .LE. 100) PRINT 101 RAY24440 XA = XA-X0 RAY24450 YA = YA-Y0 RAY24460 ZA = ZA-Z0 RAY24470 IF( NP .LE. 100) PRINT 103, TP, XA, YA, ZA, VZP, VXP, VYP RAY24480 1 IF( DATA( 4,NO ) .EQ. 0. ) GO TO 2 RAY24490 IF( NP .LE. 100) PRINT 102 RAY24500 YR = YA*CX + ZA*SX RAY24510 ZR = -YA*SX + ZA*CX RAY24520 VYR= VYA*CX + VZA*SX RAY24530 VZR=-VYA*SX + VZA*CX RAY24540 YA = YR RAY24550 ZA = ZR RAY24560 VYA = VYR RAY24570 VZA = VZR RAY24580 VXP = 1000. *DATAN2( VXA,VZA ) RAY24590 VYP = 1000. *DASIN ( VYA/VEL ) RAY24600 VZP = VZA / VEL RAY24610 IF( NP .LE. 100) PRINT 103, TP, XA, YA, ZA, VZP, VXP, VYP RAY24620 2 IF( DATA( 5,NO ) .EQ. 0. ) GO TO 3 RAY24630 IF( NP .LE. 100) PRINT 102 RAY24640 XR = -ZA*SY + XA*CY RAY24650 ZR = ZA*CY + XA*SY RAY24660 VXR=-VZA*SY + VXA*CY RAY24670 VZR= VZA*CY + VXA*SY RAY24680 XA = XR RAY24690 ZA = ZR RAY24700 VXA = VXR RAY24710 VZA = VZR RAY24720 VXP = 1000. *DATAN2( VXA,VZA ) RAY24730 VYP = 1000. *DASIN ( VYA/VEL ) RAY24740 VZP = VZA / VEL RAY24750 IF( NP .LE. 100) PRINT 103, TP, XA, YA, ZA, VZP, VXP, VYP RAY24760 3 IF( DATA( 6,NO ) .EQ. 0. ) GOTO 4 !bsk RAY24770 IF( NP .LE. 100) PRINT 102 RAY24780 XR = XA*CZ + YA*SZ RAY24790 YR = -XA*SZ + YA*CZ RAY24800 VXR= VXA*CZ + VYA*SZ RAY24810 VYR=-VXA*SZ + VYA*CZ RAY24820 XA = XR RAY24830 YA = YR RAY24840 VXA = VXR RAY24850 VYA = VYR RAY24860 VXP = 1000. *DATAN2( VXA,VZA ) RAY24870 VYP = 1000. *DASIN ( VYA/VEL ) RAY24880 IF( NP .LE. 100) PRINT 103, TP, XA, YA, ZA, VZP, VXP, VYP RAY24890 4 NUM = NUM+1 TPAR = T*VEL NBR = 2 CALL PLT2 ( NUM, NO, NBR, TPAR ) RETURN RAY24900 END RAY24910 subroutine sigcap IMPLICIT REAL*8(A-H,O-Z) RAY00090 COMMON /BLCK 4/ ENERGY, VEL, PMASS, Q0 RAY00140 COMMON /BLCK60/ GAS,AGAS,ZGAS,ZION,PRESS,GASSIG,QAVER, !***MP 1-JAN-85 1 QFWHM,RHOGAS,GASK,EMASS,GASMFP,JRAY,Q00,NPASG !*** COMMON /BLCK61/ DEDX,ALPHAK,TOLD2,DEDXQ COMMON /BLCK62/ GASENE,GASVEL,TOLD,GASL include 'rtcomm65.f' COMMON /BLCK66/ tfwopt,taufct,alffct,TBAR,THWHM,tau0 common /blck70/ vel0,en0,pm0 common /blck71/ gasopt,zgas125,zgas18,dreldee,enold,icalc dimension dlsc(120),dq(120) data aa/4.8/,beta/0.037/,bb/2.2/,gama/2.44d-5/,cc/2.6/ data ipr/0/,ipr1/0/,ipr2/0/ data scoef/1.1d-8/ c c**** calculate electron capture cross sections using scaling law c see A.S. Schlachter et al. Phys. Rev. A 27(1983)3372 c epamu = 1000.*energy/pmass etil = epamu/zgas125 etilb = etil/(qbar**0.7) c c Check if etilb is in valid energy range >10 and <1000 if (etilb.ge.10..and.etilb.le.1000.) go to 10 c if (ipr.le.0) print 1001, etilb 1001 format(//' ********************WARNING**********************'/, * ' ***Etil out of range for cross section scaling***'/, 2 ' Etil(qbar) = ',1F10.3) ipr = 1 if (etilb.lt.1000.) go to 5 print 1002 1002 format(//' Energy too high-no cross section available '/) stop ' Energy too high-no cross section available' 5 if ( icalc.le.0) go to 7 if (ipr1.le.0.) print 1003, etilb,gasene 1003 format (//' *** cross sections kept constant below Etil = ', 2 F12.3,' energy = ',F10.3,' MeV',/) ipr1 = 1 return 7 if (ipr2.le.0) print 1004, etilb ipr2 = 1 1004 format (//' Energy Etil = ',F12.3, a ' too low - no cross section available '/ a , ' Etil = 10. kept constant'/) etilb = 10. etil = etilb * qbar**0.7 10 continue c bEb = beta*etilb**bb gEc = gama*etilb**cc bterm = 0. ibterm = 0 cterm = 0. icterm = 0 if (bEb.gt.10.) go to 20 ibterm = 1 bterm = bb*bEb/(dexp(bEb)-1.) 20 continue if (gEc.gt.10.) go to 30 icterm = 1 cterm = cc*gEc/(dexp(gEc)-1.) 30 continue dreldee = -aa + bterm + cterm c icalc = 1 c c find range of q-states : from int(qbar-4) to int(qbar+4) c and check for validity of range c qlo = qbar-4. qhi = qbar+4. if (qlo.lt.1.) qlo = 1. if (qhi.gt.zion-1.) qhi = zion - 1. iqlo = nint(qlo) iqhi = nint(qhi) nq = iqhi - iqlo + 1 if (nq.ge.3) go to 100 print 1000, iqlo,iqhi,qbar 1000 format(//' *** Q-range too small to fit cross sections :'/ 2 ' qlo,qhi= ',2(i3,','),' qbar = ',1f7.3//) if (nq.ge.2) go to 100 stop 666 100 do 200 iq = iqlo,iqhi q = dble(iq) etilq = etil/(q**0.7) expb = 0. expc = 0. if (ibterm.eq.1) expb = dexp(-beta*(etilq**bb)) if (icterm.eq.1) expc = dexp(-gama*(etilq**cc)) sctil = scoef*(etilq**(-aa)) 2 *(1.-expb) 3 *(1.-expc) scapq = sctil*dsqrt(q)/zgas18 dlsc(iq) = dlog(scapq) dq(iq) = q - qbar 200 continue c c Fit scap(q) to exponential function : c scap = gassig*exp(acapt*(q-qbar)) c and feed gassig and acapt to main program via blck 60 and 65 c sumx = 0. sumy = 0. sumx2 = 0. sumxy = 0. do 300 iq = iqlo,iqhi sumx = sumx + dq(iq) sumy = sumy + dlsc(iq) sumx2 = sumx2 + dq(iq)*dq(iq) sumxy = sumxy + dq(iq)*dlsc(iq) 300 continue del = nq*sumx2 - sumx*sumx dlsig = (sumx2*sumy - sumx*sumxy)/del acapt = (nq*sumxy - sumx*sumy)/del sig = dexp(dlsig) gassig = gas*sig*1.d16 return end subroutine smangsc IMPLICIT REAL*8(A-H,O-Z) RAY00090 COMMON /BLCK 4/ ENERGY, VEL, PMASS, Q0 RAY00140 include 'rtcomm65.f' COMMON /BLCK66/ tfwopt,taufct,alffct,TBAR,THWHM,tau0 data ipr/0/ c c**** c Calculates small-angle scattering according to c Meyer-Sigmund-Winterbon theory, NIM 119(1974)541. c Valid in range tau>0.01, tau<1000. c For tau<0.01, issues warning and sets thwhm = 0. c For tau>1000. issues fatal error and stops. c c tau = taufct/sigt c if (tau.gt.0.01) go to 10 if (ipr.gt.0) go to 5 print 1000, tau 1000 format (//10X,'****WARNING****'/ 3 10X,' tau(small angle) =',F12.5,/) ipr = 1 5 tau0 = tau0 + tau if (tau0.gt.0.01) go to 7 thwhm = 0. return 7 tau = tau0 tau0 = 0. go to 20 10 if (tau.lt.1000.) go to 20 print 2000,tau 2000 format (//10X,'****STOP CALCULATION****'/ 2 10X,' tau(small angle) =',F12.5,/ 3 10X,'**** TOO LARGE ****') stop 777 20 continue fn = (dlog(1.03+tau))**(-0.115) - 0.115 thwhm = alffct*(tau**fn)/energy c return end SUBROUTINE SOLND ( NO, NP, T, TP ,NUM ) RAY25230 C**** RAY25240 C**** RAY25250 C**** SOLENOID RAY TRACING BY NUMERICAL INTEGRATION OF DIFFERENTIALRAY25260 C**** EQUATIONS OF MOTION. RAY25270 C T = TIME RAY25280 C TC(1) TO TC(6) = ( X, Y, Z, VX, VY, VZ ) RAY25290 C DTC(1) TO DTC(6) = ( VX, VY, VZ, VXDOT, VYDOT, VZDOT ) RAY25300 C**** BF (POSITIVE) : SOLENOID FIELD IN BEAM DIRECTION RAY25310 C**** CBF - USED IN BSOL TO DISTINGUISH BETWEEN COORD. SYSTEMS RAY25320 C**** RAY25330 C**** RAY25340 IMPLICIT REAL*8(A-H,O-Z) RAY25350 c REAL*4 DAET, TYME !JDL 31-OCT-84 REAL*8 LF , K, L RAY25360 include 'rtcomm0.f' COMMON /BLCK 4/ ENERGY, VEL, PMASS, Q0 RAY25380 COMMON /BLCK 5/ XA, YA, ZA, VXA, VYA, VZA RAY25390 COMMON /BLCK 7/ NCODE RAY25400 COMMON /BLCK10/ BX, BY, BZ, K, TC, DTC RAY25410 COMMON /BLCK30/ BF , AL, RAD RAY25420 COMMON /BLCK31/ S, BT RAY25430 COMMON /BLCK32/ IN RAY25440 COMMON /BLCK60/ GAS,AGAS,ZGAS,ZION,PRESS,GASSIG,QAVER, !***MP 1-JAN-85 1 QFWHM,RHOGAS,GASK,EMASS,GASMFP,JRAY,Q00,NPASG !*** C*JDL DIMENSION DATA( 75,30 ), ITITLE(30) !JDL 17-NOV-83 RAY25450 DIMENSION TC(6), DTC(6), DS(6), ES(6) RAY25460 EXTERNAL BSOL RAY25470 C**** DATA C/ 3.D10/ RAY25480 C**** RAY25490 C**** RAY25500 JRAYGAS = JRAY*GAS LF = DATA( 1,NO ) RAY25510 A = DATA( 10,NO ) RAY25520 B = DATA( 11,NO ) RAY25530 L = DATA( 12,NO ) RAY25540 D = DATA( 13,NO ) RAY25550 BF = DATA( 14,NO ) RAY25560 Z11 = DATA( 15,NO ) RAY25570 Z22 = DATA( 16,NO ) RAY25580 DTF1= LF/VEL RAY25590 AL = L/2. RAY25600 RAD = D/2. RAY25610 BX = 0. RAY25620 BY = 0. RAY25630 BZ = 0. RAY25640 BT = 0. RAY25650 S = 0. RAY25660 C**** RAY25670 C**** RAY25680 IF( NP .GT. 100 ) GO TO 5 RAY25690 201 FORMAT( ' SOLENOID **** ', A4, ' ***********************'/) RAY25700 PRINT 201, ITITLE(NO) RAY25710 101 FORMAT( 8H T CM ,18X, 4HX CM , 7X, 2HBX, 8X, 4HY CM , 7X, 2HBY,RAY25720 1 8X, 4HZ CM, 7X, 2HBZ, 8X, 6HVELZ/C , 6X, 8HTHETA MR , 5X, RAY25730 2 6HPHI MR , 6X, 1HB ) RAY25740 CALL PRNT2 ( T,S,XA ,YA ,ZA ,BX,BY,BZ,BT,VXA ,VYA ,VZA )RAY25750 IF (JRAYGAS.NE.0) CALL PRNT2A PRINT 101 RAY25760 PRINT 103 RAY25770 103 FORMAT( '0COORDINATE TRANSFORMATION TO CENTERED AXIS SYSTEM ' ) RAY25780 109 FORMAT( '0COORDINATE TRANSFORMATION TO D AXIS SYSTEM ' ) RAY25790 C**** TRANSFORM FROM INITIAL ENTRANCE COORDINATES TO VFB COORD. RAY25800 C**** RAY25810 5 TC(1) = XA RAY25820 TC(2) = YA RAY25830 TC(3) = ZA-A-AL RAY25840 TC(4) = VXA RAY25850 TC(5) = VYA RAY25860 TC(6) = VZA RAY25870 CALL PRNT2 ( T,S,TC(1),TC(2),TC(3),BX,BY,BZ,BT,TC(4),TC(5),TC(6) )RAY25880 IF (JRAYGAS.NE.0) CALL PRNT2A NUM = NUM+1 TPAR = T*VEL NBR = 2 CALL PLT1 ( NUM, NO, NBR, TPAR ) C**** RAY25890 C**** TRANSLATE PARTICLE TO START OF FIRST FRINGE FIELD RAY25900 C**** RAY25910 TDT = (-TC(3) -Z11 -AL ) /DABS( TC(6) ) RAY25920 C**** RAY25930 TC(1) = TC(1) + TDT * TC(4) RAY25940 TC(2) = TC(2) + TDT * TC(5) RAY25950 TC(3) = TC(3) + TDT * TC(6) RAY25960 T = T + TDT RAY25970 NUM = NUM+1 TPAR = T*VEL NBR = 2 CALL PLT1 ( NUM, NO, NBR, TPAR ) IF( NP .LE. 100) PRINT 104 RAY25980 104 FORMAT( 22H0FRINGING FIELD REGION ) RAY25990 CALL FNMIRK( 6, T, DTF1,TC, DTC, DS, ES, BSOL , 0 ) RAY26000 NSTEP = 0 RAY26010 6 CALL PRNT2 ( T,S,TC(1),TC(2),TC(3),BX,BY,BZ,BT,TC(4),TC(5),TC(6) )RAY26020 IF (JRAYGAS.NE.0) CALL PRNT2A DO 7 I = 1, NP RAY26030 CALL FNMIRK( 6, T, DTF1,TC, DTC, DS, ES, BSOL , 1 ) RAY26040 NSTEP = NSTEP + 1 RAY26050 NUM = NUM+1 TPAR = T*VEL NBR = 2 CALL PLT1 ( NUM, NO, NBR, TPAR ) IF (NSTEP .GT. 10000) GO TO 99 RAY26051 IF( (Z22+AL) .LE. TC(3) ) GO TO 8 RAY26060 7 CONTINUE RAY26070 GO TO 6 RAY26080 8 CONTINUE RAY26090 XDTF1 =-( TC(3) -(Z22+AL) ) / DABS( TC(6) ) RAY26100 CALL FNMIRK( 6, T,XDTF1,TC, DTC, DS, ES,BSOL , 0 ) RAY26110 CALL FNMIRK( 6, T,XDTF1,TC, DTC, DS, ES,BSOL , 1 ) RAY26120 CALL PRNT2 ( T,S,TC(1),TC(2),TC(3),BX,BY,BZ,BT,TC(4),TC(5),TC(6) )RAY26130 IF (JRAYGAS.NE.0) CALL PRNT2A NUM = NUM+1 TPAR = T*VEL NBR = 2 CALL PLT1 ( NUM, NO, NBR, TPAR ) IF( NP .LE. 100) PRINT 105, NSTEP RAY26140 105 FORMAT( 10H NSTEPS= I5 ) RAY26150 C**** RAY26160 C**** TRANSFORM TO OUTPUT SYSTEM COORD. RAY26170 C**** RAY26180 TC(3) = TC(3) - B - AL RAY26190 IF( NP .LE. 100) PRINT 109 RAY26200 CALL PRNT2 ( T,S,TC(1),TC(2),TC(3),BX,BY,BZ,BT,TC(4),TC(5),TC(6) )RAY26210 IF (JRAYGAS.NE.0) CALL PRNT2A C**** RAY26220 C**** TRANSLATE PARTICLE TO OUT SYSTEM COORD. RAY26230 C**** RAY26240 TDT = -TC(3) /DABS( TC(6) ) RAY26250 TC(1) = TC(1) + TDT * TC(4) RAY26260 TC(2) = TC(2) + TDT * TC(5) RAY26270 TC(3) = TC(3) + TDT * TC(6) RAY26280 T = T + TDT RAY26290 TP = T * VEL RAY26300 BX = 0. RAY26310 BY = 0. RAY26320 BZ = 0. RAY26330 BT = 0. RAY26340 S = 0. RAY26350 VXF = 1000. *DATAN2( TC(4), TC(6) ) RAY26360 VYF = 1000. *DASIN ( TC(5)/ VEL ) RAY26370 VZF = TC(6) / VEL RAY26380 IF( NP .LE. 100) PRINT 115,TP,TC(1),TC(2),TC(3),VZF,VXF,VYF RAY26390 115 FORMAT( F10.4, 10X, F10.3, 11X, F10.3, 11X, F10.3, 11X, RAY26400 1 F13.5, F13.2, F11.2 ) RAY26410 NUM = NUM+1 TPAR = T*VEL NBR = 3 CALL PLT1 ( NUM, NO, NBR, TPAR ) C**** RAY26420 C**** CALCULATE INTERCEPTS IN SYSTEM D RAY26430 C**** RAY26440 Z0X = -TC(1)/ ( TC(4) / TC(6) + 1.E-10 ) RAY26450 Z0Y = -TC(2)/ ( TC(5) / TC(6) + 1.E-10 ) RAY26460 IF( NP .LE. 100) PRINT 111, VXF, VYF, Z0X, Z0Y RAY26470 111 FORMAT( / ' INTERSECTIONS WITH VER. AND HOR. PLANES ' , RAY26480 X /15X, 5H XP=F10.4, 10H MR YP= F10.4, 3H MR / RAY26490 1 15X, 5H Z0X=F10.2, 10H CM Z0Y= F10.2, 3H CM / )RAY26500 RETURN RAY26510 99 CALL PRNT4(NO, IN ) RAY26511 RETURN RAY26512 END RAY26520 SUBROUTINE SQDIST c c charge distribution in solid target c c Author: B. Schneck (ANL, 87-09-11) c c Version A: Betz Formula c Form: H. D. Betz, Heavy Ion Charge States c in: Applied Atomic Collision Physics, Vol. 4 (Acad. Press, 1983) c c Version B: Sawyer Formula (87-09-15) c From: R. O. Sayer, Semi-Empirical Formulas for Heavy-Ion Stripping Data, c Revue de Physique Appliquee 12(1977) 1543 c c This routine calculates the charge state distribution of heavy ions c in a solid target. The optimal solution would be to have a new c type of beam-line element 'STAR' with the associated parameter input c which also introduces energy straggling and scattering. c Also only average distributions are calculated. This is not an c accurete description for thin foils. c But for the moment this quick solution will be enough. c c (Version A) c This routine is quite similar to the QDIST routine for charge distribution c in gas except for different parameter settings. c c (Version B) c The Sayer formula is more acureat than the Bets and also introduces c a certain assymmetry in the charge distribution. c c Global variables: c VEL Velocity of ion c ZION Nucleus charge of ion c QBAR Average charge state c DELSQR half width of charge state distribution c IMPLICIT REAL*8(A-H,O-Z) COMMON /BLCK 4/ ENERGY, VEL, PMASS, Q0 RAY00140 COMMON /BLCK60/ GAS,AGAS,ZGAS,ZION,PRESS,GASSIG,QAVER, !***MP 1-JAN-85 1 QFWHM,RHOGAS,GASK,EMASS,GASMFP,JRAY,Q00,NPASG !*** include 'rtcomm65.f' c c***** Betz ***** c DATA V0/2.189D8/, PI/3.14159/ c DATA C11/0.936/, C12/1.686/, A1/0.864/, DEL1/0.851/, GAM1/0.437/ c DATA C2 /1.041/, A2/0.851/, DEL2/0.847/, GAM2/0.432/ c c data da/1.41/, dk/0.11/, da/0.3/, db/0.37/ c c VBV0 = VEL/V0 c if (zion.gt.15) goto 100 c TMP = -A1*(VBV0**DEL1)/(ZION**GAM1) c QBAR = ZION*(1.-(c11+c12/zion)*DEXP(TMP)) c goto 200 c 100 tmp = -a2*(vbv0**del2)/(zion**gam2) c qbar = zion*(1.-c2*dexp(tmp)) c 200 tmp = da * (zion**dk) * (qbar**da) * ((1- qbar/zion)**db) c delsqr= tmp*tmp c c***** Sayer ***** c common /sqdiscm/ sqdminq, sqdp(21) DIMENSION Q(21),P(21) data c/2.998D10/ c5 CALL INKBI(' Z(INTEGER)'' ',IZ) c CALL INKBI(' MASS(INTEGER)'' ',IM) c10 CALL INKBF(' ENERGY IN MEV(FLOATING(<0 FOR NEW Z/M)'' ',E) c IF(E.LT.0) GO TO 5 C CALCULATE VELOCITY c BETA=SQRT(2*E/(FLOAT(IM)*931.478)) c Z=FLOAT(IZ) C TYPE 903,Z 903 FORMAT(F) C CALCULATE MAXIMUM CHARGE STATE beta=vel/c z=zion Qbar=Z*(1-1.03*EXP(-47.3*(Z**(-0.38))*(BETA**0.86))) QOZ=Qbar/Z RHO=0.48*(Z**0.45)*(QOZ*(1-QOZ))**0.26 EOR=0.0007*Z-0.7*BETA C ROUND Qbar IZM=INT(Qbar) C CALCULATE IZM+- 10 CHARGE UNITS I=IZM-10 IF(I.LT.1.) I=1 sqdminq=float(i) M=1 sum=0 100 ARG=(I-Qbar)**2/(2*RHO*RHO*(1+EOR*(I-Qbar))) sqdP(M)=EXP(-ARG) sum=sum+sqdp(m) M=M+1 I=I+1 IF(M.GT.21) GO TO 150 c IF(float(I).LT.z) GO TO 100 ! commented out 90-04-07 if(float(i).le.z) go to 100 ! corrected 90-04-07 to allow q=z C NORMALIZE TO INTEGRAL OVER Q=1 150 continue sqdp(1)=sqdp(1)/sum DO 300 K=2,21 sqdP(K)=sqdp(k-1)+sqdP(k)/sum c TYPE 900,sqsminq+k-1.,sqdP(K) 300 CONTINUE c900 FORMAT(' Q=',F8.4,' P=',F8.4,' ') c TYPE 901,Qbar,RHO,EOR c901 FORMAT(' MOST PROBABLE=',F8.3,' RHO=',F8.3,' EOR=',F8.3,' ') c GO TO 10 c END c delsqr=rho*rho RETURN END SUBROUTINE SQSAMP c c sample a charge state in solid target c c Author: B. Schneck (ANL, 87-09-15) c c This routine is called by RTMAIN to sample an initial charge state c for a ray. The parameters are set up according to the Sayer formula c before by a call to SQDIST. c c Global variables: c iseed random generator c sqdp(*) probabilities for charge state c sqdminq charge state corresponding to sqdp(1) c zion highest returned charge state c q0 returned charge state c IMPLICIT REAL*8(A-H,O-Z) c COMMON /BLCK 4/ ENERGY, VEL, PMASS, Q0 COMMON /BLCK60/ GAS,AGAS,ZGAS,ZION,PRESS,GASSIG,QAVER, 1 QFWHM,RHOGAS,GASK,EMASS,GASMFP,JRAY,Q00,NPASG common /BLCK63/ iseed c common /sqdiscm/ sqdminq, sqdp(21) r=ran(iseed) q0=sqdminq i=1 10 if (r.lt.sqdp(i).or.(i.ge.21).or.(q0.ge.zion)) return i=i+1 if (i.gt.21) return q0=q0+1. goto 10 END FUNCTION STOP(Z1,AA1,Z2,E) RAYANL07 C C CALCULATES: C - NUCLEAR STOPPING POWERS C - ELECTRONIC STOPPING POWERS FOR HE IN C ALL ELEMENTAL SOLID AND GASEOUS MATTER C - EFFECTIVE CHARGES TO CONVERT HE C STOPPING POWERS TO ALL OTHERS C (SEE J. F. ZIEGLER) C C INPUT: C - Z1, AA1 = Z AND A OF PROJECTILE C - Z2, AA2 = Z AND A OF STOPPING MATERIAL C - E = LABORATORY ENERGY OF PROJECTILE IN MEV C - IM = SOLID STOPPING MATTER: SET IM=1, C GASEOUS STOPPING MATTER: SET IM=0 C C OUTPUT: C - STOP: STOPPING POWERS IN MEV/MG/CM**2 C - COMMON RANGEC: VOVC = VELOCITY/C C V1OVC = MAXIMUM VELOCITY FOR LINDHARDT-SCHARFF-APPROXIMATION C EPS = REDUCED VELOCITY C DEDXE = ELECTRONIC PART OF STOPPING POWER C DEDXN = NUCLEAR PART OF STOPPING POWER C C****************************************************** C DIMENSION SC(92),AH1(92),AH2(92),AH3(92),AH4(92), 1 AH5(92),AH6(92),AH7(92) DIMENSION A1(92),A2(92),A3(92),A4(92),A5(92),A6(92),A7(92), 1 A8(92),A9(92) DIMENSION B1(92),B2(92),B3(92),B4(92),B5(92),B6(92),B7(92), 1 B8(92),B9(92) COMMON /RANGEC/VOVC,V1OVC,EPS,DEDXE,DEDXN COMMON /DATAD/ AH1,AH2,AH3,AH4,AH5,AH6,AH7, 1 A1,A2,A3,A4,A5,A6,A7,A8,A9, 1 B1,B2,B3,B4,B5,B6,B7,B8,B9 COMMON /SHELLC/ SC DATA ZERO/1.E-30/ C IM=0. RAYANL09 AA2=2.*Z2 RAYANL10 C IF(Z1.LE.0..OR.AA1.LE.0..OR.Z2.LE.0..OR.AA2.LE.0..OR.E.LT.ZERO) 1 GOTO 400 IZ1=IRND(Z1) K=IRND(Z2) IF(K.GT.92) K=92 EX=2./3. VSQ=E/AA1 VOVC=0.04634*SQRT(VSQ) IF(VOVC.GT.1.) VOVC=0.999999 V1OVC=0.0073*Z1**EX FAC=0.60225/AA2 C FAC CONVERTS UNITS FROM EV/10**15ATOMS/CM**2 TO MEV/MG/CM**2 C C NUCLEAR STOPPING POWERS C A=AA1+AA2 Z=SQRT(Z1**EX+Z2**EX) EPS=E*32530.*AA2/Z/Z1/Z2/A RAYANL11 IF(EPS.LT.0.01) GOTO 100 IF(EPS.GT.10) GOTO 110 EU=EXP(1.) DEDXN=1.7*SQRT(EPS)*ALOG(EPS+EU)/(1.+6.8*EPS+3.4*EPS**1.5) GOTO 120 100 DEDXN=1.593*SQRT(EPS) GOTO 120 110 DEDXN=0.5*ALOG(0.47*EPS)/EPS 120 DEDXN=8.462*Z1*Z2*AA1/A/Z*FAC*DEDXN C C MASTER ELECTRONIC STOPPING POWERS FOR HYDROGEN C IF(IZ1.EQ.2) GOTO 300 EH=1000.*VSQ IF(EH.GE.1000.) GOTO 200 IF(EH.LE.10.) GOTO 210 DEDXE=FAC/(1./AH2(K)/EH**0.45+ 1 EH/AH3(K)/ALOG(1.+AH4(K)/EH+AH5(K)*EH)) GOTO 220 200 BSQ=VOVC*VOVC DEDXE=FAC*AH6(K)/BSQ*ALOG(AH7(K)*BSQ/(1.-BSQ))+SC(K)/EH GOTO 220 210 DEDXE=FAC*AH1(K)*SQRT(EH) 220 STOP=DEDXE+DEDXN IF(IZ1.EQ.1) RETURN IF(IZ1.EQ.3) GOTO 230 C C ZIEGLERS EFFECTIVE Z'S AND ELECTRONIC STOPPING C POWERS FOR PROJECTILES WITH Z>3 C B=0.1772*SQRT(EH)/Z1**EX G=Z1*(1.-(1.034-0.1777/EXP(0.08114*Z1)) 1 /EXP(B+0.0378*SIN(1.5708*B))) IF(G.LT.1.) G=1. DEDXE=DEDXE*G*G STOP=DEDXE+DEDXN RETURN C C EFFECTIVE Z AND ELECTRONIC STOPPING POWER FOR LITHIUM C 230 G=3. HEXP=0.7138+0.002797*EH+1.348E-6*EH*EH IF(HEXP.LT.60.) G=G-3./EXP(HEXP) DEDXE=G*G*DEDXE STOP=DEDXE+DEDXN RETURN C C MASTER ELECTRONIC STOPPING POWERS FOR HELIUM C 300 EHE=4.*VSQ C SOLID AND GASEOUS MATTER, HIGH ENERGIES IF(EHE.LT.10.) GOTO 310 E1=ALOG(1./EHE) DEDXE=FAC*EXP(A6(K)+(A7(K)+(A8(K)+A9(K)*E1)*E1)*E1) STOP=DEDXE+DEDXN RETURN 310 IF(IM.LT.1) GOTO 320 C SOLID MATTER, LOW ENERGIES E1=(1000.*EHE)**A2(K) DEDXE=FAC/(1./E1/A1(K)+EHE/A3(K)/ALOG(1.+A4(K)/EHE+A5(K)*EHE)) STOP=DEDXE+DEDXN RETURN C GASEOUS MATTER, LOW ENERGIES 320 E1=(1000.*EHE)**B2(K) DEDXE=FAC/(1./E1/B1(K)+EHE/B3(K)/ALOG(1.+B4(K)/EHE+B5(K)*EHE)) STOP=DEDXE+DEDXN RETURN C 400 DEDXE=ZERO DEDXN=ZERO STOP=ZERO RETURN END C C****************************************** C FUNCTION STOPS(Z1,AA1,Z2,AA2,E) !MP 29-jul-93 C C CALCULATES: C - NUCLEAR STOPPING POWERS C - ELECTRONIC STOPPING POWERS FOR HE IN C ALL ELEMENTAL SOLID AND GASEOUS MATTER C - EFFECTIVE CHARGES TO CONVERT HE C STOPPING POWERS TO ALL OTHERS C (SEE J. F. ZIEGLER) C C INPUT: C - Z1, AA1 = Z AND A OF PROJECTILE C - Z2, AA2 = Z AND A OF STOPPING MATERIAL C - E = LABORATORY ENERGY OF PROJECTILE IN MEV C - IM = SOLID STOPPING MATTER: SET IM=1, C GASEOUS STOPPING MATTER: SET IM=0 C C OUTPUT: C - STOPS: STOPPING POWERS IN MEV/MG/CM**2 C - COMMON RANGEC: VOVC = VELOCITY/C C V1OVC = MAXIMUM VELOCITY FOR LINDHARDT-SCHARFF-APPROXIMATION C EPS = REDUCED VELOCITY C DEDXE = ELECTRONIC PART OF STOPPING POWER C DEDXN = NUCLEAR PART OF STOPPING POWER C C****************************************************** C DIMENSION SC(92),AH1(92),AH2(92),AH3(92),AH4(92), 1 AH5(92),AH6(92),AH7(92) DIMENSION A1(92),A2(92),A3(92),A4(92),A5(92),A6(92),A7(92), 1 A8(92),A9(92) DIMENSION B1(92),B2(92),B3(92),B4(92),B5(92),B6(92),B7(92), 1 B8(92),B9(92) COMMON /RANGEC/VOVC,V1OVC,EPS,DEDXE,DEDXN COMMON /DATAD/ AH1,AH2,AH3,AH4,AH5,AH6,AH7, 1 A1,A2,A3,A4,A5,A6,A7,A8,A9, 1 B1,B2,B3,B4,B5,B6,B7,B8,B9 COMMON /SHELLC/ SC DATA ZERO/1.E-30/ C IM=1. !MP 27-jul-93 C AA2=2.*Z2 !MP 29-jul-93 C IF(Z1.LE.0..OR.AA1.LE.0..OR.Z2.LE.0..OR.AA2.LE.0..OR.E.LT.ZERO) 1 GOTO 400 IZ1=IRND(Z1) K=IRND(Z2) IF(K.GT.92) K=92 EX=2./3. VSQ=E/AA1 VOVC=0.04634*SQRT(VSQ) IF(VOVC.GT.1.) VOVC=0.999999 V1OVC=0.0073*Z1**EX FAC=0.60225/AA2 C FAC CONVERTS UNITS FROM EV/10**15ATOMS/CM**2 TO MEV/MG/CM**2 C C NUCLEAR STOPPING POWERS C A=AA1+AA2 Z=SQRT(Z1**EX+Z2**EX) EPS=E*32530.*AA2/Z/Z1/Z2/A RAYANL11 IF(EPS.LT.0.01) GOTO 100 IF(EPS.GT.10) GOTO 110 EU=EXP(1.) DEDXN=1.7*SQRT(EPS)*ALOG(EPS+EU)/(1.+6.8*EPS+3.4*EPS**1.5) GOTO 120 100 DEDXN=1.593*SQRT(EPS) GOTO 120 110 DEDXN=0.5*ALOG(0.47*EPS)/EPS 120 DEDXN=8.462*Z1*Z2*AA1/A/Z*FAC*DEDXN C C MASTER ELECTRONIC STOPPING POWERS FOR HYDROGEN C IF(IZ1.EQ.2) GOTO 300 EH=1000.*VSQ IF(EH.GE.1000.) GOTO 200 IF(EH.LE.10.) GOTO 210 DEDXE=FAC/(1./AH2(K)/EH**0.45+ 1 EH/AH3(K)/ALOG(1.+AH4(K)/EH+AH5(K)*EH)) GOTO 220 200 BSQ=VOVC*VOVC DEDXE=FAC*AH6(K)/BSQ*ALOG(AH7(K)*BSQ/(1.-BSQ))+SC(K)/EH GOTO 220 210 DEDXE=FAC*AH1(K)*SQRT(EH) 220 STOPS=DEDXE+DEDXN IF(IZ1.EQ.1) RETURN IF(IZ1.EQ.3) GOTO 230 C C ZIEGLERS EFFECTIVE Z'S AND ELECTRONIC STOPPING C POWERS FOR PROJECTILES WITH Z>3 C B=0.1772*SQRT(EH)/Z1**EX G=Z1*(1.-(1.034-0.1777/EXP(0.08114*Z1)) 1 /EXP(B+0.0378*SIN(1.5708*B))) IF(G.LT.1.) G=1. DEDXE=DEDXE*G*G STOPS=DEDXE+DEDXN RETURN C C EFFECTIVE Z AND ELECTRONIC STOPPING POWER FOR LITHIUM C 230 G=3. HEXP=0.7138+0.002797*EH+1.348E-6*EH*EH IF(HEXP.LT.60.) G=G-3./EXP(HEXP) DEDXE=G*G*DEDXE STOPS=DEDXE+DEDXN RETURN C C MASTER ELECTRONIC STOPPING POWERS FOR HELIUM C 300 EHE=4.*VSQ C SOLID AND GASEOUS MATTER, HIGH ENERGIES IF(EHE.LT.10.) GOTO 310 E1=ALOG(1./EHE) DEDXE=FAC*EXP(A6(K)+(A7(K)+(A8(K)+A9(K)*E1)*E1)*E1) STOPS=DEDXE+DEDXN RETURN 310 IF(IM.LT.1) GOTO 320 C SOLID MATTER, LOW ENERGIES E1=(1000.*EHE)**A2(K) DEDXE=FAC/(1./E1/A1(K)+EHE/A3(K)/ALOG(1.+A4(K)/EHE+A5(K)*EHE)) STOPS=DEDXE+DEDXN RETURN C GASEOUS MATTER, LOW ENERGIES 320 E1=(1000.*EHE)**B2(K) DEDXE=FAC/(1./E1/B1(K)+EHE/B3(K)/ALOG(1.+B4(K)/EHE+B5(K)*EHE)) STOPS=DEDXE+DEDXN RETURN C 400 DEDXE=ZERO DEDXN=ZERO STOPS=ZERO RETURN END C C****************************************** C SUBROUTINE VELS ( NO,NP,T,TP ,NUM ) RAY17720 C**** RAY17730 C**** RAY17740 C VELOCITY SELECTOR......ADDED JAN. 1976 BY W. R. BERNECKY RAY17750 C**** RAY17760 C**** RAY17770 IMPLICIT REAL*8 (A-H,O-Z) RAY17780 c REAL*4 DAET, TYME !JDL 31-OCT-84 REAL*8 K,LF1,LU1,LF2,L RAY17790 EXTERNAL BEVC RAY17800 include 'rtcomm0.f' COMMON /BLCK 4/ ENERGY, VEL, PMASS, Q0 RAY17820 COMMON /BLCK 5/ XA,YA,ZA,VXA,VYA,VZA RAY17830 COMMON /BLCK10/ BX, BY, BZ, K, TC, DTC RAY17840 COMMON /BLCK11/ EX, EY, EZ, QMC, IVEC RAY17850 COMMON /BLCK71/ CB0,CB1,CB2,CB3,CB4,CB5 RAY17860 COMMON /BLCK72/ CE0,CE1,CE2,CE3,CE4,CE5 RAY17870 COMMON /BLCK73/ IN RAY17880 COMMON /BLCK74/ BF,EF,S,DG RAY17890 COMMON /BLCK75/ BC2,BC4,EC2,EC4 RAY17900 COMMON /BLCK76/ DB,DE,WB,WE RAY17910 C**** RAY17920 C*JDL DIMENSION DATA(75,30) , ITITLE(30) !JDL 17-NOV-83 RAY17930 DIMENSION TC(6),DTC(6),DS(6),ES(6) RAY17940 C**** DATA C/3.D10/ RAY17950 C**** RAY17960 LF1=DATA( 1,NO) RAY17970 LU1=DATA( 2,NO) RAY17980 LF2=DATA( 3,NO) RAY17990 DG =DATA( 4,NO) RAY18000 A =DATA(11,NO) RAY18010 B =DATA(12,NO) RAY18020 L =DATA(13,NO) RAY18030 BF =DATA(14,NO) RAY18040 EF =DATA(15,NO) RAY18050 DB =DATA(16,NO) RAY18060 DE =DATA(17,NO) RAY18070 WB =DATA(18,NO) RAY18080 WE =DATA(19,NO) RAY18090 Z11=DATA(20,NO) RAY18100 Z12=DATA(21,NO) RAY18110 Z21=DATA(22,NO) RAY18120 Z22=DATA(23,NO) RAY18130 BC2=DATA(24,NO) RAY18140 BC4=DATA(25,NO) RAY18150 EC2=DATA(26,NO) RAY18160 EC4=DATA(27,NO) RAY18170 EX = 0. RAY18180 EY = 0. RAY18190 EZ = 0. RAY18200 S = 0. RAY18210 BX = 0. RAY18220 BY = 0. RAY18230 BZ = 0. RAY18240 IF ( NP .GT. 100 ) GO TO 5 RAY18250 PRINT 100, ITITLE(NO) RAY18260 100 FORMAT ('0VELOCITY SELECTOR**** ',A4,' ******************'/ ) RAY18270 PRINT 101 RAY18280 101 FORMAT (8H T CM,6X,4HX CM,5X,2HBX,8X,2HEX,8X,4HY CM,5X,2HBY,8X,RAY18290 1 2HEY,7X,4HZ CM,6X,2HBZ,8X,2HEZ,6X,8HTHETA MR,5X,6HPHI MR, RAY18300 2 2X, 'VEL/E9' ) RAY18310 TDIST = T*VEL RAY18320 CALL PRNT3( TDIST,XA,YA,ZA,BX,BY,BZ,EX,EY,EZ,VXA,VYA,VZA ) RAY18330 PRINT 103 RAY18340 103 FORMAT ( '0COORDINATE TRANSFORMATION TO B AXIS SYSTEM' ) RAY18350 109 FORMAT ( '0COORDINATE TRANSFORMATION TO D AXIS SYSTEM' ) RAY18360 C**** RAY18370 C**** TRANSFORM FROM INITIAL ENTRANCE COORDINATES RAY18380 C**** RAY18390 5 TC(1) = -XA RAY18400 TC(2) = YA RAY18410 TC(3) = A-ZA RAY18420 TC(4) = -VXA RAY18430 TC(5) = VYA RAY18440 TC(6) = -VZA RAY18450 CALL PRNT3 (TDIST,TC(1),TC(2),TC(3),BX,BY,BZ, RAY18460 1 EX,EY,EZ,TC(4),TC(5),TC(6) ) RAY18470 NUM = NUM+1 TPAR = T*VEL NBR = 2 CALL PLT1 ( NUM, NO, NBR, TPAR ) C**** RAY18480 C**** TRANSLATE PARTICLE TO START OF FRINGE FIELD RAY18490 C**** RAY18500 TDT = ( TC(3)-Z11 )/DABS( TC(6) ) RAY18510 TC(1) = TC(1)+TDT*TC(4) RAY18520 TC(2) = TC(2)+TDT*TC(5) RAY18530 TC(3) = TC(3)+TDT*TC(6) RAY18540 T = T+TDT RAY18550 NUM = NUM+1 TPAR = T*VEL NBR = 2 CALL PLT1 ( NUM, NO, NBR, TPAR ) C****