SUBROUTINE TRACKT C ********************** IMPLICIT REAL*8 (A-H,O-Z) PARAMETER (MXPART= 16384) PARAMETER (MXELMD = 8192) PARAMETER (MAXPOS = 8192) PARAMETER (MAXMAT = 250) COMMON AMAT(27,6,MAXMAT),NORLST(MAXPOS),EXPEL2,N,LOGPAR(MXPART) LOGICAL LOGPAR COMMON /SYMMAP/ BSYMAT(6,6,MAXMAT),CSYMAT(6,27,MAXMAT) COMMON/INOUT/IIN,IOUT,ISOUT,ISO,NOUT,NSLC COMMON/DETL/DENER(15),NH,NV,NVH,NHVP(105),MDPRT,NDENER, 1NUXS(45),NUX(45),NUYS(45),NUY(45),NCO,NHNVHV,MULPRT,NSIG PARAMETER (MAXDAT = 4000) COMMON /INPUTT/ KODE(MXELMD),IADR(MXELMD),ELDAT(MAXDAT) +,MADR(MXELMD),KCOUNT,NA,KUNITS COMMON/CHINP/NAME(8,MXELMD),LABEL(14,MXELMD) CHARACTER*1 NAME,LABEL COMMON/TRACE/PART(MXPART,6),DEL(MXPART),NPART,NCPART,NPRINT, < NCTURN,MLOCAT,NTURN COMMON/V/AL,ALO2,VV(27),X1,X2,X3,X4,X5,X6,Y1,Y2,Y3,Y4,Y5,Y6 COMMON/PLT/ 1XMIN,XMAX,YMIN,YMAX,XPMIN,XPMAX,YPMIN,YPMAX,ALMIN,ALMAX, >DELMIN,DELMAX,DNUMIN,DNUMAX,DBMIN,DBMAX, 2MALL,NPLOT,NCCUM,NGRAPH,NCOL,NLINE COMMON/CHPLT/MXXPR,MYYPR,MXY,MALE COMMON/CONST/PI,TWOPI,CRDEG,CMAGEN,CLIGHT,EMASS,ERAD,ECHG >,TOLLSQ,ETAFAC,SIGFAC,MAXFAC,IPTYP COMMON/TRI/WCO(15,6),GEN(5,4),PGEN(75,6),DIST, DZ1,DZ2,DZC1,DZS1,DZC2,DZS2,DDEL,I,IEP,MNEL PARAMETER (MXLIST = 40) COMMON/MAT/TEMP(6,27),NORDER,MPRINT,IMAT,NMAT,IFITE(2),NELM,NOP, NMISE,MISSEL(MXMIS),NMRNGE(MXMIS), >MSRNGE(2,10,MXMIS),MISFLG,MCHFLG PARAMETER (MXMTR = 5000) COMMON/MISTRK/AKMIS(15,MXMTR),KMPOS(MXMTR),IMEXP,NMTOT,MISPTR COMMON/CSEEDS/ISEED,IXG,IXS,IXMSTP,IMSD,IMOSTP,ISYNSD,ISYSTP, >ISDBEG,IBGSTP,IXES,IXESTP,IESBEG,IESTBG COMMON/ERR/ERRVAL(7,50),NERELE(50),NERPAR(7,50),NERR,NEROPT, > NERRE,MERSEL(50),NERNGE(50),MERNGE(2,10,50),MERFLG PARAMETER (MAXERR = 100) COMMON /ERRSRT/ ERRSRT(MAXERR),NERSRT,IERSRT,IERBEG COMMON/ERSAV/SAV(7),SAVMAT(6,27),IERSET,IER,IDE,IEMSAV PARAMETER (MXLCND = 100) PARAMETER (MXLVAR = 50) COMMON/FITL/COEF(MXLVAR,6),VALF(MXLCND), > WGHT(MXLCND),RVAL(MXLCND),XM(MXLVAR) > ,EM(MXLVAR),WV,NELF(MXLVAR,6),NPAR(MXLVAR,6), > IND(MXLVAR,6),NPVAR(MXLVAR),NVAL(MXLCND) > ,NSTEP,NVAR,NCOND,ISTART,NDIV,IFITM,IFITD,IFITBM, > IFITTR COMMON/MONIT/VALMON(MXLCND,4,3) COMMON/MONFIT/VALFA(MXLCND),WGHTA(MXLCND),ERRA(MXLCND), >AMULTA(MXLVAR,6),ADDA(MXLVAR,6),DELA(MXLVAR) >,NPARA(MXLVAR,6),NELFA(MXLVAR,6), >NPVARA(MXLVAR),INDA(MXLVAR,6),VALR(MXLCND),RMOSIG, >NMONA(MXLCND),NVALA(MXLCND),NVARA,NCONDA >,IALFLG,MONFLG,MONLST,NOPTER, >IAFRST,IMOOPT,IMSBEG,NALPRT PARAMETER (MAXCOR = 600) COMMON/CORR/CORVAL(MAXCOR,4),ICRID(MAXCOR), >ICRPOS(MAXCOR),ICRSET(MAXCOR), >ICROPT(MAXCOR),NCORR,NCURCR,ICRFLG,ICRCHK,ALMNEL,ICRPTR,NPARC COMMON/ORBIT/SIZEX,SIZEY,RMSX,RMSY,RMSIX,RMSIY, >RTEMPX,RTEMPY,RMSPX(5),RMSPY(5),RPX,RPY, >RMAXX,RMAXY,RMINX,RMINY,MAXX,MAXY,MINX,MINY,PLENG, >IRNG,IRANGE(5),NPRORB,IORB,IREF,IPAGE,IPOINT COMMON/SYNC/ENOM,SYNDEL,EMITGR,EMITK,EMITK2,ISYNFL,ISYNQD,IRND,IFF COMMON/ADIA/VPARM(15,6),IADFLG,IADCAV,NADVAR,IVID(15), >IVPAR(15),IVOPT(15) COMMON/SYM/ENERLI,GAMMLI,BETALI,ISYOPT,ISYFLG,MATTOT,KANVAR COMMON/LNGTH/TLENG,ALENG(MXELMD),ACLENG(MAXPOS) COMMON/COLL/COLENG, XSIZE, YSIZE, ISHAPE CHARACTER*1 MALE(101,51),MXXPR(101,51),MYYPR(101,51),MXY(101,51) COMMON/CTRMAT/ AM1(27),AM2(27),AM3(27),AM4(27),AM5(27),AM6(27), >ZI(6),ZF(6),NEL,IMSAV, >M1(27),M2(27),M3(27),M4(27),M5(27),M6(27),N1,N2,N3,N4,N5,N6 COMMON/CRDMON/MONAME(8),MOBEG,MOEND,MRDFLG >,MRDCHK CHARACTER*1 MONAME COMMON/CSEIS/XLAMBS,AXSEIS,PHIXS,YLAMBS, >AYSEIS,PHIYS,XSEIS,YSEIS,ISEIFL,IBEGSE,IENDSE COMMON/CRMAT/ACIN(6),AINC(6),ACOUT(6), > IFLMAT,NRMPRT,NRMORD common/cspch/delspc(mxpart),dpmax,dkmax,ispopt,ispchf COMMON/CAV/FREQ,ALC,AML,CAVPHI,DEOVE,CPHI(MXPART), >PINGAM,PBETA,PCLENG,DTN,DAML,DTNA(MXPART), >CTF,CLP,DPHI,F0CAV,F1CAV,PERCAV,APHIAD,ICOPT,IAML, >N0CAV,N1CAV,INCAV COMMON/LINCAV/LCAVIN,NUMCAV,ENJECT,IECAV(MAXMAT), & EIDEAL(MAXPOS),EREAL(MAXPOS) LOGICAL LCAVIN DIMENSION Y(6),X(6) EQUIVALENCE (Y1,Y(1)),(X1,X(1)) C C PRINT INITIAL POSITIONS C NORDER=2 IF(NPRINT.NE.-2)CALL TRAKPR(-1,1) IF(NPLOT.EQ.0) THEN LSTREQ=NCTURN+NTURN NXREQ=NCTURN+NTURN ELSE NXREQ = NPLOT +NCTURN LSTREQ = NTURN/NPLOT*NPLOT ENDIF C C TURN LOOP NCTURN -> NTURN C NCHECK=0 PINGAM=0.0D0 PBETA=1.0D0 CTF=0.0D0 10 NCTURN=NCTURN+1 ntbeg=1 if(ncturn.eq.1)then DO 11011 IPT=1,MXPART 11011 DTNA(IPT)=0.0D0 PCLENG=0 DTN=0 isyfl=0 if(ispchf.eq.1) then do 811 ipart=1,ncpart delspc(ipart)=-dkmax* > (dabs(part(ipart,6))+dpmax-dabs(del(ipart)))/dpmax 811 continue endif endif if(isyfl.eq.1)syphip=syphi IF(IADFLG.EQ.1)CALL ADICHK MONFLG=0 IF(IALFLG.EQ.0)GOTO 601 IF(IALFLG.EQ.1)GOTO 602 ITRBEG=IAFRST ITREND=MONLST IF(IXMSTP.NE.0) THEN IXS=ISDBEG IXMSTP=IBGSTP ELSE IXS=ISDBEG ENDIF IF(IXESTP.NE.0) THEN IXES=IESBEG IXESTP=IESTBG ELSE IXES=IESBEG ENDIF IERSRT = IERBEG GOTO 603 601 ITRBEG=1 ITREND=NELM IF(IXMSTP.NE.0) THEN IXS=1 IXMSTP=1 ELSE IXS=ISEED ENDIF IF(IXESTP.NE.0) THEN IXES=1 IXESTP=1 ELSE IXES=ISEED ENDIF IERSRT = 1 GOTO 603 602 ITRBEG=1 ITREND=IAFRST-1 IF(IXMSTP.NE.0) THEN IXS=1 IXMSTP=1 ELSE IXS=ISEED ENDIF IF(IXESTP.NE.0) THEN IXES=1 IXESTP=1 ELSE IXES=ISEED ENDIF IERSRT = 1 603 ILIST=1 MISPTR = 1 ICRPTR = 1 ITCHCK = (NCTURN-1)*(ITREND-ITRBEG+1) DO 110 IE=ITRBEG,ITREND IEP=IE NEL=NORLST(IE) MNEL=NEL IAD=IADR(NEL) MATADR=MADR(NEL) NT=KODE(NEL) NTP1=NT+1 CLP=CTF*ALENG(NEL)*PINGAM*PINGAM IF(ISEIFL.EQ.1) THEN IF((IE.GE.IBEGSE).AND.(IE.LE.IENDSE)) THEN DXS=-XSEIS XSEIS=AXSEIS*DSIN(PHIXS+ACLENG(IE)*TWOPI/XLAMBS) DXS=DXS+XSEIS DYS=-YSEIS YSEIS=AYSEIS*DSIN(PHIYS+ACLENG(IE)*TWOPI/YLAMBS) DYS=DYS+YSEIS DO 333 IP=1,NPART IF(.NOT.LOGPAR(IP))GOTO 333 PART(IP,1)=PART(IP,1)+DXS PART(IP,3)=PART(IP,3)+DYS 333 CONTINUE ENDIF ENDIF GOTO(10000,1000,4000,4000,4000,5000,6000,7000,8000, >9000,9000,20000,12000,13000,20000,9000,110,9500),NTP1 C C (SKIP OVER ELEMENT IF KODE=16 - NO CODE 16 ELEMENTS) C C C TREATING DRIFTS : CODE 0 , NO ERRORS ,ALIGNMENTS, PARTICLE CHECK C 10000 AL=ALENG(NEL) IF(AL.EQ.0.0D0) GOTO 99888 ALO2=0.5D0*AL CALL TRFDR GOTO 99888 C C TREATING BENDS : CODE 1 ,ERRORS,MISALIGNEMENTS,PARTICLE CHECK C CORRECTOR ELEMENTS AND SYNCHROTON RADIATION C 1000 MCHFLG=0 ICRCHK=0 IF(ISYNFL.NE.0) CALL SYNPRE(IAD,NEL) IF(ICRFLG.EQ.1) CALL CORCHK(IE) IF(MISFLG.EQ.1) CALL MISCHK IF((MERFLG.EQ.1).OR.(ICRCHK.EQ.2)) CALL ESET(NEL,MATADR) IMSAV=0 IF((NCPART.GT.2).AND.(ISYOPT.LT.1)) THEN IMSAV=1 CALL TRSAV(MATADR) ENDIF if (iff.ge.1) then alen = dabs(aleng(nel)) angle = dabs(eldat(iad+1)) if (kunits.eq.2) angle = angle * crdeg call synrad(1, alen, angle) endif DO 1001 ICPART=1,NPART IF(.NOT.LOGPAR(ICPART)) GO TO 1001 X1=PART(ICPART,1) X2=PART(ICPART,2) X3=PART(ICPART,3) X4=PART(ICPART,4) X5=PART(ICPART,5) X6=PART(ICPART,6) TEST=(X1)**2+(X3)**2 C do not expel particles if tracking is part of least square fit IF( (TEST.LT.EXPEL2) .OR. (IFITTR .GT. 0) ) GO TO 1002 WRITE(IOUT,10024)ICPART,IE,(NAME(IZ,NEL),IZ=1,8),NCTURN IF(ISO.NE.0)WRITE(ISOUT,10024)ICPART,IE,(NAME(IZ,NEL),IZ=1,8) <,NCTURN NCPART=NCPART-1 LOGPAR(ICPART)=.FALSE. WRITE(IOUT,10300)ICPART,(PART(ICPART,J),J=1,6) GOTO 1001 1002 IF(ISYNFL.EQ.0)GOTO 1008 IF(ISYNFL.EQ.2)GOTO 1009 if (iff.ge.1) call synrad(2, alen, angle) X6=X6-0.5D0*SYNDEL IF(ISYNFL.EQ.1)GOTO 1008 1009 X6=X6+0.707D0*EMITGR*RANNUM(ISYNSD,IRND,6.0D0,ISYSTP) 1008 IF(ICRCHK.EQ.1) CALL CSET IF(MCHFLG.EQ.1) CALL MSET CALL TRMAT(MATADR,ICPART) IF(MCHFLG.EQ.1) CALL MRESET IF(ICRCHK.EQ.1) CALL CRESET IF(ISYNFL.EQ.0)GOTO 1006 IF(ISYNFL.EQ.2)GOTO 1007 if (iff.ge.1) call synrad(2, alen, angle) Y6=Y6-0.5D0*SYNDEL IF(ISYNFL.EQ.1)GOTO 1006 1007 Y6=Y6+0.707D0*EMITGR*RANNUM(ISYNSD,IRND,6.0D0,ISYSTP) 1006 PART(ICPART,1)=Y1 PART(ICPART,2)=Y2 PART(ICPART,3)=Y3 PART(ICPART,4)=Y4 PART(ICPART,5)=Y5 PART(ICPART,6)=Y6 1001 CONTINUE GOTO 99888 C C TREATING QUADS : CODE 2,SEXTUPOLES : CODE 3,QUADSEXT : CODE 4 C ERRORS,MISALIGNEMENTS,PARTICLE CHECK C CORRECTOR ELEMENTS C 4000 MCHFLG=0 ICRCHK=0 isptst=0 if((ispchf.eq.1).and.(ntp1.eq.3))isptst=1 alen = dabs(aleng(nel)) IF(ISYNQD.EQ.1) CALL SYNPRE(IAD,NEL) IF(ICRFLG.EQ.1) CALL CORCHK(IE) IF(MISFLG.EQ.1) CALL MISCHK IF((MERFLG.EQ.1).OR.(ICRCHK.EQ.2)) CALL ESET(NEL,MATADR) IMSAV=0 IF((NCPART.GT.2).AND.(ISYOPT.LT.1)) THEN IMSAV=1 CALL TRSAV(MATADR) ENDIF c change particle check for a check vs 1/2-aperture rather than expel2 aperture = eldat (iadr(nel+1) - 2) if (aperture.le.0.d0 .or. aperture.gt.expel2) aperture=expel2 DO 4001 ICPART=1,NPART IF(.NOT.LOGPAR(ICPART)) GO TO 4001 X1=PART(ICPART,1) X2=PART(ICPART,2) X3=PART(ICPART,3) X4=PART(ICPART,4) X5=PART(ICPART,5) X6=PART(ICPART,6)+isptst*delspc(icpart) TEST=(X1)**2+(X3)**2 C do not expel particles if tracking for least squares fit if ( (test.lt.aperture) .OR. (ifittr .gt. 0) ) go to 4002 c IF(TEST.LT.EXPEL2) GO TO 4002 WRITE(IOUT,10024)ICPART,IE,(NAME(IZ,NEL),IZ=1,8),NCTURN IF(ISO.NE.0)WRITE(ISOUT,10024)ICPART,IE,(NAME(IZ,NEL),IZ=1,8) <,NCTURN NCPART=NCPART-1 LOGPAR(ICPART)=.FALSE. WRITE(IOUT,10300)ICPART,(PART(ICPART,J),J=1,6) GOTO 4001 4002 IF(ICRCHK.EQ.1) CALL CSET IF(MCHFLG.EQ.1) CALL MSET IF(ISYNQD.EQ.1) THEN xs1=x1 XS2=X2 xs3=x3 XS4=X4 xs5=x5 xs6=x6 ENDIF CALL TRMAT(MATADR,ICPART) IF(ISYNQD.EQ.1) THEN D1=DSQRT(1.0D0-XS2**2-XS4**2) D2=DSQRT(1.0D0-Y2**2-Y4**2) COSEX=XS2*Y2+XS4*Y4+D1*D2 ANGLE=DABS(DACOS(COSEX)) if (iff.ge.1) then x1 = xs1 x2 = xs2 x3 = xs3 x4 = xs4 x5 = xs5 x6 = xs6 c option 3 is quad specific (see routine SYNRAD) call synrad(3, alen, angle) x6 = x6 - syndel/2.0d0 c perform new tracking same quad call trmat(matadr,icpart) c option 2 saves time here! call synrad(2, alen, angle) y6 = y6 - syndel/2.0d0 else EMITGR=DSQRT(EMITK*ANGLE*ANGLE*ANGLE) Y6=Y6+EMITGR*RANNUM(ISYNSD,IRND,6.0D0,ISYSTP) > -EMITK2*ANGLE*ANGLE endif ENDIF IF(MCHFLG.EQ.1) CALL MRESET IF(ICRCHK.EQ.1) CALL CRESET PART(ICPART,1)=Y1 PART(ICPART,2)=Y2 PART(ICPART,3)=Y3 PART(ICPART,4)=Y4 PART(ICPART,5)=Y5 PART(ICPART,6)=Y6-isptst*delspc(icpart) 4001 CONTINUE GOTO 99888 C C TREAT MULTIPOLES : CODE 5 . MISALIGNMENTS AND ERRORS C 5000 AL = 0.5D0*ALENG(NEL) ALO2=0.5D0*AL MCHFLG=0 IF(MISFLG.EQ.1)CALL MISCHK IF(MERFLG.EQ.1)CALL ESET(NEL,MATADR) CALL MULTIT(NEL) IF(AL.NE.0.0D0)THEN IMSAV=0 IF((NCPART.GT.2).AND.(ISYOPT.LT.1))THEN IMSAV=1 CALL TRSAV(MATADR) ENDIF ENDIF DO 5001 ICPART=1,NPART IF(.NOT.LOGPAR(ICPART)) GO TO 5001 X1=PART(ICPART,1) X2=PART(ICPART,2) X3=PART(ICPART,3) X4=PART(ICPART,4) X5=PART(ICPART,5) X6=PART(ICPART,6) TEST=(X1)**2+(X3)**2 C do not expel particles if tracking for least squares fit IF( (TEST.LT.EXPEL2) .OR. (IFITTR .GT. 0) ) GO TO 5002 WRITE(IOUT,10024)ICPART,IE,(NAME(IZ,NEL),IZ=1,8),NCTURN IF(ISO.NE.0)WRITE(ISOUT,10024)ICPART,IE,(NAME(IZ,NEL),IZ=1,8) <,NCTURN NCPART=NCPART-1 LOGPAR(ICPART)=.FALSE. WRITE(IOUT,10300)ICPART,(PART(ICPART,J),J=1,6) GOTO 5001 5002 IF(MCHFLG.EQ.1)CALL MSET IF(AL.NE.0.0d0) THEN CALL TRMAT(MATADR,ICPART) X1=Y1 X2=Y2 X3=Y3 X4=Y4 X5=Y5 X6=Y6 ENDIF CALL MULTTR(X1,X2,X3,X4,X5,X6,Y1,Y2,Y3,Y4,Y5,Y6) IF(AL.NE.0.0d0) THEN X1=Y1 X2=Y2 X3=Y3 X4=Y4 X5=Y5 X6=Y6 CALL TRMAT(MATADR,ICPART) ENDIF IF(MCHFLG.EQ.1)CALL MRESET PART(ICPART,1)=Y1 PART(ICPART,2)=Y2 PART(ICPART,3)=Y3 PART(ICPART,4)=Y4 PART(ICPART,5)=Y5 PART(ICPART,6)=Y6 5001 CONTINUE GOTO 99888 C C TREAT COLLIMATORS : CODE 6 . NO MISALIGNEMENTS NO ERRORS C 6000 AL = ALENG(NEL) CALL COLPRE(IAD) DO 6001 ICPART=1,NPART IF(.NOT.LOGPAR(ICPART)) GO TO 6001 X1=PART(ICPART,1) X2=PART(ICPART,2) X3=PART(ICPART,3) X4=PART(ICPART,4) X5=PART(ICPART,5) X6=PART(ICPART,6) C CHECK COORDINATES AT ENTRY, BOTH RECTANGULAR AND ELLIPTIC CASES IF(ISHAPE.EQ.2) THEN IF(DABS(X1).GT.XSIZE.OR.DABS(X3).GT.YSIZE) GO TO 6002 ELSE ALIM = (X1/XSIZE)**2 + (X3/YSIZE)**2 IF(ALIM.GT.1.0) GO TO 6002 ENDIF C IF ZERO LENGTH, THEN JOB IS DONE IF(AL.EQ.0.0) GOTO 6001 CALL TRDRIF PART(ICPART,1)=Y1 PART(ICPART,3)=Y3 PART(ICPART,5)=Y5 C IF(ISYFLG.EQ.1) THEN REDUNDANT STATEMENTS C PART(ICPART,2)=Y2 DRIFT DOES NOT CHANGE C PART(ICPART,4)=Y4 MOMENTUM OR ANGLE C ENDIF C NOW CHECK COORDINATES AT EXIT IF(ISHAPE.EQ.2) THEN IF((DABS(Y1).GT.XSIZE).OR.(DABS(Y3).GT.YSIZE)) GO TO 6002 ELSE ALIM = (Y1/XSIZE)**2 + (Y3/YSIZE)**2 IF(ALIM.GT.1.0) GO TO 6002 ENDIF GO TO 6001 6002 WRITE(IOUT,10024)ICPART,IE,(NAME(IZ,NEL),IZ=1,8),NCTURN IF(ISO.NE.0)WRITE(ISOUT,10024)ICPART,IE,(NAME(IZ,NEL),IZ=1,8) <,NCTURN 10024 FORMAT(//,' PARTICLE #',I6,' IS LOST BEFORE ELEMENT',I6, + '(',8A1,')', + ' DURING TURN:',I6,/,' ITS POSITION IS :',//) NCPART=NCPART-1 LOGPAR(ICPART)=.FALSE. WRITE(IOUT,10300)ICPART,(PART(ICPART,J),J=1,6) IF(ISO.NE.0)WRITE(ISOUT,10300)ICPART,(PART(ICPART,J),J=1,6) 10300 FORMAT(' ',I4,6(E14.5)) DX5=Y5-X5 CPHI(ICPART)=CPHI(ICPART)+CTF*DX5-CLP*X6 6001 CONTINUE GOTO 99888 7000 CALL CAVPRE(IAD,NEL,NCTURN,IE) DO 7001 ICPART=1,NPART IF(.NOT.LOGPAR(ICPART)) GO TO 7001 X1=PART(ICPART,1) X2=PART(ICPART,2) X3=PART(ICPART,3) X4=PART(ICPART,4) X5=PART(ICPART,5) X6=PART(ICPART,6) CALL CAVITY(X1,X2,X3,X4,X5,X6,Y1,Y2,Y3,Y4,Y5,Y6,ICPART,NCTURN) PART(ICPART,1)=Y1 PART(ICPART,2)=Y2 PART(ICPART,3)=Y3 PART(ICPART,4)=Y4 PART(ICPART,5)=Y5 PART(ICPART,6)=Y6 DX5=Y5-X5 CPHI(ICPART)=CPHI(ICPART)+CTF*DX5-CLP*X6 7001 CONTINUE IF(INCAV.EQ.1)INCAV=2 GOTO 99888 C C C TREAT KICKS : CODE 8 . NO MISALIGNMENT , ERRORS (FOR POSSIBLE ROLL C STUDY), CORRECTORS OPTION 3 ONLY. C 8000 AL=0.5D0*ALENG(NEL) ALO2=0.5D0*AL ICRCHK=0 IF(AL.NE.0.0D0) CALL TRFDR IF(ICRFLG.EQ.1) CALL CORCHK(IE) IF(KUNITS.EQ.2) ANGKIK=ELDAT(IAD+7)*CRDEG IF(KUNITS.EQ.1) ANGKIK = -ELDAT(IAD+7) IF(KUNITS.EQ.0) ANGKIK = ELDAT(IAD+7) COSK=DCOS(ANGKIK) SINK=DSIN(ANGKIK) IF(MERFLG.EQ.1)CALL ESET(NEL,MATADR) IKI=DABS(ELDAT(IAD+9))+.01 IKM=MOD(NCTURN,IKI) IF(IKM.NE.0)GO TO 8002 MSYN=ELDAT(IAD+10) IF(MSYN.LT.0) THEN NSYN=ABS(FLOAT(MSYN)) if(ispchf.eq.1) then do 810 ipart=1,ncpart delspc(ipart)=-dkmax* > (dabs(part(ipart,6))+dpmax-dabs(del(ipart)))/dpmax 810 continue endif if(isyfl.eq.0) then syphip=-twopi/nsyn isyfl=1 endif if(ntbeg.eq.1) then syphi=syphip+twopi/nsyn ntbeg=0 endif SYNFAC=DCOS(TWOPI*(ACLENG(IE)/TLENG)/NSYN+syphi) ENDIF IFACTK=ELDAT(IAD+10) DXK=ELDAT(IAD+1) IF(KUNITS.EQ.1) THEN DXPK=-ELDAT(IAD+2) ELSE DXPK=ELDAT(IAD+2) ENDIF DYK=ELDAT(IAD+3) DYPK=ELDAT(IAD+4) DALK=ELDAT(IAD+5) DDELK=ELDAT(IAD+6) C C SCALE MOMENTA KICKS BY RATIO OF IDEAL TO REAL MOMENTA IF CAVITIES C ARE PRESENT AND ERRORS ARE ACTIVATED C IF((LCAVIN).AND.(MERFLG.EQ.1)) THEN CPIDEAL=DSQRT(EIDEAL(IE)**2-EMASS**2) CPREAL =DSQRT(EREAL(IE)**2-EMASS**2) RATMOM=(CPIDEAL/CPREAL) DXPK=RATMOM*DXPK DYPK=RATMOM*DYPK DDELK=RATMOM*DDELK END IF DO 8001 ICPART=1,NPART IF(.NOT.LOGPAR(ICPART)) GO TO 8001 X1=PART(ICPART,1) X2=PART(ICPART,2) X3=PART(ICPART,3) X4=PART(ICPART,4) X5=PART(ICPART,5) X6=PART(ICPART,6) IF(ICRCHK.EQ.2) CALL CSET FACTE=1.0D0 IF(IFACTK.EQ.1)FACTE=1.0D0/(1.0D0+X6) SX1=X1*COSK+X3*SINK X3=-X1*SINK+X3*COSK X1=SX1 SX2=X2*COSK+X4*SINK X4=-X2*SINK+X4*COSK X2=SX2 Y1=X1+DXK Y2=X2+DXPK*FACTE Y3=X3+DYK Y4=X4+DYPK*FACTE Y5=X5+DALK DX5=DALK CPHI(ICPART)=CPHI(ICPART)+CTF*DX5-CLP*X6 Y6=X6+DDELK IF(MSYN.LT.0) Y6=DEL(ICPART)*SYNFAC PART(ICPART,1)=Y1 PART(ICPART,2)=Y2 PART(ICPART,3)=Y3 PART(ICPART,4)=Y4 PART(ICPART,5)=Y5 PART(ICPART,6)=Y6 8001 CONTINUE 8002 IF(AL.NE.0.0D0)CALL TRFDR GOTO 99888 C C TREATING C TWISS : CODE 9,GENERAL MATRIX : CODE 10, SOLQUA : CODE 15 C ERRORS,MISALIGNEMENTS,PARTICLE CHECK C CORRECTOR ELEMENTS C 9000 MCHFLG=0 ICRCHK=0 IF(ICRFLG.EQ.1) CALL CORCHK(IE) IF(MISFLG.EQ.1) CALL MISCHK IF((MERFLG.EQ.1).OR.(ICRCHK.EQ.2)) CALL ESET(NEL,MATADR) IMSAV=0 IF((NCPART.GT.2).AND.(ISYOPT.LT.1)) THEN IMSAV=1 CALL TRSAV(MATADR) ENDIF DO 9001 ICPART=1,NPART IF(.NOT.LOGPAR(ICPART)) GO TO 9001 X1=PART(ICPART,1) X2=PART(ICPART,2) X3=PART(ICPART,3) X4=PART(ICPART,4) X5=PART(ICPART,5) X6=PART(ICPART,6) TEST=(X1)**2+(X3)**2 C do not expel particles if tracking for least squares fit IF( (TEST.LT.EXPEL2) .OR. (IFITTR .GT. 0) )GO TO 9002 WRITE(IOUT,10024)ICPART,IE,(NAME(IZ,NEL),IZ=1,8),NCTURN IF(ISO.NE.0)WRITE(ISOUT,10024)ICPART,IE,(NAME(IZ,NEL),IZ=1,8) <,NCTURN NCPART=NCPART-1 LOGPAR(ICPART)=.FALSE. WRITE(IOUT,10300)ICPART,(PART(ICPART,J),J=1,6) GOTO 9001 9002 IF(ICRCHK.EQ.1) CALL CSET IF(MCHFLG.EQ.1) CALL MSET CALL TRMAT(MATADR,ICPART) IF(MCHFLG.EQ.1) CALL MRESET IF(ICRCHK.EQ.1) CALL CRESET PART(ICPART,1)=Y1 PART(ICPART,2)=Y2 PART(ICPART,3)=Y3 PART(ICPART,4)=Y4 PART(ICPART,5)=Y5 PART(ICPART,6)=Y6 9001 CONTINUE GOTO 99888 C----------------------------------------------------------------------- C C TREAT LINAC CAVITY: CODE 17 C ERRORS,MISALIGNEMENTS,PARTICLE CHECK C CORRECTOR ELEMENTS C 9500 MCHFLG=0 ICRCHK=0 IF(ICRFLG.EQ.1) CALL CORCHK(IE) IF(MISFLG.EQ.1) CALL MISCHK IF((MERFLG.EQ.1).OR.(ICRCHK.EQ.2)) CALL ESET(NEL,MATADR) IMSAV=0 IF((NCPART.GT.2).AND.(ISYOPT.LT.1)) THEN IMSAV=1 CALL TRSAV(MATADR) ENDIF C C GET KICK PARAMETERS FROM ELEMENT DATA C DELTAE=ELDAT(IAD+2) PHI0 =ELDAT(IAD+3)*CRDEG AKICK =ELDAT(IAD+5) KONOFF=ELDAT(IAD+6) C DEFAULTS (USED IF KONOFF=0) ENOW=1.D0 SHIFT=0.D0 C GET ENERGY IF KICK BEFORE CAVITY IF(KONOFF.LT.0) THEN IF(IE.EQ.1) THEN ENOW=ENJECT ELSE ENOW=EREAL(IE-1) END IF END IF C GET ENERGY IF KICK AFTER CAVITY IF(KONOFF.GT.0) THEN ENOW=EREAL(IE) END IF C GET KICK MAGNITUDE IF NONZERO IF(KONOFF.NE.0) THEN CPNOW=DSQRT(ENOW**2-EMASS**2) SHIFT=(DELTAE*AKICK*DCOS(PHI0))/CPNOW END IF DO 9501 ICPART=1,NPART IF(.NOT.LOGPAR(ICPART)) GO TO 9501 X1=PART(ICPART,1) X2=PART(ICPART,2) X3=PART(ICPART,3) X4=PART(ICPART,4) X5=PART(ICPART,5) X6=PART(ICPART,6) TEST=(X1)**2+(X3)**2 C do not expel particles if tracking for lest squares fit IF( (TEST.LT.EXPEL2) .OR. (IFITTR .GT. 0) ) GO TO 9502 WRITE(IOUT,10024)ICPART,IE,(NAME(IZ,NEL),IZ=1,8),NCTURN IF(ISO.NE.0)WRITE(ISOUT,10024)ICPART,IE,(NAME(IZ,NEL),IZ=1,8) <,NCTURN NCPART=NCPART-1 LOGPAR(ICPART)=.FALSE. WRITE(IOUT,10300)ICPART,(PART(ICPART,J),J=1,6) GOTO 9501 9502 IF(ICRCHK.EQ.1) CALL CSET IF(MCHFLG.EQ.1) CALL MSET C C CHECK KICK PARAMETERS; PROCESS KICK IF REQUIRED C IF(KONOFF.EQ.(-2)) X4=X4+SHIFT IF(KONOFF.EQ.(-1)) X2=X2+SHIFT CALL TRMAT(MATADR,ICPART) C C CHECK KICK PARAMETERS; PROCESS KICK IF REQUIRED C IF(KONOFF.EQ.1) Y2=Y2+SHIFT IF(KONOFF.EQ.2) Y4=Y4+SHIFT IF(MCHFLG.EQ.1) CALL MRESET IF(ICRCHK.EQ.1) CALL CRESET PART(ICPART,1)=Y1 PART(ICPART,2)=Y2 PART(ICPART,3)=Y3 PART(ICPART,4)=Y4 PART(ICPART,5)=Y5 PART(ICPART,6)=Y6 9501 CONTINUE GOTO 99888 C----------------------------------------------------------------------- C TREAT ARBITRARY ELEMENT : CODE 12 MISALIGNEMENT ERRORS CORRECTORS C C IF (ISYOPT.NE.0) IE IF SYMPLECTIC TRACING IS DONE C SEE COMMENTS IN SUBROUTINE TRAFCT HEADING C REGARDING CHOICE OF VARIABLES C 12000 MCHFLG = 0 ICRCHK = 0 IERSET = 0 IF (ICRCHK.EQ.1) CALL CORCHK(IE) IF (MISFLG.EQ.1) CALL MISCHK IF ( (MERFLG.EQ.1).OR.(ICRCHK.EQ.2) ) CALL ESET(NEL,MATADR) CALL ARBIT(IAD,NEL) DO 12001 ICPART=1,NPART IF(.NOT.LOGPAR(ICPART)) GO TO 12001 X1=PART(ICPART,1) X2=PART(ICPART,2) X3=PART(ICPART,3) X4=PART(ICPART,4) X5=PART(ICPART,5) X6=PART(ICPART,6) IF (ICRCHK.NE.1) THEN IF (MCHFLG.NE.1) THEN CALL TRAFCT(X1,X2,X3,X4,X5,X6,Y1,Y2,Y3,Y4,Y5,Y6,ICPART) ELSE CALL MSET CALL TRAFCT(X1,X2,X3,X4,X5,X6,Y1,Y2,Y3,Y4,Y5,Y6,ICPART) CALL MRESET END IF ELSE CALL CSET IF (MCHFLG.NE.1) THEN CALL TRAFCT(X1,X2,X3,X4,X5,X6,Y1,Y2,Y3,Y4,Y5,Y6,ICPART) ELSE CALL MSET CALL TRAFCT(X1,X2,X3,X4,X5,X6,Y1,Y2,Y3,Y4,Y5,Y6,ICPART) CALL MRESET END IF CALL CRESET END IF PART(ICPART,1)=Y1 PART(ICPART,2)=Y2 PART(ICPART,3)=Y3 PART(ICPART,4)=Y4 PART(ICPART,5)=Y5 PART(ICPART,6)=Y6 12001 CONTINUE GOTO 99888 C C TREAT MONITORS : THEY CAN BE MISALIGNED BUT HAVE NO ERRORS C 13000 MCHFLG=0 IF(MISFLG.EQ.1)CALL MISCHK IF(MRDFLG.EQ.1)CALL RMOCHK(IE) IF(IALFLG.EQ.2)CALL MONCHK(IE) IF((MONFLG.NE.0).OR.(MRDCHK.EQ.1)) THEN AL=0.5D0*ALENG(NEL) ALO2=0.5D0*AL DO 13001 ICPART=1,NPART IF(.NOT.LOGPAR(ICPART))GOTO 13001 X1=PART(ICPART,1) X3=PART(ICPART,3) X5=PART(ICPART,5) X2=PART(ICPART,2) X4=PART(ICPART,4) X6=PART(ICPART,6) IF(MCHFLG.EQ.1) CALL MSET CALL TRDRIF PART(ICPART,1)=Y1 PART(ICPART,3)=Y3 PART(ICPART,5)=Y5 PART(ICPART,2)=Y2 PART(ICPART,4)=Y4 PART(ICPART,6)=Y6 DX5=Y5-X5 CPHI(ICPART)=CPHI(ICPART)+CTF*DX5-CLP*X6 13001 CONTINUE IF(IALFLG.EQ.2)CALL DETLPR(IE,ILIST) IF(MRDFLG.EQ.1)CALL READMO(IE) DO 13002 ICPART=1,NPART IF(.NOT.LOGPAR(ICPART))GOTO 13002 X1=PART(ICPART,1) X3=PART(ICPART,3) X5=PART(ICPART,5) X2=PART(ICPART,2) X4=PART(ICPART,4) X6=PART(ICPART,6) CALL TRDRIF IF(MCHFLG.EQ.1) CALL MRESET PART(ICPART,1)=Y1 PART(ICPART,3)=Y3 PART(ICPART,5)=Y5 PART(ICPART,2)=Y2 PART(ICPART,4)=Y4 PART(ICPART,6)=Y6 DX5=Y5-X5 CPHI(ICPART)=CPHI(ICPART)+CTF*DX5-CLP*X6 13002 CONTINUE GOTO 13010 ENDIF AL=ALENG(NEL) ALO2=0.5D0*AL CALL TRFDR 13010 GOTO 99888 20000 CONTINUE 99888 IF(IFLMAT.NE.0)CALL RMAT(IE,ILIST) IF(NANAL.EQ.0)GO TO 63 DO 64 IEN=1,NENER XCOR(NCTURN,IEN)=PART(IEN,1) XPCOR(NCTURN,IEN)=PART(IEN,2) 64 CONTINUE 63 IF (NJOB .EQ. 0) GO TO 62 NCP = 1 DO 61 IC = 1, NCASE XG (NCTURN,IC) = PART(NCP, 1) - XCO XPG(NCTURN,IC) = PART(NCP, 2) - XPCO IF (NJOB .EQ. 2) NCP = NCP + 1 YG (NCTURN,IC) = PART(NCP, 3) - YCO YPG(NCTURN,IC) = PART(NCP, 4) - YPCO NCP=NCP+1 61 CONTINUE 62 CONTINUE IF(NCPART.EQ.0) THEN NCTURN=NTURN NXREQ=NTURN ENDIF IF(IREF.EQ.1)CALL PLPORB(IE,NEL,NELM) IF((MDPRT.EQ.-2).AND.(IFITD.NE.1))GOTO 76 IF(MDPRT.EQ.0)GOTO75 IF((MDPRT.LE.-1).AND.(IE.NE.NELM))GOTO76 IF(IE.EQ.NELM)GOTO75 CALL PRTTST(IE,ILIST,IPRT) IF(IPRT.NE.1)GOTO76 75 CALL DETLPR(IE,ILIST) 76 IF(NPRINT.EQ.0)CALL TRAKPR(0,IEP) IF(NPLOT.EQ.0) THEN NZERO=0 NCCUM=1 CALL PLOTPR(IEP,NZERO) ENDIF C C PRINT AFTER N TURNS AT M LOCATIONS C 90 MODPR=1 MODPL=1 IF(NPRINT.GT.0)MODPR=MOD(NCTURN,NPRINT) IF(NPLOT.GT.0)MODPL=MOD(NCTURN,NPLOT) IF((MODPR.EQ.0).OR.(MODPL.EQ.0)) THEN CALL PRTTST(IE,ILIST,IPRT) IF(IPRT.EQ.1)THEN IF(MODPR.EQ.0)CALL TRAKPR(0,IEP) IF((MODPL.EQ.0).AND.(MLOCAT.NE.0)) THEN NZERO=0 NCCUM=1 CALL PLOTPR(IEP,NZERO) ENDIF ENDIF ENDIF IF(IERSET.EQ.1)CALL ERESET(NEL,MATADR) IF(MONFLG.EQ.2)GOTO112 IF(NCPART.NE.0) THEN ICHECK=(ITCHCK+(IE-ITRBEG+1))*NCPART-NCHECK IF(ICHECK.GE.100000) THEN WRITE(ISOUT,99110)IE,NCTURN NCHECK=NCHECK+100000 ENDIF 99110 FORMAT(' AT ELEMENT ',I6,' DURING TURN ',I6) ENDIF 110 CONTINUE 112 IF(IALFLG.EQ.1)THEN IF(IXMSTP.NE.0) THEN ISDBEG=IXS IBGSTP=IXMSTP ELSE ISDBEG=IXS ENDIF IF(IXESTP.NE.0) THEN IESBEG=IXES IESTBG=IXESTP ELSE IESBEG=IXES ENDIF IERBEG=IERSRT ENDIF IF(IALFLG.EQ.1)CALL DETLPR(ITREND,ILIST) C C CHECK THE PLOT REQUESTED FOR THIS TURN C IF(NCTURN.LT.NTURN) GO TO 300 IF(((NPRINT.NE.-2).AND.(MLOCAT.EQ.0).AND.(NPRINT.NE.0)) >.OR.(NPRINT.EQ.-1)) >CALL TRAKPR(0,NELM) 300 IF((NPLOT.LE.0).OR.(MLOCAT.NE.0)) GO TO 200 IF(NCTURN.NE.NXREQ) GO TO 200 NZERO = 1 IF(NCTURN.EQ.NPLOT) NZERO = 0 IF(NCCUM.EQ.1) NZERO = 0 IF(NCTURN.EQ.LSTREQ) NCCUM = 1 CALL PLOTPR(NELM,NZERO) NXREQ = NXREQ+NPLOT 200 IF(NCTURN.LT.NTURN) GO TO 10 RETURN END SUBROUTINE TRAFCT(XI,XPI,YI,YPI,ALI,DELI, > XO,XPO,YO,YPO,ALO,DELO,IPART) C ********************** IMPLICIT REAL*8 (A-H,O-Z) PARAMETER (MXPART= 16384) C C C THIS ROUTINE IS TO BE PROGRAMMED BY THE USER C THE INPUT COORDINATES HAVE A TRAILING I AND THE OUTPUT C COORDINATES HAVE A TRAILING O. C IF THE TRANSFORM THAT IS PROGRAMMED HERE IS NOT SYMPLECTIC C OR DOES NOT SATISFY LIOUVILLE'S THEOREM SOME OTHER PARTS OF C THE PROGRAM MAY NOT GIVE MEANINGFUL RESULTS !!!!! C THE ONLY PARTS OF THE PROGRAMME AFFECTED BY THIS ELEMENT ARE C THE MOVE(MENT) ANALYSIS OPERATION, THE TRAC(KING) OPERATION AND C THE MODI(FICATION) OF PARAMETERS OPERATION. C NTURN IN THE CURRENT TURN BEING PROCESSED AND CAN BE USED C TO DESIGN AN ELEMENT WHOSE BEHAVIOUR VARIES WITH THE TURN. C IPART IS THE # OF THE PARTICLE BEING TREATED. LOGPAR IS A LOGICAL C ARRAY.LOGPAR(IPART) SHOULD BE SET TO .FALSE. TO STOP THE PARTICLE C FROM BEING TRACKED ANY FURTHER.THE COORDINATES OF THE PARTICLE C REMAIN UNALTERED TO THE END OF THE CURRENT TRACKING. C C IF THIS SUBROUTINE IS TO BE USED WITH SYMPLECTIC TRACING AND C CANONICAL VARIABLES , IT SHOULD BE WRITTEN TO EMPLOY THE C CANONICAL SET X,PX,Y,PY,T,PT(=-E) (AS OF 3 APRIL 1985). C COMMON/ARB/PARA(20),NT(MXPART),NARBP COMMON/INOUT/IIN,IOUT,ISOUT,ISO,NOUT,NSLC PARAMETER (MXELMD = 8192) PARAMETER (MAXPOS = 8192) PARAMETER (MAXMAT = 250) COMMON AMAT(27,6,MAXMAT),NORLST(MAXPOS), 1EXPEL2,N,LOGPAR(MXPART) LOGICAL LOGPAR COMMON/TRACE/PART(MXPART,6),DEL(MXPART),NPART,NCPART,NPRINT, < NCTURN,MLOCAT,NTURN IF((NCTURN.NE.1).OR.(IPART.NE.1))GOTO 3 DO 4 JPART=1,NPART 4 NT(JPART)=0 3 ALO=ALI DELO=DELI YO=YI YPO=YPI XO=XI XPO=XPI IF(XO.GE.PARA(1))GOTO 10 LOGPAR(IPART)=.FALSE. NT(IPART)=NCTURN NCPART=NCPART-1 IF(NCPART.EQ.0)GOTO 2 10 ITOT=PARA(2) IF((NCTURN.NE.ITOT).OR.(NARBP.EQ.1))RETURN 2 DO 1 IPRT=1,NPART WRITE(IOUT,10001)NT(IPRT),(PART(IPRT,IC),IC=1,6) 10001 FORMAT(' ',I5,6E11.3) 1 CONTINUE NARBP=1 RETURN END C ************************ SUBROUTINE TRAKPR(ICODE,IE) C ************************ IMPLICIT REAL*8 (A-H,O-Z) PARAMETER (MXPART= 16384) PARAMETER (MXELMD = 8192) PARAMETER (MAXPOS = 8192) PARAMETER (MAXMAT = 250) COMMON AMAT(27,6,MAXMAT),NORLST(MAXPOS), 1EXPEL2,N,LOGPAR(MXPART) LOGICAL LOGPAR COMMON/INOUT/IIN,IOUT,ISOUT,ISO,NOUT,NSLC PARAMETER (MAXDAT = 4000) COMMON /INPUTT/ KODE(MXELMD),IADR(MXELMD),ELDAT(MAXDAT) +,MADR(MXELMD),KCOUNT,NA,KUNITS COMMON/CHINP/NAME(8,MXELMD),LABEL(14,MXELMD) CHARACTER*1 NAME,LABEL COMMON/TRACE/PART(MXPART,6),DEL(MXPART),NPART,NCPART,NPRINT, < NCTURN,MLOCAT,NTURN COMMON/CAV/FREQ,ALC,AML,CAVPHI,DEOVE,CPHI(MXPART), >PINGAM,PBETA,PCLENG,DTN,DAML,DTNA(MXPART), >CTF,CLP,DPHI,F0CAV,F1CAV,PERCAV,APHIAD,ICOPT,IAML, >N0CAV,N1CAV,INCAV C C WHAT KIND OF PRINTING? C NEL = NORLST(IE) IF(ICODE)10,30,30 C C INITIAL POSITIONS PRINTING C 10 IF(NOUT.LT.4) THEN WRITE(IOUT,10301) 10301 FORMAT(//,' INITIAL POSITIONS OF PARTICLES ',/) DO 20 I=1,NPART IF(.NOT.LOGPAR(I)) GO TO 20 WRITE(IOUT,10300)I,(PART(I,K),K=1,6) 10300 FORMAT(1x,I4,6(E14.5)) 20 CONTINUE ELSE IF(NOUT.EQ.4) THEN DO 22 I=1,NPART IF(.NOT.LOGPAR(I)) GO TO 22 WRITE(IOUT,10320)NCTURN,(NAME(IN,NEL),IN=1,8) >,I,(PART(I,K),K=1,6) 22 CONTINUE ENDIF 10320 FORMAT(I4,8A1,I4,6(E13.4)) ENDIF RETURN C C OTHER PRINTING C 30 IF(NOUT.LT.4) THEN WRITE(IOUT,10302)IE,(NAME(IZ,NEL),IZ=1,8),NCTURN 10302 FORMAT(/,' PARTICLE POSITIONS AFTER ELEMENT',2X,I6,'(',8A1,')', > 2X,'DURING TURN',I6,/) DO 40 I=1,NPART IF(.NOT.LOGPAR(I)) GO TO 40 WRITE(IOUT,10300) I,(PART(I,K),K=1,6) 40 CONTINUE ELSE IF(NOUT.EQ.4) THEN DO 42 I=1,NPART IF(.NOT.LOGPAR(I)) GO TO 42 WRITE(IOUT,10320)NCTURN,(NAME(IN,NEL),IN=1,8) >,I,(PART(I,K),K=1,6) 42 CONTINUE ENDIF IF(NOUT.EQ.14) THEN DO 23 I=1,NPART IF(.NOT.LOGPAR(I)) GO TO 23 WRITE(IOUT,10321)NCTURN,I,(PART(I,K),K=1,4), > CPHI(I),PART(I,6) 10321 FORMAT(I4,I4,6(E13.4)) 23 CONTINUE ENDIF ENDIF RETURN END SUBROUTINE TRDRIF C *********************** IMPLICIT REAL*8(A-H,O-Z),INTEGER(I-N) COMMON/V/AL,ALO2,VV(27),X1,X2,X3,X4,X5,X6,Y1,Y2,Y3,Y4,Y5,Y6 COMMON/SYM/ENERLI,GAMMLI,BETALI,ISYOPT,ISYFLG,MATTOT,KANVAR PARAMETER (MXELMD = 8192) PARAMETER (MAXMAT = 250) COMMON /SYMMAP/ BSYMAT(6,6,MAXMAT),CSYMAT(6,27,MAXMAT) DIMENSION ZI(6),ZF(6) C C IF (ISYFLG.EQ.1)THEN DISABLE THIS - ISYFLG IS FLAG ON C MATRICES, NOT VARIABLES IF (KANVAR.EQ.1) THEN C C IN THIS CASE, INTERNAL VARIABLES ARE CANONICAL (KANVAR = 1) C AND MUST BE SWITCHED TO GEOMETRIC VARIABLES BEFORE DOING RAY TRACE C CALL NCVAR(X1,ZI,GAMMLI,BETALI) ZF(1)=ZI(2)*AL+ZI(1) ZF(2)=ZI(2) ZF(3)=ZI(4)*AL+ZI(3) ZF(4)=ZI(4) ZF(5)=ALO2*(ZI(2)*ZI(2)+ZI(4)*ZI(4))+ZI(5) ZF(6)=ZI(6) CALL CVAR(ZF,Y1,GAMMLI,BETALI) ELSE C C IN THIS CASE, EITHER ISYFLG=0 (NO SYMPLECTIFICATION) OR THINGS ARE C SYMPLECTIFIED BUT ISYOPT=1 OR 3, SO THAT INTERNAL VARIABLES ARE THE C GEOMETRIC VARIABLES (KANVAR = 0). JUST DO THE RAY TRACE C Y1=X2*AL+X1 Y2=X2 Y3=X4*AL+X3 Y4=X4 Y5=ALO2*(X2*X2+X4*X4)+X5 Y6=X6 END IF RETURN END SUBROUTINE TRFDR C *********************** IMPLICIT REAL*8(A-H,O-Z),INTEGER(I-N) PARAMETER (MXPART= 16384) COMMON/V/AL,ALO2,VV(27),X1,X2,X3,X4,X5,X6,Y1,Y2,Y3,Y4,Y5,Y6 PARAMETER (MXELMD = 8192) PARAMETER (MAXPOS = 8192) PARAMETER (MAXMAT = 250) COMMON AMAT(27,6,MAXMAT),NORLST(MAXPOS), 1EXPEL2,N,LOGPAR(MXPART) LOGICAL LOGPAR COMMON/SYM/ENERLI,GAMMLI,BETALI,ISYOPT,ISYFLG,MATTOT,KANVAR COMMON/TRACE/PART(MXPART,6),DEL(MXPART),NPART,NCPART,NPRINT, < NCTURN,MLOCAT,NTURN COMMON/CAV/FREQ,ALC,AML,CAVPHI,DEOVE,CPHI(MXPART), >PINGAM,PBETA,PCLENG,DTN,DAML,DTNA(MXPART), >CTF,CLP,DPHI,F0CAV,F1CAV,PERCAV,APHIAD,ICOPT,IAML, >N0CAV,N1CAV,INCAV DO 13003 ICPART=1,NPART IF(.NOT.LOGPAR(ICPART))GOTO 13003 X1=PART(ICPART,1) X3=PART(ICPART,3) X5=PART(ICPART,5) X2=PART(ICPART,2) X4=PART(ICPART,4) C X6=PART(ICPART,6) C MUST DO ENERGY DEVIATION ALSO - SO THAT C TRANSFORMATION FROM CANONICAL TO GEOMETRIC C VARIABLES IS POSSIBLE CALL TRDRIF DX5=Y5-X5 CPHI(ICPART)=CPHI(ICPART)+CTF*DX5-CLP*X6 PART(ICPART,1)=Y1 PART(ICPART,3)=Y3 PART(ICPART,5)=Y5 C IF(ISYFLG.EQ.1) THEN DISABLE - THIS IS REDUNDANT, AS C PART(ICPART,2)=Y2 DRIFT DOES NOT CHANGE MOMENTA IN C PART(ICPART,4)=Y4 ANY EVENT C ENDIF 13003 CONTINUE RETURN END SUBROUTINE TRMAT(MATADR,ICPART) C ******************************* IMPLICIT REAL*8(A-H,O-Z),INTEGER(I-N) PARAMETER (MXPART= 16384) COMMON/V/AL,ALO2,VV(27),X1,X2,X3,X4,X5,X6,Y1,Y2,Y3,Y4,Y5,Y6 COMMON/CTRMAT/ AM1(27),AM2(27),AM3(27),AM4(27),AM5(27),AM6(27), >ZI(6),ZF(6),NEL,IMSAV, >M1(27),M2(27),M3(27),M4(27),M5(27),M6(27),N1,N2,N3,N4,N5,N6 COMMON/SYM/ENERLI,GAMMLI,BETALI,ISYOPT,ISYFLG,MATTOT,KANVAR PARAMETER (MXELMD = 8192) PARAMETER (MAXPOS = 8192) PARAMETER (MAXMAT = 250) COMMON AMAT(27,6,MAXMAT),NORLST(MAXPOS), 1EXPEL2,N,LOGPAR(MXPART) LOGICAL LOGPAR COMMON/CAV/FREQ,ALC,AML,CAVPHI,DEOVE,CPHI(MXPART), >PINGAM,PBETA,PCLENG,DTN,DAML,DTNA(MXPART), >CTF,CLP,DPHI,F0CAV,F1CAV,PERCAV,APHIAD,ICOPT,IAML, >N0CAV,N1CAV,INCAV DIMENSION Y(6) EQUIVALENCE (Y(1),Y1) IF(ISYOPT.LT.1) THEN IF (IMSAV.EQ.0) THEN CALL COMPL DO 50 IM=1,6 SUM=0.0D0 DO 51 JM=1,27 AMIJ=AMAT(JM,IM,MATADR) IF (AMIJ.EQ.0D0)GOTO 51 SUM=SUM+AMIJ*VV(JM) 51 CONTINUE 50 Y(IM)=SUM ELSE CALL COMPL SUM=0.0D0 DO 211 JM=1,N1 211 SUM = SUM + AM1(JM)*VV(M1(JM)) Y1=SUM SUM=0.0D0 DO 212 JM=1,N2 212 SUM = SUM + AM2(JM)*VV(M2(JM)) Y2=SUM SUM=0.0D0 DO 213 JM=1,N3 213 SUM = SUM + AM3(JM)*VV(M3(JM)) Y3=SUM SUM=0.0D0 DO 214 JM=1,N4 214 SUM = SUM + AM4(JM)*VV(M4(JM)) Y4=SUM SUM=0.0D0 DO 215 JM=1,N5 215 SUM = SUM + AM5(JM)*VV(M5(JM)) Y5=SUM SUM=0.0D0 DO 216 JM=1,N6 216 SUM = SUM + AM6(JM)*VV(M6(JM)) Y6=SUM ENDIF ELSE IF(KANVAR.EQ.0) THEN CALL CVAR(X1,ZI,GAMMLI,BETALI) IF(ISYOPT.EQ.1) THEN CALL SYMRTX(MATADR,ZI,ZF) ELSE CALL SYMRAT(MATADR,ZI,ZF) END IF CALL NCVAR(ZF,Y1,GAMMLI,BETALI) ELSE IF (ISYOPT.EQ.2) THEN CALL SYMRTX(MATADR,X1,Y1) ELSE CALL SYMRAT(MATADR,X1,Y1) END IF END IF C C REPLACED (2/7/86) C C IF(ISYOPT.EQ.1) THEN C CALL CVAR(X1,ZI,GAMMLI,BETALI) C CALL SYMRTX(MATADR,ZI,ZF) C CALL NCVAR(ZF,Y1,GAMMLI,BETALI) C ELSE C IF(ISYOPT.EQ.2) THEN C CALL SYMRTX(MATADR,X1,Y1) C ELSE C IF(ISYOPT.EQ.3) THEN C CALL CVAR(X1,ZI,GAMMLI,BETALI) C CALL SYMRAT(MATADR,ZI,ZF) C CALL NCVAR(ZF,Y1,GAMMLI,BETALI) C ELSE C IF(ISYOPT.GT.3) CALL SYMRAT(MATADR,X1,Y1) C END IF C END IF C END IF END IF DX5=Y5-X5 CPHI(ICPART)=CPHI(ICPART)+CTF*DX5-CLP*X6 RETURN END SUBROUTINE TRSAV(MATADR) C *********************** IMPLICIT REAL*8(A-H,O-Z),INTEGER(I-N) PARAMETER (MXPART= 16384) COMMON/V/AL,ALO2,VV(27),X1,X2,X3,X4,X5,X6,Y1,Y2,Y3,Y4,Y5,Y6 COMMON/CTRMAT/ AM1(27),AM2(27),AM3(27),AM4(27),AM5(27),AM6(27), >ZI(6),ZF(6),NEL,IMSAV, >M1(27),M2(27),M3(27),M4(27),M5(27),M6(27),N1,N2,N3,N4,N5,N6 PARAMETER (MXELMD = 8192) PARAMETER (MAXPOS = 8192) PARAMETER (MAXMAT = 250) COMMON AMAT(27,6,MAXMAT),NORLST(MAXPOS), 1EXPEL2,N,LOGPAR(MXPART) LOGICAL LOGPAR IJM=1 DO 202 JM=1,27 AMIJ=AMAT(JM,1,MATADR) IF(AMIJ.NE.0.0D0)THEN M1(IJM)=JM AM1(IJM)=AMIJ IJM=IJM+1 ENDIF 202 CONTINUE N1=IJM-1 IJM=1 DO 203 JM=1,27 AMIJ=AMAT(JM,2,MATADR) IF(AMIJ.NE.0.0D0)THEN M2(IJM)=JM AM2(IJM)=AMIJ IJM=IJM+1 ENDIF 203 CONTINUE N2=IJM-1 IJM=1 DO 204 JM=1,27 AMIJ=AMAT(JM,3,MATADR) IF(AMIJ.NE.0.0D0)THEN M3(IJM)=JM AM3(IJM)=AMIJ IJM=IJM+1 ENDIF 204 CONTINUE N3=IJM-1 IJM=1 DO 205 JM=1,27 AMIJ=AMAT(JM,4,MATADR) IF(AMIJ.NE.0.0D0)THEN M4(IJM)=JM AM4(IJM)=AMIJ IJM=IJM+1 ENDIF 205 CONTINUE N4=IJM-1 IJM=1 DO 206 JM=1,27 AMIJ=AMAT(JM,5,MATADR) IF(AMIJ.NE.0.0D0)THEN M5(IJM)=JM AM5(IJM)=AMIJ IJM=IJM+1 ENDIF 206 CONTINUE N5=IJM-1 IJM=1 DO 207 JM=1,27 AMIJ=AMAT(JM,6,MATADR) IF(AMIJ.NE.0.0D0)THEN M6(IJM)=JM AM6(IJM)=AMIJ IJM=IJM+1 ENDIF 207 CONTINUE N6=IJM-1 RETURN END C ************************* SUBROUTINE TUNE(IEND) C ************************* IMPLICIT REAL*8(A-H,O-Z), INTEGER (I-N) PARAMETER (MXPART= 16384) PARAMETER (MXELMD = 8192) PARAMETER (MAXPOS = 8192) PARAMETER (MAXMAT = 250) COMMON AMAT(27,6,MAXMAT),NORLST(MAXPOS), 1EXPEL2,N,LOGPAR(MXPART) LOGICAL LOGPAR COMMON/INOUT/IIN,IOUT,ISOUT,ISO,NOUT,NSLC PARAMETER (MAXDAT = 4000) COMMON /INPUTT/ KODE(MXELMD),IADR(MXELMD),ELDAT(MAXDAT) +,MADR(MXELMD),KCOUNT,NA,KUNITS COMMON/CHINP/NAME(8,MXELMD),LABEL(14,MXELMD) CHARACTER*1 NAME,LABEL COMMON/LNGTH/TLENG,ALENG(MXELMD),ACLENG(MAXPOS) COMMON/CSEEDS/ISEED,IXG,IXS,IXMSTP,IMSD,IMOSTP,ISYNSD,ISYSTP, >ISDBEG,IBGSTP,IXES,IXESTP,IESBEG,IESTBG C CINTAK : COMMON CONTAINING ARRAYS NEEDED FOR INPUT PARAMETER (MXINP = 100) COMMON/CINTAK/DATA(MXINP),ICHAR(8) COMMON /CTUNE/DNU0X,DNU0Y,DBETX,DBETY,DALPHX,DALPHY, >DXCO,DXPCO,DYCO,DYPCO,DDELCO CHARACTER*1 ICHAR NCHAR=0 NDATA=1 NIPR=1 CALL INPUT(ICHAR,NCHAR,DATA,MXINP,IEND,NDATA,NIPR) IOPT=DATA(1) NCHAR=8 NDATA=0 CALL INPUT(ICHAR,NCHAR,DATA,MXINP,IEND,NDATA,NIPR) CALL ELID(ICHAR,NELID) CALL INPUT(ICHAR,NCHAR,DATA,MXINP,IEND,NDATA,NIPR) CALL DIMPAR(NELID,ICHAR,NPAR) NCHAR=0 NDATA=2 CALL INPUT(ICHAR,NCHAR,DATA,MXINP,IEND,NDATA,NIPR) DNUX=DATA(1) FACTOR=DATA(2) IAD=IADR(NELID) ELDAT(IAD+NPAR-1)=ELDAT(IAD+NPAR-1)+FACTOR*(DNUX-DNU0X) IF(NOUT.GE.3) >WRITE(IOUT,99999)DNU0X,DNU0Y,DNUX,ELDAT(IAD+NPAR-1) 99999 FORMAT(' ',4E16.5) IADP1=IADR(NELID+1) RETURN END SUBROUTINE TVBGN(IUNIT) C-----DUMMY ROUTINE FOR TV RETURN END SUBROUTINE TVEND C-----DUMMY ROUTINE FOR TV RETURN END SUBROUTINE TVRNG(A,B,C,D,E) C-----DUMMY ROUTINE FOR TV RETURN END