SUBROUTINE ACCGET C C SUBROUTINE ACCGET GETS THE PARAMETERS FOR AN ACCELERATOR ELEMENT C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'CONSTS.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM0B.CIN' INCLUDE 'ELM11.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'ELM26B.CIN' INCLUDE 'INDPAR.CIN' INCLUDE 'XRAN.CIN' C C LOCAL VARIABLES C INTEGER IADR, IDATA, IT REAL DATAR, FREQ EXTERNAL DATAR, IDATA C C------------------------------------------------------- IADR = I + 1 L = DATAR(IADR) IF (PRAN11(1) .NE. 0.0) L = L + PRAN11(1)*XRAN(1) L = L*UNITI(8) C IADR = I + 2 EGAIN = DATAR(IADR) IF (PRAN11(2) .NE. 0.0) 1 EGAIN = EGAIN + PRAN11(2)*XRAN(2) EGAIN = EGAIN*UNITI(11) C IADR = I + 3 PHASEL = DATAR(IADR) IF (PRAN11(3) .NE. 0.0) 1 PHASEL = PHASEL + PRAN11(3)*XRAN(3) PHASEL = PHASEL/RADIAN C IADR = I + 4 IF (IPTOJ(5) .EQ. 0) THEN WAVEL = DATAR(IADR) IF (PRAN11(4) .NE. 0.0) 1 WAVEL = WAVEL + PRAN11(4)*XRAN(4) WAVEL = WAVEL*UNITI(5) ELSE FREQ = DATAR(IADR) WAVEL = CLIGHT*1.0E-6/FREQ ENDIF IT = IPTOJ(6) IF (IT .EQ. 0) THEN NUMTYP = IT ELSE NUMTYP = IDATA(I + IT) ENDIF RETURN END SUBROUTINE ACCMTX C C CALCULATES THE TRANSFER MATRIX FOR AN ACCELERATOR SECTION C C LIST OF COMMON BLOCKS C INCLUDE 'CONSTS.CIN' INCLUDE 'ELM0B.CIN' INCLUDE 'ELM1A.CIN' INCLUDE 'ELM11.CIN' INCLUDE 'ELM16B.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'R.CIN' C C LOCAL VARIABLES C C---------------------------------------------------- IF (NORD1 .LT. 1) GO TO 100 COSPHI = COS(PHASEL) SINPHI = SIN(PHASEL) DEE = EGAIN*COSPHI DUM = EGAIN*SINPHI C C ELECTRONS C IF (SM .NE. 0.0) GO TO 50 IF (ABS(DEE/RI) .LT. 0.01) THEN R(1,2) = L*(1.0 - 0.5*DEE/RI + (DEE/RI)**2/3.0) ELSE R(1,2) = L*(RI*LOG(1. + DEE/RI)/DEE) ENDIF R(2,2) = RI/(RI + DEE) R(3,4) = R(1,2) R(4,4) = R(2,2) IF (WAVEL .NE. 0.) R(6,5) = (DUM/(RI+DEE))*(2.0*PI/WAVEL) R(6,6) = R(2,2) RINEW = RI + DEE PREF = PREF*RINEW/RI RI = RINEW GO TO 100 C C PROTONS AND HEAVY IONS C 50 EOLD = SQRT(RI**2 + SM**2) ENEW = EOLD + DEE RINEW = SQRT(ENEW**2 - SM**2) GAMIN = EOLD/SM BETAIN = RI/EOLD ETAIN = RI/SM GAM = ENEW/SM BETA = RINEW/ENEW ETAN = RINEW/SM DGAM = DEE/(SM*L) DETA = GAM*DGAM/ETAN DETAIN = GAMIN*DGAM/ETAIN SQEIN = SQRT(ETAIN) SQET = SQRT(ETAN) RETA = SQRT(SQET/SQEIN) RBETA = BETA/BETAIN Q = PI*DUM/(L*WAVEL*SM) TQ = 2.0*Q QSQ = SQRT(Q) STQ = SQRT(TQ) DELG = DEE/SM FINT = DELG - 0.75*GAMIN*DELG**2/ETAIN**2 1 - 0.25*DELG**3/ETAIN**2 + 0.875*GAMIN**2*DELG**3/ETAIN**4 FINT = FINT/(DGAM*SQRT(ETAIN**3)) FINTA = QSQ*FINT COSK = COSH(FINTA) SINK = SINH(FINTA) FINTB = STQ*FINT COSL = COS(FINTB) SINL = SIN(FINTB) R(1,1) = RETA*COSK - 0.25*DETAIN*SQEIN*RETA*SINK/QSQ R(1,2) = SQEIN**3*RETA*SINK/QSQ R(2,1) = 0.25*(DETA*RETA - DETAIN/RETA)*COSK/ETAN 1 + (RETA*QSQ/ETAN 2 - 0.0625*DETA*DETAIN/(RETA*QSQ))*SINK/SQET R(2,2) = 0.25*SQEIN**3*DETA*RETA*SINK/(QSQ*ETAN) 1 + COSK/RETA**5 R(3,3) = R(1,1) R(3,4) = R(1,2) R(4,3) = R(2,1) R(4,4) = R(2,2) R(5,5) = RBETA*COSL/RETA**3 1 + 0.75*RBETA*DETAIN*SQEIN*SINL/(RETA*STQ) R(5,6) = BETA*BETAIN*(0.75*(- DETA/RETA 1 + DETAIN*RETA**3)*COSL 2 + (0.5625*DETA*DETAIN*SQEIN/STQ 3 + STQ/SQET)*SINL/RETA)/TQ IF (WAVEL .NE. 0.0) THEN R(6,5) = - SQEIN*STQ*SINL/(BETA*BETAIN*RETA) ENDIF R(6,6) = (COSL - 0.75*SQEIN*DETAIN*SINL/STQ)/(RBETA*RETA) PREF = PREF*RINEW/RI RI = RINEW C 100 RETURN END SUBROUTINE ADVANC(I) C C CALCULATE THE COORDINATE ROTATION MATRIX AND VECTOR SPANNING C THE BEAM LINE SINCE THE LAST UPDATE C USED FOR MISALIGNMENT CALCULATIONS AND FLOOR COORDINATE LAYOUTS C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM0D.CIN' INCLUDE 'IOUNIT.CIN' INCLUDE 'FLUSHC.CIN' INCLUDE 'OC.CIN' INCLUDE 'OCP.CIN' C C LOCAL VARIABLES C INTEGER I, J, K, L REAL O1(3,3), S, S1 C C------------------------------------------------------------ IF (I .LT. 0 .OR. I .GT. 4) THEN WRITE (NOUT,9001) I 9001 FORMAT (' *** ERROR ***, I = ',I2,'IN ADVANC') FLUSHL = .TRUE. GO TO 20 ENDIF IF (.NOT. OMTX) GO TO 15 IF (.NOT. OCP(I)) GO TO 10 C C MULTIPLY COORDINATE ROTATION OF ELEMENT TIMES ACCUMULATED C COORDINATE ROTATION C DO 2 J = 1, 3 DO 2 K = 1, 3 S1 = 0.0 DO 1 L = 1, 3 S1 = S1 + O(1,J,L)*O(I,L,K) 1 CONTINUE O1(J,K) = S1 2 CONTINUE C DO 5 J = 1, 3 S = 0.0 DO 4 K = 1, 3 S = S + O(I,K,J)*X0(1,K) 4 CONTINUE X0(I,J) = X0(I,J) + S 5 CONTINUE C DO 8 J = 1, 3 DO 7 K = 1, 3 O(I,J,K) = O1(J,K) 7 CONTINUE 8 CONTINUE GO TO 20 C C ACCUMULATED COORDINATE ROTATION IS COORDINATE ROTATION OF LAST C ELEMENT C 10 DO 11 J = 1, 3 X0(I,J) = X0(1,J) DO 11 K = 1, 3 O(I,J,K) = O(1,J,K) 11 CONTINUE 15 OCP(I) = .TRUE. C 20 RETURN END SUBROUTINE AGENDA(LOC) C C A MARKER HAS BEEN ENCOUNTERED C RUN THROUGH LIST OF UPDATES, CONSTRAINTS, AND PRINT STATEMENTS C C LIST OF COMMON BLOCKS C INCLUDE 'DATA2A.CIN' INCLUDE 'ELM31A.CIN' INCLUDE 'ELM31B.CIN' C C LOCAL VARIABLES C INTEGER LOC C C----------------------------------------------------------- C TRANSFER FROM MARKER TO LIST C IF (LOC .EQ. 2) GO TO 50 IF (NMARKB .EQ. 0) GO TO 100 NMARK = NUM NUM = NMARKB - 1 NDIFM = NDIF NDIF = 1 MKG = .TRUE. GO TO 100 C C TRANSFER BACK TO MARKER C 50 NUM = NMARK NDIF = NDIFM MKG = .FALSE. C 100 RETURN END SUBROUTINE AGENDR(LOC) C C THE DECK CONTAINS MISALIGNMENTS REFERRED TO SINGLE MAGNETS C CHECK TO SEE IF THE PRESENT MAGNET IS ONE SO REFERENCED C IF IT IS, LOOP THROUGH POSSIBLE MISALIGNMENT SPECIFICATIONS C INCLUDE 'DATA2A.CIN' INCLUDE 'ELM8G.CIN' INCLUDE 'ELM31A.CIN' INCLUDE 'ELM31B.CIN' C IF (LOC .EQ. 2) GO TO 50 IF (NMISRB .EQ. 0) GO TO 100 NMARK = NUM NUM = NMISRB - 1 NDIFM = NDIF NDIF = 1 ALGR = .TRUE. GO TO 100 C C TRANSFER BACK TO MARKER C 50 NUM = NMARK NDIF = NDIFM ALGR = .FALSE. C 100 RETURN END SUBROUTINE AGS C C CALCULATES PARTIALS FOR THE AGS MACHINE CONSTRAINT C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'CONSTS.CIN' INCLUDE 'ELM10A.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM10D.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'RC.CIN' INCLUDE 'RCP.CIN' INCLUDE 'RC2.CIN' INCLUDE 'R2P.CIN' C C LOCAL VARIABLES C INTEGER J, K, L1, N LOGICAL LOGIC REAL RCT, RCTV C-------------------------------------------------------------------- C J = - (JCON + 10) K = KCON C IF (RCP) GO TO 10 RCT = RC2(J,J) + RC2(K,K) GO TO 50 C 10 IF (R2P) GO TO 20 RCT = RC(J,J) + RC(K,K) GO TO 50 C 20 RCT = 0.0 DO 30 L1 = 1, 6 RCT = RCT + RC2(J,L1)*RC(L1,J) + RC2(K,L1)*RC(L1,K) 30 CONTINUE C 50 COC = RCT IF (ABS(COC) .GT. 2.0) GO TO 100 COCO = ACOS(0.5*COC)/(2.0*PI) 60 IF (DE0 - COCO .LT. 0.5) GO TO 70 COCO = COCO + 1.0 GO TO 60 70 IF (DE0 - COCO .GT. -0.5) GO TO 80 COCO = COCO - 1.0 GO TO 70 80 COCO = 2.0*PI*COCO/UNITO(12) C 100 IF (NV3 .LT. 1) GO TO 250 A(1) = 2.0*COS(UNITO(12)*DE0) - COC CALL CLI(LOGIC) IF (LOGIC) GO TO 300 C CW = ( - 1.0/(2.0*UNITO(12)*SIN(UNITO(12)*DE0)*SD))**2 IF (NV1 .LT. 1) GO TO 250 DO 200 N = 1, NV1 RCTV = 0.0 IF (.NOT. (RVP(N) .OR. R2VP(N))) GO TO 200 IF (RCP) GO TO 110 RCTV = R2V(J,J,N) + R2V(K,K,N) GO TO 150 110 IF (R2P) GO TO 120 RCTV = RCV(J,J,N) + RCV(K,K,N) GO TO 150 120 IF (R2VP(N)) GO TO 130 DO 125 L1 = 1, 6 RCTV = RCTV + RC2(J,L1)*RCV(L1,J,N) + RC2(K,L1)*RCV(L1,K,N) 125 CONTINUE GO TO 150 130 IF (RVP(N)) THEN DO 135 L1 = 1, 6 RCTV = RCTV + R2V(J,L1,N)*RC(L1,J) + R2V(K,L1,N)*RC(L1,K) 1 + RC2(J,L1)*RCV(L1,J,N) + RC2(K,L1)*RCV(L1,K,N) 135 CONTINUE ELSE DO 140 L1 = 1, 6 RCTV = RCTV + R2V(J,L1,N)*RC(L1,J) + R2V(K,L1,N)*RC(L1,K) 140 CONTINUE ENDIF 150 A(N+1) = RCTV 200 CONTINUE 250 CALL GATHER C 300 RETURN END SUBROUTINE ALTER(CHANGE) C C SUBROUTINE ALTER USES CHANGE DATA IN CA(*,1) AND MODIFIES THE DATA ARRAY. C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'BROAD.CIN' INCLUDE 'DATA0A.CIN' INCLUDE 'DATA0B.CIN' INCLUDE 'DATA1A.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM10D.CIN' INCLUDE 'ELM13B.CIN' INCLUDE 'ELM39C.CIN' INCLUDE 'FLUSHC.CIN' INCLUDE 'INDPAR.CIN' INCLUDE 'IOUNIT.CIN' INCLUDE 'STEPT1.CIN' C C LOCAL VARIABLES C CHARACTER*10 CHOUT(20) INTEGER VARY REAL CHANGE(NPVAR+1) REAL LIMIT EXTERNAL IDATA C C-------------------------------------------------------- C CHANGE VARIED PARAMETERS TO NEW VALUES C CALL INITL C DO 100 IRU = 1, 2 IHIGH = 0 DO 90 NUM = 1, NEL I = ISTOR(NUM) IF (I .LT. IHIGH) GO TO 90 IHIGH = MAX0(I,IHIGH) TYPE = IDATA(I) IF (TYPE .LE. 0 .OR. TYPE .GE. 50) GO TO 90 CALL SKETCH(NUM) IF (TYPE .EQ. 10) GO TO 90 IF (TYPE .EQ. 39) GO TO 80 NVT = NV(TYPE) IF (NVT .LT. 1) GO TO 90 DO 60 J = 1, NVT IPT = IPTOJ(J) IF (IPT .EQ. 0) GO TO 60 IPLUSJ = I + IPT VARY = TIE(IPLUSJ) IF (VARY .EQ. 0 .OR. VARY .GE. 99) GO TO 60 IVARY = IABS(VARY) IF (IVARY .GT. NV1) GO TO 60 SIG = SIGNF(FLOAT(VARY)) X2 = DATA(IPLUSJ) + SIG*CHANGE(IVARY+1) IF (IRU .EQ. 2) GO TO 50 C C LOWER LIMIT TEST C SI = LIMIT(TYPE,J,2) IF (SI .EQ. 0.0) GO TO 30 SI = LIMIT(TYPE,J,1) IF (X2 .GE. SI) GO TO 30 X2 = AMAX1(X2,SI) GO TO 40 C C UPPER LIMIT TEST C 30 SI = LIMIT(TYPE,J,4) IF (SI .EQ. 0.0) GO TO 60 SI = LIMIT(TYPE,J,3) IF (X2 .LE. SI) GO TO 60 X2 = AMIN1(X2,SI) C 40 CHANGE(IVARY+1) = (X2 - DATA(IPLUSJ))*SIG IF (IVARY .GT. NPVAR + 1 .OR. IVARY .LT. 0) THEN WRITE (NOUT,9008) 9008 FORMAT (' IN ALTER, IVARY = ',I8) FLUSHL = .TRUE. GO TO 200 ENDIF GO TO 60 C 50 DATA(IPLUSJ) = X2 IF (IPLUSJ .GT. IDALIM .OR. IPLUSJ .LE. 0) THEN WRITE (NOUT,9009) 9009 FORMAT (' IN ALTER, IPLUSJ = ',I8) FLUSHL = .TRUE. GO TO 200 ENDIF 60 CONTINUE GO TO 90 C 80 TYPEL = INT(DATA(I+1)) NPARL = INT(DATA(I+2)) IF (IPTOJ(3) .NE. 0) THEN IPT = IPTOJ(3) LTYPE = 1 DPARL = DATA(I+IPT) CALL LIMSET ENDIF IF (IPTOJ(4) .NE. 0) THEN IPT = IPTOJ(4) LTYPE = 2 DPARL = DATA(I+IPT) CALL LIMSET ENDIF IF (IPTOJ(5) .NE. 0) THEN IPT = IPTOJ(5) LTYPE = 1 DPARL = DATA(I+IPT) DPARL = - ABS(DPARL) CALL LIMSET LTYPE = 2 DPARL = ABS(DPARL) CALL LIMSET ENDIF C 90 CONTINUE 100 CONTINUE C C PRINT OUT CHANGES APPLIED C IF (.NOT. ONLY .AND. .NOT. (LSTEP .AND. .NOT. BROAD)) THEN DO 110 J = 1, NV1 CHAN = CHANGE(J+1) ACHAN = ABS(CHAN) IF (ACHAN .GE. 0.001 .AND. ACHAN .LT. 10000.0) THEN WRITE (CHOUT(J),1001) CHAN ELSE WRITE (CHOUT(J),1002) CHAN ENDIF 110 CONTINUE WRITE (NOUT,1000) EPS, CA(1,1), (CHOUT(J), J = 1, NV1) ENDIF C 200 RETURN C 1000 FORMAT (1X,E12.5,1X,'(',E12.5,')',10A10,/(28X,10A10)) 1001 FORMAT (F10.4) 1002 FORMAT (E10.2) END SUBROUTINE ARGUE C C TRANSFER FROM DUMMY ARGUMENT TO ELEMENT OR BEAM SUBLINE C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA1A.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM0F.CIN' INCLUDE 'ELM24A.CIN' INCLUDE 'ELM24B.CIN' INCLUDE 'FLUSHC.CIN' INCLUDE 'IOUNIT.CIN' C C LOCAL VARIABLES C INTEGER IDATA, J, NARG, NUMA EXTERNAL IDATA C C----------------------------------------------------------------- J = JDEF GO TO (100,100,300,300), J C 100 IF (.NOT. ATWORK) GO TO 400 IF (J .EQ. 1 .AND. NDIF .EQ. 1) GO TO 200 IF (J .EQ. 1 .AND. NDIF .EQ. -1) GO TO 250 IF (J .EQ. 2 .AND. NDIF .EQ. 1) GO TO 250 IF (J .EQ. 2 .AND. NDIF .EQ. -1) GO TO 200 C C BEGINNING OF ACTUAL ARGUMENT C STEP THROUGH WITHOUT EXECUTION, WAIT UNTIL CALLED BY DUMMY C 200 NUM = NUM + NDIF I = ISTOR(NUM) TYPE = IDATA(I) IF (TYPE .NE. 32) GO TO 200 NEND = IDATA(I+1) IF (NEND .NE. 2) GO TO 200 NARG = IDATA(I+2) IF (NARG .NE. NADDEF(1)) GO TO 200 GO TO 400 C C END OF ACTUAL ARGUMENT, TRANSFER BACK TO DUMMY C 250 NUM = NUC(NULEV) NDIF = NDIF*NUS(NULEV) NULEV = NULEV - 1 IF (NULEV .LT. 0) THEN WRITE (NOUT,9002) NULEV 9002 FORMAT (' *** ERROR *** ARGUMENT LEVEL = ',I5) FLUSHL = .TRUE. GO TO 400 ENDIF GO TO 400 C C ENCOUNTER DUMMY ARGUMENT, TRANSFER TO ACTUAL ARGUMENT C 300 IF (NUM .EQ. NUSE) ATWORK = .TRUE. IF (.NOT. ATWORK) GO TO 400 NUMA = NUM NUM = NDC(NDLEV-NULEV) NULEV = NULEV + 1 IF (NULEV .GT. 10) THEN WRITE (NOUT,9003) NULEV 9003 FORMAT (' *** ERROR ***, ARGUMENT LEVEL = ',I5) FLUSHL = .TRUE. GO TO 400 ENDIF NUC(NULEV) = NUMA IF (J .EQ. 3) NUS(NULEV) = 1 IF (J .EQ. 4) NUS(NULEV) = -1 NDIF = NDIF*NUS(NULEV) C C STEP THROUGH ARGUMENTS UNTIL CORRECT ONE IS ENCOUNTERED C 310 NUM = NUM + 1 I = ISTOR(NUM) TYPE = IDATA(I) IF (TYPE .NE. 32) GO TO 310 NEND = IDATA(I+1) IF (NDIF .EQ. 1 .AND. NEND .NE. 1) GO TO 310 IF (NDIF .EQ. -1 .AND. NEND .NE. 2) GO TO 310 NARG = IDATA(I+2) IF (NARG .NE. NADDEF(1)) GO TO 310 C 400 CONTINUE RETURN END SUBROUTINE BEAM C C CALCULATE THE BEAM MATRIX EITHER FROM PARAMETERS ON THE C BEAM CARD, OR FROM SI AND RC2 C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'COCOM.CIN' INCLUDE 'COP.CIN' INCLUDE 'ELM1D.CIN' INCLUDE 'ELM7C.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'R2P.CIN' INCLUDE 'R3P.CIN' INCLUDE 'SI.CIN' C C LOCAL VARIABLES C INTEGER J, K, JM1 C C------------------------------------------------------ C CENTROID C DO 1 J = 1, 6 CEN(J) = 0.0 IF (SOFA) CEN(J) = CO(J) 1 CONTINUE C C BEAM MATRIX SAME AS WHEN LAST CALCULATED C IF (NORD3 .LT. 1) GO TO 940 IF (R3P) CALL UPDAT3 IF (R2P) GO TO 200 DO 150 J = 1, 6 DO 150 K = 1, 6 SIT(J,K) = SI(J,K) 150 CONTINUE GO TO 940 C C FIRST-ORDER BEAM MATRIX C 200 CALL BEAM1 C C SECOND-ORDER BEAM MATRIX C IF (NORD3 .GE. 2) CALL BEAM2 C C THIRD-ORDER BEAM MATRIX C IF (NORD3 .GE. 3) CALL BEAM3 C C SYMMETRIZATION OF RESULT C 900 DO 920 J = 2, 6 JM1 = J - 1 DO 920 K = 1, JM1 SIT(K,J) = SIT(J,K) 920 CONTINUE 940 RECENT = .TRUE. RETURN END SUBROUTINE BEAM1 C C FIRST-ORDER CONTRIBUTIONS TO BEAM MATRIX C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'CONSTS.CIN' INCLUDE 'ELM1B.CIN' INCLUDE 'ELM1C.CIN' INCLUDE 'ELM1D.CIN' INCLUDE 'ELM1E.CIN' INCLUDE 'RCP.CIN' INCLUDE 'RC2.CIN' INCLUDE 'RS.CIN' INCLUDE 'SI.CIN' C C LOCAL VARIABLES C INTEGER J, K, L1 REAL ALPHX0, ALPHY0, BETX0, BETY0, EPSX0, EPSY0, SS C C------------------------------------------------------------- C BEAM MATRIX CALCULATED FROM TRANSFER MATRIX C AND PREVIOUS BEAM MATRIX C CALL CAB(RT,RC2,SI) DO 240 J = 1, 6 DO 240 K = 1, J SS = 0.0 DO 235 L1 = 1, 6 SS = SS + RT(J,L1)*RC2(K,L1) 235 CONTINUE SIT(J,K) = SS 240 CONTINUE C C PHASE ADVANCES FOR ACCELERATOR NOTATION C IF (.NOT. DOPH) GO TO 300 EPSX0 = SQRT(SI(1,1)*SI(2,2) - SI(2,1)**2) EPSX = SIT(1,1)*SIT(2,2) - SIT(2,1)**2 IF (EPSX .GE. 0.0) THEN EPSX = SQRT(EPSX) ELSE EPSX = 0.0 ENDIF IF (EPSX0 .EQ. 0.0 .OR. EPSX .EQ. 0.0) THEN DOPH = .FALSE. GO TO 300 ENDIF BETX0 = SI(1,1)/EPSX0 BETAX = SIT(1,1)/EPSX ALPHX0 = - SI(2,1)/EPSX0 ALPHAX = - SIT(2,1)/EPSX SNPX = RC2(1,2)/SQRT(BETX0*BETAX) CSPX = RC2(1,1)*SQRT(BETX0/BETAX) - ALPHX0*SNPX IF (CSPX .EQ. 0.0) THEN IF (SNPX .GT. 0.0) THEN PSIX = 0.5*PI ELSE PSIX = 1.5*PI ENDIF ELSE PSIX = ATAN(SNPX/CSPX) ENDIF IF (RCP) PSIX = PSIX + PSIX1 IF (CSPX .LT. 0.0) PSIX = PSIX + PI 255 IF (PSIX .GE. PSIXO) GO TO 260 PSIX = PSIX + 2.0*PI GO TO 255 C 260 EPSY0 = SQRT(SI(3,3)*SI(4,4) - SI(4,3)**2) EPSY = SIT(3,3)*SIT(4,4) - SIT(4,3)**2 IF (EPSY .GE. 0.0) THEN EPSY = SQRT(EPSY) ELSE EPSY = 0.0 ENDIF IF (EPSY0 .EQ. 0.0 .OR. EPSY .EQ. 0.0) THEN DOPH = .FALSE. GO TO 300 ENDIF BETY0 = SI(3,3)/EPSY0 BETAY = SIT(3,3)/EPSY ALPHY0 = - SI(4,3)/EPSY0 ALPHAY = - SIT(4,3)/EPSY SNPY = RC2(3,4)/SQRT(BETY0*BETAY) CSPY = RC2(3,3)*SQRT(BETY0/BETAY) - ALPHY0*SNPY IF (CSPY .EQ. 0.0) THEN IF (SNPY .GT. 0.0) THEN PSIY = 0.5*PI ELSE PSIY = 1.5*PI ENDIF ELSE PSIY = ATAN(SNPY/CSPY) ENDIF IF (RCP) PSIY = PSIY + PSIY1 IF (CSPY .LT. 0.0) PSIY = PSIY + PI 265 IF (PSIY .GE. PSIYO) GO TO 300 PSIY = PSIY + 2.0*PI GO TO 265 C 300 PSIXO = PSIX PSIYO = PSIY 400 RETURN END SUBROUTINE BEAM2 C C SECOND-ORDER CONTRIBUTIONS TO BEAM MATRIX C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM1D.CIN' INCLUDE 'ELM7C.CIN' INCLUDE 'SI.CIN' INCLUDE 'TC2.CIN' INCLUDE 'TR.CIN' INCLUDE 'TS.CIN' C C LOCAL VARIABLES C C C-------------------------------------------------------------------- C CENTROID ADJUSTMENT DUE TO SECOND-ORDER TERMS ACTING ON C BEAM WIDTH C DO 20 J = 1, 5 SS = 0.0 IND = 0 DO 10 L2 = 1, 6 DO 10 L1 = 1, L2 IND = IND + 1 SS = SS + TC2(J,IND)*SI(L1,L2) 10 CONTINUE CEN(J) = CEN(J) + SS 20 CONTINUE C C SECOND-ORDER CONTRIBUTION TO BEAM SIZE C DO 40 J = 1, 5 DO 40 L1 = 1, 6 INDA = 0 DO 40 K = 1, 6 SS = 0.0 DO 30 L2 = 1, K INDA = INDA + 1 SS = SS + TC2(J,INDA)*SI(L1,L2) 30 CONTINUE TR(J,L1,K) = SS 40 CONTINUE C DO 60 J = 1, 5 INDA = 0 DO 60 L1 = 1, 6 DO 60 K = 1, L1 INDA = INDA + 1 SS = 0.0 DO 50 L2 = 1, 6 SS = SS + TR(J,K,L2)*SI(L1,L2) 50 CONTINUE TS(J,INDA) = SS 60 CONTINUE C DO 80 J = 1, 5 DO 80 K = 1, J TSST = 0.0 DO 70 L1 = 1, 6 DO 70 L2 = 1, 6 TSST = TSST + TR(J,L1,L2)*TR(K,L2,L1) 70 CONTINUE SIT(J,K) = SIT(J,K) + TSST 80 CONTINUE C DO 100 J = 1, 5 DO 100 K = 1, J TSST = 0.0 DO 90 IND = 1, 21 TSST = TSST + TS(J,IND)*TC2(K,IND) 90 CONTINUE SIT(J,K) = SIT(J,K) + TSST 100 CONTINUE C RETURN END SUBROUTINE BEAM3 C C THIRD-ORDER CONTRIBUTIONS TO BEAM MATRIX C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM1D.CIN' INCLUDE 'RC2.CIN' INCLUDE 'RS.CIN' INCLUDE 'SI.CIN' INCLUDE 'UC2.CIN' INCLUDE 'US.CIN' C C LOCAL VARIABLES C REAL UST(5,6,21), USS(5,36,6), USSS(5,216), USSC(5,6) C C-------------------------------------------------------------- C THIRD-ORDER CONTRIBUTIONS C PRODUCT OF RC2 AND SI C DO 20 J = 1, 6 DO 20 K = 1, 6 SS = 0.0 DO 10 L1 = 1, 6 SS = SS + RC2(J,L1)*SI(L1,K) 10 CONTINUE RS(J,K) = SS 20 CONTINUE C C PRODUCT OF UC2 AND SI DOUBLY CONTRACTED C DO 40 J = 1, 5 I234 = 0 DO 40 I4 = 1, 6 SS = 0.0 DO 30 I3 = 1, I4 DO 30 I2 = 1, I3 I234 = I234 + 1 SS = SS + UC2(J,I234)*SI(I2,I3) 30 CONTINUE US(J,I4) = SS 40 CONTINUE C DO 60 J = 1, 5 I234 = 0 DO 60 I4 = 1, 6 DO 60 I3 = 1, I4 DO 60 I2 = 1, I3 I234 = I234 + 1 US(J,I3) = US(J,I3) + UC2(J,I234)*SI(I2,I4) 60 CONTINUE C DO 80 J = 1, 5 I234 = 0 DO 80 I4 = 1, 6 DO 80 I3 = 1, I4 DO 80 I2 = 1, I3 I234 = I234 + 1 US(J,I2) = US(J,I2) + UC2(J,I234)*SI(I3,I4) 80 CONTINUE C C MULTIPLY U X SI TO GET MATRIX PRODUCT US C DO 120 I1 = 1, 5 DO 105 I2 = 1, 6 DO 105 I34 = 1, 21 UST(I1,I2,I34) = 0.0 105 CONTINUE C I234 = 0 I34 = 0 DO 120 I4 = 1, 6 DO 120 I3 = 1, I4 I34 = I34 + 1 DO 120 I2 = 1, I3 I234 = I234 + 1 C UFAC = UC2(I1,I234) IF (UFAC .NE. 0.0) THEN DO 110 I5 = 1, 6 UST(I1,I5,I34) = UST(I1,I5,I34) + UFAC*SI(I2,I5) 110 CONTINUE ENDIF 120 CONTINUE C C MULTIPLY US X SI TO GET DOUBLE MATRIX PRODUCT USS C DO 150 I1 = 1, 5 DO 130 I23 = 1, 36 DO 130 I4 = 1, 6 USS(I1,I23,I4) = 0.0 130 CONTINUE C I34 = 0 DO 140 I4 = 1, 6 DO 140 I3 = 1, I4 I34 = I34 + 1 DO 140 I2 = 1, 6 C UFAC = UST(I1,I2,I34) IF (UFAC .NE. 0.0) THEN DO 135 I6 = 1, 6 I26 = I2 + 6*I6 - 6 USS(I1,I26,I4) = USS(I1,I26,I4) + UFAC*SI(I3,I6) 135 CONTINUE ENDIF 140 CONTINUE 150 CONTINUE C C MULTIPLY USS X SI TO GET USSS C DO 190 I1 = 1, 5 DO 170 I234 = 1, 216 USSS(I1,I234) = 0.0 170 CONTINUE C DO 190 I4 = 1, 6 I23 = 0 DO 190 I3 = 1, 6 DO 190 I2 = 1, 6 I23 = I23 + 1 C UFAC = USS(I1,I23,I4) IF (UFAC .NE. 0.0) THEN DO 180 I7 = 1, 6 I237 = I2 + 6*I3 + 36*I7 - 42 USSS(I1,I237) = USSS(I1,I237) + UFAC*SI(I4,I7) 180 CONTINUE ENDIF 190 CONTINUE C C CROSS PRODUCT BETWEEN FIRST AND THIRD ORDER C DO 220 J = 1, 6 DO 220 K = 1, J RSSU = 0.0 USSR = 0.0 C IF (K .LT. 5) THEN DO 200 L1 = 1, 6 RSSU = RSSU + RS(J,L1)*US(K,L1) 200 CONTINUE ENDIF C IF (J .LT. 5) THEN DO 210 L1 = 1, 6 USSR = USSR + US(J,L1)*RS(K,L1) 210 CONTINUE ENDIF C SIT(J,K) = SIT(J,K) + RSSU + USSR 220 CONTINUE C C MATRIX PRODUCT OF US AND SI C DO 240 J = 1, 5 DO 240 K = 1, 6 SS = 0.0 DO 230 L1 = 1, 6 SS = SS + US(J,L1)*SI(L1,K) 230 CONTINUE USSC(J,K) = SS 240 CONTINUE C C MATRIX PRODUCT OF US TIMES SI AND US C DO 260 J = 1, 4 DO 260 K = 1, J SS = 0.0 DO 250 L1 = 1, 6 SS = SS + USSC(J,L1)*US(K,L1) 250 CONTINUE SIT(J,K) = SIT(J,K) + SS 260 CONTINUE C C PRODUCT OF USSS AND UC2 C DO 300 J = 1, 4 DO 300 K = 1, J I234 = 0 SS = 0.0 DO 280 I4 = 1, 6 DO 280 I3 = 1, I4 DO 280 I2 = 1, I3 I234 = I234 + 1 IND = I2 + 6*I3 + 36*I4 - 42 SUM = USSS(J,IND) IND = I2 + 6*I4 + 36*I3 - 42 SUM = SUM + USSS(J,IND) IND = I3 + 6*I2 + 36*I4 - 42 SUM = SUM + USSS(J,IND) IND = I3 + 6*I4 + 36*I2 - 42 SUM = SUM + USSS(J,IND) IND = I4 + 6*I2 + 36*I3 - 42 SUM = SUM + USSS(J,IND) IND = I4 + 6*I3 + 36*I2 - 42 SUM = SUM + USSS(J,IND) SS = SS + SUM*UC2(K,I234) 280 CONTINUE SIT(J,K) = SIT(J,K) + SS 300 CONTINUE C RETURN END SUBROUTINE BEAMIN C C CALCULATES THE INITIAL BEAM ENVELOPE FROM THE DATA C C ---------------------------------------------------------------------- INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'BETAC.CIN' INCLUDE 'COCOM.CIN' INCLUDE 'DATA0A.CIN' INCLUDE 'DATA1A.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0C.CIN' INCLUDE 'ELM1A.CIN' INCLUDE 'ELM1B.CIN' INCLUDE 'ELM1C.CIN' INCLUDE 'ELM1D.CIN' INCLUDE 'ELM13B.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'ELM15C.CIN' INCLUDE 'ELM16B.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'ETACOM.CIN' INCLUDE 'ETAP.CIN' INCLUDE 'FLUSHC.CIN' INCLUDE 'INDPAR.CIN' INCLUDE 'IOUNIT.CIN' INCLUDE 'R2P.CIN' INCLUDE 'R3P.CIN' INCLUDE 'SI.CIN' C C LOCAL VARIABLES C INTEGER IAX, IAY, IBX, IBY, IDATA, IEX, IEY INTEGER IPLNO, IPLUSJ, IRI INTEGER J, JPL1, K REAL DATAR, E, RINEW, SIJJ C------------------------------------------------------------------------------ C IPLNO = IPTOJ(8) RMSADD = IPLNO .NE. 0 IF (RMSADD) GO TO 160 NEXT = IDATA(ISTOR(NUM+1)) IRI = IPTOJ(7) RI = DATAR(I+IRI)*UNITI(11) IF (.NOT. LPRF) PREF = RI IF (SM .EQ. 0.0) THEN BETA = 1.0 GAMMA = 2.0E5 ELSE E = SQRT(RI**2 + SM**2) BETA = RI/E GAMMA = E/SM ENDIF LTWISS = IPTOJ(10) .NE. 0 .AND. IPTOJ(13) .NE. 0 C DO 105 J = 1, 6 CO(J) = 0.0 105 CONTINUE C IF (R2P .OR. R3P) CALL UPDAT2 IF (NORD3 .LT. 1) GO TO 150 IF (ACCEL .OR. LTWISS) GO TO 130 NOPH = .TRUE. C DO 110 J = 1, 6 IPLUSJ = I + J SIJJ = (DATAR(IPLUSJ)*UBEAM(J))**2 IF (SIJJ .GT. 0.0) NOPH = .FALSE. SI(J,J) = SIJJ 110 CONTINUE C DO 120 J = 1, 5 JPL1 = J + 1 DO 120 K = JPL1, 6 SI(J,K) = 0.0 SI(K,J) = 0.0 120 CONTINUE GO TO 140 C 130 DO 131 J = 1, 6 DO 131 K = 1, 6 SI(J,K) = 0.0 131 CONTINUE C IF (ACCEL .AND. .NOT. LTWISS) THEN BETAX = DATAR(I+1)*UBEAM(1)/UBEAM(2) ALPHAX = DATAR(I+2) EPSX = 1.0 BETAY = DATAR(I+3)*UBEAM(3)/UBEAM(4) ALPHAY = DATAR(I+4) EPSY = 1.0 ELSE IBX = IPTOJ(10) BETAX = DATAR(I+IBX)*UBEAM(1)/UBEAM(2) IAX = IPTOJ(11) ALPHAX = DATAR(I+IAX) IEX = IPTOJ(12) IF (IEX .NE. 0.0) THEN EPSX = DATAR(I+IEX)*UBEAM(1)*UBEAM(2) ELSE EPSX = 1.0 ENDIF IBY = IPTOJ(13) BETAY = DATAR(I+IBY)*UBEAM(3)/UBEAM(4) IAY = IPTOJ(14) ALPHAY = DATAR(I+IAY) IEY = IPTOJ(15) IF (IEY .NE. 0) THEN EPSY = DATAR(I+IEY)*UBEAM(3)*UBEAM(4) ELSE EPSY = 1.0 ENDIF ENDIF C SI(1,1) = EPSX*BETAX SI(1,2) = - EPSX*ALPHAX SI(2,1) = SI(1,2) SI(2,2) = EPSX*(1.0 + ALPHAX**2)/BETAX SI(3,3) = EPSY*BETAY SI(3,4) = - EPSY*ALPHAY SI(4,3) = SI(3,4) SI(4,4) = EPSY*(1.0 + ALPHAY**2)/BETAY C 140 IF (RAY) GO TO 150 DO 145 J = 1, 5 145 ETA(J) = 0.0 ETA(6) = UBEAM(6) RAY = .TRUE. C 150 CALL INIT1 GO TO 170 C 160 IF (R2P .OR. R3P) CALL UPDAT2 IF (ACCEL .OR. LTWISS) GO TO 180 IF (NORD3 .GT. 1) GO TO 190 RINEW = RI + DATA(I+7)*UNITI(11) PREF = PREF*RINEW/RI RI = RINEW C IF (NORD3 .LT. 1) GO TO 200 DO 165 J = 1, 6 IPLUSJ = I + J SI(J,J) = SI(J,J) + (DATA(IPLUSJ)*UBEAM(J))**2 IF (SI(J,J) .GT. 0.0) NOPH = .FALSE. 165 CONTINUE RECENT = .FALSE. C 170 EPSX = SQRT(SI(1,1)*SI(2,2) - SI(1,2)**2) EPSY = SQRT(SI(3,3)*SI(4,4) - SI(3,4)**2) GO TO 200 C 180 WRITE (NOUT,9001) 9001 FORMAT (' *** ERROR *** RMS ADDITION NOT PERMITTED WITH', 1 ' ACCELERATOR NOTATION') FLUSHL = .TRUE. GO TO 200 C 190 WRITE (NOUT,9015) 9015 FORMAT (' *** ERROR *** RMS ADDITION NOT PERMITTED WITH', 1 ' HIGHER-ORDER MATRIX DISPLAY') FLUSHL = .TRUE. C 200 RETURN END SUBROUTINE BEND C C CALCULATES FIRST-ORDER TRANSFER MATRIX FOR A BENDING MAGNET C INCLUDE 'BETAC.CIN' INCLUDE 'ELM0B.CIN' INCLUDE 'ELM1A.CIN' INCLUDE 'ELM4A.CIN' INCLUDE 'ELM4B.CIN' INCLUDE 'ELM4D.CIN' INCLUDE 'ELM5A.CIN' INCLUDE 'ELM5B.CIN' INCLUDE 'ELM7B.CIN' INCLUDE 'ELM10E.CIN' INCLUDE 'ELM13B.CIN' INCLUDE 'ELM16B.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'FLUSHC.CIN' INCLUDE 'IOUNIT.CIN' INCLUDE 'R.CIN' INCLUDE 'TERMS.CIN' INCLUDE 'WMN.CIN' C C LOCAL VARIABLES C REAL CXY, CYX, SKX, SKY, WM2N C C--------------------------------------------------------------- C FIRST-ORDER TRANSFER MATRIX C JQUAD = 1 RH = 1.0 + RMPS H = RH*H0 WMN = (1.0 - NB) + RMPS*(2.0 - NB) IF (WMN .EQ. 0.0) THEN WRITE (NOUT,9101) 9101 FORMAT (' N = 1.0 DOES NOT WORK WITH EXISTING EXPRESSIONS ', 1 'FOR MATRIX ELEMENTS, TRY RESETTING TO 1.0001') FLUSHL = .TRUE. GO TO 500 ENDIF KQ2 = H0**2*WMN KX2 = KQ2 CALL FOCUS CX = R(1,1) SX = R(1,2) SKX = - R(2,1) JQUAD = 3 KQ2 = H0**2*RH*NB KY2 = KQ2 CALL FOCUS CY = R(3,3) SY = R(3,4) SKY = - R(4,3) IF (CX .GT. 0.5) DISN = SX**2/(1.0 + CX) IF (CX .LE. 0.5) DISN = (1.0 - CX)/(WMN*H0**2) DISP = H*DISN R(1,6) = DISP R(5,2) = - H0*DISN DDISP = H*SX R(2,6) = DDISP R(5,1) = - H0*SX R56 = - RH*(L - SX)/WMN IF (SM .NE. 0.0 .AND. RI .NE. 0.0) R56 = R56 + L/GAMMA**2 R(5,6) = R56 C C TERMS USED FOR HIGHER ORDER OR OFF-AXIS EXPANSION OR C NON-MIDPLANE SYMMETRIC FIELD COMPONENTS C IF (CY .GT. 0.5) DSVN = SY**2/(1.0 + CY) IF (CY .LE. 0.5) DSVN = (1.0 - CY)/(NB*H*H0) XPND = ABS(SQRT(ABS(WMN))*H0*L) .LT. 0.01 IF (XPND) THEN SMLCX = 1.0/3.0*WMN*H0**2*L**3 - 1.0/30.0*WMN**2*H0**4*L**5 ELSE SMLCX = SX - L*CX ENDIF C C OFF-AXIS EXPANSION OR NON-MIDPLANE-SYMMETRIC FIELD COMPONENTS C IF (RMPS .EQ. 0.0 .AND. (RNMS .EQ. 0.0 .OR. 1 (VRN .EQ. 0.0 .AND. NPN .EQ. 0.0 .AND. BDBP .EQ. 0.0))) 2 GO TO 500 IF (RMPS .NE. 0.0 .OR. (RNMS .NE. 0.0 .AND. VRN .NE. 0.0)) THEN DCOV = .TRUE. IF (BAX) R1P = .TRUE. ENDIF HEX = H0*RMPS VR = RNMS*VRN NPR = NPN*RNMS COD(1) = - RMPS*H0*DISN COD(2) = - RMPS*H0*SX COD(3) = VR*H0*DSVN COD(4) = VR*H0*SY COD(5) = 0.0 COD(6) = 0.0 IF (NORD1 .LT. 1) GO TO 500 CXY = (VR - NPR) CYX = RH*(NPR - 2.0*VR) WM2N = 1.0 - 2.0*NB + RMPS*(2.0 - 2.0*NB) IF (WM2N .EQ. 0.0) THEN WRITE (NOUT,9100) 9100 FORMAT (' N = 0.5 DOES NOT WORK WITH VIOLATION OF MIDPLANE', 1 ' SYMMETRY, TRY RESETTING TO .5001') FLUSHL = .TRUE. GO TO 500 ENDIF R(1,3) = CXY*(CY - CX)/WM2N R(1,4) = CXY*(SY - SX)/WM2N R(2,3) = CXY*(SKX - SKY)/WM2N R(2,4) = CXY*(CY - CX)/WM2N R(3,1) = CYX*(CX - CY)/WM2N R(3,2) = CYX*(SX - SY)/WM2N R(4,1) = CYX*(SKY - SKX)/WM2N R(4,2) = CYX*(CX - CY)/WM2N R(3,6) = - VR*H0*DSVN 1 + H0*CYX*(DISN - DSVN)/WM2N R(4,6) = - VR*H0*SY 1 + H0*CYX*(SX - SY)/WM2N R(5,3) = H0*CXY*(SX - SY)/WM2N R(5,4) = H0*CXY*(DISN - DSVN)/WM2N C 500 RETURN END SUBROUTINE BFGET C C GET PARAMETERS DESCRIBING THE FRINGE FIELD OF A BENDING MAGNET C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM2A.CIN' INCLUDE 'ELM2B.CIN' INCLUDE 'ELM4A.CIN' INCLUDE 'ELM13B.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'ELM16A.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'ELM26A.CIN' INCLUDE 'ELM26B.CIN' INCLUDE 'INDBND.CIN' INCLUDE 'INDPAR.CIN' INCLUDE 'NXRAN.CIN' INCLUDE 'XRAN.CIN' INCLUDE 'XRAN4.CIN' C C LOCAL VARIABLES C INTEGER IADR, IAPB, ILAYL, IRAB, J, NXR REAL DATAR EXTERNAL DATAR C C------------------------------------------------------------------ C POLE-FACE ROTATION ANGLE C NHGAP = 2 NFINT = 3 IADR = I + 1 BE = DATAR(IADR) IF (PRAN2(1) .NE. 0.0) BE = BE + PRAN2(1)*XRAN(1) BE = BE*UNITI(7) C C RANDOM ERRORS AND AUTOMATIC SETTING OF POLE-FACE ROTATION ANGLE C IF (NORD1 .LT. 1) GO TO 240 IF (BEFORE) THEN IF (RANZC) THEN NXR = NXRAN(2) DO 231 J = 1, NXR 231 XRAN(J) = XRAN2I(J) ENDIF IF (NPFR .EQ. 1) BE = 0.5*AL IF (NPFR .EQ. 2) BE = 0.0 IF (NPFR .EQ. 3) BE = AL ELSE IF (NPFR .EQ. 1) BE = 0.5*AL IF (NPFR .EQ. 2) BE = AL IF (NPFR .EQ. 3) BE = 0.0 ENDIF C C HORIZONTAL AND VERTICAL GAP C APB(1) = APBI(1) IAPB = IPTOJ(2) IF (IAPB .EQ. 0) THEN APB(2) = APBI(2) ELSE IADR = I + IAPB APB(2) = DATAR(IADR) ENDIF IF (PRAN2(2) .NE. 0.0) 1 APB(2) = APB(2) + PRAN2(2)*XRAN(2) APB(2) = APB(2)*UNITI(3) C C FRINGE FIELD INTEGRALS C LAYK = LAYKI C ILAYL = IPTOJ(3) IF (ILAYL .EQ. 0) LAYL = LAYLI IF (ILAYL .NE. 0) THEN IADR = I + ILAYL LAYL = DATAR(IADR) ENDIF IF (PRAN2(3) .NE. 0.0) 1 LAYL = LAYL + PRAN2(3)*XRAN(3) C LAYX = LAYXI C C POLE FACE SURFACE CURVATURE C IRAB = IPTOJ(4) IF (IRAB .NE. 0) THEN IADR = I + IRAB RABT = DATAR(IADR) ELSE IF (BEFORE) THEN RABT = RAB1I ELSE RABT = RAB2I ENDIF ENDIF IF (PRAN2(4) .NE. 0.0) 1 RABT = RABT + PRAN2(4)*XRAN(4) RABT = RABT/UNITI(8) 240 RETURN END SUBROUTINE BGET(II) C C GET PARAMETERS DESCRIBING THE LENGTH AND CENTRAL FIELD OF C A BENDING MAGNET C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM1A.CIN' INCLUDE 'ELM4A.CIN' INCLUDE 'ELM4C.CIN' INCLUDE 'ELM13B.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'ELM16A.CIN' INCLUDE 'ELM16B.CIN' INCLUDE 'ELM26B.CIN' INCLUDE 'INDBND.CIN' INCLUDE 'INDPAR.CIN' INCLUDE 'XRAN.CIN' C C LOCAL VARIABLES C INTEGER IL, IB, IRHO, IANG, IADR, II, IN, IK1, IRMPS REAL DATAR, RHO EXTERNAL DATAR C C--------------------------------------------------------------- C STORAGE POSITION OF PARAMETERS C NL = 1 NBV = 2 NRHO = 3 NANG = 4 NN = 5 NK1 = 6 NRMPS = 7 NRNMS = 8 NVR = 9 NNP = 10 NK1P = 11 NBDB = 12 NK2 = 13 NBDBP = 14 NK2P = 15 NGAM = 16 NK3 = 17 NTILT = 18 IF (IPTOJ(NL) .EQ. 1 .AND. IPTOJ(NBV) .EQ. 2 .AND. ANIN) THEN IPTOJ(NBV) = 0 IPTOJ(NANG) = 2 ENDIF IL = IPTOJ(NL) IB = IPTOJ(NBV) IRHO = IPTOJ(NRHO) IANG = IPTOJ(NANG) C C MAGNET LENGTH GIVEN C IF (IL .EQ. 0) GO TO 50 IADR = II + IL LBEND = DATAR(IADR) IF (PRAN4(1) .NE. 0.0) LBEND = LBEND + PRAN4(1)*XRAN(1) LBEND = LBEND*UNITI(8) C C LENGTH AND MAGNETIC FIELD GIVEN C IF (IB .EQ. 0) GO TO 10 IADR = II + IB B = DATAR(IADR) IF (PRAN4(2) .NE. 0.0) B = B + PRAN4(2)*XRAN(2) B = B*UNITI(9)*RI/PREF H0 = B/RI AL = H0*LBEND RHO = 0.0 IF (H0 .NE. 0.0) RHO = 1.0/H0 GO TO 100 C C LENGTH AND BENDING RADIUS GIVEN C 10 IF (IRHO .EQ. 0) GO TO 20 IADR = II + IRHO RHO = DATAR(IADR) IF (PRAN4(3) .NE. 0.0) RHO = RHO + PRAN4(3)*XRAN(3) RHO = RHO*UNITI(8) H0 = 1.0/RHO AL = H0*LBEND IF (RI .NE. 0.0) B = H0*RI GO TO 100 C C LENGTH AND BENDING ANGLE GIVEN C 20 IADR = II + IANG AL = DATAR(IADR) IF (PRAN4(4) .NE. 0.0) AL = AL + PRAN4(4)*XRAN(4) AL = AL*UNITI(7) H0 = AL/LBEND B = RI*H0 GO TO 100 C C FIELD AND BENDING ANGLE GIVEN C 50 IF (IB .EQ. 0) GO TO 70 IADR = II + IB B = DATAR(IADR) IF (PRAN4(2) .NE. 0.0) B = B + PRAN4(2)*XRAN(2) B = B*UNITI(9)*RI/PREF IADR = II + IANG AL = DATAR(IADR) IF (PRAN4(4) .NE. 0.0) AL = AL + PRAN4(4)*XRAN(4) AL = AL*UNITI(7) H0 = B/RI IF (H0 .NE. 0.0) THEN RHO = 1.0/H0 LBEND = RHO*AL ENDIF GO TO 100 C C BENDING RADIUS AND ANGLE GIVEN C 70 IADR = II + IRHO RHO = DATAR(IADR) IF (PRAN4(3) .NE. 0.0) RHO = RHO + PRAN4(3)*XRAN(3) RHO = RHO*UNITI(8) IADR = II + IANG AL = DATAR(IADR) IF (PRAN4(4) .NE. 0.0) AL = AL + PRAN4(4)*XRAN(4) AL = AL*UNITI(7) LBEND = RHO*AL IF (RI .NE. 0.0) B = RI/RHO H0 = 1.0/RHO C C SPECIFICATION OF NORMALIZED FIELD GRADIENT C 100 IN = IPTOJ(NN) IK1 = IPTOJ(NK1) IF (IK1 .EQ. 0 .AND. PRAN4(6) .EQ. 0.0) THEN IF (IN .EQ. 0) THEN NB = 0.0 ELSE IADR = II + IN NB = DATAR(IADR) ENDIF IF (PRAN4(5) .NE. 0.0) NB = NB + PRAN4(5)*XRAN(5) ELSE IF (IK1 .EQ. 0) THEN K1 = 0.0 ELSE IADR = II + IK1 K1 = DATAR(IADR) ENDIF IF (PRAN4(6) .NE. 0.0) K1 = K1 + PRAN4(6)*XRAN(6) K1 = K1/UNITI(8)**2 IF (H0 .NE. 0.0) NB = - K1/H0**2 ENDIF C C FRACTIONAL MISTUNING FOR HORIZONTAL STEERING C IRMPS = IPTOJ(NRMPS) IF (IRMPS .NE. 0) THEN IADR = II + IRMPS RMPS = DATAR(IADR) ELSE RMPS = RMPSI ENDIF IF (PRAN4(NRMPS) .NE. 0.0) 1 RMPS = RMPS + PRAN4(NRMPS)*XRAN(NRMPS) RETURN END SUBROUTINE BPRINT INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'CCENT.CIN' INCLUDE 'CONSTS.CIN' INCLUDE 'ELM0B.CIN' INCLUDE 'ELM4A.CIN' INCLUDE 'ELM5A.CIN' INCLUDE 'ELM13A.CIN' INCLUDE 'ELM13B.CIN' INCLUDE 'ELM15B.CIN' INCLUDE 'ELM15C.CIN' INCLUDE 'ELM20.CIN' INCLUDE 'IOUNIT.CIN' INCLUDE 'OC.CIN' INCLUDE 'XYZOLD.CIN' C DIMENSION OBEG(3,3), OCEN(3,3), OEND(3,3), OFOO(3,3), 1 OROT(3,3), OTEMP(3,3) DIMENSION XBEG(3), XEND(3) C IF (ONLY) GO TO 100 C C TRANSFORMATION AT END OF ELEMENT C DO 28 J = 1, 3 DO 28 K = 1, 3 OBEG(J,K) = OOLD(J,K) 28 CONTINUE XBEG(1) = XOLD XBEG(2) = YOLD XBEG(3) = ZOLD C DO 30 J = 1, 3 DO 30 K = 1, 3 OEND(J,K) = O(4,J,K) 30 CONTINUE XEND(1) = X0(4,1) XEND(2) = X0(4,2) XEND(3) = X0(4,3) C C LOOK FOR TILT OR REFER C IF (REFER .AND. TOTRC .NE. 0.0) THEN TOTR = TOTRC IF (.NOT. REFER) TOTR = TOTR - TOTROT COST = COS(TOTR) SINT = SIN(TOTR) OROT(1,1) = COST OROT(1,2) = SINT OROT(1,3) = 0.0 OROT(2,1) = - SINT OROT(2,2) = COST OROT(2,3) = 0.0 OROT(3,1) = 0.0 OROT(3,2) = 0.0 OROT(3,3) = 1.0 ENDIF C AL2 = 0.5*AL CS2 = COS(AL2) SN2 = SIN(AL2) OFOO(1,1) = CS2 OFOO(1,2) = 0.0 OFOO(1,3) = SN2 OFOO(2,1) = 0.0 OFOO(2,2) = 1.0 OFOO(2,3) = 0.0 OFOO(3,1) = - SN2 OFOO(3,2) = 0.0 OFOO(3,3) = CS2 C C TRANSFORMATION OF ORIENTATION OF CENTER OF MAGNET C IF (REFER .AND. TOTRC .NE. 0.0) THEN DO 55 J = 1, 3 DO 55 K = 1, 3 BLOB = 0.0 DO 54 M = 1, 3 BLOB = BLOB + OFOO(J,M)*OROT(M,K) 54 CONTINUE OTEMP(J,K) = BLOB 55 CONTINUE C DO 60 J = 1, 3 DO 60 K = 1, 3 BLOB = 0.0 DO 59 M = 1, 3 BLOB = BLOB + OROT(M,J)*OTEMP(M,K) 59 CONTINUE OFOO(J,K) = BLOB 60 CONTINUE ENDIF C DO 80 J = 1, 3 DO 80 K = 1, 3 BLOB = 0.0 DO 78 M = 1, 3 BLOB = BLOB + OFOO(M,J)*OEND(M,K) 78 CONTINUE OTEMP(J,K) = BLOB 80 CONTINUE C DO 85 J = 1, 3 DO 85 K = 1, 3 OCEN(J,K) = OTEMP(J,K) 85 CONTINUE C C CALCULATE COORDINATES AT CENTER OF MAGNET C SUMC = 0.0 SUMO = 0.0 DO 95 J = 1, 3 CDIF = XEND(J) - XBEG(J) OSUM = OEND(3,J) + OBEG(J,3) SUMC = SUMC + CDIF*OSUM SUMO = SUMO + OSUM**2 95 CONTINUE SEFF = SUMC/SUMO XCEN = XBEG(1) + OBEG(3,1)*SEFF YCEN = XBEG(2) + OBEG(3,2)*SEFF ZCEN = XBEG(3) + OBEG(3,3)*SEFF C C PRINT COORDINATES AT CENTER OF MAGNET C ALONG = (LC - 0.5*LMAG)/UFLOOR(1) XCENT = XCEN/UFLOOR(1) YCENT = YCEN/UFLOOR(1) ZCENT = ZCEN/UFLOOR(1) C CSY = OCEN(3,3) SNY = OCEN(3,1) IF (CSY .EQ. 0.0) THEN IF (SNY .GT. 0.0) YAW = 0.5*PI IF (SNY .LT. 0.0) YAW = - 0.5*PI ELSE YAW = ATAN(SNY/CSY) IF (CSY .LT. 0.0) THEN SHIFT = SIGN(PI,SNY) YAW = YAW + SHIFT ENDIF YAW = YAW/UFLOOR(2) ENDIF C PITCH = ASIN(OCEN(3,2))/UFLOOR(2) C IF (OCEN(2,2) .NE. 0.0) ROLL = ATAN(OCEN(1,2)/OCEN(2,2)) IF (OCEN(2,2) .EQ. 0.0 .AND. OCEN(1,2) .GT. 0.0) ROLL = 0.5*PI IF (OCEN(2,2) .EQ. 0.0 .AND. OCEN(1,2) .LT. 0.0) ROLL = - 0.5*PI IF (OCEN(2,2) .LT. 0.0) THEN SHIFT = SIGN(PI,OCEN(1,2)) ROLL = ROLL + SHIFT ENDIF ROLL = ROLL/UFLOOR(2) C IF (UFLOOR(2) .LE. 0.1) THEN WRITE (NOUT,1000) ALONG, XFLOOR(1), XCENT, YCENT, ZCENT, 1 XFLOOR(1), YAW, PITCH, ROLL, XFLOOR(2) ELSE WRITE (NOUT,1001) ALONG, XFLOOR(1), XCENT, YCENT, ZCENT, 1 XFLOOR(1), YAW, PITCH, ROLL, XFLOOR(2) ENDIF C 1000 FORMAT (1H ,8X,F10.3,1X,A4,9X,3F11.4,1X,A4,1X,3F10.3,1X,A4) 1001 FORMAT (1H ,5X,F15.6,1X,A4,8X,3F13.5,1X,A4,1X,3F12.6,1X,A4) 100 RETURN END SUBROUTINE BVGET C C GET PARAMETERS DESCRIBING HIGHER ORDER AND C NON-MIDPLANE-SYMMETRIC FIELD COMPONENTS OF A BENDING MAGNET FIELD C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM4A.CIN' INCLUDE 'ELM4C.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'ELM16A.CIN' INCLUDE 'ELM26B.CIN' INCLUDE 'INDBND.CIN' INCLUDE 'INDPAR.CIN' INCLUDE 'NXRAN.CIN' INCLUDE 'XRAN.CIN' INCLUDE 'XRAN4.CIN' C C LOCAL VARIABLES C INTEGER IADR, IBDB, IBDBP, IGAM, IK1P, IK2, IK2P, IK3 INTEGER INP, IRNMS, IVR, J, NXR REAL DATAR EXTERNAL DATAR C C------------------------------------------------------------------- C RANDOM NUMBERS FOR ERRORS C NXR = NXRAN(4) DO 10 J = 1, NXR 10 XRAN(J) = XRAN4(J) C C SCALING FACTOR FOR NON-MIDPLANE-SYMMETRIC FIELD COMPONENTS C IRNMS = IPTOJ(NRNMS) IF (IRNMS .NE. 0) THEN IADR = I + IRNMS RNMS = DATAR(IADR) ELSE RNMS = RNMSI ENDIF IF (PRAN4(NRNMS) .NE. 0.0) 1 RNMS = RNMS + PRAN4(NRNMS)*XRAN(NRNMS) C C NON-MIDPLANE-SYMMETRIC NORMALIZED BENDING FIELD C IVR = IPTOJ(NVR) IF (IVR .NE. 0) THEN IADR = I + IVR VRN = DATAR(IADR) ELSE VRN = VRNI ENDIF IF (PRAN4(NVR) .NE. 0.0) 1 VRN = VRN + PRAN4(NVR)*XRAN(NVR) C C NON-MIDPLANE-SYMMETRIC NORMALIZED FIELD GRADIENT C INP = IPTOJ(NNP) IK1P = IPTOJ(NK1P) IF (IK1P .EQ. 0 .AND. PRAN4(NK1P) .EQ. 0.0) THEN IF (INP .EQ. 0) THEN NPN = NPNI ELSE IADR = I + INP NPN = DATAR(IADR) ENDIF IF (PRAN4(NNP) .NE. 0.0) NPN = NPN + PRAN4(NNP)*XRAN(NNP) ELSE IF (IK1P .EQ. 0) THEN K1P = 0.0 ELSE IADR = I + IK1P K1P = DATAR(IADR) ENDIF IF (PRAN4(NK1P) .NE. 0.0) K1P = K1P + PRAN4(NK1P)*XRAN(NK1P) K1P = K1P/UNITI(8)**2 IF (H0 .NE. 0.0) NPN = - K1P/H0**2 ENDIF C C MIDPLANE SYMMETRIC NORMALIZED FIELD SECOND DERIVATIVE C IBDB = IPTOJ(NBDB) IK2 = IPTOJ(NK2) IF (IBDB .NE. 0) THEN IADR = I + IBDB BDB = DATAR(IADR) IF (PRAN4(NBDB) .NE. 0.0) BDB = BDB + PRAN4(NBDB)*XRAN(NBDB) ELSE IF (IK2 .NE. 0) THEN IADR = I + IK2 K2 = DATAR(IADR) IF (PRAN4(NK2) .NE. 0.0) K2 = K2 + PRAN4(NK2)*XRAN(NK2) K2 = K2/UNITI(8)**3 IF (MPMAD) K2 = 0.5*K2 IF (H0 .NE. 0.0) BDB = K2/H0 ELSE BDB = BDBI IF (PRAN4(NBDB) .NE. 0.0) BDB = BDB + PRAN4(NBDB)*XRAN(NBDB) ENDIF C C NON-MIDPLANE SYMMETRIC NORMALIZED FIELD SECOND DERIVATIVE C IBDBP = IPTOJ(NBDBP) IK2P = IPTOJ(NK2P) IF (IK2P .EQ. 0 .AND. PRAN4(NK2P) .EQ. 0.0) THEN IF (IBDBP .EQ. 0) THEN BDBP = BDBPI ELSE IADR = I + IBDBP BDBP = DATAR(IADR) ENDIF IF (PRAN4(NBDBP) .NE. 0.0) 1 BDBP = BDBP + PRAN4(NBDBP)*XRAN(NBDBP) ELSE IF (IK2P .EQ. 0) THEN K2P = 0.0 ELSE IADR = I + IK2P K2P = DATAR(IADR) ENDIF IF (PRAN4(NK2P) .NE. 0.0) K2P = K2P + PRAN4(NK2P)*XRAN(NK2P) IF (MPMAD) K2P = 0.5*K2P K2P = K2P/UNITI(8)**3 IF (H0 .NE. 0.0) BDBP = K2P*UNITI(1)**2/H0 ENDIF C C MIDPLANE SYMMETRIC NORMALIZED FIELD THIRD DERIVATIVE C IGAM = IPTOJ(NGAM) IK3 = IPTOJ(NK3) IF (IGAM .NE. 0) THEN IADR = I + IGAM GAM = DATAR(IADR) IF (PRAN4(NGAM) .NE. 0.0) GAM = GAM + PRAN4(NGAM)*XRAN(NGAM) ELSE IF (IK3 .NE. 0) THEN IADR = I + IK3 K3 = DATAR(IADR) IF (MPMAD) K3 = K3/6.0 K3 = K3/UNITI(8)**4 GAM = K3*UNITI(1)**3/H0 ELSE GAM = GAMI IF (PRAN4(NGAM) .NE. 0.0) GAM = GAM + PRAN4(NGAM)*XRAN(NGAM) ENDIF RETURN END SUBROUTINE CAB(C,A,B) C C CALCULATES MATRIX PRODUCT: C = A X B C REAL C(6,6), A(6,6), B(6,6), S C DO 2 I = 1, 6 DO 2 J = 1, 6 S = 0.0 DO 1 K = 1, 6 S = S + A(I,K)*B(K,J) 1 CONTINUE C(I,J) = S 2 CONTINUE C RETURN END SUBROUTINE CAB2 (RC, TC, RA, TA, RB, TB) C C CALCULATES MATRIX PRODUCE IN SECOND ORDER C C LIST OF COMMON BLOCKS C INCLUDE 'TMUL.CIN' C C LOCAL VARIABLES C REAL RA(6,6), RB(6,6), RC(6,6) REAL TA(5,21), TB(5,21), TC(5,21) C C----------------------------------------------------------- CALL CAB(RC,RA,RB) C TMUL = .FALSE. TMULT = .FALSE. DO 5 I1 = 1, 5 DO 5 I23 = 1, 21 IF (TA(I1,I23) .NE. 0.0) THEN TMUL = .TRUE. IF (I1 .LE. 4) TMULT = .TRUE. GO TO 50 ENDIF 5 CONTINUE C 50 DO 90 I1 = 1, 5 DO 90 I23 = 1, 21 S = 0.0 DO 80 I4 = 1, 5 S = S + RA(I1,I4)*TB(I4,I23) 80 CONTINUE TC(I1,I23) = S 90 CONTINUE C IF (.NOT. TMUL) GO TO 200 I1MIN = 1 IF (.NOT. TMULT) I1MIN = 5 C DO 150 I1 = I1MIN, 5 DO 150 I2 = 1, 6 INDA = 0 DO 150 I5 = 1, 6 TRR = 0.0 DO 110 I4 = 1, I5 INDA = INDA + 1 TRR = TRR + TA(I1,INDA)*RB(I4,I2) 110 CONTINUE C IF (TRR .EQ. 0.0) GO TO 150 DO 120 I3 = 1, 6 I23 = INDEX2(I2,I3) TC(I1,I23) = TC(I1,I23) + TRR*RB(I5,I3) 120 CONTINUE 150 CONTINUE C 200 RETURN END SUBROUTINE CAB3(RC,TC,UC,RA,TA,UA,RB,TB,UB) C C CALCULATES MATRIX PRODUCT IN THIRD ORDER C C LIST OF COMMON BLOCKS C INCLUDE 'TMUL.CIN' INCLUDE 'UMUL.CIN' C C LOCAL VARIABLES C INTEGER I1, I2, I3, I4, I5, I6, I7, I234, I1MIN INTEGER INDA, INDB, INDEX3 REAL RA(6,6), RB(6,6), RC(6,6) REAL S, TA(5,21), TB(5,21), TC(5,21), TR, TT REAL UA(5,56), UB(5,56), UC(5,56) REAL UR(6), URR C C------------------------------------------------------ CALL CAB2(RC,TC,RA,TA,RB,TB) C C FIND WHICH ROWS SHOULD BE MULTIPLIED C UMUL = .FALSE. DO 10 I1 = 1, 5 DO 10 I234 = 1, 56 IF (UA(I1,I234) .NE. 0.0) THEN UMUL = .TRUE. GO TO 50 ENDIF 10 CONTINUE C C PART OF UC FROM RA X UB C 50 DO 90 I1 = 1, 5 DO 90 I234 = 1, 56 S = 0.0 DO 80 I5 = 1, 5 S = S + RA(I1,I5)*UB(I5,I234) 80 CONTINUE UC(I1,I234) = S 90 CONTINUE C C PART OF UC FROM UA X RB X RB X RB C IF (.NOT. UMUL) GO TO 300 DO 150 I1 = 1, 5 DO 150 I2 = 1, 6 INDA = 0 DO 150 I7 = 1, 6 DO 110 I6 = 1, I7 UR(I6) = 0.0 DO 110 I5 = 1, I6 INDA = INDA + 1 UR(I6) = UR(I6) + UA(I1,INDA)*RB(I5,I2) 110 CONTINUE C DO 140 I3 = 1, 6 URR = 0.0 DO 120 I6 = 1, I7 URR = URR + UR(I6)*RB(I6,I3) 120 CONTINUE IF (URR .EQ. 0.0) GO TO 140 C DO 130 I4 = 1, 6 I234 = INDEX3(I2,I3,I4) UC(I1,I234) = UC(I1,I234) + URR*RB(I7,I4) 130 CONTINUE 140 CONTINUE 150 CONTINUE C C PART OF UC FROM TA X RB X TB C IF (.NOT. TMUL) GO TO 300 I1MIN = 1 IF (.NOT. TMULT) I1MIN = 5 C DO 200 I1 = I1MIN, 5 DO 200 I2 = 1, 6 INDA = 0 DO 200 I6 = 1, 5 TR = 0.0 DO 160 I5 = 1, I6 INDA = INDA + 1 TR = TR + TA(I1,INDA)*RB(I5,I2) 160 CONTINUE C IF (TR .EQ. 0.0) GO TO 200 INDB = 0 DO 170 I4 = 1, 6 DO 170 I3 = 1, I4 INDB = INDB + 1 I234 = INDEX3(I2,I3,I4) UC(I1,I234) = UC(I1,I234) + TR*TB(I6,INDB) 170 CONTINUE 200 CONTINUE C C PART OF UC FROM TA X TB X RB C DO 250 I1 = I1MIN, 5 INDB = 0 DO 250 I3 = 1, 6 DO 250 I2 = 1, I3 INDB = INDB + 1 INDA = 0 DO 250 I6 = 1, 6 TT = 0.0 DO 210 I5 = 1, I6 INDA = INDA + 1 IF (I5 .EQ. 6) GO TO 210 TT = TT + TA(I1,INDA)*TB(I5,INDB) 210 CONTINUE C IF (TT .EQ. 0.0) GO TO 250 DO 220 I4 = 1, 6 I234 = INDEX3(I2,I3,I4) UC(I1,I234) = UC(I1,I234) + TT*RB(I6,I4) 220 CONTINUE 250 CONTINUE C 300 RETURN END SUBROUTINE CABD2(RC,TC,RA,TA,RB,RBV,TBV) C C COMPUTES RCV AND RCV FROM PRELIMINARY CALCULATIONS C C LIST OF COMMON BLOCKS C INCLUDE 'TMUL.CIN' C C LOCAL VARIABLES C REAL RA(6,6), RB(6,6), RBV(6,6), RC(6,6) REAL TA(5,21), TBV(5,21), TC(5,21) C C------------------------------------------------------- CALL CAB(RC,RA,RBV) C DO 20 I1 = 1, 5 DO 20 I23 = 1, 21 S = 0.0 DO 10 I4 = 1, 5 S = S + RA(I1,I4)*TBV(I4,I23) 10 CONTINUE TC(I1,I23) = S 20 CONTINUE C TMUL = .FALSE. TMULT = .FALSE. DO 30 I1 = 1, 5 DO 30 I23 = 1, 21 IF (TA(I1,I23) .NE. 0.0) THEN TMUL = .TRUE. IF (I1 .LE. 4) TMULT = .TRUE. GO TO 40 ENDIF 30 CONTINUE C 40 IF (.NOT. TMUL) GO TO 100 IF (TMULT) THEN I1MIN = 1 ELSE I1MIN = 5 ENDIF C DO 80 I1 = I1MIN, 5 DO 80 I2 = 1, 6 INDA = 0 DO 80 I5 = 1, 6 TRR = 0.0 TRRV = 0.0 DO 50 I4 = 1, I5 INDA = INDA + 1 TRR = TRR + TA(I1,INDA)*RB(I4,I2) TRRV = TRRV + TA(I1,INDA)*RBV(I4,I2) 50 CONTINUE C IF (TRR .EQ. 0.0 .AND. TRRV .EQ. 0.0) GO TO 80 DO 60 I3 = 1, 6 I23 = INDEX2(I2,I3) TC(I1,I23) = TC(I1,I23) + TRRV*RB(I5,I3) + TRR*RBV(I5,I3) 60 CONTINUE 80 CONTINUE C 100 RETURN END SUBROUTINE CABD3(RC,TC,UC,RA,TA,UA,RB,TB,RBV,TBV,UBV) C C COMPUTES RCV, TCV, AND UCV FROM PRELIMINARY CALCULATIONS C C LIST OF COMMON BLOCKS C INCLUDE 'TMUL.CIN' INCLUDE 'UMUL.CIN' C C LOCAL VARIABLES C INTEGER I1, I2, I3, I4, I5, I6, I7 INTEGER I234, INDA, INDB, INDEX3, I1MIN REAL DTR, DTT, S, URR, DURR, TR, TT REAL RA(6,6), RB(6,6), RBV(6,6), RC(6,6) REAL TA(5,21), TB(5,21), TBV(5,21), TC(5,21) REAL UA(5,56), UBV(5,56), UC(5,56) REAL UR(6), DUR(6) C C---------------------------------------------------------------------- CALL CABD2(RC,TC,RA,TA,RB,RBV,TBV) C C PART OF UC FROM RA X UBV C DO 20 I1 = 1, 5 DO 20 I234 = 1, 56 S = 0.0 DO 10 I5 = 1, 5 S = S + RA(I1,I5)*UBV(I5,I234) 10 CONTINUE UC(I1,I234) = S 20 CONTINUE C C PART OF UC FROM UA X RB X RB X RBV C + UA X RB X RBB X RB C + UA X RBV X RB X RB C IF (.NOT. UMUL) GO TO 300 DO 150 I1 = 1, 5 DO 150 I2 = 1, 6 INDA = 0 DO 150 I7 = 1, 6 DO 110 I6 = 1, I7 UR(I6) = 0.0 DUR(I6) = 0.0 DO 110 I5 = 1, I6 INDA = INDA + 1 UR(I6) = UR(I6) + UA(I1,INDA)*RB(I5,I2) DUR(I6) = DUR(I6) + UA(I1,INDA)*RBV(I5,I2) 110 CONTINUE C DO 140 I3 = 1, 6 URR = 0.0 DURR = 0.0 DO 120 I6 = 1, I7 URR = URR + UR(I6)*RB(I6,I3) DURR = DURR + UR(I6)*RBV(I6,I3) + DUR(I6)*RB(I6,I3) 120 CONTINUE IF (URR .EQ. 0.0 .AND. DURR .EQ. 0.0) GO TO 140 C DO 130 I4 = 1, 6 I234 = INDEX3(I2,I3,I4) UC(I1,I234) = UC(I1,I234) + URR*RBV(I7,I4) + DURR*RB(I7,I4) 130 CONTINUE 140 CONTINUE 150 CONTINUE C C PART OF UC FROM TA X RBV X TB C + TA X RB X TBV C IF (.NOT. TMUL) GO TO 300 I1MIN = 1 IF (.NOT. TMULT) I1MIN = 5 C DO 200 I1 = I1MIN, 5 DO 200 I2 = 1, 6 INDA = 0 DO 200 I6 = 1, 5 TR = 0.0 DTR = 0.0 DO 160 I5 = 1, I6 INDA = INDA + 1 TR = TR + TA(I1,INDA)*RB(I5,I2) DTR = DTR + TA(I1,INDA)*RBV(I5,I2) 160 CONTINUE C IF (TR .EQ. 0.0 .AND. DTR .EQ. 0.0) GO TO 200 INDB = 0 DO 170 I4 = 1, 6 DO 170 I3 = 1, I4 INDB = INDB + 1 I234 = INDEX3(I2,I3,I4) UC(I1,I234) = UC(I1,I234) + TR*TBV(I6,INDB) + DTR*TB(I6,INDB) 170 CONTINUE 200 CONTINUE C C PART OF UC FROM TA X TBV X RB C + TA X TB X RBV C DO 250 I1 = I1MIN, 5 INDB = 0 DO 250 I3 = 1, 6 DO 250 I2 = 1, I3 INDB = INDB + 1 INDA = 0 DO 250 I6 = 1, 6 TT = 0.0 DTT = 0.0 DO 210 I5 = 1, I6 INDA = INDA + 1 IF (I5 .EQ. 6) GO TO 210 TT = TT + TA(I1,INDA)*TB(I5,INDB) DTT = DTT + TA(I1,INDA)*TBV(I5,INDB) 210 CONTINUE C IF (TT .EQ. 0.0) GO TO 250 DO 220 I4 = 1, 6 I234 = INDEX3(I2,I3,I4) UC(I1,I234) = UC(I1,I234) + TT*RBV(I6,I4) + DTT*RB(I6,I4) 220 CONTINUE 250 CONTINUE C 300 RETURN END SUBROUTINE CABT(C,A,B) C C CALCULATES MATRIX PRODUCT C = A X B (TRANSPOSE) C C LOCAL VARIABLES C REAL C(6,6), A(6,6), B(6,6), S C C------------------------------------------------------- DO 1 I = 1, 6 DO 1 J = 1, 6 S = 0.0 DO 4 K = 1, 6 S = S + A(I,K) * B(J,K) 4 CONTINUE C(J,I) = S 1 CONTINUE RETURN END SUBROUTINE CHEK (CKK) C C LOOKS FOR MAIN BODY OF BENDING MAGNET ASSOCIATED WITH FRINGING FIELD C C LIST OF COMMON BLOCKS C LOGICAL CKK C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA0B.CIN' INCLUDE 'DATA1A.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM2B.CIN' INCLUDE 'ELM2D.CIN' INCLUDE 'ELM4E.CIN' INCLUDE 'INDPAR.CIN' INCLUDE 'IOUNIT.CIN' C C LOCAL VARIABLES C INTEGER IDATA, II, IL, IADR, J, K, NBVARY, TYPEN EXTERNAL IDATA C C----------------------------------------------------------------- CKK = .TRUE. C C CHECK TO SEE IF INTERVENING CARDS ARE I/O CONTROLS C AND DECIDE IF FRINGING FIELD IS AT ENTRANCE OR EXIT C J = NUM DO 10 K = 1, 100 J = J + NDIF IF (J .LE. 0) GO TO 20 IF (J .GT. NEL) GO TO 20 II = ISTOR(J) TYPEN = IDATA(II) IF (TYPEN .EQ. 4) GO TO 50 IF (TYPEN .NE. 13 .AND. TYPEN .NE. 23 .AND. TYPEN .NE. 30) 1 GO TO 20 10 CONTINUE C 20 J = NUM DO 30 K = 1, 100 J = J - NDIF IF (J .LE. 0) GO TO 40 IF (J .GT. NEL) GO TO 40 II = ISTOR(J) TYPEN = IDATA(II) IF (TYPEN .EQ. 4) GO TO 60 IF (TYPEN .NE. 13 .AND. TYPEN .NE. 23 .AND. TYPEN .NE. 30) 1 GO TO 40 30 CONTINUE 40 WRITE (NOUT, 140) 140 FORMAT ('0*** BEND ELEMENT NOT FOUND FOR ROTAT ELEMENT') CKK = .FALSE. RETURN C C SET FRINGING FIELD PARAMETERS C FRINGING FIELD IS AT MAGNET ENTRANCE C 50 BEFORE = .TRUE. NUM4 = J FFIN = .TRUE. GO TO 70 C C FRINGING FIELD IS AT MAGNET EXIT C 60 BEFORE = .FALSE. C C FIND VARY CODE OF FIELD FOR USE IN FITTING C 70 IL = IPTOJB(1) IF (IL .EQ. 0) IADR = II + 1 IF (IL .NE. 0) IADR = II + 2 80 IBVARY = IADR NBVARY = TIE(IBVARY) IF (NBVARY .EQ. 100) THEN IADR = IDATA(IADR) GO TO 80 ENDIF RETURN END SUBROUTINE ELIMTB (A,N) C ELIMTB (A,N) WILL RETURN THE STRING WHOSE LAST CHARACTER IS NOT C BLANK. THE STRING RETURN WILL HAVE THE LENGTH N. C THIS ROUTINE WILL FIND THE POSITION OF THE LAST NON-BLANK, OR C TAB CHARACTER IN A AND RETURN THAT LOCATION IN N. CHARACTER A*(*) NA = LEN(A) IF (NA .LE. 0) THEN N = 0 RETURN END IF IF (A .EQ. ' ') THEN N = 0 RETURN END IF NA = LEN(A) DO 10 100 I = NA, 1, -1 IF (ICHAR(A(I:I)) .EQ. 0) GO TO 10 100 IF ((A(I:I) .NE. ' ') .AND. (A(I:I) .NE. ' ')) THEN N = I RETURN END IF 10100 CONTINUE N = 0 RETURN END SUBROUTINE CLI(LOGIC) C C CHECK TO SEE IF CONSTRAINT IS ONE SIDED C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM10D.CIN' C C LOCAL VARIABLES C LOGICAL LOGIC C C---------------------------------------------------------------------- C ELIMINATE CONSTRAINT IF NOT APPLICABLE C LOGIC = .FALSE. IF (CTY .EQ. 0) GO TO 10 IF ((CTY .EQ. 1) .AND. (A(1) .GT. 0.0)) GO TO 10 IF ((CTY .EQ. 2) .AND. (A(1) .LT. 0.0)) GO TO 10 A(1) = 0.0 NC = NC - 1 LOGIC = .TRUE. C 10 RETURN END SUBROUTINE CMISDO(CMIS) C C CREATE LITERAL DESCRIPTIONS FROM INTERNALLY STORED MISALIGNMENT C CODE C CHARACTER*20 CMIS INCLUDE 'ELM8A.CIN' INCLUDE 'RDCHAR.CIN' CHARACTER*2 CR1, CR2 CHARACTER*3 CUNC CHARACTER*4 CBEAM CHARACTER*5 CBENDS, CKNOWN, CQUADS, CTABLE CHARACTER*6 CRAND, CSING CHARACTER*7 CMAG INTEGER NMIN, NMAX DATA CUNC /'UNC'/ DATA CKNOWN /'KNOWN'/ DATA CRAND /'RANDOM'/ DATA CBEAM /'BEAM'/ DATA CTABLE /'TABLE'/ DATA CSING /'SINGLE'/ DATA CR1 /'R1'/ DATA CR2 /'R2'/ DATA CMAG /'MAGNETS'/ DATA CBENDS /'BENDS'/ DATA CQUADS /'QUADS'/ C CMIS = BLANK IF (LFM .EQ. 0) THEN CMIS(1:3) = CUNC NMIN = 4 ELSE IF (LFM .EQ. 1) THEN CMIS(1:5) = CKNOWN NMIN = 6 ELSE IF (LFM .EQ. 2) THEN CMIS(1:6) = CRAND NMIN = 7 ENDIF C CMIS(NMIN:NMIN) = SLASH NMIN = NMIN + 1 C IF (RORC .EQ. 0) THEN NMAX = NMIN + 5 CMIS(NMIN:NMAX) = CSING ELSE IF (RORC .EQ. 1) THEN NMAX = NMIN + 1 CMIS(NMIN:NMAX) = CR1 ELSE IF (RORC .EQ. 2) THEN NMAX = NMIN + 1 CMIS(NMIN:NMAX) = CR2 ELSE IF (RORC .EQ. 3) THEN NMAX = NMIN + 6 CMIS(NMIN:NMAX) = CMAG ELSE IF (RORC .EQ. 4) THEN NMAX = NMIN + 4 CMIS(NMIN:NMAX) = CBENDS ELSE IF (RORC .EQ. 5) THEN NMAX = NMIN + 4 CMIS(NMIN:NMAX) = CQUADS ENDIF C NMIN = NMAX + 1 CMIS(NMIN:NMIN) = SLASH NMIN = NMIN + 1 C IF (LTAB .EQ. 0) THEN NMAX = NMIN + 3 CMIS(NMIN:NMAX) = CBEAM ELSE IF (LTAB .EQ. 1) THEN NMAX = NMIN + 4 CMIS(NMIN:NMAX) = CTABLE ENDIF RETURN END SUBROUTINE COMBIN C C PERFORM ALGEBRAIC OPERATIONS AND EVALUATE FUNCTIONS C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA0A.CIN' INCLUDE 'DATA0B.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM22A.CIN' INCLUDE 'ELM23.CIN' C C LOCAL VARIABLES C REAL DREGA(NPVAR), DREGB(NPVAR), DREGC(NPVAR) EXTERNAL DATAR C C------------------------------------------------------------- C INPUT REGISTERS AND OPERATION C K1 = K1REG K2 = K2REG J = JREG NP1 = NV3 + 1 IF (JTIE .EQ. 0 .AND. J .GT. 20) GO TO 500 IF (K1TIE .EQ. 0 .AND. K1 .GT. 20) GO TO 500 C C FIRST OPERAND C IF (K1TIE .EQ. 100) GO TO 20 IF (.NOT. LREG(K1)) GO TO 500 REGA = REG(K1) IF (NV3 .EQ. 0) GO TO 50 DO 5 JJ = 1, NV3 5 DREGA(JJ) = DREG(K1,JJ) IF (NV3 .GE. NPVAR) GO TO 50 10 DO 15 JJ = NP1, NPVAR 15 DREGA(JJ) = 0.0 GO TO 50 C 20 REGA = DATAR(K1) IF (NV3 .EQ. 0) GO TO 50 DO 25 JJ = 1, NV3 25 DREGA(JJ) = 0.0 NV2 = K1 27 NV2 = TIE(NV2) IF (NV2 .EQ. 100) GO TO 27 IF (NV2 .EQ. 0) GO TO 50 IF (NV2 .EQ. 99) GO TO 30 DREGA(NV2) = 1.0 GO TO 50 C 30 IF (NV3 .EQ. 0) GO TO 50 DO 35 JJ = 1, NV3 35 DREGA(JJ) = DATA(K1+JJ) C C SECOND OPERAND C 50 IF (IOPN .GT. 4) GO TO 100 IF (K2TIE .EQ. 0 .AND. K2 .GT. 20) GO TO 500 IF (K2TIE .EQ. 100) GO TO 70 IF (.NOT. LREG(K2)) GO TO 500 REGB = REG(K2) IF (NV3 .EQ. 0) GO TO 100 DO 55 JJ = 1, NV3 55 DREGB(JJ) = DREG(K2,JJ) IF (NV3 .GE. NPVAR) GO TO 100 60 DO 65 JJ = NP1, NPVAR 65 DREGB(JJ) = 0.0 GO TO 100 C 70 REGB = DATAR(K2) IF (NV3 .EQ. 0) GO TO 100 DO 75 JJ = 1, NV3 75 DREGB(JJ) = 0.0 NV2 = K2 77 NV2 = TIE(NV2) IF (NV2 .EQ. 100) GO TO 77 IF (NV2 .EQ. 0) GO TO 100 IF (NV2 .EQ. 99) GO TO 80 DREGB(NV2) = 1.0 GO TO 100 C 80 IF (NV3 .EQ. 0) GO TO 100 DO 85 JJ = 1, NV3 85 DREGB(JJ) = DATA(K2+JJ) C C OPERATIONS C 100 IF (NV3 .EQ. 0) GO TO 106 IF (NV3 .GE. NPVAR) GO TO 106 DO 105 JJ = NP1, NPVAR 105 DREGC(JJ) = 0.0 106 IF (IOPN .LT. 10) THEN GO TO (110,120,130,140), IOPN ELSE IGO = IOPN - 11 GO TO (150,160,170,180,190,200,210,220,230,240), IGO ENDIF C C ADDITION C 110 REGC = REGA + REGB IF (NV3 .EQ. 0) GO TO 500 DO 115 N = 1, NV3 115 DREGC(N) = DREGA(N) + DREGB(N) GO TO 500 C C SUBTRACTION C 120 REGC = REGA - REGB IF (NV3 .EQ. 0) GO TO 500 DO 125 N = 1, NV3 125 DREGC(N) = DREGA(N) - DREGB(N) GO TO 500 C C MULTIPLICATION C 130 PROD = REGA*REGB IF (NV3 .EQ. 0) GO TO 138 DO 135 N = 1, NV3 135 DREGC(N) = REGA*DREGB(N) + DREGA(N)*REGB 138 REGC = PROD GO TO 500 C C DIVISION C 140 QUOT = REGA/REGB IF (NV3 .EQ. 0) GO TO 148 DO 145 N = 1, NV3 145 DREGC(N) = (REGB*DREGA(N) - REGA*DREGB(N))/REGB**2 148 REGC = QUOT GO TO 500 C C NEGATIVE C 150 REGC = - REGA IF (NV3 .EQ. 0) GO TO 500 DO 155 N = 1, NV3 155 DREGC(N) = - DREGA(N) GO TO 500 C C SQUARE ROOT C 160 ROOT = SQRT(REGA) IF (NV3 .GT. 0) THEN DO 165 N = 1, NV3 165 DREGC(N) = 0.5*DREGA(N)/ROOT ENDIF REGC = ROOT GO TO 500 C C LOGARITHM C 170 XLOG = LOG(REGA) IF (NV3 .GT. 0) THEN DO 175 N = 1, NV3 175 DREGC(N) = DREGA(N)/REGA ENDIF REGC = XLOG GO TO 500 C C EXPONENTIAL C 180 EXPX = EXP(REGA) IF (NV3 .GT. 0) THEN DO 185 N = 1, NV3 185 DREGC(N) = EXPX*DREGA(N) ENDIF REGC = EXPX GO TO 500 C C SINE C 190 SINX = SIN(REGA) IF (NV3 .GT. 0) THEN COSX = COS(REGA) DO 195 N = 1, NV3 195 DREGC(N) = COSX*DREGA(N) ENDIF REGC = SINX GO TO 500 C C COSINE C 200 COSX = COS(REGA) IF (NV3 .GT. 0) THEN SINX = SIN(REGA) DO 205 N = 1, NV3 205 DREGC(N) = - SINX*DREGA(N) ENDIF REGC = COSX GO TO 500 C C HYPERBOLIC SINE C 210 SINHX = SINH(REGA) IF (NV3 .GT. 0) THEN COSHX = COSH(REGA) DO 215 N = 1, NV3 215 DREGC(N) = COSHX*DREGA(N) ENDIF REGC = SINHX GO TO 500 C C HYPERBOLIC COSINE C 220 COSHX = COSH(REGA) IF (NV3 .GT. 0) THEN SINHX = SINH(REGA) DO 225 N = 1, NV3 225 DREGC(N) = SINHX*DREGA(N) ENDIF REGC = COSHX GO TO 500 C C ARCSINE C 230 ASINX = ASIN(REGA) IF (NV3 .GT. 0) THEN SKORT = 1.0/SQRT(1.0 - REGA**2) DO 235 N = 1, NV3 235 DREGC(N) = SKORT*DREGA(N) ENDIF REGC = ASINX GO TO 500 C C ARCCOSINE C 240 ACOSX = ACOS(REGA) IF (NV3 .GT. 0) THEN SKORT = - 1.0/SQRT(1.0 - REGA**2) DO 245 N = 1, NV3 245 DREGC(N) = SKORT*DREGA(N) ENDIF REGC = ACOSX GO TO 500 C C STORE RESULT OF OPERATION C 500 IF (JTIE .EQ. 100) GO TO 520 REG(J) = REGC LREG(J) = .TRUE. IF (NV3 .EQ. 0) GO TO 550 DO 505 JJ = 1, NV3 505 DREG(J,JJ) = DREGC(JJ) GO TO 550 C 520 DATA(J) = REGC IF (NV3 .EQ. 0) GO TO 550 DO 525 JJ = 1, NV3 525 DATA(J+JJ) = DREGC(JJ) C 550 RETURN END SUBROUTINE CONDOR C C CALCULATES PARTIALS AND CONSTRAINTS FOR THIRD-ORDER FITTING C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM10A.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM10D.CIN' INCLUDE 'ELM13B.CIN' INCLUDE 'ELM15C.CIN' INCLUDE 'IOUNIT.CIN' INCLUDE 'R2P.CIN' INCLUDE 'RC2.CIN' INCLUDE 'SI.CIN' INCLUDE 'UC2.CIN' C C LOCAL VARIABLES C REAL RSX(6,NPVAR+1), USX(56,NPVAR+1) REAL UST(6,21,NPVAR+1), USS(21,6,NPVAR+1) REAL USSS(56,NPVAR+1), USSC(6,NPVAR+1) C C----------------------------------------------------------- J = JCON K = KCON NP1 = NV1 + 1 IF (J .GE. 0) GO TO 200 C C THIRD ORDER MATRIX ELEMENT CONSTRAINT C 70 J = - J KLM = K K = KLM/100 LM = KLM - 100*K LL = LM/10 M = LM - 10*LL IF (J .GT. 6) GO TO 900 IF (K .LT. 1 .OR. K .GT. 6) GO TO 900 IF (LL .LT. 1 .OR. LL .GT. 6) GO TO 900 IF (M .LT. 1 .OR. M .GT. 6) GO TO 900 KLM = K + LL*(LL-1)/2 + M*(M+1)*(M-1)/6 DO 80 L1 = 1, NP1 80 A(L1) = 0.0 CW = 1.0/SD**2 FAC = UBEAM(K)*UBEAM(LL)*UBEAM(M)/UBEAM(J) COC = UC2(J,KLM)*FAC IF (NV3 .LT. 1) RETURN A(1) = DE0 - COC C IF (NV1 .LT. 1) GO TO 120 DO 110 N = 1, NV1 IF (.NOT. R2VP(N)) GO TO 110 A(N+1) = U2V(J,KLM,N)*FAC 110 CONTINUE 120 CALL GATHER RETURN C C MINIMIZATION OF CONTRIBUTION OF THIRD-ORDER ABERRATIONS TO BEAM C 200 IF (.NOT. ACCEL) CW = 1.0/SD**2 C C THIRD-ORDER CONTRIBUTIONS C PRODUCT OF RC2 AND SI C DO 220 L2 = 1, 6 SS = 0.0 DO 210 L1 = 1, 6 SS = SS + RC2(J,L1)*SI(L1,L2) 210 CONTINUE RSX(1,L2) = - SS 220 CONTINUE C DO 240 N = 1, NV1 DO 240 L2 = 1, 6 SS = 0.0 DO 230 L1 = 1, 6 SS = SS + R2V(J,L1,N)*SI(L1,L2) 230 CONTINUE RSX(N+1,L2) = SS 240 CONTINUE C C PRODUCT OF UC2 AND SI DOUBLY CONTRACTED C I234 = 0 DO 260 I4 = 1, 6 SS = 0.0 DO 250 I3 = 1, I4 DO 250 I2 = 1, I3 I234 = I234 + 1 SS = SS + UC2(J,I234)*SI(I2,I3) 250 CONTINUE USX(I4,1) = - SS 260 CONTINUE C I234 = 0 DO 270 I4 = 1, 6 DO 270 I3 = 1, I4 DO 270 I2 = 1, I3 I234 = I234 + 1 USX(I3,1) = USX(I3,1) - UC2(J,I234)*SI(I2,I4) 270 CONTINUE C I234 = 0 DO 280 I4 = 1, 6 DO 280 I3 = 1, I4 DO 280 I2 = 1, I3 I234 = I234 + 1 USX(I2,1) = USX(I2,1) - UC2(J,I234)*SI(I3,I4) 280 CONTINUE C DO 330 N = 1, NV1 I234 = 0 DO 300 I4 = 1, 6 SS = 0.0 DO 290 I3 = 1, I4 DO 290 I2 = 1, I3 I234 = I234 + 1 SS = SS + U2V(J,I234,N)*SI(I2,I3) 290 CONTINUE USX(I4,N+1) = SS 300 CONTINUE C I234 = 0 DO 310 I4 = 1, 6 DO 310 I3 = 1, I4 DO 310 I2 = 1, I3 I234 = I234 + 1 USX(I3,N+1) = USX(I3,N+1) + U2V(J,I234,N)*SI(I2,I4) 310 CONTINUE C I234 = 0 DO 320 I4 = 1, 6 DO 320 I3 = 1, I4 DO 320 I2 = 1, I3 I234 = I234 + 1 USX(I2,N+1) = USX(I2,N+1) + U2V(J,I234,N)*SI(I3,I4) 320 CONTINUE 330 CONTINUE C C MULTIPLY U X SI TO GET MATRIX PRODUCT US C DO 335 N = 1, NP1 DO 335 I2 = 1, 6 DO 335 I34 = 1, 21 UST(I2,I34,N) = 0.0 335 CONTINUE C I234 = 0 I34 = 0 DO 350 I4 = 1, 6 DO 350 I3 = 1, I4 I34 = I34 + 1 DO 350 I2 = 1, I3 I234 = I234 + 1 UFAC = - UC2(J,I234) IF (UFAC .NE. 0.0) THEN DO 340 I5 = 1, 6 UST(I5,I34,1) = UST(I5,I34,1) + UFAC*SI(I2,I5) 340 CONTINUE ENDIF 350 CONTINUE C DO 380 N = 1, NV1 I234 = 0 I34 = 0 DO 370 I4 = 1, 6 DO 370 I3 = 1, I4 I34 = I34 + 1 DO 370 I2 = 1, I3 I234 = I234 + 1 UFAC = U2V(J,I234,N) IF (UFAC .NE. 0.0) THEN DO 360 I5 = 1, 6 UST(I5,I34,N+1) = UST(I5,I34,N+1) + UFAC*SI(I2,I5) 360 CONTINUE ENDIF 370 CONTINUE 380 CONTINUE C C MULTIPLY US X SI TO GET DOUBLE MATRIX PRODUCT USS C DO 400 N = 1, NP1 DO 385 I23 = 1, 21 DO 385 I4 = 1, 6 USS(I23,I4,N) = 0.0 385 CONTINUE C I34 = 0 DO 400 I4 = 1, 6 DO 400 I3 = 1, 6 I34 = I34 + 1 DO 400 I2 = 1, I3 UFAC = UST(I2,I34,N) IF (UFAC .NE. 0.0) THEN DO 390 I6 = 1, 6 I26 = INDEX2(I2,I6) USS(I26,I4,N) = USS(I26,I4,N) + UFAC*SI(I3,I6) 390 CONTINUE ENDIF 400 CONTINUE C C MULTIPLY USS X SI TO GET USSS C DO 440 N = 1, NP1 DO 410 I234 = 1, 56 USSS(I234,N) = 0.0 410 CONTINUE C DO 430 I4 = 1, 6 I23 = 0 DO 430 I3 = 1, 6 DO 430 I2 = 1, I3 I23 = I23 + 1 C UFAC = USS(I23,I4,N) IF (UFAC .NE. 0.0) THEN DO 420 I7 = 1, 6 I237 = INDEX3(I2,I3,I7) USSS(I237,N) = USSS(I237,N) + UFAC*SI(I4,I7) 420 CONTINUE ENDIF 430 CONTINUE 440 CONTINUE C C MATRIX PRODUCT OF US AND SI C DO 460 N = 1, NP1 DO 450 L2 = 1, 6 SS = 0.0 DO 445 L1 = 1, 6 SS = SS + USX(L1,N)*SI(L1,L2) 445 CONTINUE USSC(L2,N) = SS 450 CONTINUE 460 CONTINUE C C CROSS PRODUCT BETWEEN FIRST AND THIRD ORDER C DO 500 N1 = 1, NP1 DO 500 N2 = 1, NP1 RSSU = 0.0 USSR = 0.0 C IF (K .LT. 5) THEN DO 470 L1 = 1, 6 RSSU = RSSU + RSX(L1,N1)*USX(L1,N2) 470 CONTINUE ENDIF C IF (J .LT. 5) THEN DO 480 L1 = 1, 6 USSR = USSR + USX(L1,N1)*RSX(L1,N2) 480 CONTINUE ENDIF C C MATRIX PRODUCT OF US TIMES SI AND US C USSISU = 0.0 DO 485 L1 = 1, 6 USSISU = USSISU + USSC(L1,N1)*USX(L1,N2) 485 CONTINUE C C PRODUCT OF USSS AND UC2 C USSSU = 0.0 I234 = 0 DO 490 I4 = 1, 6 DO 490 I3 = 1, I4 DO 490 I2 = 1, I3 I234 = I234 + 1 IF (N1 .EQ. 1) THEN UFAC = - UC2(J,I234) ELSE UFAC = U2V(J,I234,N1-1) ENDIF IF (UFAC .NE. 0.0) THEN USSSU = USSSU + 6.0*UFAC*USSS(I234,N2) ENDIF 490 CONTINUE CA(N1,N2) = CA(N1,N2) 1 + CW*(RSSU + USSR + USSISU + USSSU)/UBEAM(J)**2 500 CONTINUE RETURN C C ILLEGAL CONSTRAINT C 900 WRITE (NOUT,9804) 9804 FORMAT (' *** ERROR *** ILLEGAL FORM OF CONSTRAINT') COC = 0.0 RETURN END SUBROUTINE CONSEC C C CALCULATES PARTIALS AND CONSTRAINTS FOR SECOND-ORDER FITTING C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM10A.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM10D.CIN' INCLUDE 'ELM13B.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'ELM15C.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'ELM17B.CIN' INCLUDE 'R2P.CIN' INCLUDE 'SI.CIN' INCLUDE 'TC2.CIN' C C LOCAL VARIABLES C REAL TCS(11), TR(11,6,6), TS(11,21) C C--------------------------------------------------------------------- J = JCON K = KCON NP1 = NV1 + 1 IF (J .EQ. 18) GO TO 300 IF (J .GE. 0) GO TO 200 C C SECOND ORDER MATRIX ELEMENT CONSTRAINT C 70 IF (K .GT. 100) GO TO 150 IF (J .LT. - 20) J = J + 20 J = - J KM = K K = KM/10 M = KM - 10*K IF (J .GT. 6) GO TO 900 IF (K .LT. 1 .OR. K .GT. 6) GO TO 900 IF (M .LT. 1 .OR. M .GT. 6) GO TO 900 KM = K + M*(M-1)/2 DO 80 L1 = 1, NP1 80 A(L1) = 0.0 CW = 1.0/SD**2 FAC = UBEAM(K)*UBEAM(M)/UBEAM(J) COC = TC2(J,KM)*FAC IF (NV3 .LT. 1) RETURN A(1) = DE0 - COC C IF (NV1 .GE. 1) THEN DO 130 N = 1, NV1 IF (R2VP(N)) THEN A(N+1) = T2V(J,KM,N)*FAC ENDIF 130 CONTINUE ENDIF CALL GATHER NP1 = NV1 + 1 RETURN C C THIRD-ORDER MATRIX ELEMENT CONSTRAINT C 150 IF (NORD3 .GE. 3) CALL CONDOR RETURN C C MINIMIZATION OF CONTRIBUTION OF SECOND-ORDER ABERRATIONS TO BEAM C 200 IF (ACCEL) RETURN CW = 1.0/(SD*UBEAM(J))**2 C SS = 0.0 IND = 0 DO 210 L2 = 1, 6 DO 210 L1 = 1, L2 IND = IND + 1 SS = SS + TC2(J,IND)*SI(L1,L2) 210 CONTINUE TCS(1) = - SS N1 = 1 C DO 220 L1 = 1, 6 INDA = 0 DO 220 K = 1, 6 SS = 0.0 DO 215 L2 = 1, K INDA = INDA + 1 SS = SS + TC2(J,INDA)*SI(L1,L2) 215 CONTINUE TR(1,L1,K) = - SS 220 CONTINUE C IF (NV3 .LT. 1) GO TO 900 IF (NV1 .LT. 1) GO TO 251 DO 230 N = 1, NV1 SS = 0.0 IND = 0 DO 225 L2 = 1, 6 DO 225 L1 = 1, L2 IND = IND + 1 SS = SS + T2V(J,IND,N)*SI(L1,L2) 225 CONTINUE TCS(N+1) = SS 230 CONTINUE C DO 240 N = 1, NV1 DO 240 L1 = 1, 6 INDA = 0 DO 240 K = 1, 6 SS = 0.0 DO 235 L2 = 1, K INDA = INDA + 1 SS = SS + T2V(J,INDA,N)*SI(L1,L2) 235 CONTINUE TR(N+1,L1,K) = SS 240 CONTINUE C NP1 = NV1 + 1 DO 250 N = 1, NP1 INDA = 0 DO 250 L1 = 1, 6 DO 250 K = 1, L1 INDA = INDA + 1 SS = 0.0 DO 245 L2 = 1, 6 SS = SS + TR(N,K,L2)*SI(L1,L2) 245 CONTINUE TS(N,INDA) = SS 250 CONTINUE C 251 DO 260 N1 = 1, NP1 DO 260 N2 = 1, N1 IF (N1 .EQ. 1 .AND. N2 .EQ. 1) GO TO 260 TSST = TCS(N1)*TCS(N2) DO 255 L1 = 1, 6 DO 255 L2 = 1, 6 TSST = TSST + TR(N1,L1,L2)*TR(N2,L2,L1) 255 CONTINUE CA(N1,N2) = CA(N1,N2) + TSST*CW 260 CONTINUE C N2 = 1 DO 270 N1 = 2, NP1 TSST = 0.0 DO 265 IND = 1, 21 TSST = TSST + TS(N1,IND)*TC2(J,IND) 265 CONTINUE CA(N1,N2) = CA(N1,N2) - TSST*CW 270 CONTINUE C DO 280 N1 = 2, NP1 DO 280 N2 = 2, N1 TSST = 0.0 DO 275 IND = 1, 21 TSST = TSST + TS(N1,IND)*T2V(J,IND,N2-1) 275 CONTINUE CA(N1,N2) = CA(N1,N2) + TSST*CW 280 CONTINUE C IF (NORD3 .GE. 3) CALL CONDOR RETURN C C LIMITATIONS ON SEXTUPOLE STRENGTH C 300 SEXLIM = .TRUE. SEXMAX = SD*UNITI(9) C 900 RETURN END SUBROUTINE CONSTR C C CALCULATES PARTIALS AND FIRST-ORDER CONSTRAINTS C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'COCOM.CIN' INCLUDE 'CONSTS.CIN' INCLUDE 'COP.CIN' INCLUDE 'DATA0A.CIN' INCLUDE 'ELM0B.CIN' INCLUDE 'ELM0E.CIN' INCLUDE 'ELM1D.CIN' INCLUDE 'ELM10A.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM10D.CIN' INCLUDE 'ELM15C.CIN' INCLUDE 'ELM16C.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'ETACOM.CIN' INCLUDE 'ETAP.CIN' INCLUDE 'FLUSHC.CIN' INCLUDE 'IOUNIT.CIN' INCLUDE 'OC.CIN' INCLUDE 'OCP.CIN' INCLUDE 'RC2.CIN' INCLUDE 'R2P.CIN' INCLUDE 'R3P.CIN' INCLUDE 'SI.CIN' INCLUDE 'SVP.CIN' C C LOCAL VARIABLES C LOGICAL LOGIC C DATA REARTH /6.3714E6/ C C------------------------------------------------------------------ J = JCON K = KCON NP1 = NV1 + 1 DO 80 L1 = 1, NP1 80 A(L1) = 0.0 IF (J .EQ. 0 .AND. K .EQ. 0) GO TO 100 IF (J .EQ. 8 .AND. K .NE. 8) GO TO 110 IF (J .EQ. 9) GO TO 160 IF (J .EQ. 18) GO TO 800 IF (J .EQ. 100) GO TO 850 GO TO 200 C C SYSTEM LENGTH CONSTRAINT C 100 COC = LC/UFLOOR(1) IF (NV3 .GE. 1) THEN CW = 1.0/SD**2 A(1) = DE0 - COC CALL CLI (LOGIC) IF (LOGIC) GO TO 1000 IF (NV1 .GE. 1) THEN DO 101 N = 1, NV1 A(N+1) = LCV(N)/UFLOOR(1) 101 CONTINUE ENDIF ENDIF 105 CALL GATHER GO TO 1000 C C FLOOR COORDINATE CONSTRAINT C 110 IF (K .GE. 4) GO TO 120 IF (K .LE. 0) GO TO 900 C C CONSTRAINT ON POSITION C COC = X0(4,K)/UFLOOR(1) IF (NV3 .GE. 1) THEN CW = 1.0/SD**2 A(1) = DE0 - COC IF (NV1 .GE. 1) THEN DO 111 N = 1, NV1 IF (OVP(N)) A(N+1) = X0V(K,N)/UFLOOR(1) 111 CONTINUE ENDIF ENDIF CALL GATHER GO TO 1000 C C CONSTRAINT ON ANGLES C 120 IF (NV3 .GE. 1) CW = 1.0/SD**2 IF (K .EQ. 5) GO TO 130 IF (K .EQ. 6) GO TO 140 IF (K .EQ. 7) GO TO 150 IF (K .GE. 8) GO TO 900 C C CONSTRAINT ON YAW C CSY = O(4,3,3) SNY = O(4,3,1) IF (CSY .EQ. 0.0) THEN IF (SNY .GT. 0.0) YAW = 0.5*PI IF (SNY .LT. 0.0) YAW = - 0.5*PI ELSE YAW = ATAN(SNY/CSY) IF (CSY .LT. 0.0) THEN SHIFT = SIGN(PI,SNY) YAW = YAW + SHIFT ENDIF COC = YAW/UFLOOR(2) ENDIF C IF (NV3 .GE. 1) THEN A(1) = DE0 - COC IF (NV1 .GE. 1) THEN DO 123 N = 1, NV1 IF (OVP(N)) THEN DSNY = OV(3,1,N) DCSY = OV(3,3,N) A(N+1) = (CSY*DSNY - SNY*DCSY)/(CSY**2 + SNY**2) A(N+1) = A(N+1)/UFLOOR(2) ENDIF 123 CONTINUE ENDIF ENDIF CALL GATHER GO TO 1000 C C CONSTRAINT ON PITCH C 130 SINP = O(4,3,2) COC = ASIN(SINP)/UFLOOR(2) IF (NV3 .GE. 1) THEN A(1) = DE0 - COC IF (NV1 .GE. 1) THEN COSP = SQRT(1.0 - SINP**2) DO 131 N = 1, NV1 IF (OVP(N)) THEN DSINP = OV(3,2,N) A(N+1) = (DSINP/COSP)/UFLOOR(2) ENDIF 131 CONTINUE ENDIF ENDIF CALL GATHER GO TO 1000 C C CONSTRAINT ON ROLL C 140 ROLL = ATAN(O(4,1,2)/O(4,2,2)) IF (O(4,2,2) .LT. 0.0) THEN SHIFT = SIGN(PI,O(4,1,2)) ROLL = ROLL + SHIFT ENDIF COC = ROLL/UFLOOR(2) IF (NV3 .GE. 1) THEN A(1) = DE0 - COC IF (NV1 .GE. 1) THEN DO 143 N = 1, NV1 IF (OVP(N)) THEN A(N+1) = (O(4,2,2)*OV(1,2,N) - O(4,1,2)*OV(2,2,N))/ 1 (O(4,2,2)**2 + O(4,1,2)**2) A(N+1) = A(N+1)/UFLOOR(2) ENDIF 143 CONTINUE ENDIF ENDIF 145 CALL GATHER GO TO 1000 C C CONSTRAINT ON ELEVATION C 150 COC = (X0(4,2) + 1 0.5*((X0(4,1) - XINIT)**2 + (X0(4,3) - ZINIT)**2)/REARTH) 2 /UFLOOR(1) IF (NV3 .LT. 1) GO TO 155 CW = 1.0/SD**2 A(1) = DE0 - COC IF (NV1 .LT. 1) GO TO 155 DO 151 N = 1, NV1 IF (OVP(N)) THEN A(N+1) = (X0V(2,N) + (X0V(1,N)*(X0(4,1) - XINIT) 1 + X0V(3,N)*(X0(4,3) - ZINIT))/REARTH)/UFLOOR(1) ENDIF 151 CONTINUE 155 CALL GATHER GO TO 1000 C C CONSTRAINT ON ALGEBRAIC COMBINATION OF MATRIX ELEMENTS C 160 COC = DATA(KCON) IF (NV3 .LT. 1) GO TO 165 CW = 1.0/SD**2 A(1) = DE0 - COC IF (NV1 .LT. 1) GO TO 165 DO 161 N = 1, NV1 161 A(N+1) = DATA(KCON+N) 165 CALL GATHER NP1 = NV1 + 1 GO TO 1000 C C TRANSFER MATRIX CONSTRAINTS C 200 IF (R3P) CALL UPDAT3 IF (J .LT. -20) GO TO 210 IF (J .LT. -10) GO TO 250 IF (J .LT. 0) GO TO 350 GO TO 400 C C R2 MATRIX CONSTRAINT C 210 IF (NORD3 .LT. 1) GO TO 1000 IF (K .GT. 10) GO TO 230 J = - (J + 20) IF (J .LT. 1 .OR. J .GT. 6) GO TO 900 IF (K .LT. 1 .OR. K .GT. 6) GO TO 900 FAC = UBEAM(K)/UBEAM(J) COC = RC2(J,K)*FAC IF (NV3 .GE. 1) THEN CW = 1.0/SD**2 A(1) = DE0 - COC CALL CLI(LOGIC) IF (LOGIC) GO TO 1000 C IF (NV1 .GE. 1) THEN DO 220 N = 1, NV1 IF (R2VP(N)) A(N+1) = R2V(J,K,N)*FAC 220 CONTINUE ENDIF ENDIF CALL GATHER GO TO 1000 C C T2 MATRIX CONSTRAINT C 230 IF (NORD3 .GE. 2) CALL CONSEC GO TO 1000 C C AGS MACHINE CONSTRAINT C 250 J = - (JCON + 10) IF (J .LT. 1 .OR. J .GT. 6) GO TO 900 IF (K .LT. 1 .OR. K .GT. 6) GO TO 900 IF (J .EQ. 5) GO TO 300 IF (NORD3 .GE. 1) CALL AGS GO TO 1000 C C PHASE ADVANCE CONSTRAINT C 300 CALL PHASE GO TO 1000 C C R MATRIX CONSTRAINT C 350 IF (NORD3 .LT. 1) GO TO 1000 J = - J IF (K .GT. 10) GO TO 390 IF (J .LT. 1 .OR. J .GT. 6) GO TO 900 IF (K .LT. 1 .OR. K .GT. 6) GO TO 900 CALL RFIT GO TO 1000 C C T MATRIX CONSTRAINT C 390 IF (NORD3 .GE. 2) CALL CONSEC GO TO 1000 C C BEAM CONSTRAINTS C 400 IF (J .EQ. K) GO TO 500 IF (J .GT. 10 .AND. J .LE. 16) GO TO 600 IF (J .GT. 20 .AND. J .LE. 26) GO TO 510 IF (J .EQ. 0 .OR. J .EQ. 7) GO TO 700 IF (J .EQ. 27) GO TO 750 C C BEAM MATRIX CONSTRAINT C IF (NORD3 .LT. 1) GO TO 1000 IF (.NOT. RECENT) CALL BEAM FAC = 1.0/(UBEAM(J)*UBEAM(K)) IF (J .GT. 6) GO TO 900 IF (K .LT. 1 .OR. K .GT. 6) GO TO 900 COC = SIT(J,K)*FAC IF (NV3 .LT. 1) GO TO 445 CW = 1.0/SD**2 A(1) = DE0 - COC CALL CLI(LOGIC) IF (LOGIC) GO TO 1000 C IF (NV1 .LT. 1) GO TO 445 DO 440 N = 1, NV1 IF (R2P) GO TO 410 IF (.NOT. SVP(N)) GO TO 440 SVJK = SV(J,K,N) GO TO 430 410 SVJK = 0.0 IF (SVP(N)) THEN DO 420 L1 = 1, 6 DO 420 L2 = 1, 6 SVJK = SVJK + RC2(J,L1)*SV(L1,L2,N)*RC2(K,L2) 420 CONTINUE ENDIF IF (R2VP(N)) THEN DO 425 L1 = 1, 6 DO 425 L2 = 1, 6 SVJK = SVJK + R2V(J,L1,N)*SI(L1,L2)*RC2(K,L2) 1 + RC2(J,L1)*SI(L1,L2)*R2V(K,L2,N) 425 CONTINUE ENDIF 430 A(N+1) = SVJK*FAC 440 CONTINUE C 445 CALL GATHER GO TO 1000 C C BEAM SIZE CONSTRAINT C 500 IF (NORD3 .LT. 1) GO TO 1000 IF (J .GT. 6) GO TO 900 CALL EXTENT GO TO 1000 C C ACCELERATOR PARAMETER BEAM CONSTRAINT C 510 CALL SNYDER GO TO 1000 C C BEAM CORRELATION CONSTRAINT C 600 IF (NORD3 .LT. 1) GO TO 1000 J = JCON - 10 K = KCON IF (J .GT. 6) GO TO 900 IF (K .LT. 1 .OR. K .GT. 6) GO TO 900 CALL CORREL GO TO 1000 C C FIRST MOMENT CONSTRAINT C 700 IF (K .LT. 1 .OR. K .GT. 6) GO TO 900 COC = 0.0 IF (SOFA) COC = CO(K)/UBEAM(K) IF (NV3 .LT. 1) GO TO 745 CW = 1.0/SD**2 A(1) = DE0 - COC CALL CLI(LOGIC) IF (LOGIC) GO TO 1000 C IF (.NOT. SOFA) GO TO 745 IF (NV1 .LT. 1) GO TO 745 DO 740 N = 1, NV1 IF (CVP(N)) THEN COTV = COV(K,N) A(N+1) = COTV/UBEAM(K) ENDIF 740 CONTINUE 745 CALL GATHER GO TO 1000 C C CONSTRAINT ON ACCELERATOR FUNCTION ETA C 750 IF (K .LT. 1 .OR. K .GT. 6) GO TO 900 COC = 0.0 IF (RAY) COC = ETA(K)/UBEAM(K) IF (NV3 .LT. 1) GO TO 795 CW = 1.0/SD**2 A(1) = DE0 - COC CALL CLI(LOGIC) IF (LOGIC) GO TO 1000 C IF (.NOT. RAY) GO TO 795 IF (NV1 .LT. 1) GO TO 795 DO 790 N = 1, NV1 IF (EVP(N)) A(N+1) = ETAV(K,N)/UBEAM(K) 790 CONTINUE 795 CALL GATHER GO TO 1000 C C SEXTUPOLE STRENGTH LIMITS C 800 IF (NORD3 .GE. 2) CALL CONSEC GO TO 1000 C C NUMERICAL CONSTANT C 850 A(1) = - ACON IF (NV3 .LT. 1) GO TO 870 DO 860 N = 1, NPVAR 860 A(N+1) = 0.0 870 CALL GATHER GO TO 1000 C C ILLEGAL CONSTRAINT C 900 WRITE (NOUT,9804) 9804 FORMAT (' *** ERROR *** ILLEGAL FORM OF CONSTRAINT') FLUSHL = .TRUE. COC = 0.0 C 1000 RETURN END SUBROUTINE CORREL C C CALCULATES PARTIALS FOR A CONSTRAINT ON THE BEAM ELLIPSE CORRELATION C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM1D.CIN' INCLUDE 'ELM10A.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM10D.CIN' INCLUDE 'RC2.CIN' INCLUDE 'R2P.CIN' INCLUDE 'SI.CIN' INCLUDE 'SVP.CIN' C C LOCAL VARIABLES C LOGICAL LOGIC C C--------------------------------------------------------------- IF (.NOT. RECENT) CALL BEAM J = JCON K = KCON J = J - 10 SIJJ = SIT(J,J) SIKK = SIT(K,K) SIJK = SIT(J,K) W = SIJK/SQRT(SIJJ*SIKK) COC = W IF (NV3 .LT. 1) GO TO 100 CW = 1.0/SD**2 A(1) = DE0 - W CALL CLI(LOGIC) IF (LOGIC) GO TO 150 C IF (NV1 .LT. 1) GO TO 100 DO 90 N = 1, NV1 IF (R2P) GO TO 10 IF (.NOT. SVP(N)) GO TO 90 SVJJ = SV(J,J,N) SVKK = SV(K,K,N) SVJK = SV(J,K,N) GO TO 50 C 10 SVJJ = 0.0 SVKK = 0.0 SVJK = 0.0 IF (SVP(N)) THEN DO 20 L1 = 1, 6 DO 20 L2 = 1, 6 SVJJ = SVJJ + RC2(J,L1)*SV(L1,L2,N)*RC2(J,L2) SVKK = SVKK + RC2(K,L1)*SV(L1,L2,N)*RC2(K,L2) SVJK = SVJK + RC2(J,L1)*SV(L1,L2,N)*RC2(K,L2) 20 CONTINUE ENDIF IF (R2VP(N)) THEN DO 30 L1 = 1, 6 DO 30 L2 = 1, 6 SVJJ = SVJJ + 2.0*R2V(J,L1,N)*SI(L1,L2)*RC2(J,L2) SVKK = SVKK + 2.0*R2V(K,L1,N)*SI(L1,L2)*RC2(K,L2) SVJK = SVJK + R2V(J,L1,N)*SI(L1,L2)*RC2(K,L2) 1 + RC2(J,L1)*SI(L1,L2)*R2V(K,L2,N) 30 CONTINUE ENDIF 50 ANC = SVJK/SIJK - 0.5*(SVJJ/SIJJ + SVKK/SIKK) A(N+1) = W*ANC 90 CONTINUE 100 CALL GATHER C 150 RETURN END SUBROUTINE CSAVE INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'BSH.CIN' INCLUDE 'CCENT.CIN' INCLUDE 'ELM20.CIN' INCLUDE 'OC.CIN' INCLUDE 'XYZOLD.CIN' C--------------------------------------------------------------- REAL POS(3) C LCOLD = LCPOS TOTRC = TOTROT DO 24 J = 1, 3 DO 24 K = 1, 3 OOLD(J,K) = O(4,J,K) 24 CONTINUE DO 25 J = 1, 3 POS(J) = X0(4,J) 25 CONTINUE XOLD = POS(1) YOLD = POS(2) ZOLD = POS(3) RETURN END SUBROUTINE DAMAGE C C CALCULATE TRANSFER MATRIX IN CASE OF MISALIGNMENTS FOR TABLE C C LIST OF COMMON BLOCKS C INCLUDE 'COACOM.CIN' INCLUDE 'ELM8H.CIN' INCLUDE 'ELM8J.CIN' INCLUDE 'ELM8M.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'R.CIN' C C LOCAL VARIABLES C LOGICAL DCOM DIMENSION COMS(6), WORK(6,6) C-------------------------------------------------------------- C C LOOP OVER POSSIBLE TABLE ENTRIES C DO 200 N = 1, NMMAX IF (.NOT. LNMT(N)) GO TO 200 DO 190 M = 1, 6 DCOM = .FALSE. CALL ROTOR C C DISPLACEMENT OF AXIS BY MISALIGNMENT C DO 20 J = 1, 6 COA(J) = COM(J,M,N) IF (COA(J) .NE. 0.0) DCOM = .TRUE. 20 CONTINUE C C ADVANCEMENT OF DISPLACED AXIS C DO 30 J = 1, 6 COMS(J) = COM(J,M,N) 30 CONTINUE CALL THREAD(0,COMS) DO 35 J = 1, 6 COM(J,M,N) = COMS(J) 35 CONTINUE C C REEVALUATION OF TRANSFER MATRIX ELEMENTS TO TO SHIFTED AXIS C IF (DCOM .AND. NORD1 .GE. 2 .AND. NORD2 .GE. 1) CALL ENRIM C C ACCUMULATION OF TRANSFER MATRIX C IF (R2PM(N)) GO TO 100 L1L2 = 0 DO 60 L2 = 1, 6 DO 60 L1 = 1, 6 L1L2 = L1L2 + 1 RC2M(L1L2,M,N) = R(L1,L2) 60 CONTINUE GO TO 140 C 100 DO 120 L1 = 1, 6 KL2 = 0 DO 120 L2 = 1, 6 S = 0.0 DO 115 K = 1, 6 KL2 = KL2 + 1 S = S + R(L1,K)*RC2M(KL2,M,N) 115 CONTINUE WORK(L1,L2) = S 120 CONTINUE C L1L2 = 0 DO 130 L2 = 1, 6 DO 130 L1 = 1, 6 L1L2 = L1L2 + 1 RC2M(L1L2,M,N) = WORK(L1,L2) 130 CONTINUE C 140 DO 160 J = 1, 6 160 CONTINUE C 190 CONTINUE R2PM(N) = .TRUE. 200 CONTINUE C RETURN END REAL FUNCTION DATAR(IADR) C C FETCHES VALUE STORED OR REFERRED TO IN DATA ARRAY C C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA0A.CIN' INCLUDE 'DATA0B.CIN' C C LOCAL VARIABLES C EXTERNAL IDATA C C------------------------------------------------------ C IADS = IADR 10 IF (TIE(IADS) .EQ. 100) THEN IADS = IDATA(IADS) GO TO 10 ENDIF DATAR = DATA(IADS) RETURN END SUBROUTINE DBEAMS C C CALCULATES PARTIAL DERIVATIVES OF THE INITIAL BEAM MATRIX C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'COCOM.CIN' INCLUDE 'ELM0E.CIN' INCLUDE 'ELM1A.CIN' INCLUDE 'ELM1B.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM13B.CIN' INCLUDE 'ELM15C.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'SI.CIN' INCLUDE 'SVP.CIN' C C LOCAL VARIABLES C INTEGER J, JU, K REAL EPSC, SIGG C------------------------------------------------------------------------------- C SIGG = DPARM NV2 = IABS(NV2) IF (NORD3 .LT. 1) GO TO 100 IF (.NOT. SVP(NV2)) THEN DO 110 J = 1, 6 COV(J,NV2) = 0.0 DO 110 K = 1, 6 SV(J,K,NV2) = 0.0 110 CONTINUE ENDIF C IF (ACCEL .OR. LTWISS) THEN IF ((ACCEL .AND. (JV .EQ. 1 .OR. JV .EQ. 3)) 1 .OR. JV .EQ. 10 .OR. JV .EQ. 13) THEN IF (JV .EQ. 1 .OR. JV .EQ. 10) THEN JU = 1 EPSC = EPSX ELSE JU = 3 EPSC = EPSY ENDIF SV(JU,JU,NV2) = SIGG*EPSC*UBEAM(JU)/UBEAM(JU+1) SV(JU+1,JU+1,NV2) = - SIGG*EPSC*SI(JU+1,JU+1)*UBEAM(JU)/ 1 (SI(JU,JU)*UBEAM(JU+1)) ELSE IF ((ACCEL .AND. (JV .EQ. 2 .OR. JV .EQ. 4)) 1 .OR. JV .EQ. 11 .OR. JV .EQ. 14) THEN IF (JV .EQ. 2 .OR. JV .EQ. 11) THEN JU = 2 EPSC = EPSX ELSE JU = 4 EPSC = EPSY ENDIF SV(JU-1,JU,NV2) = - SIGG*EPSC SV(JU,JU-1,NV2) = - SIGG*EPSC SV(JU,JU,NV2) = - 2.0*SIGG*EPSC*SI(JU-1,JU)/SI(JU-1,JU-1) ENDIF ELSE SV(JV,JV,NV2) = SV(JV,JV,NV2) 1 + 2.0*SIGG*SQRT(SI(JV,JV))*UBEAM(JV) ENDIF SVP(NV2) = .TRUE. 100 RETURN END SUBROUTINE DBEND2 C C CALCULATES PARTIAL DERIVATIVES OF THE SECOND-ORDER C TRANSFER MATRIX OF A BENDING MAGNET C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'COP.CIN' INCLUDE 'ELM0B.CIN' INCLUDE 'ELM0E.CIN' INCLUDE 'ELM4A.CIN' INCLUDE 'ELM4D.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'HSINT.CIN' INCLUDE 'HSINTA.CIN' INCLUDE 'HPINT.CIN' INCLUDE 'HPINTA.CIN' INCLUDE 'INDBND.CIN' INCLUDE 'R.CIN' INCLUDE 'T.CIN' INCLUDE 'TERMS.CIN' INCLUDE 'VSINT.CIN' INCLUDE 'VSINTA.CIN' INCLUDE 'VPINT.CIN' INCLUDE 'VPINTA.CIN' INCLUDE 'WMN.CIN' C C LOCAL VARIABLES C REAL DBEB, DBEP, GLOP, H, HEX, RH, WM5N C------------------------------------------------------------------------------- C IF (JV .EQ. NBDB .OR. JV .EQ. NK2) GO TO 10 IF (JV .EQ. NBDBP .OR. JV .EQ. NK2P) GO TO 50 GO TO 100 C C VARIATION OF SEXTUPOLE COMPONENT C 10 IF (SOFA) LINEAR = .FALSE. DBEB = DPARM/(H0*UNITI(1))**2 IF (JV .EQ. NK2) DBEB = DBEB/(H0*UNITI(8))**3 WM5N = 1.0 - 5.0*NB + RMPS*(2.0 - 5.0*NB) HEX = RMPS*H0 H = H0 + HEX RH = 1.0 + RMPS C RV(1,1) = RV(1,1) + 2.0*HEX*H0*DBEB*HSCDX RV(1,2) = RV(1,2) + 2.0*RMPS*DBEB*HSSDX RV(1,6) = RV(1,6) + 2.0*HEX*DBEB*HSDX2 RV(2,1) = RV(2,1) + 2.0*HEX*H0*DBEB*HPCDX RV(2,2) = RV(2,2) + 2.0*HEX*DBEB*H0*HPSDX RV(2,6) = RV(2,6) + 2.0*HEX*DBEB*HPDX2 RV(3,3) = RV(3,3) - 2.0*HEX*DBEB*H0*VSDCM RV(3,4) = RV(3,4) - 2.0*RMPS*DBEB*VSDSM RV(4,3) = RV(4,3) - 2.0*HEX*DBEB*H0*VPDCM RV(4,4) = RV(4,4) - 2.0*HEX*DBEB*H0*VPDSM C TV(1,1) = - H0**2*H*DBEB*HSCX2 TV(1,2) = - 2.0*H0**2*H*DBEB*HSCSX TV(1,3) = - DBEB*H*HSSX2 TV(1,6) = H0**2*H*DBEB*HSCY2 TV(1,9) = 2.0*H*DBEB*HSCSY TV(1,10) = H*DBEB*HSSY2 TV(1,16) = - 2.0*H0*H*DBEB*HSCDX TV(1,17) = - 2.0*RH*DBEB*HSSDX TV(1,21) = - H*DBEB*HSDX2 TV(2,1) = - H0**2*H*DBEB*HPCX2 TV(2,2) = - 2.0*H0**2*H*DBEB*HPCSX TV(2,3) = - H0**2*H*DBEB*HPSX2 TV(2,6) = H0**2*H*DBEB*HPCY2 TV(2,9) = 2.0*H0**2*H*DBEB*HPCSY TV(2,10) = H*DBEB*HPSY2 TV(2,16) = - 2.0*DBEB*H0*H*HPCDX TV(2,17) = - 2.0*H0*H*DBEB*HPSDX TV(2,21) = - H*DBEB*HPDX2 TV(3,4) = 2.0*H0**2*H*DBEB*VSCCM TV(3,5) = 2.0*H*DBEB*VSSCM TV(3,5) = 2.0*H*DBEB*VSCSM TV(3,8) = 2.0*H*DBEB*VSSSM TV(3,18) = 2.0*H0*H*DBEB*VSDCM TV(3,19) = 2.0*RH*DBEB*VSDSM TV(4,4) = 2.0*H0**2*H*DBEB*VPCCM TV(4,5) = 2.0*H0**2*H*DBEB*VPSCM TV(3,5) = 2.0*H0**2*H*DBEB*VPCSM TV(4,8) = 2.0*H*DBEB*VPSSM TV(4,18) = 2.0*H0*H*DBEB*VPDCM TV(4,19) = 2.0*H0*H*DBEB*VPDSM TV(5,1) = H0**2*DBEB*(3.0*L - SX*CX - 2.0*SX)/(6.0*WMN) TV(5,2) = 2.0*DBEB*(1.0 - CX)/(3.0*WMN**2) 1 - 2.0*H0**2*DBEB*SX**2/(6.0*WMN) TV(5,3) = DBEB*(3.0*L - 4.0*SX + SX*CX)/(6.0*WMN**2) TV(5,6) = - DBEB*(2.0*H0**2*(1.0 - 3.0*NB)*(L - SX)/WMN 1 - H0**2*(L - SY*CY))/(2.0*WM5N) TV(5,9) = - DBEB*(H0**2*SY**2/WM5N 1 - 2.0*(1.0 - CX)/(WM5N*WMN)) IF (NB .NE. 0.0) GLOP = (L - SY*CY)/(2.0*NB) IF (NB .EQ. 0.0) GLOP = H0**2*L**3/3.0 TV(5,10) = - DBEB*(GLOP - 2.0*(L - SX)/WMN)/WM5N TV(5,16) = DBEB*(H0*SMLCX/WMN**2 1 - 2.0*H0*(L - SX)/(3.0*WMN**2) 2 - H0*(L - SX*CX)/(3.0*WMN**2)) TV(5,17) = DBEB*(4.0*H0*DISN/(3.0*WMN**2) 1 + (H0*L*SX - H0*SX**2/3.0)/WMN**2) TV(5,21) = DBEB*(4.0*(L - SX)/3.0 - SX + L*CX 1 + (L - CX*SX)/6.0)/WMN**3 GO TO 100 C C VARIATION OF SKEW SEXTUPOLE COMPONENT C 50 IF (SOFA) LINEAR = .FALSE. DBEP = DPARM*RNMS/(H0*UNITI(1))**2 IF (JV .EQ. NK2P) DBEP = DBEP/(H0*UNITI(8))**3 C TV(1,4) = 2.0*DBEP*H0**3*HSCCM TV(1,7) = 2.0*DBEP*H0*HSCSM TV(1,5) = 2.0*DBEP*H0*HSSCM TV(1,8) = 2.0*DBEP*H0*HSSSM TV(1,18) = 2.0*DBEP*HSDCM TV(1,19) = 2.0*DBEP*HSDSM TV(2,4) = 2.0*DBEP*H0**3*HPCCM TV(2,7) = 2.0*DBEP*H0**3*HPCSM TV(2,5) = 2.0*DBEP*H0**3*HPSCM TV(2,8) = 2.0*DBEP*H0*HPSSM TV(2,18) = 2.0*DBEP*H0**2*HPDCM TV(2,19) = 2.0*DBEP*H0**2*HPDSM TV(3,1) = DBEP*H0**3*VSCX2 TV(3,2) = 2.0*DBEP*H0*VSCSX TV(3,3) = DBEP*H0*VSSX2 TV(3,16) = 2.0*DBEP*VSCDX TV(3,17) = 2.0*DBEP*VSSDX TV(3,21) = DBEP*H0*VSDX2 TV(3,6) = - DBEP*H0**3*VSCY2 TV(3,9) = - 2.0*DBEP*H0**3*VSCSY TV(3,10) = - DBEP*H0*VSSY2 TV(4,1) = DBEP*H0**3*VPCX2 TV(4,2) = 2.0*DBEP*H0**3*VPCSX TV(4,3) = DBEP*H0*VPSX2 TV(4,16) = 2.0*DBEP*H0**2*VPCDX TV(4,17) = 2.0*DBEP*VPSDX TV(4,21) = DBEP*H0*VPDX2 TV(4,6) = - DBEP*H0**3*VPCY2 TV(4,9) = - 2.0*DBEP*H0**3*VPCSY TV(4,10) = - DBEP*H0**3*VPSY2 C 100 RETURN END SUBROUTINE DBEND3 C C CALCULATES PARTIAL DERIVATIVES OF THE THIRD-ORDER C TRANSFER MATRIX OF A BENDING MAGNET C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM0E.CIN' INCLUDE 'ELM4A.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'HSINT3.CIN' INCLUDE 'HPINT3.CIN' INCLUDE 'INDBND.CIN' INCLUDE 'U.CIN' INCLUDE 'VSINT3.CIN' INCLUDE 'VPINT3.CIN' C------------------------------------------------------------------------------- C IF (JV .NE. NGAM .AND. JV .NE. NK3) GO TO 100 IF (H0 .EQ. 0) GO TO 100 DGAB = DPARM/(H0*UNITI(1))**3 IF (JV .EQ. NK3) DGAB = DGAB/(H0*UNITI(8))**4 UV(1,1) = - DGAB*H0**4*HSCCC0 UV(1,2) = - 3.0*DGAB*H0**4*HSCCS0 UV(1,3) = - 3.*DGAB*H0**4*HSCSS0 UV(1,4) = - DGAB*H0**4*HSSSS0 UV(1,8) = 3.0*DGAB*H0**4*HSCCC2 UV(1,9) = 3.0*DGAB*H0**4*HSSCC2 UV(1,14) = 6.0*DGAB*H0**4*HSCCS2 UV(1,15) = 6.0*DGAB*H0**4*HSSCS2 UV(1,17) = 3.0*DGAB*H0**4*HSCSS2 UV(1,18) = 3.0*DGAB*H0**4*HSSSS2 UV(1,36) = - 3.0*DGAB*H0**4*HSCCD0 UV(1,37) = - 6.0*DGAB*H0**4*HSCSD0 UV(1,38) = - 3.0*DGAB*H0**4*HSSSD0 UV(1,41) = 3.0*DGAB*H0**4*HSDCC2 UV(1,44) = 6.0*DGAB*H0**4*HSDCS2 UV(1,45) = 3.0*DGAB*H0**4*HSDSS2 UV(1,51) = - 3.0*DGAB*H0**4*HSCDD0 UV(1,52) = - 3.0*DGAB*H0**4*HSSDD0 UV(1,56) = - DGAB*H0**4*HSDDD0 C UV(2,1) = - DGAB*H0**4*HPCCC0 UV(2,2) = - 3.0*DGAB*H0**4*HPCCS0 UV(2,3) = - 3.0*DGAB*H0**4*HPCSS0 UV(2,4) = - DGAB*H0**4*HPSSS0 UV(2,8) = 3.0*DGAB*H0**4*HPCCC2 UV(2,9) = 3.0*DGAB*H0**4*HPSCC2 UV(2,14) = 6.0*DGAB*H0**4*HPCCS2 UV(2,15) = 6.0*DGAB*H0**4*HPSCS2 UV(2,17) = 3.0*DGAB*H0**4*HPCSS2 UV(2,18) = 3.0*DGAB*H0**4*HPSSS2 UV(2,36) = - 3.0*DGAB*H0**4*HPCCD0 UV(2,37) = - 6.0*DGAB*H0**4*HPCSD0 UV(2,38) = - 3.0*DGAB*H0**4*HPSSD0 UV(2,41) = 3.0*DGAB*H0**4*HPDCC2 UV(2,44) = 6.0*DGAB*H0**4*HPDCS2 UV(2,45) = 3.0*DGAB*H0**4*HPDSS2 UV(2,51) = - 3.0*DGAB*H0**4*HPCDD0 UV(2,52) = - 3.0*DGAB*H0**4*HPSDD0 UV(2,56) = - DGAB*H0**4*HPDDD0 C UV(3,5) = 3.0*DGAB*H0**4*VSCCC1 UV(3,6) = 6.0*DGAB*H0**4*VSCSC1 UV(3,7) = 3.0*DGAB*H0**4*VSSSC1 UV(3,10) = - DGAB*H0**4*VSCCC3 UV(3,11) = 3.0*DGAB*H0**4*VSCCS1 UV(3,12) = 6.0*DGAB*H0**4*VSCSS1 UV(3,13) = 3.0*DGAB*H0**4*VSSSS1 UV(3,16) = - 3.0*DGAB*H0**4*VSCCS3 UV(3,19) = - 3.0*DGAB*H0**4*VSCSS3 UV(3,20) = - DGAB*H0**4*VSSSS3 UV(3,39) = 6.0*DGAB*H0**4*VSCDC1 UV(3,40) = 6.0*DGAB*H0**4*VSSDC1 UV(3,42) = 6.0*DGAB*H0**4*VSCDS1 UV(3,43) = 6.0*DGAB*H0**4*VSSDS1 UV(3,53) = 3.0*DGAB*H0**4*VSDDC1 UV(3,54) = 3.0*DGAB*H0**4*VSDDS1 C UV(4,5) = 3.0*DGAB*H0**4*VPCCC1 UV(4,6) = 6.0*DGAB*H0**4*VPCSC1 UV(4,7) = 3.0*DGAB*H0**4*VPSSC1 UV(4,10) = - DGAB*H0**4*VPCCC3 UV(4,11) = 3.0*DGAB*H0**4*VPCCS1 UV(4,12) = 6.0*DGAB*H0**4*VPCSS1 UV(4,13) = 3.0*DGAB*H0**4*VPSSS1 UV(4,16) = - 3.0*DGAB*H0**4*VPCCS3 UV(4,19) = - 3.0*DGAB*H0**4*VPCSS3 UV(4,20) = - DGAB*H0**4*VPSSS3 UV(4,39) = 6.0*DGAB*H0**4*VPCDC1 UV(4,40) = 6.0*DGAB*H0**4*VPSDC1 UV(4,42) = 6.0*DGAB*H0**4*VPCDS1 UV(4,43) = 6.0*DGAB*H0**4*VPSDS1 UV(4,53) = 3.0*DGAB*H0**4*VPDDC1 UV(4,54) = 3.0*DGAB*H0**4*VPDDS1 C 100 RETURN END SUBROUTINE DBENDI C C CALCULATES PARTIAL DERIVATIVES OF THE FIRST-ORDER C TRANSFER MATRIX OF A BENDING MAGNET C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM0B.CIN' INCLUDE 'ELM0E.CIN' INCLUDE 'ELM1A.CIN' INCLUDE 'ELM4A.CIN' INCLUDE 'ELM4B.CIN' INCLUDE 'ELM4C.CIN' INCLUDE 'ELM4D.CIN' INCLUDE 'ELM5A.CIN' INCLUDE 'ELM5B.CIN' INCLUDE 'ELM7B.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM10E.CIN' INCLUDE 'ELM13A.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'ELM16B.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'ELM28.CIN' INCLUDE 'INDBND.CIN' INCLUDE 'INDPAR.CIN' INCLUDE 'R.CIN' INCLUDE 'TERMS.CIN' INCLUDE 'WMN.CIN' C C LOCAL VARIABLES C REAL KVKH, KVKV C C-------------------------------------------------------------- IL = IPTOJ(NL) IB = IPTOJ(NBV) IRHO = IPTOJ(NRHO) IANG = IPTOJ(NANG) IK1 = IPTOJ(NK1) RH = 1.0 + RMPS IF (JV .EQ. NL) GO TO 10 IF (JV .EQ. NBV) GO TO 20 IF (JV .EQ. NRHO) GO TO 30 IF (JV .EQ. NANG) GO TO 40 IF (JV .EQ. NN) GO TO 50 IF (JV .EQ. NK1) GO TO 60 IF (JV .EQ. NRMPS) GO TO 140 IF (JV .EQ. NRNMS) GO TO 150 IF (JV .EQ. NVR) GO TO 160 IF (JV .EQ. NNP) GO TO 170 IF (JV .EQ. NK1P) GO TO 170 IF (JV .EQ. NTILT) GO TO 180 GO TO 500 C C MAGNET LENGTH IS VARIED C 10 LV = DPARM*UNITI(8) LVE = LV IF (IB .NE. 0 .OR. IRHO .NE. 0) THEN IF (TYPE .EQ. 28) THEN SNA2 = 0.5*H0*LRBEND CSA2 = SQRT(1.0 - SNA2**2) LVE = LVE/CSA2 ENDIF GO TO 100 ELSE IF (IANG .NE. 0) THEN IF (TYPE .EQ. 28) LVE = LVE*LBEND/LRBEND IF (IK1 .EQ. 0) THEN GO TO 110 ELSE KVKH = - H0**2*LVE/LBEND KVKV = 0.0 HV = - H0*LVE/LBEND GO TO 130 ENDIF ENDIF RETURN C C MAGNETIC FIELD IS VARIED C 20 IF (IL .NE. 0 .AND. IK1 .EQ. 0) THEN KVK = DPARM*B*UNITI(9)/(RI*PREF) KVKH = KVK*WMN KVKV = KVK*RH*NB HV = DPARM*UNITI(9)/PREF IF (TYPE .EQ. 28) THEN SNA2 = 0.5*H0*LRBEND CSA2 = SQRT(1.0 - SNA2**2) LVE = ( - L + LRBEND/CSA2)*UNITI(9)/B ENDIF GO TO 120 ELSE IF (IL .NE. 0 .AND. IK1 .NE. 0) THEN KVKH = DPARM*B*UNITI(9)/(RI*PREF) KVKV = 0.0 HV = DPARM*UNITI(9)/PREF IF (TYPE .EQ. 28) THEN SNA2 = 0.5*H0*LRBEND CSA2 = SQRT(1.0 - SNA2**2) LVE = (- L + LRBEND/CSA2)*UNITI(9)/B ENDIF GO TO 120 ELSE IF (IANG .NE. 0 .AND. IK1 .EQ. 0) THEN LVE = - DPARM*UNITI(9)*RI**2*AL/(B**2*PREF) GO TO 110 ELSE IF (IANG .NE. 0 .AND. IK1 .NE. 0) THEN LVE = - DPARM*L*UNITI(9)/B KVKH = H0*UNITI(9)/PREF KVKV = 0.0 HV = UNITI(9)/PREF GO TO 130 ENDIF GO TO 500 C C RADIUS OF CURVATURE OF REFERENCE ORBIT IS VARIED C 30 IF (IL .NE. 0 .AND. IK1 .EQ. 0) THEN KVK = - DPARM*H0**3*UNITI(8) KVKH = KVK*WMN KVKV = KVK*RH*NB HV = - H0**2*UNITI(8) SNA2 = 0.5*H0*LRBEND CSA2 = SQRT(1.0 - SNA2**2) LVE = (AL - H0*LRBEND/CSA2)*UNITI(8) GO TO 120 ELSE IF (IL .NE. 0 .AND. IK1 .NE. 0) THEN KVKH = - DPARM*H0**3*UNITI(8) KVKV = 0.0 HV = - H0**2*UNITI(8) IF (TYPE .EQ. 28) THEN SNA2 = 0.5*H0*LRBEND CSA2 = SQRT(1.0 - SNA2**2) LVE = (AL - H0*LRBEND/CSA2)*UNITI(8) ENDIF GO TO 120 ELSE IF (IANG .NE. 0 .AND. IK1 .EQ. 0) THEN LVE = DPARM*AL*UNITI(8) GO TO 110 ELSE IF (IANG .NE. 0 .AND. IK1 .NE. 0) THEN LVE = DPARM*AL*UNITI(8) KVKH = - H0**3*UNITI(8) KVKV = 0.0 HV = - H0**2*UNITI(8) GO TO 130 ENDIF GO TO 500 C C BEND ANGLE IS VARIED C 40 IF (IL .NE. 0 .AND. IK1 .EQ. 0) THEN KVK = DPARM*H0*UNITI(7)/LBEND KVKH = KVK*WMN KVKV = KVK*RH*NB HV = UNITI(7)/LBEND IF (AL .NE. 0.0) THEN LVE = 0.5*LRBEND*(1.0 - 0.5*AL/TAN(0.5*AL))/SIN(0.5*AL) 1 *UNITI(7) ELSE LVE = 0.0 ENDIF GO TO 120 ELSE IF (IL .NE. 0 .AND. IK1 .NE. 0) THEN IF (TYPE .EQ. 4 .OR. TYPE .EQ. 29) THEN KVKH = DPARM*H0*UNITI(7)/L KVKV = 0.0 HV = UNITI(7)/LBEND GO TO 120 ELSE SNA2 = 0.5*H0*LRBEND CSA2 = SQRT(1.0 - SNA2**2) KVKH = 2.0*SNA2*CSA2*UNITI(7)/LRBEND**2 KVKV = 0.0 HV = CSA2*UNITI(7)/LRBEND RHO = 0.0 IF (H0 .NE. 0.0) RHO = 1.0/H0 LVE = RHO*(1.0 - L*CSA2/LRBEND)*UNITI(7) GO TO 130 ENDIF ELSE IF (IB .NE. 0 .OR. IRHO .NE. 0) THEN RHO = 0.0 IF (H0 .NE. 0.0) RHO = 1.0/H0 LVE = DPARM*RHO*UNITI(7) GO TO 100 ENDIF RETURN C C DIMENSIONLESS FIELD INDEX N IS VARIED C 50 KVKH = - 0.5*DPARM*H0**2 KVKV = 0.5*DPARM*H0**2*RH HV = 0.0 LVE = 0.0 GO TO 120 C C FIELD INDEX K1 IS VARIED C 60 KVKH = 0.5*DPARM*UNITI(8)**2 KVKV = - 0.5*DPARM*UNITI(8)**2 HV = 0.0 LVE = 0.0 GO TO 120 C C LENGTH CHANGES BUT FIELD STAYS CONSTANT C 100 LINEAR = .FALSE. JQUAD = 1 KQ2 = KX2 CALL DFOL JQUAD = 3 KQ2 = KY2 CALL DFOL RV(1,6) = H0*SX*LVE RV(5,2) = - RV(1,6) RV(2,6) = H0*CX*LVE RV(5,1) = - RV(2,6) RV(5,6) = (CX - 1.0)*LVE/WMN GO TO 500 C C LENGTH CHANGES BUT BEND ANGLE STAYS CONSTANT C 110 RV(1,2) = SX*LVE/L RV(2,1) = KX2*SX*LVE/L RV(3,4) = SY*LVE/L RV(4,3) = KY2*SY*LVE/L RV(1,6) = DISP*LVE/L RV(5,2) = - DISP*LVE/L RV(5,6) = R56*LVE/L GO TO 500 C C MAGNETIC FIELD OR FIELD INDEX IS VARIED BUT LENGTH STAYS CONSTANT C 120 LINEAR = .FALSE. JQUAD = 1 H = H0*(1.0 + RMPS) KQ2 = KX2 KVK = KVKH CALL DFOCUS JQUAD = 3 KQ2 = KY2 KVK = KVKV CALL DFOCUS IF (TYPE .EQ. 28) THEN RV(1,1) = RV(1,1) - KX2*SX*LVE RV(1,2) = RV(1,2) + CX*LVE RV(2,1) = RV(2,1) - KX2*CX*LVE RV(2,2) = RV(2,2) - KX2*SX*LVE RV(3,3) = RV(3,3) - KY2*SY*LVE RV(3,4) = RV(3,4) + CY*LVE RV(4,3) = RV(4,3) - KY2*CY*LVE RV(4,4) = RV(4,4) - KY2*SY*LVE ENDIF IF (KX2 .NE. 0.0) RV(1,6) = (- 2.0*DISP + H0*L*SX)*KVKH/KX2 1 + HV*DISP/H0 IF (TYPE .EQ. 28) RV(1,6) = RV(1,6) + H0*SX*LVE RV(5,2) = - RV(1,6) IF (TYPE .EQ. 28) RV(2,6) = RV(2,6) + H0*CX*LVE IF (KX2 .NE. 0.0) RV(2,6) = H*RV(1,2) + HV*DDISP/H0 RV(5,1) = - RV(2,6) IF (KX2 .NE. 0.0) 1 RV(5,6) = (- 3.0*R56 - H0*L*DISP)*KVKH/KX2 + 2.0*R56*HV/H0 GO TO 500 C C LENGTH IS VARIED BUT FIELD AND K1 STAY CONSTANT C 130 LINEAR = .FALSE. RV(1,1) = - (KX2*LVE + L*KVKH)*SX RV(1,2) = LVE*CX + (L*CX - SX)*KVKH/KX2 RV(2,1) = - KX2*LVE*CX - (SX + L*CX)*KVKH RV(2,2) = RV(1,1) RV(3,3) = K1*LVE*SY RV(3,4) = CY*LVE RV(4,3) = K1*LVE*CY RV(4,4) = RV(3,3) RV(1,6) = (HV/KX2 - 2.0*H0*KVKH/KX2**2)*(1.0 - CX) 1 + H0*SX*LBEND*KVKH/KX2 + H0*SX*LVE RV(5,2) = - RV(1,6) RV(2,6) = HV*SX + H0*RV(1,2) RV(5,1) = - RV(2,6) RV(5,6) = (AL**2*RV(1,2) + 1 ( - AL**2 + 2.0*K1*L*R56)*LVE)/(AL**2 - K1*L**2) GO TO 500 C C EXCESS FIELD FRACTION RMPS IS VARIED C 140 LINEAR = .FALSE. HEX = RMPS*H0 H = H0 + HEX DHEX = DPARM*H0 DCOV = .TRUE. CODV(1) = - DPARM*DISP CODV(2) = - DPARM*DDISP SKX = KX2*SX SKY = KY2*SY DCXX = - H0*DHEX*(2.0 - NB) DCYY = - H0*DHEX*NB RV(1,1) = 0.5*DCXX*L*SX RV(1,2) = 0.5*DCXX*SMLCX/KX2 RV(2,1) = 0.5*DCXX*(SX + L*CX) RV(2,2) = 0.5*DCXX*L*SX RV(1,6) = DHEX*DISN 1 + H*DCXX*(1.0 - CX - 0.5*L*SKX)/KX2**2 RV(2,6) = DHEX*SX 1 + 0.5*H*DCXX*(SKX - KX2*L*CX)/KX2**2 RV(3,3) = 0.5*DCYY*L*SY IF (KY2 .NE. 0.0) RV(3,4) = 0.5*DCYY*(SY - L*CY)/KY2 RV(4,3) = 0.5*DCYY*(SY + L*CY) RV(4,4) = 0.5*DCYY*L*SY GO TO 500 C C SKEW FIELD MULTIPLIER RNMS IS VARIED C 150 HEX = RMPS*H0 V = VRN*H0 IF (V .NE. 0.0) DCOV = .TRUE. DV = DPARM*V H = H0 + HEX CODV(3) = DPARM*V*SY**2/(1.0 + CY) CODV(4) = DPARM*V*SY SKX = KX2*SX SKY = KY2*SY DCXY = H0*(V - H0*NPN) DCYX = H0*(2.0*V - H0*NPN) RV(1,3) = DCXY*(CY - CX)/(KX2 - KY2) RV(1,4) = DCXY*(SY - SX)/(KX2 - KY2) RV(2,3) = DCXY*(SKX - SKY)/(KX2 - KY2) RV(2,4) = DCXY*(CY - CX)/(KX2 - KY2) RV(3,1) = DCYX*(CX - CY)/(KY2 - KX2) RV(3,2) = DCYX*(SX - SY)/(KY2 - KX2) RV(4,1) = DCYX*(SKY - SKX)/(KY2 - KX2) RV(4,2) = DCYX*(CX - CY)/(KY2 - KX2) RV(3,6) = - DV*SY**2/(1.0 + CY) 1 + H*DCYX*(DSVN + (CX - CY)/(KX2 - KY2))/KX2 RV(4,6) = - DV*SY 1 + H*DCYX*(SY - (SKX - SKY)/(KX2 - KY2))/KX2 GO TO 500 C C NORMALIZED SKEW DIPOLE FIELD IS VARIED C 160 DCOV = .TRUE. HEX = RMPS*H0 H = H0 + HEX SKX = KX2*SX SKY = KY2*SY DV = DPARM*H0 CODV(3) = DPARM*RNMS*H0*SY**2/(1.0 + CY) CODV(4) = DPARM*RNMS*H0*SY DCXY = DPARM*H0*RNMS*DV DCYX = 2.0*DPARM*H*RNMS*DV RV(1,3) = DCXY*(CX - CY)/(KY2 - KX2) RV(1,4) = DCXY*(SX - SY)/(KY2 - KX2) RV(2,3) = DCXY*(SKX - SKY)/(KX2 - KY2) RV(2,4) = DCXY*(CX - CY)/(KY2 - KX2) RV(3,1) = DCYX*(CX - CY)/(KY2 - KX2) RV(3,2) = DCYX*(SX - SY)/(KY2 - KX2) RV(4,1) = DCYX*(SKX - SKY)/(KX2 - KY2) RV(4,2) = DCYX*(CX - CY)/(KY2 - KX2) RV(3,6) = - DV*RNMS*SY**2/(1.0 + CY) 1 + H*DCYX*(DSVN + (CX - CY)/(KX2 - KY2))/KX2 RV(4,6) = - DV*RNMS*SY 1 + H*DCYX*(SY - (SKX - SKY)/(KX2 - KY2))/KX2 GO TO 500 C C NORMALIZED SKEW QUADRUPOLE FIELD IS VARIED C 170 HEX = RMPS*H0 H = H0 + HEX SKX = KX2*SX SKY = KY2*SY DCXY = - DPARM*H0**2*RNMS DCYX = - DPARM*H0**2*RNMS IF (JV .EQ. NK1P) THEN DCXY = DCXY/(UNITI(8)*H0)**2 DCYX = DCYX/(UNITI(8)*H0)**2 ENDIF RV(1,3) = DCXY*(CY - CX)/(KX2 - KY2) RV(1,4) = DCXY*(SY - SX)/(KX2 - KY2) RV(2,3) = DCXY*(SKX - SKY)/(KX2 - KY2) RV(2,4) = DCXY*(CY - CX)/(KX2 - KY2) RV(3,1) = DCYX*(CX - CY)/(KY2 - KX2) RV(3,2) = DCYX*(SX - SY)/(KY2 - KX2) RV(4,1) = DCYX*(SKX - SKY)/(KX2 - KY2) RV(4,2) = DCYX*(CX - CY)/(KY2 - KX2) RV(3,6) = H*DCYX*(DSVN + (CX - CY)/(KX2 - KY2))/KX2 RV(4,6) = H*DCYX*(SY - (SKX - SKY)/(KX2 - KY2))/KX2 GO TO 500 C C TILT IS VARIED C 180 IF (JV .EQ. NTILT .AND. REFER) THEN CALL DSROTR ENDIF C C RETURN C 500 RETURN END SUBROUTINE DEFINE C C KEEPS TRACK OF DEFINED SECTIONS (24. ELEMENT) C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA1C.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0F.CIN' INCLUDE 'ELM24A.CIN' INCLUDE 'ELM24B.CIN' INCLUDE 'ELM24C.CIN' INCLUDE 'FLUSHC.CIN' INCLUDE 'IOUNIT.CIN' C C LOCAL VARIABLES INTEGER J C C------------------------------------------------------------------------ J = JDEF GO TO (100,200,300,300), J C C BEGINNING OF DEFINED SECTION C 100 IF (.NOT. ATWORK) GO TO 400 IF (NDLEV .EQ. 0) GO TO 400 IF (LABEL(NUM) .EQ. NDN(NDLEV)) GO TO 250 GO TO 400 C C END OF DEFINED SECTION C 200 IF (.NOT. ATWORK) GO TO 400 IF (NDLEV .EQ. 0) GO TO 400 IF (LABEL(NUM) .EQ. NDN(NDLEV)) GO TO 250 GO TO 400 C C EXIT FROM DEFINED SECTION C 250 NUM = NDC(NDLEV) NDIF = NDIF*NDS(NDLEV) NDLEV = NDLEV - 1 IF (NDLEV .LT. 0 .OR. NDLEV .GT. 10) THEN WRITE (NOUT,9002) NDLEV FLUSHL = .TRUE. ENDIF GO TO 400 C C ENTER DEFINED SECTION C 300 IF (NUM .EQ. NUSE) ATWORK = .TRUE. IF (.NOT. ATWORK) GO TO 400 NDLEV = NDLEV + 1 IF (NDLEV .LE. 0 .OR. NDLEV .GT. 10) THEN WRITE (NOUT,9002) NDLEV 9002 FORMAT (' *** ERROR *** BEAMLINE NESTING LEVEL = ',I5) FLUSHL = .TRUE. GO TO 400 ENDIF NDC(NDLEV) = NUM IF (J .EQ. 3) NDS(NDLEV) = 1 IF (J .EQ. 4) NDS(NDLEV) = -1 NDN(NDLEV) = LABEL(NUM) NDIF = NDIF*NDS(NDLEV) IF (NDIF .EQ. 1) NUM = NADDEF(1) IF (NDIF .EQ. -1) NUM = NADDEF(2) C 400 CONTINUE RETURN END SUBROUTINE DEMENT C C CALCULATES DERIVATIVES OF KNOWN MISALIGNMENT TRANSFORMATION C AT MAGNET ENTRANCE C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM0E.CIN' INCLUDE 'ELM7B.CIN' INCLUDE 'ELM8D.CIN' INCLUDE 'ELM8K.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM10E.CIN' INCLUDE 'ELM15C.CIN' INCLUDE 'OC.CIN' INCLUDE 'R.CIN' C C LIST OF LOCAL VARIABLES C REAL DMM(3,3), DRM(3,3), DRMV(3) REAL DVDIS(3), DVROT(3), DVD1(3), DVR1(3) C EQUIVALENCE (DX,VDIS(1)), (DY,VDIS(2)), (DZ,VDIS(3)) EQUIVALENCE (RX,VROT(1)), (RY,VROT(2)), (RZ,VROT(3)) EQUIVALENCE (DDX,DVDIS(1)), (DDY,DVDIS(2)), (DDZ,DVDIS(3)) EQUIVALENCE (DRX,DVROT(1)), (DRY,DVROT(2)), (DRZ,DVROT(3)) C C--------------------------------------------------------------------------- DO 10 J = 1, 3 DVDIS(J) = 0.0 DVROT(J) = 0.0 10 CONTINUE C IF (JV .EQ. 1 .OR. JV .EQ. 3 .OR. JV .EQ. 5) THEN JN = (JV + 1)/2 DVDIS(JN) = DPARM*UMIS(1) ENDIF C IF (JV .EQ. 2 .OR. JV .EQ. 4 .OR. JV .EQ. 6) THEN JN = JV/2 DVROT(JN) = DPARM*UMIS(2) ENDIF C DO 20 J = 1, 3 SD = 0.0 SR = 0.0 DO 18 K = 1, 3 SD = SD + OT(J,K)*DVDIS(K) SR = SR + OT(J,K)*DVROT(K) 18 CONTINUE DVD1(J) = SD DVR1(J) = SR 20 CONTINUE C DO 30 J = 1, 3 DVDIS(J) = DVD1(J) 30 DVROT(J) = DVR1(J) C DTH = 0.0 IF (THMIS .NE. 0.0) DTH = RX*DRX + RY*DRY + RZ*DRZ SN = SIN(THMIS) CS = COS(THMIS) ZN = SN**2/(1.0 + CS) DSN = CS*DTH DZN = SN*DTH IF (THMIS .NE. 0.0) THEN DRX = (DRX - RX*DTH)/THMIS DRY = (DRY - RY*DTH)/THMIS DRZ = (DRZ - RZ*DTH)/THMIS ENDIF C C ROTATION MATRIX FOR MAGNET C DRM(1,1) = 2.0*RX*DRX*ZN - (1.0 - RX**2)*DZN DRM(1,2) = - DRZ*SN - RZ*DSN + DRX*RY*ZN + RX*DRY*ZN + RX*RY*DZN DRM(1,3) = DRY*SN + RY*DSN + DRX*RZ*ZN + RX*DRZ*ZN + RX*RZ*DZN DRM(2,1) = DRZ*SN + RZ*DSN + DRX*RY*ZN + RX*DRY*ZN + RX*RY*DZN DRM(2,2) = 2.0*RY*DRY*ZN - (1.0 - RY**2)*DZN DRM(2,3) = - DRX*SN - RX*DSN + DRY*RZ*ZN + RY*DRZ*ZN + RY*RZ*DZN DRM(3,1) = - DRY*SN - RY*DSN + DRX*RZ*ZN + RX*DRZ*ZN + RX*RZ*DZN DRM(3,2) = DRX*SN + RX*DSN + DRY*RZ*ZN + RY*DRZ*ZN + RY*RZ*ZN DRM(3,3) = 2.0*RZ*DRZ*ZN - (1.0 - RZ**2)*DZN C DO 40 J = 1, 3 SS = 0.0 DO 35 K = 1, 3 SS = SS + DRM(J,K)*XT(K) 35 CONTINUE DVDIS(J) = DVDIS(J) + SS 40 CONTINUE C C TRANSPOSE ROTATION MATRIX TO ACT ON COORDINATES C DO 50 J = 1, 3 JM1 = J - 1 DO 50 K = 1, JM1 S = RM(J,K) RM(J,K) = RM(K,J) RM(K,J) = S DS = DRM(J,K) DRM(J,K) = DRM(K,J) DRM(K,J) = DS 50 CONTINUE C DMM(1,1) = (DRM(1,1) - DRM(1,3)*RM(3,1)/RM(3,3) 1 - DRM(3,1)*RM(1,3)/RM(3,3) 2 + DRM(3,3)*RM(1,3)*RM(3,1)/RM(3,3)**2)/RM(3,3) 3 - DRM(3,3)*(RM(1,1) - RM(1,3)*RM(3,1)/RM(3,3))/RM(3,3)**2 DMM(1,2) = (DRM(1,2) - DRM(1,3)*RM(3,2)/RM(3,3) 1 - DRM(3,2)*RM(1,3)/RM(3,3) 2 + DRM(3,3)*RM(1,3)*RM(3,2)/RM(3,3)**2)/RM(3,3) 3 - DRM(3,3)*(RM(1,2) - RM(1,3)*RM(3,1)/RM(3,3))/RM(3,3)**2 DMM(1,3) = DRM(1,3)/RM(3,3) - RM(1,3)*DRM(3,3)/RM(3,3)**2 DMM(2,1) = (DRM(2,1) - DRM(2,3)*RM(3,1)/RM(3,3) 1 - DRM(3,1)*RM(2,3)/RM(3,3) 2 + DRM(3,3)*RM(2,3)*RM(3,1)/RM(3,3)**2)/RM(3,3) 3 - DRM(3,3)*(RM(2,1) - RM(2,3)*RM(3,1)/RM(3,3))/RM(3,3)**2 DMM(2,2) = (DRM(2,2) - DRM(2,3)*RM(3,2)/RM(3,3) 1 - DRM(3,2)*RM(2,3)/RM(3,3) 2 + DRM(3,3)*RM(2,3)*RM(3,1)/RM(3,3)**2)/RM(3,3) 3 - DRM(3,3)*(RM(2,2) - RM(2,3)*RM(3,2)/RM(3,3))/RM(3,3)**2 DMM(2,3) = DRM(2,3)/RM(3,3) - RM(2,3)*DRM(3,3)/RM(3,3)**2 C DO 60 J = 1, 3 SS = 0.0 DO 55 K = 1, 3 SS = SS + RM(J,K)*DVDIS(K) 55 CONTINUE DRMV(J) = SS 60 CONTINUE C CODV(1) = - DRMV(1) + DMM(1,3)*RMV(3) + MM(1,3)*DRMV(3) CODV(2) = DRM(1,3)/RM(3,3) - RM(1,3)*DRM(3,3)/RM(3,3)**2 CODV(3) = - DRMV(2) + DMM(2,3)*RMV(3) + MM(2,3)*DRMV(3) CODV(4) = DRM(2,3)/RM(3,3) - RM(2,3)*DRM(3,3)/RM(3,3)**2 CODV(5) = - RMV(3) DCOV = .TRUE. C RV(1,1) = DRM(1,1) - DMM(1,3)*RM(3,1) - MM(1,3)*DRM(3,1) RV(1,2) = DMM(1,1)*RMV(3) + MM(1,1)*DRMV(3) RV(1,3) = DRM(1,2) - DMM(1,3)*RM(3,2) - MM(1,3)*DRM(3,2) RV(1,4) = DMM(1,2)*RMV(3) + MM(1,2)*DRMV(3) RV(2,2) = DMM(1,1) RV(2,4) = DMM(1,2) RV(3,1) = DRM(2,1) - DMM(2,3)*RM(3,1) - MM(2,3)*DRM(3,1) RV(3,2) = DMM(2,1)*RMV(3) + MM(2,1)*DRMV(3) RV(3,3) = DRM(2,2) - DMM(2,3)*RM(3,2) - MM(2,3)*DRM(3,2) RV(3,4) = MM(2,2)*RMV(3) RV(3,4) = DMM(2,2)*RMV(3) + MM(2,2)*DRMV(3) RV(4,2) = DMM(2,1) RV(4,4) = DMM(2,2) C DO 80 J = 1, 3 X0V(1,J) = VDIS(J) DO 80 K = 1, 3 OV(1,J,K) = RM(J,K) 80 CONTINUE RETURN END SUBROUTINE DEMEX C C CALCULATES DERIVATIVES OF KNOWN MISALIGNMENT TRANSFORMATION C AT MAGNET EXIT C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM0E.CIN' INCLUDE 'ELM7B.CIN' INCLUDE 'ELM8D.CIN' INCLUDE 'ELM8K.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM10E.CIN' INCLUDE 'ELM15C.CIN' INCLUDE 'OC.CIN' INCLUDE 'R.CIN' C C LOCAL VARIABLES C REAL DMM(3,3), DRM(3,3), DVDIS(3), DVROT(3), DVD1(3) REAL DVR1(3), XTEMP(3) C EQUIVALENCE (DX,VDIS(1)), (DY,VDIS(2)), (DZ,VDIS(3)) EQUIVALENCE (RX,VROT(1)), (RY,VROT(2)), (RZ,VROT(3)) EQUIVALENCE (DDX,DVDIS(1)), (DDY,DVDIS(2)), (DDZ,DVDIS(3)) EQUIVALENCE (DRX,DVROT(1)), (DRY,DVROT(2)), (DRZ,DVROT(3)) C C---------------------------------------------------------------------- DO 10 J = 1, 3 DVDIS(J) = 0.0 DVROT(J) = 0.0 10 CONTINUE IF (JV .EQ. 1 .OR. JV .EQ. 3 .OR. JV .EQ. 5) THEN JN = (JV + 1)/2 DVDIS(JN) = DPARM*UMIS(1) ENDIF IF (JV .EQ. 2 .OR. JV .EQ. 4 .OR. JV .EQ. 6) THEN JN = JV/2 DVROT(JN) = DPARM*UMIS(2) ENDIF C DO 20 J = 1, 3 SD = 0.0 SR = 0.0 DO 18 K = 1, 3 SD = SD + OR(J,K)*DVDIS(K) SR = SR + OR(J,K)*DVROT(K) 18 CONTINUE DVD1(J) = SD DVR1(J) = SR 20 CONTINUE C DO 30 J = 1, 3 DVDIS(J) = DVD1(J) 30 DVROT(J) = DVR1(J) C DTH = 0.0 IF (THMIS .NE. 0.0) DTH = RX*DRX + RY*DRY + RZ*DRZ SN = SIN(THMIS) CS = COS(THMIS) ZN = SN**2/(1.0 + CS) DSN = CS*DTH DZN = SN*DTH IF (THMIS .NE. 0.0) THEN DRX = (DRX - RX*DTH)/THMIS DRY = (DRY - RY*DTH)/THMIS DRZ = (DRZ - RZ*DTH)/THMIS ENDIF C C ROTATION MATRIX FOR MAGNET C DRM(1,1) = 2.0*RX*DRX*ZN - (1.0 - RX**2)*DZN DRM(1,2) = - DRZ*SN - RZ*DSN + DRX*RY*ZN + RX*DRY*ZN + RX*RY*DZN DRM(1,3) = DRY*SN + RY*DSN + DRX*RZ*ZN + RX*DRZ*ZN + RX*RZ*DZN DRM(2,1) = DRZ*SN + RZ*DSN + DRX*RY*ZN + RX*DRY*ZN + RX*RY*DZN DRM(2,2) = 2.0*RY*DRY*ZN - (1.0 - RY**2)*DZN DRM(2,3) = - DRX*SN - RX*DSN + DRY*RZ*ZN + RY*DRZ*ZN + RY*RZ*DZN DRM(3,1) = - DRY*SN - RY*DSN + DRX*RZ*ZN + RX*DRZ*ZN + RX*RZ*DZN DRM(3,2) = DRX*SN + RX*DSN + DRY*RZ*ZN + RY*DRZ*ZN + RY*RZ*DZN DRM(3,3) = 2.0*RZ*DRZ*ZN - (1.0 - RZ**2)*DZN C DO 35 J = 1, 3 SS = 0.0 DO 32 K = 1, 3 SS = SS + OR(J,K)*XR(K) 32 CONTINUE XTEMP(J) = SS 35 CONTINUE C DO 40 J = 1, 3 SS = 0.0 DO 38 K = 1, 3 SS = SS + DRM(J,K)*XTEMP(K) 38 CONTINUE DVDIS(J) = DVDIS(J) + SS 40 CONTINUE C DMM(1,1) = (DRM(1,1) - DRM(1,3)*RM(3,1)/RM(3,3) 1 - DRM(3,1)*RM(1,3)/RM(3,3) 2 + DRM(3,3)*RM(1,3)*RM(3,1)/RM(3,3)**2)/RM(3,3) 3 - DRM(3,3)*(RM(1,1) - RM(1,3)*RM(3,1)/RM(3,3))/RM(3,3)**2 DMM(1,2) = (DRM(1,2) - DRM(1,3)*RM(3,2)/RM(3,3) 1 - DRM(3,2)*RM(1,3)/RM(3,3) 2 + DRM(3,3)*RM(1,3)*RM(3,2)/RM(3,3)**2)/RM(3,3) 3 - DRM(3,3)*(RM(1,2) - RM(1,3)*RM(3,1)/RM(3,3))/RM(3,3)**2 DMM(1,3) = DRM(1,3)/RM(3,3) - RM(1,3)*DRM(3,3)/RM(3,3)**2 DMM(2,1) = (DRM(2,1) - DRM(2,3)*RM(3,1)/RM(3,3) 1 - DRM(3,1)*RM(2,3)/RM(3,3) 2 + DRM(3,3)*RM(2,3)*RM(3,1)/RM(3,3)**2)/RM(3,3) 3 - DRM(3,3)*(RM(2,1) - RM(2,3)*RM(3,1)/RM(3,3))/RM(3,3)**2 DMM(2,2) = (DRM(2,2) - DRM(2,3)*RM(3,2)/RM(3,3) 1 - DRM(3,2)*RM(2,3)/RM(3,3) 2 + DRM(3,3)*RM(2,3)*RM(3,1)/RM(3,3)**2)/RM(3,3) 3 - DRM(3,3)*(RM(2,2) - RM(2,3)*RM(3,2)/RM(3,3))/RM(3,3)**2 DMM(2,3) = DRM(2,3)/RM(3,3) - RM(2,3)*DRM(3,3)/RM(3,3)**2 C CODV(1) = DDX - DMM(1,3)*DZ - MM(1,3)*DDZ CODV(2) = DRM(1,3)/RM(3,3) - RM(1,3)*DRM(3,3)/RM(3,3)**2 CODV(3) = DDY - DMM(2,3)*DZ - MM(2,3)*DDZ CODV(4) = DRM(2,3)/RM(3,3) - RM(2,3)*DRM(3,3)/RM(3,3)**2 CODV(5) = DDZ DCOV = .TRUE. C RV(1,1) = DRM(1,1) + DMM(1,3)*RM(3,1) + MM(1,3)*DRM(3,1) RV(1,2) = - DMM(1,1)*DZ - MM(1,1)*DDZ RV(1,3) = DRM(1,2) + DMM(1,3)*RM(3,2) + MM(1,3)*DRM(3,2) RV(1,4) = - DMM(1,2)*DZ - MM(1,2)*DDZ RV(2,2) = DMM(1,1) RV(2,4) = DMM(1,2) RV(3,1) = DRM(2,1) + DMM(2,3)*RM(3,1) + MM(2,3)*RM(3,1) RV(3,2) = - DMM(2,1)*DZ - MM(2,1)*DDZ RV(3,3) = DRM(2,2) + DMM(2,3)*RM(3,2) + MM(2,3)*DRM(3,2) RV(3,4) = - DMM(2,2)*DZ - MM(2,2)*DDZ RV(4,2) = DMM(2,1) RV(4,4) = DMM(2,2) C DO 75 J = 1, 3 VD = 0.0 DO 70 K = 1, 3 VD = VD + RM(K,J)*DVDIS(K) 70 CONTINUE DVD1(J) = - VD 75 CONTINUE C DO 80 J = 1, 3 X0V(1,J) = DVD1(J) DO 80 K = 1, 3 OV(1,J,K) = DRM(J,K) 80 CONTINUE RETURN END REAL FUNCTION DEN(X) C C PREVENTS DIVISION BY ZERO C C------------------------------------------- IF (X .EQ. 0.0) THEN DEN = (1.E-16) ELSE DEN = X ENDIF RETURN END SUBROUTINE DEPEND C C TEST FOR ALGEBRAIC DEPENDENCE C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA0A.CIN' INCLUDE 'DATA0B.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM22A.CIN' INCLUDE 'ELM23.CIN' INCLUDE 'FLUSHC.CIN' INCLUDE 'IOUNIT.CIN' C C LOCAL VARIABLES C REAL DREGA(NPVAR), DREGB(NPVAR), DREGC(NPVAR) EXTERNAL IDATA C C----------------------------------------------------------------- C C INPUT REGISTERS AND OPERATION C K1 = K1REG K2 = K2REG J = JREG NP1 = NV1 + 1 IF (JTIE .EQ. 0 .AND. J .GT. 20) GO TO 500 IF (K1TIE .EQ. 0 .AND. K1 .GT. 20) GO TO 500 C C FIRST OPERAND C IF (K1TIE .EQ. 100) GO TO 20 IF (.NOT. LREG(K1)) GO TO 500 IF (NV3 .EQ. 0) GO TO 50 DO 5 JJ = 1, NV1 5 DREGA(JJ) = DREG(K1,JJ) IF (NV1 .GE. NPVAR) GO TO 50 10 DO 15 JJ = NP1, NPVAR 15 DREGA(JJ) = 0.0 GO TO 50 C 20 IF (NV3 .EQ. 0) GO TO 50 DO 25 JJ = 1, NV3 25 DREGA(JJ) = 0.0 26 NV2 = TIE(K1) IF (NV2 .EQ. 100) THEN K1 = IDATA(K1) GO TO 26 ENDIF IF (NV2 .EQ. 0) GO TO 50 IF (NV2 .EQ. 99) GO TO 30 IF (NV2 .LT. 0 .OR. NV2 .GT. NPVAR) THEN WRITE (NOUT,9005) NV2 9005 FORMAT (' *** ERROR ***, NV2 = ',I5) FLUSHL = .TRUE. GO TO 550 ENDIF DREGA(NV2) = 1.0 GO TO 50 C 30 IF (NV3 .EQ. 0) GO TO 50 DO 35 JJ = 1, NV1 35 DREGA(JJ) = DATA(K1+JJ) C C SECOND OPERAND C 50 IF (IOPN .GT. 4) GO TO 100 IF (K2TIE .EQ. 0 .AND. K2 .GT. 20) GO TO 500 IF (K2TIE .EQ. 100) GO TO 70 IF (.NOT. LREG(K2)) GO TO 500 IF (NV3 .EQ. 0) GO TO 100 DO 55 JJ = 1, NV1 55 DREGB(JJ) = DREG(K2,JJ) IF (NV1 .GE. NPVAR) GO TO 100 60 DO 65 JJ = NP1, NPVAR 65 DREGB(JJ) = 0.0 GO TO 100 C 70 IF (NV3 .EQ. 0) GO TO 100 DO 75 JJ = 1, NV3 75 DREGB(JJ) = 0.0 76 NV2 = TIE(K2) IF (NV2 .EQ. 100) THEN K2 = IDATA(K2) GO TO 76 ENDIF IF (NV2 .EQ. 0) GO TO 100 IF (NV2 .EQ. 99) GO TO 80 IF (NV2 .LT. 0 .OR. NV2 .GT. NPVAR) THEN WRITE (NOUT,9005) NV2 FLUSHL = .TRUE. GO TO 550 ENDIF DREGB(NV2) = 1.0 GO TO 100 C 80 IF (NV3 .EQ. 0) GO TO 100 DO 85 JJ = 1, NV1 85 DREGB(JJ) = DATA(K2+JJ) C C OPERATIONS C 100 IF (NV3 .EQ. 0) GO TO 106 IF (NV3 .GE. NPVAR) GO TO 106 DO 105 JJ = NP1, NPVAR 105 DREGC(JJ) = 0.0 106 IF (IOPN .LT. 10) THEN GO TO 110 ELSE GO TO 150 ENDIF C C BINARY OPERATIONS C 110 IF (NV3 .EQ. 0) GO TO 500 DO 115 N = 1, NV1 IF (DREGA(N) .GT. 0.5 .OR. DREGB(N) .GT. 0.5) DREGC(N) = 1.0 115 CONTINUE GO TO 500 C C UNARY OPERATIONS C 150 IF (NV3 .EQ. 0) GO TO 500 DO 155 N = 1, NV1 IF (DREGA(N) .GT. 0.5) DREGC(N) = 1.0 155 CONTINUE GO TO 500 C C STORE RESULT OF OPERATION C 500 IF (JTIE .EQ. 100) GO TO 520 LREG(J) = .TRUE. IF (NV3 .EQ. 0) GO TO 550 DO 505 JJ = 1, NV1 505 DREG(J,JJ) = DREGC(JJ) GO TO 550 C 520 IF (NV3 .EQ. 0) GO TO 550 DO 525 JJ = 1, NV1 DATA(J+JJ) = DREGC(JJ) 525 CONTINUE C 550 RETURN END SUBROUTINE DEPIC2 C C CHARACTERIZES A SIMPLE ELEMENT OR ONE OF THE COMPONENTS C OF A COMPOUND ELEMENT AS TO WHAT KIND OF MATRICES IT PRODUCES C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA0A.CIN' INCLUDE 'DATA1A.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM0C.CIN' INCLUDE 'ELM0D.CIN' INCLUDE 'ELM8G.CIN' INCLUDE 'ELM13A.CIN' INCLUDE 'ELM13B.CIN' INCLUDE 'RCP.CIN' INCLUDE 'R2P.CIN' C C LOCAL VARIABLES C INTEGER TYT EXTERNAL IDATA C C------------------------------------------------------------------- C RMTX = .FALSE. OMTX = .FALSE. CFIT = .FALSE. RSYM = .FALSE. MPRN = .FALSE. C IF (TYPE .GE. 82 .AND. TYPE .LE. 86) GO TO 5200 GO TO ( 100, 200, 300, 400, 500, 600, 700, 800,5200,1000, 1 1100,1200,1300,1400,5200,1600,1700,1800,1900,2000, 2 5200,5200,5200,5200,2500,5200,2700,2800,2800,5200, 3 3100,5200,3300,3400,3500,3500,3700,3800,5200,5200, 4 4100,4200,4300,5200,4500,4600,4600,4600), TYPEC GO TO 5200 C 100 MPRN = .TRUE. GO TO 5200 C 200 RMTX = .TRUE. MPRN = .TRUE. GO TO 5200 C 300 RMTX = .TRUE. RSYM = .TRUE. MPRN = .TRUE. GO TO 5200 C 400 RMTX = .TRUE. MPRN = .TRUE. GO TO 5200 C 500 RMTX = .TRUE. MPRN = .TRUE. GO TO 5200 C 600 MPRN = .TRUE. GO TO 5200 C 700 MPRN = .TRUE. GO TO 5200 C 800 IF (TYPE .NE. 6 .AND. TYPE .NE. 37) THEN IF (TYPE .EQ. 2 .OR. TYPE .EQ. 4 .OR. TYPE .EQ. 28 1 .OR. TYPE .EQ. 29) THEN NMR = NM4 ELSE IF (TYPE .EQ. 5) THEN NMR = NM5 ELSE IF (TYPE .EQ. 8) THEN NMR = NUM ENDIF IMIS = ISTOR(NMR) TYT = INT(DATA(IMIS+7)) LFM = TYT/100 ENDIF RMTX = LFM .GE. 1 MPRN = .TRUE. GO TO 5200 C 1000 MPRN = .TRUE. GO TO 5200 C 1100 RMTX = .TRUE. RSYM = .TRUE. MPRN = .TRUE. GO TO 5200 C 1200 MPRN = .TRUE. GO TO 5200 C 1300 ID = INT(DATA(I+1)) OMTX = ID .EQ. 9 .AND. R1P RMTX = ID .EQ. 11 MPRN = .TRUE. GO TO 5200 C 1400 IF (NDIF .EQ. 1 .AND. NUM + 1 .GT. NEL) GO TO 1410 IF (NDIF .EQ. -1 .AND. NUM - 1 .LE. 0) GO TO 1410 IPNOTY = ISTOR(NUM + NDIF) NEXT = IDATA(IPNOTY) IF (NEXT .EQ. TYPE) GO TO 1420 1410 RMTX = .TRUE. 1420 MPRN = .TRUE. GO TO 5200 C 1600 IF16 = INT(DATA(I+1)) OMTX = IF16 .GE. 19 .AND. IF16 .LE. 20 CFIT = IF16 .GE. 16 .AND. IF16 .LE. 20 MPRN = .TRUE. GO TO 5200 C 1700 MPRN = .TRUE. GO TO 5200 C 1800 RMTX = .TRUE. MPRN = .TRUE. GO TO 5200 C 1900 RMTX = .TRUE. RSYM = .TRUE. MPRN = .TRUE. GO TO 5200 C 2000 RMTX = .NOT. REFER MPRN = .TRUE. GO TO 5200 C 2500 RMTX = .TRUE. MPRN = .TRUE. GO TO 5200 C 2700 MPRN = .TRUE. GO TO 5200 C 2800 RMTX = .TRUE. MPRN = .TRUE. GO TO 5200 C 3100 MPRN = PMK GO TO 5200 C 3300 MPRN = .TRUE. GO TO 5200 C 3400 RMTX = .TRUE. RSYM = .TRUE. MPRN = .TRUE. GO TO 5200 C 3500 RMTX = .TRUE. MPRN = .TRUE. GO TO 5200 C 3700 MPRN = .TRUE. GO TO 5200 C 3800 MPRN = .TRUE. GO TO 5200 C 4100 RMTX = .TRUE. MPRN = .TRUE. GO TO 5200 C 4200 RMTX = .TRUE. MPRN = .TRUE. GO TO 5200 C 4300 OMTX = RCP .OR. R2P MPRN = .TRUE. GO TO 5200 C 4500 RMTX = .TRUE. RSYM = .TRUE. MPRN = .TRUE. GO TO 5200 C 4600 RMTX = .TRUE. RSYM = .TRUE. MPRN = .TRUE. GO TO 5200 C 5200 OMTX = RMTX .OR. OMTX CFIT = OMTX .OR. CFIT RETURN END SUBROUTINE DEPICT C C CHARACTERIZES ELEMENT AS TO WHETHER IT IS AN OPERATION, C OR A PHYSICAL ELEMENT THAT CAN BE ROTATED, OR IS COMPOUND C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA0A.CIN' INCLUDE 'DATA0B.CIN' INCLUDE 'DATA1A.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM0D.CIN' INCLUDE 'ELM0F.CIN' INCLUDE 'ELM8G.CIN' INCLUDE 'ELM31A.CIN' INCLUDE 'ELM38A.CIN' INCLUDE 'INDPAR.CIN' INCLUDE 'INDBND.CIN' C C LOCAL VARIABLES C INTEGER IDATA, IDL1, IDL2, IPT, NMARKT, RORC, TYT EXTERNAL IDATA C C---------------------------------------------------------------------- C ATWE = ATWORK OPER = .FALSE. RABL = .FALSE. WFRN = .FALSE. NTILT = 0 C IF (TYPE .GE. 82 .AND. TYPE .LE. 86) GO TO 5200 GO TO ( 100, 200, 300, 400, 500, 600, 700, 800, 900,1000, 1 1100,1200,1300,1400,1500,1600,1700,1800,1900,2000, 2 2100,2200,2300,2400,2500,2600,2700,2800,2800,3000, 3 3100,3200,3300,3400,3500,3500,3700,3800,3900,4000, 4 4100,4200,4300,4400,4500,4600,4600,4600), TYPE C 100 ATWE = .NOT. MKG GO TO 5200 C 200 ATWE = ATWE .AND. .NOT. MKG RABL = .TRUE. GO TO 5200 C 300 ATWE = ATWE .AND. .NOT. MKG GO TO 5200 C 400 ATWE = ATWE .AND. .NOT. MKG RABL = .TRUE. NTILT = 18 GO TO 5200 C 500 ATWE = ATWE .AND. .NOT. MKG RABL = .TRUE. NTILT = 6 GO TO 5200 C 600 OPER = .TRUE. ATWE = .FALSE. IF (MKG) THEN IF (IPTOJ(3) .NE. 0) THEN NMARKT = IDATA(I+3) ATWE = NMARKS .EQ. NMARKT ENDIF ELSE IF (IPTOJ(3) .EQ. 0) ATWE = .TRUE. ENDIF GO TO 5200 C 700 IDL1 = IDATA(ISTOR(NUM-1)) IF (IDL1 .EQ. 1) THEN ATWE = .NOT. MKG ELSE IDL2 = IDATA(ISTOR(NUM-2)) IF (IDL1 .EQ. 12 .AND. IDL2 .EQ. 1) THEN ATWE = .NOT. MKG ENDIF ENDIF GO TO 5200 C 800 TYT = INT(DATA(I+7)) RORC = MOD(TYT,10) ATWE = .FALSE. IF (RORC .GE. 3) THEN ATWE = (.NOT. MKG .AND. IPTOJ(9) .EQ. 0) 1 .OR. (MKG .AND. IPTOJ(9) .NE. 0) ELSE IF (MKG) THEN IF (IPTOJ(9) .NE. 0 .AND. TIE(I+9) .EQ. 101) THEN NMARKT = IDATA(I+9) ATWE = NMARKS .EQ. NMARKT ENDIF ELSE IF (ALGR) THEN IF (IPTOJ(9) .NE. 0 .AND. TIE(I+9) .EQ. 102) THEN ATWE = IDATA(I+9) .EQ. NMARK ENDIF ELSE IF (ATWORK) THEN IF (IPTOJ(9) .EQ. 0) ATWE = .TRUE. ENDIF ENDIF ENDIF OPER = IDATA(I+9) .GE. 1 .AND. TIE(I+9) .EQ. 100 GO TO 5200 C 900 ATWE = ATWE .AND. .NOT. MKG GO TO 5200 C 1000 OPER = .TRUE. ATWE = .FALSE. IPT = IPTOJ(7) IF (MKG) THEN IF (IPT .NE. 0) THEN NMARKT = IDATA(I+IPT) ATWE = NMARKS .EQ. NMARKT ENDIF ELSE ATWE = IPTOJ(7) .EQ. 0 ENDIF GO TO 5200 C 1100 ATWE = ATWE .AND. .NOT. MKG GO TO 5200 C 1200 ATWE = .NOT. MKG GO TO 5200 C 1300 OPER = .TRUE. IF (MKG) THEN IF (IPTOJ(2) .NE. 0) THEN NMARKT = IDATA(I+2) ATWE = NMARKS .EQ. NMARKT ELSE ATWE = .FALSE. ENDIF ELSE ATWE = IPTOJ(2) .EQ. 0 ENDIF GO TO 5200 C 1400 ATWE = ATWE .AND. .NOT. MKG GO TO 5200 C 1500 ATWE = .TRUE. GO TO 5200 C 1600 ATWE = .NOT. MKG GO TO 5200 C 1700 ATWE = .NOT. MKG GO TO 5200 C 1800 ATWE = ATWE .AND. .NOT. MKG RABL = .TRUE. NTILT = 5 GO TO 5200 C 1900 ATWE = ATWE .AND. .NOT. MKG GO TO 5200 C 2000 ATWE = ATWE .AND. .NOT. MKG GO TO 5200 C 2100 GO TO 5200 C 2200 ATWE = ATWE .OR. PLNOW OPER = .TRUE. GO TO 5200 C 2300 ATWE = ATWE .OR. .NOT. MKG OPER = .TRUE. GO TO 5200 C 2400 ATWE = .NOT. MKG GO TO 5200 C 2500 ATWE = ATWE .AND. .NOT. MKG RABL = .TRUE. NTILT = 5 GO TO 5200 C 2600 ATWE = .NOT. MKG GO TO 5200 C 2700 ATWE = .NOT. MKG GO TO 5200 C 2800 ATWE = ATWE .AND. .NOT. MKG RABL = .TRUE. WFRN = .TRUE. NTILT = 24 GO TO 5200 C 3000 ATWE = .NOT. MKG GO TO 5200 C 3100 ATWE = ATWE .AND. .NOT. MKG GO TO 5200 C 3200 GO TO 5200 C 3300 OPER = .TRUE. ATWE = .FALSE. IF (MKG) THEN IF (IPTOJ(2) .NE. 0) THEN NMARKT = IDATA(I+2) ATWE = NMARKS .EQ. NMARKT ENDIF ELSE IF (IPTOJ(2) .EQ. 0) ATWE = .TRUE. ENDIF GO TO 5200 C 3400 ATWE = ATWE .AND. .NOT. MKG GO TO 5200 C 3500 ATWE = ATWE .AND. .NOT. MKG RABL = .TRUE. WFRN = .TRUE. NTILT = 5 GO TO 5200 C 3700 OPER = .TRUE. ATWE = .FALSE. IF (MKG) THEN IF (IPTOJ(3) .NE. 0) THEN NMARKT = IDATA(I+3) ATWE = NMARKS .EQ. NMARKT ENDIF ELSE IF (IPTOJ(3) .EQ. 0) ATWE = .TRUE. ENDIF GO TO 5200 C 3800 ATWE = .NOT. MKG GO TO 5200 C 3900 ATWE = .NOT. MKG GO TO 5200 C 4000 ATWE = ATWE .AND. .NOT. MKG GO TO 5200 C 4100 ATWE = ATWE .AND. .NOT. MKG RABL = .TRUE. NTILT = 10 GO TO 5200 C 4200 ATWE = ATWE .AND. .NOT. MKG RABL = .TRUE. WFRN = .TRUE. GO TO 5200 C 4300 IDL1 = IDATA(ISTOR(NUM-1)) IF (IDL1 .EQ. 1) THEN ATWE = .TRUE. ELSE IDL2 = IDATA(ISTOR(NUM-2)) IF (IDL1 .EQ. 12 .AND. IDL2 .EQ. 1) THEN ATWE = .TRUE. ENDIF ENDIF GO TO 5200 C 4400 ATWE = .TRUE. GO TO 5200 C 4500 ATWE = ATWE .AND. .NOT. MKG GO TO 5200 C 4600 ATWE = ATWE .AND. .NOT. MKG GO TO 5200 C 5200 RETURN END SUBROUTINE DERIVE C C MULTIPLIES R, T, AND U MATRICES AND THEIR DERIVATIVES FOR C THE ENTIRE SYSTEM C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'COCOM.CIN' INCLUDE 'COP.CIN' INCLUDE 'DATA0A.CIN' INCLUDE 'DATA0B.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM0D.CIN' INCLUDE 'ELM0E.CIN' INCLUDE 'ELM2D.CIN' INCLUDE 'ELM7B.CIN' INCLUDE 'ELM8A.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM10E.CIN' INCLUDE 'ELM13B.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'ETACOM.CIN' INCLUDE 'ETAP.CIN' INCLUDE 'FLUSHC.CIN' INCLUDE 'INDPAR.CIN' INCLUDE 'NELMS.CIN' INCLUDE 'R.CIN' INCLUDE 'R0P.CIN' INCLUDE 'R2P.CIN' INCLUDE 'R2VS.CIN' INCLUDE 'R3P.CIN' INCLUDE 'RC2.CIN' INCLUDE 'SI.CIN' INCLUDE 'SVP.CIN' C C LOCAL VARIABLES C LOGICAL VARLET, WOOF INTEGER VARST REAL COSS(6), COT(6), COTF(6), ETAS(6), ETAT(6) EXTERNAL IDATA C C--------------------------------------------------------------- WOOF = SOFA NWK = -1 CALL ELMENT(NWK) IF (FLUSHL) GO TO 810 IF (TYPE .LE. 0) GO TO 810 IF (NWK .EQ. 1) GO TO 200 IF (TYPE .EQ. 1 .OR. TYPE .EQ. 7 .OR. TYPE .EQ. 8 1 .OR. TYPE .EQ. 27 .OR. TYPE .EQ. 43) GO TO 170 IF (TYPE .EQ. 12) GO TO 100 IF (CFIT) GO TO 200 GO TO 810 C C ELEMENTS AFFECTING THE BEAM MATRIX BUT HAVING NO TRANSFER MATRIX C 100 IF (NORD3 .LT. 1) GO TO 170 DO 120 N = 1, NV1 IF (SVP(N)) THEN DO 110 J = 2, 6 JMIN1 = J - 1 DO 110 K = 1, JMIN1 DSV = 0.0 IF (SI(J,J) .NE. 0.0 .AND. SI(K,K) .NE. 0.0) 1 DSV = 0.5*SI(J,K)*(SV(J,J,N)/SI(J,J) + SV(K,K,N)/SI(K,K)) SV(J,K,N) = DSV SV(K,J,N) = DSV 110 CONTINUE ENDIF 120 CONTINUE C 170 NVTYPE = NV(TYPE) IF (NVTYPE .EQ. 0) GO TO 810 DO 180 JV = 1, NVTYPE IPT = IPTOJ(JV) IF (IPT .EQ. 0) GO TO 180 IPLJV = I + IPT IADR = IPLJV 172 NV2 = TIE(IADR) IF (NV2 .EQ. 0) GO TO 180 IF (NV2 .EQ. 100) THEN IADR = IDATA(IADR) IF (NV2 .EQ. 100) GO TO 172 ENDIF DPARM = 1.0 IF (NV2 .LT. 0) DPARM = - 1.0 NVP = 1 IF (NV2 .EQ. 99) NVP = NPVAR DO 175 JP = 1, NVP IF (NVP .EQ. NPVAR) THEN NV2 = JP DPARM = DATA(IADR + JP) IF (DPARM .EQ. 0.0) GO TO 175 ENDIF NV1 = MAX0(NV1,IABS(NV2)) CALL PARTLS 175 CONTINUE 180 CONTINUE IF (TYPE .EQ. 43) GO TO 808 GO TO 810 C C ELEMENTS HAVING A TRANSFER MATRIX C 200 NVTYPE = NV(TYPE) IF (.NOT. RMTX) GO TO 808 C C IS ANYTHING BEING VARIED? C IF (NVTYPE .LT. 1) GO TO 215 DO 210 JV = 1, NVTYPE NV2 = VARST(JV) IF (NV2 .NE. 0 .AND. NV2 .NE. 99) THEN GO TO 300 ELSE IF (NV2 .EQ. 99) THEN IF (JV .LE. NELMS(TYPE)) THEN IADR = I + IPTOJ(JV) IADR = IDATA(IADR) ELSE IF (TYPE .EQ. 2) THEN IADR = IBVARY ELSE IADR = 0 ENDIF DO 205 JP = 1, NV3 DPARM = DATA(IADR + JP) IF (DPARM .NE. 0.0) GO TO 300 205 CONTINUE ENDIF 210 CONTINUE C C IS THERE ANY IMPLICIT ELEMENT VARIATION DUE TO C CENTROID VARIATION? C 215 IF (SOFA .OR. RAY) THEN DO 220 N = 1, NV1 IF (CVP(N) .OR. EVP(N)) GO TO 300 220 CONTINUE ENDIF C C UNVARIED ELEMENT C 240 VARLET = .FALSE. IF (RAY) THEN DO 245 J = 1, 6 245 ETAT(J) = ETA(J) CALL THREAD(0,ETAT) ENDIF IF (WOOF) THEN IF (R1P) THEN DO 251 J = 1, 6 251 COTF(J) = COF(J) CALL THRED1(R,COTF) ENDIF DO 258 J = 1, 6 258 COT(J) = CO(J) CALL THREAD(0,COT) IF (NORD1 .GE. 2 .AND. NORD2 .GE. 1) CALL ENRICH(0) ENDIF C 260 IF (NORD2 .GE. 1) CALL MRR3 C IF (WOOF) THEN IF (R1P) THEN IF (DCOV) THEN DO 291 J = 1, 6 291 COF(J) = COTF(J) + COD(J) ELSE DO 292 J = 1, 6 292 COF(J) = COTF(J) ENDIF ENDIF IF (DCOV) THEN DO 295 J = 1, 6 295 CO(J) = COT(J) + COD(J) ELSE DO 296 J = 1, 6 296 CO(J) = COT(J) ENDIF ELSE IF (DCOV) THEN IF (R1P) THEN DO 297 J = 1, 6 297 COF(J) = COD(J) ENDIF DO 298 J = 1, 6 298 CO(J) = COD(J) SOFA = .TRUE. NORD1 = NORDX ENDIF IF (RAY) THEN DO 299 J = 1, 6 299 ETA(J) = ETAT(J) ENDIF GO TO 800 C C VARIED ELEMENT C 300 VARLET = .TRUE. IF (R3P) CALL UPDAT3 IF (RAY) THEN DO 301 J = 1, 6 301 ETAT(J) = ETA(J) CALL THREAD(0,ETAT) ENDIF 305 CALL RTORSH C 310 IF (WOOF) THEN IF (R1P) THEN DO 312 J = 1, 6 312 COTF(J) = COF(J) CALL THRED1(R,COTF) ENDIF DO 318 J = 1, 6 318 COT(J) = CO(J) CALL THREAD(0,COT) IF (NORD1 .GE. 2 .AND. NORD2 .GE. 1) CALL ENRICH(3) ENDIF C C R TIMES DERIVATIVE OF ACCUMULATED R2 C DO 380 N = 1, NV1 NV2 = N IF (R2VP(N) .AND. NORD2 .GE. 1) CALL MRR2V C IF (CVP(N) .OR. EVP(N)) CALL TWITCH IF (CVP(N) .AND. NORD1 .GE. 2 .AND. NORD2 .GE. 1) 1 CALL MRTR2 380 CONTINUE C C DERIVATIVE OF R TIMES ACCUMULATED R2 C 400 DO 590 JV = 1, NVTYPE NV2 = VARST(JV) DPARM = 1.0 IF (NV2 .EQ. 0) GO TO 590 IF (NV2 .LT. 0) DPARM = - 1.0 NVP = 1 IF (NV2 .EQ. 99) NVP = NV3 NVPART = NV2 DO 580 JP = 1, NVP IF (NVPART .EQ. 99) THEN NV2 = JP IADR = IDATA(I + IPTOJ(JV)) DPARM = DATA(IADR + JP) IF (DPARM .EQ. 0.0) GO TO 580 ENDIF C CALL MVZERO C 420 NV1 = MAX0(NV1,IABS(NV2)) CALL PARTLS NV2 = IABS(NV2) C 440 IF (RAY) THEN DO 442 J = 1, 6 442 ETAS(J) = ETA(J) CALL THREAD(1,ETAS) IF (.NOT. EVP(NV2)) THEN DO 443 J = 1, 6 443 ETAV(J,NV2) = ETAS(J) + CODV(J) EVP(NV2) = .TRUE. ELSE DO 448 J = 1, 6 448 ETAV(J,NV2) = ETAV(J,NV2) + ETAS(J) + CODV(J) ENDIF ENDIF C 450 IF (WOOF) THEN DO 452 J = 1, 6 452 COSS(J) = CO(J) CALL THREAD(1,COSS) IF (.NOT. CVP(NV2)) THEN DO 453 J = 1, 6 453 COV(J,NV2) = COSS(J) CVP(NV2) = .TRUE. ELSE DO 458 J = 1, 6 458 COV(J,NV2) = COV(J,NV2) + COSS(J) ENDIF IF (DCOV) THEN DO 460 J = 1, 6 460 COV(J,NV2) = COV(J,NV2) + CODV(J) ENDIF C IF (NORD1 .GE. 2 .AND. NORD2 .GE. 1) CALL ENRICH(1) C ELSE IF (DCOV) THEN DO 475 J = 1, 6 475 COV(J,NV2) = CODV(J) CVP(NV2) = .TRUE. ENDIF ENDIF C IF (NORD2 .GE. 1) THEN CALL MRVRC2 R2VP(NV2) = .TRUE. ENDIF LCV(NV2) = LCV(NV2) + LV C 580 CONTINUE 590 CONTINUE C C ACCUMULATED DERIVATIVE OF R2 MATRIX C DO 620 N = 1, NV1 IF (R2VP(N)) THEN DO 610 JK = 1, 36 R2VL(JK,N) = R2VSL(JK,N) 610 CONTINUE ENDIF 620 CONTINUE C C ACCUMULATED R2 MATRIX C 650 IF (NWK .NE. 1) GO TO 810 IF (RAY) THEN DO 655 J = 1, 6 655 ETA(J) = ETAT(J) + COD(J) ENDIF IF (WOOF) THEN IF (R1P) THEN DO 662 J = 1, 6 662 COF(J) = COTF(J) ENDIF DO 667 J = 1, 6 667 CO(J) = COT(J) + COD(J) ELSE IF (DCOV) THEN IF (R1P) THEN DO 668 J = 1, 6 668 COF(J) = COD(J) ENDIF DO 669 J = 1, 6 669 CO(J) = COD(J) SOFA = .TRUE. NORD1 = NORDX ENDIF ENDIF C 670 IF (NORD2 .GE. 1) THEN CALL RSHTOR CALL MRR2 ENDIF C C ADVANCE TO NEXT ELEMENT C 800 IF (ALIGN) THEN CALL ADVANC(2) IF (FLUSHL) GO TO 810 CALL ADVANC(3) IF (FLUSHL) GO TO 810 ENDIF IF (.NOT. VARLET) R3P = .TRUE. IF (VARLET) R2P = .TRUE. R0P = .TRUE. 808 IF (LAY) CALL GROPE 810 RETURN END SUBROUTINE DFBEND C C CALCULATES DERIVATIVE OF FLOOR COORDINATE TRANSFORMATION C THROUGH A BENDING MAGNET C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA1C.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM0B.CIN' INCLUDE 'ELM4A.CIN' INCLUDE 'ELM4D.CIN' INCLUDE 'ELM5A.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM13A.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'ELM16B.CIN' INCLUDE 'ELM20.CIN' INCLUDE 'ELM28.CIN' INCLUDE 'FLUSHC.CIN' INCLUDE 'INDBND.CIN' INCLUDE 'INDPAR.CIN' INCLUDE 'IOUNIT.CIN' INCLUDE 'OIV.CIN' C C LOCAL VARIABLES C INTEGER IANG, IB, IL, IRHO REAL ADOT, CSA2, DSAL, RDOT, RHO, RHODOT, SNA2, X1 C C---------------------------------------------------------------- IL = IPTOJ(NL) IB = IPTOJ(NBV) IRHO = IPTOJ(NRHO) IANG = IPTOJ(NANG) IF (JV .EQ. NTILT) GO TO 200 IF (JV .GT. 4) GO TO 500 GO TO (10,20,30,40), JV C 10 IF (IB .NE. 0 .OR. IRHO .NE. 0) THEN GO TO 100 ELSE IF (IANG .NE. 0) THEN GO TO 110 ENDIF GO TO 500 C 20 IF (IL .NE. 0) THEN RHO = 0.0 IF (H0 .NE. 0.0) RHO = 1.0/H0 RHODOT = - RHO**2*UNITI(9)/PREF IF (TYPE .EQ. 4 .OR. TYPE .EQ. 29) THEN ADOT = L*UNITI(9)/PREF ELSE IF (TYPE .EQ. 28) THEN SNA2 = 0.5*H0*LRBEND CSA2 = SQRT(1.0 - SNA2**2) ADOT = LRBEND*UNITI(9)/(PREF*CSA2) ENDIF GO TO 120 ELSE IF (IANG .NE. 0) THEN GO TO 110 ENDIF GO TO 500 C 30 IF (IL .NE. 0) THEN RHODOT = UNITI(8) IF (TYPE .EQ. 4 .OR. TYPE .EQ. 29) THEN ADOT = - H0**2*L*RHODOT ELSE SNA2 = 0.5*H0*LRBEND CSA2 = SQRT(1.0 - SNA2**2) ADOT = - H0**2*LRBEND*RHODOT/CSA2 ENDIF GO TO 120 ELSE IF (IANG .NE. 0) THEN GO TO 110 ENDIF GO TO 500 C 40 ADOT = UNITI(7) IF (IL .NE. 0) THEN IF (TYPE .EQ. 4 .OR. TYPE .EQ. 29) THEN RHODOT = - L*UNITI(7)/AL**2 ELSE IF (TYPE .EQ. 28) THEN SNA2 = 0.5*H0*LRBEND CSA2 = SQRT(1.0 - SNA2**2) IF (H0 .NE. 0.0) THEN RHODOT = - CSA2*UNITI(7)/(H0**2*LRBEND) ELSE RHODOT = 0.0 ENDIF ENDIF GO TO 120 ELSE IF (IB .NE. 0 .OR. IRHO .NE. 0) THEN RHODOT = 0.0 GO TO 130 ENDIF GO TO 500 C 100 OIV(1,1) = - SNAL*H0*LVE OIV(3,3) = OIV(1,1) OIV(1,3) = CSAL*H0*LVE OIV(3,1) = - OIV(1,3) XIV(1) = - SNAL*LVE XIV(3) = CSAL*LVE GO TO 500 C 110 IF (H0 .EQ. 0.0) GO TO 115 IF (CSAL .LT. 0.5) THEN DSAL = - (1.0 - CSAL)/H0 ELSE DSAL = - SNAL**2/(H0*(1.0 + CSAL)) ENDIF XIV(1) = DSAL*LVE/L XIV(3) = SNAL*LVE/(H0*L) GO TO 500 C 115 WRITE (NOUT,9002) 9002 FORMAT (' ZERO BEND ANGLE NOT PERMITTED AS INITIAL VALUE', 1 ' FOR FITTING') WRITE (NOUT,9003) LABEL(NUM) 9003 FORMAT (' ELEMENT IS ',A8) FLUSHL = .TRUE. GO TO 500 C 120 OIV(1,1) = - SNAL*ADOT OIV(3,3) = OIV(1,1) OIV(1,3) = CSAL*ADOT OIV(3,1) = - OIV(1,3) IF (AL .NE. 0.0) THEN XIV(1) = - (1.0 - CSAL)*RHODOT - SNAL*ADOT/H0 XIV(3) = SNAL*RHODOT + CSAL*ADOT/H0 ELSE XIV(1) = - 0.5*L*ADOT XIV(3) = - H0*L**2*ADOT/3.0 ENDIF GO TO 500 C 130 RHO = 0.0 IF (H0 .NE. 0.0) RHO = 1.0/H0 OIV(1,1) = - SNAL*ADOT OIV(3,3) = OIV(1,1) OIV(1,3) = CSAL*ADOT OIV(3,1) = - OIV(1,3) XIV(1) = - RHO*SNAL*ADOT XIV(3) = RHO*SNAL*ADOT GO TO 500 C 200 IF (.NOT. REFER) GO TO 500 RDOT = UNITI(13) OIV(1,1) = 2.0*(1.0 - CSAL)*SNR*CSR*RDOT OIV(1,2) = (CSAL - 1.0)*(CSR**2 - SNR**2)*RDOT OIV(1,3) = - SNAL*SNR*RDOT OIV(2,1) = OIV(1,2) OIV(2,2) = - 2.0*(1.0 - CSAL)*SNR*CSR*RDOT OIV(2,3) = SNAL*CSR*RDOT OIV(3,1) = - OIV(1,3) OIV(3,2) = - OIV(2,3) X1 = - (1.0 - CSAL)/H0 XIV(1) = - SNR*RDOT*X1 XIV(2) = CSR*RDOT*X1 GO TO 500 C 500 RETURN END SUBROUTINE DFOCU2 C C DERIVATIVE OF SECOND-ORDER TRANSFER MATRIX FOR A QUADRUPOLE C WITH RESPECT TO MAGNETIC FIELD OR GRADIENT C C LIST OF COMMON BLOCKS C INCLUDE 'ELM0B.CIN' INCLUDE 'ELM5A.CIN' INCLUDE 'ELM5B.CIN' INCLUDE 'R.CIN' INCLUDE 'T.CIN' C C LOCAL VARIABLES C C C---------------------------------------------------------- J = JQUAD CS = R(J,J) SN = R(J,J+1) DCS = - L*SN*KVK IF (KQ2 .NE. 0.0) THEN DSN = ( - SN + L*CS)*KVK/KQ2 ELSE DSN = 0.0 ENDIF DCSP = - (SN + L*CS)*KVK BLOB = 0.5*(L**2*CS + L*SN)*KVK C TV(J,J+15) = BLOB TV(J+1,J+16) = BLOB IF (KQ2 .NE. 0.0) THEN TV(J,J+16) = 0.5*(( - SN + L*CS)/KQ2 + L**2*SN)*KVK ELSE TV(J,J+16) = 0.0 ENDIF TV(J+1,J+15) = 0.5*(SN + 3.0*L*CS 1 - KQ2*L**2*SN)*KVK C TV(5,J*(J+1)/2) = - 0.25*(2.0*L*KVK + DCSP*CS 1 - KQ2*SN*DCS) TV(5,J*(J+3)/2) = - 0.5*(- KQ2*DSN*SN + SN*DCSP) TV(5,J*(J+3)/2+1) = - 0.25*(DCS*SN + CS*DSN) 100 RETURN END SUBROUTINE DFOCU3 C C DERIVATIVE OF THIRD-ORDER TRANSFER MATRIX ELEMENTS WITH RESPECT C TO MAGNETIC FIELD OR GRADIENT C C ---------------------------------------------------------------------- INCLUDE 'ELM0B.CIN' INCLUDE 'ELM5A.CIN' INCLUDE 'ELM5B.CIN' INCLUDE 'ELM5C.CIN' INCLUDE 'R.CIN' INCLUDE 'U.CIN' C C LOCAL VARIABLES C INTEGER JO, KLM REAL DCS, DCSO, DSN, DSNO C----------------------------------------------------------------------- C J = JQUAD JO = 4 - J CS = R(J,J) SN = R(J,J+1) DCS = RV(J,J) DSN = RV(J,J+1) DCSO = RV(JO,JO) DSNO = RV(JO,JO+1) C IF (J .EQ. 1) KLM = 1 IF (J .EQ. 3) KLM = 10 UV(J,KLM) = 4.0*KVK*U(J,KLM)/KQ2 1 + KQ2**2*(13.*DCS*SN**2 + 26.*CS*SN*DSN - 9.*L*DSN)/48. UV(J+1,KLM) = 4.0*KVK*U(J+1,KLM)/KQ2 1 - KQ2**2*(7.*DSN + 30.*KVK*SN**3 + 45.*KQ2*SN**2*DSN 2 + 9.*L*DCS)/48. IF (J .EQ. 1) KLM = 2 IF (J .EQ. 3) KLM = 16 UV(J,KLM) = 2.0*KVK*U(J,KLM)/KQ2 1 + KQ2*(- 22.*DSN + 52.*KVK*SN**3 + 78.*KQ2*SN**2*DSN 2 + 6.*L*DCS)/32. UV(J+1,KLM) = 4.0*KVK*U(J+1,KLM)/KQ2 1 + 3.*KQ2**2*(5.*DCS*SN**2 + 10.*CS*SN*DSN 2 - L*DSN)/16. IF (J .EQ. 1) KLM = 3 IF (J .EQ. 3) KLM = 19 UV(J,KLM) = 2.0*KVK*U(J,KLM)/KQ2 1 - KQ2*(13.*DCS*SN**2 + 26.*CS*SN*DSN + 3.*L*DSN)/16. UV(J+1,KLM) = 2.0*KVK*U(J+1,KLM)/KQ2 1 + KQ2*(- 26.*DSN + 60.*KVK*SN**3 + 90.*KQ2*SN**2*DSN 2 - 6.*L*DCS)/32. IF (J .EQ. 1) KLM = 4 IF (J .EQ. 3) KLM = 20 UV(J,KLM) = (-9.*DSN - 26.*KVK*SN**3 1 - 39.*KQ2*SN**2*DSN + 9.*L*DCS)/48. UV(J+1,KLM) = 2.0*KVK*U(J+1,KLM)/KQ2 1 - KQ2*(5.*DCS*SN**2 + 10.*CS*SN*DSN + 3.*L*DSN)/16. IF (J .EQ. 1) KLM = 8 IF (J .EQ. 3) KLM = 5 UV(J,KLM) = 4.0*KVK*U(J,KLM)/KQ2 1 + KQ2**2*(- 3.*DCS*SNO**2 - 6.*CS*SNO*DSNO + 2.*L*DSN 2 - 3.*DSN*SNO*CSO - 3.*SN*DSNO*CSO - 3.*SN*SNO*DCSO)/16. UV(J+1,KLM) = 4.0*KVK*U(J+1,KLM)/KQ2 1 + KQ2**2*(2.*L*DCS - 9.*DCS*CSO*SNO - 9.*CS*DCSO*SNO 2 - 9.*CS*CSO*DSNO - 9.*DSN - 22.*KVK*SN*SNO**2 3 - 11.*KQ2*DSN*SNO**2 - 22.*KQ2*SN*SNO*DSNO)/16. IF (J .EQ. 1) KLM = 14 IF (J .EQ. 3) KLM = 6 UV(J,KLM) = 2.0*KVK*U(J,KLM)/KQ2 1 + 3.*KQ2*(- DCS*CSO*SNO - CS*DCSO*SNO - CS*CSO*DSNO 2 + DSN - 2.0*KVK*SN*SNO**2 - KQ2*DSN*SNO**2 3 - 2.0*KQ2*SN*SNO*DSNO)/8. UV(J+1,KLM) = 4.0*KVK*U(J+1,KLM)/KQ2 1 + KQ2**2*(- 9.*DCS*SNO**2 - 18.*CS*SNO*DSNO 2 - 11.*DSN*SNO*CSO - 11.*SN*DSNO*CSO 3 - 11.*SN*SNO*DCSO)/8. IF (J .EQ. 1) KLM = 17 IF (J .EQ. 3) KLM = 7 UV(J,KLM) = 2.0*KVK*U(J,KLM)/KQ2 1 - KQ2*(3.*DCS*SNO**2 + 6.*CS*SNO*DSNO + 2.*L*DSN 2 + 3.*DSN*CSO*SNO + 3.*SN*DCSO*SNO + 3.*SN*CSO*DSNO)/16. UV(J+1,KLM) = 2.0*KVK*U(J+1,KLM)/KQ2 1 - KQ2*(2.*L*DCS + 9.*DCS*CSO*SNO + 9.*CS*DCSO*SNO 2 + 9.*CS*CSO*DSNO + 22.*KVK*SN*SNO**2 3 + 11.*KQ2*DSN*SNO**2 + 22.*KQ2*SN*SNO*DSNO 4 + 5.*DSN)/16 IF (J .EQ. 1) KLM = 9 IF (J .EQ. 3) KLM = 11 UV(J,KLM) = 2.0*KVK*U(J,KLM)/KQ2 1 + KQ2*(3.*DCS*CSO*SNO + 3.*CS*DCSO*SNO + 3.*CS*CSO*DSNO 2 - 2.*L*DCS - 3.*DSN*CSO**2 - 6.*SN*CSO*DCSO 3 - 6.*DSN)/16. UV(J+1,KLM) = 4.0*KVK*U(J+1,KLM)/KQ2 1 + KQ2**2*(11.*DCS*SNO**2 + 22.*CS*SNO*DSNO + 2.*L*DSN 2 - 9.*DSN*CSO*SNO - 9.*SN*DCSO*SNO 3 - 9.*SN*CSO*DSNO)/16 IF (J .EQ. 1) KLM = 15 IF (J .EQ. 3) KLM = 12 UV(J,KLM) = 2.0*KVK*U(J,KLM)/KQ2 1 + 3.*KQ2*(DCS*SNO**2 + 2.*CS*SNO*DSNO - DSN*CSO*SNO 2 - SN*DCSO*SNO - SN*CSO*DSNO)/8. UV(J+1,KLM) = 2.0*KVK*U(J+1,KLM)/KQ2 1 + KQ2*(11.*DCS*CSO*SNO + 11.*CS*DCSO*SNO 2 + 11.*CS*CSO*DSNO - 3.*DSN - 18.*KVK*SN*SNO**2 3 - 9.*KQ2*DSN*SNO**2 - 18.*KQ2*SN*SNO*DSNO)/8. IF (J .EQ. 1) KLM = 18 IF (J .EQ. 3) KLM = 13 UV(J,KLM) = (3.*DCS*CSO*SNO + 3.*CS*DCSO*SNO 1 + 3.*CS*CSO*DSNO + 2.*L*DCS - 3.*DSN*CSO**2 2 - 6.*SN*CSO*DCSO - 2.*DSN)/16. UV(J+1,KLM) = 2.0*KVK*U(J+1,KLM)/KQ2 1 + KQ2*(11.*DCS*SNO**2 + 22.*CS*SNO*DSNO - 2.*L*DSN 2 - 9.*DSN*CSO*SNO - 9.*SN*DCSO*SNO 3 - 9.*SN*CSO*DSNO)/16 UV(J,50+J) = 2.0*KVK*U(J,50+J)/KQ2 1 - KQ2*(3.*L*DSN + L**2*DCS)/8. UV(J,51+J) = ( - 2.0*KVK*L**2*SN - KQ2*L**2*DSN + L*DCS 1 - DSN)/8. UV(J+1,50+J) = 2.0*KVK*U(J+1,50+J)/KQ2 1 + KQ2*(- 5.*L*DCS - 3.*DSN + 2.0*KVK*L**2*SN 2 + KQ2*L**2*DSN)/8. UV(J+1,51+J) = 2.0*KVK*U(J+1,51+J)/KQ2 1 + KQ2*(- 3.*L*DSN - L**2*DCS)/8. RETURN END SUBROUTINE DFOCUS C C DERIVATIVE OF FIRST-ORDER TRANSFER MATRIX FOR A QUADRUPOLE C WITH RESPECT TO MAGNETIC FIELD OR GRADIENT C C LIST OF COMMON BLOCKS C INCLUDE 'ELM0B.CIN' INCLUDE 'ELM5A.CIN' INCLUDE 'ELM5B.CIN' INCLUDE 'R.CIN' C------------------------------------------------------- C J = JQUAD CS = R(J,J) SN = R(J,J+1) RV(J,J) = - L*SN*KVK RV(J+1,J+1) = RV(J,J) IF (KQ2 .NE. 0.0) THEN RV(J,J+1) = (- SN + L*CS)*KVK/KQ2 ELSE RV(J,J+1) = 0.0 ENDIF RV(J+1,J) = - (SN + L*CS)*KVK RETURN END SUBROUTINE DFOL C C DERIVATIVE OF FIRST-ORDER TRANSFER MATRIX WITH RESPECT C TO MAGNET LENGTH FOR QUADRUPOLES AND DIPOLES C C LIST OF COMMON BLOCKS C INCLUDE 'ELM5A.CIN' INCLUDE 'ELM5B.CIN' INCLUDE 'R.CIN' C C LOCAL VARIABLES C REAL DCS, DSN C C--------------------------------------------------- J = JQUAD CS = R(J,J) SN = R(J,J+1) DCS = - KQ2*SN*LVE DSN = CS*LVE RV(J,J) = DCS RV(J,J+1) = DSN RV(J+1,J) = - KQ2*DSN RV(J+1,J+1) = DCS RETURN END SUBROUTINE DFOL2 C C DERIVATIVE OF SECOND-ORDER TRANSFER MATRIX ELEMENTS WITH C RESPECT TO MAGNET LENGTH C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM0B.CIN' INCLUDE 'ELM0E.CIN' INCLUDE 'ELM5A.CIN' INCLUDE 'ELM5B.CIN' INCLUDE 'R.CIN' INCLUDE 'T.CIN' C C LOCAL VARIABLES C REAL BLOB, DCS, DCSP, DSN C C--------------------------------------------------- J = JQUAD CS = R(J,J) SN = R(J,J+1) DCS = - KQ2*SN*LVE DSN = CS*LVE DCSP = - KQ2*CS*LVE BLOB = 0.5*(KQ2*SN + KQ2*L*CS)*LV C TV(J,J+15) = BLOB TV(J+1,J+16) = BLOB TV(J,J+16) = 0.5*(DSN - LV*CS - L*DCS) TV(J+1,J+15) = 0.5*KQ2*(2.0*CS - KQ2*L*SN)*LV C TV(5,J*(J+1)/2) = - 0.25*(KQ2*LV + DCSP*CS - KQ2*SN*DCS) TV(5,J*(J+3)/2) = - 0.5*(- KQ2*DSN*SN + SN*DCSP) TV(5,J*(J+3)/2+1) = - 0.25*(LV + DCS*SN + CS*DSN) 100 RETURN END SUBROUTINE DFOL3 C C DERIVATIVE OF THIRD-ORDER TRANSFER MATRIX ELEMENTS WITH C RESPECT TO MAGNET LENGTH C C ---------------------------------------------------------------------- INCLUDE 'ELM0B.CIN' INCLUDE 'ELM5A.CIN' INCLUDE 'ELM5B.CIN' INCLUDE 'ELM5C.CIN' INCLUDE 'R.CIN' INCLUDE 'U.CIN' C C LOCAL VARIABLES C INTEGER JO, KLM REAL DCS, DCSO, DSN, DSNO, LV C----------------------------------------------------------------------- C J = JQUAD LV = LVE JO = 4 - J CS = R(J,J) SN = R(J,J+1) CSO = R(JO,JO) SNO = R(JO,JO+1) DCS = RV(J,J) DSN = RV(J,J+1) DCSO = RV(JO,JO) DSNO = RV(JO,JO+1) C IF (J .EQ. 1) KLM = 1 IF (J .EQ. 3) KLM = 10 UV(J,KLM) = KQ2**2*(13.*DCS*SN**2 + 26.*CS*SN*DSN 1 - 9*LV*SN - 9.*L*DSN)/48. UV(J+1,KLM) = - KQ2**2*(7.*DSN + 45.*KQ2*SN**2*DSN 1 + 9.*LV*CS + 9.*L*DCS)/48. IF (J .EQ. 1) KLM = 2 IF (J .EQ. 3) KLM = 16 UV(J,KLM) = KQ2*(-22.*DSN + 78.*KQ2*SN**2*DSN 1 + 6.*LV*CS + 6.*L*DCS)/32. UV(J+1,KLM) = 3.*KQ2**2*(5.*DCS*SN**2 + 10.*CS*SN*DSN 1 - LV*SN - L*DSN)/16. IF (J .EQ. 1) KLM = 3 IF (J .EQ. 3) KLM = 19 UV(J,KLM) = - KQ2*(13.*DCS*SN**2 + 26.*CS*SN*DSN 1 + 3.*LV*SN + 3.*L*DSN)/16. UV(J+1,KLM) = KQ2*(-26.*DSN + 90.*KQ2*SN**2*DSN 1 - 6.*LV*CS - 6.*L*DCS)/32. IF (J .EQ. 1) KLM = 4 IF (J .EQ. 3) KLM = 20 UV(J,KLM) = (- 9.*DSN - 39.*KQ2*SN**2*DSN 1 + 9.*LV*CS + 9.*L*DCS)/48. UV(J+1,KLM) = - KQ2*(5.*DCS*SN**2 + 10.*CS*SN*DSN 1 + 3.*LV*SN + 3.*L*DSN)/16. IF (J .EQ. 1) KLM = 8 IF (J .EQ. 3) KLM = 5 UV(J,KLM) = KQ2**2*(- 3.*DCS*SNO**2 - 6.*CS*SNO*DSNO 1 + 2.*LV*SN + 2.*L*DSN - 3.*DSN*SNO*CSO - 3.*SN*DSNO*CSO 2 - 3.*SN*SNO*DCSO)/16. UV(J+1,KLM) = KQ2**2*(2.*LV*CS + 2.*L*DCS - 9.*DCS*CSO*SNO 1 - 9.*CS*DCSO*SNO - 9.*CS*CSO*DSNO - 9.*DSN 2 - 11.*KQ2*DSN*SNO**2 - 22.*KQ2*SN*SNO*DSNO)/16. IF (J .EQ. 1) KLM = 14 IF (J .EQ. 3) KLM = 6 UV(J,KLM) = 3.*KQ2*(- DCS*CSO*SNO - CS*DCSO*SNO 1 - CS*CSO*DSNO + DSN - KQ2*DSN*SNO**2 2 - 2.0*KQ2*SN*SNO*DSNO)/8. UV(J+1,KLM) = KQ2**2*(- 9.*DCS*SNO**2 - 18.*CS*SNO*DSNO 1 - 11.*DSN*SNO*CSO - 11.*SN*DSNO*CSO 2 - 11.*SN*SNO*DCSO)/8. IF (J .EQ. 1) KLM = 17 IF (J .EQ. 3) KLM = 7 UV(J,KLM) = - KQ2*(3.*DCS*SNO**2 + 6.*CS*SNO*DSNO 1 + 2.*LV*SN + 2.*L*DSN + 3.*DSN*CSO*SNO + 3.*SN*DCSO*SNO 2 + 3.*SN*CSO*DSNO)/16. UV(J+1,KLM) = - KQ2*(2.*LV*CS + 2.*L*DCS + 9.*DCS*CSO*SNO 1 + 9.*CS*DCSO*SNO + 9.*CS*CSO*DSNO 2 + 11.*KQ2*DSN*SNO**2 + 22.*KQ2*SN*SNO*DSNO 3 + 5.*DSN)/16. IF (J .EQ. 1) KLM = 9 IF (J .EQ. 3) KLM = 11 UV(J,KLM) = KQ2*(3.*DCS*CSO*SNO + 3.*CS*DCSO*SNO 1 + 3.*CS*CSO*DSNO - 2.*LV*CS - 2.*L*DCS - 3.*DSN*CSO**2 2 - 6.*SN*CSO*DCSO - 6.*DSN)/16. UV(J+1,KLM) = KQ2**2*(11.*DCS*SNO**2 + 22.*CS*SNO*DSNO 1 + 2.*LV*SN + 2.*L*DSN - 9.*DSN*CSO*SNO 2 - 9.*SN*DCSO*SNO - 9.*SN*CSO*DSNO)/16. IF (J .EQ. 1) KLM = 15 IF (J .EQ. 3) KLM = 12 UV(J,KLM) = 3.*KQ2*(DCS*SNO**2 + 2.*CS*SNO*DSNO 1 - DSN*CSO*SNO - SN*DCSO*SNO - SN*CSO*DSNO)/8. UV(J+1,KLM) = KQ2*(11.*DCS*CSO*SNO + 11.*CS*DCSO*SNO 1 + 11.*CS*CSO*DSNO - 3.*DSN - 9.*KQ2*DSN*SNO**2 2 - 18.*KQ2*SN*SNO*DSNO)/8. IF (J .EQ. 1) KLM = 18 IF (J .EQ. 3) KLM = 13 UV(J,KLM) = (3.*DCS*CSO*SNO + 3.*CS*DCSO*SNO 1 + 3.*CS*CSO*DSNO + 2.*LV*CS + 2.*L*DCS - 3.*DSN*CSO**2 2 - 6.*SN*CSO*DCSO - 2.*DSN)/16. UV(J+1,KLM) = KQ2*(11.*DCS*SNO**2 + 22.*CS*SNO*DSNO 1 - 2.*LV*SN - 2.*L*DSN - 9.*DSN*CSO*SNO 2 - 9.*SN*DCSO*SNO - 9.*SN*CSO*DSNO)/16. UV(J,50+J) = - KQ2*(3.*LV*SN + 3.*L*DSN + 2.*L*LV*CS 1 + L**2*DCS)/8. UV(J,51+J) = (- 2.0*KQ2*L*LV*SN - KQ2*L**2*DSN + LV*CS 1 + L*DCS - DSN)/8. UV(J+1,50+J) = KQ2*(- 5.*LV*CS - 5.*L*DCS - 3.*DSN 1 + 2.0*KQ2*L*LV*SN + KQ2*L**2*DSN)/8. UV(J+1,51+J) = KQ2*(-3.*LV*SN - 3.*L*DSN - 2.*L*LV*CS 1 - L**2*DCS)/8. 100 RETURN END SUBROUTINE DFRINB C C CALCULATES PARTIAL DERIVATIVES OF BENDING MAGNET FRINGE C FIELD MATRIX ELEMENTS WITH RESPECT TO CENTRAL MAGNETIC C FIELD OR ANYTHING EQUIVALENT C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM0E.CIN' INCLUDE 'ELM2A.CIN' INCLUDE 'ELM2B.CIN' INCLUDE 'ELM4A.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'ELM16B.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'INDBND.CIN' INCLUDE 'INDPAR.CIN' INCLUDE 'R.CIN' C C LOCAL VARIABLES C INTEGER IANG, IB, IL, IRHO REAL HV C C-------------------------------------------------------------- LINEAR = .FALSE. IL = IPTOJB(NL) IB = IPTOJB(NBV) IRHO = IPTOJB(NRHO) IANG = IPTOJB(NANG) IF (IL .NE. 0 .AND. IANG .NE. 0) HV = H0*UNITI(7)*DPARM/AL IF (IB .NE. 0) HV = UNITI(9)*DPARM/PREF IF (IRHO .NE. 0) HV = - H0**2*DPARM*UNITI(8) RV(2,1) = HV*TB RV(4,3) = - HV*TB + 4.0*HV*H0*APB(2)*LAYL*SB*(SB**2 + TB**2) RETURN END SUBROUTINE DFRINJ C C CALCULATES PARTIAL DERIVATIVES OF BENDING MAGNET FRINGE FIELD C MATRIX ELEMENTS WITH RESPECT TO POLE FACT ROTATION ANGLE C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM0E.CIN' INCLUDE 'ELM2A.CIN' INCLUDE 'ELM2B.CIN' INCLUDE 'ELM4A.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'R.CIN' C C LOCAL VARIABLES C REAL BEV C C-------------------------------------------------------------------- LINEAR = .FALSE. BEV = DPARM*UNITI(7) IF (TYPE .EQ. 28 .AND. JV .EQ. 2) BEV = 0.5*BEV RV(2,1) = BEV*H0*SB**2 RV(4,3) = - BEV*H0*SB**2 1 + 2.0*BEV*H0**2*APB(2)*LAYL*SB*TB*(5.0*SB**2 + TB**2) C RETURN END SUBROUTINE DFRINR C C CALCULATES PARTIAL DERIVATIVES OF RBEND FRINGE FIELD MATRIX C ELEMENTS WITH RESPECT TO QUANTITIES DESCRIBING THE MAIN BODY C OF THE MAGNET C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM0E.CIN' INCLUDE 'ELM2A.CIN' INCLUDE 'ELM2B.CIN' INCLUDE 'ELM4A.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'ELM16B.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'ELM28.CIN' INCLUDE 'INDBND.CIN' INCLUDE 'INDPAR.CIN' INCLUDE 'R.CIN' C C LOCAL VARIABLES C INTEGER IANG, IB, IL, IRHO REAL BEV, CSA2, HV, SNA2 C C---------------------------------------------------------------- LINEAR = .FALSE. IL = IPTOJ(NL) IB = IPTOJ(NBV) IRHO = IPTOJ(NRHO) IANG = IPTOJ(NANG) GO TO (10,20,30,40), JV C 10 IF (IB .NE. 0) THEN SNA2 = 0.5*H0*LRBEND CSA2 = SQRT(1.0 - SNA2**2) BEV = 0.5*H0*UNITI(8)/CSA2 GO TO 110 ELSE IF (IRHO .NE. 0) THEN SNA2 = 0.5*H0*LRBEND CSA2 = SQRT(1.0 - SNA2**2) BEV = 0.5*H0*UNITI(8)/CSA2 GO TO 110 ELSE IF (IANG .NE. 0) THEN HV = - H0*UNITI(8)*DPARM/LRBEND GO TO 100 ENDIF GO TO 200 C 20 IF (IL .NE. 0) THEN HV = UNITI(9)*DPARM/PREF SNA2 = 0.5*H0*LRBEND CSA2 = SQRT(1.0 - SNA2**2) BEV = 0.5*LRBEND*UNITI(9)/(PREF*CSA2) GO TO 120 ELSE IF (IANG .NE. 0) THEN HV = UNITI(9)*DPARM/PREF GO TO 100 ENDIF GO TO 200 C 30 IF (IL .NE. 0) THEN HV = - H0**2*DPARM*UNITI(8) SNA2 = 0.5*H0*LRBEND CSA2 = SQRT(1.0 - SNA2**2) BEV = - 0.5*H0**2*LRBEND*UNITI(8)/CSA2 GO TO 120 ELSE IF (IANG .NE. 0) THEN HV = - H0**2*DPARM*UNITI(8) GO TO 100 ENDIF GO TO 200 C 40 BEV = 0.5*UNITI(7) IF (IL .NE. 0) THEN SNA2 = 0.5*H0*LRBEND CSA2 = SQRT(1.0 - SNA2**2) HV = CSA2*DPARM*UNITI(7)/LRBEND GO TO 120 ELSE IF (IB .NE. 0 .OR. IRHO .NE. 0) THEN GO TO 110 ENDIF GO TO 200 C 100 RV(2,1) = HV*TB RV(4,3) = - HV*TB + 4.0*HV*H0*APB(2)*LAYL*SB*(SB**2 + TB**2) GO TO 200 C 110 RV(2,1) = H0*SB**2*BEV RV(4,3) = - H0*SB**2*BEV GO TO 200 C 120 RV(2,1) = HV*TB + H0*SB**2*BEV RV(4,3) = - HV*TB + 4.0*HV*H0*APB(2)*LAYL*SB*(SB**2 + TB**2) 1 - H0*SB**2*BEV 2 + 4.0*H0**2*APB(2)*LAYL*TB*SB*(5.0*SB**2 + TB**2) 3 *BEV GO TO 200 C 200 RETURN END SUBROUTINE DOCTPL C C CALCULATES PARTIAL DERIVATIVES OF THIRD-ORDER MATRIX ELEMENTS C WITH RESPECT TO THE MAGNETIC FIELD ON AN OCTUPOLE C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM0B.CIN' INCLUDE 'ELM0E.CIN' INCLUDE 'ELM6.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'ELM16B.CIN' INCLUDE 'INDPAR.CIN' INCLUDE 'U.CIN' C C LOCAL VARIABLES C C------------------------------------------------------------------------ C IB = IPTOJ(2) IK1 = IPTOJ(4) IF (IB .NE. 0) DW2 = DPARM*UNITI(9)/(PREF*AP**3) IF (IK1 .NE. 0) DW2 = DPARM/UNITI(8)**3 S = - 0.5*DW2*L UV(1,1) = S*L UV(2,1) = 2.0*S UV(3,10) = S*L UV(4,10) = 2.0*S S = - .5*DW2*L**2 UV(1,2) = S*L UV(2,2) = 3.*S UV(3,16) = S*L UV(4,16) = 3.0*S S = - 0.25*DW2*L**3 UV(1,3) = S*L UV(2,3) = 4.0*S UV(3,19) = S*L UV(4,19) = 4.0*S S = - .05*DW2*L**4 UV(1,4) = S*L UV(2,4) = 5.0*S UV(3,20) = S*L UV(4,20) = 5.0*S S = 1.5*DW2*L UV(1,8) = S*L UV(2,8) = 2.0*S UV(3,5) = S*L UV(4,5) = 2.0*S S = DW2*L**2 UV(1,14) = S*L UV(2,14) = 3.0*S UV(3,6) = S*L UV(4,6) = 3.0*S S = 0.25*DW2*L**3 UV(1,17) = S*L UV(2,17) = 4.0*S UV(3,7) = S*L UV(4,7) = 4.0*S S = .5*DW2*L**2 UV(1,9) = S*L UV(2,9) = 3.0*S UV(3,11) = S*L UV(4,11) = 3.0*S S = .5*DW2*L**3 UV(1,15) = S*L UV(2,15) = 4.0*S UV(3,12) = S*L UV(4,12) = 4.0*S S = 0.15*DW2*L**4 UV(1,18) = S*L UV(2,18) = 5.0*S UV(3,13) = S*L UV(4,13) = 5.0*S RETURN END SUBROUTINE DSEXT2 C C CALCULATES PARTIAL DERIVATIVES OF SECOND-ORDER MATRIX ELEMENTS C WITH RESPECT TO THE MAGNETIC FIELD OF A SEXTUPOLE C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA0B.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0B.CIN' INCLUDE 'ELM0E.CIN' INCLUDE 'ELM4A.CIN' INCLUDE 'ELM6.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM10D.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'ELM16B.CIN' INCLUDE 'ELM17B.CIN' INCLUDE 'INDPAR.CIN' INCLUDE 'T.CIN' C C LOCAL VARIABLES C C------------------------------------------------------------------------------ IB = IPTOJ(2) IK2 = IPTOJ(4) IF (IB .NE. 0) W2 = 2.0*DPARM*UNITI(9)/(PREF*AP**2) IF (IK2 .NE. 0.0) W2 = 2.0*DPARM/UNITI(8)**3 S = - 0.25*W2*L TV(1,1) = S*L TV(2,1) = 2.0*S S = - W2*L**3/24.0 TV(1,3) = S*L TV(2,3) = 4.0*S S = 0.25*W2*L TV(1,6) = S*L TV(2,6) = 2.0*S S = W2*L**3/24.0 TV(1,10) = S*L TV(2,10) = 4.0*S S = - W2*L**2/6.0 TV(1,2) = S*L TV(2,2) = 3.0*S S = W2*L**2/6.0 TV(1,9) = S*L TV(2,9) = 3.0*S S = 0.5*W2*L TV(3,4) = S*L TV(4,4) = 2.0*S S = W2*L**2/6.0 TV(3,5) = S*L TV(3,7) = S*L TV(4,5) = 3.0*S TV(4,7) = 3.0*S S = W2*L**3/12.0 TV(3,8) = S*L TV(4,8) = 4.0*S IF (SEXLIM) THEN NV2 = IABS(TIE(I+2)) IF (NV2 .EQ. 100) THEN IADR = IDATA(I+2) NV2 = IABS(TIE(IADR)) ENDIF CW = 1.0/SEXMAX**2 CA(1,1) = CA(1,1) + CW*B**2 CA(NV2+1,1) = CA(NV2+1,1) - CW*B*UNITI(9) CA(NV2+1,NV2+1) = CA(NV2+1,NV2+1) + CW*UNITI(9)**2 ENDIF RETURN END SUBROUTINE DSEXT3 C C CALCULATES PARTIAL DERIVATIVES OF THIRD-ORDER MATRIX ELEMENTS C WITH RESPECT TO THE MAGNETIC FIELD OF AN OCTUPOLE C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM0B.CIN' INCLUDE 'ELM0E.CIN' INCLUDE 'ELM1A.CIN' INCLUDE 'ELM4A.CIN' INCLUDE 'ELM6.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'ELM16B.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'U.CIN' C C LOCAL VARIABLES C REAL DW2, S, W2 C------------------------------------------------------------------------------ LINEAR = .FALSE. W2 = 2.0*B/(RI*AP**2) DW2 = 2.0*DPARM*UNITI(9)/(PREF*AP**2) S = 2.0*W2*DW2*L**3/48. UV(1,1) = S*L UV(2,1) = 4.0*S UV(3,10) = S*L UV(4,10) = 4.0*S S = 2.0*W2*DW2*L**4/48. UV(1,2) = S*L UV(2,2) = 5.0*S UV(3,16) = S*L UV(4,16) = 5.0*S S = 2.0*W2*DW2*L**5/144. UV(1,3) = S*L UV(2,3) = 6.0*S UV(3,19) = S*L UV(4,19) = 6.0*S S = 2.0*W2*DW2*L**6/1008. UV(1,4) = S*L UV(2,4) = 7.*S UV(3,20) = S*L UV(4,20) = 7.*S S = 2.0*W2*DW2*L**3/48. UV(1,8) = S*L UV(2,8) = 4.0*S UV(3,5) = S*L UV(4,5) = 4.0*S S = 0.05*W2*DW2*L**4 UV(1,14) = S*L UV(2,14) = 5.0*S UV(3,6) = S*L UV(4,6) = 5.0*S S = 2.0*W2*DW2*L**5/240. UV(1,17) = S*L UV(2,17) = 6.0*S UV(3,7) = S*L UV(4,7) = 6.0*S S = - 2.0*W2*DW2*L**4/240. UV(1,9) = S*L UV(2,9) = 5.0*S UV(3,11) = S*L UV(4,11) = 5.0*S S = 2.0*W2*DW2*L**5/360. UV(1,15) = S*L UV(2,15) = 6.0*S UV(3,12) = S*L UV(4,12) = 6.0*S S = 2.0*W2*DW2*L**6/1008. UV(1,18) = S*L UV(2,18) = 7.0*S UV(3,13) = S*L UV(4,13) = 7.0*S S = 0.25*DW2*L UV(1,36) = S*L UV(2,36) = 2.0*S S = DW2*L**3/24. UV(1,38) = S*L UV(2,38) = 4.0*S S = - 0.25*DW2*L UV(1,41) = S*L UV(2,41) = 2.0*S S = - DW2*L**3/24. UV(1,45) = S*L UV(2,45) = 4.0*S S = DW2*L**2/6. UV(1,37) = S*L UV(2,37) = 3.0*S S = - DW2*L**2/6. UV(1,44) = S*L UV(2,44) = 3.0*S S = - 0.5*DW2*L UV(3,39) = S*L UV(4,39) = 2.0*S S = - DW2*L**2/6. UV(3,40) = S*L UV(3,42) = S*L UV(4,40) = 3.0*S UV(4,42) = 3.0*S S = - DW2*L**3/6. UV(3,43) = S*L UV(4,43) = 4.0*S RETURN END SUBROUTINE DSHFT C C CALCULATES THE PARTIAL DERIVATIVES OF THE FLOOR COORDINATES C WITH RESPECT TO THE SHIFT IN THE BEAM REFERENCE C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'COCOM.CIN' INCLUDE 'ELM0E.CIN' INCLUDE 'ELM7B.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'OIV.CIN' C C LOCAL VARIABLES C C--------------------------------------------------------------------------- C IF (JV .EQ. 2 .OR. JV .EQ. 4) GO TO 10 IF (JV .EQ. 5 .OR. JV .EQ. 6) GO TO 100 IF (JV .EQ. 1) XIV(1) = - DPARM*UNITI(1) IF (JV .EQ. 3) XIV(2) = - DPARM*UNITI(3) GO TO 100 C C SHIFT IN ANGLE C 10 TNT1 = CO(2) THETA1 = ATAN(TNT1) CST1 = COS(THETA1) SNT1 = SIN(THETA1) TNP1 = CO(4)*CST1 PHI1 = ATAN(TNP1) CSP1 = COS(PHI1) SNP1 = SIN(PHI1) PHI2 = ATAN(CO(4)-COD(4)) CSP2 = COS(PHI2) SNP2 = SIN(PHI2) THETA2 = ATAN((CO(2)-COD(2))*CSP2) CST2 = COS(THETA2) SNT2 = SIN(THETA2) C C SHIFT IN HORIZONTAL ANGLE C IF (JV .EQ. 4) GO TO 20 DCST1 = - SNT1*CST1**2*DPARM*UNITI(2) DSNT1 = CST1**3*DPARM*UNITI(2) OIV(1,1) = CST2*DCST1 + SNT2*DSNT1*CSP2*CSP1 OIV(1,2) = SNT2*SNP1 OIV(1,3) = CST2*DSNT1 - SNT2*DCST1*CSP1 OIV(2,1) = - SNT2*DCST1*SNP2 - DSNT1*CSP2*SNP1 1 + CST2*DSNT1*SNP2*CSP1 OIV(2,2) = CSP2*CSP1 + CST2*SNP2*SNP1 OIV(2,3) = - SNT2*DSNT1*SNP2 + DCST1*CSP2*SNP1 1 - CST2*DCST1*SNP2*CSP1 OIV(3,1) = SNT2*DCST1*CSP2 + SNT2*SNP2*SNP1 1 - CST2*DSNT1*CSP2*CSP1 OIV(3,2) = SNP2*CSP1 - CST2*CSP2*SNP1 OIV(3,3) = SNT2*DSNT1*CSP2 + DCST1*SNP2*SNP1 1 + CST2*DCST1*CSP2*CSP1 GO TO 100 C C SHIFT IN VERTICAL ANGLE C 20 DCSP1 = - SNP1*CSP1**2*DPARM*UNITI(4) DSNP1 = CSP1**3*DPARM*UNITI(4) OIV(1,1) = SNT2*SNT1*CSP2*DCSP1 OIV(1,2) = SNT2*DSNP1 OIV(1,3) = - SNT2*CST1*DCSP1 OIV(2,1) = SNT1*CSP2*DSNP1 + CST2*SNT1*SNP2*DCSP1 OIV(2,2) = CSP2*DCSP1 + CST2*SNP2*DSNP1 OIV(2,3) = CST1*CSP2*DSNP1 - CST2*CST1*SNP2*DCSP1 OIV(3,1) = SNT2*SNP2*DSNP1 - CST2*SNT1*CSP2*DCSP1 OIV(3,2) = SNP2*DCSP1 - CST2*CSP2*DSNP1 OIV(3,3) = CST1*SNP2*DSNP1 + CST2*CST1*CSP2*DCSP1 C 100 RETURN END SUBROUTINE DSOLE2 C C CALCULATES THE PARTIAL DERIVATIVES OF SECOND-ORDER MATRIX C ELEMENTS WITH RESPECT TO PARAMETERS DESCRIBING A SOLENOID C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM0B.CIN' INCLUDE 'ELM0E.CIN' INCLUDE 'ELM5B.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'ELM16B.CIN' INCLUDE 'ELM19.CIN' INCLUDE 'T.CIN' C------------------------------------------------------------------------------- C C LENGTH IS VARIED C IF (JV .EQ. 2) GO TO 10 TEMP = 0.5*KO*(SN + KL*CS)*LV TV(1,16) = TEMP TV(2,17) = TEMP TV(3,18) = TEMP TV(4,19) = TEMP TEMP = KL*SN*LV TV(1,17) = TEMP TV(3,19) = TEMP TEMP = - 0.5*KO*(CS - KL*SN)*LV TV(1,18) = TEMP TV(2,19) = TEMP TV(4,17) = - TEMP TV(3,16) = - TEMP TEMP = - KL*CS*LV TV(1,19) = TEMP TV(3,17) = - TEMP TEMP = 0.25*KO*(2.0*KO*CS - KO*KL*SN)*LV TV(2,16) = TEMP TV(4,18) = TEMP TEMP = 0.25*KO*(2.0*KO*SN + KO*KL*SN)*LV TV(2,18) = TEMP TV(4,16) = - TEMP GO TO 100 C C MAGNETIC FIELD IS VARIED C 10 TEMP = 0.5*L*(SN + KL*CS)*UNITI(9)/PREF TV(1,16) = TEMP TV(2,17) = TEMP TV(3,18) = TEMP TV(4,19) = TEMP TEMP = ( - SN/KO**2 + L*CS/KO + L**2*SN)*UNITI(9)/PREF TV(1,17) = TEMP TV(3,19) = TEMP TEMP = - 0.5*L*(CS - KL*SN)*UNITI(9)/PREF TV(1,18) = TEMP TV(2,19) = TEMP TV(4,17) = - TEMP TV(3,16) = - TEMP TEMP = ( - (1.0 - CS)/KO**2 + L*SN/KO - L**2*CS)*UNITI(9)/PREF TV(1,19) = TEMP TV(3,17) = - TEMP TEMP = 0.25*(3.0*KL*CS - KL**2*SN + SN)*UNITI(9)/PREF TV(2,16) = TEMP TV(4,18) = TEMP TEMP = 0.25*(3.0*KL*SN + KL**2*CS + 1.0 - CS)*UNITI(9)/PREF TV(2,18) = TEMP TV(4,16) = - TEMP C 100 RETURN END SUBROUTINE DSOLEN C C CALCULATES THE PARTIAL DERIVATIVES OF THE FIRST-ORDER MATRIX C ELEMENTS WITH RESPECT TO THE PARAMETERS DESCRIBING A SOLENOID C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM0B.CIN' INCLUDE 'ELM0E.CIN' INCLUDE 'ELM5B.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'ELM16B.CIN' INCLUDE 'ELM19.CIN' INCLUDE 'INDPAR.CIN' INCLUDE 'R.CIN' C C LOCAL VARIABLES C INTEGER IB, IK, J1 REAL DB C------------------------------------------------------------------------------- C CS = COS(KL) SN = SIN(KL) IF (JV .EQ. 1) GO TO 10 IF (JV .EQ. 2) GO TO 20 IF (JV .EQ. 3) GO TO 20 GO TO 50 C C LENGTH OF SOLENOID VARIED C 10 LV = DPARM*UNITI(8) RV(1,1) = - 0.5*KO*SN*LV RV(2,2) = RV(1,1) RV(1,2) = CS*LV RV(2,1) = - 0.25*KO**2*CS*LV RV(1,3) = 0.5*KO*CS*LV RV(2,4) = RV(1,3) RV(1,4) = SN*LV RV(2,3) = - 0.25*KO**2*SN*LV GO TO 50 C C FIELD OF SOLENOID VARIED C 20 IB = IPTOJ(2) IK = IPTOJ(3) IF (IB .NE. 0) DB = DPARM*L*UNITI(9)/PREF IF (IK .NE. 0) DB = 2.0*DPARM*UNITI(7) RV(1,1) = - 0.5*DB*SN RV(2,2) = RV(1,1) RV(1,2) = DB*( - SN/KL + CS)/KO RV(2,1) = - 0.25*DB*(SN/L + KO*CS) RV(1,3) = 0.5*DB*CS RV(2,4) = RV(1,3) RV(1,4) = DB*(SN - (1.0 - CS)/KL)/KO RV(2,3) = - 0.25*DB*(KO*SN + (1.0 - CS)/L) C C K FACTOR OF SOLENOID VARIED C 50 CONTINUE DO 55 J = 3, 4 DO 55 J1 = 1, 2 RV(J,J1) = - RV(J-2,J1+2) 55 CONTINUE DO 60 J = 1, 2 DO 60 J1 = 1, 2 RV(J+2,J1+2) = RV(J,J1) 60 CONTINUE RETURN END SUBROUTINE DSROTC C C CALCULATES THE PARTIAL DERIVATIVES OF THE TRANSFER MATRIX C ELEMENTS OF A KICK ELEMENT WITH RESPECT TO THE TILT (ROLL). C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM0E.CIN' INCLUDE 'ELM7B.CIN' INCLUDE 'ELM10E.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'ELM20.CIN' C C LOCAL VARIABLES C REAL CODS(6), CODT(6), DPU C C---------------------------------------------------------- IF (DCOV) THEN DO 75 J = 1, 4 75 CODS(J) = COD(J) C CODT(1) = - CODS(1)*SNR - CODS(3)*CSR CODT(2) = - CODS(2)*SNR - CODS(4)*CSR CODT(3) = CODS(1)*CSR - CODS(3)*SNR CODT(4) = CODS(2)*CSR - CODS(4)*SNR C DPU = DPARM*UNITI(13) DO 455 J = 1, 4 455 CODV(J) = CODT(J)*DPU ENDIF RETURN END SUBROUTINE DSROTN C C CALCULATES THE PARTIAL DERIVATIVES OF THE FIRST-ORDER MATRIX C ELEMENTS OF THE SROT ELEMENT C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM0E.CIN' INCLUDE 'ELM2B.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'ELM20.CIN' INCLUDE 'R.CIN' C C LOCAL VARIABLES C REAL DCS, DSN, DTH C C----------------------------------------------------------------- DTH = DPARM*UNITI(13) IF (TYPE .NE. 20 .AND. .NOT. BEFORE) DTH = - DTH DCS = - SNR*DTH IF (NDIF .LT. 0) DCS = - DCS RV(1,1) = DCS RV(2,2) = DCS RV(3,3) = DCS RV(4,4) = DCS DSN = CSR*DTH IF (NDIF .LT. 0) DSN = - DSN RV(2,4) = DSN RV(1,3) = DSN RV(4,2) = - DSN RV(3,1) = - DSN RETURN END SUBROUTINE DSROTR C C CALCULATES THE PARTIAL DERIVATIVES OF THE FIRST-ORDER MATRIX C ELEMENTS WITH RESPECT TO THE TILT (ROLL). C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM0E.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'R.CIN' C--------------------------------------------------------------- DO 20 J = 1, 6 DO 20 K = 1, 6 RV(J,K) = R(J,K) 20 CONTINUE C DO 50 K = 1, 6 RV1K = - RV(3,K) RV2K = - RV(4,K) RV(3,K) = RV(1,K) RV(4,K) = RV(2,K) RV(1,K) = RV1K RV(2,K) = RV2K 50 CONTINUE C DO 55 J = 1, 6 RVJ1 = - RV(J,3) RVJ2 = - RV(J,4) RV(J,3) = RV(J,1) RV(J,4) = RV(J,2) RV(J,1) = RVJ1 RV(J,2) = RVJ2 55 CONTINUE C DPU = DPARM*UNITI(13) DO 60 J = 1, 6 DO 60 K = 1, 6 RV(J,K) = RV(J,K)*DPU 60 CONTINUE C RETURN END SUBROUTINE EL242 C C STEP THROUGH BEND ELEMENT WITH POSSIBLE FRINGE FIELDS C (ROTAT ELEMENT) C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA0A.CIN' INCLUDE 'DATA1A.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM0C.CIN' INCLUDE 'ELM2B.CIN' INCLUDE 'ELM2D.CIN' INCLUDE 'ELM4E.CIN' INCLUDE 'ELM8A.CIN' INCLUDE 'ELM8G.CIN' INCLUDE 'ELM8H.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM10E.CIN' INCLUDE 'ELM13A.CIN' INCLUDE 'ELM13B.CIN' INCLUDE 'ELM13C.CIN' INCLUDE 'ELM16B.CIN' INCLUDE 'FLUSHC.CIN' INCLUDE 'INDBND.CIN' INCLUDE 'INDPAR.CIN' INCLUDE 'LXRAN.CIN' INCLUDE 'OCP.CIN' INCLUDE 'R2P.CIN' INCLUDE 'R3P.CIN' INCLUDE 'STEPT1.CIN' C C LOCAL VARIABLES C INTEGER IDATA, IMIS INTEGER NUME, NUMS, NUM2I, NUM2O INTEGER TYPEN LOGICAL CKK EXTERNAL IDATA C C DETERMINE WHICH PARTS OF 2-4-2 ARE PRESENT C NUMS = NUM FFIN = .FALSE. IF (TYPE .EQ. 2) THEN CALL CHEK(CKK) IF (.NOT. CKK) GO TO 200 NUM2I = NUM NUM = NUM4 I = ISTOR(NUM) TYPE = IDATA(I) CALL SKETCH(NUM) CALL DEPICT ELSE NUM4 = NUM ENDIF TILT = IPTOJ(NTILT) .NE. 0 CALL HUNT2 IF (FFOUT) THEN NUM2O = NUM2 NUME = NUM2O ELSE NUME = NUM4 ENDIF C NUM = NUMS I = ISTOR(NUM) TYPE = IDATA(I) TYPEC = TYPE IF (TYPE .EQ. 2 .AND. NUM2I + NDIF .NE. NUM4) GO TO 60 IF (FFOUT .AND. NUM4 + NDIF .NE. NUM2O) GO TO 60 GO TO 70 C C ALGEBRAIC COMBINATIONS C 60 IF (TYPE .EQ. 23 .OR. TYPE .EQ. 30) THEN IF (NV3 .GE. 1) THEN CALL DERIVE ELSE CALL ELICIT CALL POSTER ENDIF IF (FLUSHL) GO TO 200 IF (TYPE .LE. 0) GO TO 200 ENDIF IF (NUM .LT. NUME) THEN NUM = NUM + NDIF I = ISTOR(NUM) TYPE = IDATA(I) TYPEC = TYPE GO TO 60 ENDIF C 70 NUM = NUMS I = ISTOR(NUM) TYPE = IDATA(I) BEFORE = .TRUE. C C CHECK FOR MISALIGNMENTS C DMC = .FALSE. IF (ALO(1)) THEN NMIS = NM4 NMISE = NUM4 IMIS = ISTOR(NMIS) TYT = INT(DATA(IMIS+7)) LFM = TYT/100 RORC = MOD(TYT,10) IR = 1 IF (FFIN .OR. FFOUT) IR = 3 DMC = LFM .GE. 1 ENDIF C C ENTRANCE MISALIGNMENT C IF (DMC) THEN TYPEC = 8 LXRAN = LFM .EQ. 2 CALL SKETCH(NMISE) IF (NV3 .GE. 1) THEN CALL DERIVE ELSE CALL ELICIT IF (.NOT. LSTEPN) THEN CALL POSTER CALL MPRINT ENDIF ENDIF IF (FLUSHL) GO TO 200 IF (TYPE .LE. 0) GO TO 200 ENDIF IF (LFM .EQ. 0 .AND. ALO(1) .AND. (FFIN .OR. FFOUT) .AND. R2P) 1 CALL UPDAT2 IF (LFM .EQ. 1 .AND. ALO(1) .AND. (FFIN .OR. FFOUT) .AND. OCP(3)) 1 CALL RESET(3) C C ROTATION OF ELEMENT C IF (TILT) THEN TYPEC = 20 IF (NV3 .GE. 1) THEN CALL DERIVE ELSE CALL ELICIT IF (.NOT. LSTEPN) CALL POSTER ENDIF IF (FLUSHL) GO TO 200 IF (TYPE .LE. 0) GO TO 200 ENDIF C C ENTRANCE FRINGE FIELD C IF (LAY) CALL CSAVE IF (FFIN) THEN NUM = NUM2I I = ISTOR(NUM) TYPE = IDATA(I) TYPEC = TYPE LXRAN = .TRUE. CALL SKETCH(NUM4) IF (NV3 .GE. 1) THEN CALL DERIVE ELSE CALL ELICIT IF (.NOT. LSTEPN) THEN CALL POSTER CALL VPRINT ENDIF ENDIF IF (FLUSHL) GO TO 200 IF (TYPE .LE. 0) GO TO 200 C C ALGEBRAIC OPERATIONS C 140 IF (NDIF .GT. 0 .AND. NUM .GE. NUM4 - NDIF) GO TO 150 IF (NDIF .LT. 0 .AND. NUM .LE. NUM4 - NDIF) GO TO 150 NUM = NUM + NDIF I = ISTOR(NUM) TYPE = IDATA(I) TYPEC = TYPE IF (NV3 .GE. 1) NCT = NCT + 1 IF (TYPE .NE. 23 .AND. TYPE .NE. 30) THEN IF (NV3 .GE. 1) THEN CALL DERIVE ELSE CALL ELICIT IF (.NOT. LSTEPN) CALL POSTER ENDIF IF (FLUSHL) GO TO 200 IF (TYPE .LE. 0) GO TO 200 ENDIF GO TO 140 ENDIF C C CENTRAL BODY OF BEND C 150 NUM = NUM4 I = ISTOR(NUM) TYPE = IDATA(I) TYPEC = TYPE IF (NV3 .GE. 1 .AND. FFIN) NCT = NCT + 1 IF (FFIN .OR. DMC) CALL SKETCH(NUM) LXRAN = .NOT. FFIN IF (NV3 .GE. 1) THEN CALL DERIVE ELSE CALL ELICIT IF (.NOT. LSTEPN) THEN CALL POSTER CALL VPRINT ENDIF ENDIF IF (FLUSHL) GO TO 200 IF (TYPE .LE. 0) GO TO 200 C C EXIT FRINGING FIELD C BEFORE = .FALSE. IF (FFOUT) THEN 170 NUM = NUM + NDIF I = ISTOR(NUM) TYPE = IDATA(I) TYPEC = TYPE IF (NV3 .GE. 1) NCT = NCT + 1 IF (TYPE .NE. 23 .AND. TYPE .NE. 30) THEN CALL SKETCH(NUM) LXRAN = TYPE .EQ. 2 IF (NV3 .GE. 1) THEN CALL DERIVE ELSE CALL ELICIT IF (.NOT. LSTEPN) THEN CALL POSTER IF (TYPE .EQ. 2) THEN CALL VPRINT IF (LAY .AND. PBP) CALL BPRINT ENDIF ENDIF ENDIF IF (FLUSHL) GO TO 200 IF (TYPE .LE. 0) GO TO 200 ENDIF IF (NDIF .GT. 0 .AND. NUM .LT. NUM2O) GO TO 170 IF (NDIF .LT. 0 .AND. NUM .GT. NUM2O) GO TO 170 ENDIF IF (NV3 .LE. 0 .AND. .NOT. LSTEPN) THEN TYPEN = IDATA(ISTOR(NUM+NDIF)) IF (TILT .OR. (REFER .AND. TYPEN .EQ. 20)) SONLY = .TRUE. CALL MPRINT IF (TILT .OR. (REFER .AND. TYPEN .EQ. 20)) SONLY = .FALSE. ENDIF C C REVERSE ROTATION OF ELEMENT C IF (TILT) THEN TYPEC = 20 IF (NV3 .GE. 1) THEN CALL DERIVE ELSE CALL ELICIT IF (.NOT. LSTEPN) THEN CALL POSTER CALL MPRINT ENDIF ENDIF IF (FLUSHL) GO TO 200 IF (TYPE .LE. 0) GO TO 200 ENDIF C C SEE IF ELEMENT IS MISALIGNED C DMC = .FALSE. IF (ALO(1)) THEN NMIS = NM4 DMC = .TRUE. ENDIF C C EXIT MISALIGNMENT C IF (DMC) THEN IF (NV3 .GE. 1) THEN IF (LFM .EQ. 0 .AND. (R2P .OR. R3P)) CALL UPDAT2 ELSE IF (LFM .EQ. 0 .AND. R2P) CALL UPDAT2 ENDIF TYPEC = 8 CALL SKETCH(NMIS) IF (NV3 .GE. 1) THEN CALL DERIVE ELSE CALL ELICIT IF (.NOT. LSTEPN) THEN CALL POSTER CALL MPRINT ENDIF ENDIF IF (FLUSHL) GO TO 200 IF (TYPE .LE. 0) GO TO 200 ENDIF C 200 RETURN END SUBROUTINE ELCOMP C C STEPS THROUGH COMPOUND ELEMENTS (RBEND, SBEND, HKICK, VKICK, C AND KICKER) C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA0A.CIN' INCLUDE 'DATA0B.CIN' INCLUDE 'DATA1A.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM0C.CIN' INCLUDE 'ELM2B.CIN' INCLUDE 'ELM4E.CIN' INCLUDE 'ELM8A.CIN' INCLUDE 'ELM8G.CIN' INCLUDE 'ELM8H.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM13B.CIN' INCLUDE 'ELM13C.CIN' INCLUDE 'ELM16B.CIN' INCLUDE 'FLUSHC.CIN' INCLUDE 'INDBND.CIN' INCLUDE 'INDPAR.CIN' INCLUDE 'LXRAN.CIN' INCLUDE 'OCP.CIN' INCLUDE 'R2P.CIN' INCLUDE 'R3P.CIN' INCLUDE 'STEPT1.CIN' C C LOCAL VARIABLES C INTEGER ID, IMIS, IPT, IPTOJM(25), J LOGICAL TILINT REAL DATAR C C ELEMENTS VKICK AND KICKER ARE TREATED LIKE ROTATED HKICK C TILT = .FALSE. IF (TYPE .EQ. 36) THEN TILT = .TRUE. ELSE IF (TYPE .EQ. 42) THEN IF (IPTOJ(3) .NE. 0) THEN ID = IPTOJ(3) IF (DATAR(I+ID) .NE. 0.0 .OR. TIE(I+ID) .NE. 0) 1 TILT = .TRUE. ENDIF ELSE IPT = IPTOJ(NTILT) IF (IPT .NE. 0) THEN IF (DATAR(I+IPT) .NE. 0.0 .OR. TIE(I+IPT) .NE. 0) 1 TILT = .TRUE. ENDIF ENDIF BEFORE = .TRUE. C C CHECK FOR MISALIGNMENTS C DMC = .FALSE. IF (ALO(1)) THEN NMIS = NM4 NMISE = NUM4 IMIS = ISTOR(NMIS) TYT = INT(DATA(IMIS+7)) LFM = TYT/100 RORC = MOD(TYT,10) IR = 3 DMC = LFM .GE. 1 ENDIF C C ENTRANCE MISALIGNMENT C IF (DMC) THEN TYPEC = 8 LXRAN = LFM .EQ. 2 DO 50 J = 1, 25 50 IPTOJB(J) = IPTOJ(J) CALL SKETCH(NMISE) DO 60 J = 1, 25 60 IPTOJM(J) = IPTOJ(J) IF (NV3 .GE. 1) THEN CALL DERIVE ELSE CALL ELICIT IF (.NOT. LSTEPN) THEN CALL POSTER CALL MPRINT ENDIF ENDIF IF (FLUSHL) GO TO 200 IF (TYPE .LE. 0) GO TO 200 DO 70 J = 1, 25 70 IPTOJ(J) = IPTOJB(J) ENDIF IF (LFM .EQ. 0 .AND. ALO(1) .AND. R2P) CALL UPDAT2 IF (LFM .EQ. 1 .AND. ALO(1) .AND. OCP(3)) CALL RESET(3) C C COORDINATE ROTATION C LXRAN = .TRUE. IF (TILT) THEN TYPEC = 20 IF (NV3 .GE. 1) THEN CALL DERIVE ELSE CALL ELICIT IF (.NOT. LSTEPN) THEN TILINT = .FALSE. IF (TYPE .EQ. 28 .OR. TYPE .EQ. 29 .OR. TYPE .EQ. 35 1 .OR. TYPE .EQ. 42) THEN TILINT = .TRUE. ELSE IF (TYPE .EQ. 36) THEN IPT = IPTOJ(NTILT) IF (IPT .NE. 0.0) THEN IF (DATA(I+IPT) .NE. 0.0 .OR. TIE(I+IPT) .NE. 0) 1 TILINT = .TRUE. ENDIF ENDIF IF (TILINT) THEN CALL POSTER SONLY = .TRUE. CALL MPRINT SONLY = .FALSE. ENDIF ENDIF ENDIF IF (FLUSHL) GO TO 200 IF (TYPE .LE. 0) GO TO 200 ENDIF C C ENTRANCE FRINGING FIELD C TYPEC = 2 IF (NV3 .GE. 1) THEN CALL DERIVE ELSE IF (LAY) CALL CSAVE CALL ELICIT IF (.NOT. LSTEPN) THEN IF (TYPE .EQ. 28 .OR. TYPE .EQ. 29) CALL POSTER ENDIF ENDIF IF (FLUSHL) GO TO 200 IF (TYPE .LE. 0) GO TO 200 C C CENTRAL BODY OF BEND C IF (TYPE .EQ. 28 .OR. TYPE .EQ. 29) TYPEC = 4 IF (TYPE .EQ. 35 .OR. TYPE .EQ. 36 .OR. TYPE .EQ. 42) TYPEC = 35 IF (NV3 .GE. 1) THEN CALL DERIVE ELSE CALL ELICIT IF (.NOT. LSTEPN) THEN CALL POSTER ENDIF ENDIF IF (FLUSHL) GO TO 200 IF (TYPE .LE. 0) GO TO 200 C C EXIT FRINGING FIELD C TYPEC = 2 BEFORE = .FALSE. IF (NV3 .GE. 1) THEN CALL DERIVE ELSE CALL ELICIT IF (.NOT. LSTEPN) THEN IF (TYPE .EQ. 28 .OR. TYPE .EQ. 29) CALL POSTER CALL VPRINT IF ((TYPE .EQ. 28 .OR. TYPE .EQ. 29) .AND. LAY .AND. PBP) 1 CALL BPRINT IF (TILT) THEN IF (TILINT .OR. TYPE .NE. 36) THEN IF (TILINT) SONLY = .TRUE. CALL MPRINT IF (TILINT) SONLY = .FALSE. ENDIF ELSE CALL MPRINT ENDIF ENDIF ENDIF IF (FLUSHL) GO TO 200 IF (TYPE .LE. 0) GO TO 200 C C REVERSE ROTATION OF ELEMENT C IF (TILT) THEN TYPEC = 20 IF (NV3 .GE. 1) THEN CALL DERIVE ELSE CALL ELICIT IF (.NOT. LSTEPN) THEN IF (TILINT) CALL POSTER IF (TILINT .OR. TYPE .EQ. 36) CALL MPRINT ENDIF ENDIF IF (FLUSHL) GO TO 200 IF (TYPE .EQ. 0) GO TO 200 ENDIF C C SEE IF ELEMENT IS MISALIGNED C DMC = .FALSE. IF (ALO(1)) THEN NMIS = NM4 DMC = .TRUE. ENDIF C C EXIT MISALIGNMENT C IF (DMC) THEN IF (NV3 .GE. 1) THEN IF (LFM .EQ. 0 .AND. (R2P .OR. R3P)) CALL UPDAT2 ELSE IF (LFM .EQ. 0 .AND. R2P) CALL UPDAT2 ENDIF TYPEC = 8 DO 180 J = 1, 25 180 IPTOJ(J) = IPTOJM(J) IF (NV3 .GE. 1) THEN CALL DERIVE ELSE CALL ELICIT IF (.NOT. LSTEPN) THEN CALL POSTER CALL MPRINT ENDIF ENDIF IF (FLUSHL) GO TO 200 IF (TYPE .LE. 0) GO TO 200 ENDIF C 200 RETURN END SUBROUTINE ELICIT C C ACCUMULATES MATRICES WHEN NOT FITTING C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'COCOM.CIN' INCLUDE 'COP.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM0D.CIN' INCLUDE 'ELM7B.CIN' INCLUDE 'ELM8A.CIN' INCLUDE 'ELM8H.CIN' INCLUDE 'ELM10E.CIN' INCLUDE 'ELM13B.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'ETACOM.CIN' INCLUDE 'ETAP.CIN' INCLUDE 'FLUSHC.CIN' INCLUDE 'R.CIN' INCLUDE 'R2P.CIN' INCLUDE 'R0P.CIN' C C LOCAL VARIABLES C REAL COT(6), COTF(6) C C------------------------------------------------------------------ C DETERMINE EFFECT OF ELEMENT C CALL ELMENT(NWK) IF (TYPE .LE. 0) GO TO 550 IF (FLUSHL) GO TO 550 IF (CFIT .AND. .NOT. RMTX) GO TO 520 IF (NWK .NE. 1) GO TO 550 C C MULTIPLY TRANSFER MATRICES C IF (RAY) CALL THREAD(0,ETA) IF (ALIGN) CALL RTORO IF (SOFA) THEN IF (R1P) THEN DO 110 J = 1, 6 110 COTF(J) = COF(J) CALL THRED1(R,COTF) ENDIF DO 113 J = 1, 6 113 COT(J) = CO(J) CALL THREAD(0,COT) IF (NORD1 .GE. 2 .AND. NORD2 .GE. 1) CALL ENRICH(0) ENDIF IF (NORD2 .GE. 1) CALL MRR2 C IF (SOFA) THEN IF (R1P) THEN IF (DCOV) THEN DO 241 J = 1, 6 241 COF(J) = COTF(J) + COD(J) ELSE DO 242 J = 1, 6 242 COF(J) = COTF(J) ENDIF ENDIF IF (DCOV) THEN DO 265 J = 1, 6 265 CO(J) = COT(J) + COD(J) ELSE DO 270 J = 1, 6 270 CO(J) = COT(J) ENDIF ELSE IF (DCOV) THEN IF (R1P) THEN DO 273 J = 1, 6 273 COF(J) = COD(J) ENDIF DO 275 J = 1, 6 275 CO(J) = COD(J) SOFA = .TRUE. NORD1 = NORDX ENDIF C C ADVANCE TO NEXT ELEMENT C 500 IF (ALIGN) THEN CALL ADVANC(2) CALL ADVANC(3) ENDIF 510 R2P = .TRUE. R0P = .TRUE. 520 IF (LAY) CALL ADVANC(4) IF (NM .GE. 1) CALL DAMAGE DO 530 J = 1, 6 530 CONTINUE C 550 RETURN END SUBROUTINE ELMENT(NWK) C C EVALUATES THE NUMERICAL EFFECT OF EACH ELEMENT C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'BETAC.CIN' INCLUDE 'COCOM.CIN' INCLUDE 'CONSTS.CIN' INCLUDE 'COP.CIN' INCLUDE 'DATA0A.CIN' INCLUDE 'DATA0B.CIN' INCLUDE 'DATA1A.CIN' INCLUDE 'DATA1C.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'DATA2D.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM0B.CIN' INCLUDE 'ELM0C.CIN' INCLUDE 'ELM0D.CIN' INCLUDE 'ELM0E.CIN' INCLUDE 'ELM1A.CIN' INCLUDE 'ELM1C.CIN' INCLUDE 'ELM1D.CIN' INCLUDE 'ELM2A.CIN' INCLUDE 'ELM2B.CIN' INCLUDE 'ELM2D.CIN' INCLUDE 'ELM4A.CIN' INCLUDE 'ELM4D.CIN' INCLUDE 'ELM4E.CIN' INCLUDE 'ELM5A.CIN' INCLUDE 'ELM5B.CIN' INCLUDE 'ELM6.CIN' INCLUDE 'ELM7B.CIN' INCLUDE 'ELM8A.CIN' INCLUDE 'ELM8B.CIN' INCLUDE 'ELM8C.CIN' INCLUDE 'ELM8G.CIN' INCLUDE 'ELM8H.CIN' INCLUDE 'ELM8L.CIN' INCLUDE 'ELM9.CIN' INCLUDE 'ELM10A.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM10E.CIN' INCLUDE 'ELM13A.CIN' INCLUDE 'ELM13B.CIN' INCLUDE 'ELM14A.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'ELM15B.CIN' INCLUDE 'ELM15C.CIN' INCLUDE 'ELM16A.CIN' INCLUDE 'ELM16B.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'ELM20.CIN' INCLUDE 'ELM23.CIN' INCLUDE 'ELM24A.CIN' INCLUDE 'ELM26A.CIN' INCLUDE 'ELM26B.CIN' INCLUDE 'ELM31A.CIN' INCLUDE 'ELM38A.CIN' INCLUDE 'ELM38B.CIN' INCLUDE 'ELM39A.CIN' INCLUDE 'ELM39C.CIN' INCLUDE 'ELM42.CIN' INCLUDE 'ETACOM.CIN' INCLUDE 'ETAP.CIN' INCLUDE 'FLUSHC.CIN' INCLUDE 'HORNS.CIN' INCLUDE 'INDBND.CIN' INCLUDE 'INDPAR.CIN' INCLUDE 'IOUNIT.CIN' INCLUDE 'LXRAN.CIN' INCLUDE 'NHORN.CIN' INCLUDE 'NXRAN.CIN' INCLUDE 'R.CIN' INCLUDE 'RCP.CIN' INCLUDE 'R2P.CIN' INCLUDE 'R3P.CIN' INCLUDE 'SI.CIN' INCLUDE 'STEPT1.CIN' INCLUDE 'XRAN.CIN' INCLUDE 'XRAN4.CIN' INCLUDE 'ZHORN.CIN' C C LOCAL VARIABLES C EXTERNAL DATAR, IDATA C C----------------------------------------------------------------------- C L = 0.0 TH = 0.0 CALL DEPIC2 IF (TYPE .NE. 14) THEN IF (.NOT. RMTX .AND. .NOT. OMTX) GO TO 80 IF (.NOT. RMTX) GO TO 70 ELSE IF (TYP1 .EQ. 14) GO TO 80 ENDIF C DCOV = .FALSE. DO 52 J = 1, 6 52 COD(J) = 0.0 IF (NORD1 .GE. 1) THEN DO 55 J = 1, 36 55 RL(J) = 0.0 DO 60 J = 1, 36, 7 60 RL(J) = 1.0 ENDIF C 70 IF (ALIGN .AND. RMTX) THEN CALL PICKUP(1) IF (.NOT. RCP .AND. .NOT. R2P .AND. .NOT. R3P) CALL PICKUP(2) IF (.NOT. R2P .AND. .NOT. R3P) CALL PICKUP(3) IF (TYPE .EQ. 3 .OR. TYPE .EQ. 4 .OR. TYPE .EQ. 5 1 .OR. TYPE .EQ. 11 .OR. TYPE .EQ. 18 .OR. TYPE .EQ. 19 2 .OR. TYPE .EQ. 28 .OR. TYPE .EQ. 29) 3 LAST = LABEL(NUM)(1:8) ENDIF C 80 NWK = 0 IF (.NOT. RANZC) GO TO 90 IF (.NOT. LXRAN) GO TO 90 C INDEX = TYPE IF (TYPEC .EQ. 8) INDEX = TYPEC NXR = NXRAN(INDEX) IF (NXR .GT. 0) THEN DO 85 J = 1, NXR XRAN(J) = RANDIS() 85 CONTINUE ENDIF C IF (TYPE .EQ. 2 .AND. BEFORE) THEN NXR = NXRAN(2) DO 86 J = 1, NXR 86 XRAN2I(J) = XRAN(J) NXR = NXRAN(4) DO 87 J = 1, NXR XRAN(J) = RANDIS() 87 XRAN4(J) = XRAN(J) ENDIF C LXRAN = .FALSE. C 90 IF (TYPE .GE. 82 .AND. TYPE .LE. 86) GO TO 7800 GO TO ( 100, 200, 300, 400, 500, 600, 700, 800, 900,1000, 1 1100,1200,1300,1400,1500,1600,1700,1800,1900,2000, 2 2100,2200,2300,2400,2500,2600,2700,2800,2800,3000, 3 3100,3200,3300,3400,3500,3500,3700,3800,3900,4000, 4 4100,4200,4300,5020,4500,4600,4600,4600), TYPE C C 1. -- BEAM C 100 CALL BEAMIN GO TO 5020 C C 2. -- POLE FACE ROTATION C 200 IF (TYPEC .EQ. 20) GO TO 250 IF (TYPEC .EQ. 8) GO TO 260 C IF (BEFORE .AND. .NOT. DMC) THEN IBEND = ISTOR(NUM4) CALL BGET(IBEND) CALL SKETCH(NUM) ENDIF CALL BFGET IF (NORD1 .GE. 3 .AND. (LAYL .EQ. 0.0 .OR. APB(2) .EQ. 0.0)) THEN WRITE (NOUT,9016) 9016 FORMAT (' *** ERROR *** FRINGING FIELD MUST HAVE NONZERO', 1 ' EXTENT IN THIRD ORDER') FLUSHL = .TRUE. GO TO 5020 ENDIF CALL FRINGE GO TO 5000 C 250 WRITE (NOUT,9005) FLUSHL = .TRUE. GO TO 5020 C 260 NMIS = NM4 NMISE = NUM4 NUPD = 3 CALL MISGET IF (VMMAX .NE. 0 .OR. NV3 .NE. 0) THEN CALL MALIGN IF (FLUSHL) GO TO 5020 IF (LFM .GE. 1 .AND. LTAB .EQ. 0) GO TO 5000 ENDIF GO TO 5020 C C 3. -- DRIFT SPACE C 300 IADR = I + 1 L = DATAR(IADR) IF (PRAN3 .NE. 0.0) L = L + PRAN3*XRAN(1) L = L*UNITI(8) IF (NORD1 .GE. 1) THEN R(1,2) = L R(3,4) = L IF (SM .NE. 0.0 .AND. RI .NE. 0.0) R(5,6) = L/GAMMA**2 ENDIF IT = IPTOJ(2) IF (IT .EQ. 0) THEN NUMTYP = IT ELSE NUMTYP = IDATA(I + IT) ENDIF GO TO 5000 C C 4. -- BENDING MAGNET C 400 IF (TYPEC .EQ. 8) GO TO 460 IF (TYPEC .EQ. 20) GO TO 450 IF (.NOT. FFIN) CALL BGET(I) L = LBEND LMAG = L TOTANG = TOTANG + AL C CALL BVGET CALL BEND IF (FLUSHL) GO TO 5020 GO TO 5000 C 450 WRITE (NOUT,9005) 9005 FORMAT (' TILT NOT PERMITTED ON BEND -- TRY RBEND OR SBEND') FLUSHL = .TRUE. GO TO 5020 C 460 NMIS = NM4 NUPD = 1 IF (FFIN .OR. FFOUT) NUPD = 3 CALL MISGET IF (VMMAX .NE. 0.0 .OR. NV3 .NE. 0) THEN NMISE = NUM NUM4 = NUM CALL MALIGN IF (FLUSHL) GO TO 5020 IF (LFM .GE. 1 .AND. LTAB .EQ. 0) GO TO 5000 ENDIF GO TO 5020 C C 5. -- QUADRUPOLE C 500 IF (TYPEC .EQ. 20) GO TO 560 IF (TYPEC .EQ. 8) GO TO 570 C CALL GGET IF (NORD1 .LT. 1) GO TO 550 C KX2 = KQ2 JQUAD = 1 CALL FOCUS CX = R(1,1) SX = R(1,2) JQUAD = 3 KQ2 = - KQ2 KY2 = KQ2 CALL FOCUS CY = R(3,3) SY = R(3,4) IF (SM .NE. 0.0 .AND. RI .NE. 0.0) R(5,6) = L/GAMMA**2 C 550 GO TO 5000 C 560 IROLL = IPTOJ(6) IF (IROLL .EQ. 0) GO TO 5020 IADR = I + IROLL TH = DATAR(IADR)*UNITI(13) IF (.NOT. BEFORE) TH = - TH CALL ROTATE(NPM) IF (NPM .EQ. 4) GO TO 2040 IF (.NOT. REFER) GO TO 5000 GO TO 5020 C 570 NMIS = NM5 NUPD = 1 CALL MISGET IF (VMMAX .NE. 0.0 .OR. NV3 .NE. 0) THEN NMISE = NUM CALL MALIGN IF (FLUSHL) GO TO 5020 IF (LFM .GE. 1 .AND. LTAB .EQ. 0) GO TO 5000 ENDIF GO TO 5020 C C 6. -- UPDATE C 600 IF (.NOT. ATWE) GO TO 5020 IF (TYPEC .EQ. 8) GO TO 650 JA = INT(DATA(I+1)) KA = INT(DATA(I+2)) IF (JA .NE. 0) GO TO 5020 IF (NORD3 .GT. 1 .AND. .NOT. NOPH .AND. R2P) THEN WRITE (NOUT,9003) 9003 FORMAT (' *** ERROR *** UPDATE NOT PERMITTED WITH OFF-AXIS', 1 ' EXPANSION, NONZERO PHASE SPACE, AND SECOND-ORDER', 2 ' MATRIX DISPLAY') FLUSHL = .TRUE. GO TO 5020 ENDIF IF (KA .EQ. 1) THEN IF (RCP .OR. R2P .OR. R3P) CALL UPDATE ELSE IF (KA .EQ. 2) THEN IF (R2P .OR. R3P) CALL UPDAT2 ENDIF GO TO 5020 C 650 IF (JA .NE. 0) GO TO 5020 BEFORE = .TRUE. CALL MISGET IF (VMMAX .NE. 0.0 .OR. NV3 .NE. 0) THEN IF (LTAB .EQ. 1) THEN IF (NM .GE. 10) GO TO 5020 LABM(NM+1) = LAST(1:8) ENDIF CALL MALIGN IF (FLUSHL) GO TO 5020 IF (LFM .GE. 1 .AND. LTAB .EQ. 0) GO TO 5000 ENDIF GO TO 5020 C C 7. -- BEAM CENTROID SHIFT C 700 DO 710 J = 1, 6 IPLUSJ = I + J COD(J) = DATAR(IPLUSJ) IF (PRAN7(J) .NE. 0.0) 1 COD(J) = COD(J) + PRAN7(J)*XRAN(J) COD(J) = COD(J)*UNITI(J) 710 CONTINUE RECENT = .FALSE. DCOV = .TRUE. C IF (SOFA) THEN DO 712 J = 1, 6 712 CO(J) = CO(J) + COD(J) ELSE DO 716 J = 1, 6 716 CO(J) = COD(J) SOFA = .TRUE. NORD1 = NORDX IF (BAX) THEN DO 720 J = 1, 6 720 COF(J) = CO(J) R1P = .TRUE. ENDIF ENDIF GO TO 5020 C C 8. -- MAGNET MISALIGNMENT C 800 IF (.NOT. ATWE) GO TO 5020 IF (ACCEL) GO TO 890 VMMAX = 0.0 DO 810 J = 1, 6 IPLUSJ = I + J I2MOD = 2 - MOD(J,2) VM(J) = DATAR(IPLUSJ)*UMIS(I2MOD) VMMAX = AMAX1(VMMAX,ABS(VM(J))) 810 CONTINUE C TYT = INT(DATA(I+7)) RORC = MOD(TYT,10) LTAB = MOD(TYT/10,10) LFM = TYT/100 IR = RORC + 1 IF (VMMAX .EQ. 0.0 .AND. NV3 .EQ. 0) THEN TYT = 0 GO TO 5020 ENDIF C IF (IPTOJ(8) .EQ. 0) THEN MCF = MCFO ELSE MCF = INT(DATA(I+8)) ENDIF TMK = MCF/100 CHORD = MOD(MCF/10,10) .EQ. 0 FEO = MOD(MCF,10) .EQ. 1 C IF (RORC .GE. 3) GO TO 850 IF (LFM .EQ. 2) THEN DO 820 J = 1, 6 VM(J) = VMSAV(IR,IVMS(IR),J) 820 CONTINUE IVMS(IR) = IVMS(IR) - 1 ENDIF C IF (LTAB .EQ. 1) THEN IF (NM .GE. 10) GO TO 5020 LABM(NM+1) = LAST(1:8) ENDIF BEFORE = .FALSE. NMIS = NUM IF (LFM .EQ. 0 .AND. (R2P .OR. R3P)) CALL UPDAT2 CALL MALIGN IF (FLUSHL) GO TO 5020 IF (LFM .GE. 1 .AND. LTAB .EQ. 0) GO TO 5000 GO TO 5020 C 850 IF (RORC .EQ. 3 .OR. RORC .EQ. 4) THEN ALO(1) = .TRUE. NM4 = NUM ENDIF IF (RORC .EQ. 3 .OR. RORC .EQ. 5) THEN ALO(2) = .TRUE. NM5 = NUM ENDIF GO TO 5020 C 890 WRITE (NOUT,9002) 9002 FORMAT (' *** ERROR *** MISALIGNMENTS NOT PERMITTED WITH', 1 ' ACCELERATOR NOTATION') FLUSHL = .TRUE. GO TO 5020 C C 9. -- REPEAT C 900 NREP = IDATA(I+1) CALL REPEAT GO TO 5020 C C 10. -- FITTING CONSTRAINTS C 1000 DRC = .FALSE. JCON = IDATA(I+1) KCON = IDATA(I+2) DE0 = DATAR(I+3) SD = DATAR(I+4) IF (SD .EQ. 0.0) THEN WRITE (NOUT,9805) 9805 FORMAT (' *** ERROR *** TOLERANCE OF ZERO ON FIT ELEMENT ', 1 'NOT ACCEPTABLE') FLUSHL = .TRUE. GO TO 5020 ENDIF CTY = TIE(I+1) NC = NC + 1 CALL CONSTR IF (FLUSHL) GO TO 5020 IF (LSTEPN) THEN ID1 = IPTOJ(10) ID2 = IPTOJ(11) DATA(I+ID1) = DATA(I+ID1) + COC DATA(I+ID2) = DATA(I+ID2) + COC**2 ENDIF GO TO 5020 C C 11. -- ACCELERATOR C 1100 CALL ACCGET CALL ACCMTX GO TO 5000 C C 12. -- CORRELATIONS IN BEAM ELLIPSE C 1200 IF (NORD3 .LT. 1) GO TO 5020 N = 0 DO 1210 J = 2, 6 JMIN1 = J - 1 DO 1210 K = 1, JMIN1 N = N + 1 IPLUSN = I + N SI(K,J) = DATAR(IPLUSN)*SQRT(SI(J,J)*SI(K,K)) SI(J,K) = SI(K,J) 1210 CONTINUE GO TO 5020 C C 13. -- INPUT-OUTPUT OPTIONS C 1300 CDB = INT(DATA(I+1)) IF (CDB .EQ. 9 .AND. .NOT. R1P) GO TO 1310 C 1310 IF (ATWE) THEN CALL IDIOT ELSE OMTX = .FALSE. CFIT = .FALSE. ENDIF IF (CDB .EQ. 11) GO TO 5000 GO TO 5020 C C 14. -- ARBITRARY MATRIX C 1400 J1 = INT(DATA(I+7)) IF (J1 .LE. 0 .OR. J1 .GT. 6) THEN WRITE (NOUT,9013) J1 9013 FORMAT (' *** ERROR *** ILLEGAL MATRIX INDEX, J1 = ',I5) FLUSHL = .TRUE. GO TO 5020 ENDIF DO 1410 K = 1, 6 IPLUSK = I + K R(J1,K) = DATA(IPLUSK)*UNITI(J1)/UNITI(K) 1410 CONTINUE IF (NDIF .EQ. 1 .AND. NUM + 1 .GT. NEL) GO TO 5000 IF (NDIF .EQ. -1 .AND. NUM - 1 .LE. 0) GO TO 5000 IPNOTY = ISTOR(NUM + NDIF) NEXT = IDATA(IPNOTY) I14S = NEXT I14T = NEXT IF (NEXT .EQ. TYPE) GO TO 5005 GO TO 5000 C C 15. -- UNITS C 1500 J = INT(DATA(I+1)) IF (J .EQ. 20) GO TO 1510 XNAME = LABEL(NUM)(1:4) USIZE = DATA(I+2) CALL UNITS(J) GO TO 5020 C 1510 MPMAD = .TRUE. GO TO 5020 C C 16. -- SPECIAL PARAMETERS C 1600 NPARS = INT(DATA(I+1)) IADR = I + 2 PARAM = DATAR(IADR) IF (NPARS .LE. 0 .OR. (NPARS .GT. 27 .AND. NPARS .LT. 100) 1 .OR. (NPARS .GT. 110 .AND. NPARS .LT. 200) 2 .OR. (NPARS .GT. 202 .AND. NPARS .LT. 250) 3 .OR. NPARS .GT. 254) GO TO 1699 IF (NPARS .GT. 27) GO TO 5020 CALL SPESHL GO TO 5020 C 1699 WRITE (NOUT,3390) 3390 FORMAT ('0 ERROR - CHECK INPUT DATA FOR SPECIAL PARAMETER') GO TO 5020 C C 17. -- SECOND- OR THIRD-ORDER CALCULATION C 1700 IF (RCP .OR. R2P .OR. RCP) THEN WRITE (NOUT,9004) 9004 FORMAT (' *** ERROR *** ORDER ELEMENT MUST PRECEDE ANY ', 1 'ELEMENT WHICH HAS A TRANSFER MATRIX') FLUSHL = .TRUE. GO TO 5020 ENDIF NORDX = INT(DATA(I+1)) NORDY = INT(DATA(I+2)) IF (ACCEL .OR. LTWISS) NORDY = 1 NORDX = MAX0(NORDX,NORDY) NORD1 = NORDY NORD3 = NORDY NORD2 = NORD3 IF (ALIGN .OR. SOFA .OR. ACCEL) NORD1 = NORDX IF (ALIGN) NORD2 = NORD1 IF (.NOT. LIMTD) LINEAR = .TRUE. CALL ORDCK GO TO 5020 C C 18. -- SEXTUPOLE C 1800 IF (TYPEC .EQ. 20) GO TO 1860 IF (TYPEC .EQ. 8) GO TO 1870 IF (RORC .EQ. 3 .OR. RORC .EQ. 6) THEN IF (NM .GE. 10) GO TO 1801 LABM(NM+1) = LABEL(NUM)(1:8) DMC = .TRUE. ENDIF C 1801 CALL SEXGET C 1840 IF (NORD1 .GE. 1) THEN R(1,2) = L R(3,4) = L IF (SM .NE. 0.0 .AND. RI .NE. 0.0) R(5,6) = L/GAMMA**2 ENDIF GO TO 5000 C 1860 IROLL = IPTOJ(5) IADR = I + IROLL TH = DATAR(IADR)*UNITI(13) IF (.NOT. BEFORE) TH = - TH CALL ROTATE(NPM) IF (NPM .EQ. 4) GO TO 2040 IF (.NOT. REFER) GO TO 5000 GO TO 5020 C 1870 GO TO 5020 C C 19. -- SOLENOID C 1900 IF (ACCEL .OR. LTWISS) GO TO 2040 CALL SOLGET IF (NORD1 .GE. 1) CALL SOLEN GO TO 5000 C C 20. -- BEAM ROTATION C 2000 IADR = I + 1 TH = DATAR(IADR) IF (PRAN20 .NE. 0.0) TH = TH + PRAN20*XRAN(1) TH = TH*UNITI(13) IT = IPTOJ(2) IF (IT .EQ. 0) THEN NUMTYP = IT ELSE NUMTYP = IDATA(I + IT) ENDIF CALL ROTATE(NPM) IF (NPM .EQ. 4) GO TO 2040 IF (.NOT. REFER) GO TO 5000 GO TO 5020 C 2040 WRITE (NOUT,2098) 2098 FORMAT (' *** ERROR *** ROTATION INCOMPATABLE WITH ACCELERATOR', 1 ' NOTATION') FLUSHL = .TRUE. GO TO 5020 C C 21. -- STRAY FIELD C 2100 DO 2105 JK = 1, 36 2105 RL(JK) = 0.0 DO 2110 JK = 1, 36, 7 2110 RL(JK) = 1.0 DO 2120 J = 1, 6 VM(J) = 0.0 2120 CONTINUE J = INT(DATA(I+1)) IF (J .LE. 0 .OR. J .GT. 6) THEN WRITE (NOUT,9014) J 9014 FORMAT (' *** ERROR *** ILLEGAL MISALIGNMENT INDEX = ',I5) FLUSHL = .TRUE. GO TO 5020 ENDIF IF (DATA(I+3) .EQ. 0.0) THEN TYT = 110 VM(J) = DATA(I+2) ELSE TYT = 0 VM(J) = DATA(I+3) ENDIF LFM = TYT/100 LTAB = MOD(TYT/10,10) VM(J) = VM(J)*UNITI(9)*UNITI(8)/RI IF (R2P .OR. R3P) CALL UPDAT2 CALL MALIGN IF (FLUSHL) GO TO 5020 IF (LFM .GE. 1 .AND. LTAB .EQ. 0) GO TO 5000 GO TO 5020 C C 22. -- DEFINE REGISTER CONTENTS C 2200 IF (.NOT. DRC) THEN CALL FIND10 IF (TYPE .LT. 0) GO TO 5100 IF (.NOT. DRC) GO TO 5020 ENDIF JCON = IDATA(I+1) IF (JCON .NE. 100) THEN KCON = IDATA(I+2) JTIE = TIE(I+3) IF (JTIE .NE. 100) THEN JREG = IDATA(I+3) ELSE JREG = IDATA(I+3) ENDIF ELSE ACON = DATA(I+3) ENDIF DE0 = 0.0 SD = 1.0 CALL CONSTR GO TO 5020 C C 23. -- ALGEBRAIC OPERATIONS C 2300 K1REG = IDATA(I+1) K1TIE = TIE(I+1) K2REG = IDATA(I+2) K2TIE = TIE(I+2) IOPN = IDATA(I+3) JREG = IDATA(I+4) JTIE = TIE(I+4) CALL COMBIN GO TO 5020 C C 24. -- DEFINE SECTION C 2400 JDEF = IDATA(I+1) IF (JDEF .EQ. 3 .OR. JDEF .EQ. 4) THEN NADDEF(1) = IDATA(I+2) NADDEF(2) = IDATA(I+3) ENDIF CALL DEFINE GO TO 5020 C C 25. -- OCTUPOLE C 2500 IF (TYPEC .EQ. 20) GO TO 2550 C CALL OCTGET IF (NORD1 .GE. 1) THEN R(1,2) = L R(3,4) = L IF (SM .NE. 0.0 .AND. RI .NE. 0.0) R(5,6) = L/GAMMA**2 ENDIF GO TO 5000 C 2550 IROLL = IPTOJ(5) IADR = I + IROLL TH = DATAR(IADR)*UNITI(13) IF (.NOT. BEFORE) TH = - TH CALL ROTATE(NPM) IF (NPM .EQ. 4) GO TO 2040 IF (.NOT. REFER) GO TO 5000 GO TO 5020 C C 26. -- RANDOM CHANGE OF PHYSICAL PARAMETER C 2600 CALL ERRSET GO TO 5020 C C 27. -- ACCELERATOR ETA FUNCTION C 2700 RAY = .TRUE. NORD1 = NORDX DO 2710 J = 1, 6 IPLUSJ = I + J ETA(J) = DATA(IPLUSJ)*UBEAM(J) 2710 CONTINUE GO TO 5020 C C 28. -- RECTANGULAR BENDING MAGNET C OR C 29. -- SECTOR BENDING MAGNET C 2800 IF (TYPEC .EQ. 4) GO TO 2840 IF (TYPEC .EQ. 20) GO TO 2850 IF (TYPEC .EQ. 8) GO TO 2860 IF ((RORC .EQ. 3 .OR. RORC .EQ. 4) .AND. NM .LT. 10) THEN IF (BEFORE) CALL PICKUP(3) IF (.NOT. BEFORE) LABM(NM+1) = LABEL(NUM)(1:8) DMC = .NOT. BEFORE ENDIF C IF (BEFORE) CALL RBGET CALL RBFGET IF (NORD1 .GE. 3 .AND. (LAYL .EQ. 0.0 .OR. APB(2) .EQ. 0.0)) THEN WRITE (NOUT,9016) FLUSHL = .TRUE. GO TO 5020 ENDIF CALL FRINGE GO TO 5000 C 2840 L = LBEND LMAG = L CALL RBVGET TOTANG = TOTANG + AL CALL BEND IF (FLUSHL) GO TO 5020 GO TO 5000 C 2850 NROLL = 24 IROLL = IPTOJ(NROLL) IADR = I + IROLL TH = DATAR(IADR)*UNITI(13) IF (.NOT. BEFORE) TH = - TH CALL ROTATE(NPM) IF (NPM .EQ. 4) GO TO 2040 IF (.NOT. REFER) GO TO 5000 GO TO 5020 C 2860 IF (.NOT. DMC) GO TO 5020 NMIS = NM4 NUPD = 3 CALL MISGET IF (VMMAX .NE. 0.0 .OR. NV3 .NE. 0) THEN NMISE = NUM NUM4 = NUM CALL MALIGN IF (FLUSHL) GO TO 5020 IF (LFM .GE. 1 .AND. LTAB .EQ. 0) GO TO 5000 ENDIF GO TO 5020 C C 30. -- PARAMETER C 3000 IADR = I + 1 PARAM = DATAR(IADR) GO TO 5020 C C 31. -- POSITION MARKER C 3100 IF (.NOT. MKG) THEN NMARKS = IDATA(I+1) CALL AGENDA(1) ATWE = PMK DRC = .FALSE. ENDIF GO TO 5020 C C 32. -- DUMMY ARGUMENT C 3200 JDEF = IDATA(I+1) NADDEF(1) = IDATA(I+2) CALL ARGUE GO TO 5020 C C 33. -- STORAGE OF MATRIX ELEMENT C 3300 DRC = .FALSE. IF (.NOT. ATWE) GO TO 5020 IADR = IDATA(I+1) PARAM = DATA(IADR) GO TO 5020 C C 34. -- PLASMA LENS C 3400 CALL PLSGET IF (NORD1 .GE. 1) THEN KX2 = KQ2 JQUAD = 1 CALL FOCUS CX = R(1,1) SX = R(1,2) JQUAD = 3 KY2 = KQ2 CALL FOCUS CY = R(3,3) SY = R(3,4) IF (SM .NE. 0.0 .AND. RI .NE. 0.0) R(5,6) = L/GAMMA**2 ENDIF GO TO 5000 C C 35. -- HKICK -- HORIZONTAL VERNIER C OR C 36. -- VKICK -- VERTICAL VERNIER C 3500 NROT35 = 5 IF (TYPEC .EQ. 35) GO TO 3540 IF (TYPEC .EQ. 20) GO TO 3550 CALL VRBGET BE = 0.0 RABT = 0.0 APB(2) = APBI(2) LAYK = 0.0 LAYL = 0.5 LAYX = 0.0 IF (NORD1 .GE. 3 .AND. (LAYL .EQ. 0.0 .OR. APB(2) .EQ. 0.0)) THEN WRITE (NOUT,9016) FLUSHL = .TRUE. GO TO 5020 ENDIF CALL FRINGE GO TO 5000 C 3540 L = LBEND CALL VERN IF (AL .NE. 0.0) THEN DCOV = .TRUE. IF (BAX) R1P = .TRUE. ENDIF GO TO 5000 C 3550 IROLL = IPTOJ(NROT35) IF (IROLL .EQ. 0) THEN TH = 0.0 ELSE IADR = I + IROLL TH = DATAR(IADR)*UNITI(13) ENDIF IF (TYPE .EQ. 36) TH = TH + 0.5*PI IF (.NOT. BEFORE) TH = - TH CALL ROTATE(NPM) IF (NPM .EQ. 4) GO TO 2040 IF (.NOT. REFER) GO TO 5000 GO TO 5020 C C 37. -- ALIGNMENT MARKER C 3700 IF (TYPEC .EQ. 8) GO TO 3750 JA = INT(DATA(I+1)) KA = INT(DATA(I+2)) IF (JA .NE. 0) GO TO 5020 C IADR = I + IPTOJ(4) NUPS = IDATA(IADR) NKNOW = 0 NUNC = 0 IF (NUPS .NE. 0) THEN DO 3710 NAL = 1, NUPS NMIS = IDATA(IADR+NAL) IMIS = ISTOR(NMIS) ICODE = INT(DATA(IMIS+7)) LFM = ICODE/100 IF (LFM .EQ. 0) NUNC = NUNC + 1 IF (LFM .GE. 1) NKNOW = NKNOW + 1 3710 CONTINUE ENDIF C IF (NKNOW .GE. 1 .AND. NORD3 .GE. 2 .AND. .NOT. NOPH 1 .AND. R2P) THEN WRITE (NOUT,9003) FLUSHL = .TRUE. GO TO 5020 ENDIF C IF (KA .EQ. 1) THEN IF (RCP .OR. R2P .OR. R3P) THEN IF (NUNC .EQ. 0 .AND. NKNOW .GT. 0) CALL RESET(2) IF (NUNC .GT. 0) CALL UPDATE ENDIF ELSE IF (KA .EQ. 2) THEN IF (R2P .OR. R3P) THEN IF (NUNC .EQ. 0 .AND. NKNOW .GT. 0) CALL RESET(3) IF (NUNC .GT. 0) CALL UPDAT2 ENDIF ENDIF GO TO 5020 C 3750 IF (JA .NE. 0) GO TO 5020 BEFORE = .TRUE. CALL MISGET IF (VMMAX .NE. 0.0 .OR. NV3 .NE. 0) THEN IF (LTAB .EQ. 1) THEN IF (NM .GE. 10) GO TO 5020 LABM(NM+1) = LAST(1:8) ENDIF CALL MALIGN IF (FLUSHL) GO TO 5020 IF (LFM .GE. 1 .AND. LTAB .EQ. 0) GO TO 5000 ENDIF GO TO 5020 C C PLOT -- PLOT OF MATRIX ELEMENTS C 3800 PLOT = .TRUE. NPLT = NPARMS/2 IDIF = 1 IF (.NOT. LPLOT) THEN DO 3810 J = 1, NPLT JPLOT(J) = IDATA(I+IDIF) KPLOT(J) = IDATA(I+IDIF+1) IDIF = IDIF + 2 JCON = JPLOT(J) KCON = KPLOT(J) EPLOT(J) = JCON .EQ. KCON .AND. JCON .GE. 1 .AND. JCON .LE. 6 IF (.NOT. PLNOW .AND. .NOT. LPLOT) THEN IF (JCON .EQ. 0 .AND. KCON .EQ. 0) LPLOT = .TRUE. IF (JCON .EQ. 8) LPLOT = .TRUE. ENDIF 3810 CONTINUE ENDIF C IF (.NOT. LPLOT) PLNOW = .TRUE. GO TO 5020 C C LIMIT -- SET LIMITS ON VARIED QUANTITIES C 3900 TYPEL = INT(DATA(I+1)) NPARL = INT(DATA(I+2)) LTYPE = INT(DATA(I+3)) DPARL = DATA(I+4) IF (LTYPE .EQ. 1 .OR. LTYPE .EQ. 2) THEN CALL LIMSET ELSE IF (LTYPE .EQ. 3) THEN LTYPE = 1 DPARL = - ABS(DPARL) CALL LIMSET LTYPE = 2 DPARL = ABS(DPARL) CALL LIMSET ENDIF LIMTD = .TRUE. LINEAR = .FALSE. GO TO 5020 C C DESCRIPTIONS OF MAGNETS BY TYPE C 4000 GO TO 5020 C C ELECTROSTATIC SEPTUM C 4100 IF (TYPEC .EQ. 20) GO TO 4160 CALL SEPTUM GO TO 5000 C 4160 IROLL = IPTOJ(NTILT) IF (IROLL .EQ. 0) GO TO 5020 IADR = I + IROLL TH = DATAR(IADR)*UNITI(13) IF (.NOT. BEFORE) TH = - TH CALL ROTATE(NPM) IF (NPM .EQ. 4) GO TO 2040 IF (.NOT. REFER) GO TO 5000 GO TO 5020 C C 42. -- KICKER -- CORRECTOR FOR BOTH PLANES C 4200 LBEND = DATAR(I+1)*UNITI(8) HAL = - DATAR(I+2)*UNITI(7) VAL = - DATAR(I+3)*UNITI(7) AL = SQRT(HAL**2 + VAL**2) AL = SIGN(AL,HAL) H0 = AL/LBEND C IF (TYPEC .EQ. 20) GO TO 4240 IF (TYPEC .EQ. 2) GO TO 4220 C L = LBEND B = RI*H0 CALL VERN IF (AL .NE. 0.0) THEN DCOV = .TRUE. IF (BAX) R1P = .TRUE. ENDIF GO TO 5000 C 4220 BE = 0.0 RABT = 0.0 APB(2) = APBI(2) LAYK = 0.0 LAYL = 0.5 LAYX = 0.0 IF (NORD1 .GE. 3 .AND. (LAYL .EQ. 0.0 .OR. APB(2) .EQ. 0.0)) THEN WRITE (NOUT,9016) FLUSHL = .TRUE. GO TO 5020 ENDIF CALL FRINGE GO TO 5000 C 4240 HAL = - DATAR(I+2)*UNITI(7) VAL = - DATAR(I+3)*UNITI(7) AL = SQRT(HAL**2 + VAL**2) AL = SIGN(AL,HAL) IF (HAL .NE. 0) THEN TH = ATAN(VAL/HAL) ELSE IF (VAL .GT. 0) THEN TH = 0.5*PI ELSE IF (VAL .LT. 0) THEN TH = - 0.5*PI ELSE TH = 0.0 ENDIF ENDIF IF (.NOT. BEFORE) TH = - TH CALL ROTATE(NPM) IF (NPM .EQ. 4) GO TO 2040 IF (.NOT. REFER) GO TO 5000 GO TO 5020 C C 43. -- REFERENCE COORDINATE SYSTEM SHIFT C 4300 DO 4310 J = 1, 6 IPLUSJ = I + J COD(J) = DATA(IPLUSJ) IF (PRAN43(J) .NE. 0.0) 1 COD(J) = COD(J) + PRAN43(J)*XRAN(J) COD(J) = COD(J)*UNITI(J) 4310 CONTINUE RECENT = .FALSE. DCOV = .TRUE. C IF (SOFA) THEN DO 4312 J = 1, 6 4312 CO(J) = CO(J) + COD(J) ELSE DO 4316 J = 1, 6 4316 CO(J) = COD(J) SOFA = .TRUE. NORD1 = NORDX IF (BAX) THEN DO 4320 J = 1, 6 4320 COF(J) = CO(J) R1P = .TRUE. ENDIF ENDIF C IF (.NOT. (ALIGN .OR. LAY)) GO TO 5020 IF (.NOT. (RCP .OR. R2P)) GO TO 5020 CALL OSET GO TO 5020 C C 45. -- NEUTRINO HORN C 4500 NHORN = NHORN + 1 N = NHORN L = ZHORN(N,LASTH(N)) - ZHORN(N,1) GO TO 5020 C C 46. -- HMONITOR C OR C 47. -- VMONITOR C OR C 48. -- MONITOR C 4600 IADR = I + 1 L = DATAR(IADR) L = L*UNITI(8) IF (NORD1 .GE. 1) THEN R(1,2) = L R(3,4) = L IF (SM .NE. 0.0 .AND. RI .NE. 0.0) R(5,6) = L/GAMMA**2 ENDIF GO TO 5000 C C DEFAULT UNITS SET C 7800 CALL UNITS(TYPE) GO TO 5020 C C INDICATE WHETHER ELEMENT HAS MATRIX C 5000 NWK = 1 RECENT = .FALSE. IF (ALIGN .OR. LAY) CALL OSET IF (TYPE .NE. 8 .AND. TYPEC .NE. 8) CALL OSAVE 5005 IF (NORD1 .GE. 2) CALL SECORD IF (TYPE .EQ. 14 .AND. NEXT .EQ. TYPE) GO TO 5010 IF (REFER .AND. TOTROT .NE. 0.0 .AND. .NOT. RSYM) THEN IF (DCOV .OR. NORD1 .GE. 1) CALL ROTAT1(0) IF (ALIGN .OR. LAY) CALL ROTATC(0) ENDIF 5010 TYP1 = TYPE LC = LC + L GO TO 5100 C 5020 NWK = 2 5100 RETURN END SUBROUTINE ELTILT C C STEPS THROUGH ELEMENT WHICH HAS NO FRINGE FIELDS BUT CAN C BE ROLLED C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA0A.CIN' INCLUDE 'DATA1A.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM0C.CIN' INCLUDE 'ELM2B.CIN' INCLUDE 'ELM8A.CIN' INCLUDE 'ELM8G.CIN' INCLUDE 'ELM8H.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM13A.CIN' INCLUDE 'ELM13C.CIN' INCLUDE 'ELM16B.CIN' INCLUDE 'FLUSHC.CIN' INCLUDE 'INDBND.CIN' INCLUDE 'INDPAR.CIN' INCLUDE 'LXRAN.CIN' INCLUDE 'R2P.CIN' INCLUDE 'R3P.CIN' INCLUDE 'STEPT1.CIN' C C LOCAL VARIABLES C INTEGER IDATA, IMIS, IPTOJM(25), J, TYPEN EXTERNAL IDATA C C SEE IF ELEMENT IS ROTATED C TILT = IPTOJ(NTILT) .NE. 0 DMC = .FALSE. BEFORE = .TRUE. C C CHECK FOR MISALIGNMENTS C IF (TYPE .EQ. 5 .AND. ALO(2)) THEN NMIS = NM5 IMIS = ISTOR(NMIS) TYT = INT(DATA(IMIS+7)) LFM = TYT/100 RORC = MOD(TYT,10) DMC = LFM .GE. 1 ENDIF C C ENTRANCE MISALIGNMENT C IF (DMC) THEN TYPEC = 8 LXRAN = LFM .EQ. 2 DO 50 J = 1, 25 50 IPTOJB(J) = IPTOJ(J) CALL SKETCH(NMIS) IF (NV3 .GE. 1) THEN CALL DERIVE ELSE CALL ELICIT IF (.NOT. LSTEPN) THEN CALL POSTER CALL MPRINT ENDIF ENDIF IF (FLUSHL) GO TO 200 IF (TYPE .LE. 0) GO TO 200 DO 60 J = 1, 25 IPTOJM(J) = IPTOJ(J) 60 IPTOJ(J) = IPTOJB(J) ENDIF C C ROTATION OF ELEMENT C IF (TILT) THEN TYPEC = 20 IF (NV3 .GE. 1) THEN CALL DERIVE ELSE CALL ELICIT IF (.NOT. LSTEPN) THEN CALL POSTER SONLY = .TRUE. CALL MPRINT SONLY = .FALSE. ENDIF ENDIF IF (FLUSHL) GO TO 200 IF (TYPE .LE. 0) GO TO 200 ENDIF C C MAIN ELEMENT C TYPEC = TYPE LXRAN = .TRUE. IF (NV3 .GE. 1) THEN CALL DERIVE ELSE CALL ELICIT IF (.NOT. LSTEPN) THEN CALL POSTER CALL VPRINT TYPEN = IDATA(ISTOR(NUM+NDIF)) IF (TILT .OR. (REFER .AND. TYPEN .EQ. 20)) SONLY = .TRUE. CALL MPRINT IF (TILT .OR. (REFER .AND. TYPEN .EQ. 20)) SONLY = .FALSE. ENDIF ENDIF IF (FLUSHL) GO TO 200 IF (TYPE .LE. 0) GO TO 200 C C REVERSE ROTATION OF ELEMENT C BEFORE = .FALSE. IF (TILT) THEN TYPEC = 20 IF (NV3 .GE. 1) THEN CALL DERIVE ELSE CALL ELICIT IF (.NOT. LSTEPN) THEN CALL POSTER CALL MPRINT ENDIF ENDIF IF (FLUSHL) GO TO 200 IF (TYPE .LE. 0) GO TO 200 ENDIF C C SEE IF ELEMENT IS MISALIGNED C DMC = .FALSE. IF (TYPE .EQ. 5 .AND. ALO(2)) THEN NMIS = NM5 DMC = .TRUE. ENDIF C C EXIT MISALIGNMENT C IF (DMC) THEN IF (NV3 .GE. 1) THEN IF (LFM .EQ. 0 .AND. (R2P .OR. R3P)) CALL UPDAT2 ELSE IF (LFM .EQ. 0 .AND. R2P) CALL UPDAT2 ENDIF TYPEC = 8 DO 110 J = 1, 25 110 IPTOJ(J) = IPTOJM(J) IF (NV3 .GE. 1) THEN CALL DERIVE ELSE CALL ELICIT IF (.NOT. LSTEPN) THEN CALL POSTER CALL MPRINT ENDIF ENDIF IF (FLUSHL) GO TO 200 IF (TYPE .LE. 0) GO TO 200 ENDIF C 200 RETURN END SUBROUTINE ENRIC2 C C CALCULATES CONTRIBUTION FROM SECOND-ORDER TERMS C TO THE FIRST ORDER MATRIX FROM A SHIFTED REFERENCE C TRAJECTORY C C LIST OF COMMON BLOCKS C INCLUDE 'COACOM.CIN' INCLUDE 'RA.CIN' INCLUDE 'TA.CIN' C--------------------------------------------------------------------- C DO 100 J = 1, 5 IND = 0 DO 100 L2 = 1, 6 DO 100 L1 = 1, L2 IND = IND + 1 RA(J,L1) = RA(J,L1) + TA(J,IND)*COA(L2) RA(J,L2) = RA(J,L2) + TA(J,IND)*COA(L1) 100 CONTINUE C RETURN END SUBROUTINE ENRIC3 C C CALCULATES CONTRIBUTION FROM THIRD-ORDER TERMS C TO FIRST- AND SECOND-ORDER MATRICES FROM SHIFTED C REFERENCE TRAJECTORY C C LIST OF COMMON BLOCKS C INCLUDE 'COACOM.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'RA.CIN' INCLUDE 'TA.CIN' INCLUDE 'UA.CIN' C C----------------------------------------------------------------- C CONTRIBUTION OF THIRD-ORDER TERMS TO FIRST-ORDER MATRIX C DO 20 J = 1, 4 IND = 0 DO 20 L3 = 1, 6 DO 20 L2 = 1, L3 DO 20 L1 = 1, L2 IND = IND + 1 RA(J,L1) = RA(J,L1) + UA(J,IND)*COA(L2)*COA(L3) RA(J,L2) = RA(J,L2) + UA(J,IND)*COA(L1)*COA(L3) RA(J,L3) = RA(J,L3) + UA(J,IND)*COA(L1)*COA(L2) 20 CONTINUE C C CONTRIBUTION OF THIRD-ORDER TERMS TO SECOND-ORDER MATRIX C IF (NORD2 .LT. 2) GO TO 100 DO 50 J = 1, 4 IND = 0 IND23 = 0 IND13 = 0 DO 50 L3 = 1, 6 IND12 = 0 IND13S = IND13 DO 50 L2 = 1, L3 IND13 = IND13S IND23 = IND23 + 1 DO 50 L1 = 1, L2 IND12 = IND12 + 1 IND13 = IND13 + 1 IND = IND + 1 TA(J,IND23) = TA(J,IND23) + UA(J,IND)*COA(L1) TA(J,IND13) = TA(J,IND13) + UA(J,IND)*COA(L2) TA(J,IND12) = TA(J,IND12) + UA(J,IND)*COA(L3) 50 CONTINUE C 100 RETURN END SUBROUTINE ENRICH(NM) C C CALCULATES NEW TRANSFER MATRIX ABOUT DISPLACED TRAJECTORY C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'COCOM.CIN' INCLUDE 'COACOM.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'R.CIN' INCLUDE 'RA.CIN' INCLUDE 'RC3.CIN' INCLUDE 'T.CIN' INCLUDE 'TA.CIN' INCLUDE 'TC3.CIN' INCLUDE 'U.CIN' INCLUDE 'UA.CIN' INCLUDE 'UC3.CIN' C C--------------------------------------------------------------------- C TRANSFER OF MATRICES TO WORK AREAS C IF (NM .EQ. 0) THEN DO 5 JK = 1, 36 5 RAL(JK) = RL(JK) IF (NORD1 .GE. 2) THEN DO 10 JKL = 1, 105 10 TAL(JKL) = TL(JKL) ENDIF IF (NORD1 .GE. 3) THEN DO 12 JKLM = 1, 280 12 UAL(JKLM) = UL(JKLM) ENDIF ELSE IF (NM .EQ. 1) THEN DO 15 JK = 1, 36 15 RAL(JK) = RVL(JK) IF (NORD1 .GE. 2) THEN DO 20 JKL = 1, 105 20 TAL(JKL) = TVL(JKL) ENDIF IF (NORD1 .GE. 3) THEN DO 22 JKLM = 1, 280 22 UAL(JKLM) = UVL(JKLM) ENDIF ELSE IF (NM .EQ. 3) THEN DO 25 JK = 1, 36 25 RAL(JK) = RC3L(JK) IF (NORD1 .GE. 2) THEN DO 30 JKL = 1, 105 30 TAL(JKL) = TC3L(JKL) ENDIF IF (NORD1 .GE. 3) THEN DO 35 JKLM = 1, 280 35 UAL(JKLM) = UC3L(JKLM) ENDIF ENDIF C 50 DO 60 J = 1, 6 60 COA(J) = CO(J) C C CONTRIBUTION OF HIGHER-ORDER MATRICES TO OFF-AXIS LOWER ORDER C 100 IF (NORD1 .GE. 2) CALL ENRIC2 IF (NORD1 .GE. 3) CALL ENRIC3 C C TRANSFER OF MATRICES FROM WORK AREAS C IF (NM .EQ. 0) THEN DO 105 JK = 1, 36 105 RL(JK) = RAL(JK) IF (NORD2 .GE. 2) THEN DO 110 JKL = 1, 105 110 TL(JKL) = TAL(JKL) ENDIF IF (NORD2 .GE. 3) THEN DO 112 JKLM = 1, 280 112 UL(JKLM) = UAL(JKLM) ENDIF ELSE IF (NM .EQ. 1) THEN DO 115 JK = 1, 36 115 RVL(JK) = RAL(JK) IF (NORD2 .GE. 2) THEN DO 120 JKL = 1, 105 120 TVL(JKL) = TAL(JKL) ENDIF IF (NORD2 .GE. 3) THEN DO 122 JKLM = 1, 280 122 UVL(JKLM) = UAL(JKLM) ENDIF ELSE IF (NM .EQ. 3) THEN DO 125 JK = 1, 36 125 RC3L(JK) = RAL(JK) IF (NORD2 .GE. 2) THEN DO 130 JKL = 1, 105 130 TC3L(JKL) = TAL(JKL) ENDIF IF (NORD2 .GE. 3) THEN DO 132 JKLM = 1, 280 132 UC3L(JKLM) = UAL(JKLM) ENDIF ENDIF C 200 RETURN END SUBROUTINE ENRIM C C CALCULATES NEW TRANSFER MATRIX FOR MISALIGNMENT TABLE C ABOUT DISPLACED TRAJECTORY C C LIST OF COMMON BLOCKS C INCLUDE 'ELM17A.CIN' INCLUDE 'R.CIN' INCLUDE 'RA.CIN' INCLUDE 'T.CIN' INCLUDE 'TA.CIN' INCLUDE 'U.CIN' INCLUDE 'UA.CIN' C C--------------------------------------------------------------- C C TRANSFER OF MATRICES TO WORK AREAS C DO 5 JK = 1, 36 5 RAL(JK) = RL(JK) IF (NORD1 .GE. 2) THEN DO 10 JKL = 1, 105 10 TAL(JKL) = TL(JKL) ENDIF IF (NORD1 .GE. 3) THEN DO 12 JKLM = 1, 280 12 UAL(JKLM) = UL(JKLM) ENDIF C C CONTRIBUTION OF HIGHER-ORDER MATRICES TO OFF-AXIS LOWER ORDER C 100 IF (NORD1 .GE. 2) CALL ENRIC2 IF (NORD1 .GE. 3) CALL ENRIC3 C C TRANSFER OF MATRICES FROM WORK AREAS C DO 105 JK = 1, 36 105 RL(JK) = RAL(JK) IF (NORD2 .GE. 2) THEN DO 110 JKL = 1, 105 110 TL(JKL) = TAL(JKL) ENDIF IF (NORD2 .GE. 3) THEN DO 112 JKLM = 1, 280 112 UL(JKLM) = UAL(JKLM) ENDIF C 200 RETURN END SUBROUTINE ERRSET C C READ MAGNITUDES OF ERRORS FOR PHYSICAL PARAMETERS C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA0A.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM26A.CIN' INCLUDE 'ELM26B.CIN' C C---------------------------------------------------------------- TYPER = INT(DATA(I+1)) NPAR = INT(DATA(I+2)) DPAR = DATA(I+3) IF (TYPER .GT. NELMCT) GO TO 1000 GO TO (1000, 20, 30, 40, 50,1000, 70,1000,1000,1000, 1 110,1000,1000,1000,1000,1000,1000, 180, 190, 200, 2 1000,1000,1000,1000, 250,1000,1000, 280, 280,1000, 3 1000,1000,1000, 340,1000,1000,1000,1000,1000,1000, 4 1000,1000, 430,1000,1000,1000,1000,1000), TYPER C 20 IF (NPAR .LT. 1 .OR. NPAR .GT. 4) GO TO 1000 PRAN2(NPAR) = DPAR GO TO 1000 C 30 IF (NPAR .NE. 1) GO TO 1000 PRAN3 = DPAR GO TO 1000 C 40 IF (NPAR .LT. 1 .OR. NPAR .GT. 15) GO TO 1000 PRAN4(NPAR) = DPAR GO TO 1000 C 50 IF (NPAR .LT. 1 .OR. NPAR .GT. 5) GO TO 1000 PRAN5(NPAR) = DPAR GO TO 1000 C 70 IF (NPAR .LT. 1 .OR. NPAR .GT. 6) GO TO 1000 PRAN7(NPAR) = DPAR GO TO 1000 C 110 IF (NPAR .LT. 1 .OR. NPAR .GT. 4) GO TO 1000 PRAN11(NPAR) = DPAR GO TO 1000 C 180 IF (NPAR .LT. 1 .OR. NPAR .GT. 4) GO TO 1000 PRAN18(NPAR) = DPAR GO TO 1000 C 190 IF (NPAR .LT. 1 .OR. NPAR .GT. 3) GO TO 1000 PRAN19(NPAR) = DPAR GO TO 1000 C 200 IF (NPAR .NE. 1) GO TO 1000 PRAN20 = DPAR GO TO 1000 C 250 IF (NPAR .LT. 1 .OR. NPAR .GT. 4) GO TO 1000 PRAN25(NPAR) = DPAR GO TO 1000 C 280 IF (NPAR .LT. 1 .OR. NPAR .GT. 23) GO TO 1000 PRAN28(NPAR) = DPAR GO TO 1000 C 340 IF (NPAR .LT. 1 .OR. NPAR .GT. 5) GO TO 1000 PRAN34(NPAR) = DPAR C 430 IF (NPAR .LT. 1 .OR. NPAR .GT. 6) GO TO 1000 PRAN43(NPAR) = DPAR GO TO 1000 C 1000 RETURN END SUBROUTINE EXPLOR C C DETERMINE BEGINNING AND END OF SECTION WHERE FITTING OCCURS C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA0A.CIN' INCLUDE 'DATA0B.CIN' INCLUDE 'DATA1A.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'DATA2B.CIN' INCLUDE 'DATA2D.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM0C.CIN' INCLUDE 'ELM0D.CIN' INCLUDE 'ELM0F.CIN' INCLUDE 'ELM4E.CIN' INCLUDE 'ELM8A.CIN' INCLUDE 'ELM8G.CIN' INCLUDE 'ELM9.CIN' INCLUDE 'ELM10E.CIN' INCLUDE 'ELM10F.CIN' INCLUDE 'ELM14A.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'ELM20.CIN' INCLUDE 'ELM23.CIN' INCLUDE 'ELM24A.CIN' INCLUDE 'ELM24B.CIN' INCLUDE 'ELM31A.CIN' INCLUDE 'FLUSHC.CIN' INCLUDE 'INDPAR.CIN' INCLUDE 'STEPT1.CIN' INCLUDE 'VFLAG.CIN' C C LOCAL VARIABLES C INTEGER NVSET(NPVAR) EXTERNAL IDATA LOGICAL CKK C C------------------------------------------------------------------- C NUM = 1 NDIF = 1 TYP1 = 0 TOTROT = 0.0 TOTRA = 0.0 IP = 0 NDLEV = 0 NCT = 0 NCTV = 0 NCTE = 0 NCTC = 0 DRC = .FALSE. NORD1 = -1 NUM14S = 0 NCT14S = 0 ATWORK = NUSE .EQ. 0 MKG = .FALSE. VFLAG = .FALSE. DO 5 J = 1, NPVAR 5 NVSET(J) = 0 C IF (NEL .LE. 0) GO TO 5300 10 I = ISTOR(NUM) TYPE = IDATA(I) IF (TYPE .LE. 0 .OR. TYPE .GE. 50) GO TO 5200 CALL SKETCH(NUM) NCT = NCT + 1 CALL DEPICT TYPEC = TYPE IF (.NOT. ATWE) GO TO 5200 C IVA = 0 C IF (TYPE .EQ. 2) GO TO 200 IF (TYPE .EQ. 5) GO TO 500 IF (TYPE .EQ. 6) GO TO 600 IF (TYPE .EQ. 9) GO TO 900 IF (TYPE .EQ. 10) GO TO 1000 IF (TYPE .EQ. 14) GO TO 1400 IF (TYPE .EQ. 22) GO TO 2200 IF (TYPE .EQ. 23) GO TO 2300 IF (TYPE .EQ. 24) GO TO 2400 IF (TYPE .EQ. 28 .OR. TYPE .EQ. 29) GO TO 2800 IF (TYPE .EQ. 31) GO TO 3100 IF (TYPE .EQ. 33) GO TO 3300 IF (TYPE .EQ. 37) GO TO 3700 GO TO 5000 C C 2. -- POLE FACE ROTATION C 200 CALL CHEK(CKK) IF (.NOT. CKK) GO TO 5200 NUMS = NUM NUM = NUM4 I = ISTOR(NUM) TYPE = IDATA(I) CALL SKETCH(NUM) NVTYPE = NPARMS DO 250 JV = 1, NVTYPE IADR = I + JV 210 ISIG = IABS(TIE(IADR)) IF (ISIG .NE. 0 .AND. ISIG .LE. NPVAR) NVSET(ISIG) = ISIG IF (ISIG .EQ. 100) THEN IADR = IDATA(IADR) GO TO 210 ENDIF IF (ISIG .EQ. 99) THEN ISIG = 0 DO 220 K = 1, NPVAR ITEST = NVSET(K) IF (ITEST .GE. 0) ISIG = ITEST 220 CONTINUE ENDIF 240 IF (ISIG .NE. 0) IVA = 1 250 CONTINUE NUM = NUMS I = ISTOR(NUM) TYPE = IDATA(I) GO TO 5000 C C 5. -- QUADRUPOLE C 500 IF (NMISRB .NE. 0) CALL AGENDR(1) GO TO 5000 C C 6. -- UPDATE C 600 IF (DATA(I+1) .NE. 0.0) GO TO 5100 IADR = I + IPTOJ(4) NUPS = IDATA(IADR) IF (NUPS .NE. 0) THEN DO 620 NAL = 1, NUPS IF (NAL .GT. 10) GO TO 620 NMIS = IDATA(IADR+NAL) IMIS = ISTOR(NMIS) TYT = INT(DATA(IMIS+7)) LFM = TYT/100 LTAB = MOD(TYT/10,10) IF (LFM .EQ. 0 .OR. LFM .EQ. 2 .OR. LTAB .EQ. 1) GO TO 620 DO 610 J = 1, 6 IF (TIE(IMIS+J) .NE. 0) IVA = 1 610 CONTINUE 620 CONTINUE ENDIF GO TO 5100 C C 9. -- REPEAT C 900 NREP = IDATA(I+1) CALL REPEAT IF (FLUSHL) GO TO 5300 GO TO 5200 C C 10. -- FITTING CONSTRAINTS C 1000 IF (.NOT. ATWE) GO TO 5200 NCTC = NCT DRC = .FALSE. GO TO 5200 C C 14. -- ARBITRARY MATRIX C 1400 IF (TYP1 .NE. 14) THEN NUM14S = NUM NCT14S = NCT ENDIF GO TO 5000 C C 22. -- DEFINE REGISTER CONTENTS C 2200 IF (.NOT. DRC) CALL FIND10 GO TO 5200 C C 23. -- ALGEBRAIC OPERATIONS C 2300 K1REG = IDATA(I+1) K1TIE = TIE(I+1) K2REG = IDATA(I+2) K2TIE = TIE(I+2) IOPN = IDATA(I+3) JREG = IDATA(I+4) JTIE = TIE(I+4) CALL DEPEND IF (FLUSHL) GO TO 5300 GO TO 5200 C C 24. -- DEFINED SECTION C 2400 JDEF = IDATA(I+1) IF (JDEF .EQ. 3 .OR. JDEF .EQ. 4) THEN NADDEF(1) = IDATA(I+2) NADDEF(2) = IDATA(I+3) ENDIF CALL DEFINE IF (FLUSHL) GO TO 5300 GO TO 5200 C C 28. -- RBEND OR 29. -- SBEND C 2800 IF (NMISRB .NE. 0) CALL AGENDR(1) GO TO 5000 C C 31. -- POSITION MARKER C 3100 NMARKS = IDATA(I+1) DRC = .FALSE. CALL AGENDA(1) GO TO 5200 C C 33. -- STORAGE OF MATRIX ELEMENT C 3300 DRC = .FALSE. GO TO 5200 C C 37. -- ALIGNMENT MARKER C 3700 IADR = I + IPTOJ(4) NUPS = IDATA(IADR) IF (NUPS .NE. 0) THEN DO 3720 NAL = 1, NUPS IF (NAL .GT. 10) GO TO 3720 NMIS = IDATA(IADR+NAL) IMIS = ISTOR(NMIS) TYT = INT(DATA(IMIS+7)) LFM = TYT/100 LTAB = MOD(TYT/10,10) IF (LFM .EQ. 0 .OR. LFM .EQ. 2 .OR. LTAB .EQ. 1) GO TO 3720 DO 3710 J = 1, 6 IF (TIE(IMIS+J) .NE. 0) IVA = 1 3710 CONTINUE 3720 CONTINUE ENDIF GO TO 5100 C C DO VARY CODES C 5000 CALL SKETCH(NUM) NVTYPE = NV(TYPE) IF (NVTYPE .EQ. 0) GO TO 5200 IF (LSTEP) THEN IF (ISTEP .GE. I .AND. ISTEP .LE. I + NVTYPE) THEN IF (NCTV .EQ. 0) THEN NUMV = NUM NCTV = NCT IF (TYPE .NE. 30) NCTE = NCT ENDIF ENDIF ENDIF DO 5050 JV = 1, NVTYPE IADR = I + IPTOJ(JV) 5010 ISIG = IABS(TIE(IADR)) IVARY = ISIG IF (IVARY .NE. 0 .AND. IVARY .LE. NPVAR) IVARY = VSTOR(IVARY) IF (IVARY .GE. 2 .AND. IVARY .LE. 50) VFLAG = .TRUE. IF (ISIG .NE. 0 .AND. ISIG .LE. NPVAR) GO TO 5040 IF (ISIG .EQ. 100) THEN IADR = IDATA(IADR) GO TO 5010 ENDIF IF (ISIG .EQ. 99) THEN ISIG = 0 DO 5020 K = 1, NPVAR REF = DATA(IADR + K) IF (REF .GT. 0.5) ISIG = 1 5020 CONTINUE ENDIF 5040 IF (ISIG .NE. 0) IVA = 1 5050 CONTINUE C 5100 IF (IVA .EQ. 0) GO TO 5200 IF (NCTE .NE. 0) GO TO 5200 IF (TYPE .NE. 30 ) NCTE = NCT IF (NCTV .EQ. 0) THEN IF (TYPE .NE. 14) THEN NUMV = NUM NCTV = NCT ELSE NUMV = NUM14S NCTV = NCT14S NCTE = NCT14S ENDIF ENDIF C C ADVANCE TO NEXT ELEMENT C 5200 IF (MKG .AND. NUM .EQ. NMARKE) CALL AGENDA(2) IF (ALGR .AND. NUM .EQ. NMISRE) CALL AGENDR(2) NUM = NUM + NDIF IF (.NOT. MKG .AND. NUSE .NE. 0 .AND. NUM .GT. NUSE) GO TO 5300 TYP1 = TYPE IF (NUM .LE. NEL) GO TO 10 5300 CONTINUE RETURN END SUBROUTINE EXTENT C C CONSTRAINT ON BEAM SIZE C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM1D.CIN' INCLUDE 'ELM10A.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM10D.CIN' INCLUDE 'ELM15C.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'FLUSHC.CIN' INCLUDE 'IOUNIT.CIN' INCLUDE 'RCP.CIN' INCLUDE 'RC2.CIN' INCLUDE 'R2P.CIN' INCLUDE 'SI.CIN' INCLUDE 'SVP.CIN' C C LOCAL VARIABLES C LOGICAL LOGIC REAL AS(NPVAR+1), CAD(NPVAR+1), CADS(NPVAR+1), RSV(6,NPVAR) C C--------------------------------------------------------------- J = JCON IF (.NOT. RECENT) CALL BEAM SIJJ = SIT(J,J) IF (SIJJ .LT. 0.0) THEN IF (ABS(SIJJ) .LT. 1.0E-6) THEN SIJJ = 0.0 ELSE SOJJ = SIJJ/UBEAM(J)**2 WRITE (NOUT,1000) J, J, SOJJ 1000 FORMAT (1H ,'BEAM MATRIX ELEMENT SI(',I1,',',I1,') = ', 1 1PE12.4,/,1H ,'MUST BE POSITIVE, PROBABLY A TYPO') FLUSHL = .TRUE. GO TO 300 ENDIF ENDIF SSJJ = SQRT(SIJJ) COC = SSJJ/UBEAM(J) IF (NV3 .GE. 1) CW = 1.0/SD**2 IF (DE0 .EQ. 0.0 .AND. TYPE .EQ. 10) GO TO 200 IF (NV3 .LT. 1) GO TO 50 A(1) = DE0 - COC CALL CLI(LOGIC) IF (LOGIC) RETURN C IF (NV1 .LT. 1) GO TO 50 DO 40 N = 1, NV1, 1 IF (R2P) GO TO 10 IF (.NOT. SVP(N)) GO TO 40 SVJJ = SV(J,J,N) GO TO 30 10 SVJJ = 0.0 IF (SVP(N)) THEN DO 11 L1 = 1, 6 DO 11 L2 = 1, 6 SVJJ = SVJJ + RC2(J,L1)*SV(L1,L2,N)*RC2(J,L2) 11 CONTINUE ENDIF IF (R2VP(N)) THEN DO 21 L1 = 1, 6 DO 21 L2 = 1, 6 SVJJ = SVJJ + 2.0*R2V(J,L1,N)*SI(L1,L2)*RC2(J,L2) 21 CONTINUE ENDIF 30 A(N+1) = 0.5*SVJJ/(SSJJ*UBEAM(J)) CAD(N+1) = CW*A(N+1)*A(N+1) 40 CONTINUE C 50 IF (NV1 .LT. 1) GO TO 150 IF (.NOT. (R2P .OR. RCP)) GO TO 150 DO 90 N = 1, NV1 SVJJ = 0.0 IF (R2VP(N)) THEN DO 65 L1 = 1, 6 DO 65 L2 = 1, 6 SVJJ = SVJJ + R2V(J,L1,N)*SI(L1,L2)*R2V(J,L2,N) 65 CONTINUE ENDIF C 70 IF (R2VP(N) .AND. SVP(N)) THEN DO 75 L1 = 1, 6 DO 75 L2 = 1, 6 SVJJ = SVJJ + R2V(J,L1,N)*SV(L1,L2,N)*RC2(J,L2) 1 + RC2(J,L1)*SV(L1,L2,N)*R2V(J,L2,N) 75 CONTINUE ENDIF C 80 SVJJ = 0.5*SVJJ/(SSJJ*UBEAM(J)) SVJJ = SVJJ - A(N+1)*A(N+1)*UBEAM(J)/SSJJ AS(N+1) = SVJJ CADS(N+1) = A(1)*CW*AS(N+1) IF (CAD(N+1) .LT. CADS(N+1)) THEN DV = SIGN(SQRT(2.0*A(1)/AS(N+1)),A(N+1)) A(N+1) = A(N+1) + DV*AS(N+1) ENDIF 90 CONTINUE C 150 CALL GATHER RETURN C C MINIMIZATION OF BEAM SIZE C 200 CA(1,1) = CA(1,1) + COC**2*CW IF (NV3 .LT. 1) RETURN C IF (NV1 .LT. 1) GO TO 250 DO 220 N = 1, NV1 DO 220 L1 = 1, 6 SS = 0.0 DO 215 L2 = 1, 6 SS = SS + R2V(J,L2,N)*SI(L1,L2) 215 CONTINUE RSV(L1,N) = SS 220 CONTINUE C DO 230 N = 1, NV1 SS = 0.0 DO 225 K = 1, 6 SS = SS + RC2(J,K)*RSV(K,N) 225 CONTINUE CA(N+1,1) = CA(N+1,1) - SS*CW/UBEAM(J)**2 230 CONTINUE C DO 240 N1 = 1, NV1 DO 240 N2 = 1, N1 SS = 0.0 DO 235 K = 1, 6 SS = SS + R2V(J,K,N1)*RSV(K,N2) 235 CONTINUE CA(N1+1,N2+1) = CA(N1+1,N2+1) + SS*CW/UBEAM(J)**2 240 CONTINUE 250 CONTINUE C IF (NORD3 .GE. 2) CALL CONSEC C 300 RETURN END SUBROUTINE FCSET C C SETS INITIAL VALUES OF FLOOR COORDINATES C C---------------------------------- CALL OSET C RETURN END SUBROUTINE FILL23 INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA0A.CIN' INCLUDE 'DATA0B.CIN' INCLUDE 'DATA1A.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM23.CIN' C KOUNTO = 0 C 5 NUM = 0 KOUNT = 0 C 10 NUM = NUM + 1 I = ISTOR(NUM) TYPE = IDATA(I) C IF (TYPE .EQ. 23) GO TO 230 GO TO 500 C 230 K1REG = IDATA(I+1) K2REG = IDATA(I+2) IOPN = IDATA(I+3) JREG = IDATA(I+4) K1TIE = TIE(I+1) K2TIE = TIE(I+2) JTIE = TIE(I+4) CALL DEPEND IF (JTIE .EQ. 100) THEN IVA = 0 DO 235 J = 1, NPVAR IF (DATA(J + JREG) .GT. 0.5) IVA = 1 235 CONTINUE IF (IVA .GT. 0) KOUNT = KOUNT + 1 ENDIF GO TO 500 C 500 IF (NUM .LE. NEL) GO TO 10 IF (KOUNT .GT. KOUNTO) THEN KOUNTO = KOUNT GO TO 5 ENDIF C RETURN END SUBROUTINE FIND10 C C FIND CONSTRAINT OR STORAGE ELEMENT TO WHICH ALGEBRAIC C OPERATION MIGHT APPLY C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA1A.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM31A.CIN' INCLUDE 'INDPAR.CIN' C C LOCAL VARIABLES C INTEGER IDATA INTEGER TYPET EXTERNAL IDATA C C--------------------------------------------------------------------- C NN = NUM 10 NN = NN + 1 II = ISTOR(NN) TYPET = IABS(IDATA(II)) IF (TYPET .EQ. 22 .OR. TYPET .EQ. 23) GO TO 10 IF (TYPET .EQ. 30) THEN NEXT = IABS(IDATA(ISTOR(NN+1))) IF (NEXT .EQ. 10 .OR. NEXT .EQ. 33 .OR. NEXT .EQ. 38) GO TO 10 ENDIF IF (IDATA(II) .LT. 0) GO TO 100 IF (TYPET .NE. 38) THEN IF (MKG) THEN CALL SKETCH(NN) IF (TYPET .EQ. 10) ID = 7 IF (TYPET .EQ. 33) ID = 2 IPT = IPTOJ(ID) IF (IPT .EQ. 0) GO TO 100 NMARKT = IDATA(II+IPT) MKDO = NMARKS .EQ. NMARKT IF (.NOT. MKDO) GO TO 100 ENDIF ENDIF 50 DRC = .TRUE. GO TO 200 C 100 NUM = NN I = II TYPE = -10 DRC = .FALSE. CALL DEPICT C 200 RETURN END SUBROUTINE FIND8 C C LOCATE MISALIGNMENT THAT MIGHT REFER TO UPDATE C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA0A.CIN' INCLUDE 'DATA0B.CIN' INCLUDE 'DATA1A.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM8F.CIN' INCLUDE 'ELM8G.CIN' INCLUDE 'ELM31A.CIN' C C LOCAL VARIABLES C INTEGER IDATA INTEGER II, III, LFM, NELS, NMARKT, NN, NNN INTEGER TYPEM, TYPET, TYT, RORC EXTERNAL IDATA C C------------------------------------------------------------------------ C C MISALIGNMENT SPECIFICATION IMMEDIATELY FOLLOWING SINGLE C ELEMENT C NN = NUM NELS = 0 NUP(1) = 0 C 10 II = ISTOR(NN) TYPET = IDATA(II) IF (TYPET .EQ. 3 .OR. TYPET .EQ. 4 .OR. TYPET .EQ. 5 1 .OR. TYPET .EQ. 11 .OR. TYPET .EQ. 14 .OR. TYPET .EQ. 18 2 .OR. TYPET .EQ. 19 .OR. TYPET .EQ. 20 .OR. TYPET .EQ. 25 3 .OR. TYPET .EQ. 28 .OR. TYPET .EQ. 29 .OR. TYPET .EQ. 34 4 .OR. TYPET .EQ. 35 .OR. TYPET .EQ. 36) NELS = NELS + 1 IF (TYPET .EQ. 8) THEN IF (IDATA(II+9) .EQ. 0) THEN TYT = INT(DATA(II+7)) LFM = TYT/100 RORC = MOD(TYT,10) IF (LFM .GE. 1 .AND. RORC .EQ. 0) THEN NUP(1) = NUP(1) + 1 NIM(1,NUP(1)) = NN ENDIF ENDIF ENDIF IF (NN .LT. NEL .AND. NELS .LE. 1) THEN NN = NN + 1 GO TO 10 ENDIF C C MISALIGNMENT SPECIFICATION REFERRING TO MARKER C NELS = 0 NN = NUM + 1 C 20 II = ISTOR(NN) TYPET = IDATA(II) NMARKS = IDATA(II+1) IF (TYPET .EQ. 31) THEN NNN = NMARKB 25 III = ISTOR(NNN) TYPEM = IDATA(III) IF (TYPEM .EQ. 8) THEN IF (TIE(III+9) .EQ. 101) THEN NMARKT = IDATA(III+9) IF (NMARKS .EQ. NMARKT) THEN TYT = INT(DATA(III+7)) LFM = TYT/100 RORC = MOD(TYT,10) IF (LFM .GE. 1 .AND. RORC .EQ. 0) THEN NUP(1) = NUP(1) + 1 NIM(1,NUP(1)) = NNN ENDIF ENDIF ENDIF ENDIF IF (NNN .LT. NEL .AND. NELS .LE. 1 1 .AND. NNN .LE. NMARKE) THEN NNN = NNN + 1 GO TO 25 ENDIF ENDIF IF (NN .LT. NEL .AND. NELS .LE. 1 1 .AND. NN .LE. NMARKE) THEN IF (TYPET .EQ. 6 .OR. TYPET .EQ. 10 1 .OR. TYPET .EQ. 13 .OR. TYPET .EQ. 31 2 .OR. TYPET .EQ. 33 .OR. TYPET .EQ. 37 3 .OR. TYPET .EQ. 38) THEN NN = NN + 1 GO TO 20 ENDIF ENDIF C C MISALIGNMENT SPECIFICATION REFERRING TO SINGLE ELEMENT C IF (NMISRB .EQ. 0 .OR. NMISRE .EQ. 0) GO TO 50 NN = NMISRB C 30 II = ISTOR(NN) TYPET = IDATA(II) IF (TYPET .EQ. 8) THEN NMIS = IDATA(II+9) IF (TIE(II+9) .EQ. 102 .AND. NMIS .NE. 0) THEN IF (NMIS .EQ. NUM) THEN TYT = INT(DATA(II+7)) LFM = TYT/100 RORC = MOD(TYT,10) IF (LFM .GE. 1 .AND. RORC .EQ. 0) THEN NUP(1) = NUP(1) + 1 NIM(1,NUP(1)) = NN ENDIF ENDIF ENDIF ENDIF IF (NN .LT. NEL .AND. NELS .LE. 1 1 .AND. NN .LE. NMISRE) THEN NN = NN + 1 GO TO 30 ENDIF C 50 RETURN END SUBROUTINE FINGER C C FILL IN POINTERS FOR BEAM LINE SPECIFICATIONS C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'BROAD.CIN' INCLUDE 'DATA0A.CIN' INCLUDE 'DATA0B.CIN' INCLUDE 'DATA1A.CIN' INCLUDE 'DATA1C.CIN' INCLUDE 'DATA1D.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM8A.CIN' INCLUDE 'ELM8F.CIN' INCLUDE 'ELM8G.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM13B.CIN' INCLUDE 'ELM24A.CIN' INCLUDE 'ELM26A.CIN' INCLUDE 'ELM31A.CIN' INCLUDE 'ELM38B.CIN' INCLUDE 'INDPAR.CIN' C C LOCAL VARIABLES C CHARACTER*15 LABLE EXTERNAL IDATA C C--------------------------------------------------------------------- C C PROCESS DATA C NUM = 1 IOLD = 0 ALIGN = .FALSE. NUP(1) = 0 NUP(2) = 0 NUP(3) = 0 NC = 0 NV1 = 0 BAX = .FALSE. RANZC = .FALSE. NMARKB = 0 NMARKE = 0 NMISRB = 0 NMISRE = 0 NB22 = 0 NBPLOT = 0 BROAD = .FALSE. C 70 I = ISTOR(NUM) TYPE = IDATA(I) LABLE = LABEL(NUM) IF (NUSE .EQ. 0 .AND. I .LE. IOLD) GO TO 6100 IF (TYPE .LE. 0 .OR. TYPE .GE. 50) GO TO 6100 CALL SKETCH(NUM) C C PROCESS ORIGINAL DATA C IF (TYPE .EQ. 6) GO TO 600 IF (TYPE .EQ. 8) GO TO 800 IF (TYPE .EQ. 10) GO TO 1000 IF (TYPE .EQ. 13) GO TO 1300 IF (TYPE .EQ. 22) GO TO 2200 IF (TYPE .EQ. 24) GO TO 2400 IF (TYPE .EQ. 26) GO TO 2600 IF (TYPE .EQ. 33) GO TO 3300 IF (TYPE .EQ. 37) GO TO 3700 IF (TYPE .EQ. 38) GO TO 3800 IF (TYPE .EQ. 40) GO TO 4000 IF (TYPE .EQ. 44) GO TO 4400 GO TO 6000 C C UPDATE C 600 IF (IPTOJ(3) .NE. 0) THEN IF (NMARKB .EQ. 0) NMARKB = NUM NMARKE = NUM ENDIF GO TO 6000 C C MISALIGNMENT C 800 ALIGN = .TRUE. TYT = INT(DATA(I+7)) LFM = TYT/100 IF (LFM .GE. 2) RANZC = .TRUE. RORC = MOD(TYT,10) IR = RORC + 1 IF (LFM .GE. 1 .AND. RORC .LE. 2) NUP(IR) = NUP(IR) + 1 IF (IDATA(I+9) .NE. 0) THEN IF (TIE(I+9) .EQ. 102) THEN IF (NMISRB .EQ. 0) THEN NMISRB = NUM ENDIF NMISRE = NUM ELSE IF (TIE(I+9) .EQ. 101) THEN IF (NMARKB .EQ. 0) NMARKB = NUM NMARKE = NUM ENDIF ENDIF GO TO 6000 C C CONSTRAINT C 1000 NC = NC + 1 ILOC = 7 IF (IPTOJ(ILOC) .NE. 0) THEN IF (NMARKB .EQ. 0) THEN IF (NB22 .EQ. 0) THEN NMARKB = NUM ELSE NMARKB = NB22 ENDIF ENDIF NMARKE = NUM ENDIF NB22 = 0 GO TO 6000 C C INPUT/OUTPUT OPTION C 1300 CDB = INT(DATA(I+1)) IF (CDB .EQ. 9) BAX = .TRUE. IF (IPTOJ(2) .NE. 0) THEN IF (NMARKB .EQ. 0) NMARKB = NUM NMARKE = NUM ENDIF GO TO 6000 C C MATRIX ELEMENT C 2200 IF (NB22 .EQ. 0) NB22 = NUM GO TO 6000 C C DEFINED SECTION C 2400 JDEF = IDATA(I+1) IF (JDEF .EQ. 1 .OR. JDEF .EQ. 2) CALL FNDREF(LABLE) GO TO 6100 C C RANDOM ERRORS IN PHYSICAL PARAMETERS C 2600 RANZC = .TRUE. GO TO 6000 C C STORE C 3300 IF (IPTOJ(2) .NE. 0) THEN IF (NMARKB .EQ. 0) THEN IF (NB22 .EQ. 0) THEN NMARKB = NUM ELSE NMARKB = NB22 ENDIF ENDIF NMARKE = NUM ENDIF NB22 = 0 GO TO 6000 C C ALIGNMENT MARKER C 3700 IF (IPTOJ(3) .NE. 0) THEN IF (NMARKB .EQ. 0) NMARKB = NUM NMARKE = NUM ENDIF GO TO 6000 C C PLOT OF MATRIX ELEMENT C 3800 IF (NBPLOT .EQ. 0) THEN IF (NB22 .NE. 0) NBPLOT = NB22 IF (NB22 .EQ. 0) NBPLOT = NUM ENDIF GO TO 6000 C C MAGNET TYPES C 4000 CALL FNDMAG(LBTYP(NUM)) GO TO 6000 C C BROAD-BAND FITTING C 4400 BROAD = .TRUE. GO TO 6000 C C CHECK VARY CODES C 6000 IBEG = I + 1 NUM1 = NUM 6001 IEND = ISTOR(NUM1 + 1) IF (IEND .LT. IBEG) THEN NUM1 = NUM1 + 1 GO TO 6001 ENDIF 6005 IEND = IEND - 1 DO 6010 IB = IBEG, IEND NV2 = IABS(TIE(IB)) IF (NV2 .LT. 99) NV1 = MAX0(NV1,NV2) 6010 CONTINUE C C ADVANCE TO NEXT ELEMENT C 6100 IOLD = MAX0(I,IOLD) NUM = NUM + 1 IF (NUM .LE. NEL) GO TO 70 RETURN END SUBROUTINE FITCHK C C DETERMINES IF VARIED ELEMENTS ARE USED C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA0A.CIN' INCLUDE 'DATA0B.CIN' INCLUDE 'DATA1A.CIN' INCLUDE 'DATA1C.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'DATA2B.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM0D.CIN' INCLUDE 'ELM0F.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM10E.CIN' INCLUDE 'ELM16A.CIN' INCLUDE 'ELM24A.CIN' INCLUDE 'ELM31A.CIN' INCLUDE 'INDPAR.CIN' INCLUDE 'VFLAG.CIN' C--------------------------------------------------------------- EXTERNAL IDATA C CALL FILL23 C NUM = 1 NDIF = 1 ATWORK = NUSE .EQ. 0 MKG = .FALSE. NV1 = 0 C 1 I = ISTOR(NUM) TYPE = IDATA(I) IF (TYPE .LE. 0 .OR. TYPE .GE. 50) GO TO 5200 CALL SKETCH(NUM) NCT = NCT + 1 CALL DEPICT IF (.NOT. ATWE) GO TO 5200 IF (TYPE .EQ. 1) GO TO 5000 IF (TYPE .EQ. 2) GO TO 5000 IF (TYPE .EQ. 3) GO TO 5000 IF (TYPE .EQ. 4) GO TO 5000 IF (TYPE .EQ. 5) GO TO 5000 IF (TYPE .EQ. 7) GO TO 5000 IF (TYPE .EQ. 8) GO TO 5000 IF (TYPE .EQ. 12) GO TO 5000 IF (TYPE .EQ. 14) GO TO 5000 IF (TYPE .EQ. 16) GO TO 1600 IF (TYPE .EQ. 18) GO TO 5000 IF (TYPE .EQ. 19) GO TO 5000 IF (TYPE .EQ. 20) GO TO 5000 IF (TYPE .EQ. 24) GO TO 2400 IF (TYPE .EQ. 25) GO TO 5000 IF (TYPE .EQ. 27) GO TO 5000 IF (TYPE .EQ. 28 .OR. TYPE .EQ. 29) GO TO 5000 IF (TYPE .EQ. 30) GO TO 5000 IF (TYPE .EQ. 34) GO TO 5000 IF (TYPE .EQ. 35 .OR. TYPE .EQ. 36) GO TO 5000 IF (TYPE .EQ. 42) GO TO 5000 GO TO 5200 C 1600 NPARS = INT(DATA(I+1)) GO TO 5000 C 2400 JDEF = IDATA(I+1) IF (JDEF .EQ. 3 .OR. JDEF .EQ. 4) THEN NADDEF(1) = IDATA(I+2) NADDEF(2) = IDATA(I+3) ENDIF CALL DEFINE GO TO 5200 C 5000 NVTYPE = NV(TYPE) IF (NVTYPE .EQ. 0) GO TO 5200 DO 5050 JV = 1, NVTYPE IPT = IPTOJ(JV) IF (IPT .EQ. 0) GO TO 5050 IADR = I + IPT 5010 ISIG = IABS(TIE(IADR)) IVARY = ISIG IF (IVARY .NE. 0 .AND. IVARY .LE. NPVAR) IVARY = VSTOR(IVARY) IF (IVARY .GE. 2 .AND. IVARY .LE. 50) VFLAG = .TRUE. IF (ISIG .NE. 0 .AND. ISIG .LE. NPVAR) GO TO 5040 IF (ISIG .EQ. 100) THEN IADR = IDATA(IADR) GO TO 5010 ENDIF IF (ISIG .EQ. 99) THEN ISIG = 0 DO 5020 K = 1, NPVAR REF = DATA(IADR + K) IF (REF .GT. 0.5) ISIG = MAX0(ISIG,K) 5020 CONTINUE ENDIF 5040 IF (ISIG .GT. NV1) NV1 = ISIG 5050 CONTINUE C 5200 NUM = NUM + NDIF IF (NUM .LE. NEL) GO TO 1 RETURN END SUBROUTINE FITTIN C C READS IN ALL DATA, UNSCRAMBLES, AND FITS INTO DATA ARRAY C C LIST OF COMMON BLOCKS C INCLUDE 'DATA2A.CIN' INCLUDE 'DATA2D.CIN' INCLUDE 'FLUSHC.CIN' INCLUDE 'IMAGE.CIN' INCLUDE 'IOFLAG.CIN' INCLUDE 'IOUNIT.CIN' INCLUDE 'LIMITS.CIN' INCLUDE 'RDBUFF.CIN' INCLUDE 'RDCARD.CIN' INCLUDE 'RDCHAR.CIN' INCLUDE 'RDCOMS.CIN' INCLUDE 'RDPRNT.CIN' C C LOCAL VARIABLES C LOGICAL FLAG INTEGER J, L C C---------------------------------------------------------------------- C READ AND PRINT TITLE AND INDICATOR C LIST = .TRUE. RFM = .FALSE. BEF = .TRUE. PRNT = .TRUE. SLV = .TRUE. BWT = .FALSE. BRD = .FALSE. NPSTEP = NPSTEP + 1 C ECHO = .FALSE. CALL TITLE IF (ENDFIL) GO TO 600 C 2 NORAYS = 0 CALL RDIND(FLAG) IF (ENDFIL) GO TO 600 IF (LIST) THEN WRITE (NOUT,9001) WRITE (NOUT,9000) IMAGE IF (NCOMS .GT. 0) THEN L = LCOM WRITE (NOUT,1004) (CMMNT(J), J = 1, L), PARENC 1004 FORMAT (1H0,11X,'(',79A1) ENDIF WRITE (NOUT,9005) KTEXT ENDIF IF (NPSTEP .EQ. 1 .AND. INDIC .NE. 0) FLAG = .TRUE. IF (FLAG) THEN WRITE (NOUT, 9010) INDIC = 0 INDS = 0 ENDIF IF (INDS .NE. 0) GO TO 200 C C READ NEW SYSTEM C 100 ECHO = LIST .AND. .NOT. RFM NUSE = 0 CALL RDDATA IF (ENDFIL) THEN CALL RDENDF GO TO 600 ENDIF GO TO 400 C C CONVERT INTERNAL VARY CODES TO EXTERNAL C 200 ECHO = LIST .AND. .NOT. RFM CALL RDVCEX IF (ENDFIL) GO TO 600 400 IF (LIST .AND. RFM) WRITE (NOUT,9400) C C CONVERT EXTERNAL VARY CODES TO INTERNAL C 500 IF (FLUSHL) WRITE (NOUT,9150) IF (FLUSHL .OR. LIST) WRITE (NOUT,9160) NEL, NELLIM, I, IDLIM C 600 RETURN C 9000 FORMAT (1H0,10X,1H",A80,1H") 9001 FORMAT (1H1) 9005 FORMAT (1H0,10X,A80) 9010 FORMAT ('0INDICATOR VALUE WRONG OR MISSING - ZERO ASSUMED') 9150 FORMAT ('0DATA OVERFLOW OR ERRORS, RUN FLUSHED') 9160 FORMAT (1H0,I5,' ELEMENTS USED OUT OF A MAXIMUM ALLOWABLE',I5/ 1 1H ,I5,' NUMBERS USED OUT OF A MAXIMUM ALLOWABLE',I6) 9400 FORMAT (9H0SENTINEL) END SUBROUTINE FIX23H C C REVISE REFERENCES FOR ALGEBRAIC OPERATIONS FOLLOWING PRESENT ELEMENT C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA0A.CIN' INCLUDE 'DATA0B.CIN' INCLUDE 'DATA1A.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'DATA2D.CIN' INCLUDE 'ELM24D.CIN' INCLUDE 'LIMITS.CIN' C C LOCAL VARIABLES C INTEGER TYPET EQUIVALENCE (FAKE,LAKE) EXTERNAL IDATA C C------------------------------------------------------------------------ C NN = NUM KRCOM = II + 1 C 10 NN = NN + 1 III = ISTOR(NN) TYPET = IDATA(III) IF (TYPET .LE. 0 .OR. TYPET .GE. 50) GO TO 6000 CALL SKETCH(NN) IF (TYPET .EQ. 2 .OR. TYPET .EQ. 3 .OR. TYPET .EQ. 4 1 .OR. TYPET .EQ. 5 .OR. TYPET .EQ. 7 .OR. TYPET .EQ. 8 2 .OR. TYPET .EQ. 11 .OR. TYPET .EQ. 14 .OR. TYPET .EQ. 16 3 .OR. TYPET .EQ. 18 .OR. TYPET .EQ. 19 .OR. TYPET .EQ. 20 4 .OR. TYPET .EQ. 25 .OR. TYPET .EQ. 28 .OR. TYPET .EQ. 29 5 .OR. TYPET .EQ. 30 .OR. TYPET .EQ. 34 .OR. TYPET .EQ. 35 6 .OR. TYPET .EQ. 36 .OR. TYPET .EQ. 42) GO TO 100 IF (TYPET .EQ. 23) GO TO 2300 GO TO 6000 C C PHYSICAL ELEMENT C 100 DO 110 J = 1, NPARMS IADR = III + J KREG = IDATA(IADR) KTIE = TIE(IADR) IF (KTIE .EQ. 100 .AND. KREG .EQ. KRCOM) THEN KREG = I + 1 LAKE = KREG DATA(IADR) = FAKE ENDIF 110 CONTINUE GO TO 6000 C C 23. -- ALGEBRAIC OPERATION C 2300 K1REG = IDATA(III+1) K2REG = IDATA(III+2) JREG = IDATA(III+4) K1TIE = TIE(III+1) K2TIE = TIE(III+2) JTIE = TIE(III+4) KRCOM = II + 1 IF (K1TIE .EQ. 100 .AND. K1REG .EQ. KRCOM) K1REG = I + 1 IF (K2TIE .EQ. 100 .AND. K2REG .EQ. KRCOM) K2REG = I + 1 IF (JTIE .EQ. 100 .AND. JREG .EQ. KRCOM) JREG = I + 1 LAKE = K1REG DATA(III+1) = FAKE LAKE = K2REG DATA(III+2) = FAKE LAKE = JREG DATA(III+4) = FAKE GO TO 6000 C 6000 IF (NN .LT. NELLIM) GO TO 10 C 6200 RETURN END SUBROUTINE FIX23L C C REVISE REFERENCES FOR ALGEBRAIC OPERATIONS PRECEDING PRESENT ELEMENT C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA0A.CIN' INCLUDE 'DATA0B.CIN' INCLUDE 'DATA1A.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM24D.CIN' C C LOCAL VARIABLES C INTEGER TYPET EQUIVALENCE (FAKE,LAKE) EXTERNAL IDATA C C-------------------------------------------------------------------- C NN = 0 C 10 NN = NN + 1 III = ISTOR(NN) TYPET = IDATA(III) IF (TYPET .EQ. 23) GO TO 2300 GO TO 6000 C C 23. -- ALGEBRAIC OPERATION C 2300 K1REG = IDATA(III+1) K2REG = IDATA(III+2) JREG = IDATA(III+4) K1TIE = TIE(III+1) K2TIE = TIE(III+2) JTIE = TIE(III+4) KRCOM = II + 1 IF (K1TIE .EQ. 100 .AND. K1REG .EQ. KRCOM) K1REG = I + 1 IF (K2TIE .EQ. 100 .AND. K2REG .EQ. KRCOM) K2REG = I + 1 IF (JTIE .EQ. 100 .AND. JREG .EQ. KRCOM) JREG = I + 1 LAKE = K1REG DATA(III+1) = FAKE LAKE = K2REG DATA(III+2) = FAKE LAKE = JREG DATA(III+4) = FAKE GO TO 6000 C 6000 IF (NN .LT. NEL) GO TO 10 C 6200 RETURN END SUBROUTINE FIX8H C C REVISE REFERENCES FOR MISALIGNMENTS C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA0A.CIN' INCLUDE 'DATA0B.CIN' INCLUDE 'DATA1A.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'LIMITS.CIN' C C LOCAL VARIABLES C INTEGER TYPET EQUIVALENCE (FAKE,LAKE) EXTERNAL IDATA C C------------------------------------------------------------------------ C NN = NUM C 10 NN = NN + 1 III = ISTOR(NN) TYPET = IDATA(III) IF (TYPET .LE. 0 .OR. TYPET .GE. 50) GO TO 6000 IF (TYPET .EQ. 8) GO TO 800 GO TO 6000 C C 8. -- MISALIGNMENT C 800 KREG = IDATA(III+9) KTIE = TIE(III+9) IF (KREG .EQ. NUM .AND. KTIE .NE. 100) THEN KREG = NEL ENDIF LAKE = KREG DATA(III+9) = FAKE GO TO 6000 C 6000 IF (NN .LT. NELLIM) GO TO 10 C 6200 RETURN END SUBROUTINE FNDMAG(KNAME) C C FIND MAGNETS OF THE GIVEN TYPE C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA0A.CIN' INCLUDE 'DATA1A.CIN' INCLUDE 'DATA1D.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'INDPAR.CIN' C C LOCAL VARIABLES C CHARACTER*15 KNAME EQUIVALENCE (FAKE,LAKE) EXTERNAL IDATA C C----------------------------------------------------------------------- C IF (NEL .EQ. 0) GO TO 200 DO 20 NN = 1, NEL IEL = ISTOR(NN) NTYPE = IDATA(IEL) IF (KNAME .NE. LBTYP(NN)) GO TO 20 IF (NTYPE .NE. 3 .AND. NTYPE .NE. 4 .AND. NTYPE .NE. 5 1 .AND. NTYPE .NE. 11 .AND. NTYPE .NE. 18 .AND. NTYPE .NE. 19 2 .AND. NTYPE .NE. 20 .AND. NTYPE .NE. 25 .AND. NTYPE .NE. 28 3 .AND. NTYPE .NE. 29 .AND. NTYPE .NE. 35 .AND. NTYPE .NE. 36) 4 GO TO 20 CALL SKETCH(NN) IF (NTYPE .EQ. 3) ILB = 2 IF (NTYPE .EQ. 5) ILB = 7 IF (NTYPE .EQ. 11) ILB = 6 IF (NTYPE .EQ. 18) ILB = 6 IF (NTYPE .EQ. 19) ILB = 4 IF (NTYPE .EQ. 20) ILB = 2 IF (NTYPE .EQ. 25) ILB = 6 IF (NTYPE .EQ. 28 .OR. NTYPE .EQ. 29) ILB = 25 IF (NTYPE .EQ. 35 .OR. NTYPE .EQ. 36) ILB = 6 ILB = IPTOJ(ILB) IF (ILB .NE. 0) THEN IADR = IEL + ILB LAKE = NUM DATA(IADR) = FAKE ENDIF 20 CONTINUE 200 RETURN END SUBROUTINE FNDREF(KNAME) C C FIND PREVIOUS REFERENCES TO DEFINED BEAM SUBLINE C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA0A.CIN' INCLUDE 'DATA0B.CIN' INCLUDE 'DATA1A.CIN' INCLUDE 'DATA1C.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM24A.CIN' C C LOCAL VARIABLES C CHARACTER*15 KNAME EQUIVALENCE (FAKE,LAKE) EXTERNAL IDATA C----------------------------------------------------------------------- C IF (NEL .EQ. 0) GO TO 200 DO 20 NN = 1, NEL IEL = ISTOR(NN) NTYPE = IDATA(IEL) IF (KNAME .NE. LABEL(NN)) GO TO 20 IF (NTYPE .NE. 24) GO TO 20 IREF = IDATA(IEL+1) IF (IREF .NE. 3 .AND. IREF .NE. 4) GO TO 20 IADD = JDEF + 1 IADR = IEL + IADD LAKE = NUM DATA(IADR) = FAKE TIE(IADR) = 100 20 CONTINUE 200 RETURN END SUBROUTINE FNDSTP C C LOCATE VARIABLE TO BE STEPPED C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA1A.CIN' INCLUDE 'DATA1C.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'DBEAM.CIN' INCLUDE 'DBEND.CIN' INCLUDE 'DCENT.CIN' INCLUDE 'DCVTY.CIN' INCLUDE 'DDRFT.CIN' INCLUDE 'DETA.CIN' INCLUDE 'DFIT.CIN' INCLUDE 'DHKICK.CIN' INCLUDE 'DKICK.CIN' INCLUDE 'DMIS.CIN' INCLUDE 'DOCT.CIN' INCLUDE 'DQUAD.CIN' INCLUDE 'DRBND.CIN' INCLUDE 'DROT.CIN' INCLUDE 'DSEXT.CIN' INCLUDE 'DSOLE.CIN' INCLUDE 'DSPEC.CIN' INCLUDE 'DSROT.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'NELMS.CIN' INTEGER NBEAM, NROT, NDRFT, NBEND, NQUAD, NUPD INTEGER NCENT, NMIS, NREPS, NFIT, NCVTY, NCORR INTEGER NPRNT, NMTX, NUNIT, NSPEC, NORD, NSEXT INTEGER NSOLE, NSROT, NSTRA, NSTOR, NSECT, NOCT INTEGER NRAN, NETA, NRBND, NSBND, NMRKR, NHKCK INTEGER NPLT, NLIM, NMAGN, NSEPM, NKICK, NSHIFT EQUIVALENCE (NBEAM,NELMS(1)), (NROT ,NELMS(2)), 1 (NDRFT,NELMS(3)), (NBEND,NELMS(4)), 2 (NQUAD,NELMS(5)), (NUPD ,NELMS(6)), 3 (NCENT,NELMS(7)), (NMIS ,NELMS(8)), 4 (NREPS,NELMS(9)), (NFIT ,NELMS(10)), 5 (NCVTY,NELMS(11)), (NCORR,NELMS(12)), 6 (NPRNT,NELMS(13)), (NMTX ,NELMS(14)), 7 (NUNIT,NELMS(15)), (NSPEC,NELMS(16)), 8 (NORD ,NELMS(17)), (NSEXT,NELMS(18)), 9 (NSOLE,NELMS(19)), (NSROT,NELMS(20)), A (NSTRA,NELMS(21)), (NSTOR,NELMS(22)), B (NSECT,NELMS(24)), C (NOCT ,NELMS(25)), (NRAN ,NELMS(26)), D (NETA ,NELMS(27)), (NRBND,NELMS(28)), E (NSBND,NELMS(29)), F (NMRKR,NELMS(31)), H (NHKCK,NELMS(35)), I (NPLT,NELMS(38)), J (NLIM ,NELMS(39)), (NMAGN,NELMS(40)), K (NSEPM,NELMS(41)), (NKICK,NELMS(42)), L (NSHIFT,NELMS(43)) INCLUDE 'STEPT1.CIN' INCLUDE 'STEPTC.CIN' C CHARACTER*15 LABLE C IPAR = 0 IHIGH = 0 C DO 500 N = 1, NEL IF (IPAR .NE. 0) GO TO 510 I = ISTOR(N) IF (I .LT. IHIGH) GO TO 500 TYPE = IDATA(I) LABLE = LABEL(N) IF (LABLE .NE. STCTYP) GO TO 500 IELEM = I CALL SKETCH(N) C GO TO ( 10, 20, 30, 40, 50,500, 70, 80,500,100, 1 110,500,500,500,500,160,500,180,190,200, 2 500,500,500,500,250,500,270,280,280,300, 3 500,500,500,340,350,350,500,500,500,500, 4 500,420,500,500,500,500,500,500), TYPE C 10 CALL RDLOOK(STCPAR,15,DBEAM,1,NBEAM,IPAR) GO TO 500 C 20 CALL RDLOOK(STCPAR,15,DROT,1,NROT,IPAR) GO TO 500 C 30 CALL RDLOOK(STCPAR,15,DDRFT,1,NDRFT,IPAR) GO TO 500 C 40 CALL RDLOOK(STCPAR,15,DBEND,1,NBEND,IPAR) GO TO 500 C 50 CALL RDLOOK(STCPAR,15,DQUAD,1,NQUAD,IPAR) GO TO 500 C 70 CALL RDLOOK(STCPAR,15,DCENT,1,NCENT,IPAR) GO TO 500 C 80 CALL RDLOOK(STCPAR,15,DMIS,1,NMIS,IPAR) GO TO 500 C 100 CALL RDLOOK(STCPAR,15,DFIT,1,NFIT,IPAR) GO TO 500 C 110 CALL RDLOOK(STCPAR,15,DCVTY,1,NCVTY,IPAR) GO TO 500 C 160 CALL RDLOOK(STCPAR,15,DSPEC,1,NCORR,IPAR) IF (IPAR .NE. 0) IPAR = 2 GO TO 500 C 180 CALL RDLOOK(STCPAR,15,DSEXT,1,NSEXT,IPAR) GO TO 500 C 190 CALL RDLOOK(STCPAR,15,DSOLE,1,NSOLE,IPAR) GO TO 500 C 200 CALL RDLOOK(STCPAR,15,DSROT,1,NSROT,IPAR) GO TO 500 C 250 CALL RDLOOK(STCPAR,15,DOCT,1,NOCT,IPAR) GO TO 500 C 270 CALL RDLOOK(STCPAR,15,DETA,1,NRAN,IPAR) GO TO 500 C 280 CALL RDLOOK(STCPAR,15,DRBND,1,NRBND,IPAR) GO TO 500 C 300 IPAR = 1 GO TO 500 C 340 CALL RDLOOK(STCPAR,15,DQUAD,1,NQUAD,IPAR) GO TO 500 C 350 CALL RDLOOK(STCPAR,15,DHKICK,1,NHKCK,IPAR) GO TO 500 C 420 CALL RDLOOK(STCPAR,15,DKICK,1,NKICK,IPAR) GO TO 500 C 500 CONTINUE C 510 ISTEP = IELEM + IPAR RETURN END SUBROUTINE FOCUS C C FIRST-ORDER TRANSFER MATRIX FOR FOCUSING ELEMENT C (QUADRUPOLE, BENDING MAGNET, OR PLASMA LENS) C C LIST OF COMMON BLOCKS C INCLUDE 'ELM0B.CIN' INCLUDE 'ELM5A.CIN' INCLUDE 'ELM5B.CIN' INCLUDE 'R.CIN' C C LOCAL VARIABLES C REAL KL, Y, YI C C----------------------------------------------------------------- C J = JQUAD KL = SQRT( ABS(KQ2)) * L IF (KQ2 .GE. 0.0) THEN CS = COS(KL) SN = SIN(KL) ELSE Y = EXP(KL) YI = 1.0/Y CS = 0.5*(Y + YI) SN = 0.5*(Y - YI) ENDIF R(J+1,J+1) = CS R(J,J) = CS IF (KL .NE. 0.) THEN R(J,J+1) = L*SN/KL ELSE R(J,J+1) = L ENDIF R(J+1,J) = - KQ2 * R(J,J+1) RETURN END SUBROUTINE FOCUS2 C C CALCULATES SECOND-ORDER TRANSFER MATRIX FOR A QUADRUPOLE C INCLUDE 'ELM0B.CIN' INCLUDE 'ELM5A.CIN' INCLUDE 'ELM5B.CIN' INCLUDE 'R.CIN' INCLUDE 'T.CIN' C J = JQUAD CS = R(J,J) SN = R(J,J+1) T(J,J+15) = 0.5*KQ2*SN*L T(J+1,J+16) = 0.5*KQ2*SN*L T(J,J+16) = (SN - L*CS)/2.0 T(J+1,J+15) = KQ2*(SN + L*CS)/2.0 T(5,J*(J+1)/2) = - 0.25*KQ2*(L - SN*CS) T(5,J*(J+3)/2) = 0.5*KQ2*SN**2 T(5,J*(J+3)/2+1) = - 0.25*(L + CS*SN) RETURN END SUBROUTINE FOCUS3 C C CALCULATES THIRD-ORDER TRANSFER MATRIX ELEMENTS FOR A QUADRUPOLE C INCLUDE 'ELM0B.CIN' INCLUDE 'ELM5A.CIN' INCLUDE 'ELM5B.CIN' INCLUDE 'R.CIN' INCLUDE 'U.CIN' C C LOCAL VARIABLES C C----------------------------------------------------------------------------- C J = JQUAD JO = 4 - J CS = R(J,J) SN = R(J,J+1) CSO = R(JO,JO) SNO = R(JO,JO+1) IF (J .EQ. 1) KLM = 1 IF (J .EQ. 3) KLM = 10 U(J,KLM) = KQ2**2*(13.*CS*SN**2 - 9.*L*SN)/48. U(J+1,KLM) = - KQ2**2*(7.*SN + 15.*KQ2*SN**3 1 + 9.*L*CS)/48. IF (J .EQ. 1) KLM = 2 IF (J .EQ. 3) KLM = 16 U(J,KLM) = KQ2*(- 22.*SN + 26.*KQ2*SN**3 + 6.*L*CS)/32. U(J+1,KLM) = 3.*KQ2**2*(5.*CS*SN**2 - L*SN)/16. IF (J .EQ. 1) KLM = 3 IF (J .EQ. 3) KLM = 19 U(J,KLM) = - KQ2*(13.*CS*SN**2 + 3.*L*SN)/16. U(J+1,KLM) = KQ2*(- 26.*SN + 30.*KQ2*SN**3 1 - 6.*L*CS)/32. IF (J .EQ. 1) KLM = 4 IF (J .EQ. 3) KLM = 20 U(J,KLM) = (- 9.*SN - 13.*KQ2*SN**3 + 9.*L*CS)/48. U(J+1,KLM) = - KQ2*(5.*CS*SN**2 + 3.*L*SN)/16. IF (J .EQ. 1) KLM = 8 IF (J .EQ. 3) KLM = 5 U(J,KLM) = KQ2**2*(- 3.*CS*SNO**2 + 2.*L*SN 1 - 3.*SN*SNO*CSO)/16. U(J+1,KLM) = KQ2**2*(2.*L*CS - 9.*CS*CSO*SNO - 9.*SN 1 - 11.*KQ2*SN*SNO**2)/16. IF (J .EQ. 1) KLM = 14 IF (J .EQ. 3) KLM = 6 U(J,KLM) = 3.*KQ2*(- CS*CSO*SNO + SN - KQ2*SN*SNO**2)/8. U(J+1,KLM) = KQ2**2*(- 9.*CS*SNO**2 - 11.*SN*SNO*CSO)/8. IF (J .EQ. 1) KLM = 17 IF (J .EQ. 3) KLM = 7 U(J,KLM) = - KQ2*(3.*CS*SNO**2 + 2.*L*SN 1 + 3.*SN*CSO*SNO)/16. U(J+1,KLM) = - KQ2*(2.*L*CS + 9.*CS*CSO*SNO 1 + 11.*KQ2*SN*SNO**2 + 5.*SN)/16. IF (J .EQ. 1) KLM = 9 IF (J .EQ. 3) KLM = 11 U(J,KLM) = KQ2*(3.*CS*CSO*SNO - 2.*L*CS - 3.*SN*CSO**2 1 - 6.*SN)/16. U(J+1,KLM) = KQ2**2*(11.*CS*SNO**2 + 2.*L*SN 1 - 9.*SN*CSO*SNO)/16. IF (J .EQ. 1) KLM = 15 IF (J .EQ. 3) KLM = 12 U(J,KLM) = 3.*KQ2*(CS*SNO**2 - SN*CSO*SNO)/8. U(J+1,KLM) = KQ2*(11.*CS*CSO*SNO - 3.*SN 1 - 9.*KQ2*SN*SNO**2)/8. IF (J .EQ. 1) KLM = 18 IF (J .EQ. 3) KLM = 13 U(J,KLM) = (3.*CS*CSO*SNO + 2.*L*CS - 3.*SN*CSO**2 1 - 2.*SN)/16. U(J+1,KLM) = KQ2*(11.*CS*SNO**2 - 2.*L*SN 1 - 9.*SN*CSO*SNO)/16. U(J,50+J) = - KQ2*(3.*L*SN + L**2*CS)/8. U(J,51+J) = (- KQ2*L**2*SN + L*CS - SN)/8. U(J+1,50+J) = KQ2*(- 5.*L*CS - 3.*SN + KQ2*L**2*SN)/8. U(J+1,51+J) = KQ2*(- 3.*L*SN - L**2*CS)/8. RETURN END SUBROUTINE FORM C C SET UP NORMALIZED EQUATIONS FOR FITTING C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'BROAD.CIN' INCLUDE 'DATA0A.CIN' INCLUDE 'DATA0B.CIN' INCLUDE 'DATA1A.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM10D.CIN' INCLUDE 'ELM10E.CIN' INCLUDE 'ELM10F.CIN' INCLUDE 'ELM39C.CIN' INCLUDE 'INDPAR.CIN' INCLUDE 'FLUSHC.CIN' INCLUDE 'STEPT1.CIN' C C LOCAL VARIABLES C INTEGER VARY REAL LIMIT EXTERNAL IDATA C C--------------------------------------------------------------- C ZERO LOWER LEFT HALF OF MATRIX OF NORMAL EQUATIONS C NP1 = NV3 + 1 DO 10 L1 = 1, NP1 DO 10 L2 = 1, L1 CA(L1,L2) = 0.0 10 CONTINUE C C FILL IN MATRIX OF NORMAL EQUATIONS C IF (LSTEP .AND. BROAD) GO TO 20 IF (NSTEP .GE. 1 .AND. NCTV .LT. NCTE) THEN NUM = NUMV DOPARS = .TRUE. NCTS = NCTV NCTF = NCTE - 1 CALL MARCH IF (FLUSHL) GO TO 200 ENDIF DOPARS = .FALSE. NCTS = NCTE NCTF = NCTC CALL MARCH IF (FLUSHL) GO TO 200 GO TO 30 C C BROAD BAND CASE C 20 DO 25 NSTEPP = 1, NSTEPS CALL STEPIT IF (NSTEP .GE. 1 .AND. NCTV .LT. NCTE) THEN NUM = NUMV DOPARS = .TRUE. NCTS = NCTV NCTF = NCTE - 1 CALL MARCH IF (FLUSHL) GO TO 200 ENDIF DOPARS = .FALSE. NCTS = NCTE NCTF = NCTC CALL MARCH IF (FLUSHL) GO TO 200 25 CONTINUE C C SYMMETRIZE MATRIX C 30 DO 35 L1 = 2, NV1, 1 L1P1 = L1 + 1 DO 35 L2 = L1P1, NP1 CA(L1,L2) = CA(L2,L1) 35 CONTINUE C C DETERMINE WHICH VARIABLES WILL NOT HIT LIMITS C DO 40 N = 1, NP1 40 ACTIV(N) = .TRUE. C CALL INITL C DO 100 NUM = 1, NEL I = ISTOR(NUM) TYPE = IDATA(I) IF (TYPE .LE. 0 .OR. TYPE .GE. 50) GO TO 100 IF (TYPE .EQ. 23) GO TO 100 CALL SKETCH(NUM) IF (TYPE .EQ. 39) GO TO 80 NVT = NV(TYPE) IF (NVT .LT. 1) GO TO 100 DO 60 J = 1, NVT IPT = IPTOJ(J) IF (IPT .EQ. 0) GO TO 60 IPLUSJ = I + IPT VARY = TIE(IPLUSJ) IF (VARY .EQ. 0 .OR. VARY .GE. 99) GO TO 60 IVARY = IABS(VARY) + 1 SIG = SIGNF(FLOAT(VARY)) X2 = DATA(IPLUSJ) C SI = LIMIT(TYPE,J,2) IF (SI .EQ. 0.0) GO TO 50 SI = LIMIT(TYPE,J,1) IF (X2 .GT. SI) GO TO 50 ACTIV(IVARY) = ACTIV(IVARY) .AND. SIG*CA(IVARY,1) .GE. 0.0 C 50 SI = LIMIT(TYPE,J,4) IF (SI .EQ. 0.0) GO TO 60 SI = LIMIT(TYPE,J,3) IF (X2 .LT. SI) GO TO 60 ACTIV(IVARY) = ACTIV(IVARY) .AND. SIG*CA(IVARY,1) .LE. 0.0 60 CONTINUE GO TO 100 C 80 TYPEL = INT(DATA(I+1)) NPARL = INT(DATA(I+2)) IF (IPTOJ(3) .NE. 0) THEN IPT = IPTOJ(3) LTYPE = 1 DPARL = DATA(I+IPT) CALL LIMSET ENDIF IF (IPTOJ(4) .NE. 0) THEN IPT = IPTOJ(4) LTYPE = 2 DPARL = DATA(I+IPT) CALL LIMSET ENDIF IF (IPTOJ(5) .NE. 0) THEN IPT = IPTOJ(5) LTYPE = 1 DPARL = DATA(I+IPT) DPARL = - ABS(DPARL) CALL LIMSET LTYPE = 2 DPARL = ABS(DPARL) CALL LIMSET ENDIF C 100 CONTINUE C NACTIV = 0 DO 110 N = 2, NP1 IF (ACTIV(N)) NACTIV = NACTIV + 1 110 CONTINUE C IF (CHSMIN .GT. 0.0 .AND. CA(1,1) .GE. CHSMIN) GO TO 200 CHSMIN = CA(1,1) DO 120 N = 2, NP1 IF (.NOT. ACTIV(N)) THEN DO 115 J = 1, NP1 CA(J,N) = 0.0 115 CA(N,J) = 0.0 ENDIF 120 CONTINUE C C SAVE CA ARRAY C DO 140 J = 1, NP1 DO 140 K = 1, NP1 140 CASAV(J,K) = CA(J,K) C C CALCULATE MAGNITUDE OF GRADIENT C GNORM = 0.0 DO 150 J = 2, NP1 CAJ1 = CA(J,1) 150 GNORM = GNORM + CAJ1*CAJ1 GNORM = SQRT(GNORM) C 200 RETURN END SUBROUTINE FRAME2 C C CALCULATES CONTRIBUTION OF SECOND-ORDER MATRIX TO THE C BILINEAR TERMS IN A MISALIGNMENT C C LIST OF COMMON BLOCKS C INCLUDE 'ELM8H.CIN' INCLUDE 'ELM8J.CIN' INCLUDE 'TS.CIN' C C---------------------------------------------------------------- DO 50 J = 1, 5 IND = 0 DO 50 K2 = 1, 6 DO 50 K1 = 1, K2 IND = IND + 1 DO 40 M = 1, 6 GT(J,K1,M) = GT(J,K1,M) - TS(J,IND)*CT0(K2,M) GT(J,K2,M) = GT(J,K2,M) - TS(J,IND)*CT0(K1,M) 40 CONTINUE 50 CONTINUE C RETURN END SUBROUTINE FRING2 C C CALCULATES SECOND-ORDER FRINGE FIELD TRANSFER MATRIX C INCLUDE 'ELM2A.CIN' INCLUDE 'ELM2B.CIN' INCLUDE 'ELM4A.CIN' INCLUDE 'T.CIN' C C LOCAL VARIABLES C REAL EPS, SB2, SB3, TB2, TB3 C------------------------------------------------------------------------------- C EPS = 2.0*H0*APB(2) TB2 = TB**2 TB3 = TB2*TB SB2 = SB**2 SB3 = SB2*SB IF (.NOT. BEFORE) GO TO 10 C C ENTRANCE FRINGE FIELD C T(1,1) = - 0.5*H0*TB2 T(1,6) = 0.5*H0*(SB2 1 - EPS*LAYL*SB*TB*(5.0*SB2 + TB2)) T(2,1) = 0.5*H0*RABT*SB3 - H0**2*NB*TB T(2,2) = H0*TB2 T(2,6) = H0**2*(TB*(NB + 0.5 + TB2) 1 - 0.5*EPS*LAYL*SB*TB2*(7.0*SB2 + 3.0*TB2)) 2 - 0.5*H0*RABT*(SB3 3 - EPS*LAYL*TB*SB2*(5.0*SB2 + TB2)) T(2,9) = H0*( - TB2 1 + EPS*LAYL*SB*TB*(SB2 + TB2)) T(2,16) = - H0*TB T(3,4) = H0*(TB2 1 - EPS*LAYL*SB*TB*(SB2 + TB2)) T(4,4) = 2.0*H0**2*TB*NB 1 - H0*RABT*(SB3 - EPS*LAYL*TB*SB2*(5.0*SB2 + TB2)) T(4,5) = H0*( - SB2 1 + EPS*LAYL*SB*TB*(5.0*SB2 + TB2)) T(4,7) = H0*( - TB2 1 + EPS*LAYL*SB*TB*(SB2 + TB2)) T(4,18) = H0*(TB 1 - 2.0*EPS*LAYL*SB*(SB2 + TB2)) GO TO 100 C C EXIT FRINGE FIELD C 10 T(1,1) = 0.5*H0*TB2 T(1,6) = 0.5*H0*( - SB2 1 + EPS*LAYL*SB*TB*(5.0*SB2 + TB2)) T(2,1) = 0.5*H0*RABT*SB3 - TB*(NB + 0.5*TB2)*H0**2 T(2,2) = - H0*TB2 T(2,6) = H0**2*(NB*TB - 0.5*TB3 1 + EPS*LAYL*SB*TB2*(SB2 + TB2)) 2 - 0.5*H0*RABT*(SB3 3 - EPS*LAYL*TB*SB2*(5.0*SB2 + TB2)) T(2,9) = H0*(TB2 1 - EPS*LAYL*SB*TB*(SB2 + TB2)) T(2,16) = - H0*TB T(3,4) = - H0*(TB2 1 - EPS*LAYL*SB*TB*(SB2 + TB2)) T(4,4) = H0**2*(TB*(2.0*NB + SB2) 1 - EPS*LAYL*SB*TB2*(5.0*SB2 + TB2)) 2 - H0*RABT*(SB3 - EPS*LAYL*TB*SB2*(5.0*SB2 + TB2)) T(4,5) = H0*(SB2 1 - EPS*LAYL*SB*TB*(5.0*SB2 + TB2)) T(4,7) = H0*(TB2 1 - EPS*LAYL*SB*TB*(SB2 + TB2)) T(4,18) = H0*(TB 1 - 2.0*EPS*LAYL*SB*(SB2 + TB2)) C 100 RETURN END SUBROUTINE FRING3 C C CALCULATES THIRD-ORDER FRINGE FIELD TRANSFER MATRIX C INCLUDE 'ELM2A.CIN' INCLUDE 'ELM2B.CIN' INCLUDE 'ELM4A.CIN' INCLUDE 'U.CIN' C C LOCAL VARIABLES C REAL BEE, EPS REAL FINT1, FINTJ1, FINTJ2, FINTJ3, FINTJ4 REAL SB2, SB3, SB4, TB2, TB3, TB4 EQUIVALENCE (LAYL,FINT1) C------------------------------------------------------------------------------ EPS = 2.0*H0*APB(2) TB2 = TB*TB TB3 = TB2*TB TB4 = TB3*TB SB2 = SB*SB SB3 = SB2*SB SB4 = SB3*SB BEE = 6.0*FINT1 FINTJ1 = 1.0/BEE FINTJ2 = 0.0 FINTJ3 = 1.0/6.0 FINTJ4 = 0.0 IF (.NOT. BEFORE) GO TO 10 C C ENTRANCE FACE C U(1,1) = - 0.5*H0*RABT*TB*SB3 U(1,2) = - H0*TB3 U(1,8) = - 0.5*H0**2*TB2*(SB2 + TB2) + 1.5*H0*RABT*TB*SB3 U(1,9) = H0*TB*SB2 U(1,14) = H0*TB*(SB2 + TB2) U(1,36) = 0.5*H0*TB2 U(1,41) = - 0.5*H0*SB2 C U(2,1) = 0.5*H0**3*TB3 + 0.5*H0*RABT**2*TB*SB4 U(2,2) = 1.5*H0**2*TB2 + 1.5*H0*RABT*TB*SB3 U(2,3) = 0.5*H0*TB*(2.0*SB2 + 1.0) U(2,8) = 0.5*H0**3*TB3 1 + 0.5*H0**2*RABT*(SB2 + 5.0*TB2)*SB3 2 - 1.5*H0*RABT**2*TB*SB4 U(2,9) = 3.0*H0**2*TB2*SB2 - 1.5*H0*RABT*TB*SB3 U(2,14) = 2.0*H0**2*TB4 - 3.0*H0*RABT*TB*SB3 U(2,15) = - 2.0*H0*TB*SB2 U(2,17) = 0.5*H0*TB*(SB2 - 3.0*TB2) U(2,36) = - 0.5*H0*RABT*SB3 U(2,37) = - H0*TB2 U(2,41) = - H0**2*TB*(SB2 + TB2) + 0.5*H0*RABT*SB3 U(2,44) = H0*TB2 U(2,51) = H0*TB C U(3,5) = 1.5*H0*RABT*TB*SB3 U(3,6) = H0*TB*(SB2 + TB2) U(3,10) = H0**2*(2.0*(SB2 + TB2)*SB2*FINTJ2/3.0 1 + (SB2 + 5.0*TB2)*SB2/6.0) 2 - 0.5*H0*RABT*TB*SB3 U(3,11) = H0*TB3 U(3,16) = - H0*SB2*TB U(3,39) = - H0*TB2 C U(4,5) = - 0.5*H0**3*TB3 - 1.5*H0*RABT**2*TB*SB4 U(4,6) = - H0**2*TB2 - 3.0*H0*RABT*TB*SB3 U(4,7) = - 0.5*H0*TB*(1.0 + 2.0*SB2) U(4,10) = H0**3*( - 2.0*(SB2 + TB2)*SB*FINTJ1/(3.0*EPS) 1 + TB*(8.0*SB4 - 5.0*SB2*TB2 + 9.0*TB4)/18.0 2 + 2.0*TB*(9.0*SB2 + 5.0*TB2)*SB2*FINTJ4/3.0 3 - 2.0*TB*SB2*(SB2 + TB2)*FINTJ2/3.0) 4 - H0**2*RABT*(SB3*(SB2 + 5.0*TB2)/6.0 5 - 2.0*SB*(5.0*SB2 + TB2)*FINTJ2/3.0) 6 + 0.5*H0*RABT**2*TB*SB4 U(4,11) = 0.5*H0**2*TB2 - 1.5*H0*RABT*TB*SB3 U(4,12) = - 2.0*H0*TB3 U(4,16) = H0**2*(- 0.5*(1.0 + 2.0*TB4) 1 - 2.0*SB2*(SB2 + TB2)*FINTJ2) 2 + 1.5*H0*RABT*TB*SB3 U(4,19) = H0*(TB3 - 0.5*TB) U(4,39) = H0*RABT*SB3 U(4,40) = H0*SB2 U(4,42) = H0*TB2 U(4,53) = - H0*TB GO TO 100 C C EXIT FACE C 10 U(1,1) = - 0.5*H0**2*TB4 + 0.5*H0*RABT*TB*SB3 U(1,2) = - H0*TB3 U(1,8) = 0.5*H0**2*TB2*(1.0 + SB2) - 1.5*H0*RABT*TB*SB3 U(1,9) = H0*TB*SB2 U(1,14) = H0*TB*(SB2 + TB2) U(1,36) = - 0.5*H0*TB2 U(1,41) = 0.5*H0*SB2 C U(2,1) = 0.5*H0**3*TB3*SB2 1 - H0**2*RABT*TB2*SB3 + 0.5*H0*RABT**2*TB*SB4 U(2,2) = 1.5*H0**2*TB2*SB2 - 1.5*H0*RABT*TB*SB3 U(2,3) = 0.5*H0*TB*(1.0 + 2.0*SB2) U(2,8) = 1.5*H0**3*TB3*SB2 - 1.5*H0*RABT**2*TB*SB4 U(2,9) = 1.5*H0**2*TB2*SB2 + 1.5*H0*RABT*TB*SB3 U(2,14) = - H0**2*TB2*(1.0 + SB2) + 3.0*H0*RABT*TB*SB3 U(2,15) = - 2.0*H0*TB*SB2 U(2,17) = 0.5*H0*TB*(SB2 - 3.0*TB2) U(2,36) = H0**2*TB3 - 0.5*H0*RABT*SB3 U(2,37) = H0*TB2 U(2,41) = H0**2*TB3 + 0.5*H0*RABT*SB3 U(2,44) = - H0*TB2 U(2,51) = H0*TB C U(3,5) = 0.5*H0**2*TB2*(2.0*SB2 + TB2) - 1.5*H0*RABT*TB*SB3 U(3,6) = H0*TB*(SB2 + TB2) U(3,10) = - H0**2*(2.0*(SB2 + TB2)*SB2*FINTJ2/3.0 1 + (SB2 - 4.0*TB2)*SB2/6.0) 2 + 0.5*H0*RABT*TB*SB3 U(3,11) = H0*TB3 U(3,16) = - H0*SB2*TB U(3,39) = H0*TB2 C U(4,5) = - 0.5*H0**3*TB3*(1.0 + 3.0*SB2) 1 + 0.5*H0**2*RABT*SB3*(SB2 + 5.0*TB2) 2 - 1.5*H0*RABT**2*TB*SB4 U(4,6) = - H0**2*TB2*(1.0 + 3.0*SB2) + 3.0*H0*RABT*TB*SB3 U(4,7) = - 0.5*H0*TB*(1.0 + 2.0*SB2) U(4,10) = H0**3*( - 2.0*(SB2 + TB2)*SB*FINTJ1/(3.0*EPS) 1 + TB*(2.0*SB4 - 8.0*SB2*TB2 + 9.0*TB4)/18.0 2 + 2.0*TB*(9.0*SB2 + 5.0*TB2)*SB2*FINTJ4/3.0 3 - 2.0*TB*(SB2 + TB2)*SB2*FINTJ2/3.0) 4 - H0**2*RABT*(SB3/6.0 5 + 2.0*TB2*SB*(5.0*SB2 + TB2)*FINTJ2/3.0) 6 + 0.5*H0*RABT**2*TB*SB4 U(4,11) = - 0.5*H0**2*TB2*(SB2 + 2.0*TB2) + 1.5*H0*RABT*TB*SB3 U(4,12) = - 2.0*H0*TB3 U(4,16) = H0**2*(0.5*(1.0 + 5.0*TB2 + TB4) 1 + 2.0*SB2*(SB2 + TB2)*FINTJ2) 2 - 1.5*H0*RABT*TB*SB3 U(4,19) = H0*(TB3 - 0.5*TB) U(4,39) = - 2.0*H0**2*SB2*TB + H0*RABT*SB3 U(4,40) = - H0*SB2 U(4,42) = - H0*TB2 U(4,53) = - H0*TB C 100 RETURN END SUBROUTINE FRINGE C C CALCULATES FIRST-ORDER TRANSFER MATRIX FOR BENDING MAGNET C FRINGING FIELD C C LIST OF COMMON BLOCKS C INCLUDE 'ELM2A.CIN' INCLUDE 'ELM2B.CIN' INCLUDE 'ELM4A.CIN' INCLUDE 'ELM16A.CIN' INCLUDE 'R.CIN' C C LOCAL VARIABLES C REAL CB, SB2, TB1, TB2, TCOR C C---------------------------------------------------------------- TB = TAN(BE) TB2 = TB*TB CB = COS(BE) SB = 1.0/CB SB2 = SB*SB TCOR = 2.0*H0*APB(2)*LAYL TB1 = TB - TCOR*SB*(SB2 + TB2) R(2,1) = H0*TB R(4,3) = - H0*TB1 LAYK = LAYKI C 500 RETURN END SUBROUTINE FXFLT (X,I,A) C WE SET A MAXIMUM VALUE TO A OF .99999 (1.0 - 1.0E-06) I = INT(X) A = X - FLOAT(I) A = AMIN1 (A,0.99999E+00) RETURN END SUBROUTINE FZERO INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA0A.CIN' INCLUDE 'DATA1A.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0A.CIN' C DO 100 NUM = 1, NEL I = ISTOR(NUM) TYPE = IDATA(I) IF (TYPE .EQ. 10) THEN DATA(I+5) = 0.0 DATA(I+6) = 0.0 ENDIF 100 CONTINUE C RETURN END SUBROUTINE GATHER C C FORM NORMALIZED EQUATIONS FOR FITTING FROM PARTIAL DERIVATIVES C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA0A.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM10A.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM10D.CIN' INCLUDE 'ELM22A.CIN' INCLUDE 'ELM23.CIN' C C------------------------------------------------------------ C C STORE CONSTRAINT IN COVARIANCE MATRIX C NP1 = NV1 + 1 IF (TYPE .EQ. 38) GO TO 200 IF (TYPE .EQ. 22) GO TO 100 IF (NV3 .LT. 1) GO TO 200 DO 10 L1 = 1, NP1 DO 10 L2 = 1, L1 CA(L1,L2) = CA(L1,L2) + CW * A(L1) * A(L2) 10 CONTINUE GO TO 200 C C STORE MATRIX ELEMENT IN REGISTER C 100 J = JREG IF (JTIE .EQ. 100) GO TO 150 LREG(J) = .TRUE. REG(J) = COC IF (NV3 .LT. 1) GO TO 200 DO 110 N = 1, NPVAR 110 DREG(J,N) = 0.0 IF (NV1 .LT. 1) GO TO 200 DO 120 N = 1, NV1 120 DREG(J,N) = A(N+1) GO TO 200 C C STORE MATRIX ELEMENT AND DERIVATIVES IN PSEUDO-PARAMETER C 150 DATA(J) = COC IF (NV3 .LT. 1) GO TO 200 DO 160 N = 1, NPVAR 160 DATA(J+N) = 0.0 IF (NV1 .LT. 1) GO TO 200 DO 170 N = 1, NV1 170 DATA(J+N) = A(N+1) C 200 RETURN END SUBROUTINE GGET C C VALUES OF PARAMETERS DESCRIBING QUADRUPOLE C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM0B.CIN' INCLUDE 'ELM1A.CIN' INCLUDE 'ELM4A.CIN' INCLUDE 'ELM4C.CIN' INCLUDE 'ELM5A.CIN' INCLUDE 'ELM6.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'ELM16B.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'ELM26B.CIN' INCLUDE 'FLUSHC.CIN' INCLUDE 'INDPAR.CIN' INCLUDE 'IOUNIT.CIN' INCLUDE 'XRAN.CIN' C C LOCAL VARIABLES C EXTERNAL DATAR, IDATA C--------------------------------------------------------------- C C MAGNET LENGTH C IADR = I + 1 L = DATAR(IADR) IF (PRAN5(1) .NE. 0.0) L = L + PRAN5(1)*XRAN(1) L = L*UNITI(8) LMAG = L C C INDICES FOR OTHER PARAMETERS C IB = IPTOJ(2) IAP = IPTOJ(3) IG = IPTOJ(4) IK1 = IPTOJ(5) IF (IG .NE. 0) GO TO 10 IF (IK1 .NE. 0) GO TO 20 IF (IB .NE. 0) GO TO 5 KQ2 = 0.0 GO TO 40 C C MAGNETIC FIELD AND APERTURE C 5 IADR = I + IB B = DATAR(IADR) IF (PRAN5(2) .NE. 0.0) B = B + PRAN5(2)*XRAN(2) B = B*UNITI(9)*RI/PREF IF (IAP .NE. 0) THEN IADR = I + IAP AP = DATAR(IADR) ELSE WRITE (NOUT,9008) 9008 FORMAT (' *** ERROR *** QUADRUPOLE APERTURE NOT GIVEN') FLUSHL = .TRUE. KQ2 = 0.0 AP = 0.0 GO TO 40 ENDIF IF (NORD1 .LT. 1) GO TO 40 IF (AP .NE. 0.0) THEN IF (PRAN5(3) .NE. 0.0) AP = AP + PRAN5(3)*XRAN(3) AP = AP*UNITI(1) KQ2 = B/(AP*RI) ELSE WRITE (NOUT,9005) 9005 FORMAT (' *** ERROR *** QUADRUPOLE APERTURE SET TO ZERO') FLUSHL = .TRUE. KQ2 = 0.0 ENDIF GO TO 40 C C GRADIENT C 10 IADR = I + IG GRAD = DATAR(IADR) IF (PRAN5(4) .NE. 0.0) GRAD = GRAD + PRAN5(4)*XRAN(4) GRAD = GRAD*UNITI(9)*RI/(PREF*UNITI(1)) KQ2 = GRAD/RI GO TO 40 C C K1 (NORMALIZED GRADIENT) C 20 IADR = I + IK1 K1 = DATAR(IADR) IF (PRAN5(5) .NE. 0.0) K1 = K1 + PRAN5(5)*XRAN(5) KQ2 = K1/UNITI(8)**2 C 40 IT = IPTOJ(7) IF (IT .EQ. 0) THEN NUMTYP = IT ELSE NUMTYP = IDATA(I + IT) ENDIF RETURN END SUBROUTINE GROPE C C ADVANCE PARTIAL DERIVATIVE MATRICES FOR MISALIGNMENTS C AND FLOOR COORDINATES C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'COP.CIN' INCLUDE 'DATA0A.CIN' INCLUDE 'DATA0B.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM0D.CIN' INCLUDE 'ELM0E.CIN' INCLUDE 'ELM2D.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'FLUSHC.CIN' INCLUDE 'INDPAR.CIN' INCLUDE 'NELMS.CIN' INCLUDE 'OC.CIN' INCLUDE 'OCP.CIN' INCLUDE 'OIV.CIN' C C LOCAL VARIABLES C INTEGER VARST REAL OS(3,3), XS(3) EXTERNAL IDATA C C------------------------------------------------------------------------- C C INDIVIDUAL COORDINATE TRANSFORM *TIMES* C DERIVATIVE OF ACCUMULATED COORDINATE TRANSFORM C IF (.NOT. OMTX) GO TO 200 IF (NV1 .LT. 1) GO TO 200 DO 150 N = 1, NV1 IF (.NOT. OVP(N)) GO TO 150 DO 130 J = 1, 3 S = 0.0 DO 120 K = 1, 3 S1 = 0.0 DO 110 M = 1, 3 S1 = S1 + O(1,J,M)*OV(M,K,N) 110 CONTINUE OS(J,K) = S1 S = S + OV(K,J,N)*X0(1,K) 120 CONTINUE X0V(J,N) = X0V(J,N) + S 130 CONTINUE DO 140 J = 1, 3 DO 140 J1 = 1, 3 OV(J,J1,N) = OS(J,J1) 140 CONTINUE 150 CONTINUE C C DERIVATIVE OF INDIVIDUAL COORDINATE TRANSFORM TIMES C ACCUMULATED COORDINATE TRANSFORM C 200 NVTYPE = NV(TYPE) IF (NVTYPE .EQ. 0) GO TO 300 DO 280 JV = 1, NVTYPE NV2 = VARST(JV) DPARM = 1.0 IF (NV2 .EQ. 0) GO TO 280 IF (NV2 .LT. 0) DPARM = - 1.0 NVP = 1 IF (NV2 .EQ. 99) THEN NVP = NPVAR IF (JV .LE. NELMS(TYPE)) THEN IADR = I + IPTOJ(JV) 201 IF (TIE(IADR) .EQ. 100) THEN IADR = IDATA(IADR) GO TO 201 ENDIF ELSE IF (TYPE .EQ. 2) THEN IADR = IBVARY ELSE IADR = 0 ENDIF ENDIF DO 275 JP = 1, NVP IF (TYPE .EQ. 13) THEN NV2 = JV IF (.NOT. CVP(NV2)) GO TO 280 GO TO 205 ENDIF C IF (NVP .EQ. NPVAR) THEN NV2 = JP DPARM = DATA(IADR + JP) IF (DPARM .EQ. 0.0) GO TO 275 ENDIF C 205 NV1 = MAX0(NV1,IABS(NV2)) CALL SQUIRM IF (FLUSHL) GO TO 500 IF (NV2 .LT. 0) THEN NV2 = IABS(NV2) DO 208 J = 1, 3 XIV(J) = - XIV(J) DO 208 K = 1, 3 OIV(J,K) = - OIV(J,K) 208 CONTINUE ENDIF C IF (.NOT. OMTX) GO TO 220 DO 213 J = 1, 3 S = 0.0 DO 212 K = 1, 3 S1 = 0.0 DO 211 M = 1, 3 S1 = S1 + OIV(J,M)*O(4,M,K) 211 CONTINUE OS(J,K) = S1 S = S + O(4,K,J)*XIV(K) 212 CONTINUE XS(J) = S 213 CONTINUE GO TO 240 C 220 DO 225 J = 1, 3 225 XS(J) = XIV(J) DO 228 J = 1, 3 DO 228 K = 1, 3 228 OS(J,K) = OIV(J,K) GO TO 260 C 240 IF (OVP(NV2)) GO TO 250 DO 245 J = 1, 3 X0V(J,NV2) = XS(J) DO 245 K = 1, 3 OV(J,K,NV2) = OS(J,K) 245 CONTINUE GO TO 270 C 250 DO 255 J = 1, 3 X0V(J,NV2) = X0V(J,NV2) + XS(J) DO 255 K = 1, 3 OV(J,K,NV2) = OV(J,K,NV2) + OS(J,K) 255 CONTINUE GO TO 270 C 260 DO 265 J = 1, 3 265 X0V(J,NV2) = XS(J) DO 268 J = 1, 3 DO 268 K = 1, 3 268 OV(J,K,NV2) = OS(J,K) C 270 OVP(NV2) = .TRUE. 275 CONTINUE 280 CONTINUE C C ACCUMULATED FLOOR COORDINATES C 300 CALL ADVANC(4) C 500 CONTINUE RETURN END SUBROUTINE HARDEN C C COORDINATE TRANSFORMATIONS FOR MISALIGNMENTS OF BEAM SECTIONS C (TO BE STORED WITH ALIGN ELEMENT) C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA0A.CIN' INCLUDE 'DATA0B.CIN' INCLUDE 'DATA1A.CIN' INCLUDE 'DATA1C.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM0B.CIN' INCLUDE 'ELM0C.CIN' INCLUDE 'ELM0D.CIN' INCLUDE 'ELM0F.CIN' INCLUDE 'ELM1A.CIN' INCLUDE 'ELM4A.CIN' INCLUDE 'ELM8A.CIN' INCLUDE 'ELM8G.CIN' INCLUDE 'ELM9.CIN' INCLUDE 'ELM10E.CIN' INCLUDE 'ELM13B.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'ELM15B.CIN' INCLUDE 'ELM16B.CIN' INCLUDE 'ELM23.CIN' INCLUDE 'ELM24A.CIN' INCLUDE 'ELM31A.CIN' INCLUDE 'FLUSHC.CIN' INCLUDE 'INDPAR.CIN' INCLUDE 'OC.CIN' INCLUDE 'OCP.CIN' INCLUDE 'RCP.CIN' INCLUDE 'R2P.CIN' C C LOCAL VARIABLES C INTEGER IADR, IDATA, IRI, J, K, NMUP, NSLIT REAL DATAR EXTERNAL DATAR, IDATA C----------------------------------------------------------------------- C C RESET MATRICES C NUM = 1 NDIF = 1 LPRF = .FALSE. ATWORK = NUSE .EQ. 0 MKG = .FALSE. CALL UNITS(0) CALL RESET(2) CALL RESET(3) CALL RESET(4) C C BRANCH ON ELEMENT TYPE C 1 I = ISTOR(NUM) TYPE = IDATA(I) TYPEC = TYPE IF (TYPE .LE. 0 .OR. TYPE .GE. 50) GO TO 5010 CALL SKETCH(NUM) CALL DEPICT CALL DEPIC2 IF (.NOT. ATWE) GO TO 5010 IF (DOPARS .AND. TYPE .NE. 23 .AND. TYPE .NE. 30 .AND. 1 TYPE .NE. 9 .AND. TYPE .NE. 24 .AND. TYPE .NE. 31) GO TO 5010 IF (TYPE .EQ. 1) GO TO 100 IF (TYPE .EQ. 3) GO TO 300 IF (TYPE .EQ. 4) GO TO 400 IF (TYPE .EQ. 5) GO TO 500 IF (TYPE .EQ. 6) GO TO 600 IF (TYPE .EQ. 8) GO TO 800 IF (TYPE .EQ. 9) GO TO 900 IF (TYPE .EQ. 11) GO TO 1100 IF (TYPE .EQ. 13) THEN CDB = INT(DATA(I+1)) IF (CDB .EQ. 9) GO TO 1300 ENDIF IF (TYPE .EQ. 15) GO TO 1500 IF (TYPE .EQ. 18) GO TO 1800 IF (TYPE .EQ. 19) GO TO 1900 IF (TYPE .EQ. 20) GO TO 2000 IF (TYPE .EQ. 23) GO TO 2300 IF (TYPE .EQ. 24) GO TO 2400 IF (TYPE .EQ. 25) GO TO 2500 IF (TYPE .EQ. 28 .OR. TYPE .EQ. 29) GO TO 2800 IF (TYPE .EQ. 31) GO TO 3100 IF (TYPE .EQ. 34) GO TO 3400 IF (TYPE .EQ. 35 .OR. TYPE .EQ. 36) GO TO 3500 IF (TYPE .EQ. 37) GO TO 3700 IF (TYPE .EQ. 43) THEN IF (.NOT. (ALIGN .OR. LAY)) GO TO 5010 IF (.NOT. (RCP .OR. R2P)) GO TO 5010 GO TO 4300 ENDIF GO TO 5010 C C 1. -- BEAM C 100 IRI = IPTOJ(7) IF (IRI .NE. 0) THEN RI = DATA(I + IRI)*UNITI(11) IF (.NOT. LPRF) PREF = RI ENDIF GO TO 5000 C C 3. -- DRIFT SPACE C 300 IADR = I + 1 L = DATAR(IADR)*UNITI(8) GO TO 5000 C C 4. -- BENDING MAGNET C 400 CALL BGET(I) L = LBEND GO TO 5000 C C 5. -- QUADRUPOLE C 500 L = DATAR(I+1)*UNITI(8) GO TO 5000 C C 6. -- UPDATE C 600 NSLIT = INT(DATA(I+1)) IF (NSLIT .NE. 0) GO TO 5000 NMUP = INT(DATA(I+2)) IF (NMUP .EQ. 1) THEN RCP = .FALSE. R2P = .FALSE. OCP(2) = .FALSE. ENDIF IF (NMUP .EQ. 2) THEN RCP = RCP .OR. R2P R2P = .FALSE. OCP(3) = .FALSE. ENDIF GO TO 5010 C C 8. -- STORE COORDINATE TRANSFORMATION IN MISALIGNMENT ELEMENT C 800 TYT = INT(DATA(I+7)) RORC = MOD(TYT,10) IR = RORC + 1 IF (RORC .GE. 3) GO TO 5010 I = I + 9 DO 810 J = 1, 3 DATA(I+J) = X0(IR,J) 810 CONTINUE C I = I + 3 DO 820 J = 1, 3 DO 820 K = 1, 3 I = I + 1 DATA(I) = O(IR,J,K) 820 CONTINUE GO TO 5010 C C 9. -- REPEAT C 900 NREP = IDATA(I+1) CALL REPEAT IF (FLUSHL) GO TO 5100 GO TO 5010 C C 11. -- ACCELERATOR C 1100 L = DATAR(I+1)*UNITI(8) GO TO 5000 C C 13. -- REALIGNMENT OF BEAM LINE C 1300 GO TO 5000 C C 15. -- UNITS C 1500 J = INT(DATA(I+1)) IF (J .EQ. 20) GO TO 1510 XNAME = LABEL(NUM)(1:4) USIZE = DATA(I+2) CALL UNITS(J) GO TO 5000 C 1510 MPMAD = .TRUE. GO TO 5000 C C 18. -- SEXTUPOLE C 1800 L = DATAR(I+1)*UNITI(8) GO TO 5000 C C 19. -- SOLENOID C 1900 L = DATAR(I+1)*UNITI(8) GO TO 5000 C C 20. -- COORDINATE ROTATION C 2000 GO TO 5000 C C 23. -- ALGEBRAIC OPERATION C 2300 K1REG = IDATA(I+1) K1TIE = TIE(I+1) K2REG = IDATA(I+2) K2TIE = TIE(I+2) IOPN = IDATA(I+3) JREG = IDATA(I+4) JTIE = TIE(I+4) CALL COMBIN GO TO 5010 C C 24. -- DEFINE SECTION C 2400 JDEF = IDATA(I+1) IF (JDEF .EQ. 3 .OR. JDEF .EQ. 4) THEN NADDEF(1) = IDATA(I+2) NADDEF(2) = IDATA(I+3) ENDIF CALL DEFINE IF (FLUSHL) GO TO 5100 GO TO 5010 C C 25. -- OCTUPOLE C 2500 L = DATAR(I+1)*UNITI(8) GO TO 5000 C C 28. -- RBEND OR 29. -- SBEND C 2800 TYPEC = 4 CALL RBGET L = DATAR(I+1)*UNITI(8) GO TO 5000 C C 31. -- POSITION MARKER C 3100 NMARKS = IDATA(I+1) DRC = .FALSE. CALL AGENDA(1) GO TO 5010 C C 34. -- PLASMA LENS C 3400 L = DATAR(I+1)*UNITI(8) GO TO 5000 C C 35. -- HKICK OR 36. -- VKICK C 3500 L = DATAR(I+1)*UNITI(8) GO TO 5000 C C 37. -- ALIGNMENT MARKER C 3700 NSLIT = INT(DATA(I+1)) IF (NSLIT .NE. 0) GO TO 5000 NMUP = INT(DATA(I+2)) IF (NMUP .EQ. 1) OCP(2) = .FALSE. IF (NMUP .EQ. 2) OCP(3) = .FALSE. GO TO 5010 C C 43. -- COORDINATE SYSTEM SHIFT C 4300 GO TO 5000 C C COORDINATE ADVANCES FOR INDIVIDUAL ELEMENTS C 5000 CALL OSET CALL ADVANC(2) CALL ADVANC(3) R2P = .TRUE. IF (NMISRB .NE. 0) CALL AGENDR(1) C C ADVANCE TO NEXT ELEMENT C 5010 IF (MKG .AND. NUM .EQ. NMARKE) CALL AGENDA(2) IF (ALGR .AND. NUM .EQ. NMISRE) CALL AGENDR(2) NUM = NUM + NDIF IF (.NOT. MKG .AND. NUSE .NE. 0 .AND. NUM .GT. NUSE) GO TO 5100 IF (NUM .LE. NEL) GO TO 1 5100 RETURN END SUBROUTINE HUNT2 C C SEARCHES FOR AN EXIT FRINGE FIELD FOR A BENDING MAGNET C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA1A.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM2B.CIN' INCLUDE 'ELM2D.CIN' INCLUDE 'ELM8H.CIN' C C LOCAL VARIABLES C INTEGER IDATA, II, J, K, NUMA, TYPEN LOGICAL CKK EXTERNAL IDATA C-------------------------------------------------------------- C C CHECK FOR FOLLOWING FRINGE FIELD SPECIFICATION C DMC = .TRUE. FFOUT = .FALSE. J = NUM DO 10 K = 1, 5 J = J + NDIF IF (J .LE. 0) GO TO 50 IF (J .GT. NEL) GO TO 50 II = ISTOR(J) TYPEN = IDATA(II) IF (TYPEN .EQ. 2) GO TO 30 IF (TYPEN .NE. 13 .AND. TYPEN .NE. 23 .AND. TYPEN .NE. 30) 1 GO TO 50 10 CONTINUE C C DETERMINE IF IT PERTAINS TO THIS MAGNET C 30 NUMA = NUM NUM = J NUM2 = NUM CALL CHEK(CKK) DMC = BEFORE .OR. .NOT. CKK FFOUT = .NOT. BEFORE NUM = NUMA 50 RETURN END SUBROUTINE IDIOT C C PRINT INSTRUCTIONS WHICH AFFECT FITTING C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'COCOM.CIN' INCLUDE 'CONSTS.CIN' INCLUDE 'COP.CIN' INCLUDE 'ELM1D.CIN' INCLUDE 'ELM7B.CIN' INCLUDE 'ELM8A.CIN' INCLUDE 'ELM13A.CIN' INCLUDE 'ELM13B.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'ELM20.CIN' INCLUDE 'OC.CIN' INCLUDE 'R.CIN' INCLUDE 'YAW.CIN' C C LOCAL VARIABLES C C C---------------------------------------------------------------- C IF (CDB .EQ. 7) GO TO 70 IF (CDB .EQ. 9) GO TO 90 IF (CDB .EQ. 11) GO TO 110 IF (CDB .EQ. 12) GO TO 120 IF (CDB .EQ. 13) GO TO 130 IF (CDB .EQ. 18) GO TO 180 IF (CDB .EQ. 20) GO TO 200 IF (CDB .EQ. 21) GO TO 210 IF (CDB .EQ. 22) GO TO 220 IF (CDB .GE. 40 .AND. CDB .LE. 43) GO TO 400 IF (CDB .EQ. 47) GO TO 470 IF (CDB .EQ. 48) GO TO 480 IF (CDB .EQ. 191) GO TO 1910 GO TO 2000 C C ACCELERATOR NOTATION FOR BEAM MATRIX C 70 ACCEL = .TRUE. NORD1 = NORDX NORD2 = 1 NORD3 = 1 GO TO 2000 C C SHIFT REMAINING BEAM LINE TO CENTER BEAM C 90 R1P = .FALSE. IF (.NOT. (ALIGN .OR. LAY)) GO TO 2000 CALL OSET IF (ALIGN) THEN CALL ADVANC(2) CALL ADVANC(3) ENDIF SOFA = .FALSE. DO 91 J = 1, 6 CO(J) = CO(J) - COF(J) IF (NORD1 .GT. 1 .AND. CO(J) .NE. 0.0) SOFA = .TRUE. 91 CONTINUE RECENT = .FALSE. GO TO 2000 C C LEVEL FLOOR COORDINATES C 110 IF (O(4,2,2) .NE. 0.0) ROLL = ATAN(O(4,1,2)/O(4,2,2)) IF (O(4,2,2) .EQ. 0.0 .AND. O(4,1,2) .GT. 0.0) ROLL = 0.5*PI IF (O(4,2,2) .EQ. 0.0 .AND. O(4,1,2) .LT. 0.0) ROLL = - 0.5*PI IF (O(4,2,2) .LT. 0.0) THEN SHIFT = SIGN(PI,O(4,1,2)) ROLL = ROLL + SHIFT ENDIF IF (REFER) ROLL = ROLL + TOTROT CSR = COS(ROLL) SNR = SIN(ROLL) R(4,4) = CSR R(3,3) = CSR R(2,2) = CSR R(1,1) = CSR R(2,4) = - SNR R(1,3) = - SNR R(4,2) = SNR R(3,1) = SNR GO TO 2000 C C FLOOR COORDINATES C 120 LAY = .TRUE. GO TO 2000 C C REFER TRANSFER MATRIX TO ORIGINAL COORDINATE SYSTEM C 130 REFER = .TRUE. GO TO 2000 C C SUPPRESS PRINTING OF CORRECTIONS AND COVARIANCE TABLE C 180 ONLY = .TRUE. GO TO 2000 C C MISALIGNMENT PIVOT C 200 TMK = 1 MCFO = 100*TMK + MOD(MCFO,100) GO TO 2000 C C EFFECT OF MISALIGNMENT OF FOCUSING ONLY C 210 MCFO = 1 + 10*(MCFO/10) GO TO 2000 C C MISALIGNMENT ABOUT CHORD OF BEND MAGNET C 220 MCFO = 10 + 100*(MCFO/100) + MOD(MCFO,10) GO TO 2000 C C POLE FACE ROTATION ANGLE SPECIFICATION C 400 NPFR = CDB - 40 GO TO 2000 C C BENDING MAGNET DESCRIBED BY LENGTH AND FIELD C 470 ANIN = .FALSE. GO TO 2000 C C BENDING MAGNET DESCRIBED BY LENGTH AND ANGLE C 480 ANIN = .TRUE. GO TO 2000 C C FLOOR COORDINATES WITH EXTRA PRECISION C 1910 LAY191 = .TRUE. 2000 RETURN END INTEGER FUNCTION INDEX2(I2,I3) C C FINDS INDEX IN SECOND-ORDER TRANSFER MATRIX C INCLUDE 'INDX.CIN' C----------------------------------------------------------------------------- IF (I2 .LE. I3) THEN IB = I2 IC = I3 ELSE IB = I3 IC = I2 ENDIF INDEX2 = INDX2(IC) + IB RETURN END INTEGER FUNCTION INDEX3(I2,I3,I4) C C FINDS INDEX IN THIRD-ORDER TRANSFER MATRIX C INCLUDE 'INDX.CIN' DIMENSION ICNT(6), ITOT(3) EQUIVALENCE (ITOT(1),IA), (ITOT(2),IB), (ITOT(3),IC) C DO 10 J = 1, 6 ICNT(J) = 0 10 CONTINUE ICNT(I2) = ICNT(I2) + 1 ICNT(I3) = ICNT(I3) + 1 ICNT(I4) = ICNT(I4) + 1 C K = 1 DO 30 J = 1, 3 20 IF (ICNT(K) .EQ. 0) THEN K = K + 1 GO TO 20 ENDIF ITOT(J) = K ICNT(K) = ICNT(K) - 1 30 CONTINUE INDEX3 = INDX3(IC) + INDX2(IB) + IA RETURN END SUBROUTINE INIT1 C C REINITIALIZATION WHEN NEW BEAM MATRIX IS ENCOUNTERED C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'COP.CIN' INCLUDE 'ELM1A.CIN' INCLUDE 'ELM1C.CIN' INCLUDE 'ELM1D.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM20.CIN' INCLUDE 'SVP.CIN' C C LOCAL VARIABLES C INTEGER IR2P C C--------------------------------------------------------------- IF (NV1 .GE. 1) THEN DO 100 IR2P = 1, NV1, 1 SVP(IR2P) = .FALSE. 100 CONTINUE ENDIF LBEAM = .TRUE. RECENT = .FALSE. SOFA = .FALSE. PSIX = 0.0 PSIY = 0.0 TOTROT = 0.0 TOTRA = 0.0 RETURN END SUBROUTINE INITB C C DOESN'T DO MUCH OF ANYTHING C RETURN END SUBROUTINE INITL C C INITIALIZES LIMITS ON VARIED PARAMETERS C C LIST OF COMMON BLOCKS C INCLUDE 'ELM39B.CIN' INCLUDE 'ELM39D.CIN' C C---------------------------------------------------- DO 10 J = 1, 4 10 ALIM1(J) = ALM01(J) DO 20 J = 1, 4 20 ALIM2(J) = ALM02(J) DO 30 J = 1, 4 30 ALIM3(J) = ALM03(J) DO 40 J = 1, 4 DO 40 K = 1, 6 40 ALIM4(J,K) = ALM04(J,K) DO 50 J = 1, 4 DO 50 K = 1, 5 50 ALIM5(J,K) = ALM05(J,K) DO 120 J = 1, 4 DO 120 K = 1, 15 120 ALIM12(J,K) = ALM012(J,K) DO 180 J = 1, 4 DO 180 K = 1, 4 180 ALIM18(J,K) = ALM018(J,K) DO 190 J = 1, 4 DO 190 K = 1, 3 190 ALIM19(J,K) = ALM019(J,K) DO 200 J = 1, 4 200 ALIM20(J) = ALM020(J) DO 250 J = 1, 4 DO 250 K = 1, 4 250 ALIM25(J,K) = ALM025(J,K) DO 280 J = 1, 4 DO 280 K = 1, 13 280 ALIM28(J,K) = ALM028(J,K) DO 340 J = 1, 4 DO 340 K = 1, 5 340 ALIM34(J,K) = ALM034(J,K) DO 350 J = 1, 4 DO 350 K = 1, 3 350 ALIM35(J,K) = ALM035(J,K) RETURN END SUBROUTINE INITZE C C INITIAL VALUES OF MATRICES AND LOGICAL VARIABLES C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'BROAD.CIN' INCLUDE 'COCOM.CIN' INCLUDE 'COP.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0B.CIN' INCLUDE 'ELM0E.CIN' INCLUDE 'ELM0F.CIN' INCLUDE 'ELM1A.CIN' INCLUDE 'ELM1C.CIN' INCLUDE 'ELM1D.CIN' INCLUDE 'ELM1E.CIN' INCLUDE 'ELM2B.CIN' INCLUDE 'ELM2D.CIN' INCLUDE 'ELM6.CIN' INCLUDE 'ELM8A.CIN' INCLUDE 'ELM8D.CIN' INCLUDE 'ELM8H.CIN' INCLUDE 'ELM8L.CIN' INCLUDE 'ELM8M.CIN' INCLUDE 'ELM9.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM10E.CIN' INCLUDE 'ELM13A.CIN' INCLUDE 'ELM13B.CIN' INCLUDE 'ELM13C.CIN' INCLUDE 'ELM14A.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'ELM16A.CIN' INCLUDE 'ELM16B.CIN' INCLUDE 'ELM16C.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'ELM17B.CIN' INCLUDE 'ELM20.CIN' INCLUDE 'ELM22A.CIN' INCLUDE 'ELM24B.CIN' INCLUDE 'ELM26B.CIN' INCLUDE 'ELM31A.CIN' INCLUDE 'ELM38A.CIN' INCLUDE 'ELM39A.CIN' INCLUDE 'ETAP.CIN' INCLUDE 'LXRAN.CIN' INCLUDE 'NHORN.CIN' INCLUDE 'OCP.CIN' INCLUDE 'RC.CIN' INCLUDE 'RCP.CIN' INCLUDE 'RC2.CIN' INCLUDE 'R0P.CIN' INCLUDE 'R2P.CIN' INCLUDE 'R3P.CIN' INCLUDE 'STEPT1.CIN' INCLUDE 'SVP.CIN' INCLUDE 'TC.CIN' INCLUDE 'TC2.CIN' INCLUDE 'UC.CIN' INCLUDE 'UC2.CIN' C C LOCAL VARIABLES C INTEGER J, K, N C C------------------------------------------------------------------------ NUM = 1 IF (NV3 .GE. 1) THEN DO 5 N = 1, NV3, 1 LCV(N) = 0.0 RVP(N) = .FALSE. R2VP(N)= .FALSE. SVP(N) = .FALSE. CVP(N) = .FALSE. OVP(N) = .FALSE. EVP(N) = .FALSE. 5 CONTINUE ENDIF C DO 11 J = 1, 3 XR(J) = 0.0 XT(J) = 0.0 X0SV(J) = 0.0 11 CONTINUE DO 12 J = 1, 3 DO 12 K = 1, 3 OR(J,K) = 0.0 OT(J,K) = 0.0 OSV(J,K) = 0.0 12 CONTINUE DO 13 J = 1, 3 13 IVMS(J) = 0 NC = 0 NV1 = 0 NDIF = 1 NM = 0 LC = 0.0 TOTANG = 0.0 TOTROT = 0.0 TOTRA = 0.0 R0P = .FALSE. RCP = .FALSE. R2P = .FALSE. R3P = .FALSE. RI = 0.0 DO 14 J = 1, 6 14 CO(J) = 0.0 LBEAM = .FALSE. LTWISS = .FALSE. SOFA = .FALSE. RECENT = .FALSE. PSIXO = 0.0 PSIYO = 0.0 DOPH = .TRUE. RAY = .FALSE. DO 16 N = 1, 10 LNMT(N) = .FALSE. 16 R2PM(N) = .FALSE. DMC = .FALSE. FFIN = .FALSE. FFOUT = .FALSE. DCOV = .FALSE. CAP = .FALSE. IR = 1 RORC = 0 MCFO = 0 ALO(1) = .FALSE. ALO(2) = .FALSE. BEFORE = .FALSE. NOR = .FALSE. TWP = .FALSE. CPS = .FALSE. CPR = .TRUE. RAT = .FALSE. R1P = .FALSE. LAY = .FALSE. SUPP = .FALSE. ONLY = .FALSE. TERSE = .FALSE. LCPR = .TRUE. REFER = .FALSE. ACCEL = .FALSE. UNRO = .FALSE. ELPR = .TRUE. ANIN = .FALSE. NARROW = .FALSE. PBP = .FALSE. PRON = .NOT. LSTEP .OR. BROAD PMK = .FALSE. LAY191 = .FALSE. WARN20 = .TRUE. NPFR = 0 TYP1 = 0 MPMAD = .FALSE. FOTILT = 0.0 SM = 0.0 PREF = 0.0 LPRF = .FALSE. NORD1 = 1 NORD2 = 1 NORD3 = 1 NORDX = 1 LINEAR = .FALSE. SEXLIM = .FALSE. DO 20 N = 1, 9 20 VARS(N) = 0 DO 30 N = 1, NPVAR 30 LREG(N) = .FALSE. IP = 0 NDLEV = 0 NULEV = 0 ATWORK = NUSE .EQ. 0 DO 41 J = 1, 4 41 PRAN2(J) = 0.0 PRAN3 = 0.0 DO 42 J = 1, 17 42 PRAN4(J) = 0.0 DO 43 J = 1, 5 43 PRAN5(J) = 0.0 DO 44 J = 1, 6 44 PRAN7(J) = 0.0 DO 45 J = 1, 4 45 PRAN11(J) = 0.0 DO 47 J = 1, 4 47 PRAN18(J) = 0.0 DO 48 J = 1, 3 48 PRAN19(J) = 0.0 PRAN20 = 0.0 DO 49 J = 1, 4 49 PRAN25(J) = 0.0 DO 50 J = 1, 23 50 PRAN28(J) = 0.0 DO 51 J = 1, 5 51 PRAN34(J) = 0.0 DO 52 J = 1, 6 52 PRAN43(J) = 0.0 BDBI = 0.0 APBI(1) = 0.0 APBI(2) = 0.0 LAYKI = 0.0 LAYLI = 0.5 LAYXI = 0.0 RAB1I = 0.0 RAB2I = 0.0 RMPSI = 0.0 VRNI = 0.0 NPNI = 0.0 BDBPI = 0.0 RNMSI = 0.0 GAMI = 0.0 MKG = .FALSE. DRC = .FALSE. PLOT = .FALSE. LPLOT = .FALSE. PLNOW = .FALSE. LXRAN = .FALSE. CALL RESET(2) CALL RESET(3) CALL RESET(4) XINIT = 0.0 YINIT = 0.0 ZINIT = 0.0 THINIT = 0.0 PHINIT = 0.0 NHORN = 0 DO 61 J = 1, 6 DO 61 K = 1, 6 RC(J,K) = 0.0 RC2(J,K) = 0.0 61 CONTINUE DO 62 J = 1, 6 RC(J,J) = 1.0 RC2(J,J) = 1.0 62 CONTINUE DO 63 J = 1, 105 TCL(J) = 0.0 TC2L(J) = 0.0 63 CONTINUE DO 64 J = 1, 280 UCL(J) = 0.0 UC2L(J) = 0.0 64 CONTINUE CALL UNITS(0) LIMTD = .FALSE. CALL RANST CALL INITB CALL INITL RETURN END SUBROUTINE INQ C C MATRIX INVERSION TO SOLVE NORMAL EQUATIONS FOR FITTING C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM10D.CIN' C C LOCAL VARIABLES C INTEGER ROW(NPVAR+1), COL(NPVAR+1) REAL CAT(NPVAR+1) C C------------------------------------------------------------------------ C C CALCULATE SCALING FACTOR FOR NORMAL MATRIX C N = NV1 + 1 SCALE(1) = 1.0 DO 135 J = 2, N SCALE(J) = 0.0 IF (CA(J,J) .NE. 0.0) SCALE(J) = 1.0/SQRT(ABS(CA(J,J))) 135 CONTINUE C C NORMALIZE ROWS AND COLUMNS C DO 15 I = 2, N DO 15 J = 1, N CA(I,J) = CA(I,J)*SCALE(I)*SCALE(J) 15 CONTINUE CM0 = 1.0E-5 C C ADD MARQUARDT-LEVENBERG PARAMETER C IF (NMAR .GT. 0) THEN PMARQ = PARQ*(2.0**NMAR - 1.0) IF (PMARQ .GT. 0.0) THEN DO 18 J = 2, N 18 CA(J,J) = CA(J,J) + PMARQ ENDIF ELSE PMARQ = 0.0 ENDIF C C INVERT SIGNIFICANT PORTION OF MATRIX C 20 DO 100 KK = 2, N K = KK C C FIND ROW WITH LARGEST REMAINING DIFFERENCE C CM = -1. DO 25 I = K, N CM1 = ABS(CA(I,1)) IF (CM1 .GT. CM) THEN CM = CM1 KI = I ENDIF 25 CONTINUE C C FIND COLUMN WITH LARGEST ELEMENT IN PREVIOUSLY DETERMINED ROW C CM = -1. DO 30 J = K, N I = KI CM1 = ABS(CA(I,J)) IF (CM1 .GT. CM) THEN CM = CM1 KJ = J ENDIF 30 CONTINUE C C IS FOUND ELEMENT LARGE ENOUGH C IF (CM .GE. CM0) GO TO 60 C C IF NOT FIND LARGEST REMAINING ELEMENT IN MATRIX C CM = -1. DO 40 I = K, N DO 40 J = K, N CM1 = ABS(CA(I,J)) IF (CM1 .GT. CM) THEN CM = CM1 KI = I KJ = J ENDIF 40 CONTINUE C C IS FOUND ELEMENT LARGE ENOUGH C IF (CM .GE. CM0) GO TO 60 C C IF NOT, ZERO REMAINING MATRIX C 45 KP = K K = K - 1 DO 50 I = KP, N DO 50 J = 1, N CA(I,J) = 0.0 CA(J,I) = 0.0 50 CONTINUE GO TO 110 C C SWITCH AND RENORMALIZE ROWS C 60 ROW(K) = KI COL(K) = KJ CK = 1./CA(KI,KJ) CA(KI,KJ) = - CA(KI,KJ) DO 70 J = 1, N, 1 CAT(J) = CA(KI,J) CA(KI,J) = CA(K,J) CA(K,J) = CK*CAT(J) 70 CONTINUE CAT(KJ) = CAT(K) DO 80 I = 2, N CK1 = - CK * CA(I,KJ) CA(I,KJ) = CA(I,K) CA(I,K) = CK1 IF (I .NE. K) THEN DO 75 J = 1, N IF (J .NE. K) CA(I,J) = CA(I,J) + CK1*CAT(J) 75 CONTINUE ENDIF 80 CONTINUE 100 CONTINUE C C RELOCATE ROWS AND COLUMNS C 110 IF (K .LT. 2) GO TO 150 KI = COL(K) DO 120 J = 1, N, 1 CK = CA(K,J) CA(K,J) = CA(KI,J) CA(KI,J) = CK 120 CONTINUE KJ = ROW(K) DO 130 I = 2, N CK = CA(I,K) CA(I,K) = CA(I,KJ) CA(I,KJ) = CK 130 CONTINUE K = K - 1 GO TO 110 150 CONTINUE C C CALCULATE MARQUARDT-LEVENBERG PARAMETER C IF (PMARQ .NE. 0.0) GO TO 160 DO 154 I = 2, N SUM = 0.0 DO 152 J = 2, N SUM = SUM + CA(I,J)*CA(J,1) 152 CONTINUE CAT(I) = SUM 154 CONTINUE DNUM = 0.0 DEN = 0.0 DO 155 J = 2, N DNUM = DNUM + CA(J,1)*CA(J,1) DEN = DEN + CAT(J)*CAT(J) 155 CONTINUE IF (DEN .NE. 0.0) THEN PARQ = SQRT(DNUM/DEN) ELSE PARQ = 0.0 ENDIF C C RENORMALIZE INVERTED MATRIX C 160 DO 170 I = 2, N DO 170 J = 1, N 170 CA(I,J) = CA(I,J)*SCALE(I)*SCALE(J) C RETURN END SUBROUTINE IO C C IO -- IN GREEK MYTHOLOGY, A MAIDEN LOVED BY ZEUS AND CHANGED INTO A C HEIFER BY JEALOUS HERA OR, IN SOME TALES, BY ZEUS, TO PROTECT HER: C SHE WAS WATCHED BY HUNDRED-EYED ARGUS AND WAS DRIVEN TO EGYPT, C WHERE SHE REGAINED HER NATURAL FORM. C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'COP.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM1A.CIN' INCLUDE 'ELM6.CIN' INCLUDE 'ELM8H.CIN' INCLUDE 'ELM13A.CIN' INCLUDE 'ELM13B.CIN' INCLUDE 'ELM13C.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'ELM31A.CIN' INCLUDE 'ELM31B.CIN' INCLUDE 'IOUNIT.CIN' INCLUDE 'RCP.CIN' INCLUDE 'R0P.CIN' INCLUDE 'R2P.CIN' INCLUDE 'STEPT1.CIN' C C LOCAL VARIABLES C INTEGER J C C----------------------------------------------------------------------- IF (CDB .EQ. -4) GO TO 40 IF (CDB .GT. 11) GO TO 1 GO TO (10,20,30,40,50,60,70,80,90,100,110), CDB 1 IF (CDB .EQ. 14) GO TO 140 IF (CDB .EQ. 15) GO TO 150 IF (CDB .EQ. 16) GO TO 160 IF (CDB .EQ. 17) GO TO 170 IF (CDB .EQ. 18) GO TO 180 IF (CDB .EQ. 19) GO TO 190 IF (CDB .EQ. 24) GO TO 40 IF (CDB .EQ. 26) GO TO 260 IF (CDB .EQ. 27) GO TO 270 IF (CDB .EQ. 28) GO TO 280 IF (CDB .GE. 29 .AND. CDB .LE. 36) GO TO 300 IF (CDB .EQ. 38) GO TO 380 IF (CDB .EQ. 39) GO TO 390 IF (CDB .EQ. 44) GO TO 440 IF (CDB .EQ. 45) GO TO 450 IF (CDB .EQ. 46) GO TO 460 IF (CDB .EQ. 49) GO TO 490 IF (CDB .EQ. 50) GO TO 500 IF (CDB .EQ. 51) GO TO 510 IF (CDB .EQ. 52) GO TO 520 IF (CDB .EQ. 53) GO TO 530 GO TO 900 C C PRINT BEAM MATRIX SIGMA C 10 IF (.NOT. PRON) GO TO 900 IF (NOR .OR. BDUN .OR. ONLY) GO TO 900 IF (.NOT. SOFA .AND. NORD3 .LT. 1) GO TO 900 IF (LSTEP) GO TO 900 IF (ACCEL) THEN CALL TWISS ELSE CALL QEO ENDIF GO TO 900 C C SUPPRESS BEAM MATRIX PRINT C 20 NOR = .FALSE. GO TO 900 C C PRINT BEAM MATRIX AFTER EACH ELEMENT C 30 IF (ONLY) GO TO 900 IF (ACCEL) WRITE (NOUT,1001) IF (NOR) GO TO 900 NOR = .TRUE. IF (LSTEP) GO TO 900 IF (LBEAM .AND. PRON .AND. R0P .AND. .NOT. BDUN) THEN IF (ACCEL) THEN CALL TWISS ELSE CALL QEO ENDIF ENDIF GO TO 900 C C PRINT TRANSFER MATRIX R OR R2 C 40 IF (.NOT. PRON) GO TO 900 IF ((RDUN .AND. CDB .EQ. 4) .OR. (NOR .AND. TERSE) .OR. ONLY) 1 GO TO 900 IF (.NOT. TERSE .AND. .NOT. SOFA .AND. NORD3 .LT. 1) GO TO 900 IF (LSTEP) GO TO 900 IF (RCP .OR. R2P) CALL RCOUT RDUN = .TRUE. GO TO 900 C C SUPPRESS AUTOMATIC TRANSFER MATRIX PRINT C 50 RAT = .FALSE. GO TO 900 C C PRINT TRANSFER MATRIX AFTER EACH ELEMENT C 60 IF (RAT .OR. ONLY) GO TO 900 IF (LSTEP) GO TO 900 IF (TERSE .AND. .NOT. NARROW) WRITE (NOUT,1000) 1000 FORMAT (1H ,37X,3HR11,6X,3HR12,6X,3HR21,6X,3HR22,10X,3HR33,6X, 1 3HR34,6X,3HR43,6X,3HR44,10X,3HR16,6X,3HR26) RAT = .TRUE. IF (PRON .AND. (TERSE .OR. SOFA .OR. NORD3 .GE. 1) 1 .AND. (RCP .OR. R2P) .AND. .NOT. RDUN) CALL RCOUT GO TO 900 C C ACCELERATOR PARAMETERS C 70 IF (LSTEP) GO TO 900 IF (NOR .AND. NORD3 .EQ. 1 .AND. .NOT. ONLY) WRITE (NOUT,1001) 1001 FORMAT (1H ,36X,'PSIX',6X,'PSIY',6X,'BETAX',5X,'BETAY',5X, 1 'ALPHAX',4X,'ALPHAY',4X,'ETAX',6X,'ETAY',6X,'DETAX',5X, 2 'DETAY') GO TO 900 C C PRINT MISALIGNMENT PARTIAL DERIVATIVE TABLE C 80 IF (LSTEP) GO TO 900 IF (NM .GE. 1 .AND. .NOT. ONLY) CALL WOE GO TO 900 C C PRINT FLOOR COORDINATES AFTER BEAM LINE REALIGNMENT C 90 IF (LSTEP) GO TO 100 IF (PRON .AND. LAY .AND. ELPR .AND. .NOT. ONLY) 1 CALL SURVEY GO TO 900 C C OBSERVE MAGNET APERTURES C 100 CAP = .TRUE. GO TO 900 C C LEVELLING OF COORDINATE SYSTEM C 110 NBE = .TRUE. GO TO 900 C C PRINT POSITIONS OF HORIZONTAL AND VERTICAL WAISTS C 140 IF (.NOT. PRON .OR. NORD3 .LT. 1 .OR. ONLY) GO TO 900 IF (LSTEP) GO TO 100 CALL WAIST GO TO 900 C C BEAM MATRIX WITHIN 80 COLUMNS C 150 NARROW = .TRUE. GO TO 900 C C EXTRA PRECISION FOR VARIED PARAMETERS C 160 UNRO = .TRUE. GO TO 900 C C SUPPRESS PRINTING OF PHYSICAL PARAMETERS C 170 SUPP = .TRUE. ONLY = .FALSE. GO TO 900 C C PRINT ONLY ITEMS RELATED TO FITTING C 180 ONLY = .TRUE. SUPP = .FALSE. GO TO 900 C C PRINT ABBREVIATED OUTPUT C 190 IF (ONLY) GO TO 900 TERSE = .TRUE. IF (RAT) WRITE (NOUT,1000) GO TO 900 C C TURN OFF PRINTING OF ELEMENTS C 260 ELPR = .FALSE. IF (PRON) THEN DO 261 J = 1, 3 WRITE (NOUT,1006) 261 CONTINUE 1006 FORMAT (1H ,15X,1H.) ENDIF GO TO 900 C C RESTORE PRINTING OF ELEMENTS C 270 ELPR = .TRUE. GO TO 900 C C PRINT EFFECTIVE BEND POINTS C 280 PBP = .TRUE. GO TO 900 C C PUNCH TRANSFER MATRIX ON CARDS C 300 IF (NORD3 .GE. 1 .AND. .NOT. ONLY) CALL PUNCH1 GO TO 900 C C SUPPRESS CENTROID PRINT C 380 CPS = .TRUE. CPR = .FALSE. GO TO 900 C C PRINT CENTROID WITH BEAM MATRIX C 390 CPS = .TRUE. CPR = .TRUE. GO TO 900 C C PRINT MARKERS C 440 PMK = .TRUE. GO TO 900 C C SROT WARNING WITH BETA AND ALPHA TURNED OFF C 450 WARN20 = .FALSE. GO TO 900 C C SROT WARNING WITH BETA AND ALPHA TURNED ON C 460 WARN20 = .TRUE. GO TO 900 C C SUPPRESS PRINTING OF ALL CALCULATED OUTPUT C 490 IF ((.NOT. MKG .AND. NDIF .EQ. 1) .OR. (MKG .AND. NDIFM .EQ. 1)) 1 THEN PRON = .FALSE. DO 491 J = 1, 3 WRITE (NOUT,1006) 491 CONTINUE ELSE PRON = .TRUE. ENDIF GO TO 900 C C RESTORE PRINTING OF ALL CALCULATED OUTPUT C 500 IF ((.NOT. MKG .AND. NDIF .EQ. 1) .OR. (MKG .AND. NDIFM .EQ. 1)) 1 THEN PRON = .TRUE. ELSE PRON = .FALSE. DO 501 J = 1, 3 WRITE (NOUT,1006) 501 CONTINUE ENDIF GO TO 900 C C PRINT COURANT-SNYDER PARAMETERS C 510 IF (.NOT. PRON .OR. TWP .OR. TDUN .OR. ONLY) GO TO 900 IF (.NOT. SOFA .AND. NORD3 .LT. 1) GO TO 900 IF (LSTEP) GO TO 900 CALL TWISS GO TO 900 C C SUPPRESS COURANT-SNYDER PARAMETER PRINT C 520 TWP = .FALSE. GO TO 900 C C PRINT COURANT-SNYDER PARAMETERS AFTER EACH ELEMENT C 530 IF (ONLY) GO TO 900 WRITE (NOUT,1001) IF (TWP) GO TO 900 TWP = .TRUE. IF (LSTEP) GO TO 900 IF (PRON .AND. R0P .AND. .NOT. TDUN) CALL TWISS GO TO 900 C 900 RETURN END SUBROUTINE JOSTLE(M) C C CALCULATES CONTRIBUTION OF FIXED MISALIGNMENT TO MISALIGNMENT C TABLE C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM2B.CIN' INCLUDE 'ELM7B.CIN' INCLUDE 'ELM8H.CIN' INCLUDE 'ELM8M.CIN' INCLUDE 'ELM8J.CIN' INCLUDE 'R.CIN' INCLUDE 'RC2.CIN' INCLUDE 'R2P.CIN' INCLUDE 'SI.CIN' C C LOCAL VARIABLES C INTEGER M REAL FOOD(6), WORK(6,6) C C--------------------------------------------------------------------- IF (.NOT. BEFORE) GO TO 100 C C MISALIGNMENT CENTROID C DO 20 J = 1, 6 COM(J,M,NM) = COD(J) 20 CONTINUE C C MISALIGNMENT TRANSFER MATRIX C IF (R2PM(NM)) GO TO 70 IF (R2P) GO TO 30 L1L2 = 0 DO 25 L2 = 1, 6 DO 25 L1 = 1, 6 L1L2 = L1L2 + 1 RC2M(L1L2,M,NM) = R(L1,L2) 25 CONTINUE GO TO 50 C 30 DO 40 L1 = 1, 6 DO 40 L2 = 1, 6 S = 0.0 DO 35 L3 = 1, 6 S = S + R(L1,L3)*RC2(L3,L2) 35 CONTINUE WORK(L1,L2) = S 40 CONTINUE C L1L2 = 0 DO 45 L2 = 1, 6 DO 45 L1 = 1, 6 L1L2 = L1L2 + 1 RC2M(L1L2,M,NM) = WORK(L1,L2) 45 CONTINUE C 50 L1L2 = 0 DO 60 L1 = 1, 6 DO 60 L2 = 1, 6 L1L2 = L1L2 + 1 SIM(L1L2,M,NM) = SI(L1,L2) 60 CONTINUE C GO TO 200 C 70 DO 80 L1 = 1, 6 L3L2 = 0 DO 80 L2 = 1, 6 S = 0.0 DO 75 L3 = 1, 6 L3L2 = L3L2 + 1 S = S + R(L1,L3)*RC2M(L3L2,M,NM) 75 CONTINUE WORK(L1,L2) = S 80 CONTINUE C L1L2 = 0 DO 90 L2 = 1, 6 DO 90 L1 = 1, 6 L1L2 = L1L2 + 1 RC2M(L1L2,M,NM) = WORK(L1,L2) 90 CONTINUE GO TO 200 C C MISALIGNMENT CENTROID C 100 DO 120 J = 1, 6 SS = 0.0 DO 110 K = 1, 6 SS = SS + R(J,K)*COM(K,M,NM) 110 CONTINUE FOOD(J) = SS 120 CONTINUE C DO 130 J = 1, 6 COM(J,M,NM) = FOOD(J) 130 CONTINUE C DO 160 J = 1, 6 COM(J,M,NM) = COM(J,M,NM) + COD(J) 160 CONTINUE C C MISALIGNMENT TRANSFER MATRIX C DO 180 L1 = 1, 6 L3L2 = 0 DO 180 L2 = 1, 6 S = 0.0 DO 175 L3 = 1, 6 L3L2 = L3L2 + 1 S = S + R(L1,L3)*RC2M(L3L2,M,NM) 175 CONTINUE WORK(L1,L2) = S 180 CONTINUE C L1L2 = 0 DO 190 L2 = 1, 6 DO 190 L1 = 1, 6 L1L2 = L1L2 + 1 RC2M(L1L2,M,NM) = WORK(L1,L2) 190 CONTINUE C 200 RETURN END REAL FUNCTION LIMIT( TYPE, N, K) C C IMPOSES LIMITS ON VARIED QUANTITIES C C NO DESCRIPTION C C LIST OF COMMON BLOCKS C INCLUDE 'ELM1A.CIN' INCLUDE 'ELM13B.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'ELM39B.CIN' C C LOCAL VARIABLES C INTEGER K, N, NP, TYPE REAL AGEN(4), ALEN(4), ALIM C DATA AGEN/-1.E10, 1., 1.E10, 1./ DATA ALEN/0., 1., 0., 0./ C C--------------------------------------------------------------- NP = N ALIM = AGEN(K) IF (TYPE .EQ. 1 .AND. .NOT. (ACCEL .OR. LTWISS)) GO TO 10 IF (TYPE .EQ. 2) GO TO 20 IF (TYPE .EQ. 3) GO TO 30 IF (TYPE .EQ. 4) GO TO 40 IF (TYPE .EQ. 5) GO TO 50 IF (TYPE .EQ. 11) GO TO 110 IF (TYPE .EQ. 12) GO TO 120 IF (TYPE .EQ. 18) GO TO 180 IF (TYPE .EQ. 19) GO TO 190 IF (TYPE .EQ. 20) GO TO 200 IF (TYPE .EQ. 25) GO TO 250 IF (TYPE .EQ. 28 .OR. TYPE .EQ. 29) GO TO 280 IF (TYPE .EQ. 34) GO TO 340 IF (TYPE .EQ. 35 .OR. TYPE .EQ. 36) GO TO 350 GO TO 500 C 10 ALIM = ALIM1(K) GO TO 500 C 20 ALIM = ALIM2(K) IF (K .EQ. 1 .OR. K .EQ. 3) ALIM = ALIM/UNITI(7) GO TO 500 C 30 ALIM = ALIM3(K) IF (K .EQ. 1 .OR. K .EQ. 3) ALIM = ALIM/UNITI(8) GO TO 500 C 40 IF (NP .GT. 6) GO TO 500 ALIM = ALIM4(K,NP) IF (K .EQ. 1 .OR. K .EQ. 3) THEN IF (NP .EQ. 1) ALIM = ALIM/UNITI(8) IF (NP .EQ. 2) ALIM = ALIM/UNITI(9) IF (NP .EQ. 3) ALIM = ALIM/UNITI(8) IF (NP .EQ. 4) ALIM = ALIM/UNITI(7) IF (NP .EQ. 6) ALIM = ALIM*UNITI(8)**2 ENDIF GO TO 500 C 50 IF (NP .GT. 5) GO TO 500 ALIM = ALIM5(K,NP) IF (K .EQ. 1 .OR. K .EQ. 3) THEN IF (NP .EQ. 1) ALIM = ALIM/UNITI(8) IF (NP .EQ. 2) ALIM = ALIM/UNITI(9) IF (NP .EQ. 3) ALIM = ALIM/UNITI(1) IF (NP .EQ. 4) ALIM = ALIM*UNITI(1)/UNITI(9) IF (NP .EQ. 5) ALIM = ALIM*UNITI(8)**2 ENDIF GO TO 500 C 110 IF (NP .EQ. 1) ALIM = ALEN(K)/UNITI(8) GO TO 500 C 120 ALIM = ALIM12(K,NP) GO TO 500 C 180 IF (NP .GT. 4) GO TO 500 ALIM = ALIM18(K,NP) IF (K .EQ. 1 .OR. K .EQ. 3) THEN IF (NP .EQ. 1) ALIM = ALIM/UNITI(8) IF (NP .EQ. 2) ALIM = ALIM/UNITI(9) IF (NP .EQ. 3) ALIM = ALIM/UNITI(1) IF (NP .EQ. 4) ALIM = ALIM*UNITI(8)**3 ENDIF GO TO 500 C 190 IF (NP .GT. 3) GO TO 500 ALIM = ALIM19(K,NP) IF (K .EQ. 1 .OR. K .EQ. 3) THEN IF (NP .EQ. 1) ALIM = ALIM/UNITI(8) IF (NP .EQ. 2) ALIM = ALIM/UNITI(9) IF (NP .EQ. 3) ALIM = ALIM/UNITI(12) ENDIF GO TO 500 C 200 ALIM = ALIM20(K)/UNITI(13) GO TO 500 C 250 IF (NP .GT. 4) GO TO 500 ALIM = ALIM25(K,NP) IF (K .EQ. 1 .OR. K .EQ. 3) THEN IF (NP .EQ. 1) ALIM = ALIM/UNITI(8) IF (NP .EQ. 2) ALIM = ALIM/UNITI(9) IF (NP .EQ. 3) ALIM = ALIM/UNITI(1) IF (NP .EQ. 4) ALIM = ALIM*UNITI(8)**4 ENDIF GO TO 500 C 280 IF (NP .GT. 13) GO TO 500 ALIM = ALIM28(K,NP) IF (K .EQ. 1 .OR. K .EQ. 3) THEN IF (NP .EQ. 1) ALIM = ALIM/UNITI(8) IF (NP .EQ. 2) ALIM = ALIM/UNITI(9) IF (NP .EQ. 3) ALIM = ALIM/UNITI(8) IF (NP .EQ. 4) ALIM = ALIM/UNITI(7) IF (NP .EQ. 12 .OR. NP .EQ. 13) ALIM = ALIM/UNITI(7) ENDIF GO TO 500 C 340 IF (NP .GT. 5) GO TO 500 ALIM = ALIM34(K,NP) IF (K .EQ. 1 .OR. K .EQ. 3) THEN IF (NP .EQ. 1) ALIM = ALIM/UNITI(8) IF (NP .EQ. 2) ALIM = ALIM/UNITI(9) IF (NP .EQ. 3) ALIM = ALIM/UNITI(1) IF (NP .EQ. 4) ALIM = ALIM*UNITI(1)/UNITI(9) IF (NP .EQ. 5) ALIM = ALIM*UNITI(8)**2 ENDIF GO TO 500 C 350 IF (NP .GT. 4) GO TO 500 ALIM = ALIM35(K,NP) IF (K .EQ. 1 .OR. K .EQ. 3) THEN IF (NP .EQ. 1) ALIM = ALIM/UNITI(8) IF (NP .EQ. 2) ALIM = ALIM/UNITI(9) IF (NP .EQ. 3) ALIM = ALIM/UNITI(7) IF (NP .EQ. 4) ALIM = ALIM/UNITI(7) ENDIF GO TO 500 C 500 LIMIT = ALIM RETURN END SUBROUTINE LATOUT INCLUDE 'DTF.CIN' INCLUDE 'IOUNIT.CIN' INCLUDE 'PRINTC.CIN' INCLUDE 'PRINTL.CIN' C WRITE (NOUT,*) '^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^' WRITE (NOUT,*) 'LATDEF [',LATDEFL,'] <', 1 LATDEFFILE(1:LLATDEFF),'> ',LLATDEFF WRITE (NOUT,*) 'MAD [',MADL,'] <', 1 MADFILE(1:LMADF),'> ',LMADF WRITE (NOUT,*) 'TRANSPORT [',TRANSPORTL,'] <', 1 TRANSPORTFILE(1:LTRANSPORTF),'> ',LTRANSPORTF WRITE (NOUT,*) 'STRUCT [',STRUCTL,'] <', 1 STRUCTFILE(1:LSTRUCTF),'> ', LSTRUCTF WRITE (NOUT,*) 'ACAD [',ACADL,'] <', 1 ACADFILE(1:LACADF),'> ',LACADF WRITE (NOUT,*) '^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^' C IF (FILEL) THEN CALL WTOUT ENDIF IF (LATDEFL) THEN IF (LLATDEFF .GT. 0) THEN UFILEOUT = LATDEFFILE(1:LLATDEFF)//'.TOUT.LATDEF' CALL ELIMTB (UFILEOUT,LOUT) CAll LCTABS(UFILEOUT) OPEN (UNIT=35,FILE=UFILEOUT(1:LOUT), 1 FORM='FORMATTED',STATUS='UNKNOWN',IOSTAT=IOS) IF (IOS .NE. 0) THEN PRINT *,'FAILED TO OPEN LATDEF ', 1 'OUTPUT FILE. IOS=',IOS WRITE (NOUT,*) 'FAILED TO OPEN LATDEF ', 1 'OUTPUT FILE. IOS=',IOS END IF END IF CALL WLATDEF ENDIF C IF (MADL) THEN IF (LMADF .GT. 0) THEN UFILEOUT = MADFILE(1:LMADF)//'.TOUT.MAD' CALL LCTABS(UFILEOUT) CALL ELIMTB (UFILEOUT,LOUT) OPEN (UNIT=36,FILE=UFILEOUT(1:LOUT), 1 FORM='FORMATTED',STATUS='UNKNOWN',IOSTAT=IOS) IF (IOS .NE. 0) THEN PRINT *,'FAILED TO OPEN MAD ', 1 'OUTPUT FILE. IOS=',IOS WRITE (NOUT,*) 'FAILED TO OPEN MAD ', 1 'OUTPUT FILE. IOS=',IOS END IF END IF CALL WMAD END IF C IF (TRANSPORTL) THEN IF (LTRANSPORTF .GT. 0) THEN UFILEOUT=TRANSPORTFILE(1:LTRANSPORTF)// 1 '.TOUT.TRAN' CALL LCTABS(UFILEOUT) CALL ELIMTB (UFILEOUT,LOUT) OPEN (UNIT=37,FILE=UFILEOUT(1:LOUT), 1 FORM='FORMATTED',STATUS='UNKNOWN',IOSTAT=IOS) IF (IOS .NE. 0) THEN PRINT *,'FAILED TO OPEN TRANSPORT ', 1 'OUTPUT FILE. IOS=',IOS WRITE (NOUT,*) 'FAILED TO OPEN TRANSPORT ', 1 'OUTPUT FILE. IOS=',IOS END IF END IF CALL WTRAN ENDIF C IF (STRUCTL) THEN IF (LSTRUCTF .GT. 0) THEN UFILEOUT=STRUCTFILE(1:LSTRUCTF)//'.TOUT.STRUCT' CALL ELIMTB (UFILEOUT,LOUT) CALL LCTABS(UFILEOUT) OPEN (UNIT=38,FILE=UFILEOUT(1:LOUT), 1 FORM='FORMATTED',STATUS='UNKNOWN',IOSTAT=IOS) IF (IOS .NE. 0) THEN PRINT *,'FAILED TO OPEN STRUCT ', 1 'OUTPUT FILE. IOS=',IOS WRITE (NOUT,*) 'FAILED TO OPEN STRUCT ', 1 'OUTPUT FILE. IOS=',IOS END IF END IF CALL WSTRUCT END IF C IF (ACADL) THEN IF (LACADF .GT. 0) THEN UFILEOUT=ACADFILE(1:LACADF)//'.TOUT.SCR' CALL ELIMTB (UFILEOUT,LOUT) CALL LCTABS(UFILEOUT) OPEN (UNIT=39,FILE=UFILEOUT(1:LOUT), 1 FORM='FORMATTED',STATUS='UNKNOWN',IOSTAT=IOS) IF (IOS .NE. 0) THEN PRINT *,'FAILED TO OPEN AUTO-CAD ', 1 'OUTPUT FILE. IOS=',IOS WRITE (NOUT,*) 'FAILED TO OPEN AUTO-CAD ', 1 'OUTPUT FILE. IOS=',IOS END IF END IF CALL WACAD ENDIF END SUBROUTINE LATSTOR INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'LOUTAR.CIN' INCLUDE 'CONSTS.CIN' INCLUDE 'DATA1C.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'DBEAMR.CIN' INCLUDE 'DSPECR.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM0B.CIN' INCLUDE 'ELM0D.CIN' INCLUDE 'ELM1A.CIN' INCLUDE 'ELM1C.CIN' INCLUDE 'ELM1D.CIN' INCLUDE 'ELM4A.CIN' INCLUDE 'ELM4C.CIN' INCLUDE 'ELM7C.CIN' INCLUDE 'ELM11.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'ELM15C.CIN' INCLUDE 'ELM16A.CIN' INCLUDE 'ELM16B.CIN' INCLUDE 'ELM19.CIN' INCLUDE 'ETACOM.CIN' INCLUDE 'INDPAR.CIN' INCLUDE 'LBLSVE.CIN' INCLUDE 'OC.CIN' INCLUDE 'OUTNEWC.CIN' INCLUDE 'OUTNEWR.CIN' INCLUDE 'YAW.CIN' C---------------------------------------------------------------------- LOGICAL ATWEL C C\\\\\\\\\\\\\\\\ ADDITIONS 11/26/97 \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ C\\\\\\\\\\\\\\\\ ADDED 11/25/97 NMG \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ C\\\\\\\\\\\\\\\\\\\ ADDED 12/1/97 NMG \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ IF ((TYPE .EQ. 10) .AND. (LABEL(NUM) .EQ. LABELSVE)) THEN ATWEL = .TRUE. LABELSVE = ' ' ELSE ATWEL = ATWE END IF C\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 12/1/97 \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ IF (.NOT. ATWEL) GO TO 5220 C\\\\\\\\\\\\\\ ADDED 12/15/97 NMG \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ C WILL INCREMENT ICOUNT AT 5 200. IF TYPE IS NOT ONE OF THE SELECTED C TYPES ICOUNT WILL BE DECREMENTED. ICOUNT = ICOUNT + 1 C\\\\\\\\\\\\\\\\\\\\\ 12/17/97 NMG \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ C NEED TO ZERO OUTNEW C DO IA = 1, LOUTAR OUTNEW(IA,ICOUNT) = 0.0 END DO OUTLAB (ICOUNT) = 'NOT DEFINED.' OUTNEWL(ICOUNT) = .FALSE. C\\\\\\\\\\\\\\\\\\\\ 12/17/97 \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ C\\\\\\\\\\\\\\\\\ 12/15/97 \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ C C BEAM C IF (TYPE .EQ. 1) THEN DO IB = 1, 18 J = IPTOJ(IB) IF (J .GT. 0) THEN DBEAM_VAL(IB) = DATAR(I+J) ENDIF ENDDO C DO IB = 10, 15 J = IPTOJ(IB) IF (J .NE. 0) GO TO 5210 END DO C DO IB = 1, 4 J = IPTOJ(IB) IF (J .EQ. 0) GO TO 5210 IF (DBEAM_VAL(IB) .EQ. 0.0) GO TO 5210 END DO C SIG11 = DBEAM_VAL(1)**2 SIG22 = DBEAM_VAL(2)**2 SIG33 = DBEAM_VAL(3)**2 SIG44 = DBEAM_VAL(4)**2 EPSX = SQRT(SIG11*SIG22) BETAX = SQRT(SIG11/SIG22) ALPHAX = 0.0 EPSY = SQRT(SIG33*SIG44) BETAY = SQRT(SIG33/SIG44) ALPHAY = 0.0 DBEAM_VAL(10) = BETAX DBEAM_VAL(11) = ALPHAX DBEAM_VAL(12) = EPSX DBEAM_VAL(13) = BETAY DBEAM_VAL(14) = ALPHAY DBEAM_VAL(15) = EPSY C GO TO 5 210 ENDIF C C DRIFT C IF (TYPE .EQ. 3) THEN L = DATAR(I+1)*UNITI(8) OUTNEW(1,ICOUNT) = L GO TO 5 210 END IF C C BEND C IF (TYPE .EQ. 4) THEN IL = IPTOJ( 1) + I OUTNEW(1,ICOUNT) = DATAR(IL) IANG = IPTOJ( 4) + I OUTNEW(2,ICOUNT) = DATAR(IANG) IN = IPTOJ( 5) IK1 = IPTOJ( 6) NB = 0.0 K1 = 0.0 IF (IK1 .EQ. 0) THEN IF (IN .NE. 0) THEN NB = DATAR(I + IN) END IF ELSE IF (IK1 .NE. 0.0) THEN K1 = DATAR(I + IK1) END IF K1 = K1/UNITI(8)**2 IF (H0 .NE. 0.0) NB = -K1/H0**2 END IF OUTNEW(3,ICOUNT) = K1 IS = IPTOJ(13) IF (IS .GT. 0) THEN OUTNEW(4,ICOUNT) = DATAR(I + IS) END IF IO = IPTOJ(17) IF (IO .GT. 0) THEN OUTNEW(5,ICOUNT) = DATAR(I + IO) END IF IT = IPTOJ(18) IF (IT .GT. 0) THEN OUTNEW(6,ICOUNT) = DATAR(I + IT) END IF GO TO 5 210 END IF C C QUADRUPOLES C IF (TYPE .EQ. 5) THEN IL = IPTOJ( 1) + I L = DATAR(IL)*UNITI(8) OUTNEW(1,ICOUNT) = L C IB = IPTOJ(2) IAP = IPTOJ(3) IG = IPTOJ(4) IK1 = IPTOJ(5) K1 = 0.0 IF (IB .NE. 0 .AND. IAP .NE. 0) THEN B = DATAR(I+IB)*UNITI(9) AP = DATAR(I+IAP)*UNITI(1) K1 = B/(AP*RI) ENDIF IF (IG .NE. 0) THEN GRAD = DATAR(I+IG)*UNITI(9)/UNITI(1) K1 = GRAD/RI ENDIF IF (IK1 .NE. 0) THEN K1 = DATAR(I + IK1)*UNITI(8)**2 END IF K1 = K1/UNITI(8)**2 OUTNEW(3,ICOUNT) = K1 IT = IPTOJ(7) IF (IT .GT. 0) THEN OUTNEW(6,ICOUNT) = DATAR(I + IT) END IF GO TO 5 210 END IF C C FIT C IF (TYPE .EQ. 10) THEN GO TO 5 210 END IF C C ACCELERATION C IF (TYPE .EQ. 11) THEN IADR = I + 1 L = DATAR(IADR)*UNITI(8) OUTNEW(1,ICOUNT) = L C IADR = I + 2 EGAIN = DATAR(IADR)*UNITI(11) OUTNEW(2,ICOUNT) = EGAIN C IADR = I + 3 PHASEL = DATAR(IADR)/RADIAN OUTNEW(3,ICOUNT) = PHASEL C IADR = I + 4 IF (IPTOJ(5) .EQ. 0) THEN WAVEL = DATAR(IADR)*UNITI(5) FREQ = CLIGHT*1.0E-6/WAVEL ELSE FREQ = DATAR(IADR) WAVEL = CLIGHT*1.0E-6/FREQ ENDIF OUTNEW(4,ICOUNT) = FREQ GO TO 5 210 ENDIF C C BEAM CORRELATIONS C IF (TYPE .EQ. 12) THEN IF (LTWISS) THEN SIG11 = DBEAM_VAL(1)**2 SIG22 = DBEAM_VAL(2)**2 SIG33 = DBEAM_VAL(3)**2 SIG44 = DBEAM_VAL(4)**2 C R21 = 0.0 IR21 = IPTOJ(1) IF (IR21 .NE. 0.0) THEN R21 = DATAR(I+IR21) ENDIF SIG21 = R21*SQRT(SIG11*SIG22) C R43 = 0.0 IR43 = IPTOJ(6) IF (IR43 .NE. 0.0) THEN R43 = DATAR(I+IR43) ENDIF SIG43 = R43*SQRT(SIG33*SIG44) C EPSX = SQRT(SIG11*SIG22 - SIG21**2) BETAX = SIG11/EPSX ALPHAX = - SIG21/EPSX EPSY = SQRT(SIG33*SIG44 - SIG43**2) BETAY = SIG33/EPSY ALPHAY = - SIG43/EPSY C DBEAM_VAL(10) = BETAX DBEAM_VAL(11) = ALPHAX DBEAM_VAL(12) = EPSX DBEAM_VAL(13) = BETAY DBEAM_VAL(14) = ALPHAY DBEAM_VAL(15) = EPSY C GO TO 5 210 ELSE DO IB = 1, 15 J = IPTOJ(IB) DCORR_VAL(IB) = 0.0 IF (J .GT. 0) THEN DCORR_VAL(IB) = DATAR(I+J) ENDIF END DO ENDIF ENDIF C C SPECIAL PARAMETERS C IF (TYPE .EQ. 16) THEN J = INT(DATAR(I+1)) DSPEC_VAL(J+3) = PARAM GO TO 5 210 ENDIF C C SEXTUPOLES C IF (TYPE .EQ. 18) THEN IL = IPTOJ(1) + I L = DATAR(IL)*UNITI(8) OUTNEW(1,ICOUNT) = L C IB = IPTOJ(2) IAP = IPTOJ(3) IF (IB .GT. 0 .AND. IAP .GT. 0) THEN B = DATAR(I+IB)*UNITI(9)*RI/PREF AP = DATAR(I+IAP)*UNITI(1) K2 = B/(RI*AP**2) K2 = K2*UNITI(8)**3 OUTNEW(4,ICOUNT) = K2 ENDIF C IS = IPTOJ(4) IF (IS .GT. 0) THEN OUTNEW(4,ICOUNT) = DATAR(IS + I) END IF C IT = IPTOJ(5) IF (IT .GT. 0) THEN OUTNEW(6,ICOUNT) = DATAR(IT + I) END IF GO TO 5 210 END IF C C SOLENOIDS C IF (TYPE .EQ. 19) THEN IADR = I + 1 L = DATAR(IADR) L = L*UNITI(8) OUTNEW(1,ICOUNT) = L C IB = IPTOJ(2) IK = IPTOJ(3) IF (IB .NE. 0) THEN IADR = I + IB B = DATAR(IADR) B = B*UNITI(9)*RI/PREF KO = DEN(B/RI) KL = 0.5*KO*L OUTNEW(2,ICOUNT) = KL ENDIF C IF (IK .NE. 0) THEN IADR = I + IK KL = DATAR(IADR) KL = KL*UNITI(13) OUTNEW(2,ICOUNT) = KL ENDIF GO TO 5 210 ENDIF C C SROT C IF (TYPE .EQ. 20) THEN IADR = I + 1 ANGLE = DATAR(IADR)*UNITI(13) OUTNEW(1,ICOUNT) = ANGLE GO TO 5 210 ENDIF C C OCTUPOLES C IF (TYPE .EQ. 25) THEN IL = IPTOJ(1) + I L = DATAR(IL)*UNITI(8) OUTNEW(1,ICOUNT) = L C IB = IPTOJ(2) IAP = IPTOJ(3) IF (IB .GT. 0 .AND. IAP .GT. 0) THEN B = DATAR(I+IB)*UNITI(9)*RI/PREF AP = DATAR(I+IAP)*UNITI(1) K3 = B/(RI*AP**3) K3 = K3*UNITI(8)**4 OUTNEW(5,ICOUNT) = K3 ENDIF C IO = IPTOJ(4) IF (IO .GT. 0) THEN OUTNEW(5,ICOUNT) = DATAR(IO + I) END IF C IT = IPTOJ(5) IF (IT .GT. 0) THEN OUTNEW(6,ICOUNT) = DATAR(IT + I) END IF GO TO 5 210 END IF C C ETA FUNCTION C IF (TYPE .EQ. 27) THEN DO J = 1, 6 DETA_VAL(J) = ETA(J) ENDDO GO TO 5210 ENDIF C C SBEND OR RBEND C IF ((TYPE .EQ. 28) .OR. (TYPE .EQ. 29)) THEN IL = IPTOJ( 1) IB = IPTOJ( 2) IRAD = IPTOJ( 3) IANG = IPTOJ( 4) C IF (IL .NE. 0 .AND. IB .NE. 0) THEN L = DATAR(I+IL) B = DATAR(I+IB) L = DATAR(I+IL)*UNITI(8) B = DATAR(I+IB)*UNITI(9)*RI/PREF H0 = B/RI RAD = 0.0 IF (TYPE .EQ. 28 .AND. H0 .NE. 0.0) THEN ANGLE = 2.0*ASIN(0.5*H0*L) ELSE ANGLE = H0*L ENDIF ENDIF C IF (IL .NE. 0 .AND. IANG .NE. 0) THEN L = DATAR(I+IL)*UNITI(8) ANGLE = DATAR(I+IANG)*UNITI(7) ENDIF C IF (IL .NE. 0 .AND. IRAD .NE. 0) THEN L = DATAR(I+IL)*UNITI(8) RAD = DATAR(I+IRAD)*UNITI(8) H0 = 1.0/RAD IF (TYPE .EQ. 28) THEN ANGLE = 2.0*ASIN(0.5*L/RAD) ELSE ANGLE = L/RAD ENDIF ENDIF C IF (IRAD .NE. 0 .AND. IANG .NE. 0) THEN RAD = DATAR(I+IRAD)*UNITI(8) ANGLE = DATAR(I+IANG)*UNITI(7) IF (TYPE .EQ. 28) THEN L = 2.0*RAD*SIN(0.5*ANGLE) ELSE L = RAD*ANGLE ENDIF ENDIF C IF (IB .NE. 0 .AND. IANG .NE. 0) THEN B = DATAR(I+IB)*UNITI(9)*RI/PREF ANGLE = DATAR(I+IANG)*UNITI(7) H0 = B/RI IF (TYPE .EQ. 28) THEN L = 2.0*RAD*SIN(0.5*ANGLE) ELSE L = RAD*ANGLE ENDIF ENDIF C OUTNEW(1,ICOUNT) = L OUTNEW(2,ICOUNT) = ANGLE C IN = IPTOJ( 5) IK1 = IPTOJ( 6) NB = 0.0 K1 = 0.0 IF (IK1 .EQ. 0) THEN IF (IN .NE. 0) THEN NB = DATAR(I + IN) K1 = - NB*H0**2 END IF ELSE IF (IK1 .NE. 0.0) THEN K1 = DATAR(I + IK1)*UNITI(8)**2 END IF K1 = K1/UNITI(8)**2 IF (H0 .NE. 0.0) NB = - K1/H0**2 END IF OUTNEW(3,ICOUNT) = K1 C IK2 = IPTOJ(15) IF (IK2 .GT. 0) THEN OUTNEW(4,ICOUNT) = DATAR(I + IK2) END IF C IK3 = IPTOJ(21) IF (IK3 .GT. 0) THEN OUTNEW(5,ICOUNT) = DATAR(I + IK3) END IF C IT = IPTOJ(24) IF (IT .GT. 0) THEN OUTNEW(6,ICOUNT) = DATAR(I + IT) END IF GO TO 5 210 END IF C C MARKER C IF (TYPE .EQ. 31) THEN GO TO 5 210 END IF C C HKICK AND VKICK C IF ((TYPE .EQ. 35) .OR. (TYPE .EQ. 36)) THEN IL = IPTOJ(1) IF (IL .GT. 0) THEN L = DATAR(I+IL)*UNITI(8) OUTNEW(1,ICOUNT) = L END IF C IB = IPTOJ(2) IF (IB .GT. 0) THEN B = DATAR(I+IB) B = B*UNITI(9)*RI/PREF H0 = B/RI ANGLE = H0*L OUTNEW(2,ICOUNT) = - ANGLE ENDIF C IK = IPTOJ(4) IF (IK .GT. 0) THEN OUTNEW(2,ICOUNT) = DATAR(I+IK)*UNITI(7) END IF C IANG = IPTOJ(3) IF (IANG .GT. 0) THEN OUTNEW(2,ICOUNT) = - DATAR(I + IANG)*UNITI(7) END IF C IT = IPTOJ(5) IF (IT .GT. 0) THEN OUTNEW(6,ICOUNT) = DATAR(I + IT) END IF GO TO 5 210 END IF C C KICKER C IF (TYPE .EQ. 42) THEN IL = IPTOJ(1) IF (IL .GT. 0) THEN L = DATAR(I+IL)*UNITI(8) OUTNEW(1,ICOUNT) = L END IF C C IHK = IPTOJ(2) IF (IHK .GT. 0) THEN OUTNEW(2,ICOUNT) = DATAR(I+IHK)*UNITI(7) END IF C IVK = IPTOJ(3) IF (IVK .GT. 0) THEN OUTNEW(3,ICOUNT) = DATAR(I+IVK)*UNITI(7) END IF GO TO 5 210 ENDIF C C\\\\\\\\\\\\\\ ADDED 12/15/97 NMG \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ C WILL INCREMENT ICOUNT NEAR 5 200. IF WE COME HERE WILL DECREMENT C ICOUNT. ICOUNT = ICOUNT - 1 C\\\\\\\\\\\\\\\\\\\\\\\\\\ 12/15/97 \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ GO TO 5 220 5210 CONTINUE C\\\\\\\\\\\\ LATTICE FUNCTIONS. \\\\\\\\\\\\\\ OUTNEW( 7,ICOUNT) = ALPHAX OUTNEW( 8,ICOUNT) = BETAX OUTNEW( 9,ICOUNT) = PSIX/UNITO(12) OUTNEW(10,ICOUNT) = ETA(1) OUTNEW(11,ICOUNT) = ETA(2) OUTNEW(12,ICOUNT) = ALPHAY OUTNEW(13,ICOUNT) = BETAY OUTNEW(14,ICOUNT) = PSIY/UNITO(12) OUTNEW(15,ICOUNT) = ETA(3) OUTNEW(16,ICOUNT) = ETA(4) C\\\\\\\\\\\\\ SPACE COORDINATES. \\\\\\\\\\\\ OUTNEW(21,ICOUNT) = LC OUTNEW(22,ICOUNT) = X0(4,1)/UFLOOR(1) OUTNEW(23,ICOUNT) = X0(4,2)/UFLOOR(1) OUTNEW(24,ICOUNT) = X0(4,3)/UFLOOR(1) OUTNEW(25,ICOUNT) = YAW OUTNEW(26,ICOUNT) = PITCH OUTNEW(27,ICOUNT) = ROLL C\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ C\\\\\\\\\\\\\\\\\ 12/15/97 NMG \\\\\\\\\\\\\\\\\\\\\\\\\\\\\ C SQUARE ROOT OF SIGMA MATRIX NSI = 28 DO ISI = 1, 6 DO JSI = ISI, 6 OUTNEW(NSI,ICOUNT) = SIT(ISI,JSI) NSI = NSI + 1 END DO END DO C\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ C\\\\\\\\\\\\\\\ ADDED 12/16/97 NMG \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ C CENTROID C DO I1 =1, 4 OUTNEW(I1 + 16,ICOUNT) = CEN(I1) END DO C\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ OUTLAB (ICOUNT) = LABEL(NUM) IOUTTYP(ICOUNT) = TYPE OUTNEWL(ICOUNT) = .TRUE. 5220 CONTINUE C\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ C WRITE (23,*) NUM, LABEL(NUM), TYPE, ICOUNT, OUTNEWL(ICOUNT) RETURN END SUBROUTINE LIMSET C C SET LIMITS ON PHYSICAL PARAMETERS IN FITTING C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'ELM39B.CIN' INCLUDE 'ELM39C.CIN' C C------------------------------------------------------------------- NPAR = NPARL DPAR = DPARL LT = 2*LTYPE - 1 IF (TYPEL .GT. 48) GO TO 1000 GO TO ( 10, 20, 30, 40, 50,1000,1000,1000,1000,1000, 1 1000, 120,1000,1000,1000,1000,1000, 180, 190, 200, 2 1000,1000,1000,1000, 250,1000,1000, 280, 280,1000, 3 1000,1000,1000, 340, 350, 350,1000,1000,1000,1000, 4 1000,1000,1000,1000,1000,1000,1000,1000), TYPEL C 10 ALIM1(LT) = DPAR ALIM1(LT+1) = 1.0 GO TO 1000 C 20 IF (NPAR .EQ. 1) THEN ALIM2(LT) = DPAR*UNITI(7) ALIM2(LT+1) = 1.0 ENDIF GO TO 1000 C 30 IF (NPAR .EQ. 1) THEN ALIM3(LT) = DPAR*UNITI(8) ALIM3(LT+1) = 1.0 ENDIF GO TO 1000 C 40 IF (NPAR .GE. 1 .AND. NPAR .LE. 6) THEN IF (NPAR .EQ. 1) DPAR = DPAR*UNITI(8) IF (NPAR .EQ. 2) DPAR = DPAR*UNITI(9) IF (NPAR .EQ. 3) DPAR = DPAR*UNITI(8) IF (NPAR .EQ. 4) DPAR = DPAR*UNITI(7) IF (NPAR .EQ. 6) DPAR = DPAR/UNITI(8)**2 ALIM4(LT,NPAR) = DPAR ALIM4(LT+1,NPAR) = 1.0 ENDIF GO TO 1000 C 50 IF (NPAR .GE. 1 .AND. NPAR .LE. 5) THEN IF (NPAR .EQ. 1) DPAR = DPAR*UNITI(8) IF (NPAR .EQ. 2) DPAR = DPAR*UNITI(9) IF (NPAR .EQ. 3) DPAR = DPAR*UNITI(1) IF (NPAR .EQ. 4) DPAR = DPAR*UNITI(9)/UNITI(1) IF (NPAR .EQ. 5) DPAR = DPAR/UNITI(8)**2 ALIM5(LT,NPAR) = DPAR ALIM5(LT+1,NPAR) = 1.0 ENDIF GO TO 1000 C 120 IF (NPAR .GE. 1 .AND. NPAR .LE. 15) THEN ALIM12(LT,NPAR) = DPAR ALIM12(LT+1,NPAR) = 1.0 ENDIF GO TO 1000 C 180 IF (NPAR .GE. 1 .AND. NPAR .LE. 4) THEN IF (NPAR .EQ. 1) DPAR = DPAR*UNITI(8) IF (NPAR .EQ. 2) DPAR = DPAR*UNITI(9) IF (NPAR .EQ. 3) DPAR = DPAR*UNITI(1) IF (NPAR .EQ. 4) DPAR = DPAR/UNITI(8)**3 ALIM18(LT,NPAR) = DPAR ALIM18(LT+1,NPAR) = 1.0 ENDIF GO TO 1000 C 190 IF (NPAR .GE. 1 .AND. NPAR .LE. 3) THEN IF (NPAR .EQ. 1) DPAR = DPAR*UNITI(8) IF (NPAR .EQ. 2) DPAR = DPAR*UNITI(9) IF (NPAR .EQ. 3) DPAR = DPAR*UNITI(12) ALIM19(LT,NPAR) = DPAR ALIM19(LT+1,NPAR) = 1.0 ENDIF GO TO 1000 C 200 IF (NPAR .EQ. 1) THEN ALIM20(LT) = DPAR*UNITI(12) ALIM20(LT+1) = 1.0 ENDIF GO TO 1000 C 250 IF (NPAR .GE. 1 .AND. NPAR .LE. 4) THEN IF (NPAR .EQ. 1) DPAR = DPAR*UNITI(8) IF (NPAR .EQ. 2) DPAR = DPAR*UNITI(9) IF (NPAR .EQ. 3) DPAR = DPAR*UNITI(1) IF (NPAR .EQ. 4) DPAR = DPAR/UNITI(8)**4 ALIM25(LT,NPAR) = DPAR ALIM25(LT+1,NPAR) = 1.0 ENDIF GO TO 1000 C 280 IF (NPAR .GE. 1 .AND. NPAR .LE. 13) THEN IF (NPAR .EQ. 1) DPAR = DPAR*UNITI(8) IF (NPAR .EQ. 2) DPAR = DPAR*UNITI(9) IF (NPAR .EQ. 3) DPAR = DPAR*UNITI(8) IF (NPAR .EQ. 4) DPAR = DPAR*UNITI(7) IF (NPAR .EQ. 12 .OR. NPAR .EQ. 13) DPAR = DPAR*UNITI(12) ALIM28(LT,NPAR) = DPAR ALIM28(LT+1,NPAR) = 1.0 ENDIF GO TO 1000 C 340 IF (NPAR .GE. 1 .AND. NPAR .LE. 5) THEN IF (NPAR .EQ. 1) DPAR = DPAR*UNITI(8) IF (NPAR .EQ. 2) DPAR = DPAR*UNITI(9) IF (NPAR .EQ. 3) DPAR = DPAR*UNITI(1) IF (NPAR .EQ. 4) DPAR = DPAR*UNITI(9)/UNITI(1) IF (NPAR .EQ. 5) DPAR = DPAR/UNITI(8)**2 ALIM34(LT,NPAR) = DPAR ALIM34(LT+1,NPAR) = 1.0 ENDIF GO TO 1000 C 350 IF (NPAR .GE. 1 .AND. NPAR .LE. 4) THEN IF (NPAR .EQ. 1) DPAR = DPAR*UNITI(8) IF (NPAR .EQ. 2) DPAR = DPAR*UNITI(9) IF (NPAR .EQ. 3) DPAR = DPAR*UNITI(7) IF (NPAR .EQ. 4) DPAR = DPAR*UNITI(7) ALIM35(LT,NPAR) = DPAR ALIM35(LT+1,NPAR) = 1.0 ENDIF GO TO 1000 C 1000 RETURN END SUBROUTINE MALIGN C C CALCULATES EFFECT OF MISALIGNMENTS C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM0B.CIN' INCLUDE 'ELM2B.CIN' INCLUDE 'ELM8A.CIN' INCLUDE 'ELM8B.CIN' INCLUDE 'ELM8C.CIN' INCLUDE 'ELM8G.CIN' INCLUDE 'ELM8H.CIN' INCLUDE 'ELM8M.CIN' INCLUDE 'FLUSHC.CIN' INCLUDE 'IOUNIT.CIN' C C LOCAL VARIABLES C INTEGER J, M, N, NCOMP REAL VMSAV(6) CHARACTER*4 BLANK C DATA BLANK /' '/ C C------------------------------------------------------------- NCOMP = 0 IF (TYPE .EQ. 2 .OR. TYPE .EQ. 4 .OR. TYPE .EQ. 5 1 .OR. TYPE .EQ. 28 .OR. TYPE .EQ. 29) 2 NCOMP = NMISE IF (TYPE .EQ. 6 .OR. TYPE .EQ. 8 .OR. TYPE .EQ. 37) 1 NCOMP = NMIS IF (LTAB .EQ. 1) THEN DO 10 N = 1, NMMAX IF (NCOMP .EQ. NMTE(N)) THEN NM = N LNMT(NM) = .TRUE. GO TO 15 ENDIF 10 CONTINUE WRITE (NOUT,9001) 9001 FORMAT (' NO MATCH FOR MISALIGNMENT SPECIFICATION') FLUSHL = .TRUE. GO TO 100 C 15 IF (BEFORE) THEN LABM(NM) = BLANK LMIS(1,NM) = LC ELSE LABM(NM) = LAST(1:8) LMIS(2,NM) = LC ENDIF CHORDT(NM) = CHORD ENDIF C IF (LFM .EQ. 0) THEN IF (.NOT. BEFORE) CALL MUNCH ELSE IF (LFM .GE. 1) THEN IF (BEFORE) THEN IF (CHORD .OR. TMK .GE. 1) CALL OGET CALL PIVENT ELSE CALL OGET IF (CHORD .OR. TMK .GE. 1) CALL PIVENT CALL PIVEX ENDIF IF (LTAB .EQ. 0) THEN IF (BEFORE) THEN CALL MENTER ELSE CALL MEXIT ENDIF ELSE IF (LTAB .EQ. 1) THEN DO 20 M = 1, 6 20 VMSAV(M) = VM(M) C DO 50 M = 1, 6 DO 40 J = 1, 6 40 VM(J) = 0.0 VM(M) = VMSAV(M) IF (BEFORE) THEN CALL MENTER ELSE CALL MEXIT ENDIF CALL JOSTLE(M) 50 CONTINUE R2PM(NM) = .TRUE. C DO 60 M = 1, 6 60 VM(M) = VMSAV(M) ENDIF ENDIF C 100 RETURN END SUBROUTINE MARCH C C WALKS THROUGH BEAM LINE WHEN FITTING C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA0B.CIN' INCLUDE 'DATA1A.CIN' INCLUDE 'DATA1C.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM0B.CIN' INCLUDE 'ELM0C.CIN' INCLUDE 'ELM0D.CIN' INCLUDE 'ELM8G.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM10E.CIN' INCLUDE 'ELM31A.CIN' INCLUDE 'FLUSHC.CIN' INCLUDE 'LXRAN.CIN' INCLUDE 'R3P.CIN' C C LOCAL VARIABLES C INTEGER IDATA REAL DATAR EXTERNAL DATAR C---------------------------------------------------------------- C CALL PARSET IF (NCTS .EQ. 1) CALL INITZE IF (NCTS .EQ. NCTE .AND. NCTE .NE. 1) THEN CALL RECALL IF (FLUSHL) GO TO 950 ENDIF NCT = NCTS - 1 1 I = ISTOR(NUM) TYPE = IDATA(I) IF (TYPE .GE. 82 .AND. TYPE .LE. 86) GO TO 70 IF (TYPE .LE. 0 .OR. TYPE .GE. 50) GO TO 810 NCT = NCT + 1 IF (NCT .GT. NCTF) GO TO 900 C CALL SKETCH(NUM) CALL DEPICT IF (.NOT. ATWE) GO TO 810 IF (DOPARS .AND. TYPE .NE. 23 .AND. TYPE .NE. 30 .AND. 1 TYPE .NE. 9 .AND. TYPE .NE. 24 .AND. TYPE .NE. 31) GO TO 810 C C POSSIBLE INITIAL MISALIGNMENTS C CALL POSSIM C C SIMPLE ELEMENTS C IF (RABL .AND. WFRN) GO TO 200 IF (RABL) GO TO 100 70 TYPEC = TYPE LXRAN = TYPE .LT. 50 CALL DERIVE IF (FLUSHL) GO TO 950 IF (TYPE .LE. 0) GO TO 810 IF (TYPE .GE. 50) GO TO 810 IF (TYPE .EQ. 15) GO TO 810 C C UPDATE USED TO MARK BEGINNING OF MISALIGNMENT C IF (TYPE .EQ. 6 .OR. TYPE .EQ. 37) THEN CALL UPMARK IF (FLUSHL) GO TO 950 ENDIF GO TO 810 C C SIMPLE ELEMENTS WITH POSSIBLE TILT C 100 IF (TYPE .EQ. 2 .OR. TYPE .EQ. 4) GO TO 150 CALL ELTILT IF (FLUSHL) GO TO 950 GO TO 800 C C BENDING MAGNETS WITH FRINGE FIELD SPECIFIED BY SEPARATE ELEMENT C 150 CALL EL242 IF (FLUSHL) GO TO 950 GO TO 800 C C COMPOUND ELEMENTS C 200 CALL ELCOMP IF (FLUSHL) GO TO 950 GO TO 800 C C LOOP THROUGH MISALIGNMENTS BY NAME C 800 IF (NMISRB .NE. 0) CALL AGENDR(1) C C ADVANCE TO NEXT ELEMENT C 810 IF (MKG .AND. NUM .EQ. NMARKE) CALL AGENDA(2) IF (ALGR .AND. NUM .EQ. NMISRE) CALL AGENDR(2) NUM = NUM + NDIF IF (.NOT. MKG .AND. NUSE .NE. 0 .AND. NUM .GT. NUSE) GO TO 900 IF (NUM .LE. NEL) GO TO 1 900 IF (NCTF .LT. NCTC .AND. R3P) CALL UPDAT3 950 CONTINUE RETURN END SUBROUTINE MCOUNT C C COUNT THE NUMBER OF MISALIGNMENTS POINTING TO EACH UPDATE C (INCLUDING IMPLICIT INITIAL) C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA0A.CIN' INCLUDE 'DATA1A.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM0D.CIN' INCLUDE 'ELM0F.CIN' INCLUDE 'ELM8A.CIN' INCLUDE 'ELM8F.CIN' INCLUDE 'ELM8G.CIN' INCLUDE 'ELM9.CIN' INCLUDE 'ELM24A.CIN' INCLUDE 'ELM31A.CIN' INCLUDE 'FLUSHC.CIN' INCLUDE 'INDPAR.CIN' C C LOCAL VARIABLES C INTEGER IDATA INTEGER IADR, IM, IUP, NSLIT, NUMS, TYPES INTEGER LAKE REAL FAKE EQUIVALENCE (FAKE,LAKE) EXTERNAL IDATA C--------------------------------------------------------------------- C NUM = 1 NDIF = 1 NMTOT = 0 NUP(2) = 0 NUP(3) = 0 NIU(2) = 0 NIU(3) = 0 MKG = .FALSE. ATWORK = NUSE .EQ. 0 C IF (NEL .LE. 0) GO TO 5300 10 I = ISTOR(NUM) TYPE = IDATA(I) CALL SKETCH(NUM) CALL DEPICT IF (.NOT. ATWE) GO TO 5200 IF (TYPE .LE. 0 .OR. TYPE .GE. 50) GO TO 5200 IF (TYPE .EQ. 5) GO TO 500 IF (TYPE .EQ. 6) GO TO 600 IF (TYPE .EQ. 8) GO TO 800 IF (TYPE .EQ. 9) GO TO 900 IF (TYPE .EQ. 24) GO TO 2400 IF (TYPE .EQ. 28 .OR. TYPE .EQ. 29) GO TO 2800 IF (TYPE .EQ. 31) GO TO 3100 IF (TYPE .EQ. 37) GO TO 3700 GO TO 5200 C C 5. -- QUADRUPOLE C 500 IF (NMISRB .NE. 0) CALL AGENDR(1) GO TO 5200 C C 6. -- UPDATE C 600 IF (.NOT. ATWE) GO TO 5200 NSLIT = INT(DATA(I+1)) IF (NSLIT .EQ. 0) THEN IUP = INT(DATA(I+2)) NUP(IUP+1) = NUM IADR = I + IPTOJ(4) LAKE = 0 DATA(IADR) = FAKE ENDIF GO TO 5200 C C 8. -- MISALIGNMENT C 800 TYT = INT(DATA(I+7)) LFM = TYT/100 LTAB = MOD(TYT/10,10) RORC = MOD(TYT,10) IR = RORC + 1 IF (IR .EQ. 2 .OR. IR .EQ. 3) THEN NUMS = NUP(IR) IF (NUMS .EQ. 0) THEN IF (LFM .EQ. 0) GO TO 5200 NIU(IR) = NIU(IR) + 1 ELSE IM = ISTOR(NUMS) TYPES = INT(DATA(IM)) IF (LFM .NE. 0 .OR. TYPES .NE. 6) THEN CALL SKETCH(NUMS) IADR = IM + IPTOJ(4) LAKE = IDATA(IADR) + 1 DATA(IADR) = FAKE NMTOT = NMTOT + 1 ENDIF ENDIF ENDIF GO TO 5200 C C 9. -- REPEAT C 900 NREP = IDATA(I+1) CALL REPEAT IF (FLUSHL) GO TO 5300 GO TO 5200 C C 24. -- DEFINED SECTION C 2400 JDEF = IDATA(I+1) IF (JDEF .EQ. 3 .OR. JDEF .EQ. 4) THEN NADDEF(1) = IDATA(I+2) NADDEF(2) = IDATA(I+3) ENDIF CALL DEFINE IF (FLUSHL) GO TO 5300 GO TO 5200 C C 28. -- RBEND OR 29. -- SBEND C 2800 IF (NMISRB .NE. 0) CALL AGENDR(1) GO TO 5200 C C 31. -- POSITION MARKER C 3100 DRC = .FALSE. NMARKS = IDATA(I+1) CALL AGENDA(1) GO TO 5200 C C 37. -- ALIGNMENT MARKER C 3700 IF (.NOT. ATWE) GO TO 5200 NSLIT = INT(DATA(I+1)) IF (NSLIT .EQ. 0) THEN IUP = INT(DATA(I+2)) NUP(IUP+1) = NUM LAKE = 0 IADR = I + IPTOJ(4) DATA(IADR) = FAKE ENDIF GO TO 5200 C C ADVANCE TO NEXT ELEMENT C 5200 IF (MKG .AND. NUM .EQ. NMARKE) CALL AGENDA(2) IF (ALGR .AND. NUM .EQ. NMISRE) CALL AGENDR(2) NUM = NUM + NDIF IF (.NOT. MKG .AND. NUSE .NE. 0 .AND. NUM .GT. NUSE) GO TO 5300 IF (NUM .LE. NEL) GO TO 10 C 5300 RETURN END SUBROUTINE MENTER C C KNOWN MISALIGNMENT AT SECTION ENTRANCE C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM7B.CIN' INCLUDE 'ELM8A.CIN' INCLUDE 'ELM8D.CIN' INCLUDE 'ELM8K.CIN' INCLUDE 'ELM10E.CIN' INCLUDE 'ELM13B.CIN' INCLUDE 'R.CIN' C C LOCAL VARIABLES C REAL VDIS1(3), VROT1(3) EQUIVALENCE (RX,VROT(1)), (RY,VROT(2)), (RZ,VROT(3)) C C------------------------------------------------------------------ CALL MVTODR C DO 20 J = 1, 3 SD = 0.0 SR = 0.0 DO 18 K = 1, 3 SD = SD + OT(J,K)*VDIS(K) SR = SR + OT(J,K)*VROT(K) 18 CONTINUE VDIS1(J) = SD VROT1(J) = SR 20 CONTINUE C DO 30 J = 1, 3 VDIS(J) = VDIS1(J) 30 VROT(J) = VROT1(J) C C ROTATION MATRIX FOR MAGNET C CALL MROT C DO 40 J = 1, 3 SS = 0.0 DO 35 K = 1, 3 SS = SS + RM(J,K)*XT(K) 35 CONTINUE VDIS(J) = VDIS(J) + SS 40 CONTINUE C C TRANSPOSE ROTATION MATRIX TO ACT ON COORDINATES C DO 50 J = 2, 3 JM1 = J - 1 DO 50 K = 1, JM1 S = RM(J,K) RM(J,K) = RM(K,J) RM(K,J) = S 50 CONTINUE C CALL MMTX C IF (FEO) GO TO 70 DO 60 J = 1, 3 SS = 0.0 DO 55 K = 1, 3 SS = SS + RM(J,K)*VDIS(K) 55 CONTINUE RMV(J) = SS 60 CONTINUE C COD(1) = - RMV(1) + MM(1,3)*RMV(3) COD(2) = RM(1,3)/RM(3,3) COD(3) = - RMV(2) + MM(2,3)*RMV(3) COD(4) = RM(2,3)/RM(3,3) COD(5) = - RMV(3) DCOV = .TRUE. IF (BAX) R1P = .TRUE. C 70 R(1,1) = RM(1,1) - MM(1,3)*RM(3,1) R(1,2) = MM(1,1)*RMV(3) R(1,3) = RM(1,2) - MM(1,3)*RM(3,2) R(1,4) = MM(1,2)*RMV(3) R(2,2) = MM(1,1) R(2,4) = MM(1,2) R(3,1) = RM(2,1) - MM(2,3)*RM(3,1) R(3,2) = MM(2,1)*RMV(3) R(3,3) = RM(2,2) - MM(2,3)*RM(3,2) R(3,4) = MM(2,2)*RMV(3) R(4,2) = MM(2,1) R(4,4) = MM(2,2) C RETURN END SUBROUTINE MEXIT C C KNOWN MISALIGNMENT AT SECTION EXIT C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM7B.CIN' INCLUDE 'ELM8A.CIN' INCLUDE 'ELM8D.CIN' INCLUDE 'ELM8K.CIN' INCLUDE 'ELM10E.CIN' INCLUDE 'ELM13B.CIN' INCLUDE 'R.CIN' C C LOCAL VARIABLES C REAL VDIS1(3), VROT1(3), XTEMP(3) EQUIVALENCE (DX,VDIS(1)), (DY,VDIS(2)), (DZ,VDIS(3)) EQUIVALENCE (RX,VROT(1)), (RY,VROT(2)), (RZ,VROT(3)) C C------------------------------------------------------------------- CALL MVTODR C DO 20 J = 1, 3 SD = 0.0 SR = 0.0 DO 18 K = 1, 3 SD = SD + OR(J,K)*VDIS(K) SR = SR + OR(J,K)*VROT(K) 18 CONTINUE VDIS1(J) = SD VROT1(J) = SR 20 CONTINUE C DO 30 J = 1, 3 VDIS(J) = VDIS1(J) 30 VROT(J) = VROT1(J) C C ROTATION MATRIX FOR MAGNET C CALL MROT C DO 35 J = 1, 3 SS = 0.0 DO 32 K = 1, 3 SS = SS + OR(J,K)*XR(K) 32 CONTINUE XTEMP(J) = SS 35 CONTINUE C DO 50 J = 1, 3 SS = 0.0 DO 45 K = 1, 3 SS = SS + RM(J,K)*XTEMP(K) 45 CONTINUE VDIS(J) = VDIS(J) + SS 50 CONTINUE C CALL MMTX C IF (FEO) GO TO 60 COD(1) = DX - MM(1,3)*DZ COD(2) = RM(1,3)/RM(3,3) COD(3) = DY - MM(2,3)*DZ COD(4) = RM(2,3)/RM(3,3) COD(5) = DZ DCOV = .TRUE. IF (BAX) R1P = .TRUE. C 60 R(1,1) = RM(1,1) + MM(1,3)*RM(3,1) R(1,2) = - MM(1,1)*DZ R(1,3) = RM(1,2) + MM(1,3)*RM(3,2) R(1,4) = - MM(1,2)*DZ R(2,2) = MM(1,1) R(2,4) = MM(1,2) R(3,1) = RM(2,1) + MM(2,3)*RM(3,1) R(3,2) = - MM(2,1)*DZ R(3,3) = RM(2,2) + MM(2,3)*RM(3,2) R(3,4) = - MM(2,2)*DZ R(4,2) = MM(2,1) R(4,4) = MM(2,2) C RETURN END SUBROUTINE MIDENT C C IDENTIFIES POSITION OF MISALIGNMENTS ASSOCIATED WITH EACH UPDATE C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA0A.CIN' INCLUDE 'DATA1A.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM0D.CIN' INCLUDE 'ELM0F.CIN' INCLUDE 'ELM8A.CIN' INCLUDE 'ELM8F.CIN' INCLUDE 'ELM8G.CIN' INCLUDE 'ELM8H.CIN' INCLUDE 'ELM8M.CIN' INCLUDE 'ELM9.CIN' INCLUDE 'ELM24A.CIN' INCLUDE 'ELM31A.CIN' INCLUDE 'FLUSHC.CIN' INCLUDE 'INDPAR.CIN' C C LOCAL VARIABLES C INTEGER TYPES EQUIVALENCE (FAKE,LAKE) EXTERNAL IDATA C------------------------------------------------------------------ C NUM = 1 NDIF = 1 ALO(1) = .FALSE. ALO(2) = .FALSE. NM = 0 NUP(2) = 0 NUP(3) = 0 NIU(2) = 0 NIU(3) = 0 DO 5 N = 1, 10 5 NMTE(N) = 0 ATWORK = NUSE .EQ. 0 C IF (NEL .LE. 0) GO TO 5300 10 I = ISTOR(NUM) TYPE = IDATA(I) IF (TYPE .LE. 0 .OR. TYPE .GE. 50) GO TO 5200 CALL SKETCH(NUM) CALL DEPICT IF (.NOT. ATWE) GO TO 5200 IF (TYPE .EQ. 4) GO TO 400 IF (TYPE .EQ. 5) GO TO 500 IF (TYPE .EQ. 6) GO TO 600 IF (TYPE .EQ. 8) GO TO 800 IF (TYPE .EQ. 9) GO TO 900 IF (TYPE .EQ. 24) GO TO 2400 IF (TYPE .EQ. 28 .OR. TYPE .EQ. 29) GO TO 2800 IF (TYPE .EQ. 31) GO TO 3100 IF (TYPE .EQ. 37) GO TO 3700 GO TO 5200 C C 4. -- BENDING MAGNET C 400 IF (ALO(1)) THEN NMIS = NM4 IMIS = ISTOR(NMIS) TYT = INT(DATA(IMIS+7)) LTAB = MOD(TYT/10,10) IF (LTAB .EQ. 1) THEN IF (NM .LT. 10) THEN NM = NM + 1 NMTE(NM) = NUM ENDIF ENDIF ENDIF GO TO 5200 C C 5. -- QUADRUPOLE C 500 IF (ALO(2)) THEN NMIS = NM5 IMIS = ISTOR(NMIS) TYT = INT(DATA(IMIS+7)) LTAB = MOD(TYT/10,10) IF (LTAB .EQ. 1) THEN IF (NM .LT. 10) THEN NM = NM + 1 NMTE(NM) = NUM ENDIF ENDIF ENDIF GO TO 5000 C C 6. -- UPDATE C 600 IF (.NOT. ATWE) GO TO 5200 NSLIT = INT(DATA(I+1)) IF (NSLIT .EQ. 0) THEN IUP = INT(DATA(I+2)) NUP(IUP+1) = NUM LAKE = 0 IADR = I + IPTOJ(4) DATA(IADR) = FAKE ENDIF GO TO 5200 C C 8. -- MISALIGNMENT C 800 TYT = INT(DATA(I+7)) LFM = TYT/100 LTAB = MOD(TYT/10,10) RORC = MOD(TYT,10) IR = RORC + 1 IF (LTAB .EQ. 1 .AND. RORC .LE. 2 .AND. NM .LT. 10) THEN NM = NM + 1 NMTE(NM) = NUM ENDIF IF (RORC .GE. 3) GO TO 820 IF (RORC .EQ. 0) GO TO 5200 NUMS = NUP(IR) IF (NUMS .EQ. 0) THEN IF (LFM .EQ. 0) GO TO 5200 NUPS = NIU(IR) NUPS = NUPS + 1 NIU(IR) = NUPS NIM(IR,NUPS) = NUM ELSE IM = ISTOR(NUMS) TYPES = IDATA(IM) IF (LFM .NE. 0 .OR. TYPES .NE. 6) THEN CALL SKETCH(NUMS) IADR = IM + IPTOJ(4) NUPS = IDATA(IADR) NUPS = NUPS + 1 LAKE = NUPS DATA(IADR) = FAKE LAKE = NUM DATA(IADR+NUPS) = FAKE ENDIF ENDIF GO TO 5200 C 820 IF (RORC .EQ. 3 .OR. RORC .EQ. 4) THEN ALO(1) = .TRUE. NM4 = NUM ENDIF IF (RORC .EQ. 3 .OR. RORC .EQ. 5) THEN ALO(2) = .TRUE. NM5 = NUM ENDIF GO TO 5200 C C 9. -- REPEAT C 900 NREP = IDATA(I+1) CALL REPEAT IF (FLUSHL) GO TO 5300 GO TO 5200 C C 24. -- DEFINED SECTION C 2400 JDEF = IDATA(I+1) IF (JDEF .EQ. 3 .OR. JDEF .EQ. 4) THEN NADDEF(1) = IDATA(I+2) NADDEF(2) = IDATA(I+3) ENDIF CALL DEFINE IF (FLUSHL) GO TO 5300 GO TO 5200 C C 28. -- RECTANGULAR BENDING MAGNET C OR C 29. -- WEDGE BENDING MAGNET C 2800 IF (ALO(1)) THEN NMIS = NM4 IMIS = ISTOR(NMIS) TYT = INT(DATA(IMIS+7)) LTAB = MOD(TYT/10,10) IF (LTAB .EQ. 1) THEN IF (NM .LT. 10) THEN NM = NM + 1 NMTE(NM) = NUM ENDIF ENDIF ENDIF GO TO 5000 C C 31. -- POSITION MARKER C 3100 DRC = .FALSE. NMARKS = IDATA(I+1) CALL AGENDA(1) GO TO 5200 C C 37. -- ALIGNMENT MARKER C 3700 IF (.NOT. ATWE) GO TO 5200 NSLIT = INT(DATA(I+1)) IF (NSLIT .EQ. 0) THEN IUP = INT(DATA(I+2)) NUP(IUP+1) = NUM LAKE = 0 IADR = I + IPTOJ(4) DATA(IADR) = FAKE ENDIF GO TO 5200 C C LOOP THROUGH MISALIGNMENTS BY NAME C 5000 IF (NMISRB .NE. 0) CALL AGENDR(1) C C ADVANCE TO NEXT ELEMENT C 5200 IF (MKG .AND. NUM .EQ. NMARKE) CALL AGENDA(2) IF (ALGR .AND. NUM .EQ. NMISRE) CALL AGENDR(2) NUM = NUM + NDIF IF (.NOT. MKG .AND. NUSE .NE. 0 .AND. NUM .GT. NUSE) GO TO 5300 IF (NUM .LE. NEL) GO TO 10 C 5300 NMMAX = NM RETURN END SUBROUTINE MISGET C C GET PARAMETERS DESCRIBING MISALIGNMENT C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA0A.CIN' INCLUDE 'DATA1A.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM2B.CIN' INCLUDE 'ELM8A.CIN' INCLUDE 'ELM8B.CIN' INCLUDE 'ELM8G.CIN' INCLUDE 'ELM8L.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM15C.CIN' INCLUDE 'INDPAR.CIN' INCLUDE 'XRAN.CIN' C C LOCAL VARIABLES C INTEGER I2MOD, IMIS, INDX, J INTEGER MCF REAL DATAR EXTERNAL DATAR C C------------------------------------------------------------------- C MAGNITUDE OF ALIGNMENT IN EACH COORDINATE C IMIS = ISTOR(NMIS) VMMAX = 0.0 DO 10 J = 1, 6 I2MOD = 2 - MOD(J,2) INDX = IMIS + J VM(J) = DATAR(INDX)*UMIS(I2MOD) VMMAX = AMAX1(VMMAX,ABS(VM(J))) 10 CONTINUE C C ALIGNMENT CODE C TYT = INT(DATA(IMIS+7)) IF (VMMAX .EQ. 0.0 .AND. NV3 .EQ. 0) THEN TYT = 0 GO TO 40 ENDIF LFM = TYT/100 LTAB = MOD(TYT/10,10) IF (TYPE .EQ. 6 .OR. TYPE .EQ. 37) THEN RORC = MOD(TYT,10) IR = RORC + 1 NUPD = IR ENDIF C IF (IPTOJ(8) .EQ. 0) THEN MCF = MCFO ELSE MCF = INT(DATA(IMIS+8)) ENDIF TMK = MCF/100 CHORD = MOD(MCF/10,10) .EQ. 0 FEO = MOD(MCF,10) .EQ. 1 C C RANDOM MISALIGNMENT C IF (LFM .GE. 2) THEN IF (BEFORE) THEN IVMS(NUPD) = IVMS(NUPD) + 1 DO 20 J = 1, 6 VM(J) = VM(J)*XRAN(J) VMSAV(NUPD,IVMS(NUPD),J) = VM(J) 20 CONTINUE ELSE DO 30 J = 1, 6 VM(J) = VMSAV(NUPD,IVMS(NUPD),J) 30 CONTINUE IVMS(NUPD) = IVMS(NUPD) - 1 ENDIF ENDIF C 40 RETURN END SUBROUTINE MMTX C C ROTATION MATRIX FROM MISALIGNMENT APPLIED TO TRANSPORT COORDINATES, C DERIVED FROM TRANSFORMATION FOR THREE-SPACE COORDINATES C C LIST OF COMMON BLOCKS C INCLUDE 'ELM8K.CIN' C C LOCAL VARIABLES C C---------------------------------------------------------------- RM(1,1) = 1.0 + RM(1,1) RM(2,2) = 1.0 + RM(2,2) RM(3,3) = 1.0 + RM(3,3) C MM(1,1) = (RM(1,1) - RM(1,3)*RM(3,1)/RM(3,3))/RM(3,3) MM(1,2) = (RM(1,2) - RM(1,3)*RM(3,2)/RM(3,3))/RM(3,3) MM(1,3) = RM(1,3)/RM(3,3) MM(2,1) = (RM(2,1) - RM(2,3)*RM(3,1)/RM(3,3))/RM(3,3) MM(2,2) = (RM(2,2) - RM(2,3)*RM(3,2)/RM(3,3))/RM(3,3) MM(2,3) = RM(2,3)/RM(3,3) C RETURN END SUBROUTINE MPRINT C C PRINT FLOOR COORDINATES, BEAM AND TRANSFER MATRICES AFTER C EACH ELEMENT C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'COP.CIN' INCLUDE 'DATA2D.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM0C.CIN' INCLUDE 'ELM1A.CIN' INCLUDE 'ELM1D.CIN' INCLUDE 'ELM13A.CIN' INCLUDE 'ELM13B.CIN' INCLUDE 'ELM13C.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'ELM38A.CIN' C C LOCAL VARIABLES C LOGICAL BACC, BCOMB, BNORM, BSPEC LOGICAL SFO, TCOMB, TNORM, TSPEC, TYPEQ1 C C-------------------------------------------------------------- IF (ONLY) GO TO 300 IF (TYPE .LE. 0) GO TO 300 C C PRINT COMPLETE ARBITRARY MATRIX C IF (PRON .AND. ELPR .AND. TYPE .EQ. 14) THEN CDB = 14 CALL RCOUT ENDIF C C PRINT BEAM ELLIPSE, TRANSFER MATRIX, AND COORDINATES C IF (.NOT. NBE) GO TO 300 LCPR = .FALSE. IF (.NOT. PRON) GO TO 300 BDUN = .FALSE. TDUN = .FALSE. IF (NRT) RDUN = .FALSE. IF (.NOT. ELPR) GO TO 300 IF (LAY) CALL SURVEY IF (SONLY) GO TO 300 C BACC = ACCEL .OR. LTWISS IF ((BACC .OR. NORD1 .EQ. 1) 1 .AND. .NOT. RECENT) CALL BEAM TYPEQ1 = TYPE .EQ. 1 .OR. TYPE .EQ. 12 SFO = SOFA .OR. NORD3 .GE. 1 BNORM = NOR .AND. .NOT. ACCEL BSPEC = .NOT. NOR .AND. .NOT. BACC .AND. TYPEQ1 .AND. .NOT. SUPP BCOMB = BNORM .OR. BSPEC IF (LBEAM .AND. BCOMB .AND. SFO .AND. .NOT. BDUN) CALL QEO C TNORM = TWP .OR. (NOR .AND. ACCEL) TSPEC = .NOT. TWP .AND. BACC .AND. TYPEQ1 .AND. .NOT. SUPP TCOMB = TNORM .OR. TSPEC IF (LBEAM .AND. TCOMB .AND. SFO .AND. .NOT. TDUN) CALL TWISS C IF (RAT .AND. NRT .AND. (TERSE .OR. SOFA .OR. NORD3 .GE. 1) 1 .AND. .NOT. RDUN) THEN CDB = 6 CALL RCOUT ENDIF C TYPED = TYPE IF (PLOT .AND. LPLOT .AND. NPASS .EQ. 2) CALL PLOTIT C 300 RETURN END SUBROUTINE MR2RC C C MULTIPLIES RC2 AND RC AND STORES RESULT IN RC C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'RC.CIN' INCLUDE 'RCP.CIN' INCLUDE 'RC2.CIN' INCLUDE 'RS.CIN' INCLUDE 'TC.CIN' INCLUDE 'TC2.CIN' INCLUDE 'TS.CIN' INCLUDE 'UC.CIN' INCLUDE 'UC2.CIN' INCLUDE 'US.CIN' C C--------------------------------------------------------------------- IF (RCP) GO TO 50 DO 10 JK = 1, 36 10 RSL(JK) = RC2L(JK) IF (NORD2 .GE. 2) THEN DO 20 JKM = 1, 105 20 TSL(JKM) = TC2L(JKM) ENDIF IF (NORD2 .GE. 3) THEN DO 30 JKLM = 1, 280 30 USL(JKLM) = UC2L(JKLM) ENDIF GO TO 100 C 50 IF (NORD2 .EQ. 1) THEN CALL CAB(RS,RC2,RC) ELSE IF (NORD2 .EQ. 2) THEN CALL CAB2(RS,TS,RC2,TC2,RC,TC) ELSE IF (NORD2 .EQ. 3) THEN CALL CAB3(RS,TS,US,RC2,TC2,UC2,RC,TC,UC) ENDIF C 100 RETURN END SUBROUTINE MR3R2 C C MULTIPLIES RC3 AND RC2 AND STORES RESULT IN RC2 C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'RC2.CIN' INCLUDE 'R2P.CIN' INCLUDE 'RC3.CIN' INCLUDE 'RS.CIN' INCLUDE 'TC2.CIN' INCLUDE 'TC3.CIN' INCLUDE 'TS.CIN' INCLUDE 'UC2.CIN' INCLUDE 'UC3.CIN' INCLUDE 'US.CIN' C C-------------------------------------------------------------------- IF (R2P) GO TO 50 DO 10 JK = 1, 36 10 RC2L(JK) = RC3L(JK) IF (NORD2 .GE. 2) THEN DO 20 JKM = 1, 105 20 TC2L(JKM) = TC3L(JKM) ENDIF IF (NORD2 .GE. 3) THEN DO 30 JKLM = 1, 280 30 UC2L(JKLM) = UC3L(JKLM) ENDIF GO TO 100 C 50 IF (NORD2 .EQ. 1) THEN CALL CAB(RS,RC3,RC2) ELSE IF (NORD2 .EQ. 2) THEN CALL CAB2(RS,TS,RC3,TC3,RC2,TC2) ELSE IF (NORD2 .EQ. 3) THEN CALL CAB3(RS,TS,US,RC3,TC3,UC3,RC2,TC2,UC2) ENDIF C DO 60 JK = 1, 36 60 RC2L(JK) = RSL(JK) IF (NORD2 .GE. 2) THEN DO 70 JKM = 1, 105 70 TC2L(JKM) = TSL(JKM) ENDIF IF (NORD2 .GE. 3) THEN DO 80 JKLM = 1, 280 80 UC2L(JKLM) = USL(JKLM) ENDIF C 100 RETURN END SUBROUTINE MR3R2V(N) C C MULTIPLIES RC2 AND R2V AND STORES RESULT IN R2V C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'R2VT.CIN' INCLUDE 'RC2.CIN' INCLUDE 'RC3.CIN' INCLUDE 'RS.CIN' INCLUDE 'T2VT.CIN' INCLUDE 'TC2.CIN' INCLUDE 'TC3.CIN' INCLUDE 'TS.CIN' INCLUDE 'U2VT.CIN' INCLUDE 'UC2.CIN' INCLUDE 'UC3.CIN' INCLUDE 'US.CIN' C C--------------------------------------------------------------------- DO 10 JK = 1, 36 10 R2VTL(JK) = R2VL(JK,N) IF (NORD2 .GE. 2) THEN DO 20 JKL = 1, 105 T2VTL(JKL) = T2VL(JKL,N) 20 CONTINUE ENDIF IF (NORD2 .GE. 3) THEN DO 30 JKL = 1, 280 U2VTL(JKL) = U2VL(JKL,N) 30 CONTINUE ENDIF C IF (NORD2 .EQ. 1) THEN CALL CAB(RS,RC3,R2VT) ELSE IF (NORD2 .EQ. 2) THEN CALL CABD2(RS,TS,RC3,TC3,RC2,R2VT,T2VT) ELSE IF (NORD2 .EQ. 3) THEN CALL CABD3(RS,TS,US,RC3,TC3,UC3,RC2,TC2, > R2VT,T2VT,U2VT) ENDIF C DO 50 JK = 1, 36 50 R2VL(JK,N) = RSL(JK) IF (NORD2 .GE. 2) THEN DO 60 JKM = 1, 105 60 T2VL(JKM,N) = TSL(JKM) ENDIF IF (NORD2 .GE. 3) THEN DO 70 JKLM = 1, 280 70 U2VL(JKLM,N) = USL(JKLM) ENDIF C RETURN END SUBROUTINE MREC C C RESTORES RC2 TO VALUES AT BEGINNING OF FITTED SECTION C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'R.CIN' INCLUDE 'RC.CIN' INCLUDE 'RCP.CIN' INCLUDE 'RCPS.CIN' INCLUDE 'RCS.CIN' INCLUDE 'RC2.CIN' INCLUDE 'RC2S.CIN' INCLUDE 'RSS.CIN' INCLUDE 'R0P.CIN' INCLUDE 'R0PS.CIN' INCLUDE 'R2P.CIN' INCLUDE 'R2PS.CIN' INCLUDE 'R3P.CIN' INCLUDE 'T.CIN' INCLUDE 'TC2.CIN' INCLUDE 'TC2S.CIN' INCLUDE 'TSS.CIN' INCLUDE 'UC2.CIN' INCLUDE 'UC2S.CIN' C C------------------------------------------------------------------ R0P = R0PS DO 10 J = 1, 36 RL(J) = RSSL(J) RCL(J) = RCSL(J) 10 RC2L(J) = RC2SL(J) RCP = RCPS IF (NORD1 .GE. 2) THEN DO 20 J = 1, 105 TL(J) = TSSL(J) 20 TC2L(J) = TC2SL(J) ENDIF IF (NORD1 .GE. 3) THEN DO 30 J = 1, 280 30 UC2L(J) = UC2SL(J) ENDIF R2P = R2PS R3P = .FALSE. RETURN END SUBROUTINE MRET C C STORES VALUES OF RC2 AT BEGINNING OF FITTED SECTION C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'R.CIN' INCLUDE 'RC.CIN' INCLUDE 'RCP.CIN' INCLUDE 'RCPS.CIN' INCLUDE 'RCS.CIN' INCLUDE 'RC2.CIN' INCLUDE 'RC2S.CIN' INCLUDE 'RSS.CIN' INCLUDE 'R0P.CIN' INCLUDE 'R0PS.CIN' INCLUDE 'R2P.CIN' INCLUDE 'R2PS.CIN' INCLUDE 'T.CIN' INCLUDE 'TC2.CIN' INCLUDE 'TC2S.CIN' INCLUDE 'TSS.CIN' INCLUDE 'UC2.CIN' INCLUDE 'UC2S.CIN' C C------------------------------------------------------------------- R0PS = R0P DO 10 J = 1, 36 RSSL(J) = RL(J) RCSL(J) = RCL(J) 10 RC2SL(J) = RC2L(J) RCPS = RCP R2PS = R2P IF (NORD1 .GE. 2) THEN DO 20 J = 1, 105 TSSL(J) = TL(J) 20 TC2SL(J) = TC2L(J) ENDIF IF (NORD1 .GE. 3) THEN DO 30 J = 1, 280 30 UC2SL(J) = UC2L(J) ENDIF RETURN END SUBROUTINE MROT C C CALCULATES MISALIGNMENT ROTATION MATRIX C C LIST OF COMMON BLOCKS C INCLUDE 'ELM8K.CIN' C C LOCAL VARIABLES C EQUIVALENCE (RX,VROT(1)), (RY,VROT(2)), (RZ,VROT(3)) C C-------------------------------------------------------------- SN = SNM ZN = ZNM C RM(1,1) = - (1.0 - RX**2)*ZN RM(1,2) = - RZ*SN + RX*RY*ZN RM(1,3) = RY*SN + RX*RZ*ZN RM(2,1) = RZ*SN + RX*RY*ZN RM(2,2) = - (1.0 - RY**2)*ZN RM(2,3) = - RX*SN + RY*RZ*ZN RM(3,1) = - RY*SN + RX*RZ*ZN RM(3,2) = RX*SN + RY*RZ*ZN RM(3,3) = - (1.0 - RZ**2)*ZN RETURN END SUBROUTINE MRR2 C C MULTIPLIES R AND RC2 AND STORES RESULT IN RC2 C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'R.CIN' INCLUDE 'RC2.CIN' INCLUDE 'R2P.CIN' INCLUDE 'RS.CIN' INCLUDE 'T.CIN' INCLUDE 'TC2.CIN' INCLUDE 'TS.CIN' INCLUDE 'U.CIN' INCLUDE 'UC2.CIN' INCLUDE 'US.CIN' C C----------------------------------------------------------------- IF (R2P) GO TO 50 DO 10 JK = 1, 36 10 RC2L(JK) = RL(JK) IF (NORD2 .GE. 2) THEN DO 20 JKM = 1, 105 20 TC2L(JKM) = TL(JKM) ENDIF IF (NORD2 .GE. 3) THEN DO 30 JKLM = 1, 280 30 UC2L(JKLM) = UL(JKLM) ENDIF GO TO 100 C 50 IF (NORD2 .EQ. 1) THEN CALL CAB(RS,R,RC2) ELSE IF (NORD2 .EQ. 2) THEN CALL CAB2(RS,TS,R,T,RC2,TC2) ELSE IF (NORD2 .GE. 3) THEN CALL CAB3(RS,TS,US,R,T,U,RC2,TC2,UC2) ENDIF C DO 60 JK = 1, 36 60 RC2L(JK) = RSL(JK) IF (NORD2 .GE. 2) THEN DO 70 JKM = 1, 105 70 TC2L(JKM) = TSL(JKM) ENDIF IF (NORD2 .GE. 3) THEN DO 80 JKLM = 1, 280 80 UC2L(JKLM) = USL(JKLM) ENDIF C 100 RETURN END SUBROUTINE MRR2V C C MULTIPLIES RSH AND R2V AND STORES RESULT IN R2V C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'R2VS.CIN' INCLUDE 'R2VT.CIN' INCLUDE 'RC2.CIN' INCLUDE 'RC3.CIN' INCLUDE 'RS.CIN' INCLUDE 'T2VT.CIN' INCLUDE 'TC2.CIN' INCLUDE 'TC3.CIN' INCLUDE 'TS.CIN' INCLUDE 'U2VS.CIN' INCLUDE 'U2VT.CIN' INCLUDE 'UC2.CIN' INCLUDE 'UC3.CIN' INCLUDE 'US.CIN' C C----------------------------------------------------------------- N = NV2 DO 10 JK = 1, 36 R2VTL(JK) = R2VL(JK,N) 10 CONTINUE IF (NORD2 .GE. 2) THEN DO 20 JKL = 1, 105 T2VTL(JKL) = T2VL(JKL,N) 20 CONTINUE ENDIF IF (NORD2 .GE. 3) THEN DO 30 JKL = 1, 280 U2VTL(JKL) = U2VL(JKL,N) 30 CONTINUE ENDIF C IF (NORD2 .EQ. 1) THEN CALL CAB(RS,RSH,R2VT) ELSE IF (NORD2 .EQ. 2) THEN CALL CABD2(RS,TS,RSH,TSH,RC2,R2VT,T2VT) ELSE IF (NORD2 .GE. 3) THEN CALL CABD3(RS,TS,US,RSH,TSH,USH,RC2,TC2, > R2VT,T2VT,U2VT) ENDIF C DO 50 JK = 1, 36 50 R2VSL(JK,N) = RSL(JK) IF (NORD2 .GE. 2) THEN DO 60 IJK = 1, 105 60 T2VL(IJK,N) = TSL(IJK) ENDIF IF (NORD2 .GE. 3) THEN DO 70 IJKL = 1, 280 70 U2VL(IJKL,N) = USL(IJKL) ENDIF RETURN END SUBROUTINE MRR3 C C MULTIPLIES R AND RC3 AND STORES RESULT IN RC3 C C LIST OF COMMON BLOCKS C INCLUDE 'ELM17A.CIN' INCLUDE 'R.CIN' INCLUDE 'RC3.CIN' INCLUDE 'RS.CIN' INCLUDE 'R3P.CIN' INCLUDE 'T.CIN' INCLUDE 'TC3.CIN' INCLUDE 'TS.CIN' INCLUDE 'U.CIN' INCLUDE 'UC3.CIN' INCLUDE 'US.CIN' C C--------------------------------------------------------------- IF (R3P) GO TO 50 DO 10 JK = 1, 36 10 RC3L(JK) = RL(JK) IF (NORD2 .GE. 2) THEN DO 20 JKM = 1, 105 20 TC3L(JKM) = TL(JKM) ENDIF IF (NORD2 .GE. 3) THEN DO 30 JKLM = 1, 280 30 UC3L(JKLM) = UL(JKLM) ENDIF GO TO 100 C 50 IF (NORD2 .EQ. 1) THEN CALL CAB(RS,R,RC3) ELSE IF (NORD2 .EQ. 2) THEN CALL CAB2(RS,TS,R,T,RC3,TC3) ELSE IF (NORD2 .GE. 3) THEN CALL CAB3(RS,TS,US,R,T,U,RC3,TC3,UC3) ENDIF C DO 60 JK = 1, 36 60 RC3L(JK) = RSL(JK) IF (NORD2 .GE. 2) THEN DO 70 JKM = 1, 105 70 TC3L(JKM) = TSL(JKM) ENDIF IF (NORD2 .GE. 3) THEN DO 80 JKLM = 1, 280 80 UC3L(JKLM) = USL(JKLM) ENDIF C 100 RETURN END SUBROUTINE MRTR2 C C MULTIPLIES RT AND RC2 AND ADDS RESULT TO R2V C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'R2VS.CIN' INCLUDE 'RC2.CIN' INCLUDE 'RS.CIN' INCLUDE 'R2P.CIN' INCLUDE 'TC2.CIN' INCLUDE 'TS.CIN' INCLUDE 'UC2.CIN' INCLUDE 'US.CIN' C C--------------------------------------------------------- N = NV2 IF (R2P) GO TO 50 DO 10 JK = 1, 36 10 R2VSL(JK,N) = RTL(JK) IF (NORD2 .GE. 2) THEN DO 20 IJK = 1, 105 20 T2VL(IJK,N) = TTL(IJK) ENDIF IF (NORD2 .GE. 3) THEN DO 30 IJKL = 1, 280 30 U2VL(IJKL,N) = UTL(IJKL) ENDIF R2VP(N) = .TRUE. GO TO 200 C 50 IF (NORD2 .EQ. 1) THEN CALL CAB(RS,RT,RC2) ELSE IF (NORD2 .EQ. 2) THEN CALL CAB2(RS,TS,RT,TT,RC2,TC2) ELSE IF (NORD2 .GE. 3) THEN CALL CAB3(RS,TS,US,RT,TT,UT,RC2,TC2,UC2) ENDIF C IF (R2VP(N)) GO TO 100 DO 60 JK = 1, 36 60 R2VSL(JK,N) = RSL(JK) IF (NORD2 .GE. 2) THEN DO 70 IJK = 1, 105 70 T2VL(IJK,N) = TSL(IJK) ENDIF IF (NORD2 .GE. 3) THEN DO 80 IJKL = 1, 280 80 U2VL(IJKL,N) = USL(IJKL) ENDIF R2VP(N) = .TRUE. GO TO 200 C 100 DO 110 JK = 1, 36 110 R2VSL(JK,N) = R2VSL(JK,N) + RSL(JK) IF (NORD2 .GE. 2) THEN DO 120 IJK = 1, 105 120 T2VL(IJK,N) = T2VL(IJK,N) + TSL(IJK) ENDIF IF (NORD2 .GE. 3) THEN DO 130 IJKL = 1, 280 130 U2VL(IJKL,N) = U2VL(IJKL,N) + USL(IJKL) ENDIF C 200 RETURN END SUBROUTINE MRVRC2 C C MULTIPLIES RV AND RC2 AND ADDS RESULT TO R2V C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'R.CIN' INCLUDE 'R2VS.CIN' INCLUDE 'RC2.CIN' INCLUDE 'RC2S.CIN' INCLUDE 'RS.CIN' INCLUDE 'R2P.CIN' INCLUDE 'T.CIN' INCLUDE 'TC2.CIN' INCLUDE 'TC2S.CIN' INCLUDE 'TS.CIN' INCLUDE 'U.CIN' INCLUDE 'U2VS.CIN' INCLUDE 'UC2.CIN' INCLUDE 'UC2S.CIN' INCLUDE 'US.CIN' C C--------------------------------------------------------- IF (R2P) GO TO 50 DO 10 JK = 1, 36 10 R2VSL(JK,NV2) = RVL(JK) IF (NORD2 .GE. 2) THEN DO 20 JKM = 1, 105 20 T2VL(JKM,NV2) = TVL(JKM) ENDIF IF (NORD2 .GE. 3) THEN DO 30 JKLM = 1, 280 30 U2VL(JKLM,NV2) = UVL(JKLM) ENDIF GO TO 200 C 50 IF (NORD2 .EQ. 1) THEN CALL CAB(RS,RV,RC2) ELSE IF (NORD2 .EQ. 2) THEN CALL CAB2(RS,TS,RV,TV,RC2,TC2) ELSE IF (NORD2 .EQ. 3) THEN CALL CAB3(RS,TS,US,RV,TV,UV,RC2,TC2,UC2) ENDIF IF (R2VP(NV2)) GO TO 100 C DO 60 JK = 1, 36 60 R2VSL(JK,NV2) = RSL(JK) IF (NORD2 .GE. 2) THEN DO 70 JKM = 1, 105 70 T2VL(JKM,NV2) = TSL(JKM) ENDIF IF (NORD2 .GE. 3) THEN DO 80 JKLM = 1, 280 80 U2VL(JKLM,NV2) = USL(JKLM) ENDIF GO TO 200 C 100 DO 110 JK = 1, 36 110 R2VSL(JK,NV2) = R2VSL(JK,NV2) + RSL(JK) IF (NORD2 .GE. 2) THEN DO 120 JKM = 1, 105 120 T2VL(JKM,NV2) = T2VL(JKM,NV2) + TSL(JKM) ENDIF IF (NORD2 .GE. 2) THEN DO 130 JKLM = 1, 280 130 U2VL(JKLM,NV2) = U2VL(JKLM,NV2) + USL(JKLM) ENDIF C 200 RETURN END SUBROUTINE MUNCH C C CALCULATES EFFECT OF UNCERTAIN MISALIGNMENTS C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'COCOM.CIN' INCLUDE 'COP.CIN' INCLUDE 'ELM0B.CIN' INCLUDE 'ELM0E.CIN' INCLUDE 'ELM1C.CIN' INCLUDE 'ELM1D.CIN' INCLUDE 'ELM7C.CIN' INCLUDE 'ELM8A.CIN' INCLUDE 'ELM8B.CIN' INCLUDE 'ELM8D.CIN' INCLUDE 'ELM8E.CIN' INCLUDE 'ELM8H.CIN' INCLUDE 'ELM8J.CIN' INCLUDE 'ELM8M.CIN' INCLUDE 'ELM13A.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'RS.CIN' INCLUDE 'SI.CIN' C C LOCAL VARIABLES C INTEGER J, JKL, JPK, K, K2, KPJ INTEGER L1, L2, LL, M, MM, N REAL CTT(6,6), CT0P(3,3), CT0L(36), CT0PL(9), 1 CT1L(9) REAL GTL(180) REAL S, ZAP EQUIVALENCE (CT0(1,1),CT0L(1)), (CT0P(1,1),CT0PL(1)), 1 (CT1(1,1),CT1L(1)) EQUIVALENCE (GT(1,1,1),GTL(1)) C C---------------------------------------------------------------- C TRANSFORMATION OF COORDINATE SYSTEM BETWEEN MISALIGNMENT C PIVOT AND EXIT FACE C DO 5 J = 1, 9 5 CT1L(J) = 0.0 DO 8 J = 1, 36 8 CT0L(J) = 0.0 DO 9 J = 1, 9 9 CT0PL(J) = 0.0 C CALL OGET CALL PIVENT CALL PIVEX C C TRANSFORMATION FROM MISALIGNMENT COORDINATES TO TRAJECTORY C COORDINATES AT ENTRANCE FACE C CT0P(1,2) = XT(3) CT0P(2,1) = - CT0P(1,2) CT0P(3,1) = XT(2) CT0P(1,3) = - CT0P(3,1) CT0P(2,3) = XT(1) CT0P(3,2) = - CT0P(2,3) C DO 110 J = 1, 3 DO 110 K = 1, 3 CT0(2*J-1,2*K-1) = OT(J,K) 110 CONTINUE C DO 120 K = 1, 3 CT0(2,2*K) = OT(2,K) CT0(4,2*K) = - OT(1,K) 120 CONTINUE C DO 160 J = 1, 3 DO 160 K = 1, 3 S = 0.0 DO 150 N = 1, 3 S = S + CT0P(J,N)*OT(N,K) 150 CONTINUE CT0(2*J-1,2*K) = S 160 CONTINUE C C TRANSFORMATION AT EXIT FACE C CT1(1,2) = - XR(3) CT1(2,1) = - CT1(1,2) CT1(3,1) = - XR(2) CT1(1,3) = - CT1(3,1) CT1(2,3) = - XR(1) CT1(3,2) = - CT1(2,3) C C EFFECT OF MISALIGNMENT ON CENTROID DISPLACEMENT C 300 CALL TFL C IF (IR .EQ. 1) CDB = 14 IF (IR .EQ. 2) CDB = 4 IF (IR .EQ. 3) CDB = 24 CALL RCALC C C BILINEAR TERMS C DO 320 JKL = 1, 180 320 GTL(JKL) = 0.0 C IF (NORD3 .LT. 1 .AND. .NOT. SPO(IR)) GO TO 400 DO 330 J = 1, 5 DO 325 K = 1, 6 GT(J,2,K) = RS(J,1)*CT0(5,K) GT(J,4,K) = RS(J,3)*CT0(5,K) 325 CONTINUE DO 327 K = 1, 3 K2 = 2*K GT(J,1,K2) = - RS(J,3)*OT(3,K) GT(J,2,K2) = GT(J,2,K2) - RS(J,4)*OT(3,K) GT(J,3,K2) = RS(J,1)*OT(3,K) GT(J,4,K2) = GT(J,4,K2) + RS(J,2)*OT(3,K) 327 CONTINUE 330 CONTINUE C DO 360 J = 1, 6 DO 340 K = 1, 6 GT(1,J,K) = GT(1,J,K) - CT(5,K)*RS(2,J) GT(3,J,K) = GT(3,J,K) - CT(5,K)*RS(4,J) 340 CONTINUE DO 350 K = 1, 3 K2 = 2*K GT(1,J,K2) = GT(1,J,K2) - OR(3,K)*RS(3,J) GT(2,J,K2) = GT(2,J,K2) - OR(3,K)*RS(4,J) GT(3,J,K2) = GT(3,J,K2) + OR(3,K)*RS(1,J) GT(4,J,K2) = GT(4,J,K2) + OR(3,K)*RS(2,J) 350 CONTINUE 360 CONTINUE C C IMAGE OF DISPLACED CENTROID AT ENTRANCE FACE C 400 DO 420 J = 1, 6 DO 420 K = 1, 6 S = 0.0 DO 415 N = 1, 6 S = S + RS(J,N)*CT0(N,K) 415 CONTINUE CTT(J,K) = CT(J,K) CT(J,K) = CT(J,K) - S 420 CONTINUE DO 460 J = 1, 6 460 CONTINUE C IF (.NOT. SOFA) GO TO 470 DO 430 J = 1, 5 DO 425 K = 1, 6 CT(J,K) = CT(J,K) + RS(J,1)*CT0(5,K)*COLD(IR,2) CT(J,K) = CT(J,K) + RS(J,3)*CT0(5,K)*COLD(IR,4) 425 CONTINUE DO 427 K = 1, 3 K2 = 2*K CT(J,K2) = CT(J,K2) - RS(J,3)*OT(3,K)*COLD(IR,1) CT(J,K2) = CT(J,K2) - RS(J,4)*OT(3,K)*COLD(IR,2) CT(J,K2) = CT(J,K2) + RS(J,1)*OT(3,K)*COLD(IR,3) CT(J,K2) = CT(J,K2) + RS(J,2)*OT(3,K)*COLD(IR,4) 427 CONTINUE 430 CONTINUE C DO 440 K = 1, 6 CT(1,K) = CT(1,K) - CTT(5,K)*CEN(2) CT(3,K) = CT(3,K) - CTT(5,K)*CEN(4) 440 CONTINUE DO 450 K = 1, 3 K2 = 2*K CT(1,K2) = CT(1,K2) - OR(3,K)*CEN(3) CT(2,K2) = CT(2,K2) - OR(3,K)*CEN(4) CT(3,K2) = CT(3,K2) + OR(3,K)*CEN(1) CT(4,K2) = CT(4,K2) + OR(3,K)*CEN(2) 450 CONTINUE C 470 IF (NORD1 .GT. 1) CALL FRAME2 C C UNCERTAINTY IN POSITION SHOWN IN BEAM MATRIX C 500 IF (LTAB .NE. 0) GO TO 600 C IF (NORD3 .LT. 1) GO TO 900 DO 550 J = 1, 5 DO 550 K = 1, J S = 0.0 IF (FEO) GO TO 520 DO 510 N = 1, 6 ZAP = CT(J,N)*CT(K,N)*VM(N)**2 S = S + ZAP 510 CONTINUE C 520 IF (.NOT. SPO(IR)) GO TO 530 DO 525 LL = 1, 6 DO 525 M = 1, 6 ZAP = (CT(J,M)*GT(K,LL,M) + CT(K,M)*GT(J,LL,M))*COLD(IR,LL)* 1 VM(M)**2 S = S + ZAP 525 CONTINUE C 530 DO 535 L1 = 1, 6 DO 535 L2 = 1, 6 DO 535 M = 1, 6 ZAP = GT(J,L1,M)*GT(K,L2,M)*SIOL(IR,L1,L2)*VM(M)**2 S = S + ZAP 535 CONTINUE 540 SI(J,K) = SI(J,K) + S SI(K,J) = SI(J,K) 550 CONTINUE C RECENT = .FALSE. NOPH = .FALSE. GO TO 900 C C UNCERTAINTY IN POSITION SHOWN IN MISALIGNMENT TABLE C 600 LMIS(1,NM) = LUP(IR) LMIS(2,NM) = LC IF (.NOT. SOFA) THEN DO 605 J = 1, 6 DO 605 M = 1, 6 COM(J,M,NM) = 0.0 605 CONTINUE ELSE DO 610 J = 1, 6 DO 610 M = 1, 6 COM(J,M,NM) = CO(J) 610 CONTINUE ENDIF C 620 IF (NORD3 .LT. 1) GO TO 900 DO 650 J = 1, 6 DO 650 K = 1, J JPK = 6*J + K - 6 KPJ = 6*K + J - 6 MM = 0 DO 650 M = 1, 6 MM = MM + M S = 0.0 IF (J .LE. 5) THEN IF (FEO) GO TO 630 S = CT(J,M)*CT(K,M)*VM(M)**2 IF (SPO(IR)) THEN DO 625 LL = 1, 6 S = S + (CT(J,M)*GT(K,LL,M) + CT(K,M)*GT(J,LL,M))* 1 COLD(IR,LL)*VM(M)**2 625 CONTINUE ENDIF C 630 DO 635 L1 = 1, 6 DO 635 L2 = 1, 6 S = S + GT(J,L1,M)*GT(K,L2,M)*SIOL(IR,L1,L2)*VM(M)**2 635 CONTINUE ENDIF 640 SIM(JPK,M,NM) = SI(J,K) + S SIM(KPJ,M,NM) = SIM(JPK,M,NM) 650 CONTINUE C 900 DMC = .FALSE. RETURN END SUBROUTINE MVTODR C C CALCULATES DISPLACEMENTS AND ROTATION ANGLE FOR MISALIGNMENTS C C LIST OF COMMON BLOCKS C INCLUDE 'ELM8B.CIN' INCLUDE 'ELM8K.CIN' C C LOCAL VARIABLES C EQUIVALENCE (RX,VROT(1)), (RY,VROT(2)), (RZ,VROT(3)) C C------------------------------------------------------------ DO 10 J = 1, 3 VDIS(J) = VM(2*J-1) 10 VROT(J) = VM(2*J) THMIS = SQRT(RX**2 + RY**2 + RZ**2) SNM = SIN(THMIS) CSM = COS(THMIS) ZNM = SNM**2/(1.0 + CSM) IF (THMIS .NE. 0) THEN RX = RX/THMIS RY = RY/THMIS RZ = RZ/THMIS ENDIF RETURN END SUBROUTINE MVZERO C C ZEROS INDIVIDUAL TRANSFER MATRIX C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM0E.CIN' INCLUDE 'ELM7B.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'R.CIN' INCLUDE 'T.CIN' INCLUDE 'U.CIN' C C----------------------------------------------------------------- LV = 0.0 DO 10 J = 1, 6 10 CODV(J) = 0.0 DO 20 JK = 1, 36 20 RVL(JK) = 0.0 IF (NORD1 .GE. 2) THEN DO 30 JKM = 1, 105 30 TVL(JKM) = 0.0 ENDIF IF (NORD1 .GE. 3) THEN DO 40 JKLM = 1, 280 40 UVL(JKLM) = 0.0 ENDIF C RETURN END SUBROUTINE NAME10 C C FIND MATRIX ELEMENT NAME FOR CONSTRAINT C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA1A.CIN' INCLUDE 'DATA1C.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM10C.CIN' INCLUDE 'RDCHAR.CIN' C C LOCAL VARIABLES C CHARACTER*1 FTCHAR(8) EQUIVALENCE (FTNAME,FTCHAR(1)) C C------------------------------------------------------------- FTNAME = BLANK J = JCON K = KCON IF (J .EQ. 0 .AND. K .EQ. 0) GO TO 100 IF (J .EQ. 8) GO TO 110 IF (J .EQ. 9) GO TO 135 IF (J .EQ. 18) GO TO 550 IF (J .EQ. 100) GO TO 600 GO TO 140 C C SYSTEM LENGTH CONSTRAINT C 100 FTNAME = 'LENGTH' GO TO 1000 C C FLOOR COORDINATE CONSTRAINT C 110 IF (K .EQ. 1) FTNAME = 'XFLOOR' IF (K .EQ. 2) FTNAME = 'YFLOOR' IF (K .EQ. 3) FTNAME = 'ZFLOOR' IF (K .EQ. 4) FTNAME = 'YAW' IF (K .EQ. 5) FTNAME = 'PITCH' IF (K .EQ. 6) FTNAME = 'ROLL' IF (K .EQ. 7) FTNAME = 'ELEVATIO' GO TO 1000 C C CONSTRAINT ON ALGEBRAIC COMBINATION OF MATRIX ELEMENTS C 135 FTNAME = 'ALGEBRA' DO 136 N = 1, NEL II = ISTOR(N) IF (II+1 .EQ. KCON) THEN IF (LABEL(N) .NE. BLANK) THEN FTNAME = LABEL(N)(1:8) GO TO 137 ENDIF ENDIF 136 CONTINUE 137 GO TO 1000 C C TRANSFER MATRIX CONSTRAINTS C 140 IF (J .LT. - 20) GO TO 150 IF (J .LT. - 10) GO TO 200 IF (J .LT. 0) GO TO 250 GO TO 300 C C R2 MATRIX CONSTRAINT C 150 J = - (J + 20) IF (K .GT. 10) GO TO 180 FTCHAR(1) = 'R' FTCHAR(2) = 'A' FTCHAR(3) = TABLE(J+1) FTCHAR(4) = TABLE(K+1) GO TO 1000 C C T2 MATRIX CONSTRAINT C 180 IF (K .GT. 100) GO TO 190 KM = K K = KM/10 M = KM - 10*K FTCHAR(1) = 'T' FTCHAR(2) = 'A' FTCHAR(3) = TABLE(J+1) FTCHAR(4) = TABLE(K+1) FTCHAR(5) = TABLE(M+1) GO TO 1000 C C U2 MATRIX CONSTRAINT C 190 KLM = K K = KLM/100 LM = KLM - 100*K LL = LM/10 M = LM - 10*LL FTCHAR(1) = 'U' FTCHAR(2) = 'A' FTCHAR(3) = TABLE(J+1) FTCHAR(4) = TABLE(K+1) FTCHAR(5) = TABLE(LL+1) FTCHAR(6) = TABLE(M+1) GO TO 1000 C C AGS MACHINE CONSTRAINT C 200 J = - (J + 10) IF (J .EQ. 1) THEN FTNAME = 'MUX' ELSE IF (J .EQ. 3) THEN FTNAME = 'MUY' ELSE IF (J .EQ. 5) THEN IF (K .EQ. 1) FTNAME = 'PSIX' IF (K .EQ. 3) FTNAME = 'PSIY' ENDIF GO TO 1000 C C R MATRIX CONSTRAINT C 250 J = - J IF (K .GT. 10) GO TO 297 FTCHAR(1) = 'R' FTCHAR(2) = TABLE(J+1) FTCHAR(3) = TABLE(K+1) GO TO 1000 C C T MATRIX CONSTRAINT C 297 IF (K .GT. 100) GO TO 298 KM = K K = KM/10 M = KM - 10*K FTCHAR(1) = 'T' FTCHAR(2) = TABLE(J+1) FTCHAR(3) = TABLE(K+1) FTCHAR(4) = TABLE(M+1) GO TO 1000 C C U MATRIX CONSTRAINT C 298 KLM = K K = KLM/100 LM = KLM - 100*K LL = LM/10 M = LM - 10*LL FTCHAR(1) = 'U' FTCHAR(2) = TABLE(J+1) FTCHAR(3) = TABLE(K+1) FTCHAR(4) = TABLE(LL+1) FTCHAR(5) = TABLE(M+1) GO TO 1000 C C BEAM CONSTRAINTS C 300 IF (J .EQ. K) GO TO 310 IF (J .GT. 10 .AND. J .LE. 16) GO TO 400 IF (J .GT. 20 .AND. J .LE. 26) GO TO 350 IF (J .EQ. 0 .OR. J .EQ. 7) GO TO 450 IF (J .EQ. 27) GO TO 500 C C BEAM MATRIX CONSTRAINT C FTCHAR(1) = 'S' FTCHAR(2) = TABLE(J+1) FTCHAR(3) = TABLE(K+1) GO TO 1000 C C BEAM SIZE CONSTRAINT C 310 IF (J .EQ. 1) FTNAME = 'XBEAM' IF (J .EQ. 2) FTNAME = 'XPBEAM' IF (J .EQ. 3) FTNAME = 'YBEAM' IF (J .EQ. 4) FTNAME = 'YPBEAM' IF (J .EQ. 5) FTNAME = 'LBEAM' IF (J .EQ. 6) FTNAME = 'DELBEAM' GO TO 1000 C C ACCELERATOR PARAMETER BEAM CONSTRAINT C 350 J = J - 20 IF (J .EQ. 1) FTNAME = 'BETAX' IF (J .EQ. 2) FTNAME = 'ALPHAX' IF (J .EQ. 3) FTNAME = 'BETAY' IF (J .EQ. 4) FTNAME = 'ALPHAY' GO TO 1000 C C BEAM CORRELATION CONSTRAINT C 400 FTCHAR(1) = 'C' FTCHAR(2) = TABLE(J-9) FTCHAR(3) = TABLE(K+1) GO TO 1000 C C FIRST MOMENT CONSTRAINT C 450 IF (K .EQ. 1) FTNAME = 'XC' IF (K .EQ. 2) FTNAME = 'XPC' IF (K .EQ. 3) FTNAME = 'YC' IF (K .EQ. 4) FTNAME = 'YPC' IF (K .EQ. 5) FTNAME = 'DLC' IF (K .EQ. 6) FTNAME = 'DELC' GO TO 1000 C C CONSTRAINT ON ACCELERATOR FUNCTION ETA C 500 IF (K .EQ. 1) FTNAME = 'ETAX' IF (K .EQ. 2) FTNAME = 'DETAX' IF (K .EQ. 3) FTNAME = 'ETAY' IF (K .EQ. 4) FTNAME = 'DETAY' GO TO 1000 C C SEXTUPOLE STRENGTH LIMITS C 550 FTNAME(1:7) = 'SEXTLIM' GO TO 1000 C C NUMERICAL CONSTANT C 600 FTNAME = 'CONSTANT' GO TO 1000 C 1000 RETURN END INTEGER FUNCTION NIV(TYPE) C C RETURNS NUMBER OF POSSIBLY INDICATED VARIED PARAMETERS C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA0A.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM17A.CIN' C C LOCAL VARIABLES C INTEGER NV1(NELMCT), TYPE C DATA NV1 /6, 1, 1, 3, 2, 0, 6, 6, 0, 0, 1 0,15, 0, 6, 0, 2, 0, 0, 2, 1, 2 0, 0, 0, 0, 0, 0, 6, 2, 2, 1, 3 0, 0, 0, 2, 2, 2, 0, 0, 0, 0, 4 0, 3, 6, 0, 0, 1, 1, 1/ C C----------------------------------------------------------------- NIV = NV1(TYPE) IF (TYPE .EQ. 1 .AND. NORD3 .GT. 1) NIV = 0 IF (TYPE .EQ. 8 .AND. NORD3 .GT. 1) NIV = 0 IF (TYPE .EQ. 12 .AND. NORD3 .GT. 1) NIV = 0 IF (TYPE .EQ. 16) THEN IDP = INT(DATA(I+1)) IF (IDP .GE. 16 .AND. IDP .LE. 20) NIV = 2 IF (IDP .GE. 22 .AND. IDP .LE. 25) NIV = 2 ENDIF IF (TYPE .EQ. 18 .AND. NORD1 .GE. 2) NIV = 2 IF (TYPE .EQ. 25 .AND. NORD1 .GE. 3) NIV = 2 RETURN END INTEGER FUNCTION NV(TYPE) C C RETURNS NUMBER OF VARIABLE PARAMETERS FOR A GIVEN ELEMENT C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM0C.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM13A.CIN' INCLUDE 'ELM16A.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'NELMS.CIN' C C LOCAL VARIABLES C INTEGER TYPE EXTERNAL IDATA C------------------------------------------------------- C NV = NELMS(TYPE) C IF (TYPE .EQ. 1 .AND. NORD3 .EQ. 1) NV = 14 IF (TYPE .EQ. 1 .AND. NORD3 .GT. 1) NV = 0 IF (TYPE .EQ. 2) NV = NV + 1 C IF (TYPE .EQ. 6 .AND. TYPEC .EQ. 8) THEN NV = 6 IF (NORD3 .GT. 1) NV = 0 ENDIF C IF (TYPE .EQ. 8) THEN NV = 6 IF (NORD3 .GT. 1) NV = 0 ENDIF C IF (TYPE .EQ. 12 .AND. NORD3 .GT. 1) NV = 0 IF (TYPE .EQ. 13 .OR. TYPE .EQ. 16) NV = 0 IF (TYPE .EQ. 13 .AND. CDB .EQ. 9) NV = NV3 IF (TYPE .EQ. 14) NV = 6 IF (TYPE .EQ. 15) NV = 0 C IF (TYPE .EQ. 16) THEN NV = 0 IF (NPARS .EQ. 1 .OR. NPARS .EQ. 12 .OR. NPARS .EQ. 13 1 .OR. (NPARS .GE. 16 .AND. NPARS .LE. 20) 2 .OR. (NPARS .GE. 22 .AND. NPARS .LE. 25)) NV = 2 ENDIF C IF (TYPE .EQ. 20 .AND. REFER) NV = 0 IF (TYPE .EQ. 38) NV = 0 C RETURN END SUBROUTINE OCTGET C C GET VALUES OF PARAMETERS DESCRIBING OCTUPOLE C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM0B.CIN' INCLUDE 'ELM1A.CIN' INCLUDE 'ELM4A.CIN' INCLUDE 'ELM4C.CIN' INCLUDE 'ELM5A.CIN' INCLUDE 'ELM6.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'ELM16B.CIN' INCLUDE 'ELM26B.CIN' INCLUDE 'FLUSHC.CIN' INCLUDE 'INDPAR.CIN' INCLUDE 'IOUNIT.CIN' INCLUDE 'XRAN.CIN' C C LOCAL VARIABLES C INTEGER IADR, IAP, IB, IDATA, IK3, IT REAL DATAR EXTERNAL DATAR, IDATA C------------------------------------------------------------------ C C MAGNET LENGTH C IADR = I + 1 L = DATAR(IADR) IF (PRAN25(1) .NE. 0.0) L = L + PRAN25(1)*XRAN(1) L = L*UNITI(8) LMAG = L C C INDICES OF OTHER PARAMETERS C IB = IPTOJ(2) IAP = IPTOJ(3) IK3 = IPTOJ(4) C C MAGNETIC FIELD AND APERTURE C IF (IK3 .GT. 0) GO TO 5 IADR = I + IB B = DATAR(IADR) IF (PRAN25(2) .NE. 0.0) B = B + PRAN25(2)*XRAN(2) B = B*UNITI(9)*RI/PREF C IF (IAP .NE. 0) THEN IADR = I + IAP AP = DATAR(IADR) ELSE WRITE (NOUT,9010) 9010 FORMAT (' *** ERROR *** OCTUPOLE APERTURE NOT GIVEN') FLUSHL = .TRUE. K3 = 0.0 AP = 0.0 GO TO 10 ENDIF IF (AP .NE. 0.0) THEN IF (PRAN25(3) .NE. 0.0) AP = AP + PRAN25(3)*XRAN(3) AP = AP*UNITI(1) K3 = B/(RI*AP**3) ELSE WRITE (NOUT,9009) 9009 FORMAT (' *** ERROR *** OCTUPOLE APERTURE SET TO ZERO') FLUSHL = .TRUE. K3 = 0.0 ENDIF GO TO 10 C C NORMALIZED FIELD DERIVATIVE (MAD NOTATION) C 5 IADR = I + IK3 K3 = DATAR(IADR) IF (PRAN25(4) .NE. 0.0) 1 K3 = K3 + PRAN25(4)*XRAN(4) IF (MPMAD) K3 = K3/6.0 K3 = K3/UNITI(8)**3 C 10 IT = IPTOJ(6) IF (IT .EQ. 0) THEN NUMTYP = IT ELSE NUMTYP = IDATA(I + IT) ENDIF RETURN END SUBROUTINE OCTUPL C C CALCULATES THIRD-ORDER PARTIAL DERIVATIVES FOR AN OCTUPOLE C INCLUDE 'ELM0B.CIN' INCLUDE 'ELM4C.CIN' INCLUDE 'U.CIN' C------------------------------------------------------------------------------- W2 = K3 S = - 0.5*W2*L**2 U(1,1) = S U(2,1) = 2.0*S/L U(3,10) = S U(4,10) = 2.0*S/L S = - .5*W2*L**3 U(1,2) = S U(2,2) = 3.*S/L U(3,16) = S U(4,16) = 3.0*S/L S = - 0.25*W2*L**4 U(1,3) = S U(2,3) = 4.0*S/L U(3,19) = S U(4,19) = 4.0*S/L S = - .05*W2*L**5 U(1,4) = S U(2,4) = 5.0*S/L U(3,20) = S U(4,20) = 5.0*S/L S = 1.5*W2*L**2 U(1,8) = S U(2,8) = 2.0*S/L U(3,5) = S U(4,5) = 2.0*S/L S = W2*L**3 U(1,14) = S U(2,14) = 3.0*S/L U(3,6) = S U(4,6) = 3.0*S/L S = 0.25*W2*L**4 U(1,17) = S U(2,17) = 4.0*S/L U(3,7) = S U(4,7) = 4.0*S/L S = .5*W2*L**3 U(1,9) = S U(2,9) = 3.0*S/L U(3,11) = S U(4,11) = 3.0*S/L S = .5*W2*L**4 U(1,15) = S U(2,15) = 4.0*S/L U(3,12) = S U(4,12) = 4.0*S/L S = 0.15*W2*L**5 U(1,18) = S U(2,18) = 5.0*S/L U(3,13) = S U(4,13) = 5.0*S/L RETURN END SUBROUTINE OGET C C GETS FLOOR COORDINATE TRANSFER MATRIX FOR USE IN MISALIGNMENT C CALCULATION C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA0A.CIN' INCLUDE 'DATA0B.CIN' INCLUDE 'DATA1A.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM0B.CIN' INCLUDE 'ELM0C.CIN' INCLUDE 'ELM2B.CIN' INCLUDE 'ELM2D.CIN' INCLUDE 'ELM4A.CIN' INCLUDE 'ELM4E.CIN' INCLUDE 'ELM8A.CIN' INCLUDE 'ELM8D.CIN' INCLUDE 'ELM8G.CIN' INCLUDE 'ELM8H.CIN' INCLUDE 'ELM8M.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'ELM23.CIN' INCLUDE 'OC.CIN' INCLUDE 'OCS.CIN' INCLUDE 'R2P.CIN' INCLUDE 'R2PS.CIN' C C LOCAL VARIABLES C INTEGER IDATA, IMAT, IMIS, ITYT, J, K, NSAVE, TYPECS LOGICAL BEFORS EXTERNAL IDATA C---------------------------------------------------------------- C C COORDINATE TRANSFORMATION STORED IN "ALIGN" ELEMENT C IF (RORC .GE. 3) GO TO 50 IMIS = ISTOR(NMIS) ITYT = IMIS + 9 DO 10 J = 1, 3 10 XR(J) = DATA(ITYT + J) IMAT = ITYT + 3 DO 20 J = 1, 3 DO 20 K = 1, 3 IMAT = IMAT + 1 OR(J,K) = DATA(IMAT) 20 CONTINUE GO TO 300 C C COORDINATE TRANSFORMATION CALCULATED FROM PRECEDING ELEMENT C 50 IF (LFM .GE. 1 .AND. BEFORE) GO TO 100 IF (TYPE .EQ. 2 .OR. (TYPE .EQ. 4 .AND. FFIN)) GO TO 70 IF (TYPE .EQ. 28 .OR. TYPE .EQ. 29) GO TO 70 DO 55 J = 1, 3 XR(J) = X0SV(J) 55 CONTINUE DO 60 J = 1, 3 DO 60 K = 1, 3 OR(J,K) = OSV(J,K) 60 CONTINUE GO TO 300 C 70 DO 75 J = 1, 3 XR(J) = X0(3,J) 75 CONTINUE DO 80 J = 1, 3 DO 80 K = 1, 3 OR(J,K) = O(3,J,K) 80 CONTINUE GO TO 300 C C COORDINATE TRANSFORMATION CALCULATED FOR NEXT ELEMENT C 100 IF (TYPE .EQ. 2 .OR. TYPE .EQ. 4) GO TO 150 IF (TYPE .EQ. 28 .OR. TYPE .EQ. 29) GO TO 200 DO 105 J = 1, 3 XR(J) = 0.0 105 CONTINUE DO 110 J = 1, 3 DO 110 K = 1, 3 OR(J,K) = 0.0 110 CONTINUE DO 120 J = 1, 3 OR(J,J) = 1.0 120 CONTINUE L = DATA(I+1)*UNITI(8) XR(3) = L GO TO 300 C C COORDINATE TRANSFORMATION FOR BENDING MAGNET TO COME C 150 R2PS = R2P DO 152 J = 1, 3 X0S(3,J) = X0(3,J) 152 CONTINUE DO 155 J = 1, 3 DO 155 K = 1, 3 OS(3,J,K) = O(3,J,K) 155 CONTINUE C NSAVE = NUM TYPECS = TYPEC BEFORS = BEFORE R2P = .FALSE. IF (TYPE .EQ. 4) GO TO 160 CALL OSET CALL ADVANC(3) R2P = .TRUE. C 157 NUM = NUM + NDIF I = ISTOR(NUM) TYPE = IDATA(I) TYPEC = TYPE IF (TYPE .EQ. 23) THEN K1REG = IDATA(I+1) K1TIE = TIE(I+1) K2REG = IDATA(I+2) K2TIE = TIE(I+2) IOPN = IDATA(I+3) JREG = IDATA(I+4) JTIE = TIE(I+4) CALL COMBIN ENDIF IF (NUM .NE. NUM4) GO TO 157 C 160 L = LBEND CALL OSET CALL ADVANC(3) R2P = .TRUE. C IF (.NOT. FFIN .AND. DMC) GO TO 180 IF (FFIN .AND. DMC) GO TO 170 NUM = NUM2 I = ISTOR(NUM) TYPE = IDATA(I) CALL OSET CALL ADVANC(3) C 170 DO 172 J = 1, 3 XR(J) = X0(3,J) 172 CONTINUE DO 175 J = 1, 3 DO 175 K = 1, 3 OR(J,K) = O(3,J,K) 175 CONTINUE GO TO 190 C 180 DO 182 J = 1, 3 XR(J) = X0(1,J) 182 CONTINUE DO 185 J = 1, 3 DO 185 K = 1, 3 OR(J,K) = O(1,J,K) 185 CONTINUE GO TO 190 C 190 NUM = NSAVE I = ISTOR(NUM) TYPE = IDATA(I) TYPEC = TYPECS BEFORE = BEFORS C R2P = R2PS DO 192 J = 1, 3 X0(3,J) = X0S(3,J) 192 CONTINUE DO 195 J = 1, 3 DO 195 K = 1, 3 O(3,J,K) = OS(3,J,K) 195 CONTINUE GO TO 300 C C COORDINATE TRANSFORMATION FOR RBEND OR SBEND TO COME C 200 R2PS = R2P TYPECS = TYPEC DO 202 J = 1, 3 X0S(3,J) = X0(3,J) 202 CONTINUE DO 205 J = 1, 3 DO 205 K = 1, 3 OS(3,J,K) = O(3,J,K) 205 CONTINUE C BEFORS = BEFORE R2P = .FALSE. TYPEC = 2 CALL OSET CALL ADVANC(3) R2P = .TRUE. C TYPEC = 4 L = LBEND CALL OSET CALL ADVANC(3) C TYPEC = 2 CALL OSET CALL ADVANC(3) C 220 DO 222 J = 1, 3 XR(J) = X0(3,J) 222 CONTINUE DO 225 J = 1, 3 DO 225 K = 1, 3 OR(J,K) = O(3,J,K) 225 CONTINUE C TYPEC = TYPECS BEFORE = BEFORS C R2P = R2PS DO 242 J = 1, 3 X0(3,J) = X0S(3,J) 242 CONTINUE DO 245 J = 1, 3 DO 245 K = 1, 3 O(3,J,K) = OS(3,J,K) 245 CONTINUE GO TO 300 C 300 IF (LTAB .EQ. 1) 1 STRATE(NM) = XR(1) .EQ. 0.0 .AND. XR(2) .EQ. 0.0 RETURN END SUBROUTINE ORDCK C C CHECKS TO MAKE SURE THAT ORDER OF PROGRAM USED IS AT LEAST C AS GREAT AS ORDER OF CALCULATION REQUESTED C C LIST OF COMMON BLOCKS C INCLUDE 'ELM17A.CIN' INCLUDE 'FLUSHC.CIN' INCLUDE 'IOUNIT.CIN' C C------------------------------------------------------------------- IF (NORDX .GT. 3) THEN WRITE (NOUT,1000) NORDX 1000 FORMAT (' *** ERROR *** ORDER',I3,2X,'SPECIFIED FOR', 1 ' THIRD-ORDER PROGRAM') FLUSHL = .TRUE. ENDIF RETURN END SUBROUTINE OSAVE C C SAVES FLOOR COORDINATE TRANSFORMATION MATRIX AFTER EACH C ELEMENT FOR USE IN MISALIGNMENT CALCULATION C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM8D.CIN' INCLUDE 'OC.CIN' C C------------------------------------------------------------------ DO 10 J = 1, 3 DO 10 K = 1, 3 OSV(J,K) = O(1,J,K) 10 CONTINUE DO 20 J = 1, 3 X0SV(J) = X0(1,J) 20 CONTINUE RETURN END SUBROUTINE OSET C C FLOOR COORDINATE TRANSFORMATION FOR SINGLE ELEMENT C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'COCOM.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM0B.CIN' INCLUDE 'ELM0C.CIN' INCLUDE 'ELM2A.CIN' INCLUDE 'ELM2B.CIN' INCLUDE 'ELM4A.CIN' INCLUDE 'ELM4D.CIN' INCLUDE 'ELM7B.CIN' INCLUDE 'ELM8K.CIN' INCLUDE 'ELM13A.CIN' INCLUDE 'ELM15C.CIN' INCLUDE 'ELM16A.CIN' INCLUDE 'ELM16B.CIN' INCLUDE 'ELM16C.CIN' INCLUDE 'ELM20.CIN' INCLUDE 'OC.CIN' INCLUDE 'YAW.CIN' C C LOCAL VARIABLES C REAL VDIS1(3) C C---------------------------------------------------------------------- CALL RESET(1) C IF (TYPEC .EQ. 2) GO TO 200 IF (TYPEC .EQ. 3) GO TO 300 IF (TYPEC .EQ. 4) GO TO 400 IF (TYPEC .EQ. 5) GO TO 500 IF (TYPEC .EQ. 8) GO TO 800 IF (TYPEC .EQ. 11) GO TO 1100 IF (TYPEC .EQ. 13) GO TO 1300 IF (TYPEC .EQ. 16) GO TO 1600 IF (TYPEC .EQ. 18) GO TO 1800 IF (TYPEC .EQ. 19) GO TO 1900 IF (TYPEC .EQ. 20) GO TO 2000 IF (TYPEC .EQ. 25) GO TO 2500 IF (TYPE .EQ. 28 .OR. TYPE .EQ. 29) GO TO 2800 IF (TYPEC .EQ. 34) GO TO 3400 IF (TYPEC .EQ. 35) GO TO 3500 IF (TYPEC .EQ. 41) GO TO 4100 IF (TYPEC .EQ. 43) GO TO 4300 IF (TYPEC .EQ. 46 .OR. TYPEC .EQ. 47 .OR. TYPEC .EQ. 48) GO TO 300 GO TO 5200 C C 2. -- FRINGING FIELD C 200 OFFSET = - 4.0*H0*APB(2)**2*SB**2*LAYK IF (BEFORE) X0(1,1) = OFFSET IF (.NOT. BEFORE) X0(1,1) = - OFFSET GO TO 5200 C C 3. -- DRIFT SPACE C 300 X0(1,3) = L GO TO 5200 C C 4. -- BENDING MAGNET C 400 AL0 = H0*L CSAL = COS(AL0) SNAL = SIN(AL0) O(1,1,1) = CSAL O(1,3,3) = CSAL O(1,1,3) = SNAL O(1,3,1) = - SNAL IF (H0 .EQ. 0.0) THEN X0(1,3) = L ELSE IF (CSAL .GT. 0.5) X0(1,1) = - SNAL**2/(H0*(1.0 + CSAL)) IF (CSAL .LE. 0.5) X0(1,1) = - (1.0 - CSAL)/H0 X0(1,3) = SNAL/H0 ENDIF GO TO 5200 C C 5. -- QUADRUPOLE C 500 X0(1,3) = L GO TO 5200 C C 8. -- MISALIGNMENT C 800 IF (BEFORE) THEN DO 810 J = 1, 3 X0(1,J) = VDIS(J) DO 810 K = 1, 3 O(1,J,K) = RM(J,K) 810 CONTINUE ELSE DO 850 J = 1, 3 VD = 0.0 DO 840 K = 1, 3 VD = VD + RM(K,J)*VDIS(K) 840 CONTINUE VDIS1(J) = - VD 850 CONTINUE C DO 860 J = 1, 3 X0(1,J) = VDIS1(J) DO 860 K = 1, 3 O(1,J,K) = RM(J,K) 860 CONTINUE ENDIF C C 11. -- ACCELERATOR C 1100 X0(1,3) = L GO TO 5200 C C 13. -- INPUT-OUTPUT OPTIONS C 1300 IF (CDB .EQ. 11) GO TO 1310 YAW = ATAN(COF(2)) CST = COS(YAW) SNT = SIN(YAW) PITCH = ATAN(COF(4)*CST) CSP = COS(PITCH) SNP = SIN(PITCH) X0(1,1) = COF(1) X0(1,2) = COF(3) O(1,1,1) = CST O(1,1,3) = - SNT O(1,2,1) = - SNT*SNP O(1,2,2) = CSP O(1,2,3) = - CST*SNP O(1,3,1) = SNT*CSP O(1,3,2) = SNP O(1,3,3) = CST*CSP GO TO 5200 C 1310 CS = COS(ROLL) SN = SIN(ROLL) O(1,1,1) = CS O(1,1,2) = - SN O(1,2,1) = SN O(1,2,2) = CS GO TO 5200 C C 16. -- SPECIAL PARAMETERS C 1600 IF (NPARS .GE. 16 .AND. NPARS .LE. 20) THEN IF (NPARS .EQ. 19) GO TO 1610 IF (NPARS .EQ. 20) GO TO 1620 J = NPARS - 15 X0(4,J) = PARAM*UFLOOR(1) IF (J .EQ. 1) XINIT = X0(4,J) IF (J .EQ. 2) YINIT = X0(4,J) IF (J .EQ. 3) ZINIT = X0(4,J) ENDIF GO TO 5200 C 1610 TH = PARAM*UFLOOR(2) CS = COS(TH) SN = SIN(TH) O(1,1,1) = CS O(1,1,3) = - SN O(1,3,1) = SN O(1,3,3) = CS GO TO 5200 C 1620 PH = PARAM*UFLOOR(2) CS = COS(PH) SN = SIN(PH) O(1,2,2) = CS O(1,2,3) = - SN O(1,3,2) = SN O(1,3,3) = CS GO TO 5200 C C 18. -- SEXTUPOLE C 1800 X0(1,3) = L GO TO 5200 C C 19. -- SOLENOID C 1900 X0(1,3) = L GO TO 5200 C C 20. -- COORDINATE ROTATION C 2000 O(1,1,1) = CSR O(1,1,2) = SNR O(1,2,1) = - SNR O(1,2,2) = CSR GO TO 5200 C C 25. -- OCTUPOLE C 2500 X0(1,3) = L GO TO 5200 C C 28. -- RBEND OR 29. -- SBEND C 2800 IF (TYPEC .EQ. 4) GO TO 2820 IF (TYPEC .EQ. 20) GO TO 2840 GO TO 5200 C 2820 AL0 = H0*L CSAL = COS(AL0) SNAL = SIN(AL0) O(1,1,1) = CSAL O(1,3,3) = CSAL O(1,1,3) = SNAL O(1,3,1) = - SNAL IF (H0 .EQ. 0.0) THEN X0(1,3) = L ELSE IF (CSAL .GT. 0.5) X0(1,1) = - SNAL**2/(H0*(1.0 + CSAL)) IF (CSAL .LE. 0.5) X0(1,1) = - (1.0 - CSAL)/H0 X0(1,3) = SNAL/H0 ENDIF GO TO 5200 C 2840 O(1,1,1) = CSR O(1,1,2) = SNR O(1,2,1) = - SNR O(1,2,2) = CSR GO TO 5200 C C 34. -- PLASMA LENS C 3400 X0(1,3) = L GO TO 5200 C C 35. -- HKICK OR 36. -- VKICK C 3500 X0(1,3) = L GO TO 5200 C C 41. -- ELECTROSTATIC SEPTUM C 4100 X0(1,3) = L GO TO 5200 C C 43. -- REFERENCE COORDINATE SYSTEM SHIFT C 4300 X0(1,1) = - COD(1) X0(1,2) = - COD(3) THETA1 = ATAN(CO(2)) CST1 = COS(THETA1) SNT1 = SIN(THETA1) PHI1 = ATAN(CO(4)*CST1) CSP1 = COS(PHI1) SNP1 = SIN(PHI1) PHI2 = ATAN(CO(4)-COD(4)) CSP2 = COS(PHI2) SNP2 = SIN(PHI2) THETA2 = ATAN((CO(2)-COD(2))*CSP2) CST2 = COS(THETA2) SNT2 = SIN(THETA2) O(1,1,1) = CST2*CST1 + SNT2*SNT1*CSP2*CSP1 O(1,1,2) = SNT2*SNP1 O(1,1,3) = CST2*SNT1 - SNT2*CST1*CSP1 O(1,2,1) = - SNT2*CST1*SNP2 - SNT1*CSP2*SNP1 1 + CST2*SNT1*SNP2*CSP1 O(1,2,2) = CSP2*CSP1 + CST2*SNP2*SNP1 O(1,2,3) = - SNT2*SNT1*SNP2 + CST1*CSP2*SNP1 1 - CST2*CST1*SNP2*CSP1 O(1,3,1) = SNT2*CST1*CSP2 + SNT2*SNP2*SNP1 1 - CST2*SNT1*CSP2*CSP1 O(1,3,2) = SNP2*CSP1 - CST2*CSP2*SNP1 O(1,3,3) = SNT2*SNT1*CSP2 + CST1*SNP2*SNP1 1 + CST2*CST1*CSP2*CSP1 GO TO 5200 C 5200 RETURN END SUBROUTINE OUTFIT C C MAKES A RUN THROUGH THE BEAM TRANSPORT SYSTEM AND PRINTS C OUTPUT C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'BROAD.CIN' INCLUDE 'DATA0A.CIN' INCLUDE 'DATA0B.CIN' INCLUDE 'DATA1A.CIN' INCLUDE 'DATA1C.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'DSPECR.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM0B.CIN' INCLUDE 'ELM0C.CIN' INCLUDE 'ELM0D.CIN' INCLUDE 'ELM1D.CIN' INCLUDE 'ELM4A.CIN' INCLUDE 'ELM8G.CIN' INCLUDE 'ELM9.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM13B.CIN' INCLUDE 'ELM13C.CIN' INCLUDE 'ELM15B.CIN' INCLUDE 'ELM15C.CIN' INCLUDE 'ELM31A.CIN' INCLUDE 'FLUSHC.CIN' INCLUDE 'IMAGE.CIN' INCLUDE 'IOUNIT.CIN' INCLUDE 'LBLSVE.CIN' INCLUDE 'LXRAN.CIN' INCLUDE 'PRINTL.CIN' INCLUDE 'STEPT1.CIN' C C LOCAL VARIABLES C INTEGER IDATA, NSLIT REAL DATAR, WORK1 EXTERNAL DATAR, IDATA C C------------------------------------------------------------------- C IF (.NOT. LSTEP .OR. BROAD) WRITE (NOUT,8999) IMAGE 8999 FORMAT (1H1,A80/) CALL PARSET CALL INITZE DO 5 J = 1, 33 5 DSPEC_VAL(J) = 0.0 C IF (NEL .LE. 0) GO TO 5300 10 I = ISTOR(NUM) TYPE = IDATA(I) IF (TYPE .GE. 82 .AND. TYPE .LE. 86) GO TO 70 IF (TYPE .LE. 0 .OR. TYPE .GE. 50) GO TO 5200 CALL SKETCH(NUM) CALL DEPICT IF (.NOT. ATWE) GO TO 5200 C IF (PRON .AND. ELPR .AND. .NOT. LCPR .AND. TYPE .NE. 13) THEN WORK1 = LC/UFLOOR(1) WRITE (NOUT,9001) WORK1, XFLOOR(1) LCPR = .TRUE. ENDIF 9001 FORMAT (1H ,8X,F10.3,1X,A4) C IF (TYPE .EQ. 31) LABELSVE = LABEL(NUM) C C POSSIBLE INITIAL MISALIGNMENTS C CALL POSSIM IF (FLUSHL) GO TO 5500 C C SIMPLE ELEMENTS C IF (RABL .AND. WFRN) GO TO 200 IF (RABL) GO TO 100 70 TYPEC = TYPE LXRAN = TYPE .LT. 50 CALL ELICIT IF (FLUSHL) GO TO 5500 IF (TYPE .LE. 0) GO TO 5200 IF (TYPE .EQ. 15) GO TO 5200 IF (.NOT. LSTEPN) CALL POSTER IF (TYPE .NE. 30 .AND. (TYPE .NE. 14 .OR. NEXT .NE. 14)) THEN IF (.NOT. LSTEPN) THEN CALL VPRINT CALL MPRINT ENDIF ENDIF C C UPDATE USED TO MARK BEGINNING OF MISALIGNMENT C IF (TYPE .EQ. 6 .OR. TYPE .EQ. 37) THEN NSLIT = IFIX(DATA(I+1)) IF (NSLIT .EQ. 0) THEN CALL UPMARK IF (FLUSHL) GO TO 5500 ENDIF ENDIF GO TO 5200 C C SIMPLE ELEMENTS WITH POSSIBLE TILT C 100 IF (TYPE .EQ. 2 .OR. TYPE .EQ. 4) GO TO 150 CALL ELTILT IF (FLUSHL) GO TO 5500 GO TO 5000 C C BENDING MAGNETS WITH FRINGE FIELD SPECIFIED BY SEPARATE ELEMENT C 150 CALL EL242 IF (FLUSHL) GO TO 5500 GO TO 5000 C C COMPOUND ELEMENTS C 200 CALL ELCOMP IF (FLUSHL) GO TO 5500 L = LBEND C C LOOP THROUGH MISALIGNMENTS BY NAME C 5000 IF (.NOT. ALGR .AND. NMISRB .NE. 0) CALL AGENDR(1) C C ADVANCE TO NEXT ELEMENT C 5200 IF (MKG .AND. NUM .EQ. NMARKE) CALL AGENDA(2) IF (ALGR .AND. NUM .EQ. NMISRE) CALL AGENDR(2) IF (MADL .OR. TRANSPORTL .OR. LATDEFL .OR. STRUCTL .OR. 1 ACADL .OR. FILEL) CALL LATSTOR NUM = NUM + NDIF IF (.NOT. MKG .AND. NUSE .NE. 0 .AND. NUM .GT. NUSE) GO TO 5300 IF (NUM .LE. NEL) GO TO 10 C C END OF BEAM LINE - PRINT LENGTH C 5300 CONTINUE IF (.NOT. LSTEP .OR. BROAD) THEN WORK1 = LC/UFLOOR(1) WRITE (NOUT,9021) WORK1, XFLOOR(1) ENDIF 9021 FORMAT (1H0,8X,'*LENGTH*',F17.5,1X,A4) 5500 RETURN END SUBROUTINE PARADE C C PRINTS FITTED VALUES OF VARIED PARAMETERS C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA0B.CIN' INCLUDE 'DATA1A.CIN' INCLUDE 'DATA1C.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM13B.CIN' INCLUDE 'IOUNIT.CIN' INCLUDE 'RDCHAR.CIN' C C LOCAL VARIABLES C CHARACTER*8 LABOUT EXTERNAL DATAR, IDATA C------------------------------------------------------------------ C NUM = 1 NDIF = 1 C 1 I = ISTOR(NUM) TYPE = IDATA(I) C IF (TYPE .NE. 30) GO TO 5100 LABOUT(2:7) = LABEL(NUM)(1:6) IF (LABEL(NUM) .EQ. BLANK) THEN LABOUT(1:1) = BLANK LABOUT(8:8) = BLANK ELSE LABOUT(1:1) = QUOTE LABOUT(8:8) = QUOTE ENDIF C C DO VARY CODES C 30 IVA = 0 ISIG = TIE(I+1) IF (ISIG .GE. 99) ISIG = 0 IF (ISIG .NE. 0 .AND. ISIG .NE. 100) IVA = 1 60 IF (IVA .EQ. 0) GO TO 5100 C C 30. -- PARAMETER C IF (LABEL(NUM) .EQ. BLANK) GO TO 5100 IF (.NOT. SUPP) THEN PARAM = DATAR(I+1) WRITE (NOUT,9300) NUM, LABOUT, PARAM ENDIF GO TO 5000 C C PRINT VARY CODES C 5000 IF (IVA .NE. 0) WRITE (NOUT,9500) C 5100 NUM = NUM + NDIF IF (NUM .LE. NEL) GO TO 1 C C RETURN C 5200 RETURN C 9300 FORMAT (2H (,I4,')',2X,'*PARAM*',8X,A8,4X,E16.8) 9500 FORMAT (1H ,12X,'VARIED ') END SUBROUTINE PARSEC C C CALCULATES PARTIALS OF SECOND-ORDER MATRIX OF A SINGLE C BEAM ELEMENT WITH RESPECT TO THE VARIED QUANTITY C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'COP.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM0C.CIN' INCLUDE 'ELM0E.CIN' INCLUDE 'ELM2A.CIN' INCLUDE 'ELM2B.CIN' INCLUDE 'ELM4A.CIN' INCLUDE 'ELM5A.CIN' INCLUDE 'ELM5B.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM10D.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'T.CIN' C C--------------------------------------------------------------- IF (TYPEC .EQ. 2) GO TO 200 IF (TYPEC .EQ. 3) GO TO 300 IF (TYPEC .EQ. 4) GO TO 400 IF (TYPEC .EQ. 5) GO TO 500 IF (TYPEC .EQ. 18) GO TO 1800 IF (TYPEC .EQ. 19) GO TO 1900 IF (TYPEC .EQ. 25) GO TO 5000 IF (TYPEC .EQ. 35) GO TO 3500 IF (TYPEC .EQ. 36) GO TO 3500 RETURN C C 2. -- POLE FACE ROTATION C 200 IF (TYPE .EQ. 2 .AND. JV .EQ. 4) GO TO 210 IF ((TYPE .EQ. 28 .OR. TYPE .EQ. 29) .AND. 1 (JV .EQ. 18 .OR. JV .EQ. 19)) GO TO 210 GO TO 5000 C 210 IF (SOFA) LINEAR = .FALSE. EPS = 2.0*H0*APB(2) TB2 = TB*TB SB2 = SB*SB SB3 = SB2*SB TV(2,1) = 0.5*H0*SB3/UNITI(8) TV(2,6) = - 0.5*H0*(SB3 - EPS*LAYL*TB*SB2*(5.0*SB2 + TB2))/ 1 UNITI(8) TV(4,4) = - H0*(SB3 - EPS*LAYL*TB*SB2*(5.0*SB2 + TB2))/UNITI(8) GO TO 5000 C C 3. -- DRIFT SPACE C 300 LV = DPARM*UNITI(8) TV(5,3) = - 0.5*LV TV(5,10) = - 0.5*LV GO TO 5000 C C 4. -- BENDING MAGNET C 400 CALL DBEND2 GO TO 5000 C C 5. -- QUADRUPOLE C 500 IF (JV .EQ. 2 .OR. JV .EQ. 4 .OR. JV .EQ. 5) GO TO 520 JQUAD = 1 KQ2 = KX2 CALL DFOL2 JQUAD = 3 KQ2 = KY2 CALL DFOL2 GO TO 5000 C 520 JQUAD = 1 KQ2 = KX2 CALL DFOCU2 JQUAD = 3 KQ2 = KY2 KVK = - KVK CALL DFOCU2 KVK = - KVK GO TO 5000 C C 18. -- SEXTUPOLE C 1800 IF (SOFA) LINEAR = .FALSE. CALL DSEXT2 GO TO 5000 C C 19. -- SOLENOID C 1900 IF (SOFA) LINEAR = .FALSE. CALL DSOLE2 GO TO 5000 C C 35. -- HKICK -- HORIZONTAL VERNIER C OR C 36. -- VKICK -- VERTICAL VERNIER C 3500 CONTINUE GO TO 5000 C C CHANGE TRIANGULAR MATRIX INTO SQUARE MATRIX C 5000 IF (NORD1 .GE. 3) CALL PARTRJ RETURN END SUBROUTINE PARSET INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA0B.CIN' INCLUDE 'DATA1A.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM23.CIN' INCLUDE 'FLUSHC.CIN' C---------------------------------------------------------------------------- INTEGER TYPEN LOGICAL INSPEC C NITER = 1 NNOTO = -1 C C MARK ALGEBRAIC OPERATIONS NOT DONE C DO 20 NN = 1, NEL II = ISTOR(NN) TYPE = IDATA(II) IF (TYPE .EQ. 23) TIE(II+3) = 1 20 CONTINUE C C RUN THROUGH BEAM LINE PERFORMING ALGEBRAIC OPERATIONS C 50 NUM = 1 NBEG = 0 NNOT = 0 NNOTS = 0 INSPEC = .TRUE. C 70 I = ISTOR(NUM) TYPE = IDATA(I) C IF (TYPE .EQ. 23) GO TO 2300 GO TO 6100 C C 23. -- ALGEBRAIC OPERATION C 2300 K1TIE = TIE(I+1) K2TIE = TIE(I+2) JTIE = TIE(I+4) K1REG = IDATA(I+1) K2REG = IDATA(I+2) IOPN = IDATA(I+3) JREG = IDATA(I+4) IF (INSPEC) THEN IF (NBEG .EQ. 0) NBEG = NUM IF (K1TIE .EQ. 100) THEN IPAR = K1REG 2310 IF (TIE(IPAR) .EQ. 100) THEN IPAR = IDATA(IPAR) GO TO 2310 ENDIF IF (TIE(IPAR) .EQ. 99) THEN ISET = IPAR - 3 IF (TIE(ISET) .EQ. 1) NNOT = NNOT + 1 ENDIF ENDIF IF (IOPN .LT. 10) THEN IF (K2TIE .EQ. 100) THEN IPAR = K2REG 2320 IF (TIE(IPAR) .EQ. 100) THEN IPAR = IDATA(IPAR) GO TO 2320 ENDIF IF (TIE(IPAR) .EQ. 99) THEN ISET = IPAR - 3 IF (TIE(ISET) .EQ. 1) NNOT = NNOT + 1 ENDIF ENDIF ENDIF ELSE CALL COMBIN TIE(I+3) = 0 ENDIF IF (JTIE .EQ. 100) THEN IF (INSPEC) THEN TYPEN = IDATA(ISTOR(NUM+2)) HELEM = .FALSE. IF (TYPEN .EQ. 10 .OR. TYPEN .EQ. 33 .OR. TYPEN .EQ. 38 1 .OR. TYPEN .EQ. 50 .OR. TYPEN .EQ. 51 .OR. TYPEN .EQ. 52) 2 HELEM = .TRUE. IF (NNOT .EQ. 0 .AND. .NOT. HELEM) THEN NUM = NBEG - 1 INSPEC = .FALSE. ELSE IF (.NOT. HELEM) NNOTS = NNOTS + NNOT NNOT = 0 NBEG = 0 ENDIF ELSE NBEG = 0 NNOTS = NNOTS + NNOT NNOT = 0 INSPEC = .TRUE. ENDIF ENDIF C C ADVANCE TO NEXT ELEMENT C 6100 NUM = NUM + 1 IF (NUM .LE. NEL) GO TO 70 C IF (NITER .GE. 10) GO TO 6200 NITER = NITER + 1 IF (NNOTS .GT. 0) THEN IF (NNOTO .EQ. NNOTS) FLUSHL = .TRUE. IF (NNOTO .NE. NNOTS) THEN NNOTO = NNOTS GO TO 50 ENDIF ENDIF C C UNMARK ALGEBRAIC OPERATIONS FOR CONSTRAINTS, ETC. C 6200 DO 6220 NN = 1, NEL II = ISTOR(NN) TYPE = IDATA(II) IF (TYPE .EQ. 23) TIE(II+3) = 0 6220 CONTINUE RETURN END SUBROUTINE PARTLS C C CALCULATES PARTIALS OF FIRST-ORDER MATRIX OF A SINGLE BEAM C ELEMENT WITH RESPECT TO THE VARIED QUANTITY C C LIST OF COMMON BLOCKS C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'COCOM.CIN' INCLUDE 'COP.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM0B.CIN' INCLUDE 'ELM0C.CIN' INCLUDE 'ELM0D.CIN' INCLUDE 'ELM0E.CIN' INCLUDE 'ELM1A.CIN' INCLUDE 'ELM2B.CIN' INCLUDE 'ELM4A.CIN' INCLUDE 'ELM5A.CIN' INCLUDE 'ELM5B.CIN' INCLUDE 'ELM6.CIN' INCLUDE 'ELM7B.CIN' INCLUDE 'ELM8A.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM10E.CIN' INCLUDE 'ELM13A.CIN' INCLUDE 'ELM14A.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'ELM15C.CIN' INCLUDE 'ELM16B.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'ELM20.CIN' INCLUDE 'ELM42.CIN' INCLUDE 'ETACOM.CIN' INCLUDE 'ETAP.CIN' INCLUDE 'INDBND.CIN' INCLUDE 'INDPAR.CIN' INCLUDE 'R.CIN' INCLUDE 'SI.CIN' INCLUDE 'SVP.CIN' C C --------------------------------------------------------------------- C GO TO ( 100, 200, 300, 400, 500, 600, 700, 800,5020,5020, 1 5020,1200,5020,1400,5020,5020,5020,1800,1900,2000, 2 5020,5020,5020,5020,2500,5020,2700,2800,2800,5020, 3 5020,5020,5020,3400,3500,3500,3700,5020,5020,5020, 4 5020,4200,4300,5020,5020,5020,5020,5020), TYPE C C 1. -- BEAM C 100 CALL DBEAMS GO TO 5020 C C 2. -- POLE FACE ROTATION C 200 IF (JV .EQ. 1) GO TO 210 IF (JV .EQ. 5) GO TO 220 IF (JV .EQ. 4) GO TO 5000 GO TO 5020 C 210 CALL DFRINJ GO TO 5000 C 220 CALL DFRINB GO TO 5000 C C 3. -- DRIFT SPACE C 300 LINEAR = .FALSE. LV = DPARM*UNITI(8) RV(1,2) = LV RV(3,4) = LV IF (RI .EQ. 0.0 .AND. SM .EQ. 0.0) THEN RV(5,6) = 0.0 ELSE RV(5,6) = SM**2*LV/(RI**2 + SM**2) ENDIF GO TO 5000 C C 4. -- BENDING MAGNET C 400 CALL DBENDI GO TO 5000 C C 5. -- QUADRUPOLE C 500 LINEAR = .FALSE. IF (TYPEC .EQ. 20) GO TO 560 IF (JV .EQ. 1) GO TO 510 IF (JV .EQ. 2 .OR. JV .EQ. 3 .OR. JV .EQ. 4 .OR. JV .EQ. 5) 1 GO TO 520 IF (JV .EQ. NTILT) GO TO 540 GO TO 5020 C 510 LV = DPARM*UNITI(8) LVE = LV JQUAD = 1 KQ2 = KX2 CALL DFOL JQUAD = 3 KQ2 = KY2 CALL DFOL GO TO 5000 C 520 IB = IPTOJ(2) IAP = IPTOJ(3) IG = IPTOJ(4) IK1 = IPTOJ(5) IF (JV .EQ. 2 .AND. IB .NE. 0) KVK = 0.5*UNITI(9)/(AP*PREF) IF (JV .EQ. 3 .AND. IAP .NE. 0) 1 KVK = - 0.5*UNITI(1)*B/(AP**2*PREF) IF (IG .NE. 0) KVK = 0.5*UNITI(9)/(PREF*UNITI(1)) IF (IK1 .NE. 0) KVK = 0.5/UNITI(8)**2 KVK = KVK*DPARM JQUAD = 1 KQ2 = KX2 CALL DFOCUS JQUAD = 3 KQ2 = KY2 KVK = - KVK CALL DFOCUS KVK = - KVK GO TO 5000 C 540 IF (JV .EQ. NTILT .AND. REFER) THEN CALL DSROTR ENDIF GO TO 5000 C 560 IF (JV .EQ. NTILT) THEN CALL DSROTN GO TO 5000 ELSE GO TO 5020 ENDIF C C 6. -- UPDATE C 600 IF (TYPEC .EQ. 8) THEN LTAB = MOD(TYT/10,10) IF (LTAB .EQ. 0) THEN IF (RORC .LE. 2) CALL WOBBLE ENDIF ENDIF GO TO 5020 C C 7. -- BEAM CENTROID SHIFT C 700 LINEAR = .FALSE. SIGG = DPARM NV2 = IABS(NV2) IF (.NOT. CVP(NV2)) THEN DO 710 J = 1, 6 COV(J,NV2) = 0.0 710 CONTINUE ENDIF COV(JV,NV2) = COV(JV,NV2) + SIGG*UBEAM(JV) CVP(NV2) = .TRUE. GO TO 5020 C C 8. -- MAGNET MISALIGNMENT C 800 LTAB = MOD(TYT/10,10) IF (LTAB .EQ. 0) THEN IF (RORC .LE. 3) CALL WOBBLE ENDIF GO TO 5020 C C 12. -- CORRELATIONS IN BEAM ELLIPSE C 1200 SIGG = DPARM NV2 = IABS(NV2) IF (NORD3 .GE. 1) THEN K = (3 + INT(SQRT(8.0E0*FLOAT(JV) - 6.99E0)))/2 J = JV - (K-1)*(K-2)/2 DSIG = SIGG*SQRT(SI(J,J)*SI(K,K)) IF (.NOT. SVP(NV2)) THEN DO 1210 J1 = 1, 6 DO 1210 J2 = 1, 6 SV(J1,J2,NV2) = 0.0 1210 CONTINUE ENDIF SV(J,K,NV2) = SV(J,K,NV2) + DSIG SV(K,J,NV2) = SV(J,K,NV2) SVP(NV2) = .TRUE. ENDIF GO TO 5020 C C 14. -- ARBITRARY MATRIX C 1400 RV(J1,JV) = DPARM*UBEAM(J1)/UBEAM(JV) GO TO 5000 C C 18. -- SEXTUPOLE C 1800 IF (TYPEC .EQ. 20) GO TO 1820 IF (JV .EQ. NTILT) CALL DSROTR GO TO 5000 C 1820 IF (JV .EQ. NTILT) THEN CALL DSROTN GO TO 5000 ELSE GO TO 5020 ENDIF C C 19. -- SOLENOID C 1900 LINEAR = .FALSE. CALL DSOLEN GO TO 5000 C C 20. -- BEAM ROTATION C 2000 LINEAR = .FALSE. IF (.NOT. REFER) CALL DSROTN GO TO 5020 C C 25. -- OCTUPOLE C 2500 IF (TYPEC .EQ. 20) GO TO 2520 IF (JV .EQ. NTILT) CALL DSROTN GO TO 5000 C 2520 IF (JV .EQ. NTILT .AND. REFER) THEN CALL DSROTR GO TO 5000 ELSE GO TO 5020 ENDIF C C 27. -- ACCELERATOR FUNCTION ETA C 2700 LINEAR = .FALSE. SIGG = DPARM NV2 = IABS(NV2) IF (.NOT. EVP(NV2)) THEN DO 2710 J = 1, 6 ETAV(J,NV2) = 0.0 2710 CONTINUE ENDIF ETAV(JV,NV2) = ETAV(JV,NV2) + SIGG*UBEAM(JV) EVP(NV2) = .TRUE. GO TO 5020 C C 28. -- RBEND C OR C 29. -- SBEND C 2800 IF (TYPEC .EQ. 20) GO TO 2840 IF (TYPEC .EQ. 2) GO TO 2820 CALL DBENDI GO TO 5000 C 2820 IF (JV .EQ. NB .OR. JV .EQ. NE1 .OR. JV .EQ. NE2) GO TO 2825 IF (JV .EQ. NL .OR. JV .EQ. NBV .OR. JV .EQ. NRHO 1 .OR. JV .EQ. NANG) GO TO 2830 IF (JV .EQ. NH1 .OR. JV .EQ. NH2) GO TO 5000 GO TO 5020 C 2825 CALL DFRINJ GO TO 5000 C 2830 IE1 = IPTOJ(NE1) IE2 = IPTOJ(NE2) IF ((TYPE .EQ. 29 .AND. JV .EQ. NANG) 1 .OR. TYPE .EQ. 28 .AND. ((BEFORE .AND. IE1 .NE. 0)) 2 .OR. (.NOT. BEFORE .AND. IE2 .NE. 0)) THEN CALL DFRINB ELSE IF (TYPE .EQ. 28) THEN CALL DFRINR ENDIF GO TO 5000 C 2840 IF (JV .EQ. NTILT .AND. .NOT. REFER) THEN CALL DSROTR GO TO 5000 ELSE GO TO 5020 ENDIF C C 34. -- PLASMA LENS C 3400 LINEAR = .FALSE. IF (JV .EQ. 1) GO TO 3410 IF (JV .EQ. 2 .OR. JV .EQ. 3 .OR. JV .EQ. 4 .OR. JV .EQ. 5) 1 GO TO 3420 GO TO 5020 C 3410 LV = DPARM*UNITI(8) LVE = LV JQUAD = 1 CALL DFOL JQUAD = 3 CALL DFOL GO TO 5000 C 3420 IB = IPTOJ(2) IAP = IPTOJ(3) IG = IPTOJ(4) IK1 = IPTOJ(5) IF (JV .EQ. 2 .AND. IB .NE. 0) KVK = 0.5*UNITI(9)/(AP*PREF) IF (JV .EQ. 3 .AND. IAP .NE. 0) 1 KVK = - 0.5*UNITI(1)*B/(AP**2*PREF) IF (IG .NE. 0) KVK = 0.5*UNITI(9)/(PREF*UNITI(1)) IF (IK1 .NE. 0) KVK = 0.5/UNITI(8)**2 KVK = KVK*DPARM JQUAD = 1 CALL DFOCUS JQUAD = 3 CALL DFOCUS GO TO 5000 C C 35. -- HKICK -- HORIZONTAL VERNIER C OR C 36. -- VKICK -- VERTICAL VERNIER C 3500 IF (TYPEC .EQ. 20) GO TO 3540 IF (TYPEC .EQ. 2) GO TO 3530 IF (JV .LT. 1 .OR. JV .GT. 5) GO TO 5020 IF (JV .EQ. 2 .OR. JV .EQ. 3 .OR. JV .EQ. 4) GO TO 3510 IF (JV .EQ. 5) GO TO 3520 C DCOV = .TRUE. DAL = DPARM*B*UNITI(8)/PREF CODV(1) = - 0.5*DAL*L CODV(2) = - DAL RV(1,6) = 0.5*DAL*L RV(2,6) = DAL GO TO 5000 C 3510 IB = IPTOJ(2) IANG = IPTOJ(3) IK = IPTOJ(4) IF (IB .NE. 0.0) DAL = DPARM*L*UNITI(9)/PREF IF (IANG .NE. 0.0) DAL = DPARM*UNITI(7) IF (IK .NE. 0.0) DAL = - DPARM*UNITI(7) DCOV = .TRUE. CODV(1) = - 0.5*DAL*L CODV(2) = - DAL RV(1,6) = 0.5*DAL*L RV(2,6) = DAL GO TO 5000 C 3520 IF (REFER) THEN CALL DSROTR CALL DSROTC ENDIF GO TO 5000 C 3530 GO TO 5020 C 3540 IF (JV .EQ. NTILT .AND. .NOT. REFER) CALL DSROTN GO TO 5000 C C 37. -- ALIGNMENT MARKER C 3700 IF (TYPEC .EQ. 8) THEN LTAB = MOD(TYT/10,10) IF (LTAB .EQ. 0) THEN IF (RORC .LE. 2) CALL WOBBLE ENDIF ENDIF GO TO 5020 C C 42. -- KICKER -- VERNIER IN BOTH PLANES C 4200 IF (TYPEC .EQ. 20) GO TO 4240 IF (TYPEC .EQ. 2) GO TO 4220 IF (JV .NE. 2 .AND. JV .NE. 3) GO TO 5020 IKH = IPTOJ(2) IKV = IPTOJ(3) IF (IKH .NE. 0.0 .OR. IKV .NE. 0.0) DAL = - UNITI(7) IF (AL .NE. 0.0) DAL = DAL*HAL/AL DCOV = .TRUE. CODV(1) = - 0.5*DAL*L CODV(2) = - DAL RV(1,6) = 0.5*DAL*L RV(2,6) = DAL GO TO 5000 C 4220 GO TO 5020 C 4240 IF (JV .NE. 2 .AND. JV .NE. 3) GO TO 5020 LINEAR = .FALSE. IF (REFER) GO TO 5020 IF (AL .NE. 0.0) THEN IF (JV .EQ. 2) THEN DTH = VAL/AL**2 ELSE DTH = - HAL/AL**2 ENDIF ELSE DTH = 0.0 ENDIF DTH = DTH*UNITI(7) DPARM = DTH/UNITI(13) CALL DSROTN GO TO 5020 C C 43. -- REFERENCE COORDINATE SYSTEM SHIFT C 4300 LINEAR = .FALSE. SIGG = DPARM NV2 = IABS(NV2) IF (.NOT. CVP(NV2)) THEN DO 4310 J = 1, 6 COV(J,NV2) = 0.0 4310 CONTINUE ENDIF COV(JV,NV2) = COV(JV,NV2) + SIGG*UBEAM(JV) CVP(NV2) = .TRUE. GO TO 5020 C C RETURN C 5000 IF (NORD1 .GE. 2) CALL PARSEC IF (REFER .AND. TOTROT .NE. 0.0 .AND. .NOT. RSYM) CALL ROTAT1(NV2) 5020 RETURN END SUBROUTINE PARTRJ C C CALCULATES PARTIALS OF THIRD-ORDER MATRIX OF A SINGLE BEAM C ELEMENT WITH RESPECT TO THE VARIED QUANTITY C C ---------------------------------------------------------------------- INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'COP.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0C.CIN' INCLUDE 'ELM5A.CIN' INCLUDE 'ELM5B.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM14A.CIN' INCLUDE 'ELM15C.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'U.CIN' C C LOCAL VARIABLES C INTEGER IND, IX, K, M C------------------------------------------------------------------------------- C GO TO (5000, 200, 300, 400, 500,5000,5000,5000,5000,5000, 1 5000,5000,5000,1400,5000,5000,5000,1800,1900,5000, 2 5000,5000,5000,5000,2500,5000,5000,5000,5000,5000, 3 5000,5000,5000,3400,3500,3500,5000,5000,5000,5000, 4 5000,5000,5000,5000,5000,5000,5000,5000), TYPEC C C 2. -- POLE FACE ROTATION C 200 CONTINUE GO TO 5000 C C 3. -- DRIFT SPACE C 300 CONTINUE GO TO 5000 C C 4. -- BENDING MAGNET C 400 CALL DBEND3 GO TO 5000 C C 5. -- QUADRUPOLE C 500 IF (JV .EQ. 2 .OR. JV .EQ. 4 .OR. JV .EQ. 5) GO TO 520 JQUAD = 1 KQ2 = KX2 CALL DFOL3 JQUAD = 3 KQ2 = KY2 CALL DFOL3 GO TO 5000 C 520 JQUAD = 1 KQ2 = KX2 CALL DFOCU3 JQUAD = 3 KQ2 = KY2 KVK = - KVK CALL DFOCU3 KVK = - KVK GO TO 5000 C C 14. -- ARBITRARY MATRIX C 1400 IF (I14T .NE. 0) GO TO 1420 IX = I + 30 IND = 0 DO 1410 J = 1, 6 DO 1410 K = J, 6 DO 1410 M = K, 6 IX = IX + 1 IND = IND + 1 UV(J1,IND) = UBEAM(J1)/(UBEAM(J)*UBEAM(K)*UBEAM(M)) 1410 CONTINUE 1420 IF (NUM + 1 .LE. NEL) THEN IF (NEXT .EQ. 14) RETURN ENDIF GO TO 5000 C C 18. -- SEXTUPOLE C 1800 CALL DSEXT3 GO TO 5000 C C 19. -- SOLENOID C 1900 CONTINUE GO TO 5000 C C 25. -- OCTUPOLE C 2500 IF (SOFA) LINEAR = .FALSE. CALL DOCTPL GO TO 5000 C C 34. -- PLASMA LENS C 3400 CONTINUE GO TO 5000 C C 35. -- HKICK -- HORIZONTAL VERNIER C OR C 36. -- VKICK -- VERTICAL VERNIER C 3500 CONTINUE GO TO 5000 C 5000 CONTINUE RETURN END SUBROUTINE PHASE C C CONSTRAINS THE PHASE ADVANCE OF THE BEAM C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'CONSTS.CIN' INCLUDE 'ELM1C.CIN' INCLUDE 'ELM1D.CIN' INCLUDE 'ELM1E.CIN' INCLUDE 'ELM10A.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM10D.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'RC2.CIN' INCLUDE 'R2P.CIN' INCLUDE 'SI.CIN' INCLUDE 'SVP.CIN' C C LOCAL VARIABLES C LOGICAL LOGIC C----------------------------------------------------------------------- C C DETERMINE PHASE SHIFT IN BOTH TRANSVERSE PLANES C IF (.NOT. RECENT) CALL BEAM J = KCON K = J + 1 C IF (J .EQ. 1) THEN COC = PSIX/UNITO(12) SNP = SNPX CSP = CSPX ENDIF C IF (J .EQ. 3) THEN COC = PSIY/UNITO(12) SNP = SNPY CSP = CSPY ENDIF C C ADJUST UPWARD OR DOWNWARD BY 2*PI C PID = PI/UNITO(12) 10 IF (COC .GT. DE0 - PID) GO TO 20 COC = COC + 2.0*PID GO TO 10 C 20 IF (COC .LT. DE0 + PID) GO TO 30 COC = COC - 2.0*PID GO TO 20 C C DIFFERENCE BETWEEN ACTUAL AND DESIRED VALUES C 30 A(1) = DE0 - COC CALL CLI(LOGIC) IF (LOGIC) GO TO 150 C C DERIVATIVE WRT VARIED PARAMETER C IF (NV3 .LT. 1) GO TO 100 CW = 1.0/SD**2 C DO 90 N = 1, NV1 IF (R2P) GO TO 40 IF (.NOT. SVP(N)) GO TO 90 SVJJ = SV(J,J,N) SVJK = SV(J,K,N) GO TO 80 C 40 SVJJ = 0.0 SVJK = 0.0 IF (SVP(N)) THEN DO 45 L1 = 1, 6 DO 45 L2 = 1, 6 SVJJ = SVJJ + RC2(J,L1)*SV(L1,L2,N)*RC2(J,L2) SVJK = SVJK + RC2(J,L1)*SV(L1,L2,N)*RC2(K,L2) 45 CONTINUE ENDIF C 50 IF (R2VP(N)) THEN DO 75 L1 = 1, 6 DO 75 L2 = 1, 6 SVJJ = SVJJ + R2V(J,L1,N)*SI(L1,L2)*RC2(J,L2) 1 + RC2(J,L1)*SI(L1,L2)*R2V(J,L2,N) SVJK = SVJK + R2V(J,L1,N)*SI(L1,L2)*RC2(K,L2) 1 + RC2(J,L1)*SI(L1,L2)*R2V(K,L2,N) 75 CONTINUE ENDIF C 80 EPS0 = SQRT(SI(J,J)*SI(K,K) - SI(K,J)**2) EPS1 = SIT(J,J)*SIT(K,K) - SIT(K,J)**2 IF (EPS1 .GE. 0.0) THEN EPS1 = SQRT(EPS1) ELSE EPS1 = 0.0 ENDIF IF (EPS0 .EQ. 0.0 .OR. EPS1 .EQ. 0.0) THEN DOPH = .FALSE. GO TO 90 ENDIF BETA0 = SI(J,J)/EPS0 BETA1 = SIT(J,J)/EPS1 ALPHA0 = - SI(K,J)/EPS0 SNP = RC2(J,K)/SQRT(BETA0*BETA1) CSP = RC2(J,J)*SQRT(BETA0/BETA1) - ALPHA0*SNP C ZAP = BETA0*BETA1 ZIP = SQRT(ZAP) SNAP = SQRT(BETA0/BETA1) IF (SVP(N)) THEN DBETA0 = SV(J,J,N)/EPS0 DALPH0 = - SV(J,K,N)/EPS0 ELSE DBETA0 = 0.0 DALPH0 = 0.0 ENDIF DBETA1 = SVJJ/EPS1 DSNP = (ZIP*R2V(J,K,N) 1 - 0.5*RC2(J,K)*(DBETA1*BETA0 + BETA1*DBETA0)/ZIP)/ZAP DCSP = R2V(J,J,N)*SNAP 1 + 0.5*RC2(J,J)*(BETA1*DBETA0 2 - DBETA1*BETA0)/(SNAP*BETA1**2) 3 - DALPH0*SNP - ALPHA0*DSNP DTPSI = (CSP*DSNP - DCSP*SNP)/CSP**2 DPSI = CSP**2*DTPSI A(N+1) = DPSI/UNITO(12) 90 CONTINUE 100 CALL GATHER C 150 RETURN END SUBROUTINE PICKUP(I) C C STORES BEAM MATRIX AT UPDATE FOR USE IN MISALIGNMENT CALCULATION C C ---------------------------------------------------------------------- INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'COP.CIN' INCLUDE 'ELM0B.CIN' INCLUDE 'ELM0E.CIN' INCLUDE 'ELM1D.CIN' INCLUDE 'ELM7C.CIN' INCLUDE 'ELM8E.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'RC.CIN' INCLUDE 'RCP.CIN' INCLUDE 'RC2.CIN' INCLUDE 'R2P.CIN' C C LOCAL VARIABLES C INTEGER I, J, K C----------------------------------------------------------------------------- LUP(I) = LC IF (.NOT. RECENT) CALL BEAM SPO(I) = SOFA DO 5 J = 1, 6 COLD(I,J) = CEN(J) 5 CONTINUE C IF (NORD2 .LT. 1) GO TO 100 DO 10 J = 1, 6 DO 10 K = 1, 6 SIOL(I,J,K) = SIT(J,K) 10 CONTINUE C IF (RCP) THEN DO 20 J = 1, 6 DO 20 K = 1, 6 RCO(I,J,K) = RC(J,K) 20 CONTINUE ENDIF C 30 IF (I .EQ. 1) THEN DO 40 J = 1, 6 DO 40 K = 1, 6 R2O(J,K) = RC2(J,K) 40 CONTINUE ENDIF C RCPO(I) = RCP IF (I .EQ. 1) R2PO = R2P 100 RETURN END SUBROUTINE PIVENT C C COORDINATE TRANSFORMATION AT SECTION ENTRANCE C (USED FOR MISALIGNMENTS) C C ---------------------------------------------------------------------- INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM8A.CIN' INCLUDE 'ELM8D.CIN' C C LOCAL VARIABLES C INTEGER J, K REAL COSA, COST, S, SINA, SINT, XNORM C------------------------------------------------------------------------------- C IF (CHORD) GO TO 100 DO 10 J = 1, 3 DO 10 K = 1, 3 OT(J,K) = 0.0 10 CONTINUE DO 20 J = 1, 3 OT(J,J) = 1.0 20 CONTINUE DO 30 J = 1, 3 30 XT(J) = 0.0 C IF (TMK .EQ. 0) GO TO 200 IF (TMK .EQ. 2) GO TO 50 S = 0.0 DO 40 J = 1, 3 S = S + XR(J)**2 40 CONTINUE XT(3) = -0.5*S/XR(3) GO TO 200 C 50 DO 55 J = 1, 3 XT(J) = - XR(J) 55 CONTINUE DO 60 J = 1, 3 DO 60 K = 1, 3 OT(J,K) = OR(K,J) 60 CONTINUE GO TO 200 C C MISALIGNMENT ABOUT CHORD OF BENDING MAGNET C 100 S = 0.0 DO 112 J = 1, 3 S = S + XR(J)**2 112 CONTINUE XNORM = SQRT(S) DO 115 J = 1, 3 OT(J,3) = XR(J)/XNORM 115 CONTINUE OT(3,1) = - OT(1,3) OT(3,2) = - OT(2,3) SINA = SQRT(OT(1,3)**2 + OT(2,3)**2) COSA = OT(3,3) IF (SINA .EQ. 0.0) THEN COST = 1.0 SINT = 0.0 ELSE COST = OT(1,3)/SINA SINT = OT(2,3)/SINA ENDIF OT(1,1) = COST**2*COSA + SINT**2 OT(1,2) = COST*SINT*(COSA - 1.0) OT(2,1) = OT(1,2) OT(2,2) = SINT**2*COSA + COST**2 IF (TMK .EQ. 1) THEN DO 150 J = 1, 3 150 XT(J) = - 0.5*XR(J) ELSE IF (TMK .EQ. 2) THEN DO 160 J = 1, 3 160 XT(J) = - XR(J) ENDIF C 200 RETURN END SUBROUTINE PIVEX C C COORDINATE TRANSFORMATION AT SECTION EXIT C (USED FOR MISALIGNMENTS) C C ---------------------------------------------------------------------- C INCLUDE 'ELM8A.CIN' INCLUDE 'ELM8D.CIN' C C LOCAL VARIABLES C INTEGER J, K, N REAL S REAL ORT(3,3), XRT(3) C --------------------------------------------------------------------- C C PIVOT POINT ABOUT MAGNET CENTER C IF (CHORD) GO TO 100 IF (TMK .EQ. 0) GO TO 200 DO 30 J = 1, 3 30 XR(J) = XR(J) + XT(J) IF (TMK .EQ. 2) GO TO 150 GO TO 200 C C COORDINATE TRANSFORMATION FOR EXIT FACE C 100 S = 0.0 DO 110 J = 1, 3 110 XRT(J) = XR(J) DO 115 J = 1, 3 115 XR(J) = 0.0 DO 120 J = 1, 3 120 S = S + XRT(J)**2 XR(3) = SQRT(S) C C PIVOT POINT AT CHORD MIDPOINT C IF (TMK .EQ. 1) THEN DO 130 J = 1, 3 130 XR(J) = 0.5*XR(J) ELSE IF (TMK .EQ. 2) THEN DO 135 J = 1, 3 135 XR(J) = 0.0 ENDIF C C COORDINATE TRANSFORMATION FOR EXIT FACE C 150 DO 160 J = 1, 3 DO 160 K = 1, 3 ORT(J,K) = OR(J,K) 160 CONTINUE C DO 180 J = 1, 3 DO 180 K = 1, 3 S = 0.0 DO 175 N = 1, 3 S = S + ORT(J,N)*OT(N,K) 175 CONTINUE OR(J,K) = S 180 CONTINUE C 200 RETURN END SUBROUTINE PLOTIT C C OUTPUTS LISTS OF MATRIX ELEMENTS FOR PLOTTING C C ---------------------------------------------------------------------- INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'CONSTS.CIN' INCLUDE 'DEBUG.CIN' INCLUDE 'ELM0C.CIN' INCLUDE 'ELM1D.CIN' INCLUDE 'ELM10A.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM15C.CIN' INCLUDE 'ELM38A.CIN' INCLUDE 'ELM38B.CIN' INCLUDE 'ELM38C.CIN' INCLUDE 'ELM38F.CIN' INCLUDE 'FLUSHC.CIN' INCLUDE 'IOUNIT.CIN' C C LOCAL VARIABLES C INTEGER J, K, N, NLAY, NP1 LOGICAL LAYOUT REAL ALF, COV, CORR, DALF, HMAX, HOR, PSI, VER, 1 VMAX C--------------------------------------------------------------------- C NANGS = 100 DEBUG = .FALSE. NLAY = 0 DO 10 J = 1, NPLT JCON = JPLOT(J) KCON = KPLOT(J) IF (JCON .EQ. 8 .AND. KCON .LE. 3) NLAY = NLAY + 1 CALL CONSTR IF (FLUSHL) GO TO 500 QPLOT(J) = COC 10 CONTINUE LAYOUT = NPLT .EQ. 2 .AND. NLAY .EQ. 2 C IF (LAYOUT) GO TO 100 C C PLOT OF PHASE ELLIPSE C IF (NPLT .EQ. 2 .AND. EPLOT(1) .AND. EPLOT(2)) THEN NP1 = NANGS + 1 DALF = 2.0*PI/FLOAT(NANGS) IF (.NOT. RECENT) CALL BEAM J = JPLOT(1) K = KPLOT(2) HMAX = SQRT(SIT(J,J))/UBEAM(J) VMAX = SQRT(SIT(K,K))/UBEAM(K) COV = SIT(J,K)/(UBEAM(J)*UBEAM(K)) CORR = COV/(HMAX*VMAX) PSI = ASIN(CORR) DO 60 N = 1, NP1 ALF = FLOAT(N-1)*DALF HOR = HMAX*SIN(ALF) VER = VMAX*COS(ALF-PSI) WRITE (NPLOT,9008) HOR, VER 60 CONTINUE C C PLOT OF ANYTHING ELSE C INCLUDING ANYTHING VS ACCUMULATED LENGTH C ELSE WRITE (NPLOT,9008) (QPLOT(J), J = 1, NPLT) 9008 FORMAT (8F10.5) ENDIF GO TO 300 C C BEAM LINE LAYOUT C 100 CALL PLTREF IF (HIGH .EQ. 0.0 .OR. WIDE .EQ. 0.0) GO TO 500 C C RECTANGULARLY SHAPED BEAM LINE MAGNET C IF (TYPED .EQ. 29) GO TO 200 C C VIEW FROM ABOVE C IF (ND .EQ. 2) GO TO 150 CALL PLTRXZ GO TO 300 C C VIEW FROM THE SIDE C 150 CALL PLTRYZ GO TO 300 C C WEDGE BENDING MAGNET C 200 IF (ND .EQ. 1) THEN CALL PLTSXZ ELSE CALL PLTSYZ ENDIF C 300 PLNOW = .FALSE. C 500 RETURN END SUBROUTINE PLSGET C C VALUES OF PARAMETERS DESCRIBING A PLASMA LENS C C ---------------------------------------------------------------------- INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0B.CIN' INCLUDE 'ELM1A.CIN' INCLUDE 'ELM4A.CIN' INCLUDE 'ELM4C.CIN' INCLUDE 'ELM5A.CIN' INCLUDE 'ELM6.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'ELM16B.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'ELM26B.CIN' INCLUDE 'FLUSHC.CIN' INCLUDE 'INDPAR.CIN' INCLUDE 'IOUNIT.CIN' INCLUDE 'XRAN.CIN' C C LOCAL VARIABLES C INTEGER IADR, IAP, IB, IG, IK1 REAL DATAR C------------------------------------------------------------------------------- C C MAGNET LENGTH C IADR = I + 1 L = DATAR(IADR) IF (PRAN34(1) .NE. 0.0) L = L + PRAN34(1)*XRAN(1) L = L*UNITI(8) LMAG = L C C INDICES OF OTHER PARAMETERS C IB = IPTOJ(2) IAP = IPTOJ(3) IG = IPTOJ(4) IK1 = IPTOJ(5) IF (IG .NE. 0) GO TO 10 IF (IK1 .NE. 0) GO TO 20 IF (IB .NE. 0) GO TO 5 KQ2 = 0.0 GO TO 40 C C MAGNETIC FIELD AND APERTURE C 5 IADR = I + IB B = DATAR(IADR) IF (PRAN34(2) .NE. 0.0) B = B + PRAN34(2)*XRAN(2) B = B*UNITI(9)*RI/PREF IF (IAP .NE. 0) THEN IADR = I + IAP AP = DATAR(IADR) ELSE WRITE (NOUT,9012) 9012 FORMAT (' *** ERROR *** PLASMA LENS APERTURE NOT GIVEN') FLUSHL = .TRUE. KQ2 = 0.0 AP = 0.0 GO TO 40 ENDIF IF (AP .NE. 0.0) THEN IF (PRAN34(3) .NE. 0.0) AP = AP + PRAN34(3)*XRAN(3) AP = AP*UNITI(1) IF (NORD1 .LT. 1) GO TO 40 KQ2 = B/(AP*RI) ELSE WRITE (NOUT,9011) 9011 FORMAT (' *** ERROR *** PLASMA LENS APERTURE SET TO ZERO') FLUSHL = .TRUE. KQ2 = 0.0 ENDIF GO TO 40 C C GRADIENT C 10 IADR = I + IG GRAD = DATAR(IADR) IF (PRAN34(4) .NE. 0.0) GRAD = GRAD + PRAN34(4)*XRAN(4) GRAD = GRAD*UNITI(9)*RI/(PREF*UNITI(1)) KQ2 = GRAD/RI GO TO 40 C C NORMALIZED GRADIENT (MAD NOTATION) C 20 IADR = I + IK1 K1 = DATAR(IADR) IF (PRAN34(5) .NE. 0.0) K1 = K1 + PRAN34(5)*XRAN(5) KQ2 = K1/UNITI(8)**2 C 40 RETURN END SUBROUTINE PLTREF C C PLOTS REFERENCE TRAJECTORY C C ---------------------------------------------------------------------- INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'CONSTS.CIN' INCLUDE 'DATA0A.CIN' INCLUDE 'DATA1A.CIN' INCLUDE 'DEBUG.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM0B.CIN' INCLUDE 'ELM0C.CIN' INCLUDE 'ELM4A.CIN' INCLUDE 'ELM15C.CIN' INCLUDE 'ELM38B.CIN' INCLUDE 'ELM38C.CIN' INCLUDE 'ELM38E.CIN' INCLUDE 'ELM38F.CIN' INCLUDE 'INDPAR.CIN' INCLUDE 'IOUNIT.CIN' INCLUDE 'OC.CIN' C C LOCAL VARIABLES C REAL LB REAL OMAG(3,3), XMAG(3) REAL O1(3,3) EQUIVALENCE (X1,XMAG(1)), (X2,XMAG(2)), (X3,XMAG(3)) DATA DSTEP /2.0/, NDB /6/ C------------------------------------------------------------------- C NA = KPLOT(1) ND = KPLOT(2) C QORIG(1) = QPLOT(1) QORIG(2) = QPLOT(2) IF (TYPED .EQ. 4 .OR. TYPED .EQ. 28 .OR. TYPED .EQ. 29) THEN NANGS = INT((ABS(AL)*RADIAN + 1.0)/DSTEP) NANGS = MAX0(NANGS,2) DANG = AL/FLOAT(NANGS) DLB = L/FLOAT(NANGS) ANG = AL LB = L DO 20 JN = 1, NANGS IF (H0 .EQ. 0.0) THEN X1 = 0.0 X2 = 0.0 X3 = - LB LB = LB - DLB ELSE SNA = SIN(ANG) CSA = COS(ANG) IF (CSA .GT. 0.5) X1 = - SNA**2/(H0*(1.0 + CSA)) IF (CSA .LE. 0.5) X1 = - (1.0 - CSA)/H0 X2 = 0.0 X3 = - SNA/H0 ANG = ANG - DANG ENDIF C DO 10 J = 1, 3 S = 0.0 DO 5 K = 1, 3 S = S + O(4,K,J)*XMAG(K) 5 CONTINUE XPT(J) = X0(4,J) + S 10 CONTINUE C QPLOT(1) = XPT(NA)/UFLOOR(1) QPLOT(2) = XPT(ND)/UFLOOR(1) IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) 7009 FORMAT (' QPLOT = ',2F12.5) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) 7008 FORMAT (8F10.5) 20 CONTINUE C QPLOT(1) = QORIG(1) QPLOT(2) = QORIG(2) ELSE QPLOT(1) = X0(4,NA)/UFLOOR(1) QPLOT(2) = X0(4,ND)/UFLOOR(1) ENDIF IF (DEBUG) WRITE (NDB,7004) 7004 FORMAT (' EXIT POINT OF REFERENCE TRAJECTORY') IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) C WIDE = 0.0 HIGH = 0.0 IF (TYPED .EQ. 1 .OR. TYPED .EQ. 20) GO TO 500 IF (NUMTYP .EQ. 0) GO TO 500 II = ISTOR(NUMTYP) CALL SKETCH(NUMTYP) IWIDE = IPTOJ(1) IHIGH = IPTOJ(2) IF (IWIDE .NE. 0) WIDE = DATA(II + IWIDE)*UFLOOR(1) IF (IHIGH .NE. 0) HIGH = DATA(II + IHIGH)*UFLOOR(1) IF (KPLOT(2) .EQ. 1) DIM = WIDE IF (KPLOT(2) .EQ. 2) DIM = HIGH IF (DIM .EQ. 0.0) GO TO 500 C IF (TYPED .EQ. 28) THEN HAL = 0.5*AL SN2 = SIN(HAL) CS2 = COS(HAL) DO 120 J = 1, 3 DO 120 K = 1, 3 OMAG(J,K) = 0.0 120 CONTINUE OMAG(1,1) = CS2 OMAG(1,3) = - SN2 OMAG(2,2) = 1.0 OMAG(3,1) = SN2 OMAG(3,3) = CS2 C DO 130 J = 1, 3 DO 130 K = 1, 3 S1 = 0.0 DO 125 LL = 1, 3 S1 = S1 + OMAG(J,LL)*O(4,LL,K) 125 CONTINUE O1(J,K) = S1 130 CONTINUE C DO 140 J = 1, 3 DO 140 K = 1, 3 OPT(J,K) = O1(J,K) 140 CONTINUE C SAGIT = 0.5*SN2**2/(H0*(1.0 + CS2)) ELSE DO 150 J = 1, 3 DO 150 K = 1, 3 OPT(J,K) = O(4,J,K) 150 CONTINUE ENDIF C QORIG(1) = QPLOT(1) QORIG(2) = QPLOT(2) C 500 RETURN END SUBROUTINE PLTRXZ C C PLOTS RBEND ON A HORIZONTAL PLANE C C ---------------------------------------------------------------------- INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DEBUG.CIN' INCLUDE 'ELM0B.CIN' INCLUDE 'ELM0C.CIN' INCLUDE 'ELM5A.CIN' INCLUDE 'ELM15C.CIN' INCLUDE 'ELM38C.CIN' INCLUDE 'ELM38D.CIN' INCLUDE 'ELM38E.CIN' INCLUDE 'ELM38F.CIN' INCLUDE 'IOUNIT.CIN' INCLUDE 'OC.CIN' C C LOCAL VARIABLES C LOGICAL HTSIDE DATA NDB /6/ C----------------------------------------------------------------------- C C CHARACTERIZE ORIENTATION OF MAGNET C DOTOP = ABS(OPT(2,2)) .GE. 0.001 DOSIDE = ABS(OPT(1,2)) .GE. 0.001 DOENT = OPT(3,2) .LE. -0.001 DOEXIT = OPT(3,2) .GE. 0.001 ROLD = OPT(1,2) .NE. 0.0 REVERS = OPT(2,2) .LE. -0.0001 REVERS = REVERS .OR. 1 ABS(OPT(2,2)) .LT. 0.0001 .AND. OPT(1,2) .LT. -0.0001 CWISE = OPT(1,2) .GT. 0.0 IF (REVERS) CWISE = .NOT. CWISE IF (DEBUG) WRITE (NDB,7018) DOENT, DOEXIT, DOTOP, DOSIDE, CWISE, 1 REVERS 7018 FORMAT (' DOENT = ',L1,2X,'DOEX = ',L1,2X,'DOTOP = ',L1,2X, 1 ' DOSIDE = ',L1,2X,' CWISE = ',L1,2X,'REVERS = ',L1) C C PROJECTIONS OF MAGNET EDGES C DUW = OPT(1,1)*WIDE/UFLOOR(1) DUH = OPT(2,1)*HIGH/UFLOOR(1) DAW = OPT(1,3)*WIDE/UFLOOR(1) DAH = OPT(2,3)*HIGH/UFLOOR(1) IF (TYPED .EQ. 28) THEN DUS = OPT(1,1)*SAGIT/UFLOOR(1) DAS = OPT(1,3)*SAGIT/UFLOOR(1) ENDIF C IF (REVERS) THEN IF (DEBUG) WRITE (NDB,7017) 7017 FORMAT (' TRANSVERSE COORDINATES REVERSED') DUW = - DUW DUH = - DUH DAW = - DAW DAH = - DAH IF (TYPED .EQ. 28) THEN DUS = - DUS DAS = - DAS ENDIF ENDIF L = LMAG DUL = OPT(3,1)*L/UFLOOR(1) DAL = OPT(3,3)*L/UFLOOR(1) IF (DEBUG) WRITE (NDB,7013) DAW, DUW 7013 FORMAT (' DAW = ',F12.5,3X,'DUW = ',F12.5) IF (DEBUG) WRITE (NDB,7014) DAH, DUH 7014 FORMAT (' DAH = ',F12.5,3X,'DUH = ',F12.5) IF (DEBUG) WRITE (NDB,7015) DAL, DUL 7015 FORMAT (' DAL = ',F12.5,3X,'DUL = ',F12.5) IF (DEBUG) WRITE (NDB,7016) DAS, DUS 7016 FORMAT (' DAS = ',F12.5,3X,'DUS = ',F12.5) C C INTERSECTION OF REFERENCE TRAJECTORY WITH PROJECTED C DOWNSTREAM EDGE C IF (DOEXIT .OR. DOENT) THEN IF (DEBUG) WRITE (NDB,7012) 7012 FORMAT (' VIEW FROM DOWNSTREAM END') GNUW = OPT(1,1)*OPT(2,3) - OPT(2,1)*OPT(1,3) GNUS = OPT(3,1)*OPT(2,3) - OPT(2,1)*OPT(3,3) DEN = OPT(2,1)*O(4,3,3) - O(4,3,1)*OPT(2,3) IF (ABS(DEN) .LT. 0.00001) THEN SW = 0.0 ELSE SNUM = GNUW*WIDE IF (TYPED .EQ. 28) SNUM = SNUM + GNUS*SAGIT SW = 0.5*SNUM/(DEN*UFLOOR(1)) SW = SIGN(SW,OPT(3,3)) ENDIF GNUH = OPT(1,3)*OPT(2,1) - OPT(1,1)*OPT(2,3) DEN = O(4,3,3)*OPT(1,1) - OPT(1,3)*O(4,3,1) IF (ABS(DEN) .LT. 0.00001) THEN SH = 0.0 ELSE SH = 0.5*GNUH*HIGH/(DEN*UFLOOR(1)) SH = SIGN(SH,OPT(3,3)) ENDIF IF (SW .EQ. 0.0) THEN SLESS = SH ELSE IF (SH .EQ. 0.0) THEN SLESS = SW ELSE SLESS = AMIN1(SH,SW) ENDIF HTSIDE = SH .NE. 0.0 .AND. SW .NE. 0.0 .AND. SW .LT. SH HTSIDE = SH .EQ. 0.0 .OR. HTSIDE IF (DEBUG) WRITE (NDB,7019) HTSIDE 7019 FORMAT (' HTSIDE = ',L2) IF (DEBUG) WRITE (NDB,7006) SW, SH, SLESS 7006 FORMAT (' SW = ',E15.5,3X,'SH = ',E15.5,3X,'SLESS = ',E15.5) QPLOT(1) = QORIG(1) + O(4,3,3)*SLESS QPLOT(2) = QORIG(2) + O(4,3,1)*SLESS IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) 7009 FORMAT (' QPLOT = ',2F12.5) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) 7008 FORMAT (8F10.5) IF (TYPED .EQ. 28) THEN QORIG(1) = QORIG(1) + DAS QORIG(2) = QORIG(2) + DUS ENDIF ELSE QPLOT(1) = QPLOT(1) + DAS QPLOT(2) = QPLOT(2) + DUS QORIG(1) = QPLOT(1) QORIG(2) = QPLOT(2) ENDIF C C IF FACING EXIT, TRACE ABOUT EXIT FACE C IF (DOEXIT) THEN IF (HTSIDE .AND. CWISE) THEN IF (DEBUG) WRITE (NDB,7023) 7023 FORMAT (' TRACE ALONG LOWER SIDE') QPLOT(1) = QORIG(1) - 0.5*DAH - 0.5*DAW QPLOT(2) = QORIG(2) - 0.5*DUH - 0.5*DUW IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF C IF (.NOT. HTSIDE .OR. (HTSIDE .AND. CWISE)) THEN IF (DEBUG) WRITE (NDB,7024) 7024 FORMAT (' TRACE ALONG BOTTOM') QPLOT(1) = QORIG(1) - 0.5*DAH + 0.5*DAW QPLOT(2) = QORIG(2) - 0.5*DUH + 0.5*DUW IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF C IF (DEBUG) WRITE (NDB,7022) 7022 FORMAT (' LOOP AROUND EXIT FACE') QPLOT(1) = QORIG(1) + 0.5*DAH + 0.5*DAW QPLOT(2) = QORIG(2) + 0.5*DUH + 0.5*DUW IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) - DAW QPLOT(2) = QPLOT(2) - DUW IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) - DAH QPLOT(2) = QPLOT(2) - DUH IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) + DAW QPLOT(2) = QPLOT(2) + DUW IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) + 0.5*DAH QPLOT(2) = QPLOT(2) + 0.5*DUH ENDIF C C IF NOT FACING EXIT, TRACE APPROPRIATE EXIT EDGES C IF (DOENT .AND. DOTOP) THEN IF (HTSIDE .AND. CWISE) THEN QPLOT(1) = QORIG(1) + 0.5*DAH + 0.5*DAW QPLOT(2) = QORIG(2) + 0.5*DUH + 0.5*DUW IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF IF (HTSIDE .AND. .NOT. CWISE) THEN QPLOT(1) = QORIG(1) + 0.5*DAH - 0.5*DAW QPLOT(2) = QORIG(2) + 0.5*DUH - 0.5*DUW IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF QPLOT(1) = QORIG(1) + 0.5*DAH QPLOT(2) = QORIG(2) + 0.5*DUH IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF C IF (DOEXIT .AND. DOTOP) THEN IF (DEBUG) WRITE (NDB,7025) 7025 FORMAT (' TRANSITION FROM EXIT FACE TO TOP') QPLOT(1) = QPLOT(1) + 0.5*DAH QPLOT(2) = QPLOT(2) + 0.5*DUH IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) - 0.5*DAW QPLOT(2) = QPLOT(2) - 0.5*DUW ENDIF C C VIEW FROM TOP C IF (DOTOP) THEN IF (DEBUG) WRITE (NDB,7010) 7010 FORMAT (' VIEW FROM TOP') QPLOT(1) = QPLOT(1) + 0.5*DAW QPLOT(2) = QPLOT(2) + 0.5*DUW IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) - DAL QPLOT(2) = QPLOT(2) - DUL IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) - DAW QPLOT(2) = QPLOT(2) - DUW IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) IF (DOENT) THEN IF (DEBUG) WRITE (NDB,7021) 7021 FORMAT (' LOOP AROUND ENTRANCE FACE') QPLOT(1) = QPLOT(1) - DAH QPLOT(2) = QPLOT(2) - DUH IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) + DAW QPLOT(2) = QPLOT(2) + DUW IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) + DAH QPLOT(2) = QPLOT(2) + DUH IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) - DAW QPLOT(2) = QPLOT(2) - DUW IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF QPLOT(1) = QPLOT(1) + DAL QPLOT(2) = QPLOT(2) + DUL IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) + 0.5*DAW QPLOT(2) = QPLOT(2) + 0.5*DUW ENDIF C IF (DOTOP .AND. .NOT. DOSIDE) THEN IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF C C TRANSITION FROM TOP TO SIDE C IF (DOSIDE .AND. DOTOP) THEN IF (DEBUG) WRITE (NDB,7026) 7026 FORMAT (' TRANSITION FROM TOP TO SIDE') IF (CWISE) THEN QPLOT(1) = QPLOT(1) + 0.5*DAW QPLOT(2) = QPLOT(2) + 0.5*DUW ELSE QPLOT(1) = QPLOT(1) - 0.5*DAW QPLOT(2) = QPLOT(2) - 0.5*DUW ENDIF IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) - 0.5*DAH QPLOT(2) = QPLOT(2) - 0.5*DUH ENDIF C C VIEW FROM SIDE C IF (DOSIDE) THEN IF (DEBUG) WRITE (NDB,7011) 7011 FORMAT (' VIEW FROM SIDE') QPLOT(1) = QPLOT(1) - 0.5*DAH QPLOT(2) = QPLOT(2) - 0.5*DUH IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) - DAL QPLOT(2) = QPLOT(2) - DUL IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) + DAH QPLOT(2) = QPLOT(2) + DUH IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) IF (DOENT .AND. .NOT. DOTOP) THEN IF (DEBUG) WRITE (NDB,7027) 7027 FORMAT (' LOOP AROUND ENTRANCE FACE') QPLOT(1) = QPLOT(1) - DAW QPLOT(2) = QPLOT(2) - DUW IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) - DAH QPLOT(2) = QPLOT(2) - DUH IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) + DAW QPLOT(2) = QPLOT(2) + DUW IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) + DAH QPLOT(2) = QPLOT(2) + DUH IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF QPLOT(1) = QPLOT(1) + DAL QPLOT(2) = QPLOT(2) + DUL IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) - 0.5*DAH QPLOT(2) = QPLOT(2) - 0.5*DUH IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF C C LOOP AROUND EXIT FACE C IF (DOEXIT) THEN IF (DEBUG) WRITE (NDB,7020) 7020 FORMAT (' LOOP AROUND EXIT FACE') IF (DOSIDE .AND. DOTOP .AND. CWISE) THEN QPLOT(1) = QPLOT(1) + 0.5*DAH QPLOT(2) = QPLOT(2) + 0.5*DUH IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) - 0.5*DAW QPLOT(2) = QPLOT(2) - 0.5*DUW ENDIF C IF (DOTOP .AND. (.NOT. ROLD .OR. CWISE)) THEN QPLOT(1) = QPLOT(1) - 0.5*DAW QPLOT(2) = QPLOT(2) - 0.5*DUW IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) - 0.5*DAH QPLOT(2) = QPLOT(2) - 0.5*DUH ENDIF C IF (.NOT. HTSIDE .OR. (HTSIDE .AND. .NOT. CWISE)) THEN QPLOT(1) = QORIG(1) - 0.5*DAH - 0.5*DAW QPLOT(2) = QORIG(2) - 0.5*DUH - 0.5*DUW IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF C IF (HTSIDE .AND. .NOT. CWISE) THEN QPLOT(1) = QORIG(1) - 0.5*DAH + 0.5*DAW QPLOT(2) = QORIG(2) - 0.5*DUH + 0.5*DUW IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF ENDIF C IF (DOENT .AND. .NOT. HTSIDE) THEN QPLOT(1) = QPLOT(1) + 0.5*DAH QPLOT(2) = QPLOT(2) + 0.5*DUH IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF C C REFERENCE TRAJECTORY AT EXIT FACE C IF (DEBUG) WRITE (NDB,7033) DOEXIT, DOENT 7033 FORMAT (' DOEXIT = ',L1,2X,'DOENT = ',L1) IF (DOEXIT .OR. DOENT) THEN QORIG(1) = QORIG(1) - DAS QORIG(2) = QORIG(2) - DUS QPLOT(1) = QORIG(1) + O(4,3,3)*SLESS QPLOT(2) = QORIG(2) + O(4,3,1)*SLESS IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QORIG(1) QPLOT(2) = QORIG(2) IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ELSE QPLOT(1) = QPLOT(1) - DAS QPLOT(2) = QPLOT(2) - DUS IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF RETURN END SUBROUTINE PLTRYZ C C PLOTS RBEND ON A VERTICAL PLANE C C ---------------------------------------------------------------------- INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DEBUG.CIN' INCLUDE 'ELM0B.CIN' INCLUDE 'ELM0C.CIN' INCLUDE 'ELM5A.CIN' INCLUDE 'ELM15C.CIN' INCLUDE 'ELM38C.CIN' INCLUDE 'ELM38D.CIN' INCLUDE 'ELM38E.CIN' INCLUDE 'ELM38F.CIN' INCLUDE 'IOUNIT.CIN' INCLUDE 'OC.CIN' C C LOCAL VARIABLES C LOGICAL HTTOP DATA NDB /6/ C---------------------------------------------------------------------- C C CHARACTERIZE ORIENTATION OF MAGNET C DOTOP = ABS(OPT(2,1)) .GE. 0.001 DOSIDE = ABS(OPT(1,1)) .GE. 0.001 DOENT = OPT(3,1) .GE. 0.001 DOEXIT = OPT(3,1) .LE. -0.001 ROLD = OPT(2,1) .NE. 0.0 REVERS = OPT(1,1) .LE. -0.0001 REVERS = REVERS .OR. 1 ABS(OPT(1,1)) .LT. 0.0001 .AND. OPT(2,1) .LT. -0.0001 CWISE = OPT(2,1) .LT. 0.0 IF (REVERS) CWISE = .NOT. CWISE IF (DEBUG) WRITE (NDB,7018) DOENT, DOEXIT, DOTOP, DOSIDE, CWISE, 1 REVERS 7018 FORMAT (' DOENT = ',L1,2X,'DOEX = ',L1,2X,'DOTOP = ',L1,2X, 1 ' DOSIDE = ',L1,2X,' CWISE = ',L1,2X,'REVERS = ',L1) C C PROJECTIONS OF MAGNET EDGES C DUW = OPT(1,2)*WIDE/UFLOOR(1) DUH = OPT(2,2)*HIGH/UFLOOR(1) DAW = OPT(1,3)*WIDE/UFLOOR(1) DAH = OPT(2,3)*HIGH/UFLOOR(1) IF (TYPED .EQ. 28) THEN DUS = OPT(1,2)*SAGIT/UFLOOR(1) DAS = OPT(1,3)*SAGIT/UFLOOR(1) ENDIF C IF (REVERS) THEN IF (DEBUG) WRITE (NDB,7017) 7017 FORMAT (' TRANSVERSE COORDINATES REVERSED') DUW = - DUW DUH = - DUH DAW = - DAW DAH = - DAH IF (TYPED .EQ. 28) THEN DUS = - DUS DAS = - DAS ENDIF ENDIF L = LMAG DUL = OPT(3,2)*L/UFLOOR(1) DAL = OPT(3,3)*L/UFLOOR(1) IF (DEBUG) WRITE (NDB,7013) DAW, DUW 7013 FORMAT (' DAW = ',F12.5,3X,'DUW = ',F12.5) IF (DEBUG) WRITE (NDB,7014) DAH, DUH 7014 FORMAT (' DAH = ',F12.5,3X,'DUH = ',F12.5) IF (DEBUG) WRITE (NDB,7015) DAL, DUL 7015 FORMAT (' DAL = ',F12.5,3X,'DUL = ',F12.5) IF (DEBUG) WRITE (NDB,7016) DAS, DUS 7016 FORMAT (' DAS = ',F12.5,3X,'DUS = ',F12.5) C C INTERSECTION OF REFERENCE TRAJECTORY WITH PROJECTED C DOWNSTREAM EDGE C IF (DOEXIT .OR. DOENT) THEN IF (DEBUG) WRITE (NDB,7012) 7012 FORMAT (' VIEW FROM DOWNSTREAM END') GNUW = OPT(1,2)*OPT(2,3) - OPT(2,2)*OPT(1,3) GNUS = OPT(3,2)*OPT(2,3) - OPT(2,2)*OPT(3,3) DEN = OPT(2,2)*O(4,3,3) - O(4,3,2)*OPT(2,3) IF (ABS(DEN) .LT. 0.00001) THEN SW = 0.0 ELSE SNUM = GNUW*WIDE C IF (TYPED .EQ. 28) SNUM = SNUM + GNUS*SAGIT SW = 0.5*SNUM/(DEN*UFLOOR(1)) SW = SIGN(SW,OPT(3,3)) ENDIF GNU = OPT(1,3)*OPT(2,2) - OPT(1,2)*OPT(2,3) DEN = O(4,3,3)*OPT(1,2) - OPT(1,3)*O(4,3,2) IF (ABS(DEN) .LT. 0.00001) THEN SH = 0.0 ELSE SH = 0.5*GNU*HIGH/(DEN*UFLOOR(1)) SH = SIGN(SH,OPT(3,3)) ENDIF IF (SW .EQ. 0.0) THEN SLESS = SH ELSE IF (SH .EQ. 0.0) THEN SLESS = SW ELSE SLESS = AMIN1(SH,SW) ENDIF HTTOP = SH .NE. 0.0 .AND. SW .NE. 0.0 .AND. SH .LT. SW HTTOP = SW .EQ. 0.0 .OR. HTTOP IF (DEBUG) WRITE (NDB,7028) HTTOP 7028 FORMAT (' HTTOP = ',L2) IF (DEBUG) WRITE (NDB,7006) SW, SH, SLESS 7006 FORMAT (' SW = ',E15.5,3X,'SH = ',E15.5,3X,'SLESS = ',E15.5) QPLOT(1) = QORIG(1) + O(4,3,3)*SLESS QPLOT(2) = QORIG(2) + O(4,3,2)*SLESS IF (DEBUG) WRITE (NDB,7051) (QORIG(J), J = 1, 2) 7051 FORMAT (' QORIG = ',2F12.5) IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) 7009 FORMAT (' QPLOT = ',2F12.5) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) 7008 FORMAT (8F10.5) ENDIF C C IF FACING EXIT, TRACE ABOUT EXIT FACE C IF (DOEXIT) THEN IF (HTTOP .AND. CWISE) THEN IF (DEBUG) WRITE (NDB,7023) 7023 FORMAT (' TRACE ALONG LOWER SIDE') QPLOT(1) = QORIG(1) + 0.5*DAW - 0.5*DAH QPLOT(2) = QORIG(2) + 0.5*DUW - 0.5*DUH IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF C IF (.NOT. HTTOP .OR. (HTTOP .AND. CWISE)) THEN IF (DEBUG) WRITE (NDB,7029) 7029 FORMAT (' TRACE ALONG FAR FACE') QPLOT(1) = QORIG(1) + 0.5*DAW + 0.5*DAH QPLOT(2) = QORIG(2) + 0.5*DUW + 0.5*DUH IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF C IF (DEBUG) WRITE (NDB,7022) 7022 FORMAT (' LOOP AROUND EXIT FACE') QPLOT(1) = QORIG(1) - 0.5*DAW + 0.5*DAH QPLOT(2) = QORIG(2) - 0.5*DUW + 0.5*DUH IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) - DAH QPLOT(2) = QPLOT(2) - DUH IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) + DAW QPLOT(2) = QPLOT(2) + DUW IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) + DAH QPLOT(2) = QPLOT(2) + DUH IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) - 0.5*DAW QPLOT(2) = QPLOT(2) - 0.5*DUW ENDIF C C IF NOT FACING EXIT, TRACE APPROPRIATE EXIT EDGES C IF (DOENT .AND. DOSIDE) THEN IF (HTTOP .AND. CWISE) THEN QPLOT(1) = QORIG(1) + 0.5*DAH - 0.5*DAW QPLOT(2) = QORIG(2) + 0.5*DUH - 0.5*DUW IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF IF (HTTOP .AND. .NOT. CWISE) THEN QPLOT(1) = QORIG(1) - 0.5*DAH - 0.5*DAW QPLOT(2) = QORIG(2) - 0.5*DUH - 0.5*DUW IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF QPLOT(1) = QORIG(1) - 0.5*DAW QPLOT(2) = QORIG(2) - 0.5*DUW IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF C IF (DOEXIT .AND. DOSIDE) THEN IF (DEBUG) WRITE (NDB,7030) 7030 FORMAT (' TRANSITION FROM EXIT FACE TO SIDE') QPLOT(1) = QPLOT(1) - 0.5*DAW QPLOT(2) = QPLOT(2) - 0.5*DUW IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) - 0.5*DAH QPLOT(2) = QPLOT(2) - 0.5*DUH ENDIF C IF (DOSIDE .AND. DOTOP .AND. .NOT. DOENT .AND. .NOT. DOEXIT) THEN QPLOT(1) = QORIG(1) - 0.5*DAW QPLOT(2) = QORIG(2) - 0.5*DUW ENDIF C C VIEW FROM SIDE C IF (DOSIDE) THEN IF (DEBUG) WRITE (NDB,7011) 7011 FORMAT (' VIEW FROM SIDE') QPLOT(1) = QPLOT(1) + 0.5*DAH QPLOT(2) = QPLOT(2) + 0.5*DUH IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) - DAL QPLOT(2) = QPLOT(2) - DUL IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) - DAH QPLOT(2) = QPLOT(2) - DUH IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) IF (DOENT) THEN IF (DEBUG) WRITE (NDB,7021) 7021 FORMAT (' LOOP AROUND ENTRANCE FACE') QPLOT(1) = QPLOT(1) + DAW QPLOT(2) = QPLOT(2) + DUW IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) + DAH QPLOT(2) = QPLOT(2) + DUH IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) - DAW QPLOT(2) = QPLOT(2) - DUW IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) - DAH QPLOT(2) = QPLOT(2) - DUH IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) IF (DEBUG) WRITE (NDB,7091) 7091 FORMAT (' VIEW FROM SIDE') ENDIF QPLOT(1) = QPLOT(1) + DAL QPLOT(2) = QPLOT(2) + DUL IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) + 0.5*DAH QPLOT(2) = QPLOT(2) + 0.5*DUH ENDIF C IF (DOSIDE .AND. .NOT. DOTOP) THEN IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF C C TRANSITION FROM TOP TO SIDE C IF (DOSIDE .AND. DOTOP) THEN IF (DEBUG) WRITE (NDB,7026) 7026 FORMAT (' TRANSITION FROM TOP TO SIDE') IF (CWISE) THEN QPLOT(1) = QPLOT(1) + 0.5*DAH QPLOT(2) = QPLOT(2) + 0.5*DUH ELSE QPLOT(1) = QPLOT(1) - 0.5*DAH QPLOT(2) = QPLOT(2) - 0.5*DUH ENDIF IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) + 0.5*DAW QPLOT(2) = QPLOT(2) + 0.5*DUW ENDIF C C VIEW FROM TOP C IF (DOTOP) THEN IF (DEBUG) WRITE (NDB,7010) 7010 FORMAT (' VIEW FROM TOP') QPLOT(1) = QPLOT(1) + 0.5*DAW QPLOT(2) = QPLOT(2) + 0.5*DUW IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) - DAL QPLOT(2) = QPLOT(2) - DUL IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) - DAW QPLOT(2) = QPLOT(2) - DUW IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) IF (DOENT .AND. .NOT. DOSIDE) THEN IF (DEBUG) WRITE (NDB,7027) 7027 FORMAT (' LOOP AROUND ENTRANCE FACE') QPLOT(1) = QPLOT(1) - DAH QPLOT(2) = QPLOT(2) - DUH IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) + DAW QPLOT(2) = QPLOT(2) + DUW IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) + DAH QPLOT(2) = QPLOT(2) + DUH IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) - DAW QPLOT(2) = QPLOT(2) - DUW IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) IF (DEBUG) WRITE (NDB,7090) 7090 FORMAT (' VIEW FROM TOP') ENDIF QPLOT(1) = QPLOT(1) + DAL QPLOT(2) = QPLOT(2) + DUL IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) + 0.5*DAW QPLOT(2) = QPLOT(2) + 0.5*DUW IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF C C LOOP AROUND EXIT FACE C IF (DOEXIT) THEN IF (DEBUG) WRITE (NDB,7020) 7020 FORMAT (' LOOP AROUND EXIT FACE') IF (DOSIDE .AND. DOTOP .AND. CWISE) THEN QPLOT(1) = QPLOT(1) - 0.5*DAW QPLOT(2) = QPLOT(2) - 0.5*DUW IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) - 0.5*DAH QPLOT(2) = QPLOT(2) - 0.5*DUH ENDIF C IF (DOSIDE .AND. (.NOT. ROLD .OR. CWISE)) THEN QPLOT(1) = QPLOT(1) - 0.5*DAH QPLOT(2) = QPLOT(2) - 0.5*DUH IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) + 0.5*DAW QPLOT(2) = QPLOT(2) + 0.5*DUW ENDIF C IF (.NOT. HTTOP .OR. (HTTOP .AND. .NOT. CWISE)) THEN QPLOT(1) = QORIG(1) + 0.5*DAW - 0.5*DAH QPLOT(2) = QORIG(2) + 0.5*DUW - 0.5*DUH IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF C IF (HTTOP .AND. .NOT. CWISE) THEN QPLOT(1) = QORIG(1) + 0.5*DAW + 0.5*DAH QPLOT(2) = QORIG(2) + 0.5*DUW + 0.5*DUH IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF ENDIF C IF (DEBUG) WRITE (NDB,7031) 7031 FORMAT (' RETURN TO REFERENCE TRAJECTORY EXIT POINT') IF (DOENT .AND. .NOT. HTTOP) THEN QPLOT(1) = QPLOT(1) - 0.5*DAW QPLOT(2) = QPLOT(2) - 0.5*DUW IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF C C REFERENCE TRAJECTORY AT EXIT FACE C IF (DOEXIT .OR. DOENT) THEN QPLOT(1) = QORIG(1) + O(4,3,3)*SLESS QPLOT(2) = QORIG(2) + O(4,3,2)*SLESS IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QORIG(1) QPLOT(2) = QORIG(2) IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ELSE IF (TYPED .EQ. 28) THEN QPLOT(1) = QPLOT(1) - DAS QPLOT(2) = QPLOT(2) - DUS IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ELSE QPLOT(1) = QORIG(1) QPLOT(2) = QORIG(2) IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF RETURN END SUBROUTINE PLTSXZ C C PLOTS SBEND ON A HORIZONTAL PLANE C C ---------------------------------------------------------------------- INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DEBUG.CIN' INCLUDE 'ELM4A.CIN' INCLUDE 'ELM15C.CIN' INCLUDE 'ELM38C.CIN' INCLUDE 'ELM38D.CIN' INCLUDE 'ELM38F.CIN' INCLUDE 'IOUNIT.CIN' INCLUDE 'OC.CIN' C C LOCAL VARIABLES C INTEGER J, JN, K, LL, NDB LOGICAL HTSIDE, DNEXIT REAL ANG, CS, CSA, DAH1, DAH2, DAW1, DAW2, DEN, 1 DUH1, DUH2, DUW1, DUW2, GNU, HWIDE REAL S, S1, SH, SLESS, SN, SNA, SW REAL OMAG(3,3), XMAG(3) REAL O1(3,3), OPS(3,3) DATA NDB /6/ C --------------------------------------------------------------------- C C CHARACTERIZE ORIENTATION OF MAGNET C DOTOP = ABS(OPT(2,2)) .GE. 0.001 DOSIDE = ABS(OPT(1,2)) .GE. 0.001 ROLD = OPT(1,2) .NE. 0.0 REVERS = OPT(2,2) .LE. -0.0001 REVERS = REVERS .OR. 1 ABS(OPT(2,2)) .LT. 0.0001 .AND. OPT(1,2) .LT. -0.0001 CWISE = OPT(1,2) .GT. 0.0 C C ENTRANCE FACE COORDINATE SYSTEM C SN = SIN(AL) CS = COS(AL) DO 10 J = 1, 3 DO 10 K = 1, 3 OMAG(J,K) = 0.0 10 CONTINUE OMAG(1,1) = CS OMAG(1,3) = - SN OMAG(2,2) = 1.0 OMAG(3,1) = SN OMAG(3,3) = CS C DO 20 J = 1, 3 DO 20 K = 1, 3 S1 = 0.0 DO 15 LL = 1, 3 S1 = S1 + OMAG(J,LL)*O(4,LL,K) 15 CONTINUE O1(J,K) = S1 20 CONTINUE C DO 30 J = 1, 3 DO 30 K = 1, 3 OPS(J,K) = O1(J,K) 30 CONTINUE C DOENT = OPS(3,2) .LE. -0.001 DOEXIT = OPT(3,2) .GE. 0.001 DNEXIT = OPT(3,2) .LE. -0.001 IF (DEBUG) WRITE (NDB,7018) DOENT, DOEXIT, DOTOP, DOSIDE, CWISE, 1 REVERS 7018 FORMAT (' DOENT = ',L1,2X,'DOEX = ',L1,2X,'DOTOP = ',L1,2X, 1 ' DOSIDE = ',L1,2X,' CWISE = ',L1,2X,'REVERS = ',L1) C C PROJECTIONS OF MAGNET EDGES C DUW1 = OPS(1,1)*WIDE/UFLOOR(1) DUH1 = OPS(2,1)*HIGH/UFLOOR(1) DAW1 = OPS(1,3)*WIDE/UFLOOR(1) DAH1 = OPS(2,3)*HIGH/UFLOOR(1) DUW2 = OPT(1,1)*WIDE/UFLOOR(1) DUH2 = OPT(2,1)*HIGH/UFLOOR(1) DAW2 = OPT(1,3)*WIDE/UFLOOR(1) DAH2 = OPT(2,3)*HIGH/UFLOOR(1) C IF (DEBUG) WRITE (NDB,7036) DAW1, DUW1 7036 FORMAT (' DAW1 = ',F12.5,3X,'DUW1 = ',F12.5) IF (DEBUG) WRITE (NDB,7037) DAH2, DUH2 7037 FORMAT (' DAH1 = ',F12.5,3X,'DUH1 = ',F12.5) IF (DEBUG) WRITE (NDB,7033) DAW2, DUW2 7033 FORMAT (' DAW2 = ',F12.5,3X,'DUW2 = ',F12.5) IF (DEBUG) WRITE (NDB,7034) DAH2, DUH2 7034 FORMAT (' DAH2 = ',F12.5,3X,'DUH2 = ',F12.5) IF (DEBUG) WRITE (NDB,7047) QORIG(1), QORIG(2) 7047 FORMAT (' QORIG = ',2F12.5) C C INTERSECTION OF REFERENCE TRAJECTORY WITH PROJECTED C DOWNSTREAM EDGE C IF (DOEXIT .OR. DNEXIT) THEN IF (DEBUG) WRITE (NDB,7012) 7012 FORMAT (' VIEW FROM DOWNSTREAM END') GNU = OPT(1,1)*OPT(2,3) - OPT(2,1)*OPT(1,3) DEN = OPT(2,1)*OPT(3,3) - OPT(3,1)*OPT(2,3) IF (ABS(DEN) .LT. 0.00001) THEN SW = 0.0 ELSE SW = 0.5*GNU*WIDE/(DEN*UFLOOR(1)) SW = SIGN(SW,OPT(3,3)) ENDIF GNU = OPT(1,3)*OPT(2,1) - OPT(1,1)*OPT(2,3) DEN = OPT(3,3)*OPT(1,1) - OPT(1,3)*OPT(3,1) IF (ABS(DEN) .LT. 0.00001) THEN SH = 0.0 ELSE SH = 0.5*GNU*HIGH/(DEN*UFLOOR(1)) SH = SIGN(SH,OPT(3,3)) ENDIF IF (SW .EQ. 0.0) THEN SLESS = SH ELSE IF (SH .EQ. 0.0) THEN SLESS = SW ELSE SLESS = AMIN1(SH,SW) ENDIF HTSIDE = SH .NE. 0.0 .AND. SW .NE. 0.0 .AND. SW .LT. SH HTSIDE = SH .EQ. 0.0 .OR. HTSIDE IF (DEBUG) WRITE (NDB,7019) HTSIDE 7019 FORMAT (' HTSIDE = ',L2) IF (DEBUG) WRITE (NDB,7006) SW, SH, SLESS 7006 FORMAT (' SW = ',E15.5,3X,'SH = ',E15.5,3X,'SLESS = ',E15.5) QPLOT(1) = QORIG(1) + OPT(3,3)*SLESS QPLOT(2) = QORIG(2) + OPT(3,1)*SLESS IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) 7009 FORMAT (' QPLOT = ',2F12.5) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) 7008 FORMAT (8F10.5) ENDIF C C IF FACING EXIT, TRACE ABOUT EXIT FACE C IF (DOEXIT) THEN IF (REVERS .AND. .NOT. HTSIDE) THEN IF (DEBUG) WRITE (NDB,7023) 7023 FORMAT (' TRACE ALONG LOWER SIDE') QPLOT(1) = QORIG(1) + 0.5*DAH2 - 0.5*DAW2 QPLOT(2) = QORIG(2) + 0.5*DUH2 - 0.5*DUW2 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF C IF ((REVERS .AND. .NOT. HTSIDE) 1 .OR. (CWISE .AND. HTSIDE)) THEN QPLOT(1) = QORIG(1) - 0.5*DAH2 - 0.5*DAW2 QPLOT(2) = QORIG(2) - 0.5*DUH2 - 0.5*DUW2 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF C IF (CWISE .OR. .NOT. HTSIDE) THEN IF (DEBUG) WRITE (NDB,7024) 7024 FORMAT (' TRACE ALONG BOTTOM') QPLOT(1) = QORIG(1) - 0.5*DAH2 + 0.5*DAW2 QPLOT(2) = QORIG(2) - 0.5*DUH2 + 0.5*DUW2 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF C IF (DEBUG) WRITE (NDB,7022) 7022 FORMAT (' LOOP AROUND EXIT FACE') QPLOT(1) = QORIG(1) + 0.5*DAH2 + 0.5*DAW2 QPLOT(2) = QORIG(2) + 0.5*DUH2 + 0.5*DUW2 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) - DAW2 QPLOT(2) = QPLOT(2) - DUW2 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) - DAH2 QPLOT(2) = QPLOT(2) - DUH2 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) C IF (.NOT. REVERS .OR. (.NOT. CWISE .AND. HTSIDE)) THEN QPLOT(1) = QPLOT(1) + DAW2 QPLOT(2) = QPLOT(2) + DUW2 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) IF (DOTOP .OR. .NOT. CWISE) THEN QPLOT(1) = QPLOT(1) + DAH2 QPLOT(2) = QPLOT(2) + DUH2 C IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF ENDIF C IF (.NOT. CWISE .AND. REVERS .AND. HTSIDE) THEN QPLOT(1) = QPLOT(1) - DAW2 QPLOT(2) = QPLOT(2) - DUW2 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) IF (DOTOP) THEN QPLOT(1) = QPLOT(1) - DAH2 QPLOT(2) = QPLOT(2) - DUH2 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF ENDIF ENDIF C C IF NOT FACING EXIT, TRACE APPROPRIATE EXIT EDGES C IF (.NOT. DOEXIT .AND. DOTOP) THEN IF (CWISE .AND. (.NOT. REVERS .OR. .NOT. HTSIDE)) THEN QPLOT(1) = QORIG(1) + 0.5*DAH2 + 0.5*DAW2 QPLOT(2) = QORIG(2) + 0.5*DUH2 + 0.5*DUW2 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ELSE IF (CWISE .AND. REVERS .AND. HTSIDE) THEN QPLOT(1) = QORIG(1) - 0.5*DAH2 + 0.5*DAW2 QPLOT(2) = QORIG(2) - 0.5*DUH2 + 0.5*DUW2 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) - DAW2 QPLOT(2) = QPLOT(2) - DUW2 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ELSE IF (.NOT. CWISE .AND. REVERS) THEN QPLOT(1) = QORIG(1) - 0.5*DAH2 - 0.5*DAW2 QPLOT(2) = QORIG(2) - 0.5*DUH2 - 0.5*DUW2 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ELSE QPLOT(1) = QORIG(1) + 0.5*DAH2 - 0.5*DAW2 QPLOT(2) = QORIG(2) + 0.5*DUH2 - 0.5*DUW2 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) + DAW2 QPLOT(2) = QPLOT(2) + DUW2 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF ENDIF C C IF TOP (OR BOTTOM) NOT VISIBLE, ADVANCE TO NEXT EDGE FOR SIDE C IF (DNEXIT .AND. .NOT. DOTOP) THEN IF (CWISE) THEN QPLOT(1) = QORIG(1) - 0.5*DAH2 + 0.5*DAW2 QPLOT(2) = QORIG(2) - 0.5*DUH2 + 0.5*DUW2 ELSE QPLOT(1) = QORIG(1) + 0.5*DAH2 - 0.5*DAW2 QPLOT(2) = QORIG(2) + 0.5*DUH2 - 0.5*DUW2 ENDIF IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF C C VIEW FROM TOP C IF (DOTOP) THEN IF (DEBUG) WRITE (NDB,7010) 7010 FORMAT (' VIEW FROM TOP') IF (.NOT. REVERS) THEN QREF(1) = QPLOT(1) - 0.5*DAW2 QREF(2) = QPLOT(2) - 0.5*DUW2 HWIDE = 0.5*WIDE ELSE QREF(1) = QPLOT(1) + 0.5*DAW2 QREF(2) = QPLOT(2) + 0.5*DUW2 HWIDE = - 0.5*WIDE ENDIF IF (DEBUG) WRITE (NDB,7032) (QREF(J), J = 1, 2) 7032 FORMAT (' QREF = ',2F12.5) C C DOWN ALONG EDGE OF TOP C IF (DEBUG) WRITE (NDB,7041) 7041 FORMAT (' DOWN ALONG EDGE OF TOP') DO 150 JN = 1, NANGS ANG = FLOAT(JN)*DANG SNA = SIN(ANG) CSA = COS(ANG) DO 110 J = 1, 3 DO 110 K = 1, 3 OMAG(J,K) = 0.0 110 CONTINUE OMAG(1,1) = CSA OMAG(1,3) = - SNA OMAG(2,2) = 1.0 OMAG(3,1) = SNA OMAG(3,3) = CSA C IF (CSA .GT. 0.5) XMAG(1) = - SNA**2/(H0*(1.0 + CSA)) IF (CSA .LE. 0.5) XMAG(1) = - (1.0 - CSA)/H0 XMAG(2) = 0.0 XMAG(3) = - SNA/H0 C DO 120 J = 1, 3 DO 120 K = 1, 3 S1 = 0.0 DO 115 LL = 1, 3 S1 = S1 + OMAG(J,LL)*O(4,LL,K) 115 CONTINUE O1(J,K) = S1 120 CONTINUE C DO 130 J = 1, 3 S = 0.0 DO 125 K = 1, 3 S = S + O(4,K,J)*XMAG(K) 125 CONTINUE XPT(J) = S 130 CONTINUE C DO 140 J = 1, 3 DO 135 K = 1, 3 OPT(J,K) = O1(J,K) 135 CONTINUE 140 CONTINUE QPLOT(1) = QREF(1) + (XPT(3) + OPT(1,3)*HWIDE)/UFLOOR(1) QPLOT(2) = QREF(2) + (XPT(1) + OPT(1,1)*HWIDE)/UFLOOR(1) IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) 150 CONTINUE C C CROSS ENTRANCE FACE C IF (.NOT. DOENT) THEN IF (DEBUG) WRITE (NDB,7035) 7035 FORMAT (' CROSS ENTRANCE FACE') IF (.NOT. REVERS) THEN QPLOT(1) = QPLOT(1) - DAW1 QPLOT(2) = QPLOT(2) - DUW1 ELSE QPLOT(1) = QPLOT(1) + DAW1 QPLOT(2) = QPLOT(2) + DUW1 ENDIF IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF C C LOOP AROUND ENTRANCE FACE C IF (DOENT) THEN IF (DEBUG) WRITE (NDB,7021) 7021 FORMAT (' LOOP AROUND ENTRANCE FACE') IF (.NOT. REVERS) THEN QPLOT(1) = QPLOT(1) - DAW1 QPLOT(2) = QPLOT(2) - DUW1 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) - DAH1 QPLOT(2) = QPLOT(2) - DUH1 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF QPLOT(1) = QPLOT(1) + DAW1 QPLOT(2) = QPLOT(2) + DUW1 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) + DAH1 QPLOT(2) = QPLOT(2) + DUH1 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) - DAW1 QPLOT(2) = QPLOT(2) - DUW1 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) IF (REVERS) THEN QPLOT(1) = QPLOT(1) - DAH1 QPLOT(2) = QPLOT(2) - DUH1 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) + DAW1 QPLOT(2) = QPLOT(2) + DUW1 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF ENDIF C C RETURN ALONG EDGE OF TOP C IF (DEBUG) WRITE (NDB,7040) 7040 FORMAT (' RETURN ALONG EDGE OF TOP') DO 200 JN = 1, NANGS ANG = FLOAT(NANGS - JN)*DANG SNA = SIN(ANG) CSA = COS(ANG) DO 160 J = 1, 3 DO 160 K = 1, 3 OMAG(J,K) = 0.0 160 CONTINUE OMAG(1,1) = CSA OMAG(1,3) = - SNA OMAG(2,2) = 1.0 OMAG(3,1) = SNA OMAG(3,3) = CSA C IF (CSA .GT. 0.5) XMAG(1) = - SNA**2/(H0*(1.0 + CSA)) IF (CSA .LE. 0.5) XMAG(1) = - (1.0 - CSA)/H0 XMAG(2) = 0.0 XMAG(3) = - SNA/H0 C DO 170 J = 1, 3 DO 170 K = 1, 3 S1 = 0.0 DO 165 LL = 1, 3 S1 = S1 + OMAG(J,LL)*O(4,LL,K) 165 CONTINUE O1(J,K) = S1 170 CONTINUE C DO 180 J = 1, 3 S = 0.0 DO 175 K = 1, 3 S = S + O(4,K,J)*XMAG(K) 175 CONTINUE XPT(J) = S 180 CONTINUE C DO 190 J = 1, 3 DO 185 K = 1, 3 OPT(J,K) = O1(J,K) 185 CONTINUE 190 CONTINUE C QPLOT(1) = QREF(1) + (XPT(3) - OPT(1,3)*HWIDE)/UFLOOR(1) QPLOT(2) = QREF(2) + (XPT(1) - OPT(1,1)*HWIDE)/UFLOOR(1) IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) 200 CONTINUE ENDIF C C TRANSITION FROM TOP TO SIDE C IF (DOSIDE .AND. DOTOP) THEN IF (DEBUG) WRITE (NDB,7026) 7026 FORMAT (' TRANSITION FROM TOP TO SIDE') IF (CWISE .AND. .NOT. REVERS) THEN QPLOT(1) = QPLOT(1) + DAW2 QPLOT(2) = QPLOT(2) + DUW2 ELSE IF (.NOT. CWISE .AND. REVERS) THEN QPLOT(1) = QPLOT(1) - DAW2 QPLOT(2) = QPLOT(2) - DUW2 ENDIF IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) C IF (.NOT. REVERS) THEN QPLOT(1) = QPLOT(1) - DAH2 QPLOT(2) = QPLOT(2) - DUH2 ELSE QPLOT(1) = QPLOT(1) + DAH2 QPLOT(2) = QPLOT(2) + DUH2 ENDIF IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF C C VIEW FROM SIDE C IF (DOSIDE) THEN IF (CWISE) THEN QREF(1) = QPLOT(1) - 0.5*DAW2 QREF(2) = QPLOT(2) - 0.5*DUW2 HWIDE = 0.5*WIDE ELSE QREF(1) = QPLOT(1) + 0.5*DAW2 QREF(2) = QPLOT(2) + 0.5*DUW2 HWIDE = - 0.5*WIDE ENDIF IF (DEBUG) WRITE (NDB,7039) HWIDE 7039 FORMAT (' HWIDE = ',F12.5) IF (DEBUG) WRITE (NDB,7032) (QREF(J), J = 1, 2) C C DOWN ALONG EDGE OF SIDE C IF (DEBUG) WRITE (NDB,7044) 7044 FORMAT (' DOWN ALONG EDGE OF SIDE') DO 250 JN = 1, NANGS ANG = FLOAT(JN)*DANG SNA = SIN(ANG) CSA = COS(ANG) DO 210 J = 1, 3 DO 210 K = 1, 3 OMAG(J,K) = 0.0 210 CONTINUE OMAG(1,1) = CSA OMAG(1,3) = - SNA OMAG(2,2) = 1.0 OMAG(3,1) = SNA OMAG(3,3) = CSA C IF (CSA .GT. 0.5) XMAG(1) = - SNA**2/(H0*(1.0 + CSA)) IF (CSA .LE. 0.5) XMAG(1) = - (1.0 - CSA)/H0 XMAG(2) = 0.0 XMAG(3) = - SNA/H0 C DO 220 J = 1, 3 DO 220 K = 1, 3 S1 = 0.0 DO 215 LL = 1, 3 S1 = S1 + OMAG(J,LL)*O(4,LL,K) 215 CONTINUE O1(J,K) = S1 220 CONTINUE C DO 230 J = 1, 3 S = 0.0 DO 225 K = 1, 3 S = S + O(4,K,J)*XMAG(K) 225 CONTINUE XPT(J) = S 230 CONTINUE C DO 240 J = 1, 3 DO 235 K = 1, 3 OPT(J,K) = O1(J,K) 235 CONTINUE 240 CONTINUE C QPLOT(1) = QREF(1) + (XPT(3) + OPT(1,3)*HWIDE)/UFLOOR(1) QPLOT(2) = QREF(2) + (XPT(1) + OPT(1,1)*HWIDE)/UFLOOR(1) IF (DEBUG) WRITE (NDB,7038) (QPLOT(J), J = 1, 2), 1 XPT(1), XPT(3), OPT(1,3), OPT(1,1) 7038 FORMAT (' QPLOT = ',2F12.5,3X,'XPT = ',2F12.5,3X, 1 'OPT = ',2F12.5) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) 250 CONTINUE C C CROSS ENTRANCE FACE C IF (.NOT. DOENT .OR. DOTOP) THEN IF (.NOT. REVERS) THEN QPLOT(1) = QPLOT(1) + DAH1 QPLOT(2) = QPLOT(2) + DUH1 ELSE QPLOT(1) = QPLOT(1) - DAH1 QPLOT(2) = QPLOT(2) - DUH1 ENDIF IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF C C LOOP AROUND ENTRANCE FACE C IF (DOENT .AND. .NOT. DOTOP) THEN IF (DEBUG) WRITE (NDB,7027) 7027 FORMAT (' LOOP AROUND ENTRANCE FACE') IF (.NOT. REVERS) THEN QPLOT(1) = QPLOT(1) + DAH1 QPLOT(2) = QPLOT(2) + DUH1 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) - DAW1 QPLOT(2) = QPLOT(2) - DUW1 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF QPLOT(1) = QPLOT(1) - DAH1 QPLOT(2) = QPLOT(2) - DUH1 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) + DAW1 QPLOT(2) = QPLOT(2) + DUW1 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) + DAH1 QPLOT(2) = QPLOT(2) + DUH1 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) IF (REVERS) THEN QPLOT(1) = QPLOT(1) - DAW1 QPLOT(2) = QPLOT(2) - DUW1 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) - DAH1 QPLOT(2) = QPLOT(2) - DUH1 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF ENDIF C C RETURN ALONG EDGE OF SIDE C IF (DEBUG) WRITE (NDB,7045) 7045 FORMAT (' RETURN ALONG EDGE OF SIDE') IF (.NOT. REVERS) THEN QREF(1) = QREF(1) + DAH2 QREF(2) = QREF(2) + DUH2 ELSE QREF(1) = QREF(1) - DAH2 QREF(2) = QREF(2) - DUH2 ENDIF IF (DEBUG) WRITE (NDB,7032) (QREF(J), J = 1, 2) C DO 300 JN = 1, NANGS ANG = FLOAT(NANGS - JN)*DANG SNA = SIN(ANG) CSA = COS(ANG) DO 260 J = 1, 3 DO 260 K = 1, 3 OMAG(J,K) = 0.0 260 CONTINUE OMAG(1,1) = CSA OMAG(1,3) = - SNA OMAG(2,2) = 1.0 OMAG(3,1) = SNA OMAG(3,3) = CSA C IF (CSA .GT. 0.5) XMAG(1) = - SNA**2/(H0*(1.0 + CSA)) IF (CSA .LE. 0.5) XMAG(1) = - (1.0 - CSA)/H0 XMAG(2) = 0.0 XMAG(3) = - SNA/H0 C DO 270 J = 1, 3 DO 270 K = 1, 3 S1 = 0.0 DO 265 LL = 1, 3 S1 = S1 + OMAG(J,LL)*O(4,LL,K) 265 CONTINUE O1(J,K) = S1 270 CONTINUE C DO 280 J = 1, 3 S = 0.0 DO 275 K = 1, 3 S = S + O(4,K,J)*XMAG(K) 275 CONTINUE XPT(J) = S 280 CONTINUE C DO 290 J = 1, 3 DO 290 K = 1, 3 OPT(J,K) = O1(J,K) 290 CONTINUE C QPLOT(1) = QREF(1) + (XPT(3) + OPT(1,3)*HWIDE)/UFLOOR(1) QPLOT(2) = QREF(2) + (XPT(1) + OPT(1,1)*HWIDE)/UFLOOR(1) IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) 300 CONTINUE ENDIF C C LOOP AROUND EXIT FACE C IF (DOEXIT) THEN IF (DEBUG) WRITE (NDB,7020) 7020 FORMAT (' LOOP AROUND EXIT FACE') IF (CWISE .AND. .NOT. REVERS) THEN QPLOT(1) = QPLOT(1) - DAW2 QPLOT(2) = QPLOT(2) - DUW2 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF C IF (.NOT. HTSIDE .AND. .NOT. REVERS) THEN QPLOT(1) = QPLOT(1) - DAH2 QPLOT(2) = QPLOT(2) - DUH2 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF C IF (.NOT. CWISE) THEN QPLOT(1) = QPLOT(1) + DAW2 QPLOT(2) = QPLOT(2) + DUW2 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF C IF (REVERS .AND. ((CWISE .AND. DOTOP) 1 .OR. .NOT. HTSIDE)) THEN QPLOT(1) = QPLOT(1) + DAH2 QPLOT(2) = QPLOT(2) + DUH2 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF C IF (CWISE .AND. REVERS .AND. DOSIDE) THEN QPLOT(1) = QPLOT(1) - DAW2 QPLOT(2) = QPLOT(2) - DUW2 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF ENDIF C C REFERENCE TRAJECTORY AT EXIT FACE C IF (DOEXIT .OR. DNEXIT) THEN IF (DEBUG) WRITE (NDB,7046) 7046 FORMAT (' REFERENCE TRAJECTORY AT EXIT FACE') QPLOT(1) = QORIG(1) + OPT(3,3)*SLESS QPLOT(2) = QORIG(2) + OPT(3,1)*SLESS IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF QPLOT(1) = QORIG(1) QPLOT(2) = QORIG(2) IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) RETURN END SUBROUTINE PLTSYZ C C PLOTS SBEND ON A VERTICAL PLANE C C ---------------------------------------------------------------------- INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DEBUG.CIN' INCLUDE 'ELM4A.CIN' INCLUDE 'ELM15C.CIN' INCLUDE 'ELM38C.CIN' INCLUDE 'ELM38D.CIN' INCLUDE 'ELM38F.CIN' INCLUDE 'IOUNIT.CIN' INCLUDE 'OC.CIN' C --------------------------------------------------------------------- INTEGER J, JN, K, LL, NDB LOGICAL HTSIDE, DNEXIT REAL ANG, CS, CSA REAL DAH1, DAH2, DAW1, DAW2, DEN, DUH1, DUH2, DUW1, 1 DUW2 REAL GNU, HWIDE REAL S, S1, SH, SN, SNA, SLESS, SW REAL OMAG(3,3), XMAG(3) REAL OPS(3,3), O1(3,3) DATA NDB /6/ C C CHARACTERIZE ORIENTATION OF MAGNET C DOTOP = ABS(OPT(2,1)) .GE. 0.001 DOSIDE = ABS(OPT(1,1)) .GE. 0.001 ROLD = OPT(1,2) .NE. 0.0 REVERS = OPT(1,1) .LE. -0.0001 CWISE = OPT(1,2) .GT. 0.0 C C ENTRANCE FACE COORDINATE SYSTEM C SN = SIN(AL) CS = COS(AL) DO 10 J = 1, 3 DO 10 K = 1, 3 OMAG(J,K) = 0.0 10 CONTINUE OMAG(1,1) = CS OMAG(1,3) = - SN OMAG(2,2) = 1.0 OMAG(3,1) = SN OMAG(3,3) = CS C DO 20 J = 1, 3 DO 20 K = 1, 3 S1 = 0.0 DO 15 LL = 1, 3 S1 = S1 + OMAG(J,LL)*O(4,LL,K) 15 CONTINUE O1(J,K) = S1 20 CONTINUE C DO 30 J = 1, 3 DO 30 K = 1, 3 OPS(J,K) = O1(J,K) 30 CONTINUE C DOENT = OPS(3,1) .GE. 0.001 DOEXIT = OPT(3,1) .LE. -0.001 DNEXIT = OPT(3,1) .GE. 0.001 IF (DEBUG) WRITE (NDB,7018) DOENT, DOEXIT, DOTOP, DOSIDE, CWISE, 1 REVERS 7018 FORMAT (' DOENT = ',L1,2X,'DOEX = ',L1,2X,'DOTOP = ',L1,2X, 1 ' DOSIDE = ',L1,2X,' CWISE = ',L1,2X,'REVERS = ',L1) C C PROJECTIONS OF MAGNET EDGES C DUW1 = OPS(1,2)*WIDE/UFLOOR(1) DUH1 = OPS(2,2)*HIGH/UFLOOR(1) DAW1 = OPS(1,3)*WIDE/UFLOOR(1) DAH1 = OPS(2,3)*HIGH/UFLOOR(1) DUW2 = OPT(1,2)*WIDE/UFLOOR(1) DUH2 = OPT(2,2)*HIGH/UFLOOR(1) DAW2 = OPT(1,3)*WIDE/UFLOOR(1) DAH2 = OPT(2,3)*HIGH/UFLOOR(1) C IF (DEBUG) WRITE (NDB,7036) DAW1, DUW1 7036 FORMAT (' DAW1 = ',F12.5,3X,'DUW1 = ',F12.5) IF (DEBUG) WRITE (NDB,7037) DAH2, DUH2 7037 FORMAT (' DAH1 = ',F12.5,3X,'DUH1 = ',F12.5) IF (DEBUG) WRITE (NDB,7033) DAW2, DUW2 7033 FORMAT (' DAW2 = ',F12.5,3X,'DUW2 = ',F12.5) IF (DEBUG) WRITE (NDB,7034) DAH2, DUH2 7034 FORMAT (' DAH2 = ',F12.5,3X,'DUH2 = ',F12.5) IF (DEBUG) WRITE (NDB,7047) QORIG(1), QORIG(2) 7047 FORMAT (' QORIG = ',2F12.5) C C INTERSECTION OF REFERENCE TRAJECTORY WITH PROJECTED C DOWNSTREAM EDGE C IF (DOEXIT .OR. DNEXIT) THEN IF (DEBUG) WRITE (NDB,7012) 7012 FORMAT (' VIEW FROM DOWNSTREAM END') GNU = OPT(1,2)*OPT(2,3) - OPT(2,2)*OPT(1,3) DEN = OPT(2,2)*OPT(3,3) - OPT(3,2)*OPT(2,3) IF (ABS(DEN) .LT. 0.00001) THEN SW = 0.0 ELSE SW = 0.5*GNU*WIDE/(DEN*UFLOOR(1)) SW = SIGN(SW,OPT(3,3)) ENDIF GNU = OPT(1,3)*OPT(2,2) - OPT(1,2)*OPT(2,3) DEN = OPT(3,3)*OPT(1,2) - OPT(1,3)*OPT(3,2) IF (ABS(DEN) .LT. 0.00001) THEN SH = 0.0 ELSE SH = 0.5*GNU*HIGH/(DEN*UFLOOR(1)) SH = SIGN(SH,OPT(3,3)) ENDIF IF (SW .EQ. 0.0) THEN SLESS = SH ELSE IF (SH .EQ. 0.0) THEN SLESS = SW ELSE SLESS = AMIN1(SH,SW) ENDIF HTSIDE = SH .NE. 0.0 .AND. SW .NE. 0.0 .AND. SW .LT. SH HTSIDE = SH .EQ. 0.0 .OR. HTSIDE IF (DEBUG) WRITE (NDB,7019) HTSIDE 7019 FORMAT (' HTSIDE = ',L2) IF (DEBUG) WRITE (NDB,7006) SW, SH, SLESS 7006 FORMAT (' SW = ',E15.5,3X,'SH = ',E15.5,3X,'SLESS = ',E15.5) QPLOT(1) = QORIG(1) + OPT(3,3)*SLESS QPLOT(2) = QORIG(2) + OPT(3,2)*SLESS IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) 7009 FORMAT (' QPLOT = ',2F12.5) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) 7008 FORMAT (8F10.5) ENDIF C C IF FACING EXIT, TRACE ABOUT EXIT FACE C IF (DOEXIT) THEN IF (REVERS .AND. .NOT. CWISE .AND. .NOT. HTSIDE) THEN IF (DEBUG) WRITE (NDB,7023) 7023 FORMAT (' TRACE ALONG LOWER SIDE') QPLOT(1) = QORIG(1) + 0.5*DAH2 - 0.5*DAW2 QPLOT(2) = QORIG(2) + 0.5*DUH2 - 0.5*DUW2 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF C IF (REVERS .AND. (.NOT. CWISE .OR. HTSIDE)) THEN QPLOT(1) = QORIG(1) - 0.5*DAH2 - 0.5*DAW2 QPLOT(2) = QORIG(2) - 0.5*DUH2 - 0.5*DUW2 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF C IF (CWISE .OR. REVERS) THEN IF (DEBUG) WRITE (NDB,7024) 7024 FORMAT (' TRACE ALONG BOTTOM') QPLOT(1) = QORIG(1) - 0.5*DAH2 + 0.5*DAW2 QPLOT(2) = QORIG(2) - 0.5*DUH2 + 0.5*DUW2 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF C IF (DEBUG) WRITE (NDB,7022) 7022 FORMAT (' LOOP AROUND EXIT FACE') IF (CWISE .OR. REVERS .OR. (.NOT. REVERS .AND. HTSIDE)) THEN QPLOT(1) = QORIG(1) + 0.5*DAH2 + 0.5*DAW2 QPLOT(2) = QORIG(2) + 0.5*DUH2 + 0.5*DUW2 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF QPLOT(1) = QORIG(1) + 0.5*DAH2 - 0.5*DAW2 QPLOT(2) = QORIG(2) + 0.5*DUH2 - 0.5*DUW2 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) - DAH2 QPLOT(2) = QPLOT(2) - DUH2 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) + DAW2 QPLOT(2) = QPLOT(2) + DUW2 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) C IF (CWISE .OR. .NOT. REVERS) THEN QPLOT(1) = QPLOT(1) + DAH2 QPLOT(2) = QPLOT(2) + DUH2 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF C IF (.NOT. REVERS) THEN QPLOT(1) = QPLOT(1) - DAW2 QPLOT(2) = QPLOT(2) - DUW2 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF C IF (DOTOP .AND. .NOT. REVERS .AND. .NOT. CWISE) THEN QPLOT(1) = QPLOT(1) - DAH2 QPLOT(2) = QPLOT(2) - DUH2 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF ENDIF C C IF NOT FACING EXIT, TRACE APPROPRIATE EXIT EDGES C IF (.NOT. DOEXIT .AND. DOTOP) THEN IF (CWISE .AND. .NOT. REVERS) THEN QPLOT(1) = QORIG(1) + 0.5*DAH2 - 0.5*DAW2 QPLOT(2) = QORIG(2) + 0.5*DUH2 - 0.5*DUW2 ELSE IF (CWISE .AND. REVERS) THEN QPLOT(1) = QORIG(1) + 0.5*DAH2 + 0.5*DAW2 QPLOT(2) = QORIG(2) + 0.5*DUH2 + 0.5*DUW2 ELSE IF (.NOT. CWISE .AND. REVERS) THEN QPLOT(1) = QORIG(1) - 0.5*DAH2 + 0.5*DAW2 QPLOT(2) = QORIG(2) - 0.5*DUH2 + 0.5*DUW2 ELSE IF (.NOT. CWISE .AND. .NOT. REVERS) THEN QPLOT(1) = QORIG(1) - 0.5*DAH2 - 0.5*DAW2 QPLOT(2) = QORIG(2) - 0.5*DUH2 - 0.5*DUW2 ENDIF IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF C C IF TOP (OR BOTTOM) NOT VISIBLE, ADVANCE TO NEXT EDGE FOR SIDE C IF (DNEXIT .AND. .NOT. DOTOP) THEN IF (CWISE) THEN QPLOT(1) = QORIG(1) - 0.5*DAH2 + 0.5*DAW2 QPLOT(2) = QORIG(2) - 0.5*DUH2 + 0.5*DUW2 ELSE QPLOT(1) = QORIG(1) + 0.5*DAH2 - 0.5*DAW2 QPLOT(2) = QORIG(2) + 0.5*DUH2 - 0.5*DUW2 ENDIF IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF C C VIEW FROM TOP C IF (DOTOP) THEN IF (DEBUG) WRITE (NDB,7010) 7010 FORMAT (' VIEW FROM TOP') IF (.NOT. REVERS) THEN QREF(1) = QPLOT(1) + 0.5*DAW2 QREF(2) = QPLOT(2) + 0.5*DUW2 HWIDE = - 0.5*WIDE ELSE QREF(1) = QPLOT(1) - 0.5*DAW2 QREF(2) = QPLOT(2) - 0.5*DUW2 HWIDE = 0.5*WIDE ENDIF IF (DEBUG) WRITE (NDB,7032) (QREF(J), J = 1, 2) 7032 FORMAT (' QREF = ',2F12.5) C C DOWN ALONG EDGE OF TOP C IF (DEBUG) WRITE (NDB,7041) 7041 FORMAT (' DOWN ALONG EDGE OF TOP') DO 150 JN = 1, NANGS ANG = FLOAT(JN)*DANG SNA = SIN(ANG) CSA = COS(ANG) DO 110 J = 1, 3 DO 110 K = 1, 3 OMAG(J,K) = 0.0 110 CONTINUE OMAG(1,1) = CSA OMAG(1,3) = - SNA OMAG(2,2) = 1.0 OMAG(3,1) = SNA OMAG(3,3) = CSA C IF (CSA .GT. 0.5) XMAG(1) = - SNA**2/(H0*(1.0 + CSA)) IF (CSA .LE. 0.5) XMAG(1) = - (1.0 - CSA)/H0 XMAG(2) = 0.0 XMAG(3) = - SNA/H0 C DO 120 J = 1, 3 DO 120 K = 1, 3 S1 = 0.0 DO 115 LL = 1, 3 S1 = S1 + OMAG(J,LL)*O(4,LL,K) 115 CONTINUE O1(J,K) = S1 120 CONTINUE C DO 130 J = 1, 3 S = 0.0 DO 125 K = 1, 3 S = S + O(4,K,J)*XMAG(K) 125 CONTINUE XPT(J) = S 130 CONTINUE C DO 140 J = 1, 3 DO 140 K = 1, 3 OPT(J,K) = O1(J,K) 140 CONTINUE QPLOT(1) = QREF(1) + (XPT(3) + OPT(1,3)*HWIDE)/UFLOOR(1) QPLOT(2) = QREF(2) + (XPT(2) + OPT(1,2)*HWIDE)/UFLOOR(1) IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) 150 CONTINUE C C CROSS ENTRANCE FACE C IF (.NOT. DOENT) THEN IF (DEBUG) WRITE (NDB,7035) 7035 FORMAT (' CROSS ENTRANCE FACE') IF (.NOT. REVERS) THEN QPLOT(1) = QPLOT(1) + DAW1 QPLOT(2) = QPLOT(2) + DUW1 ELSE QPLOT(1) = QPLOT(1) - DAW1 QPLOT(2) = QPLOT(2) - DUW1 ENDIF IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF C C LOOP AROUND ENTRANCE FACE C IF (DOENT) THEN IF (DEBUG) WRITE (NDB,7021) 7021 FORMAT (' LOOP AROUND ENTRANCE FACE') IF (.NOT. REVERS .AND. .NOT. CWISE) THEN QPLOT(1) = QPLOT(1) + DAH1 QPLOT(2) = QPLOT(2) + DUH1 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF IF (.NOT. REVERS) THEN QPLOT(1) = QPLOT(1) + DAW1 QPLOT(2) = QPLOT(2) + DUW1 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF IF (.NOT. REVERS .OR. CWISE) THEN QPLOT(1) = QPLOT(1) - DAH1 QPLOT(2) = QPLOT(2) - DUH1 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF QPLOT(1) = QPLOT(1) - DAW1 QPLOT(2) = QPLOT(2) - DUW1 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) + DAH1 QPLOT(2) = QPLOT(2) + DUH1 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) + DAW1 QPLOT(2) = QPLOT(2) + DUW1 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) IF (REVERS .OR. .NOT. CWISE) THEN QPLOT(1) = QPLOT(1) - DAH1 QPLOT(2) = QPLOT(2) - DUH1 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF IF (REVERS) THEN QPLOT(1) = QPLOT(1) - DAW1 QPLOT(2) = QPLOT(2) - DUW1 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF IF (REVERS .AND. CWISE) THEN QPLOT(1) = QPLOT(1) + DAH1 QPLOT(2) = QPLOT(2) + DUH1 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF ENDIF C C RETURN ALONG EDGE OF TOP C IF (DEBUG) WRITE (NDB,7040) 7040 FORMAT (' RETURN ALONG EDGE OF TOP') DO 200 JN = 1, NANGS ANG = FLOAT(NANGS - JN)*DANG SNA = SIN(ANG) CSA = COS(ANG) DO 160 J = 1, 3 DO 160 K = 1, 3 OMAG(J,K) = 0.0 160 CONTINUE OMAG(1,1) = CSA OMAG(1,3) = - SNA OMAG(2,2) = 1.0 OMAG(3,1) = SNA OMAG(3,3) = CSA C IF (CSA .GT. 0.5) XMAG(1) = - SNA**2/(H0*(1.0 + CSA)) IF (CSA .LE. 0.5) XMAG(1) = - (1.0 - CSA)/H0 XMAG(2) = 0.0 XMAG(3) = - SNA/H0 C DO 170 J = 1, 3 DO 170 K = 1, 3 S1 = 0.0 DO 165 LL = 1, 3 S1 = S1 + OMAG(J,LL)*O(4,LL,K) 165 CONTINUE O1(J,K) = S1 170 CONTINUE C DO 180 J = 1, 3 S = 0.0 DO 175 K = 1, 3 S = S + O(4,K,J)*XMAG(K) 175 CONTINUE XPT(J) = S 180 CONTINUE C DO 190 J = 1, 3 DO 190 K = 1, 3 OPT(J,K) = O1(J,K) 190 CONTINUE C QPLOT(1) = QREF(1) + (XPT(3) - OPT(1,3)*HWIDE)/UFLOOR(1) QPLOT(2) = QREF(2) + (XPT(2) - OPT(1,2)*HWIDE)/UFLOOR(1) IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) 200 CONTINUE ENDIF C C TRANSITION FROM TOP TO SIDE C IF (DOSIDE .AND. DOTOP) THEN IF (DEBUG) WRITE (NDB,7026) 7026 FORMAT (' TRANSITION FROM TOP TO SIDE') IF (.NOT. REVERS) THEN QPLOT(1) = QPLOT(1) - DAW2 QPLOT(2) = QPLOT(2) - DUW2 ELSE QPLOT(1) = QPLOT(1) + DAW2 QPLOT(2) = QPLOT(2) + DUW2 ENDIF IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) C IF (.NOT. CWISE .AND. .NOT. REVERS) THEN QPLOT(1) = QPLOT(1) + DAH2 QPLOT(2) = QPLOT(2) + DUH2 ENDIF IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF C C VIEW FROM SIDE C IF (DOSIDE) THEN IF (REVERS) THEN QREF(1) = QPLOT(1) - 0.5*DAW2 QREF(2) = QPLOT(2) - 0.5*DUW2 HWIDE = 0.5*WIDE ELSE QREF(1) = QPLOT(1) + 0.5*DAW2 QREF(2) = QPLOT(2) + 0.5*DUW2 HWIDE = - 0.5*WIDE ENDIF IF (DEBUG) WRITE (NDB,7039) HWIDE 7039 FORMAT (' HWIDE = ',F12.5) IF (DEBUG) WRITE (NDB,7032) (QREF(J), J = 1, 2) C C DOWN ALONG EDGE OF SIDE C IF (DEBUG) WRITE (NDB,7044) 7044 FORMAT (' DOWN ALONG EDGE OF SIDE') DO 250 JN = 1, NANGS ANG = FLOAT(JN)*DANG SNA = SIN(ANG) CSA = COS(ANG) DO 210 J = 1, 3 DO 210 K = 1, 3 OMAG(J,K) = 0.0 210 CONTINUE OMAG(1,1) = CSA OMAG(1,3) = - SNA OMAG(2,2) = 1.0 OMAG(3,1) = SNA OMAG(3,3) = CSA C IF (CSA .GT. 0.5) XMAG(1) = - SNA**2/(H0*(1.0 + CSA)) IF (CSA .LE. 0.5) XMAG(1) = - (1.0 - CSA)/H0 XMAG(2) = 0.0 XMAG(3) = - SNA/H0 C DO 220 J = 1, 3 DO 220 K = 1, 3 S1 = 0.0 DO 215 LL = 1, 3 S1 = S1 + OMAG(J,LL)*O(4,LL,K) 215 CONTINUE O1(J,K) = S1 220 CONTINUE C DO 230 J = 1, 3 S = 0.0 DO 225 K = 1, 3 S = S + O(4,K,J)*XMAG(K) 225 CONTINUE XPT(J) = S 230 CONTINUE C DO 240 J = 1, 3 DO 240 K = 1, 3 OPT(J,K) = O1(J,K) 240 CONTINUE C QPLOT(1) = QREF(1) + (XPT(3) + OPT(1,3)*HWIDE)/UFLOOR(1) QPLOT(2) = QREF(2) + (XPT(2) + OPT(1,2)*HWIDE)/UFLOOR(1) IF (DEBUG) WRITE (NDB,7038) (QPLOT(J), J = 1, 2), XPT(3), 1 OPT(1,3), OPT(1,1) 7038 FORMAT (' QPLOT = ',2F12.5,3X,'XPT = ',2F12.5,3X, 1 'OPT = ',2F12.5) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) 250 CONTINUE C C CROSS ENTRANCE FACE C IF (.NOT. DOENT .OR. DOTOP) THEN IF (.NOT. REVERS .OR. (REVERS .AND. CWISE)) THEN QPLOT(1) = QPLOT(1) - DAH1 QPLOT(2) = QPLOT(2) - DUH1 ELSE QPLOT(1) = QPLOT(1) + DAH1 QPLOT(2) = QPLOT(2) + DUH1 ENDIF IF (DEBUG) WRITE (NDB,7048) 7048 FORMAT (' CROSS ENTRANCE FACE') IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF C C LOOP AROUND ENTRANCE FACE C IF (DOENT .AND. .NOT. DOTOP) THEN IF (DEBUG) WRITE (NDB,7027) 7027 FORMAT (' LOOP AROUND ENTRANCE FACE') IF (REVERS) THEN QPLOT(1) = QPLOT(1) + DAH1 QPLOT(2) = QPLOT(2) + DUH1 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) - DAW1 QPLOT(2) = QPLOT(2) - DUW1 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF QPLOT(1) = QPLOT(1) - DAH1 QPLOT(2) = QPLOT(2) - DUH1 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) + DAW1 QPLOT(2) = QPLOT(2) + DUW1 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) + DAH1 QPLOT(2) = QPLOT(2) + DUH1 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) IF (.NOT. REVERS) THEN QPLOT(1) = QPLOT(1) - DAW1 QPLOT(2) = QPLOT(2) - DUW1 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) QPLOT(1) = QPLOT(1) - DAH1 QPLOT(2) = QPLOT(2) - DUH1 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF ENDIF C C RETURN ALONG EDGE OF SIDE C IF (DEBUG) WRITE (NDB,7045) 7045 FORMAT (' RETURN ALONG EDGE OF SIDE') IF (.NOT. REVERS .OR. (REVERS .AND. CWISE)) THEN QREF(1) = QREF(1) - DAH2 QREF(2) = QREF(2) - DUH2 ELSE QREF(1) = QREF(1) + DAH2 QREF(2) = QREF(2) + DUH2 ENDIF IF (DEBUG) WRITE (NDB,7032) (QREF(J), J = 1, 2) C DO 300 JN = 1, NANGS ANG = FLOAT(NANGS - JN)*DANG SNA = SIN(ANG) CSA = COS(ANG) DO 260 J = 1, 3 DO 260 K = 1, 3 OMAG(J,K) = 0.0 260 CONTINUE OMAG(1,1) = CSA OMAG(1,3) = - SNA OMAG(2,2) = 1.0 OMAG(3,1) = SNA OMAG(3,3) = CSA C IF (CSA .GT. 0.5) XMAG(1) = - SNA**2/(H0*(1.0 + CSA)) IF (CSA .LE. 0.5) XMAG(1) = - (1.0 - CSA)/H0 XMAG(2) = 0.0 XMAG(3) = - SNA/H0 C DO 270 J = 1, 3 DO 270 K = 1, 3 S1 = 0.0 DO 265 LL = 1, 3 S1 = S1 + OMAG(J,LL)*O(4,LL,K) 265 CONTINUE O1(J,K) = S1 270 CONTINUE C DO 280 J = 1, 3 S = 0.0 DO 275 K = 1, 3 S = S + O(4,K,J)*XMAG(K) 275 CONTINUE XPT(J) = S 280 CONTINUE C DO 290 J = 1, 3 DO 290 K = 1, 3 OPT(J,K) = O1(J,K) 290 CONTINUE C QPLOT(1) = QREF(1) + (XPT(3) + OPT(1,3)*HWIDE)/UFLOOR(1) QPLOT(2) = QREF(2) + (XPT(2) + OPT(1,2)*HWIDE)/UFLOOR(1) IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) 300 CONTINUE ENDIF C C LOOP AROUND EXIT FACE C IF (DOEXIT) THEN IF (DEBUG) WRITE (NDB,7020) 7020 FORMAT (' LOOP AROUND EXIT FACE') C IF ((.NOT. CWISE .OR. (CWISE .AND. HTSIDE)) 1 .AND. .NOT. REVERS) THEN QPLOT(1) = QPLOT(1) + DAW2 QPLOT(2) = QPLOT(2) + DUW2 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF C IF ((CWISE .AND. REVERS) 1 .OR. (.NOT. CWISE .AND. .NOT. REVERS)) THEN QPLOT(1) = QPLOT(1) + DAH2 QPLOT(2) = QPLOT(2) + DUH2 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF C IF (REVERS .AND. DOSIDE) THEN QPLOT(1) = QPLOT(1) - DAW2 QPLOT(2) = QPLOT(2) - DUW2 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF C IF (CWISE .AND. REVERS) THEN QPLOT(1) = QPLOT(1) - DAH2 QPLOT(2) = QPLOT(2) - DUH2 IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF ENDIF C IF (DNEXIT .AND. DOSIDE) THEN IF (CWISE .AND. .NOT. REVERS .AND. .NOT. HTSIDE) THEN QPLOT(1) = QORIG(1) + 0.5*DAH2 - 0.5*DAW2 QPLOT(2) = QORIG(2) + 0.5*DUH2 - 0.5*DUW2 ELSE IF (CWISE .AND. REVERS) THEN QPLOT(1) = QORIG(1) + 0.5*DAH2 + 0.5*DAW2 QPLOT(2) = QORIG(2) + 0.5*DUH2 + 0.5*DUW2 ELSE IF (.NOT. CWISE .AND. REVERS) THEN QPLOT(1) = QORIG(1) - 0.5*DAH2 + 0.5*DAW2 QPLOT(2) = QORIG(2) - 0.5*DUH2 + 0.5*DUW2 ENDIF IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF C C REFERENCE TRAJECTORY AT EXIT FACE C IF (DOEXIT .OR. DNEXIT) THEN IF (DEBUG) WRITE (NDB,7046) 7046 FORMAT (' REFERENCE TRAJECTORY AT EXIT FACE') QPLOT(1) = QORIG(1) + OPT(3,3)*SLESS QPLOT(2) = QORIG(2) + OPT(3,2)*SLESS IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) ENDIF QPLOT(1) = QORIG(1) QPLOT(2) = QORIG(2) IF (DEBUG) WRITE (NDB,7009) (QPLOT(J), J = 1, 2) WRITE (NPLOT,7008) (QPLOT(J), J = 1, 2) RETURN END SUBROUTINE POSSIM C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA0A.CIN' INCLUDE 'DATA1A.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM0C.CIN' INCLUDE 'ELM0D.CIN' INCLUDE 'ELM2B.CIN' INCLUDE 'ELM6.CIN' INCLUDE 'ELM8A.CIN' INCLUDE 'ELM8F.CIN' INCLUDE 'ELM8G.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'FLUSHC.CIN' INCLUDE 'INDBND.CIN' INCLUDE 'INDPAR.CIN' INCLUDE 'IOUNIT.CIN' INCLUDE 'LXRAN.CIN' INCLUDE 'R0P.CIN' INCLUDE 'STEPT1.CIN' C C LOCAL VARIABLES C INTEGER IMIS, J, NUPS, TYPES C TYPEC = TYPE CALL DEPIC2 C IF (ALIGN .AND. RMTX .AND. TYPE .NE. 8) THEN BEFORE = .TRUE. C IF (.NOT. R0P) THEN DO 50 IR = 2, 3 NUPS = NIU(IR) IF (NUPS .NE. 0) THEN DO 40 NAL = 1, NUPS IF (NAL .GT. 10) THEN WRITE (NOUT,9001) 9001 FORMAT (' *** TOO MANY NESTED MISALIGNMENTS') FLUSHL = .TRUE. GO TO 200 ENDIF TYPES = TYPE TYPE = 6 TYPEC = 8 NN = NUPS - NAL + 1 NMIS = NIM(IR,NN) IMIS = ISTOR(NMIS) TYT = INT(DATA(IMIS+7)) LFM = TYT/100 LXRAN = LFM .GE. 2 DO 25 J = 1, 25 25 IPTOJB(J) = IPTOJ(J) CALL SKETCH(NMIS) IF (NV3 .GE. 1) THEN CALL DERIVE ELSE CALL ELICIT IF (.NOT. LSTEPN) THEN CALL POSTER CALL MPRINT ENDIF ENDIF IF (FLUSHL) GO TO 200 IF (TYPE .LE. 0) GO TO 200 TYPE = TYPES DO 30 J = 1, 25 30 IPTOJ(J) = IPTOJB(J) 40 CONTINUE ENDIF 50 CONTINUE ENDIF C CALL FIND8 IR = 1 JA = 0 KA = 0 NUPS = NUP(1) C IF (NUPS .NE. 0) THEN DO 80 NAL = 1, NUPS IF (NAL .GT. 10) THEN WRITE (NOUT,9001) FLUSHL = .TRUE. GO TO 200 ENDIF TYPES = TYPE TYPE = 6 TYPEC = 8 NN = NUPS - NAL + 1 NMIS = NIM(IR,NN) IMIS = ISTOR(NMIS) TYT = INT(DATA(IMIS+7)) LFM = TYT/100 LXRAN = LFM .GE. 2 DO 60 J = 1, 25 60 IPTOJB(J) = IPTOJ(J) CALL SKETCH(NMIS) IF (NV3 .GE. 1) THEN CALL DERIVE ELSE CALL ELICIT IF (.NOT. LSTEPN) THEN CALL POSTER CALL MPRINT ENDIF ENDIF IF (FLUSHL) GO TO 200 IF (TYPE .LE. 0) GO TO 200 TYPE = TYPES DO 70 J = 1, 25 70 IPTOJ(J) = IPTOJB(J) 80 CONTINUE C ENDIF ENDIF C 200 RETURN END SUBROUTINE POSTER C C PRINTS ELEMENTS AND MATRICES DURING CALCULATION C C ---------------------------------------------------------------------- INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'BROAD.CIN' INCLUDE 'CONSTS.CIN' INCLUDE 'DATA0A.CIN' INCLUDE 'DATA0B.CIN' INCLUDE 'DATA1A.CIN' INCLUDE 'DATA1C.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'DATA2B.CIN' INCLUDE 'DATA2D.CIN' INCLUDE 'DBEND.CIN' INCLUDE 'DRBND.CIN' INCLUDE 'DSPEC.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM0B.CIN' INCLUDE 'ELM0C.CIN' INCLUDE 'ELM0D.CIN' INCLUDE 'ELM1A.CIN' INCLUDE 'ELM2A.CIN' INCLUDE 'ELM2B.CIN' INCLUDE 'ELM2C.CIN' INCLUDE 'ELM4A.CIN' INCLUDE 'ELM4C.CIN' INCLUDE 'ELM4D.CIN' INCLUDE 'ELM5A.CIN' INCLUDE 'ELM6.CIN' INCLUDE 'ELM7B.CIN' INCLUDE 'ELM8A.CIN' INCLUDE 'ELM8B.CIN' INCLUDE 'ELM8G.CIN' INCLUDE 'ELM10A.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM10C.CIN' INCLUDE 'ELM11.CIN' INCLUDE 'ELM13B.CIN' INCLUDE 'ELM13C.CIN' INCLUDE 'ELM14A.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'ELM13A.CIN' INCLUDE 'ELM15B.CIN' INCLUDE 'ELM15C.CIN' INCLUDE 'ELM16A.CIN' INCLUDE 'ELM16B.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'ELM19.CIN' INCLUDE 'ELM26A.CIN' INCLUDE 'ELM26B.CIN' INCLUDE 'ELM28.CIN' INCLUDE 'ELM38A.CIN' INCLUDE 'ELM38B.CIN' INCLUDE 'ELM41.CIN' INCLUDE 'ETACOM.CIN' INCLUDE 'INDBND.CIN' INCLUDE 'INDPAR.CIN' INCLUDE 'IOUNIT.CIN' INCLUDE 'ISEEDX.CIN' INCLUDE 'KELEM.CIN' INCLUDE 'R.CIN' INCLUDE 'RDCHAR.CIN' INCLUDE 'STEPT1.CIN' C C LOCAL VARIABLES C CHARACTER*4 LABUPD CHARACTER*7 CSD CHARACTER*8 PNAME, HPLOT(8) CHARACTER*9 CACOC CHARACTER*10 SLANG, LABOUT, LABMIS CHARACTER*11 CWORK1 CHARACTER*12 CCOC, CCOC2 CHARACTER*14 CDE0 CHARACTER*16 NUMREP CHARACTER*20 CMIS INTEGER IDATA INTEGER TYPEN LOGICAL DOVC, VARIED REAL LOUT, K1NORM, K2OUT, K3OUT REAL CODO(6), VMO(6) EQUIVALENCE (PAR16,IPAR16) C --------------------------------------------------------------------- C IF (TYPE .LE. 0) GO TO 5000 NBE = .FALSE. IF (.NOT. MPRN) GO TO 5000 NBE = .TRUE. NRT = .TRUE. SONLY = .FALSE. IF (.NOT. (PRON .AND. ELPR) .AND. TYPE .NE. 13) GO TO 70 LABOUT(1:8) = LABEL(NUM)(1:8) C C DO VARY CODES C 30 DOVC = .TRUE. DOVC = DOVC .AND. .NOT. (TYPEC .EQ. 8 .AND. RORC .GE. 3) IF (.NOT. DOVC) GO TO 60 IVA = 0 KV = NIV(TYPE) IF (KV .GT. 0) THEN KV = MAX0(KV,NPARMS) IF (TYPE .EQ. 14) KV = MIN0(KV,6) DO 50 JV = 1, KV K = I + IPTOJ(JV) ISIG = TIE(K) IF (ISIG .GE. 99) ISIG = 0 IVARY = IABS(ISIG) IF (IVARY .NE. 0) THEN IVARY = VSTOR(IVARY) IVA = 1 ENDIF 50 CONTINUE ENDIF C 60 IF (ONLY) THEN IF (IVA .EQ. 0 .AND. TYPE .NE. 10 .AND. TYPE .NE. 13 1 .AND. TYPE .NE. 22 .AND. TYPE .NE. 23) GO TO 5000 ENDIF 70 GO TO ( 100, 200, 300, 400, 500, 600, 700, 800,5000,1000, 1 1100,1200,1300,1400,5000,1600,1700,1800,1900,2000, 2 2100,5000,5000,5000,2500,5000,2700,2800,2800,5000, 3 3100,5000,3300,3400,3500,3600,3700,3800,5000,5000, 4 4100,4200,4300,5000,4500,4600,4700,4800), TYPE C C 1. -- BEAM C 100 NRT = .FALSE. WORK1 = RI / UNITO(11) IF (RMSADD) GO TO 130 IF (NEXT .EQ. 12) NBE = .FALSE. IF ((ACCEL .OR. LTWISS) .AND. NEXT .EQ. 7) NBE = .FALSE. IF (PRON .AND. ELPR) 1 WRITE (NOUT,9010) NUM, LABOUT, WORK1, XDIME(11) GO TO 5000 C 130 IF (PRON .AND. ELPR) THEN IF (.NOT. SUPP) THEN WRITE (NOUT,9011) NUM, LABOUT, WORK1, XDIME(11) ELSE WRITE (NOUT,9011) NUM, LABOUT ENDIF ENDIF GO TO 5000 C C 2. -- POLE FACE ROTATION C 200 IF (.NOT. (PRON .AND. ELPR)) GO TO 5000 IF (TYPEC .EQ. 8) GO TO 270 IF (SUPP) GO TO 240 IF (PRAN2(3) .NE. 0.0 .OR. IPTOJ(3) .NE. 0) THEN WRITE (NOUT,9021) LAYK, LAYL, LAYX ENDIF BEO = BE/UNITO(7) HGAP = APB(2)/UNITO(1) IF (NORD1 .GE. 2) THEN IF (RABT .NE. 0.0 .OR. IPTOJ(4) .NE. 0) GO TO 220 ENDIF IF (HGAP .EQ. 0.0 .AND. IPTOJ(2) .EQ. 0) THEN WRITE (NOUT,9020) NUM, LABOUT, BEO, XDIME(7) ELSE WRITE (NOUT,9020) NUM, LABOUT, BEO, XDIME(7), 1 HGAP, XDIME(1) ENDIF GO TO 5000 C 220 RABO = RABT*UNITO(8) IF (HGAP .EQ. 0.0 .AND. IPTOJ(2) .EQ. 0) THEN WRITE (NOUT,9020) NUM, LABOUT, BEO, XDIME(7), 1 RABO, XDIME(8) ELSE WRITE (NOUT,9020) NUM, LABOUT, BEO, XDIME(7), 1 HGAP, XDIME(1), RABO, XDIME(8) ENDIF GO TO 5000 C 240 WRITE (NOUT,9020) NUM, LABOUT GO TO 5000 C 270 IF (LFM .EQ. 0 .AND. BEFORE) THEN NBE = .FALSE. GO TO 5000 ENDIF IF (.NOT. BEFORE) THEN DO 275 J = 1, 6 J2MOD = MOD(J-1,2) + 1 VMO(J) = VM(J)/UMIS(J2MOD) 275 CONTINUE ENDIF C CALL CMISDO(CMIS) C LABMIS = LABEL(NMIS)(1:10) IF (LFM .GE. 1) GO TO 280 WRITE (NOUT,9080) NUM, LABMIS, VMO(1), XMIS(1), 1 VMO(2), XMIS(2), VMO(3), XMIS(1), 2 VMO(4), XMIS(2), VMO(5), XMIS(1), 3 VMO(6), XMIS(2), CMIS GO TO 5000 C 280 IF (.NOT. BEFORE) GO TO 285 WRITE (NOUT,9062) NUM, LABMIS GO TO 5000 C 285 WRITE (NOUT,9081) NUM, LABMIS, 1 VMO(1), XMIS(1), VMO(2), XMIS(2), 2 VMO(3), XMIS(1), VMO(4), XMIS(2), 3 VMO(5), XMIS(1), VMO(6), XMIS(2), 4 CMIS GO TO 5000 C C 3. -- DRIFT SPACE C 300 IF (PRON .AND. ELPR) THEN IF (.NOT. SUPP) THEN LOUT = L/UNITO(8) WRITE (NOUT,9030) NUM, LABOUT, LOUT, XDIME(8) ELSE WRITE (NOUT,9030) NUM, LABOUT ENDIF ENDIF GO TO 5000 C C 4. -- BENDING MAGNET C 400 IF (.NOT. (PRON .AND. ELPR)) GO TO 5000 IF (TYPEC .EQ. 8) GO TO 470 IF (SUPP) GO TO 450 IK1 = IPTOJ(NK1) C DO 410 NPAR = NRMPS, NK3 IPAR = IPTOJ(NPAR) VARIED = TIE(I+IPAR) .NE. 0 .AND. TIE(I+IPAR) .LT. 99 IF (IPAR .EQ. 0 .AND. VARIED) GO TO 410 IF (.NOT. VARIED .AND. PRAN4(NPAR) .EQ. 0.0) GO TO 410 IF (NPAR .EQ. NRMPS) PARAM = RMPS IF (NPAR .EQ. NRNMS) PARAM = RNMS IF (NPAR .EQ. NVR) PARAM = VRN IF (NPAR .EQ. NNP) PARAM = NPN IF (NPAR .EQ. NK1P) PARAM = K1P*UNITO(8)**2 IF (NPAR .EQ. NBDB) PARAM = BDB IF (NPAR .EQ. NK2) THEN PARAM = K2*UNITO(8)**3 IF (MPMAD) PARAM = 2.0*PARAM ENDIF IF (NPAR .EQ. NBDBP) PARAM = BDBP IF (NPAR .EQ. NK2P) THEN PARAM = K2P*UNITO(8)**3 IF (MPMAD) PARAM = 2.0*PARAM ENDIF IF (NPAR .EQ. NGAM) PARAM = GAM IF (NPAR .EQ. NK3) THEN PARAM = K3*UNITO(8)**3 IF (MPMAD) PARAM = 6.0*PARAM ENDIF WRITE (NOUT,9160) NUM, DBEND(NPAR), BLANK, PARAM 410 CONTINUE C LOUT = LBEND/UNITO(8) IF (H0 .EQ. 0.0) THEN RHONRM = 0.0 ELSE RHONRM = 1.0/(H0*UNITO(8)) ENDIF ALNORM = AL/UNITO(7) IF (RI .EQ. 0.0) GO TO 430 BNORM = (1.0 + RMPS)*B/UNITO(9) IF (IK1 .NE. 0 .OR. PRAN4(6) .NE. 0.0) GO TO 420 IF (RHONRM .GE. 1000000.0 .OR. RHONRM .LE. -100000.0) GO TO 418 WRITE (NOUT,9040) NUM, KELEM(TYPE), LABOUT, LOUT, XDIME(8), 1 BNORM, XDIME(9), NB, RHONRM, XDIME(8), 2 ALNORM, XDIME(7) GO TO 5000 C 418 WRITE (NOUT,9044) NUM, KELEM(TYPE), LABOUT, LOUT, XDIME(8), 1 BNORM, XDIME(9), NB, ALNORM, XDIME(7) GO TO 5000 C 420 K1NORM = K1*UNITO(8)**2 WRITE (NOUT,9041) NUM, KELEM(4), LABOUT, LOUT, XDIME(8), 1 BNORM, XDIME(9), K1NORM, XDIME(8), 2 RHONRM, XDIME(8), ALNORM, XDIME(7) GO TO 5000 C 430 IF (IK1 .NE. 0) GO TO 435 WRITE (NOUT,9042) NUM, KELEM(4), LABOUT, LOUT, XDIME(8), 1 NB, RHONRM, XDIME(8), ALNORM, XDIME(7) GO TO 5000 C 435 K1NORM = K1*UNITO(8)**2 WRITE (NOUT,9043) NUM, KELEM(4), LABOUT, LOUT, XDIME(8), 1 K1NORM, XDIME(8), RHONRM, XDIME(8), 2 ALNORM, XDIME(7) GO TO 5000 C 450 WRITE (NOUT,9040) NUM, KELEM(4), LABOUT IF (RORC .NE. 3 .AND. RORC .NE. 4) GO TO 5000 WRITE (NOUT,9080) NUM, LABMIS GO TO 5000 C 470 LABMIS = LABEL(NMIS)(1:10) IF (LFM .EQ. 0 .AND. BEFORE) THEN NBE = .FALSE. GO TO 5000 ENDIF CALL CMISDO(CMIS) IF (.NOT. BEFORE) THEN DO 475 J = 1, 6 J2MOD = MOD(J-1,2) + 1 VMO(J) = VM(J)/UMIS(J2MOD) 475 CONTINUE ENDIF C IF (LFM .GE. 1) GO TO 480 WRITE (NOUT,9080) NUM, LABMIS, 1 VMO(1), XMIS(1), VMO(2), XMIS(2), 2 VMO(3), XMIS(1), VMO(4), XMIS(2), 3 VMO(5), XMIS(1), VMO(6), XMIS(2), 4 CMIS GO TO 5000 C 480 IF (.NOT. BEFORE) GO TO 485 WRITE (NOUT,9062) NUM, LABMIS GO TO 5000 C 485 WRITE (NOUT,9081) NUM, LABMIS, 1 VMO(1), XMIS(1), VMO(2), XMIS(2), 2 VMO(3), XMIS(1), VMO(4), XMIS(2), 3 VMO(5), XMIS(1), VMO(6), XMIS(2), 4 CMIS GO TO 5000 C C 5. -- QUADRUPOLE C 500 IF (.NOT. (PRON .AND. ELPR)) GO TO 5000 IF (TYPEC .EQ. 20) GO TO 560 IF (TYPEC .EQ. 8) GO TO 570 C 510 IF (SUPP) GO TO 565 LOUT = LMAG/UNITO(8) IF (NORD1 .LT. 1) THEN SKX = 0.0 ELSE SKX = - KX2 * SX ENDIF IF (SKX .EQ. 0.0) THEN CWORK1 = ' INFINITE' ELSE WORK1 = -1.0/(SKX*UNITO(8)) IF (ABS(WORK1) .GT. 100000.0) THEN WRITE (CWORK1,9054) WORK1 ELSE WRITE (CWORK1,9053) WORK1 ENDIF ENDIF C 530 IG = IPTOJ(4) IK1 = IPTOJ(5) IF (IG .NE. 0) GO TO 540 IF (IK1 .NE. 0) GO TO 545 BNORM = B/UNITO(9) APOUT = AP/UNITO(1) WRITE (NOUT,9050) NUM, LABOUT, LOUT, XDIME(8), BNORM, XDIME(9), 1 APOUT, XDIME(1), CWORK1, XDIME(8) GO TO 5000 C 540 GNORM = GRAD*UNITO(1)/UNITO(9) WRITE (NOUT,9051) NUM, LABOUT, LOUT, XDIME(8), GNORM, XDIME(9), 1 XDIME(1), CWORK1, XDIME(8) GO TO 5000 C 545 WRITE (NOUT,9052) NUM, LABOUT, LOUT, XDIME(8), K1, XDIME(8), 1 CWORK1, XDIME(8) GO TO 5000 C 560 THOUT = TH/UNITO(13) WRITE (NOUT,9200) NUM, BLANK, THOUT, XDIME(13) GO TO 5000 C 565 WRITE (NOUT,9050) NUM, LABOUT IF (RORC .NE. 3 .AND. RORC .NE. 5) GO TO 5000 WRITE (NOUT,9080) NUM, LABMIS GO TO 5000 C 570 IF (LFM .EQ. 0 .AND. BEFORE) THEN NBE = .FALSE. GO TO 5000 ENDIF IF (.NOT. BEFORE) THEN DO 575 J = 1, 6 J2MOD = MOD(J-1,2) + 1 VMO(J) = VM(J)/UMIS(J2MOD) 575 CONTINUE ENDIF C CALL CMISDO(CMIS) C LABMIS = LABEL(NMIS)(1:10) IF (LFM .GE. 1) GO TO 580 WRITE (NOUT,9080) NUM, LABMIS, 1 VMO(1), XMIS(1), VMO(2), XMIS(2), 2 VMO(3), XMIS(1), VMO(4), XMIS(2), 3 VMO(5), XMIS(1), VMO(6), XMIS(2), 4 CMIS GO TO 5000 C 580 IF (.NOT. BEFORE) GO TO 585 WRITE (NOUT,9062) NUM, LABMIS GO TO 5000 C 585 WRITE (NOUT,9081) NUM, LABMIS, 1 VMO(1), XMIS(1), VMO(2), XMIS(2), 2 VMO(3), XMIS(1), VMO(4), XMIS(2), 3 VMO(5), XMIS(1), VMO(6), XMIS(2), 4 CMIS GO TO 5000 C C 6. -- UPDATE C 600 NBE = .FALSE. NRT = .FALSE. IF (.NOT. (PRON .AND. ELPR)) GO TO 5000 IF (TYPEC .EQ. 8) GO TO 650 IF (JA .NE. 0) GO TO 620 IF (SUPP) GO TO 610 LABUPD = BLANK IF (JA .EQ. 0 .AND. KA .EQ. 1) LABUPD = 'R1' IF (JA .EQ. 0 .AND. KA .EQ. 2) LABUPD = 'R2' WRITE (NOUT,9060) NUM, LABOUT, LABUPD GO TO 5000 C 610 WRITE (NOUT,9060) NUM, LABOUT GO TO 5000 C 620 IF (SUPP) GO TO 630 WIDTH = DATA(I+2) JAX = MOD(JA,100) WRITE (NOUT,9061) NUM, LABOUT, JA, WIDTH, XDIME(JAX) GO TO 5000 C 630 WRITE (NOUT,9061) NUM, LABOUT GO TO 5000 C 650 IF (RORC .GE. 3 .AND. LFM .GE. 2) GO TO 5000 NBE = .TRUE. LABMIS = LABEL(NMIS)(1:10) WRITE (NOUT,9062) NUM, LABMIS GO TO 5000 C C 7. -- BEAM CENTROID SHIFT C 700 NRT = .FALSE. IF (.NOT. (PRON .AND. ELPR)) GO TO 5000 IF (.NOT. SUPP) THEN DO 710 J = 1, 6 710 CODO(J) = COD(J)/UNITO(J) WRITE (NOUT,9070) NUM, LABOUT, (CODO(J), XDIME(J), J = 1, 6) ELSE C WRITE (NOUT,9070) NUM, LABOUT ENDIF GO TO 5000 C C 8. -- MAGNET MISALIGNMENT C 800 NRT = LFM .GE. 1 .AND. LTAB .EQ. 0 LABMIS = LABEL(NUM)(1:10) IF (RORC .GE. 3) THEN NBE = .FALSE. GO TO 5000 ENDIF IF (.NOT. (PRON .AND. ELPR)) GO TO 5000 IF (SUPP) GO TO 820 DO 805 J = 1, 6 J2MOD = MOD(J-1,2) + 1 VMO(J) = VM(J)/UMIS(J2MOD) 805 CONTINUE C CALL CMISDO(CMIS) C IF (LFM .EQ. 1) GO TO 810 WRITE (NOUT,9080) NUM, LABMIS, 1 VMO(1), XMIS(1), VMO(2), XMIS(2), VMO(3), XMIS(1), 2 VMO(4), XMIS(2), VMO(5), XMIS(1), VMO(6), XMIS(2), 3 CMIS GO TO 5000 C 810 WRITE (NOUT,9081) NUM, LABMIS, 1 VMO(1), XMIS(1), VMO(2), XMIS(2), VMO(3), XMIS(1), 2 VMO(4), XMIS(2), VMO(5), XMIS(1), VMO(6), XMIS(2), 3 CMIS GO TO 5000 C 820 WRITE (NOUT,9080) NUM, LABOUT GO TO 5000 C C 10. -- FITTING CONSTRAINTS C 1000 NBE = .FALSE. IF (.NOT. (PRON .AND. ELPR)) GO TO 5000 IF (CTY .EQ. 0) SLANG = '*FIT*' IF (CTY .EQ. 1) SLANG = '*LOW.LIM.*' IF (CTY .EQ. 2) SLANG = '*UP.LIM.*' IF (SUPP) GO TO 1030 CALL NAME10 C IF (LSTEP .AND. BROAD) THEN FSTEPS = FLOAT(NSTEPS) ID1 = IPTOJ(10) ID2 = IPTOJ(11) COC = DATA(I+ID1)/FSTEPS COC2 = DATA(I+ID2)/FSTEPS - COC**2 COC2 = SQRT(COC2) ENDIF C IF (DE0 .EQ. 0.0) THEN CDE0 = ' 0.0' ELSE IF (ABS(DE0) .GE. 0.0001) THEN WRITE (CDE0,9107) DE0 ELSE WRITE (CDE0,9108) DE0 ENDIF C IF (ABS(SD) .GE. 0.0001 .AND. ABS(SD) .LT. 10.0) THEN WRITE (CSD,9109) SD ELSE WRITE (CSD,9111) SD ENDIF C IF (JCON .GT. -20 .AND. JCON .LT. -10 .AND. JCON .NE. -15) THEN IF (ABS(COC) .LE. 2.0) THEN COC = COCO ELSE COC = 0.5*COC GO TO 1020 ENDIF ENDIF C IF (COC .EQ. 0.0) THEN CCOC = ' 0.0' ELSE IF (ABS(COC) .GE. 0.0001) THEN WRITE (CCOC,9104) COC ELSE WRITE (CCOC,9105) COC ENDIF C IF (LSTEP .AND. BROAD) THEN IF (COC2 .EQ. 0.0) THEN CCOC2 = ' 0.0' ELSE IF (ABS(COC2) .GE. 0.0001) THEN WRITE (CCOC2,9104) COC2 ELSE WRITE (CCOC2,9105) COC2 ENDIF ENDIF C IF (LSTEP .AND. BROAD) GO TO 1010 IF (NARROW) THEN WRITE (NOUT,9102) NUM, SLANG, LABOUT, FTNAME, CDE0, CSD, CCOC ELSE WRITE (NOUT,9100) NUM, SLANG, LABOUT, FTNAME, CDE0, CSD, CCOC ENDIF GO TO 5000 C 1010 IF (NARROW) THEN WRITE (NOUT,9112) NUM, SLANG, LABOUT, FTNAME, CDE0, CSD, CCOC, 1 CCOC2 ELSE WRITE (NOUT,9113) NUM, SLANG, LABOUT, FTNAME, CDE0, CSD, CCOC, 1 CCOC2 ENDIF GO TO 5000 C 1020 WRITE (CACOC,9106) COC IF (NARROW) THEN WRITE (NOUT,9103) NUM, SLANG, LABOUT, FTNAME, CDE0, CSD, CACOC ELSE WRITE (NOUT,9101) NUM, SLANG, LABOUT, FTNAME, CDE0, CSD, CACOC ENDIF GO TO 5000 C 1030 WRITE (NOUT,9100) NUM, SLANG, LABOUT GO TO 5000 C C 11. -- ACCELERATOR C 1100 IF (.NOT. (PRON .AND. ELPR)) GO TO 5000 IF (SUPP) GO TO 1110 LOUT = L/UNITO(8) EGOUT = EGAIN/UNITO(11) WORK1 = RI/UNITO(11) PHOUT = PHASEL*RADIAN WOUT = WAVEL/UNITO(5) WRITE (NOUT,9110) NUM, LABOUT, LOUT, XDIME(8), EGOUT, 1 WORK1, XDIME(11), PHOUT, WOUT GO TO 5000 C 1110 WRITE (NOUT,9110) NUM, LABOUT GO TO 5000 C C 12. -- CORRELATIONS IN BEAM ELLIPSE C 1200 IF (.NOT. (PRON .AND. ELPR)) GO TO 5000 IF (IVA .NE. 0) WRITE (NOUT,9120) NUM, LABOUT NRT = .FALSE. GO TO 5000 C C 13. -- INPUT-OUTPUT OPTIONS C 1300 NBE = .FALSE. IF (PRON .AND. ELPR .AND. .NOT. ONLY) THEN IF (CDB .EQ. 9) WRITE (NOUT,9130) NUM, LABOUT IF (CDB .EQ. 11) WRITE (NOUT,9131) NUM, LABOUT IF (CDB .EQ. 9 .OR. CDB .EQ. 11) LCPR = .FALSE. ENDIF CALL IO GO TO 5000 C C 14. -- ARBITRARY MATRIX C 1400 IF (.NOT. (PRON .AND. ELPR)) GO TO 5000 IF (I14S .NE. 0) THEN WRITE (NOUT,9140) NUM, LABOUT, J1 ELSE IF (I14T .NE. 0) THEN WRITE (NOUT,9141) NUM, LABOUT, J1 ELSE WRITE (NOUT,9142) NUM, LABOUT, J1 ENDIF IF (NUM + 1 .GT. NEL) GO TO 5000 IF (NEXT .EQ. 14) NBE = .FALSE. GO TO 5000 C C 16. -- SPECIAL PARAMETERS C 1600 NBE = .FALSE. NRT = .FALSE. IF (.NOT. (PRON .AND. ELPR)) GO TO 5000 J = NPARS IF (NPARS .EQ. 100) J = 28 IF (NPARS .EQ. 101) J = 29 IF (NPARS .EQ. 102) J = 30 IF (J .GT. 30) GO TO 5000 PNAME = DSPEC(J+3)(1:8) IF (SUPP) GO TO 1620 IF (NPARS .EQ. 14) GO TO 1610 WRITE (NOUT,9160) NUM, PNAME, LABOUT, PARAM GO TO 5000 C 1610 DO 1611 J = 1, 4 J1 = 4*J - 3 J2 = J1 + 3 WRITE (NUMREP(J1:J2),9162) ISEEDX(J) 1611 CONTINUE DO 1612 J = 2, 4 DO 1612 K = 1, 4 JK = 4*J + K - 4 IF (NUMREP(JK:JK) .EQ. ' ') NUMREP(JK:JK) = '0' 1612 CONTINUE WRITE (NOUT,9161) NUM, PNAME, LABOUT, NUMREP GO TO 5000 C 1620 WRITE (NOUT,9160) NUM, PNAME, LABOUT GO TO 5000 C C 17. -- SECOND ORDER CALCULATION C 1700 NBE = .FALSE. IF (.NOT. (PRON .AND. ELPR)) GO TO 5000 IF (NORDX .EQ. 3) GO TO 1720 IF (NORDX .EQ. 2) GO TO 1710 WRITE (NOUT,9170) NUM, LABOUT, NORDX, NORD3 GO TO 5000 C 1710 WRITE (NOUT,9171) NUM, LABOUT, NORDX, NORD3 GO TO 5000 C 1720 WRITE (NOUT,9172) NUM, LABOUT, NORDX, NORD3 GO TO 5000 C C 18. -- SEXTUPOLE C 1800 IF (.NOT. (PRON .AND. ELPR)) GO TO 5000 IF (TYPEC .EQ. 20) GO TO 1820 IF (TYPEC .EQ. 8) GO TO 1830 IF (SUPP) GO TO 1840 C 1810 LOUT = LMAG/UNITO(8) IK2 = IPTOJ(4) IF (IK2 .NE. 0) GO TO 1815 BNORM = B/UNITO(9) APOUT = AP/UNITO(1) WRITE (NOUT,9180) NUM, LABOUT, LOUT, XDIME(8), BNORM, XDIME(9), 1 APOUT, XDIME(1) GO TO 5000 C 1815 K2OUT = K2*UNITO(8)**3 IF (MPMAD) K2OUT = 2.0*K2OUT WRITE (NOUT,9181) NUM, LABOUT, LOUT, XDIME(8), K2OUT, XDIME(8) GO TO 5000 C 1820 IF (SUPP) GO TO 1825 THOUT = TH/UNITO(13) WRITE (NOUT,9200) NUM, BLANK, THOUT, XDIME(13) GO TO 5000 C 1825 WRITE (NOUT,9200) NUM GO TO 5000 C 1830 IF (RORC .NE. 3) GO TO 5000 IF (TYT .LT. 200) GO TO 5000 CALL CMISDO(CMIS) DO 1835 J = 1, 6 J2MOD = MOD(J-1,2) + 1 VMO(J) = VM(J)/UMIS(J2MOD) 1835 CONTINUE LABMIS = LABEL(NMIS)(1:10) WRITE (NOUT,9080) NUM, LABMIS, 1 VMO(1), XMIS(1), VMO(2), XMIS(2), 2 VMO(3), XMIS(1), VMO(4), XMIS(2), 3 VMO(5), XMIS(1), VMO(6), XMIS(2), 3 CMIS GO TO 5000 C 1840 WRITE (NOUT,9180) NUM, LABOUT IF (RORC .NE. 3) GO TO 5000 WRITE (NOUT,9080) NUM, LABMIS GO TO 5000 C C 19. -- SOLENOID C 1900 IF (.NOT. (PRON .AND. ELPR)) GO TO 5000 IF (SUPP) GO TO 1920 LOUT = L/UNITO(8) FLEN = - R(2,1)/(SQRT(R(1,1))*UNITO(8)) ANORM = 0.5*KL/UNITO(13) IK = IPTOJ(3) IF (IK .NE. 0) GO TO 1910 BNORM = B/UNITO(9) WRITE (NOUT,9190) NUM, LABOUT, LOUT, XDIME(8), BNORM, XDIME(9), 1 FLEN, XDIME(8), ANORM, XDIME(13) GO TO 5000 C 1910 WRITE (NOUT,9191) NUM, LABOUT, LOUT, XDIME(8), ANORM GO TO 5000 C 1920 WRITE (NOUT,9190) NUM, LABOUT GO TO 5000 C C 20. -- BEAM ROTATION C 2000 IF (.NOT. (PRON .AND. ELPR)) GO TO 5000 TYPEN = IDATA(ISTOR(NUM+NDIF)) IF (REFER .AND. (TYPEN .EQ. 2 .OR. TYPEN .EQ. 4 1 .OR. TYPEN .EQ. 5 .OR. TYPEN .EQ. 18 2 .OR. TYPEN .EQ. 25 .OR. TYPEN .EQ. 28 3 .OR. TYPEN .EQ. 29)) SONLY = .TRUE. IF (SUPP) GO TO 2010 THOUT = TH/UNITO(13) WRITE (NOUT,9200) NUM, LABOUT, THOUT, XDIME(13) GO TO 5000 C 2010 WRITE (NOUT,9200) NUM, LABOUT GO TO 5000 C C 21. -- STRAY FIELD C 2100 NRT = .FALSE. IF (.NOT. (PRON .AND. ELPR)) GO TO 5000 IF (SUPP) GO TO 2110 WRITE (NOUT,9210) NUM, LABOUT, DATA(I+1), DATA(I+2), DATA(I+3) GO TO 5000 C 2110 WRITE (NOUT,9210) NUM, LABOUT GO TO 5000 C C 25. -- OCTUPOLE C 2500 IF (.NOT. (PRON .AND. ELPR)) GO TO 5000 IF (TYPEC .EQ. 20) GO TO 2520 IF (SUPP) GO TO 2550 C 2510 LOUT = LMAG/UNITO(8) IK3 = IPTOJ(4) IF (IK3 .NE. 0) GO TO 2515 BNORM = B/UNITO(9) APOUT = AP/UNITO(1) WRITE (NOUT,9250) NUM, LABOUT, LOUT, XDIME(8), BNORM, XDIME(9), 1 APOUT, XDIME(1) GO TO 5000 C 2515 K3OUT = K3*UNITO(8)**3 IF (MPMAD) K3OUT = 6.0*K3OUT WRITE (NOUT,9251) NUM, LABOUT, LOUT, XDIME(8), K3OUT, XDIME(8) GO TO 5000 C 2520 THOUT = TH/UNITO(13) WRITE (NOUT,9200) NUM, BLANK, THOUT, XDIME(13) GO TO 5000 C 2550 WRITE (NOUT,9250) NUM, LABOUT GO TO 5000 C C 27. -- ACCELERATOR FUNCTION ETA C 2700 IF (.NOT. (PRON .AND. ELPR)) GO TO 5000 DO 2705 J = 1, 6 2705 CODO(J) = ETA(J)/UNITO(J) IF (.NOT. (ACCEL .OR. LTWISS)) GO TO 2720 IF (SUPP) GO TO 2710 WRITE (NOUT,9270) NUM, LABOUT, (CODO(J), XDIME(J), J = 1, 6) GO TO 5000 C 2710 WRITE (NOUT,9270) NUM, LABOUT GO TO 5000 C 2720 IF (SUPP) GO TO 2730 WRITE (NOUT,9271) NUM, LABOUT, (CODO(J), XDIME(J), J = 1, 6) GO TO 5000 C 2730 WRITE (NOUT,9271) NUM, LABOUT GO TO 5000 C C 28. -- RECTANGULAR BEND MAGNET (INCLUDING FRINGE FIELDS) C OR C 29. -- SECTOR BEND MAGNET (INCLUDING FRINGE FIELDS) C 2800 IF (.NOT. (PRON .AND. ELPR)) GO TO 5000 IF (SUPP) GO TO 2890 IF (TYPEC .EQ. 8) GO TO 2870 IF (TYPEC .EQ. 20) GO TO 2860 IF (TYPEC .EQ. 4) GO TO 2820 IF (TYPEC .EQ. 2 .AND. BEFORE) GO TO 2810 IF (TYPEC .EQ. 2 .AND. .NOT. BEFORE) GO TO 2850 GO TO 5000 C 2810 BEO = BE1/UNITO(7) IF (NORD1 .EQ. 1) THEN WRITE (NOUT,9281) NUM, LABOUT, BEO, XDIME(7) ELSE IF (NDIF .EQ. 1) THEN RABO = RAB1*UNITO(8) ELSE RABO = RAB2*UNITO(8) ENDIF IF (RABO .NE. 0.0) THEN WRITE (NOUT,9281) NUM, LABOUT, BEO, XDIME(7), RABO, XDIME(8) ELSE WRITE (NOUT,9281) NUM, LABOUT, BEO, XDIME(7) ENDIF ENDIF GO TO 5000 C 2820 IK1 = IPTOJ(NK1) NRMPS = 7 NK3 = 21 C DO 2825 NPAR = NRMPS, NK3 IPAR = IPTOJ(NPAR) IF (NPAR .EQ. NE1 .OR. NPAR .EQ. NE2 .OR. NPAR .EQ. NH1 1 .OR. NPAR .EQ. NH2) GO TO 2825 VARIED = TIE(I+IPAR) .NE. 0 .AND. TIE(I+IPAR) .LT. 99 IF (IPAR .EQ. 0 .AND. VARIED) GO TO 2825 IF (.NOT. VARIED .AND. PRAN28(NPAR) .EQ. 0.0) GO TO 2825 IF (NPAR .EQ. NRMPS) PARAM = RMPS IF (NPAR .EQ. NVR) PARAM = VRN IF (NPAR .EQ. NNP) PARAM = NPN IF (NPAR .EQ. NK1P) PARAM = K1P*UNITO(8)**2 IF (NPAR .EQ. NRNMS) PARAM = RNMS IF (NPAR .EQ. NBDB) PARAM = BDB IF (NPAR .EQ. NK2) THEN PARAM = K2*UNITO(8)**3 IF (MPMAD) PARAM = 2.0*PARAM ENDIF IF (NPAR .EQ. NBDBP) PARAM = BDBP IF (NPAR .EQ. NK2P) THEN PARAM = K2P*UNITO(8)**3 IF (MPMAD) PARAM = 2.0*PARAM ENDIF IF (NPAR .EQ. NGAM) PARAM = GAM IF (NPAR .EQ. NK3) THEN PARAM = K3*UNITO(8)**4 IF (MPMAD) PARAM = 6.0*PARAM ENDIF WRITE (NOUT,9160) NUM, DRBND(NPAR), BLANK, PARAM 2825 CONTINUE C IF (TYPE .EQ. 28) THEN LOUT = LRBEND/UNITO(8) NN = 28 ELSE IF (TYPE .EQ. 29) THEN LOUT = LBEND/UNITO(8) NN = 29 ELSE LOUT = LBEND/UNITO(8) NN = 4 ENDIF IF (H0 .EQ. 0.0) THEN RHONRM = 0.0 ELSE RHONRM = 1.0/(H0*UNITO(8)) ENDIF ALNORM = AL/UNITO(7) IF (RI .EQ. 0.0) GO TO 2830 BNORM = (1.0 + RMPS)*B/UNITO(9) IF (IK1 .NE. 0) GO TO 2828 IF (RHONRM .GE. 1000000.0 .OR. RHONRM .LE. -100000.0) GO TO 2827 WRITE (NOUT,9040) NUM, KELEM(NN), LABOUT, LOUT, XDIME(8), 1 BNORM, XDIME(9), NB, RHONRM, XDIME(8), 2 ALNORM, XDIME(7) GO TO 5000 C 2827 WRITE (NOUT,9044) NUM, KELEM(NN), LABOUT, LOUT, XDIME(8), 1 BNORM, XDIME(9), NB, ALNORM, XDIME(7) GO TO 5000 C 2828 K1NORM = K1*UNITO(8)**2 WRITE (NOUT,9041) NUM, KELEM(NN), LABOUT, LOUT, XDIME(8), 1 BNORM, XDIME(9), K1NORM, XDIME(8), 2 RHONRM, XDIME(8), ALNORM, XDIME(7) GO TO 5000 C 2830 IF (IK1 .NE. 0) GO TO 2835 WRITE (NOUT,9042) NUM, KELEM(NN), LABOUT, LOUT, XDIME(8), 1 NB, RHONRM, XDIME(8), ALNORM, XDIME(7) GO TO 5000 2835 K1NORM = K1*UNITO(8)**2 WRITE (NOUT,9043) NUM, KELEM(NN), LABOUT, 1 LOUT, XDIME(8), K1NORM, XDIME(8), 2 RHONRM, XDIME(8), ALNORM, XDIME(7) GO TO 5000 C 2850 BEO = BE2/UNITO(7) IF (NORD1 .EQ. 1) THEN WRITE (NOUT,9281) NUM, LABOUT, BEO, XDIME(7) ELSE IF (NDIF .EQ. 1) THEN RABO = RAB2*UNITO(8) ELSE RABO = RAB1*UNITO(8) ENDIF IF (RABO .NE. 0.0) THEN WRITE (NOUT,9281) NUM, LABOUT, BEO, XDIME(7), 1 RABO, XDIME(8) ELSE WRITE (NOUT,9281) NUM, LABOUT, BEO, XDIME(7) ENDIF ENDIF GO TO 5000 C 2860 THOUT = TH/UNITO(13) WRITE (NOUT,9200) NUM, BLANK, THOUT, XDIME(13) GO TO 5000 C 2870 CALL CMISDO(CMIS) IF (.NOT. BEFORE) THEN DO 2875 J = 1, 6 J2MOD = MOD(J-1,2) + 1 VMO(J) = VM(J)/UMIS(J2MOD) 2875 CONTINUE ENDIF C CALL CMISDO(CMIS) C LABMIS = LABEL(NMIS)(1:10) IF (LFM .GE. 1) GO TO 2880 WRITE (NOUT,9080) NUM, LABMIS, 1 VMO(1), XMIS(1), VMO(2), XMIS(2), 2 VMO(3), XMIS(1), VMO(4), XMIS(2), 3 VMO(5), XMIS(1), VMO(6), XMIS(2), 4 CMIS GO TO 5000 C 2880 IF (.NOT. BEFORE) GO TO 2885 IF (PRON .AND. ELPR) WRITE (NOUT,9062) NUM, LABMIS GO TO 5000 C 2885 WRITE (NOUT,9081) NUM, LABMIS, 1 VMO(1), XMIS(1), VMO(2), XMIS(2), 2 VMO(3), XMIS(1), VMO(4), XMIS(2), 3 VMO(5), XMIS(1), VMO(6), XMIS(2), 4 CMIS GO TO 5000 C 2890 WRITE (NOUT,9040) NUM, KELEM(TYPE), LABOUT GO TO 5000 C C 31. -- MARKER C 3100 IF (.NOT. (PRON .AND. ELPR)) GO TO 5000 WRITE (NOUT,9310) NUM, LABOUT GO TO 5000 C C 33. -- STORED MATRIX ELEMENT OR ALGEBRAIC EXPRESSION C 3300 NBE = .FALSE. IF (SUPP) GO TO 5000 IF (LABEL(NUM) .EQ. BLANK) GO TO 5000 WRITE (NOUT,9330) NUM, LABOUT, PARAM GO TO 5000 C C 34. -- PLASMA LENS C 3400 IF (.NOT. (PRON .AND. ELPR)) GO TO 5000 IF (SUPP) GO TO 3470 LOUT = LMAG/UNITO(8) IF (NORD1 .LT. 1) GO TO 3415 SKX = - KX2 * SX IF (SKX .NE. 0.0) GO TO 3420 3415 WORK1 = 0.0 GO TO 3430 3420 WORK1 = 1.0/(SKX*UNITO(8)) C 3430 IG = IPTOJ(4) IK1 = IPTOJ(5) IF (IG .NE. 0) GO TO 3440 IF (IK1 .NE. 0) GO TO 3445 BNORM = B/UNITO(9) APOUT = AP/UNITO(1) WRITE (NOUT,9340) NUM, LABOUT, LOUT, XDIME(8), BNORM, 1 XDIME(9), APOUT, XDIME(1), WORK1, XDIME(8) GO TO 5000 C 3440 GNORM = GRAD*UNITO(1)/UNITO(9) WRITE (NOUT,9341) NUM, LABOUT, LOUT, 1 XDIME(8), GNORM, XDIME(9), XDIME(1), 2 WORK1, XDIME(8) GO TO 5000 C 3445 IF (ABS(K1) .GT. 0.01) THEN WRITE (NOUT,9342) NUM, LABOUT, LOUT, 1 XDIME(8), K1, XDIME(8), WORK1, XDIME(8) ELSE WRITE (NOUT,9343) NUM, LABOUT, LOUT, 1 XDIME(8), K1, XDIME(8), WORK1, XDIME(8) ENDIF GO TO 5000 C 3470 WRITE (NOUT,9340) NUM, LABOUT GO TO 5000 C C 35. -- HKICK -- HORIZONTAL VERNIER C 3500 IF (.NOT. (PRON .AND. ELPR)) GO TO 5000 IF (TYPEC .EQ. 20) GO TO 3560 IF (SUPP) GO TO 3550 LOUT = LBEND/UNITO(8) BNORM = B/UNITO(9) ALNORM = AL/UNITO(7) IF (L .EQ. 0.0 .AND. AL .NE. 0.0) GO TO 3510 WRITE (NOUT,9350) NUM, LABOUT, LOUT, XDIME(8), BNORM, XDIME(9), 1 ALNORM, XDIME(7) GO TO 5000 C 3510 WRITE (NOUT,9351) NUM, LABOUT, LOUT, XDIME(8), ALNORM, XDIME(7) GO TO 5000 C 3550 WRITE (NOUT,9350) NUM, LABOUT GO TO 5000 C 3560 IF (SUPP) GO TO 3565 THOUT = TH/UNITO(13) WRITE (NOUT,9200) NUM, BLANK, THOUT, XDIME(13) GO TO 5000 C 3565 WRITE (NOUT,9200) NUM, BLANK GO TO 5000 C C 36. -- VKICK -- VERTICAL VERNIER C 3600 IF (.NOT. (PRON .AND. ELPR)) GO TO 5000 IF (TYPEC .EQ. 20) GO TO 3660 IF (SUPP) GO TO 3650 LOUT = LBEND/UNITO(8) BNORM = B/UNITO(9) ALNORM = AL/UNITO(7) IF (L .EQ. 0.0 .AND. AL .NE. 0.0) GO TO 3610 WRITE (NOUT,9360) NUM, LABOUT, LOUT, XDIME(8), BNORM, 1 XDIME(9), ALNORM, XDIME(7) GO TO 5000 C 3610 WRITE (NOUT,9361) NUM, LABOUT, LOUT, XDIME(8), ALNORM, XDIME(7) GO TO 5000 C 3650 WRITE (NOUT,9360) NUM, LABOUT GO TO 5000 C 3660 IF (SUPP) GO TO 3665 NROT35 = 5 THROT = DATA(I+IPTOJ(NROT35)) THOUT = THROT IF (.NOT. BEFORE) THOUT = - THOUT WRITE (NOUT,9200) NUM, BLANK, THOUT, XDIME(13) GO TO 5000 C 3665 WRITE (NOUT,9200) NUM, BLANK GO TO 5000 C C 37. -- ALIGNMENT MARKER C 3700 IF (TYPEC .EQ. 8) GO TO 3750 NBE = .FALSE. NRT = .FALSE. IF (.NOT. (PRON .AND. ELPR)) GO TO 5000 IF (JA .NE. 0 .OR. NUNC .EQ. 0) GO TO 5000 IF (SUPP) GO TO 3710 LABUPD = BLANK IF (JA .EQ. 0 .AND. KA .EQ. 1) LABUPD = 'R' IF (JA .EQ. 0 .AND. KA .EQ. 2) LABUPD = 'R2' WRITE (NOUT,9370) NUM, LABOUT, LABUPD GO TO 5000 C 3710 WRITE (NOUT,9370) NUM, LABOUT GO TO 5000 C 3750 IF (RORC .GE. 3 .AND. LFM .GE. 2) GO TO 5000 LABMIS = LABEL(NMIS)(1:10) IF (PRON .AND. ELPR) WRITE (NOUT,9372) NUM, LABMIS GO TO 5000 C C 38. -- PLOTTING C 3800 NBE = .FALSE. IF (NPASS .EQ. 2) THEN IF ((LPLOT .AND. .NOT. PLNOW) .OR. 1 (NPLT .EQ. 2 .AND. EPLOT(1) .AND. EPLOT(2)) .OR. 2 (NSTEPP .EQ. 1 .AND. NSTEPS .GT. 1)) THEN DO 3810 J = 1, NPLT JCON = JPLOT(J) KCON = KPLOT(J) CALL NAME10 HPLOT(J) = FTNAME 3810 CONTINUE WRITE (NPLOT,9380) (HPLOT(J), J = 1, NPLT) ENDIF IF (PLNOW) CALL PLOTIT ENDIF GO TO 5000 C C 41. -- ELECTROSTATIC SEPTUM C 4100 IF (.NOT. (PRON .AND. ELPR)) GO TO 5000 IF (TYPEC .EQ. 20) GO TO 4160 C 4110 IF (SUPP) GO TO 4165 LOUT = L/UNITO(8) C 4130 IE = IPTOJ(4) IF (IE .NE. 0) GO TO 4140 VNORM = VOLTS/UNITO(14) APOUT = AP/UNITO(1) WRITE (NOUT,9410) NUM, LABOUT, LOUT, XDIME(8), VNORM, XDIME(14), 1 APOUT, XDIME(1) GO TO 5000 C 4140 ENORM = EFIELD*UNITO(1)/UNITO(14) WRITE (NOUT,9411) NUM, LABOUT, LOUT, XDIME(8), ENORM, XDIME(14), 1 XDIME(1) GO TO 5000 C 4160 THOUT = TH/UNITO(13) WRITE (NOUT,9200) NUM, BLANK, THOUT, XDIME(13) GO TO 5000 C 4165 WRITE (NOUT,9050) NUM, LABOUT GO TO 5000 C C 42. -- KICKER -- CORRECTOR FOR BOTH PLANES C 4200 IF (.NOT. (PRON .AND. ELPR)) GO TO 5000 IF (TYPEC .EQ. 20) GO TO 4260 IF (SUPP) GO TO 4250 LOUT = LBEND/UNITO(8) BNORM = B/UNITO(9) ALNORM = AL/UNITO(7) IF (L .EQ. 0.0 .AND. AL .NE. 0.0) GO TO 4210 WRITE (NOUT,9350) NUM, LABOUT, LOUT, XDIME(8), BNORM, XDIME(9), 1 ALNORM, XDIME(7) GO TO 5000 C 4210 WRITE (NOUT,9351) NUM, LABOUT, LOUT, XDIME(8), ALNORM, XDIME(7) GO TO 5000 C 4250 WRITE (NOUT,9350) NUM, LABOUT GO TO 5000 C 4260 IF (SUPP) GO TO 4265 THOUT = TH/UNITO(13) WRITE (NOUT,9200) NUM, BLANK, THOUT, XDIME(13) GO TO 5000 C 4265 WRITE (NOUT,9200) NUM, BLANK GO TO 5000 C C 43. -- REFERENCE COORDINATE SYSTEM SHIFT C 4300 NRT = .FALSE. IF (.NOT. (PRON .AND. ELPR)) GO TO 5000 IF (.NOT. SUPP) THEN DO 4310 J = 1, 6 4310 CODO(J) = COD(J)/UNITO(J) WRITE (NOUT,9430) NUM, LABOUT, (CODO(J), XDIME(J), J = 1, 6) ELSE WRITE (NOUT,9430) NUM, LABOUT ENDIF GO TO 5000 C C 45. -- NEUTRINO HORN C 4500 IF (PRON .AND. ELPR) THEN IF (.NOT. SUPP) THEN LOUT = L/UNITO(8) WRITE (NOUT,9450) NUM, LABOUT, LOUT, XDIME(8) ELSE WRITE (NOUT,9450) NUM, LABOUT ENDIF ENDIF GO TO 5000 C C 46. -- HMONITOR C 4600 IF (PRON .AND. ELPR) THEN IF (.NOT. SUPP) THEN LOUT = L/UNITO(8) WRITE (NOUT,9460) NUM, LABOUT, LOUT, XDIME(8) ELSE WRITE (NOUT,9460) NUM, LABOUT ENDIF ENDIF GO TO 5000 C C 47. -- VMONITOR C 4700 IF (PRON .AND. ELPR) THEN IF (.NOT. SUPP) THEN LOUT = L/UNITO(8) WRITE (NOUT,9470) NUM, LABOUT, LOUT, XDIME(8) ELSE WRITE (NOUT,9470) NUM, LABOUT ENDIF ENDIF GO TO 5000 C C 48. -- MONITOR C 4800 IF (PRON .AND. ELPR) THEN IF (.NOT. SUPP) THEN LOUT = L/UNITO(8) WRITE (NOUT,9480) NUM, LABOUT, LOUT, XDIME(8) ELSE WRITE (NOUT,9480) NUM, LABOUT ENDIF ENDIF GO TO 5000 C C RETURN C 5000 RETURN C 9010 FORMAT (2H (,I4,')',2X,'*BEAM*',9X,A8,F13.5,1X,A3,'/C') 9011 FORMAT (2H (,I4,')',2X,'*ADD TO BEAM*',2X,A8,F13.5,1X,A3,'/C') 9020 FORMAT (2H (,I4,')',2X,'*ROTAT*',8X,A8,3(F13.5,1X,A4), 1 '**-1') 9021 FORMAT (43X,'FORM FACTORS',3F13.5) 9030 FORMAT (2H (,I4,')',2X,'*DRIFT*',8X,A8,F13.5,1X,A4) 9040 FORMAT (2H (,I4,')',2X,'*',A5,'*',8X,A8,2(F13.5,1X,A4), 1 F13.5,5X,' (',F10.3,1X,A4,',',F10.5,1X,A4,')') 9041 FORMAT (2H (,I4,')',2X,'*',A5,'*',8X,A8,2(F13.5,1X,A4), 1 E13.5,1X,A4,'**-2',5X,' (',F10.3,1X,A4,',', 2 F10.5,1X,A4,')') 9042 FORMAT (2H (,I4,')',2X,'*',A5,'*',8X,A8,F13.5,1X,A4, F13.5, 1 5X,' (',F10.3,1X,A4,',',F10.5,1X,A4,')') 9043 FORMAT (2H (,I4,')',2X,'*',A5,'*',8X,A8,F13.5,1X,A4,E13.5, 1 1X,A4,'**-2',5X,' (',F10.3,1X,A4,1H,,F10.5,1X,A4,1H)) 9044 FORMAT (2H (,I4,')',2X,'*',A5,'*',8X,A8,2(F13.5,1X,A4), 1 F13.5,5X,' (',7X,'BIG',5X,',',F10.5,1X,A4,')') 9050 FORMAT (2H (,I4,')',2X,'*QUAD*',9X,A8,3(F13.5,1X,A4),' (', 1 A11,1X,A4,')') 9051 FORMAT (2H (,I4,')',2X,'*QUAD*',9X,A8,F13.5,1X,A4,F13.5,1X, 1 A4,1H/,A4,13X,2H (,A11,1X,A4,1H)) 9052 FORMAT (2H (,I4,')',2X,'*QUAD*',9X,A8,F13.5,1X,A4,F13.5,1X, 1 A4,4H**-2,14X,2H (,A11,1X,A4,1H)) 9053 FORMAT (F11.5) 9054 FORMAT (E11.5) 9060 FORMAT (2H (,I4,')',2X,'*UPDATE*',7X,A8,5X,A4) 9061 FORMAT (2H (,I4,')',2X,'*SLIT*',9X,A8,I8,'.',F13.5,1X,A4) 9062 FORMAT (2H (,I4,')',2X,'*ENTER ALIGN*',2X,A8) 9070 FORMAT (2H (,I4,')',2X,'*CENT SHIFT*',3X,A8/7X, 1 6(F13.5,1X,A4)) 9080 FORMAT (2H (,I4,')',2X,'*ALIGN*',8X,A8/7X, 1 6(F12.5,1X,A4),4X,A20) 9081 FORMAT (2H (,I4,')',2X,'*EXIT ALIGN*',3X,A8/7X, 1 6(F12.5,1X,A4),4X,A20) 9100 FORMAT (2H (,I4,')',2X,A10,5X,A8,5X,A8, 1 A14,2H /,A7,8X,'(',A12,' )') 9101 FORMAT (' (',I4,')',2X,A10,5X,A8,5X,A8, 1 A14,' /',A7,8X,'( (PI/2.0)*ACOS(',A9,') )') 9102 FORMAT (2H (,I4,')',2X,A10,5X,A8,5X,A8, 1 A14,2H /,A7,/,46X,'(',A12,' )') 9103 FORMAT (' (',I4,')',2X,A10,5X,A8,5X,A8, 1 A14,' /',A7,/,46X,'( (PI/2.0)*ACOS(',A9,') )') 9104 FORMAT (F12.5) 9105 FORMAT (E12.3) 9106 FORMAT (F9.5) 9107 FORMAT (F14.5) 9108 FORMAT (E14.5) 9109 FORMAT (F7.5) 9110 FORMAT (2H (,I4,')',2X,'*ACCEL*',8X,A8,F13.5,1X,A4, 1 F13.5,5X,'(',F11.5,2H) ,A4,F13.5,F18.5) 9111 FORMAT (E7.2) 9112 FORMAT (2H (,I4,')',2X,A10,5X,A8,5X,A8, 1 A14,2H /,A7,/,46X,'(',A12,1X,'+-',1X,A12,' )') 9113 FORMAT (2H (,I4,')',2X,A10,5X,A8,5X,A8, 1 A14,2H /,A7,8X,'(',A12,1X,'+-',1x,A12,' )') 9120 FORMAT (2H (,I4,')',2X,'*CORRELATIONS*',1X,A8) 9130 FORMAT (2H (,I4,')',2X,'*REALIGN*',6X,A8) 9131 FORMAT (2H (,I4,')',2X,'*LEVEL COORDS*',2X,A8) 9140 FORMAT (2H (,I4,')',2X,'*MATRIX*',7X,A8,' ROW',I4,'.') 9141 FORMAT (2H (,I4,')',2X,'*MATRIX*',7X,A8,' ROW',I4,'.', 1 ' + 2ND ORDER TERMS') 9142 FORMAT (2H (,I4,')',2X,'*MATRIX*',7X,A8,' ROW',I4,'.', 1 ' + 2ND AND 3RD ORDER TERMS') 9160 FORMAT (2H (,I4,')',2X,1H*,A6,1H*,7X,A8,4X,E13.5) 9161 FORMAT (2H (,I4,')',2X,1H*,A6,1H*,7X,A8,3X,A16) 9162 FORMAT (4I4) 9170 FORMAT (2H (,I4,')',2X,'*1ST ORDER*',4X,A8,31X, 1 I5,'.',I5,1H.) 9171 FORMAT (2H (,I4,')',2X,'*2ND ORDER*',4X,A8,10X, 1 'GAUSSIAN DISTRIBUTION',I5,'.',I5,1H.) 9172 FORMAT (2H (,I4,')',2X,'*3RD ORDER*',4X,A8,10X, 1 'GAUSSIAN DISTRIBUTION',I5,'.',I5,1H.) 9180 FORMAT (2H (,I4,')',2X,'*SEXT*',9X,A8,3(F13.5,1X,A4)) 9181 FORMAT (2H (,I4,')',2X,'*SEXT*',9X,A8,F13.5,1X,A4, 1 F13.5,1X,A4,'**-3') 9190 FORMAT (2H (,I4,')',2X,'*SOLE*',9X,A8,2(F13.5,1X,A4), 1 2H (,F11.5,1X,A4,1H,,F13.5,1X,A4,1H)) 9191 FORMAT (2H (,I4,')',2X,'*SOLE*',9X,A8,F13.5,1X,A4, 1 F13.5,' DEG') 9200 FORMAT (2H (,I4,')',2X,'*SROT*',9X,A8,F13.5,1X,A4) 9210 FORMAT (2H (,I4,')',2X,'*E21*',10X,A8,F13.0,2F18.5) 9250 FORMAT (2H (,I4,')',2X,'*OCT*',10X,A8,3(F13.5,1X,A4)) 9251 FORMAT (2H (,I4,')',2X,'*OCT*',10X,A8,F13.5,1X,A4, 1 E13.5,1X,A4,'**-4') 9270 FORMAT (2H (,I4,')',2X,'*ETA*',10X,A8/7X, 1 6(F12.5,1X,A4)) 9271 FORMAT (2H (,I4,')',2X,'*RAY*',11X,A8/7X, 1 6(F12.5,1X,A4)) 9281 FORMAT (2H (,I4,')',2X,'* *',8X,A8,3(F13.5,1X,A4), 1 '**-1') 9300 FORMAT (2H (,I4,')',2X,'*PARAM*',8X,A8,4X,E16.8) 9310 FORMAT (2H (,I4,')',2X,'*MARKER*',7X,A8) 9330 FORMAT (2H (,I4,')',2X,'*STORE*',8X,A8,4X,E13.5) 9340 FORMAT (2H (,I4,')',2X,'*PLASMA LENS*',2X,A8,3(F13.5,1X,A4) 1 ,2H (,F11.5,1X,A4,1H)) 9341 FORMAT (2H (,I4,')',2X,'*PLASMA LENS*',2X,A8,F13.5,1X,A4, 1 F13.5,1X,A4,1H/,A4,13X,2H (,F11.5,1X,A4,1H)) 9342 FORMAT (2H (,I4,')',2X,'*PLASMA LENS*',2X,A8,F13.5,1X,A4, 1 F13.5,1X,A4,4H**-2,14X,2H (,F11.5,1X,A4,1H)) 9343 FORMAT (2H (,I4,')',2X,'*PLASMA LENS*',2X,A8,F13.5,1X,A4, 1 E13.5,1X,A4,4H**-2,14X,2H (,F11.5,1X,A4,1H)) 9350 FORMAT (2H (,I4,')',2X,'*HKICK*',8X,A8,2(F13.5,1X,A4), 1 2H (,F11.5,1X,A4,1H)) 9351 FORMAT (2H (,I4,')',2X,'*HKICK*',8X,A8,F13.5,1X,A4,18X, 1 2H (,F11.5,1X,A4,1H)) 9360 FORMAT (2H (,I4,')',2X,'*VKICK*',8X,A8,2(F13.5,1X,A4), 1 2H (,F11.5,1X,A4,1H)) 9361 FORMAT (2H (,I4,')',2X,'*VKICK*',8X,A8,F13.5,1X,A4,18X, 1 2H (,F11.5,1X,A4,1H)) 9370 FORMAT (2H (,I4,')',2X,'*ALMARK*',7X,A8,5X,A4) 9372 FORMAT (2H (,I4,')',2X,'*ENTER ALIGN*',2X,A8) 9380 FORMAT (8A10) 9410 FORMAT (2H (,I4,')',2X,'*SEPTUM*',7X,A8,3(F13.5,1X,A4)) 9411 FORMAT (2H (,I4,')',2X,'*SEPTUM*',7X,A8,F13.5,1X,A4,F13.5,1X, 1 A4,1H/,A4) 9430 FORMAT (2H (,I4,')',2X,'*SHIFT*',8X,A8/7X, 1 6(F13.5,1X,A4)) 9450 FORMAT (2H (,I4,')',2X,'*NEUTRINO HORN*',A8,F13.5,1X,A4) 9460 FORMAT (2H (,I4,')',2X,'*HMONITOR*',5X,A8,F13.5,1X,A4) 9470 FORMAT (2H (,I4,')',2X,'*VMONITOR*',5X,A8,F13.5,1X,A4) 9480 FORMAT (2H (,I4,')',2X,'*MONITOR*',6X,A8,F13.5,1X,A4) END SUBROUTINE PUNCH1 C C PUNCHES FIRST-ORDER TRANSFER MATRICES ONTO "CARDS" C C ---------------------------------------------------------------------- INCLUDE 'ELM15C.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'IOUNIT.CIN' INCLUDE 'RS.CIN' C C LOCAL VARIABLES C INTEGER J, K REAL OUTPUT(30) C --------------------------------------------------------------------- C C CALCULATE TRANSFER MATRICES C CALL RCALC C C PUNCH FIRST ORDER MATRIX C DO 2 J = 1, 6 DO 1 K = 1, 6 OUTPUT(K) = RS(J,K)*UBEAM(K)/UBEAM(J) 1 CONTINUE WRITE (NPUNCH,1003) J, (OUTPUT(K), K = 1, 6) 1003 FORMAT (7H FIRST, I5, 6(1PE11.3)) 2 CONTINUE C C PUNCH SECOND ORDER MATRIX ELEMENTS C IF (NORD3 .GE. 2) CALL PUNCH2 RETURN END SUBROUTINE PUNCH2 C C PUNCHES SECOND-ORDER TRANSFER MATRIX ELEMENTS ONTO "CARDS" C C ---------------------------------------------------------------------- INCLUDE 'ELM13A.CIN' INCLUDE 'ELM15C.CIN' INCLUDE 'IOUNIT.CIN' INCLUDE 'TS.CIN' C C LOCAL VARIABLES C REAL OUTPUT(30) C --------------------------------------------------------------------- C IF (CDB .LT. 31) GO TO 13 N = CDB - 30 GO TO 20 13 N = 0 14 N = N + 1 20 JK = 0 DO 22 J = 1, 6 DO 21 K = 1, J JK = JK + 1 OUTPUT(K) = TS(N,JK)*UBEAM(J)*UBEAM(K)/UBEAM(N) 21 CONTINUE WRITE (NPUNCH,1009) N, J, (OUTPUT(K), K = 1, J) 1009 FORMAT (7H SECOND, I3, I2,6(1PE11.3)) 22 CONTINUE IF (CDB .GT. 30) GO TO 31 IF (CDB .NE. 30) GO TO 30 IF (N .GE. 5) GO TO 31 GO TO 14 30 IF (N .EQ. 3) GO TO 31 N = 3 GO TO 20 31 RETURN END SUBROUTINE QEO C C PRINTING OF BEAM MATRIX AND ACCUMULATED LENGTH C C ---------------------------------------------------------------------- INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'COP.CIN' INCLUDE 'ELM0B.CIN' INCLUDE 'ELM1C.CIN' INCLUDE 'ELM1D.CIN' INCLUDE 'ELM7C.CIN' INCLUDE 'ELM13B.CIN' INCLUDE 'ELM13C.CIN' INCLUDE 'ELM15B.CIN' INCLUDE 'ELM15C.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'IOUNIT.CIN' C C LOCAL VARIABLES C CHARACTER*8 LSIUN INTEGER J, JMIN1, K LOGICAL UBIG, CDONE REAL ALONG, CENUN, CORR, DEN, SIUN REAL OUTPUT(10), SIO(6) C --------------------------------------------------------------------- C C CUMULATIVE LENGTH C ALONG = LC/UFLOOR(1) C C BEAM SIZE C IF (.NOT. RECENT) CALL BEAM UBIG = UBEAM(1) .GT. 0.5 .AND. UBEAM(2) .GT. 0.5 IF (NORD3 .GE. 1) THEN DO 10 J = 1, 6 SIO(J) = SQRT(SIT(J,J)) 10 CONTINUE ENDIF C C PRINT BEAM PARAMETERS C IF (TERSE) GO TO 100 CENUN = CEN(1)/UBEAM(1) SIUN = 0.0 IF (NORD3 .GE. 1) SIUN = SIO(1)/UBEAM(1) IF (SIUN .LT. 10000.0) THEN WRITE (LSIUN,1020) SIUN 1020 FORMAT (F8.3) ELSE WRITE (LSIUN,1021) SIUN 1021 FORMAT (E8.2) ENDIF IF (LCPR) THEN IF (NARROW) THEN WRITE (NOUT,1023) CENUN, LSIUN, XBEAM(1) 1023 FORMAT (1H ,17X,F12.3,A8,1X,A4) ELSE WRITE (NOUT,1015) CENUN, LSIUN, XBEAM(1) 1015 FORMAT (1H ,67X,F12.3,A8,1X,A4) ENDIF ELSE IF (NARROW) THEN WRITE (NOUT,1024) ALONG, XFLOOR(1), CENUN, LSIUN, XBEAM(1) 1024 FORMAT (1H ,8X,F10.3,1X,A4,/,18X,F12.3,A8,1X,A4) ELSE WRITE (NOUT,1016) ALONG, XFLOOR(1), CENUN, LSIUN, XBEAM(1) 1016 FORMAT (1H ,8X,F10.3,1X,A4,44X,F12.3,A8,1X,A4) ENDIF ENDIF C 30 DO 40 J = 2, 6 JMIN1 = J - 1 CENUN = CEN(J)/UBEAM(J) SIUN = 0.0 IF (NORD3 .GE. 1) SIUN = SIO(J)/UBEAM(J) IF (SIUN .LT. 10000.0) THEN WRITE (LSIUN,1020) SIUN ELSE WRITE (LSIUN,1021) SIUN ENDIF DO 35 K = 1, JMIN1 CORR = 0.0 IF (NORD3 .GE. 1) CORR = SIT(J,K)/DEN(SIO(J)*SIO(K)) OUTPUT(K) = CORR 35 CONTINUE IF (NARROW) THEN WRITE (NOUT,1022) 1 CENUN, LSIUN, XBEAM(J), (OUTPUT(K), K = 1, JMIN1) ELSE WRITE (NOUT,1014) 1 CENUN, LSIUN, XBEAM(J), (OUTPUT(K), K = 1, JMIN1) ENDIF 40 CONTINUE 1022 FORMAT (18X,F12.3,A8,1X,A4,F9.3,4F7.3) 1014 FORMAT (68X,F12.3,A8,1X,A4,F9.3,4F7.3) GO TO 300 C C SINGLE LINE OUTPUT C 100 CDONE = .FALSE. IF (.NOT. NOPH .AND. NORD3 .GE. 1 .AND. .NOT. SOFA 1 .AND. .NOT. CPS) GO TO 120 IF (.NOT. CPR .AND. CPS) GO TO 120 CDONE = .TRUE. DO 110 J = 1, 6 OUTPUT(J) = CEN(J)/UBEAM(J) 110 CONTINUE IF (.NOT. LCPR .AND. .NOT. UBIG) THEN WRITE (NOUT,1013) ALONG, XFLOOR(1), 1 (OUTPUT(J), XBEAM(J), J = 1, 6) ELSE IF (.NOT. LCPR .AND. UBIG) THEN WRITE (NOUT,1018) ALONG, XFLOOR(1), 1 (OUTPUT(J), XBEAM(J), J = 1, 6) ELSE IF (LCPR .AND. .NOT. UBIG) THEN WRITE (NOUT,1017) (OUTPUT(J), XBEAM(J), J = 1, 6) ELSE IF (LCPR .AND. UBIG) THEN WRITE (NOUT,1019) (OUTPUT(J), XBEAM(J), J = 1, 6) ENDIF 1013 FORMAT (1H ,8X,F10.3,1X,A4,11X,6(F8.3,1X,A4),1X,2F9.3) 1018 FORMAT (1H ,8X,F10.3,1X,A4,5X,6(F9.6,1X,A4),1X,2F9.3) 1017 FORMAT (1H ,34X,6(F8.3,1X,A4),1X,2F9.3) 1019 FORMAT (1H ,28X,6(F9.6,1X,A4),1X,2F9.3) LCPR = .TRUE. C 120 IF (NOPH .OR. NORD3 .LT. 1) GO TO 300 DO 130 J = 1, 6 OUTPUT(J) = SIO(J)/UBEAM(J) 130 CONTINUE OUTPUT(7) = SIT(1,2)/DEN(SIO(1)*SIO(2)) OUTPUT(8) = SIT(3,4)/DEN(SIO(3)*SIO(4)) C IF (CDONE) THEN IF (.NOT. UBIG) THEN WRITE (NOUT,1012) (OUTPUT(J), J = 1, 8) 1012 FORMAT (1H ,34X,6(F8.3,5X),1X,2F9.3) ELSE WRITE (NOUT,1011) (OUTPUT(J), J = 1, 8) 1011 FORMAT (1H ,28X,6(F9.6,5X),1X,2F9.3) ENDIF C ELSE IF (.NOT. LCPR .AND. .NOT. UBIG) THEN WRITE (NOUT,1013) ALONG, XFLOOR(1), 1 (OUTPUT(J), XBEAM(J), J=1, 6), 2 OUTPUT(7), OUTPUT(8) ELSE IF (.NOT. LCPR .AND. UBIG) THEN WRITE (NOUT,1018) ALONG, XFLOOR(1), 1 (OUTPUT(J), XBEAM(J), J=1, 6), 2 OUTPUT(7), OUTPUT(8) ELSE IF (LCPR .AND. .NOT. UBIG) THEN WRITE (NOUT,1017) (OUTPUT(J), XBEAM(J), J = 1, 6), 1 OUTPUT(7), OUTPUT(8) ELSE WRITE (NOUT,1019) (OUTPUT(J), XBEAM(J), J = 1, 6), 1 OUTPUT(7), OUTPUT(8) ENDIF ENDIF C 300 LCPR = .TRUE. BDUN = .TRUE. RETURN END SUBROUTINE R2TORS C C TRANSFERS MATRIX R2 TO RS C C ---------------------------------------------------------------------- INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'RC2.CIN' INCLUDE 'RS.CIN' INCLUDE 'TC2.CIN' INCLUDE 'TS.CIN' INCLUDE 'UC2.CIN' INCLUDE 'US.CIN' C C LOCAL VARIABLES C INTEGER JK, JKM, JKLM C----------------------------------------------------------------------- C DO 10 JK = 1, 36 10 RSL(JK) = RC2L(JK) IF (NORD2 .GE. 2) THEN DO 20 JKM = 1, 105 20 TSL(JKM) = TC2L(JKM) ENDIF IF (NORD2 .GE. 3) THEN DO 30 JKLM = 1, 280 30 USL(JKLM) = UC2L(JKLM) ENDIF RETURN END SUBROUTINE RBFGET C C PARAMETERS FOR FRINGING FIELD OF RBEND AND SBEND C C ---------------------------------------------------------------------- INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM2A.CIN' INCLUDE 'ELM2B.CIN' INCLUDE 'ELM2C.CIN' INCLUDE 'ELM4A.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'ELM16A.CIN' INCLUDE 'ELM26B.CIN' INCLUDE 'INDBND.CIN' INCLUDE 'INDFF.CIN' INCLUDE 'INDPAR.CIN' INCLUDE 'XRAN.CIN' C C LOCAL VARIABLES C INTEGER IADR, IAPB, IBE, ILAYL, IRAB REAL DATAR C------------------------------------------------------------------------------ C C INDICES FOR PARAMETERS C NE1 = 12 NE2 = 13 NH1 = 18 NH2 = 19 IF ((BEFORE .AND. NDIF .EQ. 1) 1 .OR. (.NOT. BEFORE .AND. NDIF .NE. 1)) THEN NBETA = NE1 NRAB = NH1 ELSE IF ((BEFORE .AND. NDIF .NE. 1) 1 .OR. (.NOT. BEFORE .AND. NDIF .EQ. 1)) THEN NBETA = NE2 NRAB = NH2 ENDIF NAPB = 22 NLAYL = 23 C C POLE FACE ROTATION ANGLE C IBE = IPTOJ(NBETA) IF (IBE .EQ. 0) THEN IF (TYPE .EQ. 28) BE = 0.5*AL IF (TYPE .EQ. 29) BE = 0.0 IF (PRAN28(NBETA) .NE. 0.0) 1 BE = BE + PRAN28(NBETA)*XRAN(NBETA)*UNITI(7) ELSE IADR = I + IBE BE = DATAR(IADR) IF (PRAN28(NBETA) .NE. 0.0) 1 BE = BE + PRAN28(NBETA)*XRAN(NBETA) BE = BE*UNITI(7) ENDIF IF (BEFORE) THEN BE1 = BE ELSE BE2 = BE ENDIF C C POLE FACE CURVATURE C IRAB = IPTOJ(NRAB) IF (IRAB .NE. 0) THEN IADR = I + IRAB RABT = DATAR(IADR) ENDIF IF (IRAB .EQ. 0) THEN IF (BEFORE) THEN RABT = RAB1I ELSE RABT = RAB2I ENDIF ENDIF IF (PRAN28(NRAB) .NE. 0.0) 1 RABT = RABT + PRAN28(NRAB)*XRAN(NRAB) RABT = RABT/UNITI(8) IF (BEFORE) THEN RAB1 = RABT ELSE RAB2 = RABT ENDIF C C MAGNET APERTURE C IAPB = IPTOJ(NAPB) IF (IAPB .EQ. 0) THEN APB(2) = APBI(2) ELSE IADR = I + IAPB APB(2) = DATAR(IADR) ENDIF IF (PRAN28(NAPB) .NE. 0.0) 1 APB(2) = APB(2) + PRAN28(NAPB)*XRAN(NAPB) APB(2) = APB(2)*UNITI(3) C C FRINGE FIELD INTEGRAL C LAYK = LAYKI C ILAYL = IPTOJ(NLAYL) IF (ILAYL .EQ. 0) THEN LAYL = LAYLI ELSE IADR = I + ILAYL LAYL = DATAR(IADR) ENDIF IF (PRAN28(NLAYL) .NE. 0.0) 1 LAYL = LAYL + PRAN28(NLAYL)*XRAN(NLAYL) C LAYX = LAYXI C RETURN END SUBROUTINE RBGET C C PARAMETERS FOR THE CENTRAL FIELD OF RBEND AND SBEND C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA0B.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM1A.CIN' INCLUDE 'ELM2D.CIN' INCLUDE 'ELM4A.CIN' INCLUDE 'ELM4B.CIN' INCLUDE 'ELM4C.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'ELM16A.CIN' INCLUDE 'ELM16B.CIN' INCLUDE 'ELM26B.CIN' INCLUDE 'ELM28.CIN' INCLUDE 'INDBND.CIN' INCLUDE 'INDPAR.CIN' INCLUDE 'XRAN.CIN' C C----------------------------------------------------------------------------- C C INDICES FOR PARAMETERS C NL = 1 NBV = 2 NRHO = 3 NANG = 4 NN = 5 NK1 = 6 NRMPS = 7 C IL = IPTOJ(NL) IB = IPTOJ(NBV) IRHO = IPTOJ(NRHO) IANG = IPTOJ(NANG) C C MAGNET LENGTH C IF (IL .EQ. 0) GO TO 25 IADR = I + IL LBEND = DATAR(IADR) IF (PRAN28(NL) .NE. 0.0) LBEND = LBEND + PRAN28(NL)*XRAN(NL) LBEND = LBEND*UNITI(8) IF (TYPE .EQ. 28) LRBEND = LBEND C C MAGNET LENGTH AND FIELD C IF (IB .EQ. 0) GO TO 15 IADR = I + IB B = DATAR(IADR) IF (PRAN28(NBV) .NE. 0.0) B = B + PRAN28(NBV)*XRAN(NBV) B = B*UNITI(9)*RI/PREF H0 = B/RI RHO = 0.0 IF (H0 .NE. 0.0) RHO = 1.0/H0 IF (TYPE .EQ. 28 .AND. H0 .NE. 0.0) THEN AL = 2.0*ASIN(LBEND/(2.0*RHO)) LBEND = RHO*AL ELSE AL = H0*LBEND ENDIF GO TO 35 C C MAGNET LENGTH AND RADIUS OF CURVATURE C 15 IF (IRHO .EQ. 0) GO TO 20 IADR = I + IRHO RHO = DATAR(I+IRHO) IF (PRAN28(NRHO) .NE. 0.0) RHO = RHO + PRAN28(NRHO)*XRAN(NRHO) RHO = RHO*UNITI(8) H0 = 1.0/RHO IF (RI .NE. 0.0) B = H0*RI IF (TYPE .EQ. 28) THEN AL = 2.0*ASIN(LBEND/(2.0*RHO)) LBEND = RHO*AL ELSE AL = H0*LBEND ENDIF GO TO 35 C C MAGNET LENGTH AND ANGLE C 20 IADR = I + IANG AL = DATAR(IADR) IF (PRAN28(NANG) .NE. 0.0) AL = AL + PRAN28(NANG)*XRAN(NANG) AL = AL*UNITI(7) IF (TYPE .EQ. 28) THEN H0 = 2.0*SIN(0.5*AL)/LBEND IF (H0 .NE. 0) THEN LBEND = AL/H0 ENDIF ELSE H0 = AL/LBEND ENDIF B = RI*H0 GO TO 35 C C MAGNETIC FIELD AND BEND ANGLE C 25 IF (IB .EQ. 0) GO TO 30 IADR = I + IB B = DATAR(IADR) IF (PRAN28(NBV) .NE. 0.0) B = B + PRAN28(NBV)*XRAN(NBV) B = B*UNITI(9)*RI/PREF IADR = I + IANG AL = DATAR(IADR) IF (PRAN28(NANG) .NE. 0.0) AL = AL + PRAN28(NANG)*XRAN(NANG) AL = AL*UNITI(7) H0 = B/RI IF (H0 .NE. 0.0) RHO = 1.0/H0 LBEND = RHO*AL LRBEND = 2.0*RHO*SIN(0.5*AL) GO TO 35 C C RADIUS OF CURVATURE AND BEND ANGLE C 30 IADR = I + IRHO RHO = DATAR(IADR) IF (PRAN28(NRHO) .NE. 0.0) RHO = RHO + PRAN28(NRHO)*XRAN(NRHO) RHO = RHO*UNITI(8) IADR = I + IANG AL = DATAR(IADR) IF (PRAN28(NANG) .NE. 0.0) AL = AL + PRAN28(NANG)*XRAN(NANG) AL = AL*UNITI(7) LBEND = RHO*AL IF (RI .NE. 0.0) B = RI/RHO H0 = 1.0/RHO LRBEND = 2.0*RHO*SIN(0.5*AL) C C FRACTIONAL FIELD EXCESS C 35 IRMPS = IPTOJ(NRMPS) IF (IRMPS .NE. 0) THEN IADR = I + IRMPS RMPS = DATAR(IADR) ELSE RMPS = RMPSI ENDIF IF (PRAN28(NRMPS) .NE. 0.0) 1 RMPS = RMPS + PRAN28(NRMPS)*XRAN(NRMPS) RH = 1.0 + RMPS H = RH*H0 C C NORMALIZED FIELD GRADIENT C NB = 0.0 IN = IPTOJ(NN) IK1 = IPTOJ(NK1) IF (IK1 .EQ. 0 .AND. PRAN28(NK1) .EQ. 0.0) THEN IF (IN .EQ. 0) THEN NB = 0.0 ELSE IADR = I + IN NB = DATAR(IADR) ENDIF IF (PRAN28(NN) .NE. 0.0) NB = NB + PRAN28(NN)*XRAN(NN) ELSE IF (IK1 .EQ. 0) THEN K1 = 0.0 ELSE IADR = I + IK1 K1 = DATAR(IADR) ENDIF IF (PRAN28(NK1) .NE. 0.0) K1 = K1 + PRAN28(NK1)*XRAN(NK1) K1 = K1/UNITI(8)**2 IF (H0 .NE. 0.0) NB = - K1/H0**2 ENDIF C C VARY CODE FOR CENTRAL FIELD C IBVARY = I + IB 50 NBVARY = TIE(IBVARY) IF (NBVARY .EQ. 100) THEN IBVARY = IDATA(IBVARY) GO TO 50 ENDIF C IT = IPTOJ(25) IF (IT .EQ. 0) THEN NUMTYP = IT ELSE NUMTYP = IDATA(I + IT) ENDIF RETURN END SUBROUTINE RBVGET C C HIGHER-ORDER AND NON-MIDPLANE-SYMMETRIC COMPONENTS FOR C CENTRAL FIELD OF RBEND AND SBEND C C ---------------------------------------------------------------------- INCLUDE 'DATA2A.CIN' INCLUDE 'ELM4A.CIN' INCLUDE 'ELM4C.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'ELM16A.CIN' INCLUDE 'ELM26B.CIN' INCLUDE 'INDBND.CIN' INCLUDE 'INDPAR.CIN' INCLUDE 'XRAN.CIN' C C LOCAL VARIABLES C INTEGER IADR, IBDB, IBDBP, IGAM, IK1P, IK2, IK2P, IK3 INTEGER INP, IRNMS, IVR REAL DATAR C------------------------------------------------------------------------------- C C INDICES FOR PARAMETERS C NRNMS = 8 NVR = 9 NNP = 10 NK1P = 11 NBDB = 14 NK2 = 15 NBDBP = 16 NK2P = 17 NGAM = 20 NK3 = 21 C C NORMALIZED VERTICAL BEND C IVR = IPTOJ(NVR) IF (IVR .NE. 0) THEN IADR = I + IVR VRN = DATAR(IADR) ELSE VRN = VRNI ENDIF IF (PRAN28(NVR) .NE. 0.0) 1 VRN = VRN + PRAN28(NVR)*XRAN(NVR) C C NORMALIZED NON-MIDPLANE-SYMMETRIC GRADIENT C INP = IPTOJ(NNP) IK1P = IPTOJ(NK1P) IF (IK1P .EQ. 0 .AND. PRAN28(NK1P) .EQ. 0.0) THEN IF (INP .EQ. 0) THEN NPN = NPNI ELSE IADR = I + INP NPN = DATAR(IADR) ENDIF IF (PRAN28(NNP) .NE. 0.0) NPN = NPN + PRAN28(NNP)*XRAN(NNP) ELSE IF (IK1P .EQ. 0) THEN K1P = 0.0 ELSE IADR = I + IK1P K1P = DATAR(IADR) ENDIF IF (PRAN28(NK1P) .NE. 0.0) K1P = K1P + PRAN28(NK1P)*XRAN(NK1P) K1P = K1P/UNITI(8)**2 IF (H0 .NE. 0.0) NPN = - K1P/H0**2 ENDIF C C SCALING FACTOR FOR NON-MIDPLANE-SYMMETRIC COMPONENTS C IRNMS = IPTOJ(NRNMS) IF (IRNMS .NE. 0) THEN IADR = I + IRNMS RNMS = DATAR(IADR) ELSE RNMS = RNMSI ENDIF IF (PRAN28(NRNMS) .NE. 0.0) 1 RNMS = RNMS + PRAN28(NRNMS)*XRAN(NRNMS) C C NORMALIZED FIELD SECOND DERIVATIVE C IBDB = IPTOJ(NBDB) IK2 = IPTOJ(NK2) IF (IBDB .NE. 0) THEN IADR = I + IBDB BDB = DATAR(IADR) IF (PRAN28(NBDB) .NE. 0.0) BDB = BDB + PRAN28(NBDB)*XRAN(NBDB) ELSE IF (IK2 .NE. 0) THEN IADR = I + IK2 K2 = DATAR(IADR) IF (PRAN28(NK2) .NE. 0.0) 1 K2 = K2 + PRAN28(NK2)*XRAN(NK2) IF (MPMAD) K2 = 0.5*K2 K2 = K2/UNITI(8)**3 BDB = K2*UNITI(1)**2/H0 ELSE BDB = BDBI IF (PRAN28(NBDB) .NE. 0.0) BDB = BDB + PRAN28(NBDB)*XRAN(NBDB) ENDIF C C NORMALIZED NON-MIDPLANE-SYMMETRIC FIELD SECOND DERIVATIVE C IBDBP = IPTOJ(NBDBP) IK2P = IPTOJ(NK2P) IF (IK2P .EQ. 0 .AND. PRAN28(NK2P) .EQ. 0.0) THEN IF (IBDBP .EQ. 0) THEN BDBP = BDBPI ELSE IADR = I + IBDBP BDBP = DATAR(IADR) ENDIF IF (PRAN28(NBDBP) .NE. 0.0) 1 BDBP = BDBP + PRAN28(NBDBP)*XRAN(NBDBP) ELSE IF (IK2P .EQ. 0) THEN K2P = 0.0 ELSE IADR = I + IK2P K2P = DATAR(IADR) ENDIF IF (PRAN28(NK2P) .NE. 0.0) K2P = K2P + PRAN28(NK2P)*XRAN(NK2P) IF (MPMAD) K2P = 0.5*K2P K2P = K2P/UNITI(8)**3 IF (H0 .NE. 0.0) BDBP = K2P*UNITI(1)**2/H0 ENDIF C C NORMALIZED FIELD THIRD DERIVATIVE C IGAM = IPTOJ(NGAM) IK3 = IPTOJ(NK3) IF (IGAM .NE. 0) THEN IADR = I + IGAM GAM = DATAR(IADR) IF (PRAN28(IGAM) .NE. 0.0) GAM = GAM + PRAN28(IGAM)*XRAN(IGAM) ELSE IF (IK3 .NE. 0) THEN IADR = I + IK3 K3 = DATAR(IADR) IF (MPMAD) K3 = K3/6.0 K3 = K3/UNITI(8)**4 GAM = K3*UNITI(1)**3/H0 ELSE GAM = GAMI IF (PRAN28(NGAM) .NE. 0.0) GAM = GAM + PRAN28(NGAM)*XRAN(NGAM) ENDIF RETURN END SUBROUTINE RCALC C C CALCULATION OF TRANSFER MATRIX WHEN IT IS TO BE PRINTED C C ---------------------------------------------------------------------- INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM13A.CIN' INCLUDE 'RCP.CIN' INCLUDE 'R2P.CIN' C----------------------------------------------------------------------- C IF (CDB .EQ. 14) GO TO 260 IF (CDB .EQ. 24) GO TO 10 IF (RCP) GO TO 100 C C DESIRED MATRIX EQUALS R2 MATRIX C 10 CALL R2TORS IF (CDB .LT. 0) GO TO 300 GO TO 400 C C DESIRED MATRIX EQUALS RC MATRIX C 100 IF (R2P) GO TO 200 CALL RCTORS IF (CDB .LT. 0) GO TO 300 GO TO 400 C C DESIRED MATRIX EQUALS RC2 TIMES RC C 200 CALL MR2RC IF (CDB .LT. 0) GO TO 300 GO TO 400 C C DESIRED MATRIX EQUALS R MATRIX (INDIVIDUAL ELEMENT) C 260 CALL RTORS GO TO 400 C C FIND INVERSE MATRIX C 300 CALL RINV C 400 RETURN END SUBROUTINE RCOUT C C DIRECTS PRINTING OF TRANSFER MATRICES C C ---------------------------------------------------------------------- INCLUDE 'ELM0A.CIN' INCLUDE 'ELM0B.CIN' INCLUDE 'ELM13A.CIN' INCLUDE 'ELM13B.CIN' INCLUDE 'ELM13C.CIN' INCLUDE 'ELM15B.CIN' INCLUDE 'ELM15C.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'IOUNIT.CIN' C C LOCAL VARIABLES C REAL ALONG C---------------------------------------------------------------------------- C C ACCUMULATED LENGTH C IF (LCPR) GO TO 10 ALONG = LC/UFLOOR(1) IF (.NOT. TERSE) WRITE (NOUT,1007) ALONG, XFLOOR(1) 1007 FORMAT (1H ,8X,F10.3,1X,A4) C C DETERMINE TRANSFER MATRIX C 10 IF (NORD3 .GE. 1) CALL RCALC IF (TYPE .EQ. 13 .AND. CDB .EQ. 4 .AND. RAT) 1 GO TO 200 C C PRINT FIRST ORDER TRANSFER MATRIX C 110 CALL RCOUT1 C C PRINT SECOND ORDER TRANSFER MATRIX C 200 IF (NORD3 .GE. 2 .AND. 1 (CDB .EQ. 4 .OR. CDB .EQ. -4 .OR. CDB .EQ. 24 .OR. TERSE)) 2 CALL RCOUT2 IF (NORD3 .GE. 3 .AND. 1 (CDB .EQ. 4 .OR. CDB .EQ. -4 .OR. CDB .EQ. 24)) 1 CALL RCOUT3 C 400 LCPR = .TRUE. RETURN END SUBROUTINE RCOUT1 C C PRINTS FIRST-ORDER TRANSFER MATRIX C C ---------------------------------------------------------------------- INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'COCOM.CIN' INCLUDE 'COP.CIN' INCLUDE 'DATA1C.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0B.CIN' INCLUDE 'ELM13A.CIN' INCLUDE 'ELM13B.CIN' INCLUDE 'ELM13C.CIN' INCLUDE 'ELM15B.CIN' INCLUDE 'ELM15C.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'IOUNIT.CIN' INCLUDE 'RS.CIN' C C LOCAL VARIABLES C CHARACTER*1 BLANK CHARACTER*8 LABOUT INTEGER IROW(10), ICOL(10) REAL OUTPUT(10) DATA BLANK /' '/ DATA IROW /1,1,2,2,3,3,4,4,1,2/ DATA ICOL /1,2,1,2,3,4,3,4,6,6/ C--------------------------------------------------------------------- C IF (CDB .EQ. 6) THEN LABOUT = BLANK ELSE LABOUT = LABEL(NUM)(1:8) ENDIF C IF (TERSE) GO TO 150 NCOLS = 6 IF (CDB .EQ. 14) THEN WRITE (NOUT,1002) 1002 FORMAT (1H0,8X,'*ELEMENT MATRIX*') GO TO 110 ENDIF IF (CDB .EQ. 4 .OR. CDB .EQ. 6) NR = 1 IF (CDB .EQ. 24) NR = 2 IF (CDB .EQ. -4) NR = -1 IF (SOFA) THEN IF (NORD3 .LT. 1) NCOLS = 1 IF (NORD3 .GE. 1) NCOLS = 7 WRITE (NOUT,1008) NR, LABOUT ELSE WRITE (NOUT,1004) NR, LABOUT ENDIF 1004 FORMAT (1H ,8X,'*TRANSFORM',I2,1H*,2X,A8) 1008 FORMAT (1H ,8X,'*TRANSFORM',I2,1H*,2X,A8,65X,3HREF) C 110 DO 130 J = 1, 6 IF (SOFA) OUTPUT(NCOLS) = CO(J)/UBEAM(J) IF (NORD3 .LT. 1) THEN IF (NARROW) THEN WRITE (NOUT,1005) OUTPUT(1) ELSE WRITE (NOUT,1015) OUTPUT(1) ENDIF ELSE DO 125 K = 1, 6 OUTPUT(K) = RS(J,K)*UBEAM(K)/UBEAM(J) 125 CONTINUE IF (NARROW) THEN WRITE (NOUT,1006) (OUTPUT(K), K = 1, NCOLS) ELSE WRITE (NOUT,1003) (OUTPUT(K), K = 1, NCOLS) ENDIF ENDIF 130 CONTINUE 1005 FORMAT (66X,F13.5) 1015 FORMAT (86X,F15.5) 1006 FORMAT (F14.5,5F10.5,2X,F13.5) 1003 FORMAT (F21.5,5F10.5,15X,F15.5) GO TO 200 C C SINGLE LINE OUTPUT C 150 DO 160 J = 1, 10 IR = IROW(J) IC = ICOL(J) OUTPUT(J) = RS(IR,IC)*UBEAM(IC)/UBEAM(IR) 160 CONTINUE IF (.NOT. NARROW) THEN IF (.NOT. LCPR) THEN ALONG = LC/UFLOOR(1) WRITE (NOUT,1000) ALONG, XFLOOR(1), LABOUT, OUTPUT 1000 FORMAT (1H ,8X,F10.3,1X,A4,2X,A6,3X,4F9.4,4X,4F9.4,4X, 1 2F9.4) ELSE WRITE (NOUT,1001) LABOUT, OUTPUT 1001 FORMAT (1H ,25X,A6,3X,4F9.4,4X,4F9.4,4X,2F9.4) ENDIF ELSE IF (.NOT. LCPR) THEN ALONG = LC/UFLOOR(1) WRITE (NOUT,1007) ALONG, XFLOOR(1), LABOUT, OUTPUT(1), 1 OUTPUT(2), OUTPUT(5), OUTPUT(6), OUTPUT(9) 1007 FORMAT (1H ,8X,F10.3,1X,A4,2X,A6,3X,5F9.4) ELSE WRITE (NOUT,1009) OUTPUT(1), OUTPUT(2), OUTPUT(5), 1 OUTPUT(6), OUTPUT(9) 1009 FORMAT (1H ,25X,A6,3X,5F9.4) ENDIF ENDIF C 200 RETURN END SUBROUTINE RCOUT2 C C PRINTS SECOND-ORDER TRANSFER MATRIX C C ---------------------------------------------------------------------- INCLUDE 'ELM13B.CIN' INCLUDE 'ELM15C.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'IOUNIT.CIN' INCLUDE 'TS.CIN' C C LOCAL VARIABLES C INTEGER J, JK, K, K1, K1K2, K2, L1, L1L2, L2, N INTEGER ISH1(9), ISH2(9), ISV1(6), ISV2(6) REAL OUTPUT(10) DATA ISH1 /1,1,2,3,3,4,1,2,6/ DATA ISH2 /1,2,2,3,4,4,6,6,6/ DATA ISV1 /1,2,1,2,3,4/ DATA ISV2 /3,3,4,4,6,6/ C --------------------------------------------------------------------- C C PRINT SECOND ORDER TRANSFER MATRIX C IF (TERSE) GO TO 250 WRITE (NOUT,1011) 1011 FORMAT (1H0,8X,'*2ND ORDER TRANSFORM*') DO 210 N = 1, 5 JK = 0 DO 209 J = 1, 6 DO 208 K = 1, J JK = JK + 1 OUTPUT(K) = TS(N,JK)*UBEAM(J)*UBEAM(K)/UBEAM(N) 208 CONTINUE WRITE (NOUT,1009) (N, K, J, OUTPUT(K), K = 1, J) 1009 FORMAT (8X,6(I4,I2,I1,1PE11.3)) 209 CONTINUE WRITE (NOUT,1010) 1010 FORMAT (1H ) 210 CONTINUE GO TO 400 C 250 DO 280 J = 1, 9 K1 = ISH1(J) K2 = ISH2(J) K1K2 = K2*(K2-1)/2 + K1 OUTPUT(1) = TS(1,K1K2)*UBEAM(K1)*UBEAM(K2)/UBEAM(1) OUTPUT(2) = TS(2,K1K2)*UBEAM(K1)*UBEAM(K2)/UBEAM(2) IF (J .GT. 6) GO TO 260 L1 = ISV1(J) L2 = ISV2(J) L1L2 = L2*(L2-1)/2 + L1 OUTPUT(3) = TS(3,L1L2)*UBEAM(L1)*UBEAM(L2)/UBEAM(3) OUTPUT(4) = TS(4,L1L2)*UBEAM(L1)*UBEAM(L2)/UBEAM(4) WRITE (NOUT,1005) K1, K2, OUTPUT(1), K1, K2, OUTPUT(2), 1 L1, L2, OUTPUT(3), L1, L2, OUTPUT(4) IF (NORD3 .EQ. 1) RETURN 1005 FORMAT (1H ,37X,1H1,I2,I1,1PE11.3,3X,1H2,I2,I1,1PE11.3, 1 3X,1H3,I2,I1,1PE11.3,3X,1H4,I2,I1,1PE11.3) GO TO 280 260 WRITE (NOUT,1006) K1, K2, OUTPUT(1), K1, K2, OUTPUT(2) 1006 FORMAT (1H ,37X,1H1,I2,I1,1PE11.3,3X,1H2,I2,I1,1PE11.3) 280 CONTINUE C 400 RETURN END SUBROUTINE RCOUT3 C C PRINTS THIRD-ORDER TRANSFER MATRICES C C ---------------------------------------------------------------------- INCLUDE 'IOUNIT.CIN' INCLUDE 'ELM15C.CIN' INCLUDE 'US.CIN' C C LOCAL VARIABLES C INTEGER J, JKM, K, M, N REAL OUTPUT(10) C--------------------------------------------------------------------- C C PRINT THIRD ORDER TRANSFER MATRIX C WRITE (NOUT,1012) 1012 FORMAT (1H ,8X,'*3RD ORDER TRANSFORM*') DO 310 N = 1, 4 JKM = 0 DO 309 J = 1, 6 DO 309 K = 1, J DO 308 M = 1, K JKM = JKM + 1 OUTPUT(M) = US(N,JKM)*UBEAM(J)*UBEAM(K)*UBEAM(M)/UBEAM(N) 308 CONTINUE WRITE (NOUT,1013) (N, M, K, J, OUTPUT(M), M = 1, K) 1013 FORMAT (8X,6(I4,I2,2I1,1PE11.3)) 309 CONTINUE WRITE (NOUT,1010) 1010 FORMAT (1H ) 310 CONTINUE C RETURN END SUBROUTINE RCTORS C C TRANSFERS MATRIX RC TO RS C C ---------------------------------------------------------------------- INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'RC.CIN' INCLUDE 'RS.CIN' INCLUDE 'TC.CIN' INCLUDE 'TS.CIN' INCLUDE 'UC.CIN' INCLUDE 'US.CIN' INTEGER JK, JKM, JKLM C C------------------------------------------------------------------------ C DO 10 JK = 1, 36 10 RSL(JK) = RCL(JK) IF (NORD2 .GE. 2) THEN DO 20 JKM = 1, 105 20 TSL(JKM) = TCL(JKM) ENDIF IF (NORD2 .GE. 3) THEN DO 30 JKLM = 1, 280 30 USL(JKLM) = UCL(JKLM) ENDIF RETURN END SUBROUTINE RECALL C C RESETS MATRICES, PARAMETERS, AND LOGICAL VARIABLES TO VALUES C AT BEGINNING OF SECTION WHERE FITTING OCCURS C C ---------------------------------------------------------------------- INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'COCOM.CIN' INCLUDE 'COP.CIN' INCLUDE 'COPS.CIN' INCLUDE 'COSS.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'DATA2S.CIN' INCLUDE 'ELM0B.CIN' INCLUDE 'ELM0E.CIN' INCLUDE 'ELM0F.CIN' INCLUDE 'ELM1A.CIN' INCLUDE 'ELM1D.CIN' INCLUDE 'ELM1E.CIN' INCLUDE 'ELM7B.CIN' INCLUDE 'ELM8A.CIN' INCLUDE 'ELM8B.CIN' INCLUDE 'ELM8E.CIN' INCLUDE 'ELM9.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM13B.CIN' INCLUDE 'ELM16A.CIN' INCLUDE 'ELM16B.CIN' INCLUDE 'ELM20.CIN' INCLUDE 'ELM22A.CIN' INCLUDE 'ELM24B.CIN' INCLUDE 'ELM24C.CIN' INCLUDE 'ELM26B.CIN' INCLUDE 'ELM31A.CIN' INCLUDE 'ELM31B.CIN' INCLUDE 'ELS0B.CIN' INCLUDE 'ELS1A.CIN' INCLUDE 'ELS1D.CIN' INCLUDE 'ELS7B.CIN' INCLUDE 'ELS8A.CIN' INCLUDE 'ELS8B.CIN' INCLUDE 'ELS8C.CIN' INCLUDE 'ELS10E.CIN' INCLUDE 'ELS13A.CIN' INCLUDE 'ELS16A.CIN' INCLUDE 'ELS16B.CIN' INCLUDE 'ELS20.CIN' INCLUDE 'ELS22A.CIN' INCLUDE 'ELS24A.CIN' INCLUDE 'ELS24B.CIN' INCLUDE 'ELS24C.CIN' INCLUDE 'ELS26B.CIN' INCLUDE 'ELS31.CIN' INCLUDE 'ETACOM.CIN' INCLUDE 'ETAP.CIN' INCLUDE 'ETAPS.CIN' INCLUDE 'ETASC.CIN' INCLUDE 'FLUSHC.CIN' INCLUDE 'IOUNIT.CIN' INCLUDE 'OC.CIN' INCLUDE 'OCP.CIN' INCLUDE 'OCPS.CIN' INCLUDE 'OCS.CIN' INCLUDE 'RCP.CIN' INCLUDE 'R2P.CIN' INCLUDE 'SEEDS.CIN' INCLUDE 'SI.CIN' INCLUDE 'SIS.CIN' INCLUDE 'SVP.CIN' C C LOCAL VARIABLES C INTEGER IPP, J, K, K1, K2, N C------------------------------------------------------------------------------- C NUM = NUMS NDIF = NDIFS LC = LCS TOTROT = TOTRTS DO 5 N = 1, NV3 LCV(N) = 0 RVP(N) = .FALSE. R2VP(N) = .FALSE. SVP(N) = .FALSE. CVP(N) = .FALSE. EVP(N) = .FALSE. OVP(N) = .FALSE. 5 CONTINUE CALL MREC C DO 110 J = 1, 6 DO 110 K = 1, 6 110 SI(J,K) = SIS(J,K) DO 120 J = 1, 6 120 CO(J) = COSS(J) RI = RIS PSIXO = PSIXOS PSIYO = PSIYOS SOFA = SOFAS DO 130 J = 1, 6 130 COF(J) = COFS(J) RECENT = .FALSE. DO 135 J = 1, 6 135 ETA(J) = ETAS(J) RAY = RAYS NMARK = NMRKS NMARKS = NMRKSS MKG = MKGS NDIFM = NDIFMS DO 137 J = 1, 4 137 OCP(J) = OCPS(J) C IF (.NOT. ALIGN .AND. .NOT. LAY) GO TO 200 DO 140 J = 1, 4 DO 140 K1 = 1, 3 DO 140 K2 = 1, 3 140 O(J,K1,K2) = OS(J,K1,K2) DO 150 J = 1, 4 DO 150 K = 1, 3 150 X0(J,K) = X0S(J,K) RORC = RORCS DO 160 J = 1, 6 160 VM(J) = VMS(J) C 200 NC = 0 NV1 = 0 LAY = LAYS R1P = R1PS FOTILT = FOTLTS SM = SMS PREF = PREFS C IF (.NOT. ALIGN) GO TO 250 DO 210 J = 1, 3 DO 210 K1 = 1, 6 DO 210 K2 = 1, 6 SIOL(J,K1,K2) = SIOLS(J,K1,K2) 210 RCO(J,K1,K2) = RCOS(J,K1,K2) DO 220 J = 1, 3 DO 220 K = 1, 6 220 COLD(J,K) = COLDS(J,K) DO 230 J = 1, 6 DO 230 K = 1, 6 230 R2O(J,K) = R2OS(J,K) DO 240 J = 1, 3 SPO(J) = SPOS(J) 240 RCPO(J) = RCPOS(J) R2PO = R2POS C 250 ATWORK = ATWS C DO 260 J = 1, 20 REG(J) = REGS(J) 260 LREG(J) = LREGS(J) IP = IPS IF (IP .LT. 0 .OR. IP .GT. 4) THEN WRITE (NOUT,9005) IP 9005 FORMAT (' IN RECALL, IP = ',I5) FLUSHL = .TRUE. GO TO 500 ENDIF IF (IP .NE. 0) THEN DO 265 IPP = 1, IP IC(IPP) = ICS(IPP) 265 IS(IPP) = ISS(IPP) ENDIF NDLEV = NDLEVS IF (NDLEV .GT. 0) THEN DO 280 N = 1, NDLEV NDC(N) = NDCS(N) NDS(N) = NDSS(N) 280 NDN(N) = NDNS(N) ENDIF C 300 DO 305 J = 1, 4 305 PRAN2(J) = PRAN2S(J) PRAN3 = PRAN3S DO 310 J = 1, 15 310 PRAN4(J) = PRAN4S(J) DO 320 J = 1, 5 320 PRAN5(J) = PRAN5S(J) DO 330 J = 1, 6 330 PRAN7(J) = PRAN7S(J) DO 340 J = 1, 4 340 PRAN11(J) = PRN11S(J) DO 350 J = 1, 4 350 PRAN18(J) = PRN18S(J) DO 360 J = 1, 3 360 PRAN19(J) = PRN19S(J) PRAN20 = PRN20S DO 370 J = 1, 4 370 PRAN25(J) = PRN25S(J) DO 380 J = 1, 9 380 PRAN28(J) = PRN28S(J) DO 390 J = 1, 5 390 PRAN34(J) = PRN34S(J) DO 400 J = 1, 6 400 PRAN43(J) = PRN43S(J) C BDBI = BDBIS APBI(1) = APBIS(1) APBI(2) = APBIS(2) LAYKI = LAYKIS LAYLI = LAYLIS LAYXI = LAYXIS RAB1I = RAB1IS RAB2I = RAB2IS RMPSI = RMPSIS RNMSI = RNMSIS VRNI = VRNIS NPNI = NPNIS BDBPI = BDBPIS C CALL RANSET(ISEEDS) 500 RETURN END SUBROUTINE RECKON C C RUNS THROUGH BEAM LINE STORING AVERAGES OF CONSTRAINED QUANTITIES C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA1A.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM0C.CIN' INCLUDE 'ELM0D.CIN' INCLUDE 'ELM8G.CIN' INCLUDE 'ELM10E.CIN' INCLUDE 'ELM31A.CIN' INCLUDE 'FLUSHC.CIN' INCLUDE 'LXRAN.CIN' C CALL INITZE 1 I = ISTOR(NUM) TYPE = IDATA(I) IF (TYPE .GE. 82 .AND. TYPE .LE. 86) GO TO 70 IF (TYPE .LE. 0 .OR. TYPE .GE. 50) GO TO 810 C CALL SKETCH(NUM) CALL DEPICT IF (.NOT. ATWE) GO TO 810 IF (DOPARS .AND. TYPE .NE. 23 .AND. TYPE .NE. 30 .AND. 1 TYPE .NE. 9 .AND. TYPE .NE. 24 .AND. TYPE .NE. 31) GO TO 810 C C POSSIBLE INITIAL MISALIGNMENTS C CALL POSSIM C C SIMPLE ELEMENTS C IF (RABL .AND. WFRN) GO TO 200 IF (RABL) GO TO 100 70 TYPEC = TYPE LXRAN = TYPE .LT. 50 CALL ELICIT IF (FLUSHL) GO TO 900 IF (TYPE .LE. 0) GO TO 810 IF (TYPE .GE. 50) GO TO 810 C C UPDATE USED TO MARK BEGINNING OF MISALIGNMENT C IF (TYPE .NE. 6 .AND. TYPE .NE. 37) GO TO 810 CALL UPMARK IF (FLUSHL) GO TO 900 GO TO 810 C C SIMPLE ELEMENTS WITH POSSIBLE TILT C 100 IF (TYPE .EQ. 2 .OR. TYPE .EQ. 4) GO TO 150 CALL ELTILT IF (FLUSHL) GO TO 900 GO TO 800 C C BENDING MAGNETS WITH FRINGE FIELD SPECIFIED BY SEPARATE ELEMENT C 150 CALL EL242 IF (FLUSHL) GO TO 900 GO TO 800 C C COMPOUND ELEMENTS C 200 CALL ELCOMP IF (FLUSHL) GO TO 900 GO TO 800 C C LOOP THROUGH MISALIGNMENTS BY NAME C 800 IF (NMISRB .NE. 0) CALL AGENDR(1) C C ADVANCE TO NEXT ELEMENT C 810 IF (MKG .AND. NUM .EQ. NMARKE) CALL AGENDA(2) IF (ALGR .AND. NUM .EQ. NMISRE) CALL AGENDR(2) NUM = NUM + NDIF IF (.NOT. MKG .AND. NUSE .NE. 0 .AND. NUM .GT. NUSE) GO TO 900 IF (NUM .LE. NEL) GO TO 1 900 RETURN END SUBROUTINE REFCHK C C FILL IN POINTERS FOR BEAM LINE SPECIFICATIONS C C ---------------------------------------------------------------------- INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA1A.CIN' INCLUDE 'DATA1C.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM24A.CIN' INCLUDE 'FLUSHC.CIN' INCLUDE 'IOUNIT.CIN' C --------------------------------------------------------------------- CHARACTER*15 LABLE EXTERNAL IDATA C C PROCESS DATA C NFAUTE = 0 NUM = 1 IOLD = 0 C 70 I = ISTOR(NUM) IF (I .LE. IOLD) GO TO 6000 TYPE = IDATA(I) LABLE = LABEL(NUM) C C PROCESS ORIGINAL DATA C IF (TYPE .EQ. 24) GO TO 2400 GO TO 6000 C C DEFINED SECTION C 2400 JDEF = IDATA(I+1) IF (JDEF .EQ. 1 .OR. JDEF .EQ. 2) GO TO 6000 NADDEF(1) = IDATA(I+2) NADDEF(2) = IDATA(I+3) IF (NADDEF(1) .EQ. 0 .OR. NADDEF(2) .EQ. 0) THEN NFAUTE = NFAUTE + 1 WRITE (NOUT,7008) LABLE 7008 FORMAT (1X,'***NO DEFINITION FOR SUBLINE ',A8) ENDIF GO TO 6000 C C ADVANCE TO NEXT ELEMENT C 6000 IOLD = MAX0(I,IOLD) NUM = NUM + 1 IF (NUM .LE. NEL) GO TO 70 FLUSHL = FLUSHL .OR. NFAUTE .GT. 0 RETURN END SUBROUTINE REPEAT C C KEEPS TRACK OF REPEAT ELEMENT C C ---------------------------------------------------------------------- INCLUDE 'DATA2A.CIN' INCLUDE 'ELM9.CIN' INCLUDE 'FLUSHC.CIN' INCLUDE 'IOUNIT.CIN' C C BEGINNING OF REPEATED SECTION C 10 IF ((NREP .EQ. 0 .AND. NDIF .EQ. 1) .OR. 1 (NREP .GT. 0 .AND. NDIF .EQ. -1)) GO TO 20 IP = IP + 1 IF (IP .LE. 0 .OR. IP .GT. 4) THEN WRITE (NOUT,9001) IP 9001 FORMAT (' ***NESTING LEVEL TOO DEEP, IP = ',I5) FLUSHL = .TRUE. GO TO 40 ENDIF IF (NDIF .EQ. 1) IC(IP) = NREP IF (NDIF .EQ. -1) IC(IP) = 0 IS(IP) = NUM GO TO 40 C C END OF REPEATED SECTION C 20 IF (IP .EQ. 0 .AND. NDIF .EQ. 1) GO TO 40 IF (NDIF .EQ. -1 .AND. IC(IP) .EQ. 0) IC(IP) = NREP IC(IP) = IC(IP) - 1 IF (IC(IP) .LE. 0) GO TO 30 NUM = IS(IP) GO TO 40 30 IP = IP - 1 IF (IP .LT. 0 .OR. IP .GT. 4) THEN WRITE (NOUT,9002) IP 9002 FORMAT (' *** ERROR *** REPEAT LEVEL = ',I5) FLUSHL = .TRUE. GO TO 40 ENDIF 40 CONTINUE RETURN END SUBROUTINE RESET(I) C C INITIALIZE COORDINATE TRANSFORMATION MATRICES C C ---------------------------------------------------------------------- INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'OC.CIN' INCLUDE 'OCP.CIN' C IMAX = I + 8 DO 1 J = I, IMAX, 4 1 X0L(J) = 0.0 IMIN = I + 4 IMAX = I + 28 DO 2 J = IMIN, IMAX, 4 2 OL(J) = 0.0 IMAX = I + 32 DO 3 J = I, IMAX, 16 3 OL(J) = 1.0 OCP(I) = .FALSE. RETURN END SUBROUTINE RETAIN C C STORE VALUES OF PARAMETERS, MATRICES, AND LOGICAL VARIABLES C AT BEGINNING OF SECTION WHERE FITTING OCCURS C C ---------------------------------------------------------------------- INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'COCOM.CIN' INCLUDE 'COP.CIN' INCLUDE 'COSS.CIN' INCLUDE 'COPS.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'DATA2S.CIN' INCLUDE 'ELM0B.CIN' INCLUDE 'ELM0F.CIN' INCLUDE 'ELM1A.CIN' INCLUDE 'ELM1E.CIN' INCLUDE 'ELM7B.CIN' INCLUDE 'ELM8A.CIN' INCLUDE 'ELM8B.CIN' INCLUDE 'ELM8E.CIN' INCLUDE 'ELM9.CIN' INCLUDE 'ELM13B.CIN' INCLUDE 'ELM16A.CIN' INCLUDE 'ELM16B.CIN' INCLUDE 'ELM20.CIN' INCLUDE 'ELM22A.CIN' INCLUDE 'ELM24B.CIN' INCLUDE 'ELM24C.CIN' INCLUDE 'ELM26B.CIN' INCLUDE 'ELM31A.CIN' INCLUDE 'ELM31B.CIN' INCLUDE 'ELS0B.CIN' INCLUDE 'ELS1A.CIN' INCLUDE 'ELS1D.CIN' INCLUDE 'ELS7B.CIN' INCLUDE 'ELS8A.CIN' INCLUDE 'ELS8B.CIN' INCLUDE 'ELS8C.CIN' INCLUDE 'ELS10E.CIN' INCLUDE 'ELS13A.CIN' INCLUDE 'ELS16A.CIN' INCLUDE 'ELS16B.CIN' INCLUDE 'ELS20.CIN' INCLUDE 'ELS22A.CIN' INCLUDE 'ELS24A.CIN' INCLUDE 'ELS24B.CIN' INCLUDE 'ELS24C.CIN' INCLUDE 'ELS26B.CIN' INCLUDE 'ELS31.CIN' INCLUDE 'ETACOM.CIN' INCLUDE 'ETAP.CIN' INCLUDE 'ETAPS.CIN' INCLUDE 'ETASC.CIN' INCLUDE 'FLUSHC.CIN' INCLUDE 'IOUNIT.CIN' INCLUDE 'OC.CIN' INCLUDE 'OCP.CIN' INCLUDE 'OCPS.CIN' INCLUDE 'OCS.CIN' INCLUDE 'SEEDS.CIN' INCLUDE 'SI.CIN' INCLUDE 'SIS.CIN' C C LOCAL VARIABLES C INTEGER IPP, J, K, K1, K2, N C----------------------------------------------------------------------------- C NUMS = NUM NDIFS = NDIF LCS = LC TOTRTS = TOTROT CALL MRET C DO 110 J = 1, 6 DO 110 K = 1, 6 110 SIS(J,K) = SI(J,K) DO 120 J = 1, 6 120 COSS(J) = CO(J) RIS = RI PSIXOS = PSIXO PSIYOS = PSIYO SOFAS = SOFA DO 130 J = 1, 6 130 COFS(J) = COF(J) DO 135 J = 1, 6 135 ETAS(J) = ETA(J) RAYS = RAY NMRKS = NMARK NMRKSS = NMARKS MKGS = MKG NDIFMS = NDIFM DO 137 J = 1, 4 137 OCPS(J) = OCP(J) C IF (.NOT. LAY .AND. .NOT. ALIGN) GO TO 200 DO 140 J = 1, 4 DO 140 K1 = 1, 3 DO 140 K2 = 1, 3 140 OS(J,K1,K2) = O(J,K1,K2) DO 150 J = 1, 4 DO 150 K = 1, 3 150 X0S(J,K) = X0(J,K) RORCS = RORC DO 160 J = 1, 6 160 VMS(J) = VM(J) C 200 LAYS = LAY R1PS = R1P FOTLTS = FOTILT SMS = SM PREFS = PREF C IF (.NOT. ALIGN) GO TO 250 DO 210 J = 1, 3 DO 210 K1 = 1, 6 DO 210 K2 = 1, 6 SIOLS(J,K1,K2) = SIOL(J,K1,K2) 210 RCOS(J,K1,K2) = RCO(J,K1,K2) DO 220 J = 1, 3 DO 220 K = 1, 6 220 COLDS(J,K) = COLD(J,K) DO 230 J = 1, 6 DO 230 K = 1, 6 230 R2OS(J,K) = R2O(J,K) DO 240 J = 1, 3 SPOS(J) = SPO(J) 240 RCPOS(J) = RCPO(J) R2POS = R2PO C 250 ATWS = ATWORK C DO 260 J = 1, 20 REGS(J) = REG(J) 260 LREGS(J) = LREG(J) IPS = IP IF (IP .LT. 0 .OR. IP .GT. 4) THEN WRITE (NOUT,9005) IP 9005 FORMAT (' IN RETAIN, IP = ',I5) FLUSHL = .TRUE. GO TO 500 ENDIF IF (IPS .GT. 0) THEN DO 265 IPP = 1, IPS ICS(IPP) = IC(IPP) 265 ISS(IPP) = IS(IPP) ENDIF NDLEVS = NDLEV IF (NDLEVS .GT. 0) THEN DO 280 N = 1, NDLEV NDCS(N) = NDC(N) NDSS(N) = NDS(N) 280 NDNS(N) = NDN(N) ENDIF C 300 DO 305 J = 1, 4 305 PRAN2S(J) = PRAN2(J) PRAN3S = PRAN3 DO 310 J = 1, 15 310 PRAN4S(J) = PRAN4(J) DO 320 J = 1, 5 320 PRAN5S(J) = PRAN5(J) DO 330 J = 1, 6 330 PRAN7S(J) = PRAN7(J) DO 340 J = 1, 4 340 PRN11S(J) = PRAN11(J) DO 350 J = 1, 4 350 PRN18S(J) = PRAN18(J) DO 360 J = 1, 3 360 PRN19S(J) = PRAN19(J) PRN20S = PRAN20 DO 370 J = 1, 4 370 PRN25S(J) = PRAN25(J) DO 380 J = 1, 9 380 PRN28S(J) = PRAN28(J) DO 390 J = 1, 5 390 PRN34S(J) = PRAN34(J) DO 400 J = 1, 6 400 PRN43S(J) = PRAN43(J) C BDBIS = BDBI APBIS(1) = APBI(1) APBIS(2) = APBI(2) LAYKIS = LAYKI LAYLIS = LAYLI LAYXIS = LAYXI RAB1IS = RAB1I RAB2IS = RAB2I RMPSIS = RMPSI RNMSIS = RNMSI VRNIS = VRNI NPNIS = NPNI BDBPIS = BDBPI C CALL RANGET(ISEEDS) 500 RETURN END SUBROUTINE RFIT C C CONSTRAINS R MATRIX C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM10A.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM10D.CIN' INCLUDE 'ELM15C.CIN' INCLUDE 'RC.CIN' INCLUDE 'RCP.CIN' INCLUDE 'RC2.CIN' INCLUDE 'R2P.CIN' C----------------------------------------------------------------------- LOGICAL LOGIC C C VALUE OF MATRIX ELEMENT C J = JCON K = KCON J = - J FAC = UBEAM(K)/UBEAM(J) C IF (RCP) GO TO 10 RCT = RC2(J,K) GO TO 50 C 10 IF (R2P) GO TO 20 RCT = RC(J,K) GO TO 50 C 20 RCT = 0.0 DO 30 L1 = 1, 6 RCT = RCT + RC2(J,L1)*RC(L1,K) 30 CONTINUE C 50 COC = RCT*FAC IF (NV3 .LT. 1) GO TO 100 CW = 1.0/SD**2 A(1) = DE0 - COC CALL CLI(LOGIC) IF (LOGIC) GO TO 150 C C PARTIAL DERIVATIVES C IF (NV1 .LT. 1) GO TO 100 DO 90 N = 1, NV1 RCTV = 0.0 IF (.NOT. (RVP(N) .OR. R2VP(N))) GO TO 80 IF (RCP) GO TO 55 RCTV = R2V(J,K,N) GO TO 80 C 55 IF (R2P) GO TO 60 RCTV = RCV(J,K,N) GO TO 80 C 60 IF (R2VP(N)) GO TO 70 DO 65 L1 = 1, 6 RCTV = RCTV + RC2(J,L1)*RCV(L1,K,N) 65 CONTINUE GO TO 80 C 70 IF (RVP(N)) THEN DO 75 L1 = 1, 6 RCTV = RCTV + R2V(J,L1,N)*RC(L1,K) + RC2(J,L1)*RCV(L1,K,N) 75 CONTINUE ELSE DO 77 L1 = 1, 6 RCTV = RCTV + R2V(J,L1,N)*RC(L1,K) 77 CONTINUE ENDIF 80 A(N+1) = RCTV*FAC C 90 CONTINUE 100 CALL GATHER IF (NV1 .LT. 1) GO TO 150 C 150 RETURN END SUBROUTINE RINV C C FIND INVERSE OF TRANSFER MATRICES C C ---------------------------------------------------------------------- INCLUDE 'ELM17A.CIN' C CALL RINV1 IF (NORD3 .GE. 2) CALL RINV2 IF (NORD3 .GE. 3) CALL RINV3 RETURN END SUBROUTINE RINV1 C C CALCULATES INVERSE OF FIRST-ORDER TRANSFER MATRIX C C ---------------------------------------------------------------------- INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM10D.CIN' INCLUDE 'RS.CIN' C PMARQ = 0.0 DO 310 J = 1, 7 SCALE(J) = 1.0 310 CA(J,1) = 0.0 DO 320 J = 1, 6 DO 320 K = 1, 6 RT(J,K) = RS(J,K) 320 CA(J+1,K+1) = RS(J,K) NSAVE = NV1 NV1 = 6 CALL INQ NV1 = NSAVE DO 330 J = 1, 6 DO 330 K = 1, 6 330 RS(J,K) = CA(J+1,K+1) RETURN END SUBROUTINE RINV2 C C CALCULATES INVERSE OF SECOND-ORDER TRANSFER MATRIX C C ---------------------------------------------------------------------- INCLUDE 'RS.CIN' INCLUDE 'TR.CIN' INCLUDE 'TS.CIN' C DO 30 J = 1, 5 DO 10 L1 = 1, 6 DO 10 L2 = 1, 6 TR(J,L1,L2) = 0.0 10 CONTINUE IND = 0 DO 20 L2 = 1, 6 DO 20 L1 = 1, L2 IND = IND + 1 DO 20 K = 1, 6 TR(J,K,L2) = TR(J,K,L2) + TS(J,IND)*RS(L1,K) 20 CONTINUE 30 CONTINUE C DO 60 J = 1, 5 DO 40 IND = 1, 21 TT(J,IND) = 0.0 40 CONTINUE DO 50 K = 1, 6 DO 50 L1 = 1, 6 DO 50 L2 = 1, 6 IND = INDEX2(L1,L2) TT(J,IND) = TT(J,IND) + TR(J,L1,K)*RS(K,L2) 50 CONTINUE 60 CONTINUE C DO 80 J = 1, 5 DO 80 IND = 1, 21 SS = 0.0 DO 70 K = 1, 5 SS = SS + RS(J,K)*TT(K,IND) 70 CONTINUE TS(J,IND) = - SS 80 CONTINUE C RETURN END SUBROUTINE RINV3 C C CALCULATES INVERSE OF THIRD-ORDER TRANSFER MATRIX C C ---------------------------------------------------------------------- INCLUDE 'RS.CIN' INCLUDE 'TS.CIN' INCLUDE 'US.CIN' C----------------------------------------------------------------------- REAL UR(6) C DO 20 I1 = 1, 5 DO 20 I234 = 1, 56 SS = 0.0 DO 10 I5 = 1, 5 SS = SS + RS(I1,I5)*US(I5,I234) 10 CONTINUE UT(I1,I234) = - SS 20 CONTINUE C DO 30 J = 1, 5 DO 30 K = 1, 56 US(J,K) = 0.0 30 CONTINUE C DO 100 I1 = 1, 5 DO 100 I2 = 1, 6 INDA = 0 DO 100 I7 = 1, 6 DO 60 I6 = 1, I7 UR(I6) = 0.0 DO 60 I5 = 1, I6 INDA = INDA + 1 UR(I6) = UR(I6) + UT(I1,INDA)*RS(I5,I2) 60 CONTINUE C DO 90 I3 = 1, 6 URR = 0.0 DO 70 I6 = 1, I7 URR = URR + UR(I6)*RS(I6,I3) 70 CONTINUE IF (URR .EQ. 0.0) GO TO 90 C DO 80 I4 = 1, 6 I234 = INDEX3(I2,I3,I4) US(I1,I234) = US(I1,I234) + URR*RS(I7,I4) 80 CONTINUE 90 CONTINUE 100 CONTINUE C DO 150 J = 1, 5 INDA = 0 DO 150 I2 = 1, 6 DO 150 I1 = 1, I2 INDA = INDA + 1 INDB = 0 DO 130 J2 = 1, 6 DO 130 J1 = 1, J2 INDB = INDB + 1 IF (I1 .LE. 5) THEN I123 = INDEX3(I2,J1,J2) US(J,I123) = US(J,I123) - TS(J,INDA)*TT(I1,INDB) ENDIF 130 CONTINUE INDB = 0 DO 140 J2 = 1, 6 DO 140 J1 = 1, J2 INDB = INDB + 1 IF (I2 .LE. 5) THEN I123 = INDEX3(I1,J1,J2) US(J,I123) = US(J,I123) - TS(J,INDA)*TT(I2,INDB) ENDIF 140 CONTINUE 150 CONTINUE C RETURN END SUBROUTINE ROTAT1(NM) C C ROTATION OF FIRST-ORDER TRANSFER MATRIX C C ---------------------------------------------------------------------- INCLUDE 'ELM7B.CIN' INCLUDE 'ELM10E.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'ELM20.CIN' INCLUDE 'R.CIN' INCLUDE 'RS.CIN' C---------------------------------------------------------------------- REAL CODS(6), CODT(6) C CSR = COS(TOTROT) IF (ABS(CSR) .LT. 0.00001) CSR = 0.0 SNR = SIN(TOTROT) IF (ABS(SNR) .LT. 0.00001 .AND. ABS(TOTRA) .GT. 0.01) SNR = 0.0 C C IDENTIFY MATRIX TO BE ROTATED C IF (NM .EQ. 0) THEN IF (DCOV) THEN DO 75 J = 1, 4 75 CODS(J) = COD(J) ENDIF IF (NORD1 .GE. 1) THEN DO 80 JK = 1, 36 80 RSL(JK) = RL(JK) ENDIF ELSE IF (DCOV) THEN DO 85 J = 1, 4 85 CODS(J) = CODV(J) ENDIF IF (NORD1 .GE. 1) THEN DO 90 JK = 1, 36 90 RSL(JK) = RVL(JK) ENDIF ENDIF C C ROTATE AT ENTRANCE C 100 IF (NORD1 .GE. 1) THEN DO 110 I = 1, 6 RT(I,1) = RS(I,1)*CSR - RS(I,3)*SNR RT(I,3) = RS(I,1)*SNR + RS(I,3)*CSR RT(I,2) = RS(I,2)*CSR - RS(I,4)*SNR RT(I,4) = RS(I,2)*SNR + RS(I,4)*CSR DO 110 J = 1, 4 110 RS(I,J) = RT(I,J) ENDIF C C ROTATE AT EXIT C 200 IF (DCOV) THEN CODT(1) = CODS(1)*CSR - CODS(3)*SNR CODT(2) = CODS(2)*CSR - CODS(4)*SNR CODT(3) = CODS(1)*SNR + CODS(3)*CSR CODT(4) = CODS(2)*SNR + CODS(4)*CSR ENDIF C 210 IF (NORD1 .GE. 1) THEN DO 215 J = 1, 6 RT(1,J) = RS(1,J)*CSR - RS(3,J)*SNR RT(3,J) = RS(1,J)*SNR + RS(3,J)*CSR RT(2,J) = RS(2,J)*CSR - RS(4,J)*SNR RT(4,J) = RS(2,J)*SNR + RS(4,J)*CSR 215 CONTINUE DO 220 I = 1, 4 DO 220 J = 1, 6 220 RS(I,J) = RT(I,J) ENDIF C C REPLACE ROTATED MATRIX C 400 IF (NM .EQ. 0) THEN IF (DCOV) THEN DO 405 J = 1, 4 405 COD(J) = CODT(J) ENDIF IF (NORD1 .GE. 1) THEN DO 410 JK = 1, 36 410 RL(JK) = RSL(JK) ENDIF ELSE IF (DCOV) THEN DO 455 J = 1, 4 455 CODV(J) = CODT(J) ENDIF IF (NORD1 .GE. 1) THEN DO 460 JK = 1, 36 460 RVL(JK) = RSL(JK) ENDIF ENDIF C 500 IF (NORD1 .GE. 2) CALL ROTAT2(NM) RETURN END SUBROUTINE ROTAT2(NM) C C ROTATION OF SECOND-ORDER TRANSFER MATRIX ELEMENT C C ---------------------------------------------------------------------- INCLUDE 'ELM17A.CIN' INCLUDE 'ELM20.CIN' INCLUDE 'T.CIN' INCLUDE 'TS.CIN' REAL TSAV(6,6) C C IDENTIFY MATRIX TO BE ROTATED C IF (NM .EQ. 0) THEN DO 15 JKL = 1, 105 15 TSL(JKL) = TL(JKL) ELSE DO 55 JKL = 1, 105 55 TSL(JKL) = TVL(JKL) ENDIF C C ROTATE AT ENTRANCE C 100 DO 150 I = 1, 5 JK = 0 DO 120 K = 1, 6 DO 120 J = 1, K JK = JK + 1 TSIJK = TS(I,JK) IF (J .NE. K) TSIJK = 0.5*TSIJK TSAV(J,K) = TSIJK 120 TSAV(K,J) = TSIJK C DO 130 K = 1, 6 T1K = TSAV(1,K) TSAV(1,K) = T1K*CSR - TSAV(3,K)*SNR TSAV(3,K) = T1K*SNR + TSAV(3,K)*CSR T2K = TSAV(2,K) TSAV(2,K) = T2K*CSR - TSAV(4,K)*SNR TSAV(4,K) = T2K*SNR + TSAV(4,K)*CSR 130 CONTINUE C DO 140 J = 1, 6 TJ1 = TSAV(J,1) TSAV(J,1) = TJ1*CSR - TSAV(J,3)*SNR TSAV(J,3) = TJ1*SNR + TSAV(J,3)*CSR TJ2 = TSAV(J,2) TSAV(J,2) = TJ2*CSR - TSAV(J,4)*SNR TSAV(J,4) = TJ2*SNR + TSAV(J,4)*CSR 140 CONTINUE C JK = 0 DO 145 K = 1, 6 DO 145 J = 1, K JK = JK + 1 TSIJK = TSAV(J,K) IF (J .NE. K) TSIJK = 2.0*TSIJK 145 TS(I,JK) = TSIJK 150 CONTINUE C C ROTATE AT EXIT C JK = 0 DO 230 K = 1, 6 DO 230 J = 1, K JK = JK + 1 TT(1,JK) = TS(1,JK)*CSR - TS(3,JK)*SNR TT(3,JK) = TS(1,JK)*SNR + TS(3,JK)*CSR TT(2,JK) = TS(2,JK)*CSR - TS(4,JK)*SNR TT(4,JK) = TS(2,JK)*SNR + TS(4,JK)*CSR 230 CONTINUE DO 240 I = 1, 4 DO 240 JK = 1, 21 240 TS(I,JK) = TT(I,JK) C C REPLACE ROTATED MATRIX C 400 IF (NM .EQ. 0) THEN DO 415 JKL = 1, 105 415 TL(JKL) = TSL(JKL) ELSE DO 465 JKL = 1, 105 465 TVL(JKL) = TSL(JKL) ENDIF C 500 IF (NORD1 .GE. 3) CALL ROTAT3(NM) RETURN END SUBROUTINE ROTAT3(NM) C C ROTATION OF THIRD-ORDER TRANSFER MATRIX ELEMENT C C ---------------------------------------------------------------------- INCLUDE 'ELM20.CIN' INCLUDE 'U.CIN' INCLUDE 'US.CIN' C C LOCAL VARIABLES C REAL USAV(6,6,6) C -------------------------------------------------------------------- C C IDENTIFY MATRIX TO BE ROTATED C IF (NM .EQ. 0) THEN DO 20 JKLM = 1, 280 20 USL(JKLM) = UL(JKLM) ELSE DO 60 JKLM = 1, 280 60 USL(JKLM) = UVL(JKLM) ENDIF C C ROTATE AT ENTRANCE C 100 DO 180 I = 1, 5 JKL = 0 DO 155 L = 1, 6 DO 155 K = 1, L DO 155 J = 1, K JKL = JKL + 1 USIJKL = US(I,JKL) USAV(J,K,L) = USIJKL USAV(J,L,K) = USIJKL USAV(K,J,L) = USIJKL USAV(K,L,J) = USIJKL USAV(L,J,K) = USIJKL 155 USAV(L,K,J) = USIJKL C DO 160 L = 1, 6 DO 160 K = 1, 6 US1 = USAV(1,K,L) USAV(1,K,L) = US1*CSR - USAV(3,K,L)*SNR USAV(3,K,L) = US1*SNR + USAV(3,K,L)*CSR US2 = USAV(2,K,L) USAV(2,K,L) = US2*CSR - USAV(4,K,L)*SNR USAV(4,K,L) = US2*SNR + USAV(4,K,L)*CSR 160 CONTINUE C DO 165 L = 1, 6 DO 165 J = 1, 6 US1 = USAV(J,1,L) USAV(J,1,L) = US1*CSR - USAV(J,3,L)*SNR USAV(J,3,L) = US1*SNR + USAV(J,3,L)*CSR US2 = USAV(J,2,L) USAV(J,2,L) = US2*CSR - USAV(J,4,L)*SNR USAV(J,4,L) = US2*SNR + USAV(J,4,L)*CSR 165 CONTINUE C DO 170 K = 1, 6 DO 170 J = 1, 6 US1 = USAV(J,K,1) USAV(J,K,1) = US1*CSR - USAV(J,K,3)*SNR USAV(J,K,3) = US1*SNR + USAV(J,K,3)*CSR US2 = USAV(J,K,2) USAV(J,K,2) = US2*CSR - USAV(J,K,4)*SNR USAV(J,K,4) = US2*SNR + USAV(J,K,4)*CSR 170 CONTINUE C JKL = 0 DO 175 L = 1, 6 DO 175 K = 1, L DO 175 J = 1, K JKL = JKL + 1 USIJKL = USAV(J,K,L) 175 US(I,JKL) = USIJKL 180 CONTINUE C C ROTATE AT EXIT C 200 JKL = 0 DO 245 L = 1, 6 DO 245 K = 1, L DO 245 J = 1, K JKL = JKL + 1 UT(1,JKL) = US(1,JKL)*CSR - US(3,JKL)*SNR UT(3,JKL) = US(1,JKL)*SNR + US(3,JKL)*CSR UT(2,JKL) = US(2,JKL)*CSR - US(4,JKL)*SNR UT(4,JKL) = US(2,JKL)*SNR + US(4,JKL)*CSR 245 CONTINUE DO 250 I = 1, 4 DO 250 JKL = 1, 56 250 US(I,JKL) = UT(I,JKL) C C REPLACE ROTATED MATRIX C 400 IF (NM .EQ. 0) THEN DO 420 JKLM = 1, 280 420 UL(JKLM) = USL(JKLM) ELSE DO 470 JKLM = 1, 280 470 UVL(JKLM) = USL(JKLM) ENDIF C 500 CONTINUE RETURN END SUBROUTINE ROTATC(NM) C C ROTATES FLOOR COORDINATE TRANSFORMATION FOR ELEMENT C C ---------------------------------------------------------------------- INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM20.CIN' INCLUDE 'OC.CIN' INCLUDE 'OIV.CIN' C ---------------------------------------------------------------------- REAL OS(3,3), OT(3,3), O1(3,3), XS(3), XT(3) C CSR = COS(TOTROT) IF (ABS(CSR) .LT. 0.00001) CSR = 0.0 SNR = SIN(TOTROT) IF (ABS(SNR) .LT. 0.00001 .AND. ABS(TOTRA) .GT. 0.01) SNR = 0.0 C C IDENTIFY MATRIX TO BE ROTATED C IF (NM .EQ. 0) THEN DO 10 J = 1, 3 DO 10 K = 1, 3 10 OS(J,K) = O(1,J,K) DO 20 J = 1, 3 20 XS(J) = X0(1,J) ELSE DO 75 J = 1, 3 DO 75 K = 1, 3 75 OS(J,K) = OIV(J,K) DO 80 J = 1, 3 80 XS(J) = XIV(J) ENDIF C C ROTATE AT ENTRANCE C O1(1,1) = CSR O1(1,2) = SNR O1(2,1) = - SNR O1(2,2) = CSR DO 181 J = 1, 2 O1(J,3) = 0.0 O1(3,J) = 0.0 181 CONTINUE O1(3,3) = 1.0 C DO 190 J = 1, 3 DO 190 K = 1, 3 SS = 0.0 DO 185 L = 1, 3 SS = SS + OS(J,L)*O1(L,K) 185 CONTINUE OT(J,K) = SS 190 CONTINUE C C ROTATE AT EXIT C DO 260 J = 1, 3 DO 260 K = 1, 3 SS = 0.0 DO 255 L = 1, 3 SS = SS + O1(L,J)*OT(L,K) 255 CONTINUE OS(J,K) = SS 260 CONTINUE C DO 270 J = 1, 3 SS = 0.0 DO 265 L = 1, 3 SS = SS + O1(L,J)*XS(L) 265 CONTINUE XT(J) = SS 270 CONTINUE DO 275 J = 1, 3 275 XS(J) = XT(J) C C REPLACE ROTATED MATRIX C 400 IF (NM .EQ. 0) THEN DO 440 J = 1, 3 DO 440 K = 1, 3 O(1,J,K) = OS(J,K) 440 CONTINUE DO 445 J = 1, 3 445 X0(1,J) = XS(J) ELSE DO 490 J = 1, 3 DO 490 K = 1, 3 OIV(J,K) = OS(J,K) 490 CONTINUE DO 495 J = 1, 3 495 XIV(J) = XS(J) ENDIF C 500 CONTINUE RETURN END SUBROUTINE ROTATE(NPM) C C CALCULATES TRANSFER MATRIX FOR ROTATION ELEMENT C C ---------------------------------------------------------------------- INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM1A.CIN' INCLUDE 'ELM8A.CIN' INCLUDE 'ELM8B.CIN' INCLUDE 'ELM13A.CIN' INCLUDE 'ELM13B.CIN' INCLUDE 'ELM16B.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'ELM20.CIN' INCLUDE 'R.CIN' INTEGER NPM REAL VM3, VM4 C NPM = 0 IF (NDIF .LT. 0) TH = - TH TOTROT = TOTROT + TH TOTRA = TOTRA + ABS(TH) CSR = COS(TH) IF (ABS(CSR) .LT. 0.00001) CSR = 0.0 SNR = SIN(TH) IF (ABS(SNR) .LT. 0.00001 .AND. ABS(TH) .GT. 1.0) SNR = 0.0 C IF (ACCEL .AND. SNR .NE. 0.0 .AND. CSR .NE. 0.0) GO TO 140 IF ((ACCEL .OR. LTWISS) .AND. .NOT. REFER 1 .AND. SNR .NE. 0.0) GO TO 140 IF (REFER) THEN IF (TYPE .EQ. 13) THEN TOTROT = 0.0 ELSE GO TO 100 ENDIF ENDIF IF (NORD1 .LT. 1) GO TO 10 R(4,4) = CSR R(3,3) = CSR R(2,2) = CSR R(1,1) = CSR R(2,4) = SNR R(1,3) = SNR R(4,2) = - SNR R(3,1) = - SNR C 10 IF (.NOT. (ALIGN .OR. LAY)) GO TO 100 IF (RORC .LT. 3) GO TO 100 VM3 = R(3,1)*VM(1) + R(3,3)*VM(3) VM(1) = R(1,1)*VM(1) + R(1,3)*VM(3) VM(3) = VM3 VM4 = R(4,2)*VM(2) + R(4,4)*VM(4) VM(2) = R(2,2)*VM(2) + R(2,4)*VM(4) VM(4) = VM4 GO TO 100 C 100 NPM = 1 GO TO 150 140 NPM = 4 150 RETURN END SUBROUTINE ROTOR C C TRANSFERS MATRIX RO TO R C C ---------------------------------------------------------------------- INCLUDE 'ELM17A.CIN' INCLUDE 'R.CIN' INCLUDE 'RO.CIN' INCLUDE 'T.CIN' INCLUDE 'TO.CIN' INCLUDE 'U.CIN' INCLUDE 'UO.CIN' C DO 10 J = 1, 36 10 RL(J) = ROL(J) IF (NORD1 .GE. 2) THEN DO 20 J = 1, 105 20 TL(J) = TOL(J) ENDIF IF (NORD1 .GE. 3) THEN DO 30 J = 1, 280 30 UL(J) = UOL(J) ENDIF RETURN END SUBROUTINE RSHTOR C C TRANSFERS MATRIX RSH TO R C C ---------------------------------------------------------------------- INCLUDE 'ELM17A.CIN' INCLUDE 'R.CIN' INCLUDE 'RC3.CIN' INCLUDE 'T.CIN' INCLUDE 'TC3.CIN' INCLUDE 'U.CIN' INCLUDE 'UC3.CIN' C DO 10 J = 1, 36 10 RL(J) = RSHL(J) IF (NORD1 .GE. 2) THEN DO 20 J = 1, 105 20 TL(J) = TSHL(J) ENDIF IF (NORD1 .GE. 3) THEN DO 30 J = 1, 280 30 UL(J) = USHL(J) ENDIF RETURN END SUBROUTINE RSTORC C C TRANSFERS MATRIX RS TO RC C C ---------------------------------------------------------------------- INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'RC.CIN' INCLUDE 'RS.CIN' INCLUDE 'TC.CIN' INCLUDE 'TS.CIN' INCLUDE 'UC.CIN' INCLUDE 'US.CIN' C DO 10 JK = 1, 36 10 RCL(JK) = RSL(JK) IF (NORD2 .GE. 2) THEN DO 20 JKM = 1, 105 20 TCL(JKM) = TSL(JKM) ENDIF IF (NORD2 .GE. 3) THEN DO 30 JKLM = 1, 280 30 UCL(JKLM) = USL(JKLM) ENDIF RETURN END SUBROUTINE RTORO C C TRANSFERS MATRIX R TO RO C C ---------------------------------------------------------------------- INCLUDE 'ELM17A.CIN' INCLUDE 'R.CIN' INCLUDE 'RO.CIN' INCLUDE 'T.CIN' INCLUDE 'TO.CIN' INCLUDE 'U.CIN' INCLUDE 'UO.CIN' C DO 10 JK = 1, 36 10 ROL(JK) = RL(JK) IF (NORD1 .GE. 2) THEN DO 20 JKM = 1, 105 20 TOL(JKM) = TL(JKM) ENDIF IF (NORD1 .GE. 3) THEN DO 30 JKLM = 1, 280 30 UOL(JKLM) = UL(JKLM) ENDIF RETURN END SUBROUTINE RTORS C C TRANSFERS MATRIX R TO RS C C ---------------------------------------------------------------------- INCLUDE 'ELM17A.CIN' INCLUDE 'R.CIN' INCLUDE 'RS.CIN' INCLUDE 'T.CIN' INCLUDE 'TS.CIN' INCLUDE 'U.CIN' INCLUDE 'US.CIN' C DO 10 JK = 1, 36 10 RSL(JK) = RL(JK) IF (NORD1 .GE. 2) THEN DO 20 JKM = 1, 105 20 TSL(JKM) = TL(JKM) ENDIF IF (NORD1 .GE. 3) THEN DO 30 JKLM = 1, 280 30 USL(JKLM) = UL(JKLM) ENDIF RETURN END SUBROUTINE RTORSH C C TRANSFERS MATRIX R TO RSH C C ---------------------------------------------------------------------- INCLUDE 'ELM17A.CIN' INCLUDE 'R.CIN' INCLUDE 'RC3.CIN' INCLUDE 'T.CIN' INCLUDE 'TC3.CIN' INCLUDE 'U.CIN' INCLUDE 'UC3.CIN' C DO 10 JK = 1, 36 10 RSHL(JK) = RL(JK) IF (NORD1 .GE. 2) THEN DO 20 JKM = 1, 105 20 TSHL(JKM) = TL(JKM) ENDIF IF (NORD1 .GE. 3) THEN DO 30 JKLM = 1, 280 30 USHL(JKLM) = UL(JKLM) ENDIF RETURN END SUBROUTINE SECORD C C CALCULATES NUMERICAL VALUE OF SECOND-ORDER MATRIX ELEMENTS C C ---------------------------------------------------------------------- INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'BETAC.CIN' INCLUDE 'CONSTS.CIN' INCLUDE 'DATA0A.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM0B.CIN' INCLUDE 'ELM0C.CIN' INCLUDE 'ELM1A.CIN' INCLUDE 'ELM1F.CIN' INCLUDE 'ELM4A.CIN' INCLUDE 'ELM4B.CIN' INCLUDE 'ELM5A.CIN' INCLUDE 'ELM5B.CIN' INCLUDE 'ELM14A.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'ELM15C.CIN' INCLUDE 'ELM16B.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'ELM19.CIN' INCLUDE 'INDBND.CIN' INCLUDE 'R.CIN' INCLUDE 'T.CIN' C ---------------------------------------------------------------------- INTEGER VARST EXTERNAL IDATA C IF (TYPE .EQ. 14 .AND. TYP1 .EQ. 14) GO TO 1400 DO 11 IA = 1, 105 11 TL(IA) = 0.0 IF (RI .NE. 0.0) THEN GI2 = SM**2/(SM**2 + RI**2) ELSE GI2 = 0.0 ENDIF GO TO (5100, 200, 300, 400, 500,5200,5200,5200,5200,5200, 1 5200,5200,5200,1400,5200,5200,5200,1800,1900,5000, 2 5200,5200,5200,5200,5100,5200,5200,5200,5200,5200, 3 5200,5200,5200,3400,3500,3500,5200,5200,5200,5200, 4 5200,5200,5200,5200,5200,5200,5200,5200), TYPEC C C 2. -- POLE FACE ROTATION C 200 CALL FRING2 GO TO 5100 C C 3. -- DRIFT SPACE C 300 TANFO = TAN(FOTILT/RADIAN) T(3,7) = TANFO T(1,2) = TANFO 310 T(5,3) = - 0.5*L T(5,10) = - 0.5*L GO TO 5000 C C 4. -- BENDING MAGNET C 400 IF (H0 .EQ. 0) GO TO 310 RH = 1.0 + RMPS H = H0*RH HEX = RMPS*H0 BEB = BDB/(H0*UNITI(1))**2 CALL SECORS C 410 IF (RNMS .EQ. 0.0 .AND. VARST(NRNMS) .EQ. 0) GO TO 480 IF ((VRN .EQ. 0.0 .AND. NPN .EQ. 0.0 .AND. BDBP .EQ. 0.0) 1 .AND. (VARST(NVR) .EQ. 0 .AND. VARST(NNP) .EQ. 0 2 .AND. VARST(NK1P) .EQ. 0 .AND. VARST(NBDBP) .EQ. 0) 3 .AND. VARST(NK2P) .EQ. 0) GO TO 480 NBR = RH*NB VR = RNMS*VRN NPR = RNMS*NPN BEP = RNMS*BDBP/(H0*UNITI(1))**2 CALL SECORN 480 GO TO 5000 C C 5. -- QUADRUPOLE C 500 JQUAD = 1 KQ2 = KX2 CALL FOCUS2 JQUAD = 3 KQ2 = KY2 CALL FOCUS2 GO TO 5000 C C 14. -- ARBITRARY MATRIX C 1400 I14S = IDATA(I+8) IF (I14S .NE. 0) GO TO 1420 IX = I + 9 IND0 = 0 DO 1410 J = 1, 6 IND0 = IND0 + J IND = IND0 DO 1408 K = J, 6, 1 T(J1,IND) = DATA(IX)*UBEAM(J1)/(UBEAM(J)*UBEAM(K)) IND = IND + K IX = IX + 1 1408 CONTINUE 1410 CONTINUE 1420 IF (NDIF .EQ. 1 .AND. NUM + 1 .GT. NEL) GO TO 5100 IF (NDIF .EQ. -1 .AND. NUM - 1 .LE. 0) GO TO 5100 GO TO 5100 C C 18. -- SEXTUPOLE C 1800 CALL SEXT2 GO TO 5000 C C 19. -- SOLENOID C 1900 CS = COS(KL) SN = SIN(KL) TEMP = 0.5*KO*L*SN T(1,16) = TEMP T(2,17) = TEMP T(3,18) = TEMP T(4,19) = TEMP T(1,17) = SN/KO - L*CS T(3,19) = T(1,17) TEMP = - 0.5*KO*L*CS T(1,18) = TEMP T(2,19) = TEMP T(4,17) = - TEMP T(3,16) = - TEMP T(1,19) = (1.0 - CS)/KO - L*SN T(3,17) = - T(1,19) T(2,16) = 0.25*KO*(KO*L*CS + SN) T(4,18) = T(2,16) T(2,18) = 0.25*KO*(1.0 - CS + KO*L*SN) T(4,16) = - T(2,18) T(5,3) = - 0.5*L T(5,10) = - 0.5*L GO TO 5000 C C 34. -- PLASMA LENS C 3400 J = 1 KQ2 = KX2 3410 CS = R(J,J) SK = - R(J+1,J) SN = R(J,J+1) T(J,J+15) = SK * L / 2. T(J+1,J+16) = SK * L / 2. T(J,J+16) = (SN - L*CS)/2.0 T(J+1,J+15) = (SK + KQ2*L*CS)/2.0 T(5,J*(J+1)/2) = - 0.25*KQ2*(L - SN*CS) T(5,J*(J+3)/2) = 0.5*SN*SK T(5,J*(J+3)/2+1) = - 0.25*(L + CS*SN) IF (J .NE. 1) GO TO 5000 J = 3 KQ2 = KY2 GO TO 3410 C C 35. -- HKICK -- HORIZONTAL VERNIER C OR C 36. -- VKICK -- VERTICAL VERNIER C 3500 T(1,3) = - 0.75*H0*L**2 T(1,10) = - 0.25*H0*L**2 T(1,21) = - 0.5*H0*L**2 T(2,3) = - 1.5*H0*L T(2,10) = - 0.5*H0*L T(2,21) = - H0*L T(3,8) = - 0.5*H0*L**2 T(4,8) = - H0*L T(5,3) = - 0.5*L T(5,10) = - 0.5*L T(5,17) = - 0.5*H0*L**2 GO TO 5000 C C PATH LENGTH TERMS C 5000 T(5,21) = T(5,21) - 1.5*L*BETA**2*GI2 C C CHANGE TRIANGULAR MATRIX INTO SQUARE MATRIX C 5100 IF (NORD1 .GE. 3) CALL THOR 5200 CONTINUE RETURN END SUBROUTINE SEPTUM C C CALCULATES R MATRIX FOR AN ELECTROSTATIC SEPTUM C INCLUDE 'BETAC.CIN' INCLUDE 'CONSTS.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0B.CIN' INCLUDE 'ELM1A.CIN' INCLUDE 'ELM6.CIN' INCLUDE 'ELM7B.CIN' INCLUDE 'ELM10E.CIN' INCLUDE 'ELM13B.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'ELM16B.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'ELM41.CIN' INCLUDE 'INDPAR.CIN' INCLUDE 'R.CIN' C IL = IPTOJ(1) IV = IPTOJ(2) IAP = IPTOJ(3) IE = IPTOJ(4) L = DATAR(I+IL)*UNITI(8) IF (IV .NE. 0 .AND. IAP .NE. 0) GO TO 10 IF (IE .NE. 0) GO TO 20 EFIELD = 0.0 GO TO 30 C 10 VOLTS = DATAR(I+IV)*UNITI(14) AP = DATAR(I+IAP)*UNITI(1) EFIELD = VOLTS/AP GO TO 30 C 20 EFIELD = DATAR(I+IE)*UNITI(14)/UNITI(1) C 30 IF (NORD1 .LT. 1) GO TO 100 AL = EFIELD*L*10.0**10/(CLIGHT*RI*BETA) B2M2 = BETA**2 - 2.0 COD(3) = 0.5*L*AL COD(4) = AL R(1,2) = L R(3,4) = L R(3,6) = 0.5*B2M2*AL*L R(4,6) = B2M2*AL IF (SM .NE. 0.0 .AND. RI .NE. 0.0) R(5,6) = L/GAMMA**2 IF (AL .NE. 0.0) THEN DCOV = .TRUE. IF (BAX) R1P = .TRUE. ENDIF C 100 RETURN END SUBROUTINE SEXGET C C FETCHES VALUES OF PARAMETERS FOR A SEXTUPOLE C C ---------------------------------------------------------------------- INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM0B.CIN' INCLUDE 'ELM1A.CIN' INCLUDE 'ELM4A.CIN' INCLUDE 'ELM4C.CIN' INCLUDE 'ELM5A.CIN' INCLUDE 'ELM6.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'ELM16B.CIN' INCLUDE 'ELM26B.CIN' INCLUDE 'FLUSHC.CIN' INCLUDE 'INDPAR.CIN' INCLUDE 'IOUNIT.CIN' INCLUDE 'XRAN.CIN' C REAL DATAR EXTERNAL DATAR, IDATA C C MAGNET LENGTH C IADR = I + 1 L = DATAR(IADR) IF (PRAN18(1) .NE. 0.0) L = L + PRAN18(1)*XRAN(1) L = L*UNITI(8) LMAG = L C C INDICES OF OTHER PARAMETERS C IB = IPTOJ(2) IAP = IPTOJ(3) IK2 = IPTOJ(4) C IF (IK2 .NE. 0) GO TO 20 IF (IB .NE. 0) GO TO 5 B = 0.0 K2 = 0.0 AP = 0.0 GO TO 40 C C MAGNETIC FIELD AND APERTURE C 5 IADR = I + IB B = DATAR(IADR) IF (PRAN18(2) .NE. 0.0) B = B + PRAN18(2)*XRAN(2) B = B*UNITI(9)*RI/PREF IF (IAP .NE. 0) THEN IADR = I + IAP AP = DATAR(IADR) ELSE WRITE (NOUT,9007) 9007 FORMAT (' *** ERROR *** SEXTUPOLE APERTURE NOT GIVEN') FLUSHL = .TRUE. K2 = 0.0 AP = 0.0 GO TO 40 ENDIF IF (AP .NE. 0.0) THEN IF (PRAN18(3) .NE. 0.0) 1 AP = AP + PRAN18(3)*XRAN(3) AP = AP*UNITI(1) K2 = B/(RI*AP**2) ELSE WRITE (NOUT,9006) 9006 FORMAT (' *** ERROR *** SEXTUPOLE APERTURE SET TO ZERO') FLUSHL = .TRUE. K2 = 0.0 ENDIF GO TO 40 C C NORMALIZED FIELD SECOND DERIVATIVE C 20 IADR = I + IK2 K2 = DATAR(IADR) IF (PRAN18(4) .NE. 0.0) 1 K2 = K2 + PRAN18(4)*XRAN(4) IF (MPMAD) K2 = 0.5*K2 K2 = K2/UNITI(8)**3 C 40 IT = IPTOJ(6) IF (IT .EQ. 0) THEN NUMTYP = IT ELSE NUMTYP = IDATA(I + IT) ENDIF RETURN END SUBROUTINE SEXT2 C C CALCULATES SECOND-ORDER TRANSFER MATRIX FOR A SEXTUPOLE C INCLUDE 'ELM0B.CIN' INCLUDE 'ELM4C.CIN' INCLUDE 'T.CIN' C------------------------------------------------------------------------------- C W2 = 2.*K2 S = - 0.25*W2*L T(1,1) = S*L T(2,1) = 2.0*S S = - W2*L**3/24. T(1,3) = S*L T(2,3) = 4.0*S S = 0.25*W2*L T(1,6) = S*L T(2,6) = 2.0*S S = W2*L**3/24. T(1,10) = S*L T(2,10) = 4.0*S S = - W2*L**2/6. T(1,2) = S*L T(2,2) = 3.0*S S = W2*L**2/6. T(1,9) = S*L T(2,9) = 3.0*S S = W2*L/2. T(3,4) = S*L T(4,4) = 2.0*S S = W2*L**2/6. T(3,5) = S*L T(3,7) = S *L T(4,5) = 3.0*S T(4,7) = 3.0*S S = W2*L**3/12. T(3,8) = S*L T(4,8) = 4.0*S T(5,3) = - 0.5*L T(5,10) = - 0.5*L RETURN END SUBROUTINE SEXT3 C C CALCULATES THIRD-ORDER TRANSFER MATRIX FOR A SEXTUPOLE C INCLUDE 'ELM0B.CIN' INCLUDE 'ELM4C.CIN' INCLUDE 'U.CIN' C------------------------------------------------------------------------------ C W2 = 2.0*K2 S = W2**2*L**3/48. U(1,1) = S*L U(2,1) = 4.0*S U(3,10) = S*L U(4,10) = 4.0*S S = W2**2*L**4/48. U(1,2) = S*L U(2,2) = 5.0*S U(3,16) = S*L U(4,16) = 5.0*S S = W2**2*L**5/144. U(1,3) = S*L U(2,3) = 6.0*S U(3,19) = S*L U(4,19) = 6.0*S S = W2**2*L**6/1008. U(1,4) = S*L U(2,4) = 7.*S U(3,20) = S*L U(4,20) = 7.*S S = W2**2*L**3/48. U(1,8) = S*L U(2,8) = 4.0*S U(3,5) = S*L U(4,5) = 4.0*S S = 0.025*W2**2*L**4 U(1,14) = S*L U(2,14) = 5.0*S U(3,6) = S*L U(4,6) = 5.0*S S = W2**2*L**5/240. U(1,17) = S*L U(2,17) = 6.0*S U(3,7) = S*L U(4,7) = 6.0*S S = - W2**2*L**4/240. U(1,9) = S*L U(2,9) = 5.0*S U(3,11) = S*L U(4,11) = 5.0*S S = W2**2*L**5/360. U(1,15) = S*L U(2,15) = 6.0*S U(3,12) = S*L U(4,12) = 6.0*S S = W2**2*L**6/1008. U(1,18) = S*L U(2,18) = 7.0*S U(3,13) = S*L U(4,13) = 7.0*S S = 0.25*W2*L U(1,36) = S*L U(2,36) = 2.0*S S = W2*L**3/24. U(1,38) = S*L U(2,38) = 4.0*S S = - 0.25*W2*L U(1,41) = S*L U(2,41) = 2.0*S S = - W2*L**3/24. U(1,45) = S*L U(2,45) = 4.0*S S = W2*L**2/6. U(1,37) = S*L U(2,37) = 3.0*S S = - W2*L**2/6. U(1,44) = S*L U(2,44) = 3.0*S S = - 0.5*W2*L U(3,39) = S*L U(4,39) = 2.0*S S = - W2*L**2/6. U(3,40) = S*L U(3,42) = S*L U(4,40) = 3.0*S U(4,42) = 3.0*S S = - W2*L**3/12. U(3,43) = S*L U(4,43) = 4.0*S RETURN END REAL FUNCTION SIGNF(X) C C RETURNS THE SIGN OF A NUMBER OR ZERO C C ---------------------------------------------------------------------- DATA XNORM /1.0/ IF (X .NE. 0.0) THEN SIGNF = SIGN(XNORM,X) ELSE SIGNF = 0. ENDIF RETURN END SUBROUTINE SNYDER C C CONSTRAINS COURANT-SNYDER PARAMETERS FOR BEAM C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM1B.CIN' INCLUDE 'ELM1D.CIN' INCLUDE 'ELM10A.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM10D.CIN' INCLUDE 'ELM15C.CIN' INCLUDE 'RC2.CIN' INCLUDE 'R2P.CIN' INCLUDE 'SI.CIN' INCLUDE 'SVP.CIN' C--------------------------------------------------------------------- LOGICAL LOGIC REAL AS(NPVAR+1), CAD(NPVAR+1), CADS(NPVAR+1) C IF (.NOT. RECENT) CALL BEAM J = JCON - 20 K = KCON JSAVE = J IF (J .GE. 5 .AND. J .NE. 7 .AND. J .NE. 8) GO TO 500 IF (J .EQ. 1 .OR. J .EQ. 3) THEN FAC = UBEAM(J+1)/UBEAM(J) ELSE IF (J .EQ. 2 .OR. J .EQ. 4) THEN J = J - 1 K = J + 1 FAC = -1.0 ELSE IF (J .EQ. 7 .OR. J .EQ. 8) THEN IF (J .EQ. 7) J = 1 IF (J .EQ. 8) J = 3 K = J FAC = UBEAM(J+1)/UBEAM(J) ENDIF SICC = SIT(J,K) KSAVE = K K = J + 1 SIJJ = SIT(J,J) SIJK = SIT(J,K) SIKK = SIT(K,K) EPSC = SQRT(SIJJ*SIKK - SIJK**2) IF (J .EQ. 1) THEN EPSX = EPSC ELSE EPSY = EPSC ENDIF COC = SICC*FAC/EPSC IF (JSAVE .GE. 7) COC = SQRT(COC) IF (NV3 .LT. 1) GO TO 100 CW = 1.0/SD**2 A(1) = DE0 - COC CALL CLI(LOGIC) IF (LOGIC) GO TO 500 C IF (NV1 .LT. 1) GO TO 100 K = KSAVE DO 40 N = 1, NV1 IF (.NOT. R2P) THEN IF (SVP(N)) THEN SVJK = SV(J,K,N) GO TO 30 ELSE GO TO 40 ENDIF ENDIF SVJK = 0.0 IF (SVP(N)) THEN DO 15 L1 = 1, 6 DO 15 L2 = 1, 6 SVJK = SVJK + RC2(J,L1)*SV(L1,L2,N)*RC2(K,L2) 15 CONTINUE ENDIF C IF (R2VP(N)) THEN DO 25 L1 = 1, 6 DO 25 L2 = 1, 6 SVJK = SVJK + R2V(J,L1,N)*SI(L1,L2)*RC2(K,L2) 1 + RC2(J,L1)*SI(L1,L2)*R2V(K,L2,N) 25 CONTINUE ENDIF 30 A(N+1) = SVJK*FAC/EPSC CAD(N+1) = CW*A(N+1)*A(N+1) 40 CONTINUE C IF (JSAVE .NE. 1 .AND. JSAVE .NE. 3) GO TO 100 IF (NV1 .LT. 1) GO TO 100 IF (.NOT. R2P) GO TO 100 DO 90 N = 1, NV1 SVJJ = 0.0 IF (R2VP(N)) THEN DO 55 L1 = 1, 6 DO 55 L2 = 1, 6 SVJJ = SVJJ + R2V(J,L1,N)*SI(L1,L2)*R2V(J,L2,N) 55 CONTINUE ENDIF C IF (R2VP(N) .AND. SVP(N)) THEN DO 65 L1 = 1, 6 DO 65 L2 = 1, 6 SVJJ = SVJJ + R2V(J,L1,N)*SV(L1,L2,N)*RC2(J,L2) 1 + RC2(J,L1)*SV(L1,L2,N)*R2V(J,L2,N) 65 CONTINUE ENDIF C AS(N+1) = SVJJ*FAC CADS(N+1) = A(1)*CW*AS(N+1) IF (CAD(N+1) .LT. CADS(N+1)) THEN DV = SIGN(SQRT(2.0*A(1)/AS(N+1)),A(N+1)) A(N+1) = A(N+1) + DV*AS(N+1) ENDIF 90 CONTINUE C 100 CALL GATHER 500 RETURN END SUBROUTINE SOLEN C C EVALUATES TRANSFER MATRIX FOR A SOLENOID C C ---------------------------------------------------------------------- INCLUDE 'BETAC.CIN' INCLUDE 'ELM0B.CIN' INCLUDE 'ELM1A.CIN' INCLUDE 'ELM5B.CIN' INCLUDE 'ELM16B.CIN' INCLUDE 'ELM19.CIN' INCLUDE 'R.CIN' C SN = SIN(KL) CS = COS(KL) R(4,4) = 0.5 + 0.5*CS R(3,3) = R(4,4) R(2,2) = R(4,4) R(1,1) = R(4,4) R(1,4) = (1.- CS)/KO R(3,2) = - R(1,4) R(4,1) = 0.25*KO*(1.- CS) R(2,3) = - R(4,1) R(4,2) = - 0.5*SN R(3,1) = R(4,2) R(2,4) = - R(3,1) R(1,3) = R(2,4) R(3,4) = R(1,3)*2./KO R(1,2) = R(3,4) R(4,3) = - 0.25*KO*SN R(2,1) = R(4,3) IF (SM .NE. 0.0 .AND. RI .NE. 0.0) R(5,6) = L/GAMMA**2 RETURN END SUBROUTINE SOLGET C C GET PARAMETERS DESCRIBING SOLENOID C C ---------------------------------------------------------------------- INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM0B.CIN' INCLUDE 'ELM1A.CIN' INCLUDE 'ELM4A.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'ELM16B.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'ELM19.CIN' INCLUDE 'ELM26B.CIN' INCLUDE 'INDPAR.CIN' INCLUDE 'XRAN.CIN' C INTEGER IADR, IB, IDATA, IK, IT REAL DATAR, DEN EXTERNAL DATAR, IDATA C IADR = I + 1 L = DATAR(IADR) IF (PRAN19(1) .NE. 0.0) L = L + PRAN19(1)*XRAN(1) L = L*UNITI(8) C IB = IPTOJ(2) IK = IPTOJ(3) IF (IK .NE. 0) GO TO 5 IADR = I + IB B = DATAR(IADR) IF (PRAN19(2) .NE. 0.0) B = B + PRAN19(2)*XRAN(2) B = B*UNITI(9)*RI/PREF IF (NORD1 .LT. 1) GO TO 10 KO = DEN(B/RI) KL = KO*L GO TO 10 C 5 IADR = I + IK KL = DATAR(IADR) IF (PRAN19(3) .NE. 0.0) 1 KL = KL + PRAN19(3)*XRAN(3) KL = 2.0*KL*UNITI(13) KO = KL/L C 10 IT = IPTOJ(4) IF (IT .EQ. 0) THEN NUMTYP = IT ELSE NUMTYP = IDATA(I + IT) ENDIF RETURN END SUBROUTINE SOLVE C C DIRECTS FITTING PROCEDURE AND PRINTS OUT RESULTS C C ---------------------------------------------------------------------- INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'BROAD.CIN' INCLUDE 'DATA0A.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM10D.CIN' INCLUDE 'ELM10E.CIN' INCLUDE 'ELM10F.CIN' INCLUDE 'ELM13B.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'FLUSHC.CIN' INCLUDE 'IOUNIT.CIN' INCLUDE 'STEPT1.CIN' C ---------------------------------------------------------------------- LOGICAL OK, CALT REAL GOLD, OUTPUT(20), PAR, R REAL CS(NPVAR+1) EQUIVALENCE (CS(1),CAOLD) C IF (.NOT. ONLY .AND. (.NOT. LSTEP .OR. NSTEPP .EQ. 1 1 .OR. BROAD)) 2 WRITE (NOUT,1000) NV3, NC 1000 FORMAT (1H0,8X,'*CORRECTIONS*',/, 1 1H ,8X,'*NUMBER OF VARIED PARAMETERS = ',I5,' *',/, 2 1H ,8X,'*NUMBER OF CONSTRAINTS = ',I5,' *',/) C C INITIALIZE VARIABLES AND MAKE FIRST PASS C NSTEP = -1 NGLESS = 0 IF (NCTE .EQ. 1) GO TO 10 DOPARS = .FALSE. NCTS = 1 NCTF = NCTE - 1 IF (LSTEPN) CALL STEPIT CALL MARCH IF (FLUSHL) GO TO 400 CALL RETAIN IF (FLUSHL) GO TO 400 NMARM = 0 NSTEPM = 0 10 NSTEP = 0 OK = .FALSE. NV2 = 0 CHSMIN = - 1.0 CALL FORM IF (NV1 .EQ. 0 .AND. NV3 .NE. 0) WRITE (NOUT,1001) NV1 1001 FORMAT (1H0,8X,'*NUMBER OF USED VARIED PARAMETERS = ',I5,' *',/, 1 1H ,8X,'*RUN DISCONTINUED*') IF (NV1 .EQ. 0) FLUSHL = .TRUE. IF (FLUSHL) GO TO 400 N1P1 = NV1 + 1 NMAR = 0 PAR = 0.0 PMARQ = PAR IF (LINEAR) GO TO 100 CRIT = AMAX0(1,NC-NV1) CALT = .FALSE. C C ITERATE FROM HERE IF NEW LOW CHI-SQUARED FOUND C 20 NSTEP = NSTEP + 1 IF (NSTEP .GT. 50) GO TO 200 CAOLD = CA(1,1) IF (CA(1,1) .LT. CRIT .AND. NMAR .EQ. 0) GO TO 100 CALL INQ DO 40 J = 2, N1P1 40 CS(J) = CA(J,1) EPS = 0.5**NMAR DS = 0.0 DO 42 J = 2, N1P1 42 DS = DS + CASAV(J,1)*CS(J) IF (NMAR .EQ. 0) GO TO 50 DSM = 0.0 DO 45 J = 2, N1P1 DMX = 0.0 DO 44 K = 2, N1P1 44 DMX = DMX + CASAV(J,K)*CS(K) 45 DSM = DSM + DMX*CS(J) DS = 2.0*DS - DSM 50 GOLD = GNORM CALL ALTER(CS) CSNORM = 0.0 DO 51 J = 2, N1P1 CSNORM = CSNORM + CS(J)**2 51 CONTINUE CSNORM = SQRT(CSNORM) IF (FLUSHL) GO TO 400 NMARO = NMAR CALL FORM IF (FLUSHL) GO TO 400 IF (NACTIV .EQ. 0) GO TO 210 CRIT = AMAX0(1,NC-NV1) IF (CA(1,1) .LT. CRIT) THEN IF (NMAR .EQ. 0) GO TO 100 IF (CALT) THEN IF (NSTEP .GE. NSTEPM + 10) GO TO 100 IF (NMAR .GT. NMARM) GO TO 100 ELSE NMARM = NMAR NSTEPM = NSTEP CALT = .TRUE. ENDIF ENDIF IF (DS .EQ. 0.0) THEN NACTIV = 0 DO 55 N = 2, N1P1 IF (ACTIV(N)) NACTIV = NACTIV + 1 55 CONTINUE IF (NACTIV .GE. 1) THEN GO TO 200 ELSE GO TO 210 ENDIF ENDIF C C REFERENCE ON WHEN TO CHANGE RELAXATION FACTOR C KLAUS HALBACH PAPER AT SECOND INTERNATIONAL C CONFERENCE ON MAGNET TECHNOLOGY AT OXFORD 1967 C C R = (CAOLD - CA(1,1))/DS DSCRIT = AMIN1(0.1*CA(1,1),CRIT) IF (R .GT. 0.8 .AND. R .LT. 1.2 1 .AND. DS .LT. DSCRIT .AND. NMAR .EQ. 0) GO TO 100 IF (GNORM .LT. 0.1*GOLD) NGLESS = NSTEP IF (DS .LT. CRIT .AND. (GNORM .LT. 0.1*GOLD .OR. 1 (NGLESS .GE. NSTEP - 1 .AND. NGLESS .NE. 0))) GO TO 100 60 IF (R .GT. 0.75) NMAR = MAX0(0,NMAR-1) IF (R .GT. 0.25) GO TO 20 80 IF (NMAR .GT. 6 .AND. CSNORM .LT. 0.00001) GO TO 200 NMAR = NMAR + 1 IF (NMAR .GT. 20) GO TO 200 IF (R .GT. 0.0) GO TO 20 90 DO 95 J = 2, N1P1 95 CS(J) = - CS(J) EPS = - 0.5**NMARO CALL ALTER(CS) DO 92 J = 1, N1P1 DO 92 K = 1, N1P1 92 CA(J,K) = CASAV(J,K) CALL INQ IF (FLUSHL) GO TO 400 DO 96 J = 2, N1P1 96 CS(J) = CA(J,1) EPS = 0.5**NMAR 97 CALL ALTER(CS) IF (FLUSHL) GO TO 400 NMARO = NMAR CALL FORM IF (FLUSHL) GO TO 400 IF (NACTIV .EQ. 0) GO TO 210 CRIT = AMAX0(1,NC-NV1) IF (CA(1,1) .EQ. 0.0 .OR. OK) GO TO 220 IF (CA(1,1) .LT. CRIT .AND. NMAR .EQ. 0) GO TO 100 IF (CA(1,1) .LT. CAOLD) THEN GO TO 20 ELSE GO TO 80 ENDIF C C FITTING PROCEDURE SATISFIES CONVERGENCE TEST C 100 OK = .TRUE. CALL INQ DO 140 J = 2, N1P1 140 CS(J) = CA(J,1) EPS = 0.5**NMAR CALL ALTER(CS) IF (FLUSHL) GO TO 400 CALL FORM IF (FLUSHL) GO TO 400 IF (NACTIV .EQ. 0) GO TO 210 IF (LINEAR) GO TO 220 IF (CA(1,1) .LT. CAOLD) GO TO 220 DO 145 J = 2, N1P1 145 CS(J) = - CS(J) GO TO 97 C C FAILURE TO CONVERGE -- PRINT OUT WARNING MESSAGE C 200 WRITE (NOUT,1012) 1012 FORMAT (1H0,8X,'*FAILED*',/) IF (NC .GT. NV1) WRITE (NOUT,1015) 1015 FORMAT (1H ,8X,'*NUMBER OF CONSTRAINTS EXCEEDS *',/, 1 1H ,8X,'*NUMBER OF VARIED PARAMETERS *',/, 2 1H ,8X,'*IF RESULTS ARE STILL CONSIDERED *',/, 3 1H ,8X,'*UNSATISFACTORY *') WRITE (NOUT,1014) 1014 FORMAT (1H ,8X,'*PLEASE SEND OUTPUT TO *',/, 1 1H ,8X,'*DAVE CAREY *',/, 2 1H ,8X,'*FERMILAB, P.O. BOX 500 *',/, 3 1H ,8X,'*BATAVIA, ILL 60510, USA *') GO TO 220 C C VARIED PARAMETERS ALL JAMMED UP AGAINST LIMITS C 210 WRITE (NOUT,9011) 9011 FORMAT (1H ,8X,'* VARIED PARAMETERS ALL JAMMED UP *',/, 1 1H ,8X,'* AGAINST LIMITS *',/, 2 1H ,8X,'* FURTHER ITERATION IS NOT POSSIBLE*') C C CONCLUSION OF FITTING - PRINT OUT RESULT C 220 CALL INQ IF (LSTEP .AND. .NOT. BROAD) GO TO 350 WRITE (NOUT,1013) CA(1,1) 1013 FORMAT (1H0,8X,'*COVARIANCE (FIT',E12.5,' )') IF (NV1 .LT. 1 .OR. ONLY) GO TO 400 CAMIN = 0.0 DO 250 J = 2, N1P1 CA(1,J) = SQRT(AMAX1(CA(J,J),CAMIN)) 250 CONTINUE C DO 300 J = 2, N1P1 IF (J .LE. 2) THEN WRITE (NOUT,1020) CA(1,J) ELSE JMIN1 = J - 1 DO 280 K = 2, JMIN1 OUTPUT(K) = CA(J,K) /(DEN(CA(1,J) * CA(1,K))) 280 CONTINUE WRITE (NOUT,1020) (OUTPUT(K), K = 2, JMIN1), CA(1,J) 1020 FORMAT (1X,10F12.3) ENDIF 300 CONTINUE GO TO 400 C 350 IF (NSTEPP .EQ. 1) WRITE (NOUT,1017) 1017 FORMAT (8X,'STEPPED PARAMETER VALUE',4X,'CHI-SQUARED',/) WRITE (NOUT,1016) DATA(ISTEP), CA(1,1) 1016 FORMAT (15X,F12.5,7X,E12.5) C 400 RETURN C END SUBROUTINE SPESHL C C HANDLES SPECIAL PARAMETERS (TYPE CODE 16) C C ---------------------------------------------------------------------- INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'BETAC.CIN' INCLUDE 'COCOM.CIN' INCLUDE 'COP.CIN' INCLUDE 'DATA0B.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0B.CIN' INCLUDE 'ELM0E.CIN' INCLUDE 'ELM1A.CIN' INCLUDE 'ELM1D.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'ELM15C.CIN' INCLUDE 'ELM16A.CIN' INCLUDE 'ELM16B.CIN' INCLUDE 'ELM17B.CIN' INCLUDE 'ISEEDX.CIN' C C LOCAL VARIABLES C EXTERNAL IDATA C J = NPARS IADR = I + 2 5 NVARY = TIE(IADR) IF (NVARY .EQ. 100) THEN IADR = IDATA(IADR) GO TO 5 ENDIF C GO TO ( 10, 20, 30, 40, 40, 60, 70, 80, 90,100, 1 110,120,130,140,150,160,160,160,160,160, 2 210,220,230,240,250,260,270,900), J C C BENDING MAGNET FIELD SECOND DERIVATIVE C 10 BDBI = PARAM VARS(7) = NVARY GO TO 900 C C FRINGING FIELD TRANSVERSE DISPLACEMENT INTEGRAL C 20 LAYKI = PARAM GO TO 900 C C PARTICLE MASS C 30 SM = PARAM*UNITI(10) IF (RI .NE. 0.0 .AND. SM .NE. 0.0) THEN E = SQRT(SM**2 + RI**2) BETA = RI/E GAMMA = E/SM ENDIF GO TO 900 C C BENDING MAGNET APERTURES C 40 APBI(J-3) = PARAM GO TO 900 C C CUMULATIVE LENGTH OF SYSTEM C 60 LC = PARAM*UFLOOR(1) IF (NV1 .GE. 1) THEN DO 65 N = 1, NV1 LCV(N) = 0.0 65 CONTINUE ENDIF GO TO 900 C C FRINGING FIELD INTEGRALS C 70 LAYLI = PARAM GO TO 900 80 LAYXI = PARAM GO TO 900 C C JUNK C 90 RDL = PARAM GO TO 900 C 100 RDB = PARAM GO TO 900 C C DESIGN MOMENTUM C 110 P = RI*(1.0 + CO(6)) RI = PARAM*UNITI(11) CO(6) = P/RI - 1.0 IF (.NOT. LPRF) PREF = RI SOFA = .TRUE. RECENT = .FALSE. GO TO 900 C C BENDING MAGNET ENTRANCE AND EXIT FACE CURVATURES C 120 RAB1I = PARAM VARS(1) = NVARY GO TO 900 C 130 RAB2I = PARAM VARS(2) = NVARY GO TO 900 C C SEED FOR RANDOM NUMBER GENERATOR C 140 CALL RANSET(ISEEDX) C CALL RANSET(PARAM) GO TO 900 C C TILT OF FOCAL PLANE C 150 FOTILT = PARAM GO TO 900 C C FLOOR COORDINATES OF BEGINNING OF BEAM C 160 CALL FCSET GO TO 900 C C REFERENCE MOMENTUM FOR WHICH MAGNETIC FIELDS ARE SET C 210 PREF = PARAM*UNITI(11) LPRF = .TRUE. GO TO 900 C C EXCESS FIELD OF A BENDING MAGNET C 220 RMPSI = PARAM VARS(3) = NVARY GO TO 900 C C MULTIPLICATAVE CONSTANT FOR NON-MIDPLANE-SYMMETRIC MULTIPOLES C 230 RNMSI = PARAM VARS(4) = NVARY GO TO 900 C C VERTICALLY BENDING FIELD OF A BENDING MAGNET C 240 VRNI = PARAM VARS(5) = NVARY GO TO 900 C C NORMALIZED MIDPLANE-ANTISYMMETRIC QUADRUPOLE COMPONENT C 250 NPNI = PARAM VARS(6) = NVARY GO TO 900 C C NORMALIZED MIDPLANE-ANTISYMMETRIC SEXTUPOLE COMPONENT C 260 BDBPI = PARAM VARS(8) = NVARY GO TO 900 C C BENDING MAGNET FIELD THIRD DERIVATIVE C 270 GAMI = PARAM VARS(9) = NVARY GO TO 900 C C UNDEFINED OPERATIONS C 900 RETURN END SUBROUTINE SPREAD C C EXPAND DATA STORAGE TO HOLD COORDINATE TRANSFORMATIONS FROM C MISALIGNMENTS C C ---------------------------------------------------------------------- INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA0A.CIN' INCLUDE 'DATA0B.CIN' INCLUDE 'DATA1A.CIN' INCLUDE 'DATA1B.CIN' INCLUDE 'DATA1C.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'DATA2D.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM24D.CIN' INCLUDE 'ELM38B.CIN' INCLUDE 'FLUSHC.CIN' INCLUDE 'ICOPY.CIN' INCLUDE 'INDPAR.CIN' INCLUDE 'LIMITS.CIN' INCLUDE 'RDCARD.CIN' C EXTERNAL IDATA C IIOLD = 0 CALL EXILE C ISTOR(1) = 1 NUM = NELLIM - NEL + 1 NDIF = 1 NEL = 0 I = 1 I100 = 0 IB100 = ISTOR(NUM) CALL FND100 C IF (NUM .GE. NELLIM + 1) GO TO 5300 50 II = ISTOR(NUM) TYPE = IABS(IDATA(II)) LABLE = LABEL(NUM) NPARMS = 0 IF (NUSE .EQ. 0 .AND. II .LT. IIOLD) GO TO 5000 CALL SKETCH(NUM) NPOLD = NPARMS IF (TYPE .LE. 0 .OR. TYPE .GE. 50) GO TO 5000 IF (TYPE .EQ. 3) GO TO 300 IF (TYPE .EQ. 5) GO TO 500 IF (TYPE .EQ. 6) GO TO 600 IF (TYPE .EQ. 8) GO TO 800 IF (TYPE .EQ. 18) GO TO 1800 IF (TYPE .EQ. 24) GO TO 2400 IF (TYPE .EQ. 28 .OR. TYPE .EQ. 29) GO TO 2800 IF (TYPE .EQ. 30) GO TO 3000 IF (TYPE .EQ. 35 .OR. TYPE .EQ. 36) GO TO 3500 IF (TYPE .EQ. 37) GO TO 3700 GO TO 5000 C C 3. -- DRIFT C 300 NPSAVE = NPARMS CALL FIX23L CALL FIX23H NPARMS = NPSAVE NPOLD = NPARMS GO TO 5000 C C 5. -- QUAD C 500 GO TO 4500 C C 6. -- UPDATE C 600 NSLIT = INT(DATA(II+1)) IF (NSLIT .EQ. 0) THEN IUP = INT(DATA(II+2)) IF (IUP .EQ. 1 .OR. IUP .EQ. 2) THEN IADR = II + IPTOJ(4) NPARMS = NPARMS + IDATA(IADR) ENDIF ENDIF GO TO 5000 C C 8. -- MISALIGNMENT C 800 NPARMS = 21 GO TO 5000 C C 18. -- SEXTUPOLE C 1800 GO TO 4500 C C 24. -- DEFINED SECTION C 2400 IF (NUM .EQ. NUSE) THEN NUSE = NEL + 1 ENDIF JDEF = IDATA(II+1) IF (JDEF .EQ. 1 .OR. JDEF .EQ. 2) NPARMS = 1 IF (JDEF .EQ. 3 .OR. JDEF .EQ. 4) NPARMS = 3 GO TO 5000 C C 28. -- RBEND OR 29. -- SBEND C 2800 GO TO 4500 C C 30. -- PARAMETERS C 3000 NPARMT = NPARMS CALL FIX23L CALL FIX23H NPARMS = NPARMT IF (TIE(II+1) .EQ. 99) NPARMS = NPVAR + 1 GO TO 5000 C C 35. -- HKICK OR 36. -- VKICK C 3500 GO TO 4500 C C 37. -- ALIGNMENT MARKER C 3700 NSLIT = INT(DATA(II+1)) IF (NSLIT .EQ. 0) THEN IUP = INT(DATA(II+2)) IF (IUP .EQ. 1 .OR. IUP .EQ. 2) THEN IADR = II + IPTOJ(4) NPARMS = NPARMS + IDATA(IADR) ENDIF ENDIF GO TO 5000 C C REVISE REFERENCES ON MISALIGNMENTS C 4500 CALL FIX8H GO TO 5000 C C CHANGE REFERENCES TO PHYSICAL PARAMETERS C 5000 NEL = NEL + 1 IF (NUSE .EQ. 0 .AND. II .LT. IIOLD) GO TO 5100 NP1 = NPOLD + 1 IIPN = II + NPARMS IF (I100 .EQ. 0 .OR. I100 .GT. IIPN) GO TO 5020 DO 5010 J = 1, NP1 IADR = II + J IF (IADR .EQ. I100) THEN IANEW = ISTOR(NEL) + J CALL FIXREF CALL FND100 IF (I100 .GT. IIPN) GO TO 5020 ENDIF 5010 CONTINUE C C COPY ELEMENT TO LIST AT BEGINNING OF DATA ARRAY C 5020 DO 5030 J = 1, NP1 I1 = II + J - 1 DATA(I) = DATA(I1) TIE(I) = TIE(I1) I = I + 1 5030 CONTINUE ICOPY = I1 IF (NPARMS .GT. NPOLD) THEN NP2 = NP1 + 1 NP1 = NPARMS + 1 DO 5040 J = NP2, NP1 DATA(I) = 0.0 TIE(I) = 0 I = I + 1 5040 CONTINUE ENDIF IF (.NOT. FLUSHL) ISTOR(NEL+1) = I IIOLD = MAX0(II,IIOLD) GO TO 5180 C 5100 IF (NEL .EQ. 0) GO TO 5180 DO 5120 NN = 1, NEL NNN = NN IF (LABEL(NN) .EQ. LABLE) GO TO 5150 5120 CONTINUE 5150 ISTOR(NEL) = ISTOR(NNN) IF (.NOT. FLUSHL) ISTOR(NEL+1) = I C 5180 NDESCR(NEL) = NDESCR(NUM) LABEL(NEL) = LABLE C 5200 NUM = NUM + 1 IF (NUM .LE. NELLIM) GO TO 50 C 5300 RETURN END SUBROUTINE SQUIRM C C PARTIAL DERIVATIVES OF FLOOR COORDINATE TRANSFORMATIONS C C ---------------------------------------------------------------------- INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'COCOM.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM0C.CIN' INCLUDE 'ELM0E.CIN' INCLUDE 'ELM2B.CIN' INCLUDE 'ELM7B.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM13A.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'ELM15C.CIN' INCLUDE 'ELM16A.CIN' INCLUDE 'ELM20.CIN' INCLUDE 'FLUSHC.CIN' INCLUDE 'INDBND.CIN' INCLUDE 'OC.CIN' INCLUDE 'OIV.CIN' INCLUDE 'R.CIN' C DO 50 J = 1, 3 XIV(J) = 0.0 DO 50 K = 1, 3 OIV(J,K) = 0.0 50 CONTINUE C IF (TYPEC .EQ. 20) GO TO 2000 IF (TYPE .EQ. 2) GO TO 200 IF (TYPE .EQ. 3) GO TO 300 IF (TYPE .EQ. 4) GO TO 400 IF (TYPE .EQ. 5) GO TO 500 IF (TYPE .EQ. 13) GO TO 1300 IF (TYPE .EQ. 14) GO TO 1400 IF (TYPE .EQ. 16) GO TO 1600 IF (TYPE .EQ. 19) GO TO 1900 IF (TYPE .EQ. 28 .OR. TYPE .EQ. 29) GO TO 2800 IF (TYPE .EQ. 43) GO TO 4300 GO TO 5020 C C 2. -- POLE FACE ROTATION C 200 GO TO 5000 C C 3. -- DRIFT SPACE C 300 XIV(3) = UNITI(8) GO TO 5020 C C 4. -- BENDING MAGNET C 400 IF (JV .GE. 5) GO TO 470 CALL DFBEND IF (FLUSHL) GO TO 5020 C 470 GO TO 5000 C C 5. -- QUADRUPOLE C 500 IF (JV .NE. 1) GO TO 5000 XIV(3) = UNITI(8) GO TO 5000 C C 13. -- REALIGN BEAM LINE ALONG BEAM CENTROID C 1300 XPR = COF(2) YPR = COF(4) WPXP = SQRT(1.0 + XPR**2) WPXYP = SQRT(1.0 + XPR**2 + YPR**2) DSTDXP = 1.0/WPXP**3 DCTDXP = - XPR/WPXP**3 DSPDXP = - XPR*YPR/WPXYP**3 DCPDXP = XPR*YPR**2/(WPXP*WPXYP**3) DSPDYP = (1.0 + XPR**2)/WPXYP DCPDYP = - YPR*WPXP/WPXYP**3 SINT = - O(1,1,3) COST = O(1,1,1) SINP = O(1,3,2) COSP = O(1,2,2) XIV(1) = COV(1,NV2) XIV(2) = COV(3,NV2) OIV(1,1) = DCTDXP*COV(2,NV2) OIV(1,3) = - DSTDXP*COV(2,NV2) OIV(2,1) = - (SINP*DSTDXP + DSPDXP*SINT)*COV(2,NV2) 1 - DSPDYP*COV(4,NV2)*SINT OIV(2,2) = DCPDXP*COV(2,NV2) + DCPDYP*COV(4,NV2) OIV(2,3) = - (COST*DSPDXP + DCTDXP*SINP)*COV(2,NV2) 1 - COST*DSPDYP*COV(4,NV2) OIV(3,1) = (SINT*DCPDXP + DSTDXP*COSP)*COV(2,NV2) 1 + SINT*DCPDYP*COV(4,NV2) OIV(3,2) = DSPDXP*COV(2,NV2) + DSPDYP*COV(4,NV2) OIV(3,3) = (DCTDXP*COSP + COST*DCPDXP)*COV(2,NV2) 1 + COST*DCPDYP*COV(4,NV2) GO TO 5000 C C 14. -- ARIBTRARY MATRIX C 1400 GO TO 5020 C C 16. -- SPECIAL PARAMETERS C 1600 J = NPARS IF (JV .NE. 2) GO TO 5000 IF (J .GE. 16 .AND. J .LE. 18) GO TO 1610 IF (J .EQ. 19) GO TO 1620 IF (J .EQ. 20) GO TO 1630 GO TO 5020 C 1610 XIV(J-15) = UFLOOR(1) GO TO 5020 C 1620 OIV(1,1) = - O(4,1,3)*UFLOOR(2) OIV(3,3) = OIV(1,1) OIV(1,3) = - O(4,1,1)*UFLOOR(2) OIV(3,1) = - OIV(1,3) GO TO 5020 C 1630 OIV(2,2) = O(1,2,3)*UFLOOR(2) OIV(2,3) = - O(1,2,2)*UFLOOR(2) OIV(3,2) = - OIV(2,3) OIV(3,3) = OIV(2,2) GO TO 5020 C C 19. -- SOLENOID C 1900 IF (JV .NE. 1) GO TO 5000 XIV(3) = UNITI(8) GO TO 5020 C C 20. -- BEAM ROTATION C 2000 IF (REFER) GO TO 5000 DTH = DPARM*UNITI(13) IF (TYPE .NE. 20 .AND. .NOT. BEFORE) DTH = - DTH DCS = - R(2,4)*DTH IF (NDIF .LT. 0) DCS = - DCS OIV(1,1) = DCS OIV(2,2) = DCS DSN = R(4,4)*DTH IF (NDIF .LT. 0) DSN = - DSN OIV(1,2) = DSN OIV(2,1) = - DSN GO TO 5020 C C 28. -- RECTANGULAR BENDING MAGNET C 2800 IF (TYPEC .EQ. 2) GO TO 5020 IF (TYPEC .EQ. 20) GO TO 2820 CALL DFBEND IF (FLUSHL) GO TO 5020 IF (JV .EQ. NTILT) GO TO 5020 GO TO 5000 C 2820 GO TO 5020 C C 43. -- COORDINATE SYSTEM SHIFT C 4300 CALL DSHFT IF (JV .NE. 2 .AND. JV .NE. 4 .AND. JV .NE. 5 .AND. JV .NE. 6) 1 GO TO 5020 GO TO 5000 C C RETURN C 5000 IF (REFER .AND. TOTROT .NE. 0.0) CALL ROTATC(NV2) 5020 RETURN END SUBROUTINE STEPIT INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA0A.CIN' INCLUDE 'STEPT1.CIN' C DATA(ISTEP) = STLO + FLOAT(NSTEPP - 1)*STEP RETURN END SUBROUTINE SURVEY C C PRINTING OF FLOOR COORDINATES C C ---------------------------------------------------------------------- INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'CONSTS.CIN' INCLUDE 'DATA1C.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0B.CIN' INCLUDE 'ELM13B.CIN' INCLUDE 'ELM13C.CIN' INCLUDE 'ELM15B.CIN' INCLUDE 'ELM15C.CIN' INCLUDE 'IOUNIT.CIN' INCLUDE 'OC.CIN' INCLUDE 'YAW.CIN' C ---------------------------------------------------------------------- INTEGER J REAL ALONG, CSY, SHIFT, SNY REAL POS(3) C ALONG = LC/UFLOOR(1) DO 10 J = 1, 3 POS(J) = X0(4,J)/UFLOOR(1) 10 CONTINUE C CSY = O(4,3,3) SNY = O(4,3,1) IF (CSY .EQ. 0.0) THEN IF (SNY .GT. 0.0) YAW = 0.5*PI IF (SNY .LT. 0.0) YAW = - 0.5*PI ELSE YAW = ATAN(SNY/CSY) IF (CSY .LT. 0.0) THEN SHIFT = SIGN(PI,SNY) YAW = YAW + SHIFT ENDIF YAW = YAW/UFLOOR(2) ENDIF C PITCH = ASIN(O(4,3,2))/UFLOOR(2) C IF (O(4,2,2) .NE. 0.0) ROLL = ATAN(O(4,1,2)/O(4,2,2)) IF (O(4,2,2) .EQ. 0.0 .AND. O(4,1,2) .GT. 0.0) ROLL = 0.5*PI IF (O(4,2,2) .EQ. 0.0 .AND. O(4,1,2) .LT. 0.0) ROLL = - 0.5*PI IF (O(4,2,2) .LT. 0.0) THEN SHIFT = SIGN(PI,O(4,1,2)) ROLL = ROLL + SHIFT ENDIF ROLL = ROLL/UFLOOR(2) C IF (UFLOOR(2) .LE. 0.1) THEN WRITE (NOUT,1000) ALONG, XFLOOR(1), POS, XFLOOR(1), YAW, PITCH, 1 ROLL, XFLOOR(2) ELSE WRITE (NOUT,1001) ALONG, XFLOOR(1), POS, XFLOOR(1), YAW, PITCH, 1 ROLL, XFLOOR(2) ENDIF C IF (LAY191) 1 WRITE (NOUT,1002) LABEL(NUM), ALONG, POS, YAW, PITCH, ROLL C 1000 FORMAT (1H ,8X,F10.3,1X,A4,9X,3F11.4,1X,A4,1X,3F10.3,1X,A4) 1001 FORMAT (1H ,5X,F15.6,1X,A4,8X,3F13.5,1X,A4,1X,3F12.6,1X,A4) 1002 FORMAT (2H %,A4,F12.5,6E18.10) LCPR = .TRUE. RETURN END SUBROUTINE TFL C C DISTURBANCE AT MAGNET EXIT TO TRANSPORT VARIABLES DUE TO C MISALIGNMENT C C ---------------------------------------------------------------------- C INCLUDE 'ELM8D.CIN' INCLUDE 'ELM8H.CIN' C C LOCAL VARIABLES C INTEGER J, JK, K, N REAL S C DO 10 JK = 1, 36 10 CTL(JK) = 0.0 CT1(1,2) = XR(3) CT1(2,1) = - CT1(1,2) CT1(3,1) = XR(2) CT1(1,3) = - CT1(3,1) CT1(2,3) = XR(1) CT1(3,2) = - CT1(2,3) C DO 30 J = 1, 3 DO 30 K = 1, 3 CT(2*J-1,2*K-1) = OR(J,K) S = 0.0 DO 20 N = 1, 3 S = S + OR(J,N)*CT1(N,K) 20 CONTINUE CT(2*J-1,2*K) = S 30 CONTINUE C DO 40 K = 1, 3 CT(2,2*K) = OR(2,K) CT(4,2*K) = - OR(1,K) 40 CONTINUE C DO 50 J = 1, 6 50 CONTINUE RETURN END SUBROUTINE THOR C C CALCULATES THIRD-ORDER MATRIX ELEMENTS C C ---------------------------------------------------------------------- INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA0A.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM0B.CIN' INCLUDE 'ELM0C.CIN' INCLUDE 'ELM4A.CIN' INCLUDE 'ELM4B.CIN' INCLUDE 'ELM5A.CIN' INCLUDE 'ELM5B.CIN' INCLUDE 'ELM14A.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'ELM15C.CIN' INCLUDE 'U.CIN' C INTEGER IA, IDATA, IND, IND0, IND1, IX, K, M EXTERNAL IDATA C ---------------------------------------------------------------------- C IF (TYPE .EQ. 14 .AND. TYP1 .EQ. 14) GO TO 1400 DO 11 IA = 1, 280 11 UL(IA) = 0.0 GO TO (5000, 200, 300, 400, 500,5000,5000,5000,5000,5000, 1 5000,5000,5000,1400,5000,5000,5000,1800,1900,5000, 2 5000,5000,5000,5000,2500,5000,5000,5000,5000,5000, 3 5000,5000,5000,3400,3500,3500,5000,5000,5000,5000, 4 5000,3500,5000,5000,5000,5000,5000,5000), TYPEC C C 2. -- POLE FACE ROTATION C 200 CALL FRING3 GO TO 5000 C C 3. -- DRIFT SPACE C 300 CONTINUE GO TO 5000 C C 4. -- BENDING MAGNET C 400 IF (H0 .EQ. 0) GO TO 5000 H = (1.0 + RMPS)*H0 GAB = GAM/(H0*UNITI(1))**3 C CALL THORC CALL THORS CALL THORD CALL THORU GO TO 5000 C C 5. -- QUADRUPOLE C 500 JQUAD = 1 KQ2 = KX2 CALL FOCUS3 JQUAD = 3 KQ2 = KY2 CALL FOCUS3 GO TO 5000 C C 14. -- ARBITRARY MATRIX C 1400 IF (I14S .NE. 0) GO TO 1420 I14T = IDATA(I+30) IF (I14T .NE. 0) GO TO 1420 IX = I + 30 IND0 = 1 DO 1410 J = 1, 6 IND1 = IND0 DO 1408 K = J, 6 IND = IND1 DO 1406 M = K, 6 IX = IX + 1 U(J1,IND) = DATA(IX)*UBEAM(J1)/(UBEAM(J)*UBEAM(K)*UBEAM(M)) IND = IND + M*(M+1)/2 1406 CONTINUE IND1 = IND1 + K*(K+3)/2 1408 CONTINUE IND0 = IND0 + (J+1)*(J+2)/2 1410 CONTINUE 1420 IF (NUM + 1 .GT. NEL) GO TO 5000 IF (NEXT .EQ. 14) RETURN GO TO 5000 C C 18. -- SEXTUPOLE C 1800 CALL SEXT3 GO TO 5000 C C 19. -- SOLENOID C 1900 CONTINUE GO TO 5000 C C 25. -- OCTUPOLE C 2500 CALL OCTUPL GO TO 5000 C C 34. -- PLASMA LENS C 3400 CONTINUE GO TO 5000 C C 35. -- HKICK -- HORIZONTAL VERNIER C OR C 36. -- VKICK -- VERTICAL VERNIER C 3500 U(1,38) = 0.75*AL*L U(1,45) = 0.25*AL*L U(1,56) = 0.5*AL*L U(2,38) = 1.5*AL U(2,45) = 0.5*AL U(2,56) = AL U(3,43) = 0.5*AL*L U(4,43) = AL GO TO 5000 C C RETURN C 5000 RETURN END SUBROUTINE THREAD(NM,COR) C C ADVANCE BEAM CENTROID C C ---------------------------------------------------------------------- INCLUDE 'ELM17A.CIN' INCLUDE 'R.CIN' INCLUDE 'T.CIN' INCLUDE 'U.CIN' C ---------------------------------------------------------------------- INTEGER J, NM REAL COO(6), COR(6), COT(6) C C FIRST ORDER TERMS C DO 10 J = 1, 6 10 COO(J) = COR(J) IF (NM .EQ. 0) THEN CALL THRED1(R,COR) ELSE CALL THRED1(RV,COR) ENDIF C C SECOND-ORDER TERMS C IF (NORD1 .LE. 1) GO TO 100 DO 60 J = 1, 6 COT(J) = COR(J) 60 COR(J) = COO(J) IF (NM .EQ. 0) THEN CALL THRED2(T,COR) ELSE CALL THRED2(TV,COR) ENDIF C DO 70 J = 1, 6 70 COR(J) = COR(J) + COT(J) C C THIRD-ORDER TERMS C IF (NORD1 .LE. 2) GO TO 100 DO 80 J = 1, 6 COT(J) = COR(J) 80 COR(J) = COO(J) IF (NM .EQ. 0) THEN CALL THRED3(U,COR) ELSE CALL THRED3(UV,COR) ENDIF C DO 90 J = 1, 6 90 COR(J) = COR(J) + COT(J) C 100 RETURN END SUBROUTINE THRED1(RA,COR) C C FIRST-ORDER ADVANCEMENT OF BEAM CENTROID C C ---------------------------------------------------------------------- C LOCAL VARIABLES C REAL COR(6), COT(6), RA(6,6) C ---------------------------------------------------------------------- C C TRANSFORMATION OF BEAM CENTROID C 50 DO 70 J = 1, 6 SS = 0.0 DO 60 K = 1, 6 SS = SS + RA(J,K)*COR(K) 60 CONTINUE COT(J) = SS 70 CONTINUE C C RESET OFF-AXIS BEAM CENTROID C 200 DO 220 J = 1, 6 220 COR(J) = COT(J) RETURN END SUBROUTINE THRED2(TA,COR) C C SECOND ORDER TRANSFORMATION OF BEAM CENTROID C ---------------------------------------------------------------------- C ---------------------------------------------------------------------- C LOCAL VARIABLES C REAL COR(6), COT(6), TA(5,21) C ---------------------------------------------------------------------- C C SECOND ORDER TERMS C DO 20 J = 1, 5 IND = 0 SS = 0.0 DO 10 L2 = 1, 6 DO 10 L1 = 1, L2 IND = IND + 1 SS = SS + TA(J,IND)*COR(L1)*COR(L2) 10 CONTINUE COT(J) = SS 20 CONTINUE COT(6) = 0.0 C DO 50 J = 1, 6 50 COR(J) = COT(J) C RETURN END SUBROUTINE THRED3(UA,COR) C C THIRD-ORDER TRANSFORMATION OF BEAM CENTROID C ---------------------------------------------------------------------- C LOCAL VARIABLES C REAL COR(6), COT(6), UA(5,56) C ---------------------------------------------------------------------- C C THIRD-ORDER TERMS C DO 20 J = 1, 5 SS = 0.0 IND = 0 DO 10 L3 = 1, 6 DO 10 L2 = 1, L3 DO 10 L1 = 1, L2 IND = IND + 1 SS = SS + UA(J,IND)*COR(L1)*COR(L2)*COR(L3) 10 CONTINUE COT(J) = SS 20 CONTINUE COT(6) = 0.0 C C RESET OFF-AXIS REFERENCE TRAJECTORY C DO 50 J = 1, 6 50 COR(J) = COT(J) RETURN END SUBROUTINE TRANSPORT_WRITE INCLUDE 'LOUTAR.CIN' INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'CHARLINE.CIN' INCLUDE 'CONSTS.CIN' INCLUDE 'DATA1C.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'DBEAM.CIN' INCLUDE 'DBEAMR.CIN' INCLUDE 'DCORR.CIN' INCLUDE 'DETA.CIN' INCLUDE 'DSPEC.CIN' INCLUDE 'DSPECR.CIN' INCLUDE 'DTF.CIN' INCLUDE 'DTFRI.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM1A.CIN' INCLUDE 'ELM13A.CIN' INCLUDE 'ELM15B.CIN' INCLUDE 'ELM15C.CIN' INCLUDE 'IMAGE.CIN' INCLUDE 'KELEM.CIN' INCLUDE 'OUTNEWC.CIN' INCLUDE 'OUTNEWR.CIN' INCLUDE 'PRINTC.CIN' INCLUDE 'PRINTL.CIN' PARAMETER (NCONST = 5 000) CHARACTER EPNAM(6)*20, ARGTYPE(5)*2, CONAME(NCONST)*15 CHARACTER ARGT*2, ARGT11(4)*2, ARGT19(2)*2, ARGT20*2, 1 ARGT35(2)*2, ARGT42(3)*2 CHARACTER KELEMM*15, LABUSE*6 CHARACTER NAMELST(NCONST)*15, NAMEORG(NCONST)*15, 1 KYWD(5)*5, ELPAR(6)*30, LABELTO*15, TEMP*15 CHARACTER KWWW*5, KYWD11(4)*4, KYWD19(2)*2, KYWD20*5, 1 KYWD35(2)*5, KYWD42(3)*5 DIMENSION EPVAL(5), LCP(5), LKYWD(5) EQUIVALENCE (LCP(1),LCP1), (LCP(2),LCP2), (LCP(3),LCP3), 1 (LCP(4),LCP4), (LCP(5),LCP5) PARAMETER (ITYPES=6) CHARACTER YNVAR(ITYPES)*5 DIMENSION INDX(NELEM), FACTMAD(5) LOGICAL FNDCNME, YNUSE DIMENSION IC(4) CHARACTER ALAST*1, CNAME*6, CS(4)*1, EQSYM*3 C\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ C\\\\\\\\\\\\\\ 1/21/98 NMG \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ C FOR USE IN WADCAD CHARACTER BENDNAME(50)*7, QUADNAME(50)*7, CESTYPE*7 DIMENSION BENDLEN (50), BENDWID(50), QUADLEN(50), QUADWID(50) C DATA NQUAD /0/ DATA BENDWID, QUADWID /50*2.66667, 50*2.66667/ C\\\\\\\\\\\\\\ END 1/21/98 \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ C\\\\\\\\\\\\\\\ ADDED 12/1/97 NMG \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ DATA ARGTYPE /'L','T','K1','K2','K3'/ DATA ARGT11 /'L','V','LG','FR'/ DATA ARGT19 /'L','KS'/ DATA ARGT20 /'AN'/ DATA ARGT35 /'L','KI'/ DATA ARGT42 /'L','HK','VK'/ DATA FACTMAD /1.0, 1.0, 1.0, 2.0, 6.0/ DATA KYWD /'L','ANGLE','K1','K2','K3'/ DATA KYWD11 /'L','VOLT','LAG','FREQ'/ DATA KYWD19 /'L','KS'/ DATA KYWD20 /'ANGLE'/ DATA KYWD35 /'L','KICK'/ DATA KYWD42 /'L','HKICK','VKICK'/ DATA LKYWD /1,5,2,2,2/ DATA INDX /0,0,1,0,2,0,0,0,0,0, 1 4,0,0,0,0,0,0,5,2,1, 2 0,0,0,0,6,0,0,3,3,0, 3 4,0,0,0,2,2,0,0,0,0, 4 0,3,0,0,0,0,0,0,0,0, 5 0,0,0,0,0,0,0,0,0,0, 6 0,0,0,0/ DATA YNVAR(1) /'YNNNN'/ DATA YNVAR(2) /'YNYNN'/ DATA YNVAR(3) /'YYOON'/ DATA YNVAR(4) /'NNNNN'/ DATA YNVAR(5) /'ONNYN'/ DATA YNVAR(6) /'ONNNY'/ DATA DZERO /0.0/ C\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ ENTRY WTOUT BX0 = 0.0 C NUM = 0 C DO WHILE ((BX0 .LE. 0) .AND. (NUM .LE. NEL)) C NUM = NUM + 1 C IF (OUTNEWL(NUM)) THEN C BX0 = OUTNEW(8,NUM) C END IF C END DO C JOUT = 1 C DO I = 1, NEL C IF (OUTNEWL(I)) JOUT = JOUT + 1 C END DO C PRINT *,'JOUT=',JOUT,' ICOUNT=',ICOUNT CALL ELIMTB (IMAGE,NHD) CALL ELIMTB (CDATE,LCDA) CALL ELIMTB (CTIME,LCTM) WRITE (23,2000) IMAGE(1:NHD), CDATE, CTIME, NEL, ICOUNT + 1, 1 LOUTAR WRITE (23,2010) 33, (DSPEC(I), DSPEC_VAL(I), I = 1, 33) WRITE (23,2010) 18, (DBEAM(I), DBEAM_VAL(I), I = 1, 18) WRITE (23,2010) 6, (DETA (I), DETA_VAL (I), I = 1, 6) WRITE (23,2011) LOUTAR, (OUTDESC(I), I = 1, LOUTAR) WRITE (24 ) NHD, IMAGE(1:NHD), LCDA, CDATE(1:LCDA), 1 LCTM, CTIME(1:LCTM), NEL, ICOUNT + 1, LOUTAR LENL = LEN(DSPEC(1)) WRITE (24 ) 5, 'DSPEC', 33, LENL, 1 (DSPEC(I), DSPEC_VAL(I), I = 1, 33) LENL = LEN(DBEAM(1)) WRITE (24 ) 5, 'DBEAM', 18, LENL, 1 (DBEAM(I), DBEAM_VAL(I), I = 1, 18) LENL = LEN(DETA(1)) WRITE (24 ) 4, 'DETA', 6, LENL, 1 (DETA (I), DETA_VAL (I), I = 1, 6) WRITE (24) (OUTDESC(I), I = 1, LOUTAR) PMASS = 0.93827231 PMOM = DBEAM_VAL(7) C PMOM = RI/33.35640952 ENERGY = SQRT(PMOM*PMOM + PMASS**2) WRITE (24) PMASS, PMOM, ENERGY, RI C TO WRITE A START RECORD. C WRITE (23,2003) WRITE (23,2001) 1, 0, 0, 'START', 'START' WRITE (23,2002) 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 1 DBEAM_VAL(10), DBEAM_VAL(9), 0.0, 2 DETA_VAL(1), DETA_VAL(2), DBEAM_VAL(13), DBEAM_VAL(12), 0.0, 3 DETA_VAL(3), DETA_VAL(4), 0.0, 0.0, 0.0, 0.0, 0.0, 4 (DSPEC_VAL(JIS), JIS = 19, 23), 0.0, 0.0, 0.0, 0.0, 5 (DZERO, I = 1, 30) WRITE (24 ) 1, 0, 0, 5, 'START', 5, 'START', 1 LOUTAR, DZERO, DZERO, DZERO, DZERO, DZERO, DZERO, 2 DBEAM_VAL(10), DBEAM_VAL(9), DZERO, 3 DETA_VAL(1), DETA_VAL(2), DBEAM_VAL(13), DBEAM_VAL(12), DZERO, 4 DETA_VAL(3), DETA_VAL(4), DZERO, DZERO, DZERO, DZERO, DZERO, 5 (DSPEC_VAL(JIS), JIS = 19, 23), DZERO, DZERO, DZERO, DZERO, 6 DZERO, (DZERO, I = 1, 30) JOUT = 1 C PRINT *,'TRNSPRT. NEL =',NEL,' ICOUNT=',ICOUNT DO 10 100 NUM = 1, ICOUNT IF (.NOT. OUTNEWL(NUM)) THEN PRINT *, NUM, ICOUNT, JOUT,' <',OUTLAB(NUM),'>' GO TO 10 100 END IF JOUT = JOUT + 1 TYPE = IOUTTYP(NUM) CALL ELIMTB (KELEM(TYPE),LKEL) LABELTO = OUTLAB(NUM) CALL ELIMTB (LABELTO,LLBL) WRITE (23,2001) JOUT, NUM, TYPE, LABELTO(1:LLBL), 1 KELEM(TYPE)(1:LKEL) WRITE (23,2002) (OUTNEW(IK,NUM), IK = 1, LOUTAR) WRITE (24,IOSTAT=IOS) JOUT, NUM, TYPE, LLBL, LABELTO(1:LLBL), 1 LKEL, KELEM(TYPE)(1:LKEL), 2 LOUTAR, (OUTNEW(IJ,NUM), IJ = 1, LOUTAR) 10100 CONTINUE C PRINT *,'JOUT=',JOUT RETURN C\\\\\\\\\\\\\\\\ TO WRITE TRANSPORT INPUT \\\\\\\\\\\\\\\\\\\\\\\\\ ENTRY WTRAN PIO2 = 0.5*PI BX0 = 0.0 NUM = 0 C DO WHILE ((BX0 .LE. 0) .AND. (NUM .LE. ICOUNT)) C NUM = NUM + 1 C IF (OUTNEWL(NUM)) THEN C BX0 = OUTNEW(8,NUM) C END IF C END DO C CALL ELIMTB (IMAGE,NHD) WRITE (37,2006) ''''//IMAGE(1:NHD)//'''' WRITE (37,2005) 'TRANSPORT INPUT FROM A TRANSPORT FIT.' WRITE (37,2005) 'LATTICE HEAD-'//IMAGE(1:NHD) WRITE (37,2005) 'PROGRAM RUN AT '//CTIME//' ON '//CDATE//'.' WRITE (37,2005) WRITE (37,2006) '0, NOBEFORE, NOLIST;' WRITE (37,2006) 'UMAD' WRITE (37,2006) 'UNIT, L, FT, SIZE = 0.3048, FLOOR ;' IF (REFER) THEN WRITE (37,2006) 'PRINT, REFER ! ALLOWS USE OF ACCELERATOR '// 1 'NOTATION.' ELSE WRITE (37,2005) 'PRINT, REFER ! ALLOWS USE OF ACCELERATOR ' // 1 'NOTATION.' ENDIF WRITE (37,2005) 'PRINT, ONELINE' WRITE (37,2006) 'PRINT, BEAM, ON' WRITE (37,2005) 'PRINT, CENTROID, ON' WRITE (37,2005) 'PRINT, TWISS, OFF' WRITE (37,2005) 'PRINT, TWISS, ON;' WRITE (37,2006) 'PRINT, FLOOR, ON' WRITE (37,2005) 'PLOT, L, YFLOOR;' WRITE (37,2005) 'PLOT, ZFLOOR, XFLOOR;.' WRITE (37,2103) 'SPECIAL, LENGTH = ', DSPEC_VAL( 9) WRITE (37,2103) 'SPECIAL, XBEGIN = ', DSPEC_VAL(19) WRITE (37,2103) 'SPECIAL, YBEGIN = ', DSPEC_VAL(20) WRITE (37,2103) 'SPECIAL, ZBEGIN = ', DSPEC_VAL(21) WRITE (37,2103) 'SPECIAL, YAW = ', DSPEC_VAL(22) WRITE (37,2103) 'SPECIAL, PITCH = ', DSPEC_VAL(23) WRITE (37,2103) 'PROTON_MASS := 0.93827231 ! PROTON MASS,', 1 ' GEV/C^2' PMASS = 0.93827231 PMOM = DBEAM_VAL(7) C PMOM = RI/33.35640952 C PRINT *,'LOOKING FOR P0', DSPEC_VAL(14), DBEAM_VAL(7), C 1 DBEAM_VAL(11), DBEAM_VAL(14) WRITE (37,2104) 'PBEAM :=', PMOM, ' ! MOMENTUM,', 1 XDIME(11),'/C' ENERGY = SQRT(PMOM*PMOM + PMASS*PMASS) TBEAM = ENERGY - PMASS DPP = 0.0 WRITE (37,2103) 'KBEAM := ',TBEAM, '! KINETIC ENERGY' WRITE (37,2103) 'BRHO := 33.35640952*PBEAM! RIGIDITY, KG-M' C IF (LTWISS) THEN WRITE (37,2700) DBEAM_VAL(10), DBEAM_VAL(11), 1 DBEAM_VAL(13), DBEAM_VAL(14), 2 DBEAM_VAL(12), DBEAM_VAL(15), DPP, PMOM WRITE (37,2701) (DETA_VAL(IETA), IETA = 1, 4) ELSE WRITE (37,2703) DBEAM_VAL(1), DBEAM_VAL(2), 1 DBEAM_VAL(3), DBEAM_VAL(4), 2 DBEAM_VAL(5), DBEAM_VAL(6), PMOM NCORR = 0 DO IB = 1, 15 IF (DCORR_VAL(IB) .NE. 0.0) THEN NCORR = NCORR + 1 ENDIF ENDDO IF (NCORR .GE. 1) THEN NCT = 0 CNAME = 'CORR, ' DO IB = 1, 15 IF (DCORR_VAL(IB) .NE. 0) THEN NCT = NCT + 1 NCTM = MOD(NCT-1,4) + 1 IC(NCTM) = IB EQSYM = ' = ' IF (NCT .LT. NCORR) THEN CS(NCTM) = ',' ELSE CS(NCTM) = ' ' ENDIF IF (4*(NCT/4) .EQ. NCT .AND. NCT .LT. NCORR) THEN ALAST = '&' ELSE ALAST = ' ' ENDIF IF (4*(NCT/4) .EQ. NCT .OR. NCT .EQ. NCORR) THEN WRITE (37,2704) CNAME, 1 (DCORR(IC(II)), EQSYM, DCORR_VAL(IC(II)), 2 CS(II), II = 1, NCTM), ALAST CNAME = ' ' ENDIF ENDIF ENDDO ENDIF ENDIF NUMCOM = 0 NLIST = 0 DO 10 300 NUM = 1, ICOUNT IF (.NOT. OUTNEWL(NUM)) GO TO 10 300 TYPE = IOUTTYP(NUM) YNUSE = TYPE .EQ. 3 .OR. TYPE .EQ. 5 .OR. TYPE .EQ. 18 1 .OR. TYPE .EQ. 25 .OR. TYPE .EQ. 28 .OR. TYPE .EQ. 29 2 .OR. TYPE .EQ. 31 CALL ELIMTB (KELEM(TYPE),LKEL) LABELTO = OUTLAB(NUM) CALL ELIMTB (LABELTO,LLBL) C JA = INDX(TYPE) IF (JA .LE. 0) GO TO 10 230 KNB = 0 IF (YNUSE) THEN IAMAX = 5 ELSE IF (TYPE .EQ. 11) THEN IAMAX = 4 ELSE IF (TYPE .EQ. 19) THEN IAMAX = 2 ELSE IF (TYPE .EQ. 20) THEN IAMAX = 1 ELSE IF (TYPE .EQ. 35 .OR. TYPE .EQ. 36) THEN IAMAX = 2 ELSE IF (TYPE .EQ. 42) THEN IAMAX = 3 ENDIF C DO 10 210 IA = 1, IAMAX C IF (YNUSE) THEN IF ((YNVAR(JA)(IA:IA) .EQ. 'N') .OR. 1 ((YNVAR(JA)(IA:IA) .EQ. 'O') .AND. 2 (OUTNEW(IA,NUM) .EQ. 0.0))) THEN GO TO 10 210 END IF END IF C KNB = KNB + 1 IF (YNUSE) THEN ARGT = ARGTYPE(IA) ELSE IF (TYPE .EQ. 11) THEN ARGT = ARGT11(IA) ELSE IF (TYPE .EQ. 19) THEN ARGT = ARGT19(IA) ELSE IF (TYPE .EQ. 20) THEN ARGT = ARGT20 ELSE IF (TYPE .EQ. 35 .OR. TYPE .EQ. 36) THEN ARGT = ARGT35(IA) ELSE IF (TYPE .EQ. 42) THEN ARGT = ARGT42(IA) ENDIF C EPNAM(KNB) = LABELTO(1:LLBL)//ARGT IF (YNUSE) THEN LK = LKYWD(IA) KWWW = KYWD(IA) ELSE IF (TYPE .EQ. 11) THEN IF (IA .EQ. 1) LK = 1 IF (IA .EQ. 2) LK = 4 IF (IA .EQ. 3) LK = 3 IF (IA .EQ. 4) LK = 4 KWWW = KYWD11(IA) ELSE IF (TYPE .EQ. 19) THEN IF (IA .EQ. 1) LK = 1 IF (IA .EQ. 2) LK = 2 KWWW = KYWD19(IA) ELSE IF (TYPE .EQ. 20) THEN LK = 5 KWWW = KYWD20 ELSE IF (TYPE .EQ. 35 .OR. TYPE .EQ. 36) THEN IF (IA .EQ. 1) LK = 1 IF (IA .EQ. 2) LK = 4 KWWW = KYWD35(IA) ELSE IF (TYPE .EQ. 42) THEN IF (IA .EQ. 1) LK = 1 IF (IA .EQ. 2 .OR. IA .EQ. 3) LK = 5 KWWW = KYWD42(IA) ENDIF ELPAR(KNB) = KWWW(1:LK)//'='//EPNAM(KNB) CALL ELIMTB (EPNAM(KNB),LCP(KNB)) EPVAL(KNB) = OUTNEW(IA,NUM) C WRITE (25,3000) NUM, LABELTO(1:LLBL), C 1 EPNAM(KNB)(1:LCP(KNB)),EPVAL(IA) C 3000 FORMAT (' ',I5,' <',A,'> <',A,'> ',1P,G15.5) C\\\\\\\\\\\\\\\\\ MODIFIED 11/11/97 NMG \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ C CHECK TO SEE IF THIS NAME EXISTS IN CONAME. IF NOT ADD IT AND OUTPUT IT. FNDCNME = .FALSE. C PRINT *, IB, IA, KNB, NUMCON, '<', EPNAM(KNB), '>.' DO IB = 1, NUMCON C WRITE (3,3000) IB, IA, KNB, NUMCON, CONAME(IB), EPNAM(KNB) C 3000 FORMAT (' ',4I6,' <',A,'> <',A,'>.') C\\\\\\\\\\\\\\\\ MODIFIED 11/11/97 NMG IF (CONAME(IB) .EQ. EPNAM(KNB)) THEN FNDCNME = .TRUE. END IF END DO IF (.NOT. FNDCNME) THEN LUC = LCP(KNB) IF (EPVAL(KNB) .EQ. 0.0) THEN EVALUET = 1.0E-08 ELSE EVALUET = EPVAL(KNB) END IF NUMCON = NUMCON + 1 NUMCON = MIN(NUMCON,NCONST) WRITE (37,2702) EPNAM(KNB)(1:LUC), EVALUET CONAME(NUMCON) = EPNAM(KNB)(1:LUC) END IF C 10210 CONTINUE C C LABEL(NUM) = LABELTO NLIST1 = NLIST NLIST = NLIST1 + 1 NAMEORG(NLIST) = LABELTO(1:LLBL) C CHECK TO SEE IF THIS NAME ALREADY EXISTS. IF SO DO NOT OUTPUT. DO I = 1, NLIST1 IF (LABELTO .EQ. NAMEORG(I)) GO TO 10 230 END DO C IF (OUTNEW(6,NUM) .NE. 0.0) THEN KNB = KNB + 1 IF ((TYPE .EQ. 4) .OR. (TYPE .EQ. 28) .OR. 1 (TYPE .EQ. 29)) THEN IF (ABS(OUTNEW(6,NUM) - PIO2) .LT. 1.0E-03) THEN ELPAR(KNB) = 'TILT' ELSE WRITE (ELPAR(KNB),4000) OUTNEW(6,NUM) END IF ELSE WRITE (ELPAR(KNB),4000) OUTNEW(6,NUM) END IF END IF C IF (KNB .LE. 0) THEN SLINE = LABELTO(1:LLBL)//' : '//KELEM(TYPE)(1:LKEL) CALL ELIMTB (SLINE,N2) WRITE (37,2006) SLINE(1:N2) GO TO 10 230 END IF SLINE = LABELTO(1:LLBL)//' : '//KELEM(TYPE)(1:LKEL)//',' CALL ELIMTB (SLINE,N2) DO IB = 1, KNB CALL ELIMTB (ELPAR(IB),LPAR) N1 = N2 + 2 IF ((N2 + LPAR) .LE. 72) THEN N2 = N1 + LPAR IF (IB .LT. KNB) THEN SLINE(N1:N2) = ELPAR(IB)(1:LPAR)//',' ELSE SLINE(N1:N2) = ELPAR(IB)(1:LPAR) END IF ELSE SLINE(N1:N1) = '&' WRITE (37,2006) SLINE(1:N1) N2 = LPAR IF (IB .LT. KNB) THEN N2 = N2 + 1 SLINE = ELPAR(IB)(1:LPAR)//',' ELSE SLINE = ELPAR(IB)(1:LPAR) END IF END IF END DO IF (N2 .GT. 0) THEN WRITE (37,2006) SLINE(1:N2) END IF C 10230 CONTINUE C 10300 CONTINUE C IF (NUSE .NE. 0) THEN CALL ELIMTB (LABEL(NUSE),LUN) SLINE = LABEL(NUSE)(1:LUN)//' : LINE=(' ELSE LABUSE = 'LABUSE' LUN = 6 SLINE = LABUSE//' : LINE=(' ENDIF CALL ELIMTB (SLINE,LLN) C N2 = LLN - 1 DO 10 400 NUM = 1, NLIST CALL ELIMTB (NAMEORG(NUM),LLBL) N1 = N2 + 2 IF ((N2 + LLBL) .LE. 72) THEN N2 = N1 + LLBL IF (NUM .LT. NEL) THEN SLINE(N1:N2) = NAMEORG(NUM)(1:LLBL)//',' ELSE SLINE(N1:N2) = NAMEORG(NUM)(1:LLBL) END IF ELSE SLINE(N1:N1) = '&' WRITE (37,2006) SLINE(1:N1) N2 = LLBL IF (NUM .LT. NEL) THEN N2 = N2 + 1 SLINE = NAMEORG(NUM)(1:LLBL)//',' ELSE SLINE = NAMEORG(NUM)(1:LLBL) END IF END IF 10400 CONTINUE IF (N2 .LE. 0) THEN WRITE (37,2006) ')' ELSE WRITE (37,2006) SLINE(1:N2 - 1)//')' END IF C CALL ELIMTB (LABEL(NUSE),LNUSE) IF (NUSE .NE. 0) THEN WRITE (37,2014) 'USE, ', LABEL(NUSE)(1:LNUSE) ELSE WRITE (37,2014) 'USE, ', LABUSE ENDIF WRITE (37,2014) 'SENTINEL' WRITE (37,2014) 'SENTINEL' RETURN C\\\\\\\\\\\\\\\\ TO WRITE MAD INPUT \\\\\\\\\\\\\\\\\\\\\\\\\ ENTRY WMAD PIO2 = 0.5*PI BX0 = 0.0 NUM = 0 C DO WHILE ((BX0 .LE. 0) .AND. (NUM .LE. NEL)) C NUM = NUM + 1 C IF (OUTNEWL(NUM)) THEN C BX0 = OUTNEW(8,NUM) C END IF C END DO NFST = 1 CALL ELIMTB (IMAGE,NHD) WRITE (36,2005) 'MAD INPUT FROM TRANSPORT.' WRITE (36,2005) 'PROGRAM RUN AT '//CTIME//' ON '//CDATE WRITE (36,2006) 'TITLE,"'//IMAGE(1:NHD)//'"' PMASS = 0.93827231 PMOM = DBEAM_VAL(7) C PMOM = RI/33.35640952 WRITE (36,2104) 'PBEAM : CONSTANT = ', PMOM, 1 '! MOMENTUM,', XDIME(11), '/C' ENERGY = SQRT(PMOM*PMOM + PMASS*PMASS) TBEAM = ENERGY - PMASS WRITE (36,2103) 'KBEAM : CONSTANT = ', TBEAM, 1 '! KINETIC ENERGY' WRITE (36,2103) 'BRHO := 33.35640952*PBEAM! RIGIDITY, KG-M' WRITE (36,2510) DBEAM_VAL( 9), DBEAM_VAL(10), 1 DBEAM_VAL(12), DBEAM_VAL(13), 2 (DETA_VAL(IETA), IETA = 1, 4) NUMCON = 0 NLIST = 0 C DO 10 600 NUM = 1, ICOUNT IF (.NOT. OUTNEWL(NUM)) GO TO 10 600 TYPE = IOUTTYP(NUM) YNUSE = TYPE .EQ. 3 .OR. TYPE .EQ. 5 .OR. TYPE .EQ. 18 1 .OR. TYPE .EQ. 25 .OR. TYPE .EQ. 28 .OR. TYPE .EQ. 29 2 .OR. TYPE .EQ. 31 IF (TYPE .NE. 11) THEN KELEMM = KELEM(TYPE) ELSE KELEMM = 'RFCAVITY' ENDIF CALL ELIMTB (KELEMM,LKEL) LABELTO = OUTLAB(NUM) CALL ELIMTB (LABELTO,LLBL) IF (LLBL .LE. 0) THEN WRITE (LABELTO,4002) NUM CALL ELIMTB (LABELTO,LLBL) END IF C JA = INDX(TYPE) IF (JA .LE. 0) GO TO 10 530 C KNB = 0 IF (YNUSE) THEN IAMAX = 5 ELSE IF (TYPE .EQ. 11) THEN IAMAX = 4 ELSE IF (TYPE .EQ. 19) THEN IAMAX = 2 ELSE IF (TYPE .EQ. 20) THEN IAMAX = 1 ELSE IF (TYPE .EQ. 35 .OR. TYPE .EQ. 36) THEN IAMAX = 2 ELSE IF (TYPE .EQ. 42) THEN IAMAX = 3 ENDIF C DO 10 510 IA = 1, IAMAX IF (YNUSE) THEN IF ((YNVAR(JA)(IA:IA) .EQ. 'N') .OR. 1 ((YNVAR(JA)(IA:IA) .EQ. 'O') .AND. 2 (OUTNEW(IA,NUM) .EQ. 0.0))) THEN GO TO 10 510 END IF ENDIF C KNB = KNB + 1 IF (YNUSE) THEN ARGT = ARGTYPE(IA) ELSE IF (TYPE .EQ. 11) THEN ARGT = ARGT11(IA) ELSE IF (TYPE .EQ. 19) THEN ARGT = ARGT19(IA) ELSE IF (TYPE .EQ. 20) THEN ARGT = ARGT20 ELSE IF (TYPE .EQ. 35 .OR. TYPE .EQ. 36) THEN ARGT = ARGT35(IA) ELSE IF (TYPE .EQ. 42) THEN ARGT = ARGT42(IA) ENDIF C EPNAM(KNB) = LABELTO(1:LLBL)//ARGT IF (YNUSE) THEN LK = LKYWD(IA) KWWW = KYWD(IA) ELSE IF (TYPE .EQ. 11) THEN IF (IA .EQ. 1) LK = 1 IF (IA .EQ. 2) LK = 4 IF (IA .EQ. 3) LK = 3 IF (IA .EQ. 4) LK = 4 KWWW = KYWD11(IA) ELSE IF (TYPE .EQ. 19) THEN IF (IA .EQ. 1) LK = 1 IF (IA .EQ. 2) LK = 2 KWWW = KYWD19(IA) ELSE IF (TYPE .EQ. 20) THEN LK = 5 KWWW = KYWD20 ELSE IF (TYPE .EQ. 35 .OR. TYPE .EQ. 36) THEN IF (IA .EQ. 1) LK = 1 IF (IA .EQ. 2) LK = 4 KWWW = KYWD35(IA) ELSE IF (TYPE .EQ. 42) THEN IF (IA .EQ. 1) LK = 1 IF (IA .EQ. 2 .OR. IA .EQ. 3) LK = 5 KWWW = KYWD42(IA) ENDIF ELPAR(KNB) = KWWW(1:LK)//'='//EPNAM(KNB) CALL ELIMTB (EPNAM(KNB),LCP(KNB)) IF (YNUSE) THEN EPVAL(KNB) = FACTMAD(IA)*OUTNEW(IA,NUM) ELSE EPVAL(KNB) = OUTNEW(IA,NUM) ENDIF C\\\\\\\\\\\\\\\\\ MODIFIED 11/11/97 NMG \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ C CHECK TO SEE IF THIS NAME EXISTS IN CONAME. IF NOT ADD IT AND OUTPUT IT. FNDCNME = .FALSE. DO IB = 1, NUMCON C\\\\\\\\\\\\\\\\ MODIFIED 11/11/97 NMG IF (CONAME(IB) .EQ. EPNAM(KNB)) THEN FNDCNME = .TRUE. END IF END DO IF (.NOT. FNDCNME) THEN LUC = LCP(KNB) IF (EPVAL(KNB) .EQ. 0.0) THEN EVALUET = 1.0E-08 ELSE EVALUET = EPVAL(KNB) END IF NUMCON = NUMCON + 1 WRITE (36,2702) EPNAM(KNB)(1:LUC), EVALUET CONAME(NUMCON) = EPNAM(KNB)(1:LUC) END IF 10510 CONTINUE C LABEL(NUM) = LABELTO NLIST1 = NLIST NLIST = NLIST1 + 1 NAMEORG(NLIST) = LABELTO(1:LLBL) C C CHECK TO SEE IF THIS NAME ALREADY EXISTS. IF SO DO NOT OUTPUT. C DO I = 1, NLIST1 IF (LABELTO .EQ. NAMEORG(I)) GO TO 10 530 END DO C IF (OUTNEW(6,NUM) .NE. 0.0) THEN KNB = KNB + 1 IF ((TYPE .EQ. 4) .OR. (TYPE .EQ. 28) .OR. 1 (TYPE .EQ. 29)) THEN IF (ABS(OUTNEW(6,NUM) - PIO2) .LT. 1.0E-03) THEN ELPAR(KNB) = 'TILT' ELSE WRITE (ELPAR(KNB),4000) OUTNEW(6,NUM) END IF ELSE WRITE (ELPAR(KNB),4000) OUTNEW(6,NUM) END IF END IF C IF (KNB .LE. 0) THEN SLINE = LABELTO(1:LLBL)//' : '//KELEMM(1:LKEL) CALL ELIMTB (SLINE,N2) WRITE (36,2006) SLINE(1:N2) GO TO 10 530 END IF C SLINE = LABELTO(1:LLBL)//' : '//KELEMM(1:LKEL)//',' CALL ELIMTB (SLINE,N2) DO IB = 1, KNB CALL ELIMTB (ELPAR(IB),LPAR) N1 = N2 + 2 IF ((N2 + LPAR) .LE. 72) THEN N2 = N1 + LPAR IF (IB .LT. KNB) THEN SLINE(N1:N2) = ELPAR(IB)(1:LPAR)//',' ELSE SLINE(N1:N2) = ELPAR(IB)(1:LPAR) END IF ELSE SLINE(N1:N1) = '&' WRITE (36,2006) SLINE(1:N1) N2 = LPAR IF (IB .LT. KNB) THEN N2 = N2 + 1 SLINE = ELPAR(IB)(1:LPAR)//',' ELSE SLINE = ELPAR(IB)(1:LPAR) END IF END IF END DO IF (N2 .GT. 0) THEN WRITE (36,2006) SLINE(1:N2) END IF 10530 CONTINUE 10600 CONTINUE C IF (NUSE .NE. 0) THEN CALL ELIMTB (LABEL(NUSE),LUN) SLINE = LABEL(NUSE)(1:LUN)//' : LINE=(' ELSE LABUSE = 'LABUSE' LUN = 6 SLINE = LABUSE//' : LINE=(' ENDIF CALL ELIMTB (SLINE,LLN) C N2 = LLN - 1 DO 10 700 NUM = 1, NLIST CALL ELIMTB (NAMEORG(NUM),LLBL) N1 = N2 + 2 IF ((N2 + LLBL) .LE. 72) THEN N2 = N1 + LLBL IF (NUM .LT. NEL) THEN SLINE(N1:N2) = NAMEORG(NUM)(1:LLBL)//',' ELSE SLINE(N1:N2) = NAMEORG(NUM)(1:LLBL) END IF ELSE SLINE(N1:N1) = '&' WRITE (36,2006) SLINE(1:N1) N2 = LLBL IF (NUM .LT. NEL) THEN N2 = N2 + 1 SLINE = NAMEORG(NUM)(1:LLBL)//',' ELSE SLINE = NAMEORG(NUM)(1:LLBL) END IF END IF 10700 CONTINUE IF (N2 .LE. 0) THEN WRITE (36,2006) ')' ELSE WRITE (36,2006) SLINE(1:N2 - 1)//')' END IF C CALL ELIMTB (LABEL(NUSE),LNUSE) IF (NUSE .NE. 0) THEN WRITE (36,2014) 'USE, ', LABEL(NUSE)(1:LNUSE) ELSE WRITE (36,2014) 'USE, ', LABUSE ENDIF C C HAVE TO PUT THE FILE NAME HERE. WRITE (36,2006) 'TWISS,SAVE=CSFUN,BETA0=INITIAL,TAPE="'// 1 TIN(1:LTN)//'.TWISS"' WRITE (36,2511) (DSPEC_VAL(I)*UFLOOR(1), I = 19, 21), 1 (OUTNEW(I,NFST), I = 22, 23), TIN(1:LTN) WRITE (36,2006) 'PLOT ,HAXIS=S,VAXIS=BETX,BETY' WRITE (36,2006) 'PLOT ,HAXIS=S,VAXIS=ALFX,ALFY' WRITE (36,2006) 'PLOT ,HAXIS=S,VAXIS=DX,DY' WRITE (36,2006) 'PLOT ,HAXIS=S,VAXIS=DPX,DPY' WRITE (36,2006) 'PLOT ,HAXIS=S,VAXIS=MUX,MUY' WRITE (36,2014) 'STOP' RETURN C\\\\\\\\\\\\\\\\ TO WRITE LATDEF INPUT \\\\\\\\\\\\\\\\\\\\\\\\\ ENTRY WLATDEF PIO2 = 0.5*PI CALL ELIMTB (IMAGE,NHD) WRITE (35,2005) 'PROGRAM RUN AT '//CTIME//' ON '//CDATE WRITE (35,2006) 'TITLE,"'//IMAGE(1:NHD)//'"' PMOM = DBEAM_VAL(7) C PMOM = RI/33.35640952 PMASS = 0.93837231 ENERGY = SQRT(PMOM*PMOM + PMASS*PMASS) TBEAM = ENERGY - PMASS WRITE (35,2103) 'ENERGY', ENERGY , XDIME(11) WRITE (35,2309) 1 DBEAM_VAL( 9), DBEAM_VAL(10), 2 DBEAM_VAL(12), DBEAM_VAL(13), 3 (DETA_VAL(IETA), IETA=1,4) WRITE (35,2310) (DSPEC_VAL(I), I = 19, 23), 0.0, UFLOOR(1) NUMCON = 0 NLIST = 0 DO 11 200 NUM = 1, ICOUNT IF (.NOT. OUTNEWL(NUM)) GO TO 11 200 TYPE = IOUTTYP(NUM) CALL ELIMTB (KELEM(TYPE),LKEL) LABELTO = OUTLAB(NUM) CALL ELIMTB (LABELTO,LLBL) JA = INDX(TYPE) IF (JA .LE. 0) GO TO 11 130 KNB = 0 DO 11 110 IA = 1, 5 IF ((YNVAR(JA)(IA:IA) .EQ. 'N') .OR. 1 ((YNVAR(JA)(IA:IA) .EQ. 'O') .AND. 2 (OUTNEW(IA,NUM) .EQ. 0.0))) THEN GO TO 11 110 END IF KNB = KNB + 1 EPNAM(KNB) = LABELTO(1:LLBL)//ARGTYPE(IA) LK = LKYWD(IA) CALL ELIMTB (EPNAM(KNB),LCP(KNB)) EPVAL(KNB) = OUTNEW(IA,NUM) C WRITE (25,3000) NUM,LABELTO(1:LLBL), C 1 EPNAM(KNB)(1:LCP(KNB)),EPVAL(IA) C 3000 FORMAT (' ',I5,' <',A,'> <',A,'> ',1P,G15.5) C\\\\\\\\\\\\\\\\\ MODIFIED 11/11/97 NMG \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ C CHECK TO SEE IF THIS NAME EXISTS IN CONAME. IF NOT ADD IT AND OUTPUT IT. FNDCNME = .FALSE. DO IB = 1, NUMCON C\\\\\\\\\\\\\\\\ MODIFIED 11/11/97 NMG IF (CONAME(IB) .EQ. EPNAM(KNB)) THEN FNDCNME = .TRUE. END IF END DO IF (.NOT. FNDCNME) THEN LUC = LCP(KNB) NUMCON = NUMCON + 1 IF (IA .EQ. 3) THEN WRITE (35,2300) EPNAM(KNB)(1:LUC), 1 EPVAL(KNB),' S' ELSE WRITE (35,2300) EPNAM(KNB)(1:LUC), EPVAL(KNB) END IF EPNAM(KNB) = LABELTO(1:LLBL)//ARGTYPE(IA) CONAME(NUMCON) = EPNAM(KNB)(1:LUC) END IF 11110 CONTINUE NLIST1 = NLIST NLIST = NLIST + 1 NAMEORG(NLIST) = LABELTO(1:LLBL) C CHECK TO SEE IF THIS NAME ALREADY EXISTS. IF SO DO NOT OUTPUT. C DO I = 1, NLIST1 IF (LABELTO .EQ. NAMEORG(I)) GO TO 11 120 END DO IF (TYPE .EQ. 3) THEN IF (LABELTO(1:2) .NE. 'DR') THEN TEMP = LABELTO(1:LLBL) LABELTO = 'DR'//TEMP(1:LLBL) LLBL = LLBL + 2 END IF LUL = LCP(1) WRITE (35,2301) LABELTO(1:LLBL),EPNAM(1)(1:LUL) GO TO 11 120 END IF IF ((TYPE .EQ. 4) .OR. (TYPE .EQ. 28) .OR. (TYPE .EQ. 29)) THEN IF (KNB .GT. 2) THEN IF (LABELTO(1:2) .NE. 'CF') THEN TEMP = LABELTO(1:LLBL) LABELTO = 'CF'//TEMP(1:LLBL) LLBL = LLBL + 2 END IF ELSE IF (OUTNEW(6,NUM) .EQ. 0.0) THEN IF (LABELTO(1:2) .NE. 'BH') THEN TEMP = LABELTO(1:LLBL) LABELTO = 'BH'//TEMP(1:LLBL) LLBL = LLBL + 2 END IF ELSE IF (ABS(OUTNEW(6,NUM) - PIO2) .LT. 1.0E-03) THEN IF (LABELTO(1:2) .NE. 'BV') THEN TEMP = LABELTO(1:LLBL) LABELTO = 'BV'//TEMP(1:LLBL) LLBL = LLBL + 2 END IF ELSE IF (LABELTO(1:2) .NE. 'BR') THEN TEMP = LABELTO(1:LLBL) LABELTO = 'BR'//TEMP(1:LLBL) LLBL = LLBL + 2 END IF END IF IF (KNB .EQ. 2) THEN LUL = LCP(1) LUA = LCP(2) WRITE (35,2301) LABELTO(1:LLBL), EPNAM(1)(1:LUL), 1 EPNAM(2)(1:LUA) GO TO 11 120 ELSE IF (KNB .EQ. 3) THEN LUL = LCP(1) LUA = LCP(2) LU3 = LCP(3) WRITE (35,2301) LABELTO(1:LLBL),EPNAM(1)(1:LUL), 1 EPNAM(2)(1:LUA),EPNAM(3)(1:LUA) GO TO 11 120 ELSE IF (KNB .EQ. 4) THEN LUL = LCP(1) LUA = LCP(2) LU3 = LCP(3) LU4 = LCP(4) WRITE (35,2301) LABELTO(1:LLBL), EPNAM(1)(1:LUL), 1 EPNAM(2)(1:LUA), EPNAM(3)(1:LU3), 2 EPNAM(4)(1:LU4) GO TO 11 120 END IF END IF C IF (TYPE .EQ. 5) THEN IF ((LABELTO(1:2) .NE. 'QF') .AND. 1 (LABELTO(1:2) .NE. 'QD')) THEN IF (EPVAL(3) .GE. 0.0) THEN TEMP = LABELTO(1:LLBL) LABELTO = 'QF'//TEMP(1:LLBL) LLBL = LLBL + 2 ELSE TEMP = LABELTO(1:LLBL) LABELTO = 'QD'//TEMP(1:LLBL) LLBL = LLBL + 2 END IF END IF LUL = LCP(1) LUK = LCP(2) WRITE (35,2301) LABELTO(1:LLBL), EPNAM(1)(1:LUL), 1 EPNAM(2)(1:LUK) GO TO 11 120 END IF C IF (TYPE .EQ. 18) THEN IF ((LABELTO(1:2) .NE. 'SX') .AND. 1 (LABELTO(1:2) .NE. 'S0')) THEN TEMP = LABELTO(1:LLBL) LABELTO = 'SX'//TEMP(1:LLBL) LLBL = LLBL + 2 END IF LUS = LCP(KNB) WRITE (35,2301) LABELTO(1:LLBL),EPNAM(KNB)(1:LUS) GO TO 11 120 END IF C IF (TYPE .EQ. 25) THEN IF (LABELTO(1:2) .NE. 'OC') THEN TEMP = LABELTO(1:LLBL) LABELTO = 'OC'//TEMP(1:LLBL) LLBL = LLBL + 2 END IF LUS = LCP(KNB) WRITE (35,2301) LABELTO(1:LLBL),EPNAM(KNB)(1:LUS) GO TO 11 120 END IF C IF (TYPE .EQ. 31) THEN IF (LABELTO(1:2) .NE. 'MK') THEN TEMP = LABELTO(1:LLBL) LABELTO = 'MK'//TEMP(1:LLBL) LLBL = LLBL + 2 END IF GO TO 11 120 END IF 11120 CONTINUE NAMELST(NLIST) = LABELTO(1:LLBL) 11130 CONTINUE 11200 CONTINUE C WRITE (25,3000) NLIST C NDIF = 0 C DO I = 1, NLIST C IF (NAMELST(I) .NE. NAMEORG(I)) THEN C WRITE (25,3001) NAMELST(I),NAMEORG(I) C NDIF = NDIF + 1 C END IF C END DO C WRITE (25,*) 'NDIF=',NDIF C 3000 FORMAT (' ','NLIST=',I4) C 3001 FORMAT (' ','<',A,'> <',A,'>.') C CALL ELIMTB (LABEL(NUSE),LUN) IF (LABEL(NUSE)(1:2) .NE. 'UN') THEN TEMP = 'UN'//LABEL(NUSE)(1:LUN) LUN = LUN + 2 ELSE TEMP = LABEL(NUSE)(1:LUN) END IF WRITE (35,2006) TEMP(1:LUN)//' +' SLINE = ' ' N2 = -1 DO 11 300 NUM = 1, NLIST CALL ELIMTB (NAMELST(NUM),LLBL) N1 = N2 + 2 IF ((N2 + LLBL) .LE. 70) THEN N2 = N1 + LLBL IF (NUM .LT. NEL) THEN SLINE(N1:N2) = NAMELST(NUM)(1:LLBL)//' ' ELSE SLINE(N1:N2) = NAMELST(NUM)(1:LLBL) END IF ELSE SLINE(N1:N1) = '+' WRITE (35,2006) SLINE(1:N1) N2 = LLBL IF (NUM .LT. NEL) THEN N2 = N2 + 1 SLINE = NAMELST(NUM)(1:LLBL)//' ' ELSE SLINE = NAMELST(NUM)(1:LLBL) END IF END IF 11300 CONTINUE IF (N2 .GT. 0) THEN WRITE (35,2006) SLINE(1:N2 - 1) END IF C WRITE (35,2014) 'SECT 1' WRITE (35,2014) 'SE ',TEMP(1:LUN) WRITE (35,2014) 'END' RETURN C\\\\\\\\\\\\\\\\ TO WRITE STRUCT INPUT \\\\\\\\\\\\\\\\\\\\\\\\\ ENTRY WSTRUCT PIO2 = 0.5*PI BX0 = 0.0 NUM = 0 DO WHILE ((BX0 .LE. 0) .AND. (NUM .LE. ICOUNT)) NUM = NUM + 1 IF (OUTNEWL(NUM)) THEN BX0 = OUTNEW(8,NUM) END IF END DO NFST = NUM BX0 = 0.0 NUM = ICOUNT DO WHILE ((BX0 .LE. 0) .AND. (NUM .GT. 0)) NUM = NUM - 1 IF (OUTNEWL(NUM)) THEN BX0 = OUTNEW(8,NUM) END IF END DO CALL ELIMTB (IMAGE,NHD) WRITE (38,2005) 'STRUCT INPUT FROM A TRANSPORT FIT.' WRITE (38,2005) 'CONVERSION FROM TRANSPORT TO STRUCT INPUT.' WRITE (38,2005) 'PROGRAM RUN AT '//CTIME//' ON '//CDATE WRITE (38,2005) 'LATTICE HEAD-'//IMAGE(1:NHD) WRITE (38,2007) 'BRHO=',RI PMOM = DBEAM_VAL(7) PMASS = 0.93827231 C PMOM = RI/33.35640952 ENERGY = SQRT(PMOM*PMOM + PMASS**2) TBEAM = ENERGY - PMASS WRITE (38,2008) DBEAM_VAL( 9), DBEAM_VAL(10), DETA_VAL(1), 1 DBEAM_VAL(12), DBEAM_VAL(13), DETA_VAL(3) NUMCON = 0 NLIST = 0 DO 11 600 NUM = 1, ICOUNT IF (.NOT. OUTNEWL(NUM)) GO TO 11 600 TYPE = IOUTTYP(NUM) CALL ELIMTB (KELEM(TYPE),LKEL) LABELTO = OUTLAB(NUM) CALL ELIMTB (LABELTO,LLBL) JA = INDX(TYPE) IF (JA .LE. 0) GO TO 11 600 KNB = 0 DO 11 410 IA = 1, 5 IF ((YNVAR(JA)(IA:IA) .EQ. 'N') .OR. 1 ((YNVAR(JA)(IA:IA) .EQ. 'O') .AND. 2 (OUTNEW(IA,NUM) .EQ. 0.0))) THEN GO TO 11 410 END IF KNB = KNB + 1 EPNAM(KNB) = LABELTO(1:LLBL)//ARGTYPE(IA) LK = LKYWD(IA) EPVAL(KNB) = OUTNEW(IA,NUM) 11410 CONTINUE IF (KNB .LE. 0) GO TO 11 600 C C DRIFT C IF (TYPE .EQ. 3) THEN KODE = 1 ARG1 = EPVAL(1) ARG2 = 0.0 GO TO 11 500 END IF C C BH C IF ((TYPE .EQ. 4) .OR. (TYPE .EQ. 28) .OR. (TYPE .EQ. 29)) THEN IF (OUTNEW(6,NUM) .EQ. 0.0) THEN KODE = 4 ARG1 = EPVAL(1) ARG2 = 10.0*RI*EPVAL(2)/EPVAL(1) GO TO 11 500 END IF C C BV C IF (ABS(OUTNEW(6,NUM) - PIO2) .LT. 1.0E-03) THEN KODE = 5 ARG1 = EPVAL(1) ARG2 = 10.0*RI*EPVAL(2)/EPVAL(1) GO TO 11 500 END IF END IF C C QUADRUPOLES C IF (TYPE .EQ. 5) THEN ARG1 = EPVAL(1) ARG2 = 0.1*RI*EPVAL(3)**2 IF (EPVAL(3) .GT. 0.0) THEN KODE = 2 ELSE KODE = 3 END IF GO TO 11 500 END IF GO TO 11 600 11500 CONTINUE WRITE (38,2009) KODE,ARG1,ARG2,0.0,LABELTO(1:5),1 11600 CONTINUE RETURN C\\\\\\\\\\\\\\\\\\\\ TO WRITE AUTOCAD \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ ENTRY WACAD C PRINT *,'ENTERED ACAD' WRITE (39,2808) 'LAYER' WRITE (39,2808) 'N' WRITE (39,2808) FILENAME(1:LFI)//'_MAGNETS' WRITE (39,2808) WRITE (39,2808) 'LAYER' WRITE (39,2808) 'N' WRITE (39,2808) FILENAME(1:LFI)//'_DRIFTS' WRITE (39,2808) WRITE (39,2808) 'LAYER' WRITE (39,2808) 'N' WRITE (39,2808) FILENAME(1:LFI)//'_LINE' WRITE (39,2808) XIP = OUTNEW(22,1) YIP = OUTNEW(23,1) ZIP = OUTNEW(24,1) CALL FXFLT (XIP,JXCI,FXCI) CALL FXFLT (YIP,JYCI,FYCI) CALL FXFLT (ZIP,JZCI,FZCI) RTOD = RADIAN IF (OUTNEW(6,1) .EQ. 0.0) THEN YAW = 90.0 - RTOD*(OUTNEW(25,1) - OUTNEW( 2,1)) ELSE YAW = 90.0 - RTOD*OUTNEW(25,1) END IF IF (YAW .LT. 0) YAW = YAW + 360.0 CALL FXFLT (YAW,JYWI,FYWI) JXCP = JXCI FXCP = FXCI JYCP = JYCI FYCP = FYCI JZCP = JZCI FZCP = FZCI JYWP = JYWI FYWP = FYWI DO 11 800 NUM = 1, ICOUNT IF (.NOT. OUTNEWL(NUM)) THEN C PRINT *, NUM, ICOUNT, JOUT,' <',OUTLAB(NUM),'>' GO TO 11 800 END IF ELEN = OUTNEW( 1,NUM)/0.3048 TYPE = IOUTTYP(NUM) IF (KELEM(TYPE)(1:1) .EQ. 'Q') THEN IF (NQUAD .GT. 0) THEN DO 11 700 IQ = 1, NQUAD IF (ELEN .EQ. QUADLEN(IQ)) THEN CESTYPE = QUADNAME(IQ) GO TO 11 710 END IF 11700 CONTINUE END IF NQUAD = NQUAD + 1 QUADLEN(NQUAD) = ELEN LQEN = INT(0.5 + 12.0E+02*ELEN) WRITE (CESTYPE,4001) 'TQ',LQEN QUADNAME(NQUAD) = CESTYPE 11710 CONTINUE ELSE IF (KELEM(TYPE)(2:5) .EQ. 'BEND') THEN IF (NBEND .GT. 0) THEN DO 11 720 IB = 1, NBEND IF (ELEN .EQ. BENDLEN(IB)) THEN CESTYPE = BENDNAME(IB) GO TO 11 730 END IF 11720 CONTINUE END IF NBEND = NBEND + 1 BENDLEN(NBEND) = ELEN LBEN = INT(0.5 + 12.0E+02*ELEN) WRITE (CESTYPE,4001) 'BM',LBEN BENDNAME(NBEND) = CESTYPE C PRINT *,'<',OUTLAB(NUM),'> ',OUTNEW(6,NUM) 11730 CONTINUE END IF 11800 CONTINUE WRITE (39,2808) 'UCS' WRITE (39,2808) 'W' WRITE (39,2808) 'LAYER' WRITE (39,2808) 'S' WRITE (39,2808) FILENAME(1:LFI)//'_MAGNETS' WRITE (39,2808) C PRINT *,'NQUAD=', NQUAD WRITE (39,2808) 'COLOR' WRITE (39,2808) 'YELLOW' DO 11 810 I = 1, NQUAD CALL FXFLT ( QUADLEN(I),JLEN,FLEN) CALL FXFLT ( QUADWID(I),JWID,FWID) CALL FXFLT (0.5*QUADWID(I),JWIH,FWIH) JLEN = INT(QUADLEN(I)) C FLEN = QUADLEN(I) - FLOAT(JLEN) C JWID = QUADWID(I) C FWID = QUADWID(I) - FLOAT(JWID) C WIDH = 0.5*QUADWID(I) C JWIH = WIDH C FWIH = WIDH - FLOAT(JWIH) WRITE (39,2808) 'PLINE' WRITE (39,2805) 0,0.0,0,0.0,0,0.0 !JXCI,FXCI,JZCI,FZCI,JYCI,FYCI ! WRITE (39,2800) JWIH, FWIH, 270.0 WRITE (39,2800) JLEN, FLEN, 0.0 WRITE (39,2800) JWID, FWID, 90.0 WRITE (39,2800) JLEN, FLEN, 180.0 WRITE (39,2808) 'C' WRITE (39,2808) 'BLOCK' WRITE (39,2808) QUADNAME(I) WRITE (39,2805) 0,0.0,0,0.0,0,0.0 !JXCI,FXCI,JZCI,FZCI,JYCI,FYCI ! WRITE (39,2808) 'L' WRITE (39,2808) 11810 CONTINUE WRITE (39,2808) 'COLOR' WRITE (39,2808) 'GREEN' C PRINT *,'NBEND=',NBEND DO 11 820 I = 1, NBEND CALL FXFLT ( BENDLEN(I),JLEN,FLEN) CALL FXFLT ( BENDWID(I),JWID,FWID) CALL FXFLT (0.5*BENDWID(I),JWIH,FWIH) WRITE (39,2808) 'PLINE' WRITE (39,2805) 0,0.0,0,0.0,0,0.0 !JXCI,FXCI,JZCI,FZCI,JYCI,FYCI ! WRITE (39,2800) JWIH,FWIH,270.0 WRITE (39,2800) JLEN,FLEN,0.0 WRITE (39,2800) JWID,FWID,90.0 WRITE (39,2800) JLEN,FLEN,180.0 WRITE (39,2808) 'C' WRITE (39,2808) 'BLOCK' WRITE (39,2808) BENDNAME(I) WRITE (39,2805) 0,0.0,0,0.0,0,0.0 !JXCI,FXCI,JZCI,FZCI,JYCI,FYCI ! WRITE (39,2808) 'L' WRITE (39,2808) 11820 CONTINUE WRITE (39,2808) 'UCS' WRITE (39,2808) 'R' WRITE (39,2808) 'DUSAF' DO 11 900 NUM = 1, ICOUNT IF (.NOT. OUTNEWL(NUM)) THEN C PRINT *,NUM,ICOUNT,JOUT,' <',OUTLAB(NUM),'>' GO TO 11 900 END IF TYPE = IOUTTYP(NUM) ELEN = OUTNEW( 1,NUM)/0.3048 XIO = OUTNEW(22,NUM) YIO = OUTNEW(23,NUM) ZIO = OUTNEW(24,NUM) CALL FXFLT (OUTNEW(22,NUM),JXCO,FXCO) CALL FXFLT (OUTNEW(23,NUM),JYCO,FYCO) CALL FXFLT (OUTNEW(24,NUM),JZCO,FZCO) IF (OUTNEW(6,NUM) .EQ. 0.0) THEN YAW = 90.0 - RTOD*(OUTNEW(25,NUM) - OUTNEW( 2,NUM)) ELSE YAW = 90.0 - RTOD*OUTNEW(25,NUM) END IF IF (YAW .LT. 0) YAW = YAW + 360.0 CALL FXFLT (YAW,JYWO,FYWO) IF (KELEM(TYPE)(1:2) .EQ. 'DR') THEN CESTYPE = 'DRIFT' WRITE (39,2808) 'COLOR' WRITE (39,2808) 'WHITE' WRITE (39,2807) JXCP, FXCP, JZCP, FZCP, JYCP, FYCP, 1 JXCO, FXCO, JZCO, FZCO, JYCO, FYCO ELSE IF (KELEM(TYPE)(1:1) .EQ. 'Q') THEN LQEN = INT(0.5 + 12.0E+02*ELEN) WRITE (CESTYPE,4001) 'TQ',LQEN WRITE (39,2808) 'COLOR' WRITE (39,2808) 'YELLOW' WRITE (39,2806) CESTYPE, JXCP, FXCP, JZCP, FZCP, JYCP, FYCP, 1 JYWP, FYWP ELSE IF (KELEM(TYPE)(2:5) .EQ. 'BEND') THEN WRITE (39,2808) 'COLOR' IF (OUTNEW(6,NUM) .EQ. 0.0) THEN WRITE (39,2808) 'GREEN' ELSE WRITE (39,2808) 'CYAN' ENDIF IF (ABS(OUTNEW(2,NUM)) .GT. 1.0D-06) THEN LBEN = INT(0.5 + 12.0E+02*ELEN) WRITE (CESTYPE,4001) 'BM',LBEN WRITE (39,2806) CESTYPE, JXCP, FXCP, JZCP, FZCP, 1 JYCP, FYCP, JYWP, FYWP ELSE WRITE (39,2807) JXCP, FXCP, JZCP, FZCP, JYCP, FYCP, 1 JXCO, FXCO, JZCO, FZCO, JYCO, FYCO END IF ELSE CESTYPE = 'CELLBDY' GO TO 11 900 END IF C JXCP = JXCO FXCP = FXCO JYCP = JYCO FYCP = FYCO JZCP = JZCO FZCP = FZCO JYWP = JYWO FYWP = FYWO XIP = XIO YIP = YIO ZIP = ZIO 11900 CONTINUE WRITE (39,2808) RETURN 2000 FORMAT (' ','"OUTPUT FROM TRANSPORT."'/ 1 ' ','"TITLE-" "',A,'" '/ 2 ' ','"RUN ON" "',A,'" " AT " "',A,'" " ."'/ 3 ' ',I6,' "ELEMENTS" ',I4,' "IN BEAM LINE." ',I2, 4 ' "ITEMS IN LIST."') 2001 FORMAT (' ',3I6,' "NAME" "<',A,'>" "TYPE" "<',A,'>".') 2002 FORMAT (' ',1P,4G16.8) 2003 FORMAT (' ','!DESCRIPTION OF DATA:'/ 1 ' ','!LINE 1 ITEMS 1- 4 L,THETA,K1,K2'/ 2 ' ','!LINE 2 ITEMS 5- 8 K3,TILT,ALPHAX,BETAX,'/ 3 ' ','!LINE 3 ITEMS 9-12 MUX,ETAX,ETAX'',ALPHAY'/ 4 ' ','!LINE 4 ITEMS 13-16 BETAY,MUY,ETAY,ETAY'''/ 5 ' ','!LINE 5 ITEMS 17-20 X(CENT),X''(CENT),', 6 'Y(CENT),Y''(CENT)'/ 7 ' ','!LINE 6 ITEMS 21-24 SUML,X,Y,Z(FLOOR)'/ 8 ' ','!LINE 7 ITEMS 25-30 YAW,PITCH,4*NOT DEFINED.') 2005 FORMAT ('! ',A) 2006 FORMAT (' ',A,1X,A) 2007 FORMAT ('! ',A,1P,G20.9) 2008 FORMAT (' ','!LATTICE FUNCTIONS AND TUNES.'/' ',6F12.5) 2009 FORMAT (I5,1X,F12.4,1X,E12.5,1X,F5.2,2X,A5,1X,I4) 2010 FORMAT (' ',I3/(' ','"',A,'" ',F20.6)) 2011 FORMAT (' ',I3/(' ','"',A,'" ')) 2014 FORMAT (' ',T10,A,1X,A) 2103 FORMAT (' ',A,F20.9:2X,A) 2104 FORMAT (' ',A,F20.9:2X,A,1X,A3,A) 2300 FORMAT (' ','CO',A,2X,1P,G25.15:2X,A) 2301 FORMAT (' ',5(A:1X):' + ') 2309 FORMAT (' ','LINE',4F9.3,F9.3,F9.5,F9.3,F9.5) 2310 FORMAT (' ','COORDI +'/ 1 ' ','XI ',F16.6,' YI ',F16.6,' ZI ',F16.6,' +'/ 2 ' ','YAW ',F10.6,' PITCH ',F10.6,' ROLL ',F4.1,' +'/ 3 ' ','UNITS ',F10.4,' CHARGE -1.0') 2510 FORMAT (' ','INITIAL: BETA0 &'/ 1 ' ','BETX=',F10.3,', ALFX=',F10.3,', BETY=',F10.3, 2 ', ALFY=',F10.3:', &'/ 3 ' ','DX=',F10.3,', DPX=',F10.4,', DY=',F10.4, 4 ', DPY=',F10.4) 2511 FORMAT (' ','SURVEY,X0=',F12.4,',Y0=',F12.4,',Z0=',F12.4,' &'/ 1 ' ','THETA0=',F10.5,',PHI0=',F10.5,',TAPE="',A, 2 '.SURVEY"') 2700 FORMAT (' ','BEAM, & '/ 1 ' ','BETAX=',F10.3,', ALPHAX=',F10.5,', & '/ 1 ' ','BETAY=',F10.3,', ALPHAY=',F10.5,', &'/ 2 ' ','EPSX= ',F10.5,', EPSY = ',F10.5,', &'/ 3 ' ','DEL=',F10.5,', P0=',F10.3) 2701 FORMAT (' ','ETA, ETAX= ',F10.3,', DETAX= ',1P,G13.3,' &'/ 1 ' ','ETAY= ', 0P,F10.3,', DETAY= ',1P,G13.3) 2702 FORMAT (' ',A,' : =',1P,G25.15) 2703 FORMAT (' ','BEAM, X = ',F10.3,', XP = ',F10.3,', Y = ', 1 F10.3,', YP = ',F10.3,', &'/,5X,' DL = ',F10.3, 2 ', DEL = ',F10.3,', P0 = ',F10.3) 2704 FORMAT (' ',A6,A3,A3,F8.5,A1,2X,A3,A3,F8.5,A1, 1 2X,A3,A3,F8.5,A1,2X,A3,A3,F8.5,A1,1X,A1) 2800 FORMAT ('@',I6.6,F6.5,'<',1P,E8.2) 2803 FORMAT (' ',I4.4,1X,A,1X,A,1X,7F15.5,1X,A) 2805 FORMAT (2(I6.6,F6.5,','),I6.6,F6.5) 2806 FORMAT ('INSERT'/A/2(I6.6,F6.5,','),I6.6,F6.5///I6.6,F6.5) 2807 FORMAT ('LINE'/2(2(I6.6,F6.5,','),I6.6,F6.5/)) 2808 FORMAT (A) 4000 FORMAT ('TILT=',F12.8) 4001 FORMAT (A2,I5.5) 4002 FORMAT ('WMADLBL',I4.4) END SUBROUTINE TWISS C C PRINTS BEAM OUTPUT IN COURANT-SNYDER PARAMETER NOTATION C (SOMETIMES ERRONEOUSLY CALLED "TWISS PARAMETERS") C C ---------------------------------------------------------------------- INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'COP.CIN' INCLUDE 'ELM0B.CIN' INCLUDE 'ELM1C.CIN' INCLUDE 'ELM1D.CIN' INCLUDE 'ELM7C.CIN' INCLUDE 'ELM13B.CIN' INCLUDE 'ELM13C.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'ELM15B.CIN' INCLUDE 'ELM15C.CIN' INCLUDE 'ETACOM.CIN' INCLUDE 'IOUNIT.CIN' C ------------------------------------------------------------------- LOGICAL UBIG, UNSEP REAL OUTPUT(10) C C CUMULATIVE LENGTH C ALONG = LC/UFLOOR(1) C C ACCELERATOR NOTATION C IF (.NOT. RECENT) CALL BEAM UBIG = UBEAM(1) .GT. 0.5 .AND. UBEAM(2) .GT. 0.5 IF (.NOT. SOFA .AND. .NOT. CPS) GO TO 20 IF (.NOT. CPR .AND. CPS) GO TO 20 DO 10 J = 1, 6 OUTPUT(J) = CEN(J)/UBEAM(J) 10 CONTINUE IF (.NOT. LCPR .AND. .NOT. UBIG) THEN WRITE (NOUT,1013) ALONG, XFLOOR(1), 1 (OUTPUT(J), XBEAM(J), J = 1, 6) 1013 FORMAT (1H ,8X,F10.3,1X,A4,11X,6(F8.3,1X,A4),1X,2F9.3) ELSE IF (.NOT. LCPR .AND. UBIG) THEN WRITE (NOUT,1018) ALONG, XFLOOR(1), 1 (OUTPUT(J), XBEAM(J), J = 1, 6) 1018 FORMAT (1H ,8X,F10.3,1X,A4,11X,6(F8.5,1X,A4),1X,2F9.3) ELSE IF (LCPR .AND. .NOT. UBIG) THEN WRITE (NOUT,1017) (OUTPUT(J), XBEAM(J), J = 1, 6) 1017 FORMAT (1H ,34X,6(F8.3,1X,A4),1X,2F9.3) ELSE WRITE (NOUT,1019) (OUTPUT(J), XBEAM(J), J = 1, 6) 1019 FORMAT (1H ,34X,6(F8.5,1X,A4),1X,2F9.3) ENDIF LCPR = .TRUE. C 20 UNSEP = SIT(1,3) .NE. 0.0 UNSEP = UNSEP .OR. SIT(1,4) .NE. 0.0 UNSEP = UNSEP .OR. SIT(2,3) .NE. 0.0 UNSEP = UNSEP .OR. SIT(2,4) .NE. 0.0 IF (WARN20 .AND. UNSEP) WRITE (NOUT,1012) 1012 FORMAT ('*** WARNING TRANSVERSE PLANES ARE NOT INDEPENDENT. ', 1 'TWISS PARAMETERS MAY NOT BE MEANINGFUL ***') C EPSX = SQRT(SIT(1,1)*SIT(2,2) - SIT(1,2)**2) EPSY = SQRT(SIT(3,3)*SIT(4,4) - SIT(3,4)**2) OUTPUT(1) = PSIX/UNITO(12) OUTPUT(2) = PSIY/UNITO(12) OUTPUT(3) = SIT(1,1)*UBEAM(2)/(EPSX*UBEAM(1)) OUTPUT(4) = SIT(3,3)*UBEAM(4)/(EPSY*UBEAM(3)) OUTPUT(5) = - SIT(1,2)/EPSX OUTPUT(6) = - SIT(3,4)/EPSY OUTPUT(7) = ETA(1)/UBEAM(1) OUTPUT(8) = ETA(3)/UBEAM(3) OUTPUT(9) = ETA(2)/UBEAM(2) OUTPUT(10) = ETA(4)/UBEAM(4) IF (.NOT. LCPR) THEN WRITE (NOUT,1025) ALONG, XFLOOR(1), (OUTPUT(J), J = 1, 10) 1025 FORMAT (1H ,8X,F10.3,1X,A4,8X,10F10.4) ELSE WRITE (NOUT,1026) (OUTPUT(J), J = 1, 10) 1026 FORMAT (1H ,31X,10F10.4) ENDIF IF (WARN20 .AND. UNSEP) WRITE (NOUT,1012) C LCPR = .TRUE. TDUN = .TRUE. RETURN END SUBROUTINE TWIT1C C C DETERMINES CONTRIBUTION OF FIRST-ORDER TRANSFER MATRIX TO C TRANSFORM OF PARTIALS OF BEAM CENTROID C C ---------------------------------------------------------------------- INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'COCOM.CIN' INCLUDE 'ELM7D.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'R.CIN' C DO 110 J = 1, 6 SS = 0.0 DO 105 K = 1, 6 SS = SS + R(J,K)*COV(K,NV2) 105 CONTINUE COT(J) = SS 110 CONTINUE C RETURN END SUBROUTINE TWIT1E C C DETERMINES CONTRIBUTION OF FIRST-ORDER TRANSFER MATRIX TO C TRANSFORM OF PARTIALS OF ETA FUNCTION C C ---------------------------------------------------------------------- INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ETACOM.CIN' INCLUDE 'ETATC.CIN' INCLUDE 'R.CIN' C DO 10 J = 1, 6 SS = 0.0 DO 5 K = 1, 6 SS = SS + R(J,K)*ETAV(K,NV2) 5 CONTINUE ETAT(J) = SS 10 CONTINUE C RETURN END SUBROUTINE TWIT2C C C DETERMINES CONTRIBUTION OF SECOND-ORDER TRANSFER MATRIX TO C TRANSFORM OF PARTIALS OF BEAM CENTROID C C ---------------------------------------------------------------------- INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'COCOM.CIN' INCLUDE 'ELM7D.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'T.CIN' C C LOCAL VARIABLES C C C SECOND ORDER TERMS C DO 20 J = 1, 5 IND = 0 SS = COT(J) DO 10 L2 = 1, 6 DO 10 L1 = 1, L2 IND = IND + 1 SS = SS + T(J,IND)*(CO(L1)*COV(L2,NV2) 1 + COV(L1,NV2)*CO(L2)) 10 CONTINUE COT(J) = SS 20 CONTINUE C RETURN END SUBROUTINE TWIT2E C C DETERMINES CONTRIBUTION OF SECOND-ORDER TRANSFER MATRIX TO C TRANSFORM OF PARTIALS OF ETA FUNCTION C C ---------------------------------------------------------------------- INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ETACOM.CIN' INCLUDE 'ETATC.CIN' INCLUDE 'T.CIN' C C TRANSFORM DERIVATIVE OF ETA FUNCTION C SECOND ORDER TERMS C DO 20 J = 1, 5 IND = 0 SS = ETAT(J) DO 10 L2 = 1, 6 DO 10 L1 = 1, L2 IND = IND + 1 SS = SS + T(J,IND)*(ETA(L1)*ETAV(L2,NV2) 1 + ETAV(L1,NV2)*ETA(L2)) 10 CONTINUE ETAT(J) = SS 20 CONTINUE C RETURN END SUBROUTINE TWIT2R C C DETERMINES CONTRIBUTION OF SECOND-ORDER TRANSFER MATRIX AND C PARTIAL OF BEAM CENTROID TO PARTIAL OF FIRST-ORDER TRANSFER C MATRIX USING OFF-AXIS EXPANSION C C ---------------------------------------------------------------------- INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'COCOM.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'RS.CIN' INCLUDE 'T.CIN' C C CONTRIBUTION OF SECOND ORDER TO FIRST C DO 10 J = 1, 6 DO 10 K = 1, 6 RT(J,K) = 0.0 10 CONTINUE C DO 20 J = 1, 5 IND = 0 DO 20 L2 = 1, 6 DO 20 L1 = 1, L2 IND = IND + 1 RT(J,L1) = RT(J,L1) + T(J,IND)*COV(L2,NV2) RT(J,L2) = RT(J,L2) + T(J,IND)*COV(L1,NV2) 20 CONTINUE C RETURN END SUBROUTINE TWIT3C C C DETERMINES CONTRIBUTION OF THIRD-ORDER TRANSFER MATRIX TO C TRANSFORM OF PARTIALS OF BEAM CENTROID C C ---------------------------------------------------------------------- INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'COCOM.CIN' INCLUDE 'ELM7D.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'U.CIN' C C TRANSFORM DERIVATIVE OF REFERENCE TRAJECTORY DISPLACEMENT C DO 20 J = 1, 5 SS = 0.0 IND = 0 DO 10 L3 = 1, 6 DO 10 L2 = 1, L3 DO 10 L1 = 1, L2 IND = IND + 1 SS = SS + U(J,IND)*(CO(L1)*CO(L2)*COV(L3,NV2) 1 + CO(L1)*COV(L2,NV2)*CO(L3) 2 + COV(L1,NV2)*CO(L2)*CO(L3)) 10 CONTINUE COT(J) = COT(J) + SS 20 CONTINUE C 400 RETURN END SUBROUTINE TWIT3E C C DETERMINES CONTRIBUTION OF THIRD-ORDER TRANSFER MATRIX TO C TRANSFORM OF PARTIALS OF ETA FUNCTION C C ---------------------------------------------------------------------- INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ETACOM.CIN' INCLUDE 'ETATC.CIN' INCLUDE 'U.CIN' C C TRANSFORM DERIVATIVE OF ETA C DO 20 J = 1, 5 SS = 0.0 IND = 0 DO 10 L3 = 1, 6 DO 10 L2 = 1, L3 DO 10 L1 = 1, L2 IND = IND + 1 SS = SS + U(J,IND)*(ETA(L1)*ETA(L2)*ETAV(L3,NV2) 1 + ETA(L1)*ETAV(L2,NV2)*ETA(L3) 2 + ETAV(L1,NV2)*ETA(L2)*ETA(L3)) 10 CONTINUE ETAT(J) = ETAT(J) + SS 20 CONTINUE C RETURN END SUBROUTINE TWIT3R C C DETERMINES CONTRIBUTION OF THIRD-ORDER TRANSFER MATRIX AND C PARTIAL OF BEAM CENTROID TO PARTIAL OF FIRST- AND SECOND-ORDER C TRANSFER MATRICES USING OFF-AXIS EXPANSION C C ---------------------------------------------------------------------- INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'COCOM.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'RS.CIN' INCLUDE 'TS.CIN' INCLUDE 'U.CIN' C----------------------------------------------------------------------- C C C CONTRIBUTION TO DERIVATIVE OF FIRST-ORDER MATRIX OF C INDIVIDUAL ELEMENT FROM DERIVATIVE OF REFERENCE TRAJECTORY C DISPLACEMENT AND THIRD-ORDER MATRIX C DO 20 J = 1, 5 IND = 0 DO 10 L3 = 1, 6 DO 10 L2 = 1, L3 DO 10 L1 = 1, L2 IND = IND + 1 RT(J,L1) = RT(J,L1) + U(J,IND)*(CO(L2)*COV(L3,NV2) 1 + COV(L2,NV2)*CO(L3)) RT(J,L2) = RT(J,L2) + U(J,IND)*(CO(L1)*COV(L3,NV2) 1 + COV(L1,NV2)*CO(L3)) RT(J,L3) = RT(J,L3) + U(J,IND)*(CO(L1)*COV(L2,NV2) 1 + COV(L1,NV2)*CO(L2)) 10 CONTINUE 20 CONTINUE C C CONTRIBUTION TO DERIVATIVE OF SECOND-ORDER MATRIX OF C INDIVIDUAL ELEMENT FROM DERIVATIVE OF REFERENCE TRAJECTORY C DISPLACEMENT AND THIRD-ORDER MATRIX C IF (NORD2 .LE. 1) GO TO 100 DO 30 J = 1, 5 DO 30 K = 1, 21 TT(J,K) = 0.0 30 CONTINUE C DO 60 J = 1, 5 IND = 0 IND13 = 0 IND23 = 0 DO 50 L3 = 1, 6 IND12 = 0 IND13I = IND13 DO 40 L2 = 1, L3 IND13 = IND13I IND23 = IND23 + 1 DO 40 L1 = 1, L2 IND = IND + 1 IND12 = IND12 + 1 IND13 = IND13 + 1 UFAC = U(J,IND) IF (UFAC .NE. 0.0) THEN TT(J,IND12) = TT(J,IND12) + UFAC*COV(L3,NV2) TT(J,IND13) = TT(J,IND13) + UFAC*COV(L2,NV2) TT(J,IND23) = TT(J,IND23) + UFAC*COV(L1,NV2) ENDIF 40 CONTINUE 50 CONTINUE 60 CONTINUE C 100 RETURN END SUBROUTINE TWITCH C C ADVANCES PARTIAL DERIVATIVE OF TRANSFER MATRIX ABOUT DISPLACED C ORBIT C C ---------------------------------------------------------------------- INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'COCOM.CIN' INCLUDE 'COP.CIN' INCLUDE 'ELM7D.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'ETACOM.CIN' INCLUDE 'ETAP.CIN' INCLUDE 'ETATC.CIN' INCLUDE 'R2P.CIN' C C CONTRIBUTION TO DERIVATIVE OF FIRST-ORDER MATRIX OF C INDIVIDUAL ELEMENT FROM DERIVATIVE OF REFERENCE TRAJECTORY C DISPLACEMENT USING SHIFTED REFERENCE C IF (.NOT. CVP(NV2)) GO TO 100 IF (NORD1 .GE. 2) CALL TWIT2R IF (NORD1 .GE. 3) CALL TWIT3R IF (NORD1 .GE. 2) R2VP(NV2) = .TRUE. C C TRANSFORM DERIVATIVE OF REFERENCE TRAJECTORY DISPLACEMENT C CALL TWIT1C IF (NORD1 .GE. 2) CALL TWIT2C IF (NORD1 .GE. 3) CALL TWIT3C DO 10 J = 1, 6 10 COV(J,NV2) = COT(J) C C TRANSFORM DERIVATIVE OF ETA C 100 IF (EVP(NV2)) THEN CALL TWIT1E IF (NORD1 .GE. 2) CALL TWIT2E IF (NORD1 .GE. 3) CALL TWIT3E DO 110 J = 1, 6 110 ETAV(J,NV2) = ETAT(J) ENDIF C 200 RETURN END SUBROUTINE UNITS(J) C C MAKES UNITS CHANGES C C ---------------------------------------------------------------------- INCLUDE 'CONSTS.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'ELM15B.CIN' INCLUDE 'ELM15C.CIN' INCLUDE 'FLUSHC.CIN' INCLUDE 'INDPAR.CIN' INCLUDE 'IOUNIT.CIN' INCLUDE 'UMAD.CIN' INCLUDE 'UMETER.CIN' INCLUDE 'UMICR.CIN' INCLUDE 'UMM.CIN' INCLUDE 'UORIG.CIN' INCLUDE 'UTRANS.CIN' INCLUDE 'XMAD.CIN' INCLUDE 'XMETER.CIN' INCLUDE 'XMICR.CIN' INCLUDE 'XMM.CIN' INCLUDE 'XORIG.CIN' INCLUDE 'XTRANS.CIN' C ---------------------------------------------------------------------- CHARACTER*4 UTABLE(19) LOGICAL INPUT, OUTPUT, ELEMEN, BEAM, FLOOR, ALIGN REAL CTABLE(19) C DATA NUNIT /19/, NUNITS /14/ DATA UTABLE /'M' , 'CM' , 'MM' , 'MICR', 'IN', 'FT' , 1 'R' , 'MR' , 'MUR', 'DEG', 'N', 'PC' , 2 'PM', 'PMIC', 'GEV', 'MEV', 'KG', 'G' , 3 'TUNE' / DATA CTABLE / 1.0, 0.01, 0.001, 1.E-6, .0254, .3048, 1 1.0, 0.001, 1.E-6, 0.0, 1.0, 0.01, 2 0.001, 1.E-6, 1.0, 0.001, 1.0, 0.001, 3 0.0 / C C DETERMINE WHICH UNITS ARE TO BE CHANGED C CTABLE(19) = 2.0*PI IF (J .GE. 82 .AND. J .LE. 86) GO TO 300 IF (J .GT. NUNITS) GO TO 400 IF (J .EQ. 0) GO TO 300 INPUT = IPTOJ(3) .GE. 1 OUTPUT = IPTOJ(4) .GE. 1 IF (.NOT. INPUT .AND. .NOT. OUTPUT) THEN INPUT = .TRUE. OUTPUT = .TRUE. ENDIF ELEMEN = IPTOJ(5) .GE. 1 BEAM = IPTOJ(6) .GE. 1 FLOOR = IPTOJ(7) .GE. 1 ALIGN = IPTOJ(8) .GE. 1 IF (J .LE. 2 .AND. .NOT. ELEMEN .AND. .NOT. BEAM .AND. 1 .NOT. ALIGN) THEN ELEMEN = .TRUE. BEAM = .TRUE. ALIGN = .TRUE. ENDIF IF (J .GE. 3 .AND. J .LE. 6 .AND. .NOT. ELEMEN .AND. .NOT. BEAM) 1 THEN ELEMEN = .TRUE. BEAM = .TRUE. ENDIF IF (J .EQ. 7 .OR. J .EQ. 8 .AND. .NOT. ELEMEN .AND. .NOT. FLOOR) 1 THEN ELEMEN = .TRUE. FLOOR = .TRUE. ENDIF IF (J .GE. 9) ELEMEN = .TRUE. C C DETERMINE CONVERSION FACTOR C IF (USIZE .NE. 0.0) THEN UFAC = UORIG(J)*USIZE ELSE DO 210 JU = 1, NUNIT JJ = JU IF (XNAME .EQ. UTABLE(JU)) GO TO 230 210 CONTINUE WRITE (NOUT,9002) 9002 FORMAT ('0ERROR ON UNITS ELEMENT') FLUSHL = .TRUE. GO TO 400 C 230 JU = JJ IF (XNAME .EQ. 'DEG') THEN UFAC = 1.0/RADIAN ELSE UFAC = CTABLE(JU) ENDIF ENDIF C C CHANGE UNITS FOR PARTICULAR COORDINATE OR PARAMETER C 250 IF (ELEMEN) THEN IF (INPUT) UNITI(J) = UFAC IF (OUTPUT) THEN UNITO(J) = UFAC XDIME(J) = XNAME ENDIF ENDIF IF (J .LE. 6 .AND. BEAM) THEN UBEAM(J) = UFAC XBEAM(J) = XNAME ENDIF IF (J .LE. 2 .AND. ALIGN) THEN UMIS(J) = UFAC XMIS(J) = XNAME ENDIF IF (J .EQ. 7 .AND. FLOOR) THEN UFLOOR(2) = UFAC XFLOOR(2) = XNAME ENDIF IF (J .EQ. 8 .AND. FLOOR) THEN UFLOOR(1) = UFAC XFLOOR(1) = XNAME ENDIF IF ((J .EQ. 10 .OR. J .EQ. 11) .AND. ELEMEN) THEN IF (INPUT) UNITI(J) = UNITI(J)*10.0**10/CLIGHT IF (OUTPUT) UNITO(J) = UNITO(J)*10.0**10/CLIGHT ENDIF C IF (J .LE. 2) THEN IF (ELEMEN) THEN IF (INPUT) UNITI(J+2) = UFAC IF (OUTPUT) THEN UNITO(J+2) = UFAC XDIME(J+2) = XNAME ENDIF ENDIF IF (BEAM) THEN UBEAM(J+2) = UFAC XBEAM(J+2) = XNAME ENDIF ENDIF GO TO 400 C C RESET UNITS, EMPTY TYPE 15 CARD ENCOUNTERED C 300 DEGREE = 1.0/RADIAN UMAD(12) = 2.0*PI UTRANS(7) = DEGREE UTRANS(10) = EMASS UTRANS(12) = DEGREE UTRANS(13) = DEGREE UMETER(12) = DEGREE UMETER(13) = DEGREE UMM(12) = DEGREE UMM(13) = DEGREE UMICR(12) = DEGREE UMICR(13) = DEGREE C IF (J .EQ. 82) THEN DO 305 II = 1, 14 UORIG(II) = UMAD(II) 305 XORIG(II) = XMAD(II) ELSE IF (J .EQ. 0 .OR. J .EQ. 83) THEN DO 306 II = 1, 14 UORIG(II) = UTRANS(II) 306 XORIG(II) = XTRANS(II) ELSE IF (J .EQ. 84) THEN DO 307 II = 1, 14 UORIG(II) = UMETER(II) 307 XORIG(II) = XMETER(II) ELSE IF (J .EQ. 85) THEN DO 308 II = 1, 14 UORIG(II) = UMM(II) 308 XORIG(II) = XMM(II) ELSE IF (J .EQ. 86) THEN DO 309 II = 1, 14 UORIG(II) = UMICR(II) 309 XORIG(II) = XMICR(II) ENDIF C DO 310 II = 1, 14 UNITI(II) = UORIG(II) UNITO(II) = UORIG(II) XDIME(II) = XORIG(II) 310 CONTINUE UNITI(10) = UNITI(10)*10.0**10/CLIGHT UNITO(10) = UNITO(10)*10.0**10/CLIGHT UNITI(11) = UNITI(11)*10.0**10/CLIGHT UNITO(11) = UNITO(11)*10.0**10/CLIGHT DO 320 II = 1, 6 UBEAM(II) = UORIG(II) XBEAM(II) = XORIG(II) 320 CONTINUE DO 330 II = 1, 2 UMIS(II) = UORIG(II) XMIS(II) = XORIG(II) 330 CONTINUE UFLOOR(1) = UORIG(8) UFLOOR(2) = UORIG(7) XFLOOR(1) = XORIG(8) XFLOOR(2) = XORIG(7) C 400 RETURN END SUBROUTINE UPDAT2 C C UPDATE AUXILLIARY TRANSFER MATRIX R2 C C ---------------------------------------------------------------------- INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'OCP.CIN' INCLUDE 'R2VT.CIN' INCLUDE 'RC.CIN' INCLUDE 'RCP.CIN' INCLUDE 'RC2.CIN' INCLUDE 'RS.CIN' INCLUDE 'R2P.CIN' INCLUDE 'R3P.CIN' DIMENSION RCVS(6,6), RCVSL(36) EQUIVALENCE (RCVS(1,1),RCVSL(1)) C IF (R3P) CALL UPDAT3 IF (NORD2 .LT. 1) GO TO 280 C C BEAM UPDATE C IF (NORD3 .GE. 1) CALL UPSIG C C PARTIAL DERIVATIVES OF ACCUMULATED R MATRIX C 15 IF (NV1 .LT. 1) GO TO 200 DO 190 N = 1, NV1 C C R2 TIMES DERIVATIVE OF R1 C IF (.NOT. RVP(N)) GO TO 100 DO 40 JK = 1, 36 RCVSL(JK) = RCVL(JK,N) 40 CONTINUE CALL CAB(RS,RC2,RCVS) 45 DO 50 JK = 1, 36 50 RCVL(JK,N) = RSL(JK) C C DERIVATIVE OF R2 TIMES R1 C 100 IF (RCP) GO TO 130 DO 110 JK = 1, 36 110 RCVL(JK,N) = R2VL(JK,N) GO TO 180 C 130 IF (.NOT. R2VP(N)) GO TO 180 DO 140 JK = 1, 36 140 R2VTL(JK) = R2VL(JK,N) CALL CAB(RS,R2VT,RC) IF (.NOT. RVP(N)) THEN DO 150 JK = 1, 36 150 RCVL(JK,N) = RSL(JK) ELSE C DO 160 JK = 1, 36 160 RCVL(JK,N) = RCVL(JK,N) + RSL(JK) ENDIF 180 CONTINUE RVP(N) = RVP(N) .OR. R2VP(N) R2VP(N) = .FALSE. 190 CONTINUE C C ACCUMULATED R C 200 CALL MR2RC CALL RSTORC 280 RCP = RCP .OR. R2P R2P = .FALSE. OCP(3) = .FALSE. RETURN END SUBROUTINE UPDAT3 C C UPDATE R3 MATRIX (USED IN FITTING) C C ---------------------------------------------------------------------- INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'R2P.CIN' INCLUDE 'R3P.CIN' C C PRELIMINARY CALCULATION C IF (NORD2 .LT. 1) GO TO 300 C C CUMULATIVE R2 MATRIX C 100 CALL MR3R2 C C R3 TIMES DERIVATIVE OF R2 C 200 IF (NV1 .GE. 1) THEN DO 220 N = 1, NV1 IF (R2VP(N)) CALL MR3R2V(N) 220 CONTINUE ENDIF C 300 R2P = R2P .OR. R3P R3P = .FALSE. RETURN END SUBROUTINE UPDATE C C RESETS FLAGS SO THAT ACCUMULATION OF THE R1 TRANSFER MATRIX C WILL BEGIN ANEW C C ---------------------------------------------------------------------- INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM1E.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM17A.CIN' INCLUDE 'OCP.CIN' INCLUDE 'RCP.CIN' INCLUDE 'R2P.CIN' INCLUDE 'R3P.CIN' C IF (NORD3 .GE. 1) CALL UPSIG PSIXO = 0.0 PSIYO = 0.0 RCP = .FALSE. R2P = .FALSE. R3P = .FALSE. OCP(2) = .FALSE. OCP(3) = .FALSE. IF (NV1 .GE. 1) THEN DO 100 N = 1, NV1 RVP(N) = .FALSE. R2VP(N) = .FALSE. 100 CONTINUE ENDIF RETURN END SUBROUTINE UPMARK C INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA0A.CIN' INCLUDE 'DATA1A.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM0C.CIN' INCLUDE 'ELM8A.CIN' INCLUDE 'ELM8G.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'FLUSHC.CIN' INCLUDE 'INDPAR.CIN' INCLUDE 'IOUNIT.CIN' INCLUDE 'LXRAN.CIN' INCLUDE 'STEPT1.CIN' C C LOCAL VARIABLES C INTEGER IADR, IADRM, ICODE, IDATA, IS, J, NUPS EXTERNAL IDATA C IF (ALIGN) THEN IR = INT(DATA(I+2)) + 1 IADR = I + IPTOJ(4) NUPS = IDATA(IADR) IF (NUPS .NE. 0) THEN DO 80 NAL = 1, NUPS IF (NAL .GT. 10) THEN WRITE (NOUT,9001) 9001 FORMAT (' *** TOO MANY NESTED MISALIGNMENTS') FLUSHL = .TRUE. GO TO 200 ENDIF TYPEC = 8 IADRM = IADR + 1 + NUPS - NAL NMIS = IDATA(IADRM) IS = ISTOR(NMIS) ICODE = INT(DATA(IS+7)) LFM = ICODE/100 DO 60 J = 1, 25 60 IPTOJB(J) = IPTOJ(J) CALL SKETCH(NMIS) IF (LFM .GE. 1) THEN LXRAN = LFM .EQ. 2 IF (NV3 .GE. 1) THEN CALL DERIVE ELSE CALL ELICIT IF (.NOT. LSTEPN) THEN CALL POSTER CALL MPRINT ENDIF ENDIF IF (FLUSHL) GO TO 200 IF (TYPE .LE. 0) GO TO 200 ENDIF DO 70 J = 1, 25 70 IPTOJ(J) = IPTOJB(J) 80 CONTINUE ENDIF ENDIF C 200 RETURN END SUBROUTINE UPMIS C C UPDATE MISALIGNMENT TABLES C C ---------------------------------------------------------------------- INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM8H.CIN' INCLUDE 'ELM8J.CIN' INCLUDE 'ELM8M.CIN' C --------------------------------------------------------------------- REAL WORK(6,6) C C MISALIGNMENT TABLE BEAM SIZE C DO 100 N = 1, NMMAX IF (.NOT. LNMT(N)) GO TO 100 DO 90 M = 1, 6 C DO 70 L1 = 1, 6 DO 70 L2 = 1, 6 S = 0.0 DO 65 L3 = 1, 6 LPL = 6*L3 + L2 - 6 L1L3 = 6*L3 + L1 - 6 S = S + RC2M(L1L3,M,N)*SIM(LPL,M,N) 65 CONTINUE WORK(L1,L2) = S 70 CONTINUE C DO 80 L1 = 1, 6 DO 80 L2 = 1, L1 LPL = 6*L1 + L2 - 6 LXL = 6*L2 + L1 - 6 S = 0.0 DO 75 L3 = 1, 6 L1L3 = 6*L3 + L1 - 6 S = S + RC2M(L1L3,M,N)*WORK(L2,L3) 75 CONTINUE SIM(LPL,M,N) = S SIM(LXL,M,N) = SIM(LPL,M,N) 80 CONTINUE C 90 CONTINUE R2PM(N) = .FALSE. 100 CONTINUE C RETURN END SUBROUTINE UPSIG C C UPDATE BEAM MATRIX AND ITS PARTIAL DERIVATIVES C C ---------------------------------------------------------------------- INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'COCOM.CIN' INCLUDE 'ELM1C.CIN' INCLUDE 'ELM1D.CIN' INCLUDE 'ELM7C.CIN' INCLUDE 'ELM8H.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'R2VT.CIN' INCLUDE 'RC2.CIN' INCLUDE 'RS.CIN' INCLUDE 'R2P.CIN' INCLUDE 'SI.CIN' INCLUDE 'SVP.CIN' DIMENSION SVS(6,6) C ---------------------------------------------------------------------- C C CALCULATION OF BEAM PARAMETERS C IF (NM .GT. 0) CALL UPMIS IF (.NOT. RECENT) CALL BEAM C C PARTIAL DERIVATIVES OF BEAM PARAMETERS C IF (NV1 .LT. 1) GO TO 110 CALL CAB(RS,RC2,SI) DO 100 N = 1, NV1, 1 C C TRANSFORMATION OF PARTIAL DERIVATIVES OF PREVIOUS BEAM PARAMETERS C IF (SVP(N)) THEN DO 50 JU = 1, 6 DO 50 KU = 1, 6 SVS(JU,KU) = SV(JU,KU,N) 50 CONTINUE CALL CAB(RT,RC2,SVS) CALL CABT(SVS,RC2,RT) DO 60 JU = 1, 6 DO 60 KU = 1, 6 SV(JU,KU,N) = SVS(JU,KU) 60 CONTINUE ENDIF C C EFFECT OF DERIVATIVE OF R MATRIX ON PREVIOUS BEAM PARAMETERS C IF (.NOT. R2VP(N)) GO TO 100 DO 70 JK = 1, 36 R2VTL(JK) = R2VL(JK,N) 70 CONTINUE CALL CABT(RT,R2VT,RS) C IF (.NOT. SVP(N)) THEN DO 80 JU = 1, 6 DO 80 KU = 1, 6 SV(JU,KU,N) = RT(JU,KU) + RT(KU,JU) 80 CONTINUE ELSE C DO 90 JU = 1, 6 DO 90 KU = 1, JU SV(JU,KU,N) = SV(JU,KU,N) + RT(JU,KU) + RT(KU,JU) 90 CONTINUE ENDIF C CONTINUE SVP(N) = .TRUE. 100 CONTINUE C C NEW BEAM PARAMETERS C 110 DO 120 JU = 1, 6 120 CO(JU) = CEN(JU) DO 130 JU = 1, 6 DO 130 KU = 1, 6 SI(JU,KU) = SIT(JU,KU) 130 CONTINUE PSIX1 = PSIX PSIY1 = PSIY RETURN END INTEGER FUNCTION VARST(JV) C C FIND VARY CODE FOR PARTICULAR PARAMETER C C ---------------------------------------------------------------------- INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA0A.CIN' INCLUDE 'DATA0B.CIN' INCLUDE 'DATA1A.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM0C.CIN' INCLUDE 'ELM2B.CIN' INCLUDE 'ELM2D.CIN' INCLUDE 'ELM8A.CIN' INCLUDE 'ELM8G.CIN' INCLUDE 'ELM13A.CIN' INCLUDE 'ELM17B.CIN' INCLUDE 'INDBND.CIN' INCLUDE 'INDPAR.CIN' INCLUDE 'NELMS.CIN' C INTEGER CDBV EXTERNAL IDATA C VARST = 0 NMAX = NELMS(TYPE) C IF (TYPE .EQ. 6 .OR. TYPE .EQ. 37) GO TO 80 IF (TYPE .EQ. 13) THEN CDBV = INT(DATA(I+1)) IF (CDBV .EQ. 9) GO TO 40 ENDIF IF (TYPE .EQ. 14) THEN IF (DATA(I+30) .NE. 0.0) NMAX = 29 IF (DATA(I+8) .NE. 0.0) NMAX = 7 ENDIF C IF (JV .GT. NMAX) GO TO 100 IPARM = IPTOJ(JV) IF (IPARM .EQ. 0) GO TO 100 IF (TYPE .EQ. 28 .OR. TYPE .EQ. 29) GO TO 50 IF (TYPE .EQ. 42) GO TO 55 IADR = I + IPARM 10 NVARY = TIE(IADR) IF (NVARY .EQ. 100) THEN IADR = IDATA(IADR) GO TO 10 ENDIF VARST = NVARY GO TO 900 C 40 VARST = JV GO TO 900 C 50 IF (TYPEC .EQ. 2) THEN IF (BEFORE) THEN IF (JV .EQ. NE1 .OR. JV .EQ. NH1) GO TO 60 IF ((JV .EQ. NBV .OR. JV .EQ. NANG) .AND. IPTOJ(NE1) .EQ. 0) 1 GO TO 60 ELSE IF (JV .EQ. NE2 .OR. JV .EQ. NH2) GO TO 60 IF ((JV .EQ. NBV .OR. JV .EQ. NANG) .AND. IPTOJ(NE2) .EQ. 0) 1 GO TO 60 ENDIF IE1 = IPTOJ(NE1) IE2 = IPTOJ(NE2) IF (TYPE .EQ. 28 .AND. ((BEFORE .AND. IE1 .EQ. 0) 1 .OR. (.NOT. BEFORE .AND. IE2 .EQ. 0))) THEN IF (JV .EQ. NL .OR. JV .EQ. NBV .OR. JV .EQ. NRHO 1 .OR. JV .EQ. NANG) GO TO 60 ENDIF IF (JV .EQ. NHGAP .OR. JV .EQ. NFINT) GO TO 60 ELSE IF (TYPEC .EQ. 4) THEN IF ((JV .GE. NL .AND. JV .LE. NK1P) 1 .OR. (JV .GE. NBDB .AND. JV .LE. NK2P) 2 .OR. JV .EQ. NGAM .OR. JV .EQ. NK3 3 .OR. (JV .EQ. NTILT .AND. REFER)) GO TO 60 ELSE IF (TYPEC .EQ. 20) THEN IF (JV .EQ. NTILT) GO TO 60 ENDIF VARST = 0 GO TO 900 C 55 IF (TYPEC .EQ. 35) THEN IF (JV .EQ. 1 .OR. JV .EQ. 2 .OR. JV .EQ. 3) GO TO 60 ELSE IF (TYPEC .EQ. 20) THEN IF (JV .EQ. 2 .OR. JV .EQ. 3) GO TO 60 ENDIF VARST = 0 GO TO 900 C 60 IF (IPARM .EQ. 0) GO TO 100 IADR = I + IPARM 65 NVARY = TIE(IADR) IF (NVARY .EQ. 100) THEN IADR = IDATA(IADR) GO TO 65 ENDIF VARST = NVARY GO TO 900 C 80 IF (RORC .GT. 0) THEN IADR = I + IPTOJB(4) NMISV = IDATA(IADR+NAL) ELSE NMISV = NIM(1,NAL) ENDIF IMIS = ISTOR(NMISV) NVARY = TIE(IMIS + JV) VARST = NVARY GO TO 900 C 100 IF (TYPEC .EQ. 4) GO TO 200 IF (TYPE .EQ. 2) GO TO 150 VARST = 0 GO TO 900 C 150 IF (JV .EQ. 5) GO TO 180 IF (JV .EQ. 4) GO TO 160 GO TO 900 C 160 IF (BEFORE) THEN VARST = VARS(1) ELSE VARST = VARS(2) ENDIF GO TO 900 C 180 NBVARY = TIE(IBVARY) VARST = NBVARY GO TO 900 C 200 IF (JV .EQ. NRMPS) VARST = VARS(3) IF (JV .EQ. NRNMS) VARST = VARS(4) IF (JV .EQ. NVR) VARST = VARS(5) IF (JV .EQ. NNP) VARST = VARS(6) IF (JV .EQ. NBDB) VARST = VARS(7) IF (JV .EQ. NBDBP) VARST = VARS(8) IF (JV .EQ. NGAM) VARST = VARS(9) C 900 RETURN END SUBROUTINE VERN C C CALCULATES BEAM CENTROID DISPLACEMENT AND TRANSFER MATRIX FOR C A VERNIER MAGNET C C ---------------------------------------------------------------------- INCLUDE 'ELM0B.CIN' INCLUDE 'ELM4A.CIN' INCLUDE 'ELM7B.CIN' INCLUDE 'R.CIN' C COD(1) = - 0.5*AL*L COD(2) = - AL R(1,2) = L R(3,4) = L R(1,6) = 0.5*AL*L R(2,6) = AL R(5,2) = 0.5*H0*L**2 RETURN END SUBROUTINE VPRINT C C PRINT VARY CODES C C ---------------------------------------------------------------------- INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA0A.CIN' INCLUDE 'DATA0B.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'DATA2B.CIN' INCLUDE 'DATA2D.CIN' INCLUDE 'DBEAM.CIN' INCLUDE 'DBEND.CIN' INCLUDE 'DCENT.CIN' INCLUDE 'DCVTY.CIN' INCLUDE 'DDRFT.CIN' INCLUDE 'DETA.CIN' INCLUDE 'DHKICK.CIN' INCLUDE 'DKICK.CIN' INCLUDE 'DMIS.CIN' INCLUDE 'DOCT.CIN' INCLUDE 'DQUAD.CIN' INCLUDE 'DRBND.CIN' INCLUDE 'DROT.CIN' INCLUDE 'DSEXT.CIN' INCLUDE 'DSHIFT.CIN' INCLUDE 'DSOLE.CIN' INCLUDE 'DSPEC.CIN' INCLUDE 'DSROT.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM13B.CIN' INCLUDE 'INDPAR.CIN' INCLUDE 'IOUNIT.CIN' INCLUDE 'RDCHAR.CIN' INCLUDE 'VFLAG.CIN' C --------------------------------------------------------------------- CHARACTER*1 ICHAR(30) CHARACTER*8 CHAR(12) INTEGER IDATA, IJ, ISIG, IVA, IVARY INTEGER J, JV, JV1, JV2 INTEGER K, KV, LL, LX, NIV, NV INTEGER IARR(6) REAL PARAM EXTERNAL IDATA DATA IARR /0,0,1,3,6,10/ C C IDENTIFY VARY CODES C IF (.NOT. (PRON .AND. ELPR)) GO TO 200 IF (TYPE .EQ. 10) GO TO 200 IVA = 0 LX = 0 C C COUPLED VARIED CODES -- PRINT OUT AS VARY CODES C IF (.NOT. VFLAG) GO TO 50 KV = NIV(TYPE) IF (KV .EQ. 0) GO TO 200 IF (TYPE .NE. 14) KV = MAX0(KV,NPARMS) C DO 20 J = 1, 30 20 ICHAR(J) = BLANK C DO 30 JV = 1, KV K = I + JV ISIG = TIE(K) IF (ISIG .GE. 99) ISIG = 0 IVARY = IABS(ISIG) LX = LX + 1 IF (ISIG .LT. 0) ICHAR(LX) = MINUS LX = LX + 1 IF (IVARY .NE. 0) THEN IVARY = VSTOR(IVARY) IVA = 1 ENDIF ICHAR(LX) = TABLE(IVARY + 1) 30 CONTINUE C C PRINT VARY CODES C IF (IVA .EQ. 0) GO TO 200 WRITE (NOUT,9500) ICHAR GO TO 100 C C VARY CODES (NO OLD-STYLE COUPLING) -- IDENTIFY VARIED PARAMETERS C 50 IF (TYPE .GE. 50) GO TO 200 KV = NV(TYPE) IF (KV .EQ. 0) GO TO 200 IF (TYPE .NE. 14) KV = MAX0(KV,NPARMS) C DO 70 JV = 1, KV IJ = IPTOJ(JV) IF (IJ .EQ. 0) GO TO 70 K = I + IJ ISIG = TIE(K) IF (ISIG .GE. 99) ISIG = 0 IVARY = IABS(ISIG) IF (IVARY .NE. 0) THEN LX = LX + 1 IVARY = VSTOR(IVARY) IVA = 1 CHAR(LX) = ' ' IF (TYPE .EQ. 1) CHAR(LX) = DBEAM(JV)(1:8) IF (TYPE .EQ. 2) CHAR(LX) = DROT(JV)(1:8) IF (TYPE .EQ. 3) CHAR(LX) = DDRFT(JV)(1:8) IF (TYPE .EQ. 4) CHAR(LX) = DBEND(JV)(1:8) IF (TYPE .EQ. 5) CHAR(LX) = DQUAD(JV)(1:8) IF (TYPE .EQ. 7) CHAR(LX) = DCENT(JV)(1:8) IF (TYPE .EQ. 8) CHAR(LX) = DMIS(JV)(1:8) IF (TYPE .EQ. 11) CHAR(LX) = DCVTY(JV)(1:8) IF (TYPE .EQ. 12) THEN CHAR(LX)(1:1) = 'C' JV1 = 0 60 JV1 = JV1 + 1 IF (JV .GT. IARR(JV1+1)) GO TO 60 JV2 = JV - IARR(JV1) CHAR(LX)(2:2) = TABLE(JV1+1) CHAR(LX)(3:3) = TABLE(JV2+1) ENDIF IF (TYPE .EQ. 14) THEN CHAR(LX)(1:1) = 'R' CHAR(LX)(2:2) = TABLE(INT(DATA(I+7))+1) CHAR(LX)(3:3) = TABLE(JV+1) ENDIF IF (TYPE .EQ. 16) CHAR(LX) = DSPEC(INT(DATA(I+1))+3)(1:8) IF (TYPE .EQ. 18) CHAR(LX) = DSEXT(JV)(1:8) IF (TYPE .EQ. 19) CHAR(LX) = DSOLE(JV)(1:8) IF (TYPE .EQ. 20) CHAR(LX) = DSROT(JV)(1:8) IF (TYPE .EQ. 25) CHAR(LX) = DOCT(JV)(1:8) IF (TYPE .EQ. 27) CHAR(LX) = DETA(JV)(1:8) IF (TYPE .EQ. 28 .OR. TYPE .EQ. 29) CHAR(LX) = DRBND(JV)(1:8) IF (TYPE .EQ. 34) CHAR(LX) = DQUAD(JV)(1:8) IF (TYPE .EQ. 35 .OR. TYPE .EQ. 36) CHAR(LX) = DHKICK(JV)(1:8) IF (TYPE .EQ. 42) CHAR(LX) = DKICK(JV)(1:8) IF (TYPE .EQ. 43) CHAR(LX) = DSHIFT(JV)(1:8) ENDIF 70 CONTINUE C C PRINT VARY CODES C IF (IVA .EQ. 0) GO TO 200 WRITE (NOUT,9501) (CHAR(LL), LL = 1, LX) C C PRINT PRECISE VALUES OF VARIED PARAMETERS C 100 IF (.NOT. UNRO) GO TO 200 DO 110 JV = 1, KV K = I + IPTOJ(JV) 105 ISIG = TIE(K) IF (ISIG .EQ. 100) THEN K = IDATA(K) GO TO 105 ENDIF IF (ISIG .NE. 0) THEN PARAM = DATA(K) WRITE (NOUT,9502) PARAM ENDIF 110 CONTINUE 200 RETURN C 9500 FORMAT (1H ,12X,'VARY CODE = ',30A1) 9501 FORMAT (1H ,12X,'VARIED: ',12(A8,2X)) 9502 FORMAT (1H ,12X,'VARIED PARAMETER',3X,F18.10) END SUBROUTINE VRBGET C C GET PARAMETERS DESCRIBING VERNIER MAGNET C C ---------------------------------------------------------------------- INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'DATA2A.CIN' INCLUDE 'ELM0A.CIN' INCLUDE 'ELM1A.CIN' INCLUDE 'ELM4A.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'ELM16B.CIN' INCLUDE 'INDPAR.CIN' C INTEGER IADR, IANG, IB, IDATA, IK, IL, IT INTEGER NANG35, NB35, NK35, NL35 REAL DATAR EXTERNAL DATAR, IDATA C C MAGNET LENGTH C NL35 = 1 NB35 = 2 NANG35 = 3 NK35 = 4 IL = IPTOJ(NL35) IF (IL .NE. 0) THEN IADR = I + 1 LBEND = DATAR(IADR)*UNITI(8) ELSE LBEND = 0.0 ENDIF C C INDICES FOR OTHER PARAMETERS C IB = IPTOJ(NB35) IANG = IPTOJ(NANG35) IK = IPTOJ(NK35) IF (IK .NE. 0) GO TO 15 IF (IANG .NE. 0) GO TO 10 IF (IB .NE. 0) GO TO 5 B = 0.0 AL = 0.0 H0 = 0.0 GO TO 20 C C MAGNETIC FIELD C 5 IADR = I + IB B = DATAR(IADR) B = B*UNITI(9)*RI/PREF H0 = B/RI AL = H0*LBEND GO TO 20 C C BENDING ANGLE C 10 IADR = I + IANG AL = DATAR(IADR) AL = AL*UNITI(7) IF (LBEND .NE. 0.0) THEN H0 = AL/LBEND ELSE H0 = 0.0 ENDIF B = RI*H0 GO TO 20 C C KICK C 15 IADR = I + IK AL = - DATAR(IADR) AL = AL*UNITI(7) IF (LBEND .NE. 0.0) THEN H0 = AL/LBEND ELSE H0 = 0.0 ENDIF B = RI*H0 C C NORMALIZED FIELD DERIVATIVE (ASSUMED ZERO) C 20 NB = 0.0 C IT = IPTOJ(6) IF (IT .EQ. 0) THEN NUMTYP = IT ELSE NUMTYP = IDATA(I + IT) ENDIF RETURN END SUBROUTINE WAIST C C PRINTS LOCATION OF BEAM WAISTS IN BOTH TRANSVERSE PLANES C INCLUDE 'ELM0B.CIN' INCLUDE 'ELM1D.CIN' INCLUDE 'ELM13B.CIN' INCLUDE 'ELM15A.CIN' INCLUDE 'ELM15B.CIN' INCLUDE 'ELM15C.CIN' INCLUDE 'IOUNIT.CIN' C---------------------------------------------------------------------- CHARACTER*4 IPOS, IUP, IDOWN DATA IUP /' UP'/, IDOWN /'DOWN'/ C C HORIZONTAL PLANE C IF (.NOT. RECENT) CALL BEAM SIT11 = SIT(1,1) SIT12 = SIT(1,2) SIT22 = SIT(2,2) IF (SIT22 .LE. 0.0) GO TO 50 ADIFF = - SIT12/(SIT22*UNITO(8)) IF (ADIFF .LT. 0.0) IPOS = IUP IF (ADIFF .GE. 0.0) IPOS = IDOWN ALONG = LC/UFLOOR(1) + ADIFF ADIFF = ABS(ADIFF) XSIZE = (SIT11 - SIT12**2/SIT22) IF (ACCEL) THEN XSIZE = XSIZE*UNITO(2)/UNITO(1) WRITE (NOUT,1004) XSIZE, ADIFF, XDIME(8), IPOS, ALONG, XFLOOR(1) 1004 FORMAT (1H ,32X,4HBETA,F8.3,1X,16HHORIZONTAL WAIST,F10.3,1X,A4, 1 1X,A4,9HSTREAM AT,F10.3,1X,A4) ELSE XSIZE = SQRT(XSIZE)/UNITO(1) WRITE (NOUT,1002) XSIZE, XDIME(1), ADIFF, XDIME(8), IPOS, ALONG, 1 XDIME(8) 1002 FORMAT (1H ,32X,F8.3,1X,A4,1X,16HHORIZONTAL WAIST,F10.3,1X,A4, 1 1X,A4,9HSTREAM AT,F10.3,1X,A4) ENDIF C C VERTICAL PLANE C 50 SIT33 = SIT(3,3) SIT34 = SIT(3,4) SIT44 = SIT(4,4) IF (SIT44 .EQ. 0.0) GO TO 100 ADIFF = - SIT34/(SIT44*UFLOOR(1)) IF (ADIFF .LT. 0.0) IPOS = IUP IF (ADIFF .GE. 0.0) IPOS = IDOWN ALONG = LC/UFLOOR(1) + ADIFF ADIFF = ABS(ADIFF) YSIZE = (SIT33 - SIT34**2/SIT44) IF (ACCEL) THEN YSIZE = YSIZE*UNITO(4)/UNITO(3) WRITE (NOUT,1005) YSIZE, ADIFF, XDIME(8), IPOS, ALONG, XFLOOR(1) ELSE YSIZE = SQRT(YSIZE)/UNITO(3) WRITE (NOUT,1003) YSIZE, XDIME(1), ADIFF, XDIME(8), IPOS, ALONG, 1 XDIME(8) ENDIF 1003 FORMAT (1H ,32X,F8.3,1X,A4,1X,16H VERTICAL WAIST,F10.3,1X,A4,1X, 1 A4,9HSTREAM AT,F10.3,1X,A4) 1005 FORMAT (1H ,32X,4HBETA,F8.3,1X,16H VERTICAL WAIST,F10.3,1X,A4, 1 1X,A4,9HSTREAM AT,F10.3,1X,A4) C 100 RETURN END SUBROUTINE WOBBLE C C CALCULATES PARTIAL DERIVATIVES OF BEAM MATRIX WITH RESPECT TO C MISALIGNMENT PARAMETERS C C ---------------------------------------------------------------------- INCLUDE 'TRNSPRT_PARAM.CIN' INCLUDE 'ELM2B.CIN' INCLUDE 'ELM8A.CIN' INCLUDE 'ELM8B.CIN' INCLUDE 'ELM8E.CIN' INCLUDE 'ELM8H.CIN' INCLUDE 'ELM8J.CIN' INCLUDE 'ELM10B.CIN' INCLUDE 'ELM15C.CIN' INCLUDE 'SI.CIN' INCLUDE 'SVP.CIN' INTEGER I2MOD, J, K, M, N REAL S, ZAP C I2MOD = 2 - MOD(JV,2) IF (LFM .NE. 0) GO TO 100 C C UNCERTAIN MISALIGNMENT C DO 50 J = 1, 6 DO 50 K = 1, J S = 0.0 IF (.NOT. FEO) S = CT(J,JV)*CT(K,JV) IF (J .LE. 5) THEN IF (SPO(IR)) THEN DO 10 M = 1, 6 S = S + (CT(J,JV)*GT(K,M,JV) + CT(K,JV)*GT(J,M,JV))*COLD(IR,M) 10 CONTINUE ENDIF DO 30 M = 1, 6 DO 30 N = 1, 6 ZAP = GT(J,M,JV)*GT(K,N,JV)*SIOL(IR,M,N) S = S + ZAP 30 CONTINUE ENDIF C S = 2.0*S*VM(JV)*UMIS(I2MOD) IF (.NOT. SVP(NV2)) THEN SV(J,K,NV2) = S ELSE SV(J,K,NV2) = SV(J,K,NV2) + S ENDIF SV(K,J,NV2) = SV(J,K,NV2) 50 CONTINUE SVP(NV2) = .TRUE. GO TO 200 C C KNOWN MISALIGNMENT C 100 IF (BEFORE) CALL DEMENT IF (.NOT. BEFORE) CALL DEMEX C 200 RETURN END SUBROUTINE WOE C C PRINTING OF MISALIGNMENT TABLES C C ---------------------------------------------------------------------- INCLUDE 'ELM0B.CIN' INCLUDE 'ELM8A.CIN' INCLUDE 'ELM8B.CIN' INCLUDE 'ELM8C.CIN' INCLUDE 'ELM8H.CIN' INCLUDE 'ELM8J.CIN' INCLUDE 'ELM8M.CIN' INCLUDE 'ELM13C.CIN' INCLUDE 'ELM15B.CIN' INCLUDE 'ELM15C.CIN' INCLUDE 'IOUNIT.CIN' C --------------------------------------------------------------------- CHARACTER*1 BLANK CHARACTER*18 ABOPX CHARACTER*27 ABMEF, ABMEG CHARACTER*19 ABMC CHARACTER*27 ABDES INTEGER I2MOD, J, JJ, JL1, JL2, K, KA, KH INTEGER L1, L2, L1L2, N REAL CEO, LCM1, LCM2, OUTPUT(12), SIO, WORK DATA BLANK /' '/ DATA ABOPX /'MAGNET AXIS COORDS'/ DATA ABMC /'MAGNET CHORD COORDS'/ DATA ABMEF /'MAGNET ENTRANCE FACE COORDS'/ DATA ABMEG /'MAGNET EXIT FACE COORDS'/ C IF (.NOT. LCPR) THEN WORK = LC/UFLOOR(1) WRITE (NOUT,1004) WORK, XDIME(8) 1004 FORMAT (1H ,8X,F10.3,1X,A4) LCPR = .TRUE. ENDIF C WRITE (NOUT,1010) 1010 FORMAT (1H0) IF (TMK .EQ. 0) WRITE (NOUT,1005) 1005 FORMAT (' *PIVOT AT MAGNET ENTRANCE') IF (TMK .EQ. 1) WRITE (NOUT,1006) 1006 FORMAT (' *PIVOT AT MAGNET CENTER') IF (TMK .EQ. 2) WRITE (NOUT,1007) 1007 FORMAT (' *PIVOT AT MAGNET EXIT') IF (FEO) WRITE (NOUT,1009) 1009 FORMAT (' *FOCUSING EFFECT ONLY') C DO 2 J = 1, 6 I2MOD = 2 - MOD(J,2) 2 OUTPUT(J) = VM(J)/UMIS(I2MOD) WRITE (NOUT,1000) 1000 FORMAT (48H *MISALIGNMENT EFFECT TABLE FOR MISALIGNMENTS OF ) WRITE (NOUT,1001) OUTPUT(1), XMIS(1), OUTPUT(2), XMIS(2), 1 OUTPUT(3), XMIS(1), OUTPUT(4), XMIS(2), 2 OUTPUT(5), XMIS(1), OUTPUT(6), XMIS(2) 1001 FORMAT (1H ,6(1X,F10.3,1X,A4,6X)) C DO 100 N = 1, NMMAX IF (.NOT. LNMT(N)) GO TO 100 LCM1 = LMIS(1,N)/UFLOOR(1) LCM2 = LMIS(2,N)/UFLOOR(1) CHORD = CHORDT(N) ABDES = BLANK IF (STRATE(N)) THEN ABDES(1:18) = ABOPX ELSE IF (CHORD) THEN ABDES(1:19) = ABMC ELSE IF (TMK .EQ. 0 .OR. TMK .EQ. 1) THEN ABDES(1:27) = ABMEF ELSE IF (TMK .EQ. 2) THEN ABDES(1:27) = ABMEG ENDIF ENDIF C WRITE (NOUT,1002) LABM(N), LCM1, XDIME(8), LCM2, XDIME(8), 1 ABDES 1002 FORMAT (17H0*MISALIGNMENT OF ,1X,A4,3H* (,F10.3,1X,A4,3H TO, 1 F10.3,1X,A4,')',2X,A27) C DO 90 J = 1, 6 JJ = 7*J - 6 DO 30 K = 1, 6 CEO = COM(J,K,N) IF (.NOT. R2PM(N)) THEN SIO = SQRT(SIM(JJ,K,N)) ELSE SIO = 0.0 DO 20 L1 = 1, 6 JL1 = J + 6*L1 - 6 DO 20 L2 = 1, 6 JL2 = J + 6*L2 - 6 L1L2 = 6*L2 + L1 - 6 SIO = SIO + RC2M(JL1,K,N)*SIM(L1L2,K,N)*RC2M(JL2,K,N) 20 CONTINUE SIO = SQRT(SIO) ENDIF KA = 2*K - 1 KH = 2*K OUTPUT(KA) = CEO/UBEAM(J) OUTPUT(KH) = SIO/UBEAM(J) 30 CONTINUE WRITE (NOUT,1003) (OUTPUT(2*K-1), OUTPUT(2*K), XDIME(J), K = 1, 6) 1003 FORMAT (1H ,6(2F8.3,1X,A4,1X)) 50 CONTINUE 90 CONTINUE 100 CONTINUE C RETURN END