Title :TRANSPORT Keywords :Optics, Quadropoles, Sextapoles, Bending Magnets, EELS Computer :DEC VAX 11/730-785 Operating System :VAXVMS, Programming Language :Fortran IV Hardware Requirements :None Author(s) :K.L.Brown, F.Rothacker D.C., Carey, Ch. Iselin Correspondence Address :Stanford linear Accelerator Center, Stanford CA. USA :Fermi National Accelerator Lab. Batavia, IL. USA : CERN, Geneva, Switzerland Abstract: Transport is a computer code which calculates charged particle trajectories using first and second-order matrix multiplication methods for the design of static electromagnetic beam-line systems. It has been in existence in various versions since 1963. It is capable of computing a wide range of operating characteristics of electromagnetic systems including Quadrupoles, Sextupoles, Solenoids, Bending Magnets etc. and such can be used to calculate the optics of many EELS systems. Specific instructions on the use of TRANSPORT are extensive and should be obtained from: The Reports Office, Fermi National Accelerator Laboratory, P.O. Box 500, Batavia IL 60510, USA (Ref. NAL-91, "Transport Appendix") ------------------------------------------------------------------------------ Title :TRANSPORT Keywords :Optics, Quadropoles, Sextapoles, Bending Magnets, EELS Computer :DEC VAX 11/730-785 Operating System :VAXVMS, Programming Language :Fortran IV Hardware Requirements :None Author(s) :K.L.Brown, F.Rothacker D.C., Carey, Ch. Iselin Correspondence Address :Stanford linear Accelerator Center, Stanford CA. USA :Fermi National Accelerator Lab. Batavia, IL. USA : CERN, Geneva, Switzerland Documentation: A 256 page instruction manual on the operation of TRANSPORT is available from: The Reports Office, Fermi National Accelerator Laboratory, P.O. Box 500, Batavia IL 60510, USA (Ref. NAL-91, "Transport Appendix") The following general information can be used to generate a running version of TRANSPORT on a VAX system. Additional code is available from the authors for the following computers: IBM (Mainframe), CDC, PDP 10 ------------------------------------------------------------------------------ General Information: PRODUCT: TRANSPORT VERSION: VAX/VMS DOCUMENT NAME: PM0008 TRANSPORT IS A BEAM LINE OPTICS PROGRAM. (REFER TO DOCUMENT PM0008 FOR FURTHER INFORMATION) TRANSPORT WAS MODIFIED FOR THE VAX ON AUG. 7, 1985 BY SUSAN SISSELMAN, FERMI NATIONAL LABORATORY TRANSPORT.DAT MAY BE USED TO TEST TRANSPORT. ASSIGN TRANSPORT.DAT FOR005 NOTE: THIS DATA DOES NOT GENERATE THE RANDON GENERATOR. Compilation and Linking Procedure on a VAX: ------------------------------------------- $! [LIB.TRANSPORT]GENERATE.COM 7 AUG 85 $! $! $ WRITE SYS$OUTPUT " Compiling TRANSPORT ..." $ FORTRAN TRANSPORT.FOR $ WRITE SYS$OUTPUT " Linking TRANSPORT ..." $ LINK TRANSPORT $ DELETE TRANSPORT.OBJ $ WRITE SYS$OUTPUT " Linking TRANSPORT ..." $ WRITE SYS$OUTPUT " TRANSPORT is now ready for use !" Listing of changes made to this version of TRANSPORT ---------------------------------------------------- 3 JAN 86 A. Kreymer Modified GENERATE to report progress, bell at end, delete .OBJ file 7 JULY 1985 COPIED CYBER VERSION OF TRNSPRT 7 AUG 1985 CONVERSIONS MADE IN CHANGING PROGRAM FROM CDC VERSION TO VAX VERSION CDC VAX --- --- 1. PROGRAM NAME - LINE 1 OMITTED PARENTHESIS WITH DEVICE NAMES MADE INTO A COMMENT 2. SUBROUTINE RDPACK READ A CHARACTER IN USING INTEGER DATA REORGANIZED CONVERTED TO CHARACTER DATA USING AN INTERNAL READ 3. RANSET, RANGET, RANST RESTRUCTURED AND COMBINED INTO FUNCTION RANNU 4. RANSET - CLOCK REPLACED BY: SECONDS 5. FUNCTION RANNU REPLACED BY: RAN(ISEED) RESTRUCTURED ISEED SET TO A LARGE ODD INTEGER Test Data for Evalutation of Transport Code: TRANSPORT.DAT ---------------------------------------------------------- ' CHECK DECK FOR TRANSPORT/360 MATRIX ELEMENTS K L BROWN OCT. 10 1969' 0 (THIS TEST DECK IS DESIGNED TO CHECK ALL OF THE MATRIX ELEMENTS IN THE ) (SLAC TRANSPORT/360 PROGRAM. IT IS NOT INTENDED TO CHECK PROGRAM LOGIC NOR ) (FITTING ROUTINES. IF THIS CHECK DECK IS VERIFIED, THE MATRIX OUTPUT) (TABULATIONS OF A TRANSPORT CALCULATION SHOULD BE CORRECT PROVIDED THAT) (NO INSERTS ARE MADE BETWEEN A TYPE CODE 2.0 AND A TYPE CODE 4.0 ELEMENT) (IN THE PROGRAM LISTING. KARL L BROWN OCTOBER 1969) SENTINEL '(1) DRIFT MATRIX L= 10 METERS NORMALIZED UNITS ' 0 15. 1. ' M ' 100. ; 15. 2. ' R ' 1000. ; 15. 5. ' M ' 100. ; 15. 11. 'MEV' .001 ; 15. 6. ' N ' 100. ; 1. 2. 3. 4. 5. 6. 7. 299.792458 ; 13. 2. ; 3. 10. ; 13. 4. ; 13. 1. ; (IN THE DIMENSIONS CHOSEN FOR THIS PROBLEM, THE R12 MATRIX ELEMENT) (SHOULD EQUAL 10.0 METERS/RADIAN) SENTINEL '(2) QUADRUPOLE MATRIX K= 1/2 KL= 30 DEGREES NORMALIZED UNITS ' 0 15. 1. ' M ' 100. ; 15. 2. ' R ' 1000. ; 15. 5. ' M ' 100. ; 15. 11. 'MEV' .001 ; 15. 6. ' N ' 100. ; 1. 2. 3. 4. 5. 6. 7. 2997.92458 ; 13. 2. ; 17. ; 5.00 1.04719 5.00 0.2 ; 13. 4. ; 13. 1. ; (THE NUMERICAL VALUES OF THE 1ST AND 2ND ORDER QUADRUPOLE MATRIX ELEMENTS) (IN THIS CALCULATION SHOULD AGREE WITH THE QUADRUPOLE MATRIX ELEMENT EQUATIONS) (ON PAGES 68 AND 69 OF SLAC REPORT NO. 75. BY K.L. BROWN. THE NORMALIZED) (DIMENSIONS USED IN THIS CALCULATION, AS DETERMINED BY THE 15 TYPE) (CODES ENTRIES, ARE AS FOLLOWS@D TRANSVERSE DIMENSIONS X AND Y ARE IN METERS,) (TRANSVERSE ANGLES THETA AND PHI ARE IN RADIANS, AND MOMENTUM DEVIATION) (DELTA P/P IS FRACTIONAL . THE CENTRAL MOMENTUM IS CHOSEN AS P=BR=100 KG) (METERS FOR THIS CALCULATION.) SENTINEL '(3) PSI CORRECTION TO INPUT FRINGE FIELD G/R=0.2 K1=0.7 ' 0 15. 1. ' M ' 100. ; 15. 2. ' R ' 1000. ; 15. 5. ' M ' 100. ; 15. 11. 'MEV' .001 ; 15. 6. ' N ' 100. ; 1. 2. 3. 4. 5. 6. 7. 299.792458 ; 13. 2. ; 16. 5. 0.1 'G/2' ; 16. 7. 0.7 'K1' ; 2. 30. ; 4. .00001 10. 0. ; 13. 4. ; 13. 1. ; (THE PURPOSE OF THIS CALCULATION IS TO COMPUTE THE PSI CORRECTION TERM) (TO THE TRANSVERSE FOCAL LENGTH OF A ROTATED ENTRANCE FACE OF A BENDING) (MAGNET RESULTING FROM THE FINITE EXTENT OF THE FRINGING FIELDS. THE ) (DEFINITION OF PSI AND THE EQUATION FOR THE TRANSVERSE FOCAL LENGTH ARE GIVEN) (ON PAGES 73 AND 74 OF SLAC 75. NORMALIZED DIMENSIONS ARE USED AS IN THE) (PRECEDING PROBLEM. FOR THIS CALCULATION ; BR=10 KG METERS, R=1.0 METERS,) (G/R=0.2 AND K1=0.7 WHERE R=THE RADIUS OF THE CENTRAL ORBIT, G=THE GAP OF THE) (MAGNET AND K1 IS AN INTEGRAL OF THE FRINGING FIELD DEFINED ON PAGE 74 OF) (SLAC 75.) SENTINEL '(4) PSI CORRECTION TO INPUT FRINGE FIELD G/R=0.2 K1=0.7 K2=3.0 ' 0 15. 1. ' M ' 100. ; 15. 2. ' R ' 1000. ; 15. 5. ' M ' 100. ; 15. 11. 'MEV' .001 ; 15. 6. ' N ' 100. ; 1. 2. 3. 4. 5. 6. 7. 299.792458 ; 13. 2. ; 16. 5. 0.1 'G/2' ; 16. 7. 0.7 'K1' ; 16. 8. 3.0 'K2' ; 2. 30. ; 4. .00001 10. 0. ; 13. 4. ; 13. 1. ; (THE PURPOSE OF THIS CALCULATION IS TO COMPUTE THE PSI CORRECTION TERM) (TO THE TRANSVERSE FOCAL LENGTH OF A ROTATED ENTRANCE FACE OF A BENDING) (MAGNET RESULTING FROM THE FINITE EXTENT OF THE FRINGING FIELDS. THE ) (DEFINITION OF PSI AND THE EQUATION FOR THE TRANSVERSE FOCAL LENGTH ARE GIVEN) (ON PAGES 73 AND 74 OF SLAC 75. NORMALIZED DIMENSIONS ARE USED AS IN THE) (PRECEDING PROBLEM. BR=10 KG METERS, R=1.0 METERS, G/R=0.2, K1=0.7, AND) (K2=3.0 K2 IS DEFINED IN THE TRANSPORT/360 INSTRUCTION MANUAL.) SENTINEL '(5) PSI CORRECTION TO OUTPUT FRINGE FIELD G/R=0.2 K1=0.7 ' 0 15. 1. ' M ' 100. ; 15. 2. ' R ' 1000. ; 15. 5. ' M ' 100. ; 15. 11. 'MEV' .001 ; 15. 6. ' N ' 100. ; 1. 2. 3. 4. 5. 6. 7. 299.792458 ; 13. 2. ; 16. 5. 0.1 'G/2' ; 16. 7. 0.7 'K1' ; 4. .00001 10. 0. ; 2. 30. ; 13. 4. ; 13. 1. ; (THE PURPOSE OF THIS CALCULATION IS TO COMPUTE THE PSI CORRECTION TERM TO THE) (TRANSVERSE FOCAL LENGTH OF A ROTATED EXIT FACE OF A BENDING MAGNET RESULTING) (FROM THE FINITE EXTENT OF THE FRINGING FIELDS. THE DEFINITION OF PSI AND) (THE EQUATION FOR THE TRANSVERSE FOCAL LENGTH ARE GIVEN ON PAGES 74 AND 75 OF) (SLAC 75. NORMALIZED DIMENSIONS ARE USED AS IN THE PRECEDING PROBLEM.) (BR=10 KG METERS, R=1.0 METERS, G/R=0.2, AND K1=0.7 ) SENTINEL '(6) PSI CORRECTION TO OUTPUT FRINGE FIELD G/R=0.2 K1=0.7 K2=3.0 ' 0 15. 1. ' M ' 100. ; 15. 2. ' R ' 1000. ; 15. 5. ' M ' 100. ; 15. 11. 'MEV' .001 ; 15. 6. ' N ' 100. ; 1. 2. 3. 4. 5. 6. 7. 299.792458 ; 13. 2. ; 16. 5. 0.1 'G/2' ; 16. 7. 0.7 'K1' ; 16. 8. 3.0 'K2' ; 4. .00001 10. 0. ; 2. 30. ; 13. 4. ; 13. 1. ; (THIS CALCULATION COMPUTES THE PSI CORRECTION TERM TO THE TRANSVERSE FOCAL) (LENGTH OF A ROTATED EXIT FACE OF A BENDING MAGNET RESULTING FROM THE FINITE) (EXTENT OF THE FRINGING FIELDS. THE DEFINITION OF PSI AND THE EQUATION FOR ) (THE TRANSVERSE FOCAL LENGTH ARE GIVEN ON PAGES 74 AND 75 OF SLAC 75.) (NORMALIZED DIMENSIONS ARE USED AS IN THE PRECEDING PROBLEM.) (BR=10 KG METERS, R=1.0 METERS, G/R=0.2, K1=0.7, AND K2=3.0) SENTINEL '(7) 2ND ORDER INPUT FRINGE FIELD R(2,1) = 1.0 R=1/2 R1= 2.0 ' 0 15. 1. ' M ' 100. ; 15. 2. ' R ' 1000. ; 15. 5. ' M ' 100. ; 15. 11. 'MEV' .001 ; 15. 6. ' N ' 100. ; 1. 2. 3. 4. 5. 6. 7. 299.792458 ; 13. 2. ; 17. ; 16. 5. .05 'G/2' ; 16. 7. 0.7 'K1' ; 16. 8. 3.0 'K2' ; 16. 12. 0.5 '1/R1' ; 2. 26.566 ; 4. .00001 20. 0.5 ; 13. 4. ; 13. 1. ; (THIS CALCULATION IS INTENDED TO CHECK BOTH THE 1ST AND 2ND ORDER) (INPUT FRINGING FIELD MATRIX ELEMENTS OF A BENDING MAGNET AND COMPARE THE) (RESULTS WITH PAGES 71 THROUGH 75 OF SLAC 75. FOR THIS CALCULATION THE ) (FOLLOWING PARAMETERS WERE CHOSEN@D BR=10 KG METERS, R=1/2 METER, TAN BETA=1/2) (R1=2 METERS. G/R=0.2, K1=0.7, AND K2=3.0 NORMALIZED UNITS ARE ) (USED FOR THE TRANSVERSE DIMENSIONS.) SENTINEL '(8) 2ND ORDER OUTPUT FRINGE FIELD R(2,1) = 1.0 R=1/2 R2= 2.0 ' 0 15. 1. ' M ' 100. ; 15. 2. ' R ' 1000. ; 15. 5. ' M ' 100. ; 15. 11. 'MEV' .001 ; 15. 6. ' N ' 100. ; 1. 2. 3. 4. 5. 6. 7. 299.792458 ; 13. 2. ; 17. ; 16. 5. .05 'G/2' ; 16. 7. 0.7 'K1' ; 16. 8. 3.0 'K2' ; 16. 13. 0.5 '1/R2' ; 4. 0.00001 20. 0.5 ; 2.0 26.566 ; 13. 4. ; 13. 1. ; (THIS CALCULATION IS INTENDED TO CHECK BOTH THE 1ST AND 2ND ORDER OUTPUT) (FRINGING FIELD MATRIX ELEMENTS OF A BENDING MAGNET AND COMPARE THE RESULTS) (WITH PAGES 71 THROUGH 75 OF SLAC 75. FOR THIS CALCULATION THE FOLLOWING) (PARAMETERS WERE CHOSEN@D BR=10 KG METERS, R=1/2 METER, TAN BETA=1/2,) (R2=2 METERS. G/R=0.2, K1=0.7, AND K2=3.0 NORMALIZED UNITS ARE USED FOR) (THE TRANSVERSE DIMENSIONS) SENTINEL '(9) SEXTUPOLE MATRIX K(S)SQUARED = 10.0 L =0.1 METERS NORM UNITS ' 0 15. 1. ' M ' 100. ; 15. 2. ' R ' 1000. ; 15. 5. ' M ' 100. ; 15. 11. 'MEV' .001 ; 15. 6. ' N ' 100. ; 1. 2. 3. 4. 5. 6. 7. 2997.92458 ; 13. 2. ; 17. ; 18. 0.1 10. 0.1 ; 13. 4. ; 13. 1. ; (THESE RESULTS SHOULD BE COMPARED WITH THE MATRIX ELEMENTS LISTED ON PAGES) (69 AND 70 OF SLAC 75 FOR THE SEXTUPOLE. KS SQUARED=10. L=0.1, AND BR=100 KG) (METERS. NORMALIZED TRANSVERSE UNITS ARE USED.) SENTINEL '(10) ACCELERATOR MATRIX STANDARD UNITS ARE USED ( SEE BELOW ) ' 0 15. 1. ' CM' 1. ; 15. 2. ' MR' 1. ; 15. 5. ' CM' 1. ; 15. 8. ' M' 1. ; 15. 11. 'GEV' 1. ; 15. 6. ' PC' 1. ; -16. 3. 1836. 'MASS' ; 1. 2. 3. 4. 5. 6. 7. 10. ; 11. 10. 0.10 30. 1.00 ; 13. 4. ; (THE ANALYTICAL EXPRESSIONS FOR THE ACCELERATOR MATRIX ELEMENTS ARE LISTED) (IN THE TRANSPORT/360 MANUAL AS DERIVED BY K.L. BROWN. THIS CALCULATION) (HAS BEEN MADE IN STANDARD TRANSPORT UNITS@D X,Y IN CMS, THETA AND PHI IN ) (MILLIRADIANS AND DELTA P/P IN PERCENT. THE PARAMETERS CHOSEN FOR THE) (CALCULATION ARE E=10 GEV, DELTA E=0.1 GEV, THE PHASE LAG=30 DEGREES AND) (THE WAVELENGTH = 1 CM. ) SENTINEL '(10) ACCELERATOR MATRIX NONZERO MASS FOR PARTICLE ' 1 16. 'MASS' ; SENTINEL '(11) SOLENOID MATRIX K = 1/4 KL = 30 DEGREES NORMALIZED UNITS ' 0 15. 1. ' M ' 100. ; 15. 2. ' R ' 1000. ; 15. 5. ' M ' 100. ; 15. 8. ' CM' .01 ; 15. 11. 'MEV' .001 ; 15. 6. ' N ' 100. ; 1. 2. 3. 4. 5. 6. 7. 299.792458 ; 13. 2. ; 17. ; 19. 209.44 5.0 ; 13. 4. ; 13. 1. ; (THE ANALYTICAL EXPRESSIONS FOR THE SOLENOID MATRIX ELEMENTS ARE LISTED) (IN THE TRANSPORT/360 INSTRUCTION MANUAL AS DERIVED FROM R H HELMS SLAC ) (REPORT NO. 4. FOR THE SOLENOID K=B/2BR WHERE B IS THE MAGNETIC FIELD IN THE) (SOLENOID AND BR = P = THE PARTICLE MOMENTUM. FOR THIS CALCULATION THE ) (MOMENTUM BR = 10 KG METERS, B = 5 KG ; FROM WHICH K = 1/4. KL = 30 DEGREES) (IS CHOSEN FOR EASE OF CHECKING. NORMALIZED TRANSVERSE UNITS ARE USED FOR THE) (CALCULATION.) SENTINEL '(12) SOLENOID + COORDINATE ROTATION K = 1/4 KL = 30 DEGREES ' 0 15. 1. ' M ' 100. ; 15. 2. ' R ' 1000. ; 15. 5. ' M ' 100. ; 15. 8. ' CM' .01 ; 15. 11. 'MEV' .001 ; 15. 6. ' N ' 100. ; 1. 2. 3. 4. 5. 6. 7. 299.792458 ; 13. 2. ; 17. ; 19. 209.44 5.0 ; 20. -30. ; 13. 4. ; 13. 1. ; (IF THE TRANSVERSE COORDINATES ARE ROTATED ABOUT THE Z AXIS OF A SOLENOID BY) (AN ANGLE OF -KL , THEN THE X AND Y 1ST ORDER MATRIX ELEMENTS ARE DECOUPLED.) (THUS IN THIS TEST CASE THE MATRIX ELEMENTS R13=R14=R23=R24=R31=R32=R41=R42) (ALL SHOULD BE EQUAL TO ZERO. THIS PROVIDES A TEST FOR THE SOLENOID MATRIX) (ELEMENTS AS WELL AS THE Z ROTATION MATRIX.) SENTINEL '(13) N=1/2 BETA=1/4 42.43 DEGREE BEND NO FRINGE FIELDS NORM UNITS' 0 15. 1. ' N' 100. ; 15. 2. ' R ' 1000. ; 15. 5. ' N ' 100. ; 15. 8. ' CM' 0.01 ; 15. 11. 'MEV' .001 ; 15. 6. ' N ' 100. ; 1. 2. 3. 4. 5. 6. 7. 299.792458 ; 13. 2. ; 17. ; 16. 1. 0.250 'BETA' ; 4. 74.05 10. .5 ; 13. 4. ; 13. 1. ; (THE N=1/2, 42.4265 DEGREE BENDING MAGNET IS CHOSEN AS A TEST CASE BECAUSE) (KL = 30 DEGREES IS A CONVENIENT ANGLE. FRINGING FIELDS ARE LEFT OUT SO THAT) (THE BENDING MAGNET MATRIX ELEMENTS MAY BE INDEPENDENTLY VERIFIED. BR= 10 KG-) (METERS, R = 1 METER AND NORMALIZED TRANSVERSE DIMENSIONS ARE USED. THE ) (RESULTS SHOULD AGREE WITH PAGES 57 - 60 OF SLAC 75.) SENTINEL '(14) N=1/2 BETA= 0 42.43 DEGREE BEND NO FRINGE FIELDS NORM UNITS' 0 15. 1. ' N' 100. ; 15. 2. ' R ' 1000. ; 15. 5. ' N ' 100. ; 15. 8. ' CM' 0.01 ; 15. 11. 'MEV' .001 ; 15. 6. ' N ' 100. ; 1. 2. 3. 4. 5. 6. 7. 299.792458 ; 13. 2. ; 17. ; 16. 1. 0.00 'BETA' ; 4. 74.05 10. .5 ; 13. 4. ; 13. 1. ; (THE BETA=0 CASE IS ADDED TO ALLOW A FURTHER CHECK ON THE BENDING MAGNET) (MATRIX ELEMENTS USING THE N=1/2 THEOREMS LISTED ON PAGES 92 AND 93 OF SLAC 75) SENTINEL '(15) N=1/2 BETA=1/4 30.0 DEGREE BEND NO FRINGE FIELDS NORM UNITS' 0 15. 1. ' M ' 100. ; 15. 2. ' R ' 1000. ; 15. 5. ' M ' 100. ; 15. 8. ' CM' 0.01 ; 15. 11. 'MEV' .001 ; 15. 6. ' N ' 100. ; 1. 2. 3. 4. 5. 6. 7. 299.792458 ; 13. 2. ; 17. ; 16. 1. .250 'BETA' ; 4. 52.36 10. 0.5 ; 13. 4. ; 13. 1. ; (IT IS IMPORTANT TO CHECK THAT ANY GIVEN COMPUTER CALCULATES THE CORRECT) (RESULTS FOR BENDING MAGNETS OF ANGLES LESS THAN 0.2 RADIANS. THE FOLLOWING) (TWO COMPUTATIONS ARE DESIGNED WITH THIS IN MIND. THE FIRST CALCULATION IS ) (A SINGLE STEP 30 DEGREE BENDING MAGNET AND THE SECOND COMPUTATION IS A TEN ) (STEP CALCULATION ADDING UP TO 30 DEGREES. OBVIOUSLY, THE RESULTS OF THE TWO) (CALCULATIONS SHOULD AGREE. NORMALIZED DIMENSIONS ARE USED AND BR = 10 KG) (METERS.) SENTINEL '(16) N=1/2 BETA=1/4 30.0 DEGREE BEND 10 STEPS NO FRINGE FIELDS ' 0 15. 1. ' M ' 100. ; 15. 2. ' R ' 1000. ; 15. 5. ' M ' 100. ; 15. 8. ' CM' 0.01 ; 15. 11. 'MEV' .001 ; 15. 6. ' N ' 100. ; 1. 2. 3. 4. 5. 6. 7. 299.792458 ; 13. 2. ; 17. ; 16. 1.0 0.250 'BETA' ; 9. 10. ; 4. 5.236 10. 0.5 ; 9. 0. ; 13. 4. ; 13. 1. ; (NOTE THE USE OF THE REPEAT ELEMENT TYPE CODE 9.0 IN SETTING UP THIS PROBLEM ) SENTINEL '(17) N=1/4 BETA=1/4 30.0 DEGREE BEND NO FRINGE FIELDS NORM UNITS' 0 15. 1. ' M ' 100. ; 15. 2. ' R ' 1000. ; 15. 5. ' M ' 100. ; 15. 8. ' CM' 0.01 ; 15. 11. 'MEV' .001 ; 15. 6. ' N ' 100. ; 1. 2. 3. 4. 5. 6. 7. 299.792458 ; 13. 2. ; 17. ; 16. 1. .250 'BETA' ; 4. 52.36 10. 0.25 ; 13. 4. ; 13. 1. ; (THIS CALCULATION IS INCLUDED SO AS TO HAVE A BENDING MAGNET CASE WHERE N ) (NEITHER EQUALS ZERO NOR 1/2. NORMALIZED UNITS ARE USED AND BR = 10 KG METERS) SENTINEL '(18) N=1/2 BETA=1/4 84.85 DEGREE BEND WITH FRINGE FIELDS NORM UNIT' 0 15. 1. ' M ' 100. ; 15. 2. ' R ' 1000. ; 15. 5. ' M ' 100. ; 15. 8. ' CM' .01 ; 15. 11. 'MEV' .001 ; 15. 6. ' N ' 100. ; 1. 2. 3. 4. 5. 6. 7. 299.792458 ; 13. 2. ; 17. ; 16. 1. .250 'BETA' ; 3. 244.94 ; 2. 0. ; 4. 148.10 10. .5 ; 2. 0. ; 3. 244.94 ; 13. 4. ; 13. 1. ; (THE FOLLOWING THREE CASES ARE INCLUDED BECAUSE THEY ARE COMPOSITE SYSTEMS) (INCLUDING FRINGING FIELDS, DRIFT DISTANCES AND VARIOUS SECOND-ORDER) (CORRECTIONS. NORMALIZED UNITS ARE USED IN ALL CASES AND BR = 10 KG METERS.) (NOTE THAT, TO INCLUDE THE FRINGING FIELD MATRIX ELEMENTS IN THE CALCULATION) (THE 2. ELEMENTS MUST BE ADDED TO THE PROGRAM LISTING EVEN IF THE ROTATION) (ANGLE OF THE ENTRANCE AND/OR EXIT POLE FACE IS ZERO. THUS, IN THE FOLLOWING) (CALCULATION, 2. 0. ELEMENTS ARE ADDED BEFORE AND AFTER THE 4.0 BENDING ) (MAGNET ENTRY.) SENTINEL '(19) N=0 90 DEGREE BEND WITH FRINGE FIELDS NORMALIZED UNITS ' 0 15. 1. ' M ' 100. ; 15. 2. ' R ' 1000. ; 15. 5. ' M ' 100. ; 15. 8. ' CM' .01 ; 15. 11. 'MEV' .001 ; 15. 6. ' N ' 100. ; 1. 2. 3. 4. 5. 6. 7. 299.792458 ; 13. 2. ; 17. ; 16. 5. .0333333 'G/2' ; 16. 7. .46 'K1' ; 16. 8. 2.75 'K2' ; 16. 12. .00358 '1/R1' ; 16. 13. .00358 '1/R2' ; 3.0 210.598 ; 2.0 27.71 ; 4. 157.08 10. 0. ; 2. 27.71 ; 3. 210.598 ; 13. 4. ; 13. 1. ; SENTINEL '(20) N=1/2 BETA= 0 169.7 DEGREE BEND WITH FRINGE FIELDS NORM UNIT' 0 15. 1. ' M ' 100. ; 15. 2. ' R ' 1000. ; 15. 5. ' M ' 100. ; 15. 8. ' CM' .01 ; 15. 11. 'MEV' .001 ; 15. 6. ' N ' 100. ; 1. 2. 3. 4. 5. 6. 7. 299.792458 ; 13. 2. ; 17. ; 16. 1. 0. 'BETA' ; 3. 81.65 ; 2. 0. ; 4. 296.19 10. 0.5 ; 2. 0. ; 3. 81.65 ; 13. 4. ; 13. 1. ; SENTINEL '(21) N=1/2 BETA=1/4 169.7 DEGREE BEND WITH FRINGE FIELDS NORM UNIT' 0 15. 1. ' M ' 100. ; 15. 2. ' R ' 1000. ; 15. 5. ' M ' 100. ; 15. 8. ' CM' .01 ; 15. 11. 'MEV' .001 ; 15. 6. ' N ' 100. ; 1. 2. 3. 4. 5. 6. 7. 299.792458 ; 13. 2. ; 17. ; 16. 1. 0.250 'BETA' ; 3. 81.65 ; 2. 0. ; 4. 296.19 10. 0.5 ; 2. 0. ; 3. 81.65 ; 13. 4. ; 16. 15. 56.6 ; 3. 0. ; 13. 4. ; 16. 15. -56.6 ; 3. 0. ; 16. 15. 0. ; 16. 15. 27.7 ; 3. 0. ; 13. 4. ; 16. 15. 0. ; 13. 1. ; (THE 16. 15. ALPHA. TYPE CODE IS USED IN THIS EXAMPLE TO ROTATE TO THE X AND ) (Y FOCAL PLANES. THE X FOCAL PLANE CORRESPONDS TO THE ANGLE FOR WHICH THE) (126 MATRIX ELEMENT = 0 ; THE Y FOCAL PLANE CORRESPONDS TO THE ANGLE FOR ) (WHICH THE 346 MATRIX ELEMENT = 0. ) SENTINEL ' (22) TEST OF SECOND ORDER MATRIX ELEMENTS FOR STRONGFOCUS' 0 15. ; 1.0 2.0 5.0 2.0 5.0 0.0 2.0 10.0 ; 17.0 ; 4. 2.0 5.0 -500. 'BEND' ; 13. 4. ; ( THIS WAS PREVIOUSLY THE A.G.B.M. TEST) (UNITS ARE RESET TO THEIR DEFAULT VALUE L=CMS FOR THE BEAM PARAMETERS) (THIS IS AN EXAMPLE OF SECOND ORDER MATRIX ELEMENTS FOR A STRONG FOCUSING) (BENDING MAGNET. IT IS REPEATED FOR BOTH POLARITIES OF THE MAGNET) SENTINEL ' (23) TEST FOR OPPOSITE POLARITY ' 1 4. 2.0 5.0 500. 'BEND' ; SENTINEL Example of Computed Output using the Above TEST DATA ---------------------------------------------------- 1 0"CHECK DECK FOR TRANSPORT/360 MATRIX ELEMENTS K L BROWN OCT. 10 1969 " 0 0 (THIS TEST DECK IS DESIGNED TO CHECK ALL OF THE MATRIX ELEMENTS IN THE ) (SLAC TRANSPORT/360 PROGRAM. IT IS NOT INTENDED TO CHECK PROGRAM LOGIC NOR ) (FITTING ROUTINES. IF THIS CHECK DECK IS VERIFIED, THE MATRIX OUTPUT ) (TABULATIONS OF A TRANSPORT CALCULATION SHOULD BE CORRECT PROVIDED THAT ) (NO INSERTS ARE MADE BETWEEN A TYPE CODE 2.0 AND A TYPE CODE 4.0 ELEMENT ) (IN THE PROGRAM LISTING. KARL L BROWN OCTOBER 1969 ) 0SENTINEL 0 0 ELEMENTS USED OUT OF A MAXIMUM ALLOWABLE 3129 1 NUMBERS USED OUT OF A MAXIMUM ALLOWABLE 13160 1CHECK DECK FOR TRANSPORT/360 MATRIX ELEMENTS K L BROWN OCT. 10 1969 0*LENGTH* 0.00000 M 1 0"(1) DRIFT MATRIX L= 10 METERS NORMALIZED UNITS " 0 0 15. 1.00000 "M " 100.00000 ; 15. 2.00000 "R " 1000.00000 ; 15. 5.00000 "M " 100.00000 ; 15. 11.00000 "MEV " 0.00100 ; 15. 6.00000 "N " 100.00000 ; 1.000000 2.00000 3.00000 4.00000 5.00000 6.00000 7.00000 299.79248; 13. 2.00000; 3.0 10.00000; 13. 4.00000; 13. 1.00000; (IN THE DIMENSIONS CHOSEN FOR THIS PROBLEM, THE R12 MATRIX ELEMENT ) (SHOULD EQUAL 10.0 METERS/RADIAN ) 0SENTINEL 0 10 ELEMENTS USED OUT OF A MAXIMUM ALLOWABLE 3129 37 NUMBERS USED OUT OF A MAXIMUM ALLOWABLE 13160 1(1) DRIFT MATRIX L= 10 METERS NORMALIZED UNITS *BEAM* 1. 299.79248 MEV 0.000 M 0.000 2.000 M 0.000 3.000 R 0.000 0.000 4.000 M 0.000 0.000 0.000 5.000 R 0.000 0.000 0.000 0.000 6.000 M 0.000 0.000 0.000 0.000 0.000 7.000 N 0.000 0.000 0.000 0.000 0.000 *DRIFT* 3. 10.00000 M 10.000 M *TRANSFORM 1* 1.00000 10.00000 0.00000 0.00000 0.00000 0.00000 0.00000 1.00000 0.00000 0.00000 0.00000 0.00000 0.00000 0.00000 1.00000 10.00000 0.00000 0.00000 0.00000 0.00000 0.00000 1.00000 0.00000 0.00000 0.00000 0.00000 0.00000 0.00000 1.00000 0.00000 0.00000 0.00000 0.00000 0.00000 0.00000 1.00000 0.000 30.067 M 0.000 3.000 R 0.998 0.000 50.160 M 0.000 0.000 0.000 5.000 R 0.000 0.000 0.997 0.000 6.000 M 0.000 0.000 0.000 0.000 0.000 7.000 N 0.000 0.000 0.000 0.000 0.000 0*LENGTH* 10.00000 M 1 0"(2) QUADRUPOLE MATRIX K= 1/2 KL= 30 DEGREES NORMALIZED UNITS " 0 0 15. 1.00000 "M " 100.00000 ; 15. 2.00000 "R " 1000.00000 ; 15. 5.00000 "M " 100.00000 ; 15. 11.00000 "MEV " 0.00100 ; 15. 6.00000 "N " 100.00000 ; 1.000000 2.00000 3.00000 4.00000 5.00000 6.00000 7.00000 2997.92432; 13. 2.00000; 17. 2.00000 2.00000; 5.00 1.04719 5.00000 0.20000; 13. 4.00000; 13. 1.00000; (THE NUMERICAL VALUES OF THE 1ST AND 2ND ORDER QUADRUPOLE MATRIX ELEMENTS) (IN THIS CALCULATION SHOULD AGREE WITH THE QUADRUPOLE MATRIX ELEMENT EQUATIONS ) (ON PAGES 68 AND 69 OF SLAC REPORT NO. 75. BY K.L. BROWN. THE NORMALIZED ) (DIMENSIONS USED IN THIS CALCULATION, AS DETERMINED BY THE 15 TYPE ) (CODES ENTRIES, ARE AS FOLLOWS@D TRANSVERSE DIMENSIONS X AND Y ARE IN METERS,) (TRANSVERSE ANGLES THETA AND PHI ARE IN RADIANS, AND MOMENTUM DEVIATION ) (DELTA P/P IS FRACTIONAL . THE CENTRAL MOMENTUM IS CHOSEN AS P=BR=100 KG ) (METERS FOR THIS CALCULATION.) 0SENTINEL 0 11 ELEMENTS USED OUT OF A MAXIMUM ALLOWABLE 3129 42 NUMBERS USED OUT OF A MAXIMUM ALLOWABLE 13160 1(2) QUADRUPOLE MATRIX K= 1/2 KL= 30 DEGREES NORMALIZED UNITS *BEAM* 1. 2997.92432 MEV 0.000 M 0.000 2.000 M 0.000 3.000 R 0.000 0.000 4.000 M 0.000 0.000 0.000 5.000 R 0.000 0.000 0.000 0.000 6.000 M 0.000 0.000 0.000 0.000 0.000 7.000 N 0.000 0.000 0.000 0.000 0.000 *2ND ORDER* 17. GAUSSIAN DISTRIBUTION 2. 2. *QUAD* 5. 1.04719 M 5.00000 KG 0.20000 M ( 4.00003 M ) 1.047 M *TRANSFORM 1* 0.86603 0.99999 0.00000 0.00000 0.00000 0.00000 -0.25000 0.86603 0.00000 0.00000 0.00000 0.00000 0.00000 0.00000 1.14024 1.09570 0.00000 0.00000 0.00000 0.00000 0.27392 1.14024 0.00000 0.00000 0.00000 0.00000 0.00000 0.00000 1.00000 0.00000 0.00000 0.00000 0.00000 0.00000 0.00000 1.00000 0*2ND ORDER TRANSFORM* 1 11 0.000E+00 1 12 0.000E+00 1 22 0.000E+00 1 13 0.000E+00 1 23 0.000E+00 1 33 0.000E+00 1 14 0.000E+00 1 24 0.000E+00 1 34 0.000E+00 1 44 0.000E+00 1 15 0.000E+00 1 25 0.000E+00 1 35 0.000E+00 1 45 0.000E+00 1 55 0.000E+00 1 16 1.309E-01 1 26 4.655E-02 1 36 0.000E+00 1 46 0.000E+00 1 56 0.000E+00 1 66 0.000E+00 2 11 0.000E+00 2 12 0.000E+00 2 22 0.000E+00 2 13 0.000E+00 2 23 0.000E+00 2 33 0.000E+00 2 14 0.000E+00 2 24 0.000E+00 2 34 0.000E+00 2 44 0.000E+00 2 15 0.000E+00 2 25 0.000E+00 2 35 0.000E+00 2 45 0.000E+00 2 55 0.000E+00 2 16 2.384E-01 2 26 1.309E-01 2 36 0.000E+00 2 46 0.000E+00 2 56 0.000E+00 2 66 0.000E+00 3 11 0.000E+00 3 12 0.000E+00 3 22 0.000E+00 3 13 0.000E+00 3 23 0.000E+00 3 33 0.000E+00 3 14 0.000E+00 3 24 0.000E+00 3 34 0.000E+00 3 44 0.000E+00 3 15 0.000E+00 3 25 0.000E+00 3 35 0.000E+00 3 45 0.000E+00 3 55 0.000E+00 3 16 0.000E+00 3 26 0.000E+00 3 36 -1.434E-01 3 46 -4.917E-02 3 56 0.000E+00 3 66 0.000E+00 4 11 0.000E+00 4 12 0.000E+00 4 22 0.000E+00 4 13 0.000E+00 4 23 0.000E+00 4 33 0.000E+00 4 14 0.000E+00 4 24 0.000E+00 4 34 0.000E+00 4 44 0.000E+00 4 15 0.000E+00 4 25 0.000E+00 4 35 0.000E+00 4 45 0.000E+00 4 55 0.000E+00 4 16 0.000E+00 4 26 0.000E+00 4 36 -2.862E-01 4 46 -1.434E-01 4 56 0.000E+00 4 66 0.000E+00 5 11 -1.132E-02 5 12 1.250E-01 5 22 -4.783E-01 5 13 0.000E+00 5 23 0.000E+00 5 33 -1.264E-02 5 14 0.000E+00 5 24 0.000E+00 5 34 -1.501E-01 5 44 -5.741E-01 5 15 0.000E+00 5 25 0.000E+00 5 35 0.000E+00 5 45 0.000E+00 5 55 0.000E+00 5 16 0.000E+00 5 26 0.000E+00 5 36 0.000E+00 5 46 0.000E+00 5 56 0.000E+00 5 66 0.000E+00 0.000 4.039 M 0.000 5.069 R 0.768 0.000 8.361 M 0.000 0.000 0.000 11.096 R 0.000 0.000 0.831 -18.906 22.243 M 0.000 0.000 0.000 0.000 0.000 7.000 N 0.000 0.000 0.000 0.000 0.000 0*LENGTH* 1.04719 M 1 0"(3) PSI CORRECTION TO INPUT FRINGE FIELD G/R=0.2 K1=0.7 " 0 0 15. 1.00000 "M " 100.00000 ; 15. 2.00000 "R " 1000.00000 ; 15. 5.00000 "M " 100.00000 ; 15. 11.00000 "MEV " 0.00100 ; 15. 6.00000 "N " 100.00000 ; 1.000000 2.00000 3.00000 4.00000 5.00000 6.00000 7.00000 299.79248; 13. 2.00000; 16.00 "G/2 " 5.00000 0.10000; 16.00 "K1 " 7.00000 0.70000; 2.0 30.00000; 4.000 0.00001 10.00000 0.00000; 13. 4.00000; 13. 1.00000; (THE PURPOSE OF THIS CALCULATION IS TO COMPUTE THE PSI CORRECTION TERM ) (TO THE TRANSVERSE FOCAL LENGTH OF A ROTATED ENTRANCE FACE OF A BENDING ) (MAGNET RESULTING FROM THE FINITE EXTENT OF THE FRINGING FIELDS. THE ) (DEFINITION OF PSI AND THE EQUATION FOR THE TRANSVERSE FOCAL LENGTH ARE GIVEN) (ON PAGES 73 AND 74 OF SLAC 75. NORMALIZED DIMENSIONS ARE USED AS IN THE ) (PRECEDING PROBLEM. FOR THIS CALCULATION ; BR=10 KG METERS, R=1.0 METERS,) (G/R=0.2 AND K1=0.7 WHERE R=THE RADIUS OF THE CENTRAL ORBIT, G=THE GAP OF THE) (MAGNET AND K1 IS AN INTEGRAL OF THE FRINGING FIELD DEFINED ON PAGE 74 OF) (SLAC 75.) 0SENTINEL 0 13 ELEMENTS USED OUT OF A MAXIMUM ALLOWABLE 3129 47 NUMBERS USED OUT OF A MAXIMUM ALLOWABLE 13160 1(3) PSI CORRECTION TO INPUT FRINGE FIELD G/R=0.2 K1=0.7 *BEAM* 1. 299.79248 MEV 0.000 M 0.000 2.000 M 0.000 3.000 R 0.000 0.000 4.000 M 0.000 0.000 0.000 5.000 R 0.000 0.000 0.000 0.000 6.000 M 0.000 0.000 0.000 0.000 0.000 7.000 N 0.000 0.000 0.000 0.000 0.000 * G/2 * 16. "G/2 " 5. 0.10000E+00 * K1 * 16. "K1 " 7. 0.70000E+00 *ROTAT* 2. 30.00000 DEG 0.000 M *BEND* 4. 0.00001 M 10.00000 KG 0.00000 ( 1.000 M , 0.001 DEG ) 0.000 M *TRANSFORM 1* 1.00001 0.00001 0.00000 0.00000 0.00000 0.00000 0.57734 1.00000 0.00000 0.00000 0.00000 0.00001 0.00000 0.00000 1.00000 0.00001 0.00000 0.00000 0.00000 0.00000 -0.33308 1.00000 0.00000 0.00000 -0.00001 0.00000 0.00000 0.00000 1.00000 0.00000 0.00000 0.00000 0.00000 0.00000 0.00000 1.00000 0.000 2.000 M 0.000 3.215 R 0.359 0.000 4.000 M 0.000 0.000 0.000 5.174 R 0.000 0.000 -0.257 0.000 6.000 M 0.000 0.000 0.000 0.000 0.000 7.000 N 0.000 0.000 0.000 0.000 0.000 0*LENGTH* 0.00001 M 1 0"(4) PSI CORRECTION TO INPUT FRINGE FIELD G/R=0.2 K1=0.7 K2=3.0 " 0 0 15. 1.00000 "M " 100.00000 ; 15. 2.00000 "R " 1000.00000 ; 15. 5.00000 "M " 100.00000 ; 15. 11.00000 "MEV " 0.00100 ; 15. 6.00000 "N " 100.00000 ; 1.000000 2.00000 3.00000 4.00000 5.00000 6.00000 7.00000 299.79248; 13. 2.00000; 16.00 "G/2 " 5.00000 0.10000; 16.00 "K1 " 7.00000 0.70000; 16.00 "K2 " 8.00000 3.00000; 2.0 30.00000; 4.000 0.00001 10.00000 0.00000; 13. 4.00000; 13. 1.00000; (THE PURPOSE OF THIS CALCULATION IS TO COMPUTE THE PSI CORRECTION TERM ) (TO THE TRANSVERSE FOCAL LENGTH OF A ROTATED ENTRANCE FACE OF A BENDING ) (MAGNET RESULTING FROM THE FINITE EXTENT OF THE FRINGING FIELDS. THE ) (DEFINITION OF PSI AND THE EQUATION FOR THE TRANSVERSE FOCAL LENGTH ARE GIVEN) (ON PAGES 73 AND 74 OF SLAC 75. NORMALIZED DIMENSIONS ARE USED AS IN THE ) (PRECEDING PROBLEM. BR=10 KG METERS, R=1.0 METERS, G/R=0.2, K1=0.7, AND ) (K2=3.0 K2 IS DEFINED IN THE TRANSPORT/360 INSTRUCTION MANUAL. ) 0SENTINEL 0 14 ELEMENTS USED OUT OF A MAXIMUM ALLOWABLE 3129 50 NUMBERS USED OUT OF A MAXIMUM ALLOWABLE 13160 1(4) PSI CORRECTION TO INPUT FRINGE FIELD G/R=0.2 K1=0.7 K2=3.0 *BEAM* 1. 299.79248 MEV 0.000 M 0.000 2.000 M 0.000 3.000 R 0.000 0.000 4.000 M 0.000 0.000 0.000 5.000 R 0.000 0.000 0.000 0.000 6.000 M 0.000 0.000 0.000 0.000 0.000 7.000 N 0.000 0.000 0.000 0.000 0.000 * G/2 * 16. "G/2 " 5. 0.10000E+00 * K1 * 16. "K1 " 7. 0.70000E+00 * K2 * 16. "K2 " 8. 0.30000E+01 *ROTAT* 2. 30.00000 DEG 0.000 M *BEND* 4. 0.00001 M 10.00000 KG 0.00000 ( 1.000 M , 0.001 DEG ) 0.000 M *TRANSFORM 1* 1.00001 0.00001 0.00000 0.00000 0.00000 0.00000 0.57734 1.00000 0.00000 0.00000 0.00000 0.00001 0.00000 0.00000 1.00000 0.00001 0.00000 0.00000 0.00000 0.00000 -0.38847 1.00000 0.00000 0.00000 -0.00001 0.00000 0.00000 0.00000 1.00000 0.00000 0.00000 0.00000 0.00000 0.00000 0.00000 1.00000 0.000 2.000 M 0.000 3.215 R 0.359 0.000 4.000 M 0.000 0.000 0.000 5.236 R 0.000 0.000 -0.297 0.000 6.000 M 0.000 0.000 0.000 0.000 0.000 7.000 N 0.000 0.000 0.000 0.000 0.000 0*LENGTH* 0.00001 M 1 0"(5) PSI CORRECTION TO OUTPUT FRINGE FIELD G/R=0.2 K1=0.7 " 0 0 15. 1.00000 "M " 100.00000 ; 15. 2.00000 "R " 1000.00000 ; 15. 5.00000 "M " 100.00000 ; 15. 11.00000 "MEV " 0.00100 ; 15. 6.00000 "N " 100.00000 ; 1.000000 2.00000 3.00000 4.00000 5.00000 6.00000 7.00000 299.79248; 13. 2.00000; 16.00 "G/2 " 5.00000 0.10000; 16.00 "K1 " 7.00000 0.70000; 4.000 0.00001 10.00000 0.00000; 2.0 30.00000; 13. 4.00000; 13. 1.00000; (THE PURPOSE OF THIS CALCULATION IS TO COMPUTE THE PSI CORRECTION TERM TO THE) (TRANSVERSE FOCAL LENGTH OF A ROTATED EXIT FACE OF A BENDING MAGNET RESULTING) (FROM THE FINITE EXTENT OF THE FRINGING FIELDS. THE DEFINITION OF PSI AND) (THE EQUATION FOR THE TRANSVERSE FOCAL LENGTH ARE GIVEN ON PAGES 74 AND 75 OF) (SLAC 75. NORMALIZED DIMENSIONS ARE USED AS IN THE PRECEDING PROBLEM.) (BR=10 KG METERS, R=1.0 METERS, G/R=0.2, AND K1=0.7 ) 0SENTINEL 0 13 ELEMENTS USED OUT OF A MAXIMUM ALLOWABLE 3129 47 NUMBERS USED OUT OF A MAXIMUM ALLOWABLE 13160 1(5) PSI CORRECTION TO OUTPUT FRINGE FIELD G/R=0.2 K1=0.7 *BEAM* 1. 299.79248 MEV 0.000 M 0.000 2.000 M 0.000 3.000 R 0.000 0.000 4.000 M 0.000 0.000 0.000 5.000 R 0.000 0.000 0.000 0.000 6.000 M 0.000 0.000 0.000 0.000 0.000 7.000 N 0.000 0.000 0.000 0.000 0.000 * G/2 * 16. "G/2 " 5. 0.10000E+00 * K1 * 16. "K1 " 7. 0.70000E+00 *BEND* 4. 0.00001 M 10.00000 KG 0.00000 ( 1.000 M , 0.001 DEG ) 0.000 M *ROTAT* 2. 30.00000 DEG 0.000 M *TRANSFORM 1* 1.00000 0.00001 0.00000 0.00000 0.00000 0.00000 0.57734 1.00001 0.00000 0.00000 0.00000 0.00001 0.00000 0.00000 1.00000 0.00001 0.00000 0.00000 0.00000 0.00000 -0.33308 1.00000 0.00000 0.00000 -0.00001 0.00000 0.00000 0.00000 1.00000 0.00000 0.00000 0.00000 0.00000 0.00000 0.00000 1.00000 0.000 2.000 M 0.000 3.215 R 0.359 0.000 4.000 M 0.000 0.000 0.000 5.174 R 0.000 0.000 -0.257 0.000 6.000 M 0.000 0.000 0.000 0.000 0.000 7.000 N 0.000 0.000 0.000 0.000 0.000 0*LENGTH* 0.00001 M 1 0"(6) PSI CORRECTION TO OUTPUT FRINGE FIELD G/R=0.2 K1=0.7 K2=3.0 " 0 0 15. 1.00000 "M " 100.00000 ; 15. 2.00000 "R " 1000.00000 ; 15. 5.00000 "M " 100.00000 ; 15. 11.00000 "MEV " 0.00100 ; 15. 6.00000 "N " 100.00000 ; 1.000000 2.00000 3.00000 4.00000 5.00000 6.00000 7.00000 299.79248; 13. 2.00000; 16.00 "G/2 " 5.00000 0.10000; 16.00 "K1 " 7.00000 0.70000; 16.00 "K2 " 8.00000 3.00000; 4.000 0.00001 10.00000 0.00000; 2.0 30.00000; 13. 4.00000; 13. 1.00000; (THIS CALCULATION COMPUTES THE PSI CORRECTION TERM TO THE TRANSVERSE FOCAL ) (LENGTH OF A ROTATED EXIT FACE OF A BENDING MAGNET RESULTING FROM THE FINITE ) (EXTENT OF THE FRINGING FIELDS. THE DEFINITION OF PSI AND THE EQUATION FOR ) (THE TRANSVERSE FOCAL LENGTH ARE GIVEN ON PAGES 74 AND 75 OF SLAC 75.) (NORMALIZED DIMENSIONS ARE USED AS IN THE PRECEDING PROBLEM. ) (BR=10 KG METERS, R=1.0 METERS, G/R=0.2, K1=0.7, AND K2=3.0 ) 0SENTINEL 0 14 ELEMENTS USED OUT OF A MAXIMUM ALLOWABLE 3129 50 NUMBERS USED OUT OF A MAXIMUM ALLOWABLE 13160 1(6) PSI CORRECTION TO OUTPUT FRINGE FIELD G/R=0.2 K1=0.7 K2=3.0 *BEAM* 1. 299.79248 MEV 0.000 M 0.000 2.000 M 0.000 3.000 R 0.000 0.000 4.000 M 0.000 0.000 0.000 5.000 R 0.000 0.000 0.000 0.000 6.000 M 0.000 0.000 0.000 0.000 0.000 7.000 N 0.000 0.000 0.000 0.000 0.000 * G/2 * 16. "G/2 " 5. 0.10000E+00 * K1 * 16. "K1 " 7. 0.70000E+00 * K2 * 16. "K2 " 8. 0.30000E+01 *BEND* 4. 0.00001 M 10.00000 KG 0.00000 ( 1.000 M , 0.001 DEG ) 0.000 M *ROTAT* 2. 30.00000 DEG 0.000 M *TRANSFORM 1* 1.00000 0.00001 0.00000 0.00000 0.00000 0.00000 0.57734 1.00001 0.00000 0.00000 0.00000 0.00001 0.00000 0.00000 1.00000 0.00001 0.00000 0.00000 0.00000 0.00000 -0.38847 1.00000 0.00000 0.00000 -0.00001 0.00000 0.00000 0.00000 1.00000 0.00000 0.00000 0.00000 0.00000 0.00000 0.00000 1.00000 0.000 2.000 M 0.000 3.215 R 0.359 0.000 4.000 M 0.000 0.000 0.000 5.236 R 0.000 0.000 -0.297 0.000 6.000 M 0.000 0.000 0.000 0.000 0.000 7.000 N 0.000 0.000 0.000 0.000 0.000 0*LENGTH* 0.00001 M 1 0"(7) 2ND ORDER INPUT FRINGE FIELD R(2,1) = 1.0 R=1/2 R1= 2.0 " 0 0 15. 1.00000 "M " 100.00000 ; 15. 2.00000 "R " 1000.00000 ; 15. 5.00000 "M " 100.00000 ; 15. 11.00000 "MEV " 0.00100 ; 15. 6.00000 "N " 100.00000 ; 1.000000 2.00000 3.00000 4.00000 5.00000 6.00000 7.00000 299.79248; 13. 2.00000; 17. 2.00000 2.00000; 16.00 "G/2 " 5.00000 0.05000; 16.00 "K1 " 7.00000 0.70000; 16.00 "K2 " 8.00000 3.00000; 16.00 "1/R1" 12.00000 0.50000; 2.0 26.56600; 4.000 0.00001 20.00000 0.50000; 13. 4.00000; 13. 1.00000; (THIS CALCULATION IS INTENDED TO CHECK BOTH THE 1ST AND 2ND ORDER) (INPUT FRINGING FIELD MATRIX ELEMENTS OF A BENDING MAGNET AND COMPARE THE) (RESULTS WITH PAGES 71 THROUGH 75 OF SLAC 75. FOR THIS CALCULATION THE ) 0NEXT COMMENT TRUNCATED TO 116 CHARS. (FOLLOWING PARAMETERS WERE CHOSEN@D BR=10 KG METERS, R=1/2 METER, TAN BETA=1/2 (R1=2 METERS. G/R=0.2, K1=0.7, AND K2=) (USED FOR THE TRANSVERSE DIMENSIONS. ) 0SENTINEL 0 16 ELEMENTS USED OUT OF A MAXIMUM ALLOWABLE 3129 56 NUMBERS USED OUT OF A MAXIMUM ALLOWABLE 13160 1(7) 2ND ORDER INPUT FRINGE FIELD R(2,1) = 1.0 R=1/2 R1= 2.0 *BEAM* 1. 299.79248 MEV 0.000 M 0.000 2.000 M 0.000 3.000 R 0.000 0.000 4.000 M 0.000 0.000 0.000 5.000 R 0.000 0.000 0.000 0.000 6.000 M 0.000 0.000 0.000 0.000 0.000 7.000 N 0.000 0.000 0.000 0.000 0.000 *2ND ORDER* 17. GAUSSIAN DISTRIBUTION 2. 2. * G/2 * 16. "G/2 " 5. 0.50000E-01 * K1 * 16. "K1 " 7. 0.70000E+00 * K2 * 16. "K2 " 8. 0.30000E+01 * 1/R1 * 16. "1/R1" 12. 0.50000E+00 *ROTAT* 2. 26.56600 DEG 2.00000 M 0.000 M *BEND* 4. 0.00001 M 20.00000 KG 0.50000 ( 0.500 M , 0.001 DEG ) 0.000 M *TRANSFORM 1* 1.00001 0.00001 0.00000 0.00000 0.00000 0.00000 1.00002 1.00000 0.00000 0.00000 0.00000 0.00002 0.00000 0.00000 0.99999 0.00001 0.00000 0.00000 0.00000 0.00000 -0.65233 1.00000 0.00000 0.00000 -0.00002 0.00000 0.00000 0.00000 1.00000 0.00000 0.00000 0.00000 0.00000 0.00000 0.00000 1.00000 0*2ND ORDER TRANSFORM* 1 11 -2.500E-01 1 12 2.500E-05 1 22 5.000E-11 1 13 0.000E+00 1 23 0.000E+00 1 33 1.250E+00 1 14 0.000E+00 1 24 0.000E+00 1 34 -5.000E-06 1 44 -5.000E-11 1 15 0.000E+00 1 25 0.000E+00 1 35 0.000E+00 1 45 0.000E+00 1 55 0.000E+00 1 16 -1.000E-05 1 26 6.667E-16 1 36 0.000E+00 1 46 0.000E+00 1 56 0.000E+00 1 66 -1.000E-10 2 11 -3.012E-01 2 12 5.000E-01 2 22 -1.000E-05 2 13 0.000E+00 2 23 0.000E+00 2 33 1.801E+00 2 14 0.000E+00 2 24 0.000E+00 2 34 -5.000E-01 2 44 -1.000E-05 2 15 0.000E+00 2 25 0.000E+00 2 35 0.000E+00 2 45 0.000E+00 2 55 0.000E+00 2 16 -1.000E+00 2 26 -1.000E-10 2 36 0.000E+00 2 46 0.000E+00 2 56 0.000E+00 2 66 -2.000E-05 3 11 0.000E+00 3 12 0.000E+00 3 22 0.000E+00 3 13 5.000E-01 3 23 -2.500E-05 3 33 0.000E+00 3 14 1.500E-05 3 24 1.000E-10 3 34 0.000E+00 3 44 0.000E+00 3 15 0.000E+00 3 25 0.000E+00 3 35 0.000E+00 3 45 0.000E+00 3 55 0.000E+00 3 16 0.000E+00 3 26 0.000E+00 3 36 1.000E-05 3 46 0.000E+00 3 56 0.000E+00 3 66 0.000E+00 4 11 0.000E+00 4 12 0.000E+00 4 22 0.000E+00 4 13 6.025E-01 4 23 -2.500E+00 4 33 0.000E+00 4 14 -5.000E-01 4 24 0.000E+00 4 34 0.000E+00 4 44 0.000E+00 4 15 0.000E+00 4 25 0.000E+00 4 35 0.000E+00 4 45 0.000E+00 4 55 0.000E+00 4 16 0.000E+00 4 26 0.000E+00 4 36 1.000E+00 4 46 1.000E-10 4 56 0.000E+00 4 66 0.000E+00 5 11 6.366E-11 5 12 -1.000E-05 5 22 -5.000E-06 5 13 0.000E+00 5 23 0.000E+00 5 33 -2.713E-05 5 14 0.000E+00 5 24 0.000E+00 5 34 6.523E-06 5 44 -5.000E-06 5 15 0.000E+00 5 25 0.000E+00 5 35 0.000E+00 5 45 0.000E+00 5 55 0.000E+00 5 16 0.000E+00 5 26 -1.000E-10 5 36 0.000E+00 5 46 0.000E+00 5 56 0.000E+00 5 66 0.000E+00 19.001 28.391 M 27.615 44.522 R 0.917 0.000 5.657 M 0.000 0.000 0.000 42.002 R 0.000 0.000 0.037 -0.001 6.000 M 0.000 0.000 0.000 0.000 0.000 7.000 N 0.000 0.000 0.000 0.000 0.000 0*LENGTH* 0.00001 M 1 0"(8) 2ND ORDER OUTPUT FRINGE FIELD R(2,1) = 1.0 R=1/2 R2= 2.0 " 0 0 15. 1.00000 "M " 100.00000 ; 15. 2.00000 "R " 1000.00000 ; 15. 5.00000 "M " 100.00000 ; 15. 11.00000 "MEV " 0.00100 ; 15. 6.00000 "N " 100.00000 ; 1.000000 2.00000 3.00000 4.00000 5.00000 6.00000 7.00000 299.79248; 13. 2.00000; 17. 2.00000 2.00000; 16.00 "G/2 " 5.00000 0.05000; 16.00 "K1 " 7.00000 0.70000; 16.00 "K2 " 8.00000 3.00000; 16.00 "1/R2" 13.00000 0.50000; 4.000 0.00001 20.00000 0.50000; 2.0 26.56600; 13. 4.00000; 13. 1.00000; (THIS CALCULATION IS INTENDED TO CHECK BOTH THE 1ST AND 2ND ORDER OUTPUT ) (FRINGING FIELD MATRIX ELEMENTS OF A BENDING MAGNET AND COMPARE THE RESULTS ) (WITH PAGES 71 THROUGH 75 OF SLAC 75. FOR THIS CALCULATION THE FOLLOWING ) (PARAMETERS WERE CHOSEN@D BR=10 KG METERS, R=1/2 METER, TAN BETA=1/2,) (R2=2 METERS. G/R=0.2, K1=0.7, AND K2=3.0 NORMALIZED UNITS ARE USED FOR ) (THE TRANSVERSE DIMENSIONS ) 0SENTINEL 0 16 ELEMENTS USED OUT OF A MAXIMUM ALLOWABLE 3129 56 NUMBERS USED OUT OF A MAXIMUM ALLOWABLE 13160 1(8) 2ND ORDER OUTPUT FRINGE FIELD R(2,1) = 1.0 R=1/2 R2= 2.0 *BEAM* 1. 299.79248 MEV 0.000 M 0.000 2.000 M 0.000 3.000 R 0.000 0.000 4.000 M 0.000 0.000 0.000 5.000 R 0.000 0.000 0.000 0.000 6.000 M 0.000 0.000 0.000 0.000 0.000 7.000 N 0.000 0.000 0.000 0.000 0.000 *2ND ORDER* 17. GAUSSIAN DISTRIBUTION 2. 2. * G/2 * 16. "G/2 " 5. 0.50000E-01 * K1 * 16. "K1 " 7. 0.70000E+00 * K2 * 16. "K2 " 8. 0.30000E+01 * 1/R2 * 16. "1/R2" 13. 0.50000E+00 *BEND* 4. 0.00001 M 20.00000 KG 0.50000 ( 0.500 M , 0.001 DEG ) 0.000 M *ROTAT* 2. 26.56600 DEG 2.00000 M 0.000 M *TRANSFORM 1* 1.00000 0.00001 0.00000 0.00000 0.00000 0.00000 1.00002 1.00001 0.00000 0.00000 0.00000 0.00002 0.00000 0.00000 1.00000 0.00001 0.00000 0.00000 0.00000 0.00000 -0.65233 0.99999 0.00000 0.00000 -0.00002 0.00000 0.00000 0.00000 1.00000 0.00000 0.00000 0.00000 0.00000 0.00000 0.00000 1.00000 0*2ND ORDER TRANSFORM* 1 11 2.500E-01 1 12 2.500E-05 1 22 7.500E-11 1 13 0.000E+00 1 23 0.000E+00 1 33 -1.250E+00 1 14 0.000E+00 1 24 0.000E+00 1 34 -2.500E-05 1 44 -1.750E-10 1 15 0.000E+00 1 25 0.000E+00 1 35 0.000E+00 1 45 0.000E+00 1 55 0.000E+00 1 16 3.500E-10 1 26 1.167E-15 1 36 0.000E+00 1 46 0.000E+00 1 56 0.000E+00 1 66 -1.000E-10 2 11 -5.512E-01 2 12 -5.000E-01 2 22 -1.500E-05 2 13 0.000E+00 2 23 0.000E+00 2 33 5.119E-02 2 14 0.000E+00 2 24 0.000E+00 2 34 5.000E-01 2 44 -5.000E-06 2 15 0.000E+00 2 25 0.000E+00 2 35 0.000E+00 2 45 0.000E+00 2 55 0.000E+00 2 16 -1.000E+00 2 26 -1.000E-05 2 36 0.000E+00 2 46 0.000E+00 2 56 0.000E+00 2 66 -2.000E-05 3 11 0.000E+00 3 12 0.000E+00 3 22 0.000E+00 3 13 -5.000E-01 3 23 -5.000E-06 3 33 0.000E+00 3 14 1.500E-05 3 24 5.000E-11 3 34 0.000E+00 3 44 0.000E+00 3 15 0.000E+00 3 25 0.000E+00 3 35 0.000E+00 3 45 0.000E+00 3 55 0.000E+00 3 16 0.000E+00 3 26 0.000E+00 3 36 5.000E-11 3 46 -5.000E-16 3 56 0.000E+00 3 66 0.000E+00 4 11 0.000E+00 4 12 0.000E+00 4 22 0.000E+00 4 13 3.103E+00 4 23 2.500E+00 4 33 0.000E+00 4 14 5.001E-01 4 24 3.000E-05 4 34 0.000E+00 4 44 0.000E+00 4 15 0.000E+00 4 25 0.000E+00 4 35 0.000E+00 4 45 0.000E+00 4 55 0.000E+00 4 16 0.000E+00 4 26 0.000E+00 4 36 1.000E+00 4 46 1.000E-05 4 56 0.000E+00 4 66 0.000E+00 5 11 0.000E+00 5 12 3.333E-11 5 22 -5.000E-06 5 13 0.000E+00 5 23 0.000E+00 5 33 0.000E+00 5 14 0.000E+00 5 24 0.000E+00 5 34 1.000E-10 5 44 -5.000E-06 5 15 0.000E+00 5 25 0.000E+00 5 35 0.000E+00 5 45 0.000E+00 5 55 0.000E+00 5 16 0.000E+00 5 26 -1.000E-10 5 36 0.000E+00 5 46 0.000E+00 5 56 0.000E+00 5 66 0.000E+00 -19.000 28.391 M -1.387 18.141 R -0.064 0.000 5.657 M 0.000 0.000 0.000 48.550 R 0.000 0.000 -0.400 0.000 6.000 M 0.000 0.000 0.000 0.000 0.000 7.000 N 0.000 0.000 0.000 0.000 0.000 0*LENGTH* 0.00001 M 1 0"(9) SEXTUPOLE MATRIX K(S)SQUARED = 10.0 L =0.1 METERS NORM UNITS " 0 0 15. 1.00000 "M " 100.00000 ; 15. 2.00000 "R " 1000.00000 ; 15. 5.00000 "M " 100.00000 ; 15. 11.00000 "MEV " 0.00100 ; 15. 6.00000 "N " 100.00000 ; 1.000000 2.00000 3.00000 4.00000 5.00000 6.00000 7.00000 2997.92432; 13. 2.00000; 17. 2.00000 2.00000; 18.00 0.10000 10.00000 0.10000; 13. 4.00000; 13. 1.00000; (THESE RESULTS SHOULD BE COMPARED WITH THE MATRIX ELEMENTS LISTED ON PAGES ) (69 AND 70 OF SLAC 75 FOR THE SEXTUPOLE. KS SQUARED=10. L=0.1, AND BR=100 KG ) (METERS. NORMALIZED TRANSVERSE UNITS ARE USED. ) 0SENTINEL 0 11 ELEMENTS USED OUT OF A MAXIMUM ALLOWABLE 3129 42 NUMBERS USED OUT OF A MAXIMUM ALLOWABLE 13160 1(9) SEXTUPOLE MATRIX K(S)SQUARED = 10.0 L =0.1 METERS NORM UNITS *BEAM* 1. 2997.92432 MEV 0.000 M 0.000 2.000 M 0.000 3.000 R 0.000 0.000 4.000 M 0.000 0.000 0.000 5.000 R 0.000 0.000 0.000 0.000 6.000 M 0.000 0.000 0.000 0.000 0.000 7.000 N 0.000 0.000 0.000 0.000 0.000 *2ND ORDER* 17. GAUSSIAN DISTRIBUTION 2. 2. *SEXT* 18. 0.10000 M 10.00000 KG 0.10000 M 0.100 M *TRANSFORM 1* 1.00000 0.10000 0.00000 0.00000 0.00000 0.00000 0.00000 1.00000 0.00000 0.00000 0.00000 0.00000 0.00000 0.00000 1.00000 0.10000 0.00000 0.00000 0.00000 0.00000 0.00000 1.00000 0.00000 0.00000 0.00000 0.00000 0.00000 0.00000 1.00000 0.00000 0.00000 0.00000 0.00000 0.00000 0.00000 1.00000 0*2ND ORDER TRANSFORM* 1 11 -5.000E-02 1 12 -3.333E-03 1 22 -8.333E-05 1 13 0.000E+00 1 23 0.000E+00 1 33 5.000E-02 1 14 0.000E+00 1 24 0.000E+00 1 34 3.333E-03 1 44 8.333E-05 1 15 0.000E+00 1 25 0.000E+00 1 35 0.000E+00 1 45 0.000E+00 1 55 0.000E+00 1 16 0.000E+00 1 26 0.000E+00 1 36 0.000E+00 1 46 0.000E+00 1 56 0.000E+00 1 66 0.000E+00 2 11 -1.000E+00 2 12 -1.000E-01 2 22 -3.333E-03 2 13 0.000E+00 2 23 0.000E+00 2 33 1.000E+00 2 14 0.000E+00 2 24 0.000E+00 2 34 1.000E-01 2 44 3.333E-03 2 15 0.000E+00 2 25 0.000E+00 2 35 0.000E+00 2 45 0.000E+00 2 55 0.000E+00 2 16 0.000E+00 2 26 0.000E+00 2 36 0.000E+00 2 46 0.000E+00 2 56 0.000E+00 2 66 0.000E+00 3 11 0.000E+00 3 12 0.000E+00 3 22 0.000E+00 3 13 1.000E-01 3 23 3.333E-03 3 33 0.000E+00 3 14 3.333E-03 3 24 1.667E-04 3 34 0.000E+00 3 44 0.000E+00 3 15 0.000E+00 3 25 0.000E+00 3 35 0.000E+00 3 45 0.000E+00 3 55 0.000E+00 3 16 0.000E+00 3 26 0.000E+00 3 36 0.000E+00 3 46 0.000E+00 3 56 0.000E+00 3 66 0.000E+00 4 11 0.000E+00 4 12 0.000E+00 4 22 0.000E+00 4 13 2.000E+00 4 23 1.000E-01 4 33 0.000E+00 4 14 1.000E-01 4 24 6.667E-03 4 34 0.000E+00 4 44 0.000E+00 4 15 0.000E+00 4 25 0.000E+00 4 35 0.000E+00 4 45 0.000E+00 4 55 0.000E+00 4 16 0.000E+00 4 26 0.000E+00 4 36 0.000E+00 4 46 0.000E+00 4 56 0.000E+00 4 66 0.000E+00 5 11 0.000E+00 5 12 0.000E+00 5 22 -5.000E-02 5 13 0.000E+00 5 23 0.000E+00 5 33 0.000E+00 5 14 0.000E+00 5 24 0.000E+00 5 34 0.000E+00 5 44 -5.000E-02 5 15 0.000E+00 5 25 0.000E+00 5 35 0.000E+00 5 45 0.000E+00 5 55 0.000E+00 5 16 0.000E+00 5 26 0.000E+00 5 36 0.000E+00 5 46 0.000E+00 5 56 0.000E+00 5 66 0.000E+00 0.601 2.336 M 12.053 23.609 R 0.512 0.000 4.110 M 0.000 0.000 0.000 16.836 R 0.000 0.000 0.222 -1.700 6.287 M 0.000 -0.001 0.000 0.000 0.000 7.000 N 0.000 0.000 0.000 0.000 0.000 0*LENGTH* 0.10000 M 1 0"(10) ACCELERATOR MATRIX STANDARD UNITS ARE USED ( SEE BELOW ) " 0 0 15. 1.00000 "CM " 1.00000 ; 15. 2.00000 "MR " 1.00000 ; 15. 5.00000 "CM " 1.00000 ; 15. 8.00000 "M " 1.00000 ; 15. 11.00000 "GEV " 1.00000 ; 15. 6.00000 "PC " 1.00000 ; -16. "MASS" 3.00000 1836.00000; 1.000000 2.00000 3.00000 4.00000 5.00000 6.00000 7.00000 10.00000; 11. 10.00000 0.10000 30.00000 1.00000; 13. 4.00000; (THE ANALYTICAL EXPRESSIONS FOR THE ACCELERATOR MATRIX ELEMENTS ARE LISTED ) (IN THE TRANSPORT/360 MANUAL AS DERIVED BY K.L. BROWN. THIS CALCULATION ) (HAS BEEN MADE IN STANDARD TRANSPORT UNITS@D X,Y IN CMS, THETA AND PHI IN ) (MILLIRADIANS AND DELTA P/P IN PERCENT. THE PARAMETERS CHOSEN FOR THE) (CALCULATION ARE E=10 GEV, DELTA E=0.1 GEV, THE PHASE LAG=30 DEGREES AND ) (THE WAVELENGTH = 1 CM. ) 0SENTINEL 0 10 ELEMENTS USED OUT OF A MAXIMUM ALLOWABLE 3129 43 NUMBERS USED OUT OF A MAXIMUM ALLOWABLE 13160 1(10) ACCELERATOR MATRIX STANDARD UNITS ARE USED ( SEE BELOW ) *BEAM* 1. 10.00000 GEV 0.000 M 0.000 2.000 CM 0.000 3.000 MR 0.000 0.000 4.000 CM 0.000 0.000 0.000 5.000 MR 0.000 0.000 0.000 0.000 6.000 CM 0.000 0.000 0.000 0.000 0.000 7.000 PC 0.000 0.000 0.000 0.000 0.000 *ACC* 11. 10.00000 M 0.10000 ( 10.08660) GEV 30.00000 1.00000 10.000 M *TRANSFORM 1* 1.00000 0.99569 0.00000 0.00000 0.00000 0.00000 0.00000 0.99141 0.00000 0.00000 0.00000 0.00000 0.00000 0.00000 1.00000 0.99569 0.00000 0.00000 0.00000 0.00000 0.00000 0.99141 0.00000 0.00000 0.00000 0.00000 0.00000 0.00000 1.00000 0.00000 0.00000 0.00000 0.00000 0.00000 3.11462 0.99141 0*LENGTH* 10.00000 M 1 0"(10) ACCELERATOR MATRIX NONZERO MASS FOR PARTICLE " 0 1 15. 1.00000 "CM " 1.00000 ; 15. 2.00000 "MR " 1.00000 ; 15. 5.00000 "CM " 1.00000 ; 15. 8.00000 "M " 1.00000 ; 15. 11.00000 "GEV " 1.00000 ; 15. 6.00000 "PC " 1.00000 ; * 16.00 "MASS" 3.00000 1836.00000; 1.000000 2.00000 3.00000 4.00000 5.00000 6.00000 7.00000 10.00000; 11. 10.00000 0.10000 30.00000 1.00000; 13. 4.00000; 0SENTINEL 0 10 ELEMENTS USED OUT OF A MAXIMUM ALLOWABLE 3129 41 NUMBERS USED OUT OF A MAXIMUM ALLOWABLE 13160 1(10) ACCELERATOR MATRIX NONZERO MASS FOR PARTICLE *P MASS* 16. "MASS" 3. 0.18360E+04 *BEAM* 1. 10.00000 GEV 0.000 M 0.000 2.000 CM 0.000 3.000 MR 0.000 0.000 4.000 CM 0.000 0.000 0.000 5.000 MR 0.000 0.000 0.000 0.000 6.000 CM 0.000 0.000 0.000 0.000 0.000 7.000 PC 0.000 0.000 0.000 0.000 0.000 *ACC* 11. 10.00000 M 0.10000 ( 10.08698) GEV 30.00000 1.00000 10.000 M *TRANSFORM 1* 1.06932 1.01856 0.00000 0.00000 0.00000 0.00000 0.13962 1.06010 0.00000 0.00000 0.00000 0.00000 0.00000 0.00000 1.06932 1.01856 0.00000 0.00000 0.00000 0.00000 0.13962 1.06010 0.00000 0.00000 0.00000 0.00000 0.00000 0.00000 1.27208 0.08610 0.00000 0.00000 0.00000 0.00000 3.12795 0.99130 0*LENGTH* 10.00000 M 1 0"(11) SOLENOID MATRIX K = 1/4 KL = 30 DEGREES NORMALIZED UNITS " 0 0 15. 1.00000 "M " 100.00000 ; 15. 2.00000 "R " 1000.00000 ; 15. 5.00000 "M " 100.00000 ; 15. 8.00000 "CM " 0.01000 ; 15. 11.00000 "MEV " 0.00100 ; 15. 6.00000 "N " 100.00000 ; 1.000000 2.00000 3.00000 4.00000 5.00000 6.00000 7.00000 299.79248; 13. 2.00000; 17. 2.00000 2.00000; 19.00 209.43999 5.00000; 13. 4.00000; 13. 1.00000; (THE ANALYTICAL EXPRESSIONS FOR THE SOLENOID MATRIX ELEMENTS ARE LISTED ) (IN THE TRANSPORT/360 INSTRUCTION MANUAL AS DERIVED FROM R H HELMS SLAC ) (REPORT NO. 4. FOR THE SOLENOID K=B/2BR WHERE B IS THE MAGNETIC FIELD IN THE ) (SOLENOID AND BR = P = THE PARTICLE MOMENTUM. FOR THIS CALCULATION THE ) (MOMENTUM BR = 10 KG METERS, B = 5 KG ; FROM WHICH K = 1/4. KL = 30 DEGREES ) (IS CHOSEN FOR EASE OF CHECKING. NORMALIZED TRANSVERSE UNITS ARE USED FOR THE) (CALCULATION.) 0SENTINEL 0 12 ELEMENTS USED OUT OF A MAXIMUM ALLOWABLE 3129 45 NUMBERS USED OUT OF A MAXIMUM ALLOWABLE 13160 1(11) SOLENOID MATRIX K = 1/4 KL = 30 DEGREES NORMALIZED UNITS *BEAM* 1. 299.79248 MEV 0.000 CM 0.000 2.000 M 0.000 3.000 R 0.000 0.000 4.000 M 0.000 0.000 0.000 5.000 R 0.000 0.000 0.000 0.000 6.000 M 0.000 0.000 0.000 0.000 0.000 7.000 N 0.000 0.000 0.000 0.000 0.000 *2ND ORDER* 17. GAUSSIAN DISTRIBUTION 2. 2. *SOLO* 19. 209.44000 CM 5.00000 KG 209.440 CM *TRANSFORM 1* 0.75000 1.73205 0.43301 1.00000 0.00000 0.00000 -0.10825 0.75000 -0.06250 0.43301 0.00000 0.00000 -0.43301 -1.00000 0.75000 1.73205 0.00000 0.00000 0.06250 -0.43301 -0.10825 0.75000 0.00000 0.00000 0.00000 0.00000 0.00000 0.00000 1.00000 0.00000 0.00000 0.00000 0.00000 0.00000 0.00000 1.00000 0*2ND ORDER TRANSFORM* 1 11 0.000E+00 1 12 0.000E+00 1 22 0.000E+00 1 13 0.000E+00 1 23 0.000E+00 1 33 0.000E+00 1 14 0.000E+00 1 24 0.000E+00 1 34 0.000E+00 1 44 0.000E+00 1 15 0.000E+00 1 25 0.000E+00 1 35 0.000E+00 1 45 0.000E+00 1 55 0.000E+00 1 16 4.535E-01 1 26 6.849E-01 1 36 -2.618E-01 1 46 -8.138E-01 1 56 0.000E+00 1 66 0.000E+00 2 11 0.000E+00 2 12 0.000E+00 2 22 0.000E+00 2 13 0.000E+00 2 23 0.000E+00 2 33 0.000E+00 2 14 0.000E+00 2 24 0.000E+00 2 34 0.000E+00 2 44 0.000E+00 2 15 0.000E+00 2 25 0.000E+00 2 35 0.000E+00 2 45 0.000E+00 2 55 0.000E+00 2 16 1.737E-01 2 26 4.535E-01 2 36 1.759E-01 2 46 -2.618E-01 2 56 0.000E+00 2 66 0.000E+00 3 11 0.000E+00 3 12 0.000E+00 3 22 0.000E+00 3 13 0.000E+00 3 23 0.000E+00 3 33 0.000E+00 3 14 0.000E+00 3 24 0.000E+00 3 34 0.000E+00 3 44 0.000E+00 3 15 0.000E+00 3 25 0.000E+00 3 35 0.000E+00 3 45 0.000E+00 3 55 0.000E+00 3 16 2.618E-01 3 26 8.138E-01 3 36 4.535E-01 3 46 6.849E-01 3 56 0.000E+00 3 66 0.000E+00 4 11 0.000E+00 4 12 0.000E+00 4 22 0.000E+00 4 13 0.000E+00 4 23 0.000E+00 4 33 0.000E+00 4 14 0.000E+00 4 24 0.000E+00 4 34 0.000E+00 4 44 0.000E+00 4 15 0.000E+00 4 25 0.000E+00 4 35 0.000E+00 4 45 0.000E+00 4 55 0.000E+00 4 16 -1.759E-01 4 26 2.618E-01 4 36 1.737E-01 4 46 4.535E-01 4 56 0.000E+00 4 66 0.000E+00 5 11 0.000E+00 5 12 0.000E+00 5 22 -1.047E+00 5 13 0.000E+00 5 23 0.000E+00 5 33 0.000E+00 5 14 0.000E+00 5 24 0.000E+00 5 34 0.000E+00 5 44 -1.047E+00 5 15 0.000E+00 5 25 0.000E+00 5 35 0.000E+00 5 45 0.000E+00 5 55 0.000E+00 5 16 0.000E+00 5 26 0.000E+00 5 36 0.000E+00 5 46 0.000E+00 5 56 0.000E+00 5 66 0.000E+00 0.000 34.197 M 0.000 14.651 R 0.796 0.000 33.690 M -0.412 0.053 0.000 18.105 R -0.667 -0.263 0.922 -35.605 39.805 M 0.000 0.000 0.000 0.000 0.000 7.000 N 0.000 0.000 0.000 0.000 0.000 0*LENGTH* 209.44000 CM 1 0"(12) SOLENOID + COORDINATE ROTATION K = 1/4 KL = 30 DEGREES " 0 0 15. 1.00000 "M " 100.00000 ; 15. 2.00000 "R " 1000.00000 ; 15. 5.00000 "M " 100.00000 ; 15. 8.00000 "CM " 0.01000 ; 15. 11.00000 "MEV " 0.00100 ; 15. 6.00000 "N " 100.00000 ; 1.000000 2.00000 3.00000 4.00000 5.00000 6.00000 7.00000 299.79248; 13. 2.00000; 17. 2.00000 2.00000; 19.00 209.43999 5.00000; 20.0 -30.00000; 13. 4.00000; 13. 1.00000; (IF THE TRANSVERSE COORDINATES ARE ROTATED ABOUT THE Z AXIS OF A SOLENOID BY ) (AN ANGLE OF -KL , THEN THE X AND Y 1ST ORDER MATRIX ELEMENTS ARE DECOUPLED. ) (THUS IN THIS TEST CASE THE MATRIX ELEMENTS R13=R14=R23=R24=R31=R32=R41=R42 ) (ALL SHOULD BE EQUAL TO ZERO. THIS PROVIDES A TEST FOR THE SOLENOID MATRIX ) (ELEMENTS AS WELL AS THE Z ROTATION MATRIX. ) 0SENTINEL 0 13 ELEMENTS USED OUT OF A MAXIMUM ALLOWABLE 3129 47 NUMBERS USED OUT OF A MAXIMUM ALLOWABLE 13160 1(12) SOLENOID + COORDINATE ROTATION K = 1/4 KL = 30 DEGREES *BEAM* 1. 299.79248 MEV 0.000 CM 0.000 2.000 M 0.000 3.000 R 0.000 0.000 4.000 M 0.000 0.000 0.000 5.000 R 0.000 0.000 0.000 0.000 6.000 M 0.000 0.000 0.000 0.000 0.000 7.000 N 0.000 0.000 0.000 0.000 0.000 *2ND ORDER* 17. GAUSSIAN DISTRIBUTION 2. 2. *SOLO* 19. 209.44000 CM 5.00000 KG 209.440 CM *Z RO* 20. -30.00000 DEG 209.440 CM *TRANSFORM 1* 0.86602 2.00000 0.00000 0.00000 0.00000 0.00000 -0.12500 0.86602 0.00000 0.00000 0.00000 0.00000 0.00000 0.00000 0.86602 2.00000 0.00000 0.00000 0.00000 0.00000 -0.12500 0.86602 0.00000 0.00000 0.00000 0.00000 0.00000 0.00000 1.00000 0.00000 0.00000 0.00000 0.00000 0.00000 0.00000 1.00000 0*2ND ORDER TRANSFORM* 1 11 0.000E+00 1 12 0.000E+00 1 22 0.000E+00 1 13 0.000E+00 1 23 0.000E+00 1 33 0.000E+00 1 14 0.000E+00 1 24 0.000E+00 1 34 0.000E+00 1 44 0.000E+00 1 15 0.000E+00 1 25 0.000E+00 1 35 0.000E+00 1 45 0.000E+00 1 55 0.000E+00 1 16 2.618E-01 1 26 1.862E-01 1 36 -4.535E-01 1 46 -1.047E+00 1 56 0.000E+00 1 66 0.000E+00 2 11 0.000E+00 2 12 0.000E+00 2 22 0.000E+00 2 13 0.000E+00 2 23 0.000E+00 2 33 0.000E+00 2 14 0.000E+00 2 24 0.000E+00 2 34 0.000E+00 2 44 0.000E+00 2 15 0.000E+00 2 25 0.000E+00 2 35 0.000E+00 2 45 0.000E+00 2 55 0.000E+00 2 16 2.384E-01 2 26 2.618E-01 2 36 6.545E-02 2 46 -4.535E-01 2 56 0.000E+00 2 66 0.000E+00 3 11 0.000E+00 3 12 0.000E+00 3 22 0.000E+00 3 13 0.000E+00 3 23 0.000E+00 3 33 0.000E+00 3 14 0.000E+00 3 24 0.000E+00 3 34 0.000E+00 3 44 0.000E+00 3 15 0.000E+00 3 25 0.000E+00 3 35 0.000E+00 3 45 0.000E+00 3 55 0.000E+00 3 16 4.535E-01 3 26 1.047E+00 3 36 2.618E-01 3 46 1.862E-01 3 56 0.000E+00 3 66 0.000E+00 4 11 0.000E+00 4 12 0.000E+00 4 22 0.000E+00 4 13 0.000E+00 4 23 0.000E+00 4 33 0.000E+00 4 14 0.000E+00 4 24 0.000E+00 4 34 0.000E+00 4 44 0.000E+00 4 15 0.000E+00 4 25 0.000E+00 4 35 0.000E+00 4 45 0.000E+00 4 55 0.000E+00 4 16 -6.545E-02 4 26 4.535E-01 4 36 2.384E-01 4 46 2.618E-01 4 56 0.000E+00 4 66 0.000E+00 5 11 0.000E+00 5 12 0.000E+00 5 22 -1.047E+00 5 13 0.000E+00 5 23 0.000E+00 5 33 0.000E+00 5 14 0.000E+00 5 24 0.000E+00 5 34 0.000E+00 5 44 -1.047E+00 5 15 0.000E+00 5 25 0.000E+00 5 35 0.000E+00 5 45 0.000E+00 5 55 0.000E+00 5 16 0.000E+00 5 26 0.000E+00 5 36 0.000E+00 5 46 0.000E+00 5 56 0.000E+00 5 66 0.000E+00 0.000 39.652 M 0.000 17.419 R 0.879 0.000 27.058 M -0.208 0.111 0.000 15.460 R -0.631 -0.312 0.846 -35.605 39.805 M 0.000 0.000 0.000 0.000 0.000 7.000 N 0.000 0.000 0.000 0.000 0.000 0*LENGTH* 209.44000 CM 1 0"(13) N=1/2 BETA=1/4 42.43 DEGREE BEND NO FRINGE FIELDS NORM UNITS " 0 0 15. 1.00000 "N " 100.00000 ; 15. 2.00000 "R " 1000.00000 ; 15. 5.00000 "N " 100.00000 ; 15. 8.00000 "CM " 0.01000 ; 15. 11.00000 "MEV " 0.00100 ; 15. 6.00000 "N " 100.00000 ; 1.000000 2.00000 3.00000 4.00000 5.00000 6.00000 7.00000 299.79248; 13. 2.00000; 17. 2.00000 2.00000; 16.00 "BETA" 1.00000 0.25000; 4.000 74.05000 10.00000 0.50000; 13. 4.00000; 13. 1.00000; (THE N=1/2, 42.4265 DEGREE BENDING MAGNET IS CHOSEN AS A TEST CASE BECAUSE ) (KL = 30 DEGREES IS A CONVENIENT ANGLE. FRINGING FIELDS ARE LEFT OUT SO THAT ) (THE BENDING MAGNET MATRIX ELEMENTS MAY BE INDEPENDENTLY VERIFIED. BR= 10 KG-) (METERS, R = 1 METER AND NORMALIZED TRANSVERSE DIMENSIONS ARE USED. THE ) (RESULTS SHOULD AGREE WITH PAGES 57 - 60 OF SLAC 75. ) 0SENTINEL 0 13 ELEMENTS USED OUT OF A MAXIMUM ALLOWABLE 3129 49 NUMBERS USED OUT OF A MAXIMUM ALLOWABLE 13160 1(13) N=1/2 BETA=1/4 42.43 DEGREE BEND NO FRINGE FIELDS NORM UNITS *BEAM* 1. 299.79248 MEV 0.000 CM 0.000 2.000 N 0.000 3.000 R 0.000 0.000 4.000 N 0.000 0.000 0.000 5.000 R 0.000 0.000 0.000 0.000 6.000 N 0.000 0.000 0.000 0.000 0.000 7.000 N 0.000 0.000 0.000 0.000 0.000 *2ND ORDER* 17. GAUSSIAN DISTRIBUTION 2. 2. *EPS* 16. "BETA" 1. 0.25000E+00 *BEND* 4. 74.05000 CM 10.00000 KG 0.50000 ( 100.000 CM , 42.428 DEG ) 74.050 CM *TRANSFORM 1* 0.86602 0.70712 0.00000 0.00000 0.00000 0.26796 -0.35356 0.86602 0.00000 0.00000 0.00000 0.70712 0.00000 0.00000 0.86602 0.70712 0.00000 0.00000 0.00000 0.00000 -0.35356 0.86602 0.00000 0.00000 -0.70712 -0.26796 0.00000 0.00000 1.00000 -0.06675 0.00000 0.00000 0.00000 0.00000 0.00000 1.00000 0*2ND ORDER TRANSFORM* 1 11 -6.101E-02 1 12 6.440E-01 1 22 1.220E-01 1 13 0.000E+00 1 23 0.000E+00 1 33 -2.992E-03 1 14 0.000E+00 1 24 0.000E+00 1 34 3.158E-02 1 44 -1.280E-01 1 15 0.000E+00 1 25 0.000E+00 1 35 0.000E+00 1 45 0.000E+00 1 55 0.000E+00 1 16 3.749E-01 1 26 1.592E-01 1 36 0.000E+00 1 46 0.000E+00 1 56 0.000E+00 1 66 -2.379E-01 2 11 1.610E-01 2 12 1.220E-01 2 22 -3.220E-01 2 13 0.000E+00 2 23 0.000E+00 2 33 -1.579E-02 2 14 0.000E+00 2 24 0.000E+00 2 34 1.220E-01 2 44 -3.220E-01 2 15 0.000E+00 2 25 0.000E+00 2 35 0.000E+00 2 45 0.000E+00 2 55 0.000E+00 2 16 4.003E-01 2 26 -1.131E-01 2 36 0.000E+00 2 46 0.000E+00 2 56 0.000E+00 2 66 -7.374E-01 3 11 0.000E+00 3 12 0.000E+00 3 22 0.000E+00 3 13 -1.220E-01 3 23 -6.316E-02 3 33 0.000E+00 3 14 6.440E-01 3 24 2.440E-01 3 34 0.000E+00 3 44 0.000E+00 3 15 0.000E+00 3 25 0.000E+00 3 35 0.000E+00 3 45 0.000E+00 3 55 0.000E+00 3 16 0.000E+00 3 26 0.000E+00 3 36 1.131E-01 3 46 9.340E-02 3 56 0.000E+00 3 66 0.000E+00 4 11 0.000E+00 4 12 0.000E+00 4 22 0.000E+00 4 13 1.579E-02 4 23 5.984E-03 4 33 0.000E+00 4 14 -1.280E-01 4 24 -3.158E-02 4 34 0.000E+00 4 44 0.000E+00 4 15 0.000E+00 4 25 0.000E+00 4 35 0.000E+00 4 45 0.000E+00 4 55 0.000E+00 4 16 0.000E+00 4 26 0.000E+00 4 36 3.384E-01 4 46 1.251E-01 4 56 0.000E+00 4 66 0.000E+00 5 11 -2.245E-04 5 12 -1.310E-01 5 22 -3.698E-01 5 13 0.000E+00 5 23 0.000E+00 5 33 -1.557E-02 5 14 0.000E+00 5 24 0.000E+00 5 34 1.190E-01 5 44 -3.057E-01 5 15 0.000E+00 5 25 0.000E+00 5 35 0.000E+00 5 45 0.000E+00 5 55 0.000E+00 5 16 -3.202E-02 5 26 -2.801E-01 5 36 0.000E+00 5 46 0.000E+00 5 56 0.000E+00 5 66 -1.814E-03 -14.050 18.969 N -46.687 53.231 R 0.918 0.000 10.080 N 0.000 0.000 0.000 11.472 R 0.000 0.000 0.386 -11.311 14.802 N 0.054 0.206 0.000 0.000 0.000 7.000 N 0.099 0.093 0.000 0.000 -0.032 0*LENGTH* 74.05000 CM 1 0"(14) N=1/2 BETA= 0 42.43 DEGREE BEND NO FRINGE FIELDS NORM UNITS " 0 0 15. 1.00000 "N " 100.00000 ; 15. 2.00000 "R " 1000.00000 ; 15. 5.00000 "N " 100.00000 ; 15. 8.00000 "CM " 0.01000 ; 15. 11.00000 "MEV " 0.00100 ; 15. 6.00000 "N " 100.00000 ; 1.000000 2.00000 3.00000 4.00000 5.00000 6.00000 7.00000 299.79248; 13. 2.00000; 17. 2.00000 2.00000; 16.00 "BETA" 1.00000 0.00000; 4.000 74.05000 10.00000 0.50000; 13. 4.00000; 13. 1.00000; (THE BETA=0 CASE IS ADDED TO ALLOW A FURTHER CHECK ON THE BENDING MAGNET ) (MATRIX ELEMENTS USING THE N=1/2 THEOREMS LISTED ON PAGES 92 AND 93 OF SLAC 75 ) 0SENTINEL 0 13 ELEMENTS USED OUT OF A MAXIMUM ALLOWABLE 3129 49 NUMBERS USED OUT OF A MAXIMUM ALLOWABLE 13160 1(14) N=1/2 BETA= 0 42.43 DEGREE BEND NO FRINGE FIELDS NORM UNITS *BEAM* 1. 299.79248 MEV 0.000 CM 0.000 2.000 N 0.000 3.000 R 0.000 0.000 4.000 N 0.000 0.000 0.000 5.000 R 0.000 0.000 0.000 0.000 6.000 N 0.000 0.000 0.000 0.000 0.000 7.000 N 0.000 0.000 0.000 0.000 0.000 *2ND ORDER* 17. GAUSSIAN DISTRIBUTION 2. 2. *EPS* 16. "BETA" 1. 0.00000E+00 *BEND* 4. 74.05000 CM 10.00000 KG 0.50000 ( 100.000 CM , 42.428 DEG ) 74.050 CM *TRANSFORM 1* 0.86602 0.70712 0.00000 0.00000 0.00000 0.26796 -0.35356 0.86602 0.00000 0.00000 0.00000 0.70712 0.00000 0.00000 0.86602 0.70712 0.00000 0.00000 0.00000 0.00000 -0.35356 0.86602 0.00000 0.00000 -0.70712 -0.26796 0.00000 0.00000 1.00000 -0.06675 0.00000 0.00000 0.00000 0.00000 0.00000 1.00000 0*2ND ORDER TRANSFORM* 1 11 2.992E-03 1 12 6.755E-01 1 22 1.280E-01 1 13 0.000E+00 1 23 0.000E+00 1 33 -6.699E-02 1 14 0.000E+00 1 24 0.000E+00 1 34 0.000E+00 1 44 -1.340E-01 1 15 0.000E+00 1 25 0.000E+00 1 35 0.000E+00 1 45 0.000E+00 1 55 0.000E+00 1 16 3.808E-01 1 26 1.619E-01 1 36 0.000E+00 1 46 0.000E+00 1 56 0.000E+00 1 66 -2.375E-01 2 11 3.220E-01 2 12 2.440E-01 2 22 -2.904E-01 2 13 0.000E+00 2 23 0.000E+00 2 33 -1.768E-01 2 14 0.000E+00 2 24 0.000E+00 2 34 0.000E+00 2 44 -3.536E-01 2 15 0.000E+00 2 25 0.000E+00 2 35 0.000E+00 2 45 0.000E+00 2 55 0.000E+00 2 16 4.305E-01 2 26 -9.534E-02 2 36 0.000E+00 2 46 0.000E+00 2 56 0.000E+00 2 66 -7.347E-01 3 11 0.000E+00 3 12 0.000E+00 3 22 0.000E+00 3 13 -2.500E-01 3 23 -9.474E-02 3 33 0.000E+00 3 14 6.124E-01 3 24 2.321E-01 3 34 0.000E+00 3 44 0.000E+00 3 15 0.000E+00 3 25 0.000E+00 3 35 0.000E+00 3 45 0.000E+00 3 55 0.000E+00 3 16 0.000E+00 3 26 0.000E+00 3 36 1.073E-01 3 46 9.073E-02 3 56 0.000E+00 3 66 0.000E+00 4 11 0.000E+00 4 12 0.000E+00 4 22 0.000E+00 4 13 -3.062E-01 4 23 -1.160E-01 4 33 0.000E+00 4 14 -2.500E-01 4 24 -9.474E-02 4 34 0.000E+00 4 44 0.000E+00 4 15 0.000E+00 4 25 0.000E+00 4 35 0.000E+00 4 45 0.000E+00 4 55 0.000E+00 4 16 0.000E+00 4 26 0.000E+00 4 36 3.082E-01 4 46 1.073E-01 4 56 0.000E+00 4 66 0.000E+00 5 11 -1.646E-02 5 12 -1.370E-01 5 22 -3.707E-01 5 13 0.000E+00 5 23 0.000E+00 5 33 6.734E-04 5 14 0.000E+00 5 24 0.000E+00 5 34 1.250E-01 5 44 -3.048E-01 5 15 0.000E+00 5 25 0.000E+00 5 35 0.000E+00 5 45 0.000E+00 5 55 0.000E+00 5 16 -3.290E-02 5 26 -2.804E-01 5 36 0.000E+00 5 46 0.000E+00 5 56 0.000E+00 5 66 -1.849E-03 -14.897 19.125 N -48.993 53.436 R 0.922 0.000 9.926 N 0.000 0.000 0.000 11.204 R 0.000 0.000 0.310 -11.103 14.803 N 0.052 0.206 0.000 0.000 0.000 7.000 N 0.098 0.093 0.000 0.000 -0.032 0*LENGTH* 74.05000 CM 1 0"(15) N=1/2 BETA=1/4 30.0 DEGREE BEND NO FRINGE FIELDS NORM UNITS " 0 0 15. 1.00000 "M " 100.00000 ; 15. 2.00000 "R " 1000.00000 ; 15. 5.00000 "M " 100.00000 ; 15. 8.00000 "CM " 0.01000 ; 15. 11.00000 "MEV " 0.00100 ; 15. 6.00000 "N " 100.00000 ; 1.000000 2.00000 3.00000 4.00000 5.00000 6.00000 7.00000 299.79248; 13. 2.00000; 17. 2.00000 2.00000; 16.00 "BETA" 1.00000 0.25000; 4.000 52.36000 10.00000 0.50000; 13. 4.00000; 13. 1.00000; (IT IS IMPORTANT TO CHECK THAT ANY GIVEN COMPUTER CALCULATES THE CORRECT ) (RESULTS FOR BENDING MAGNETS OF ANGLES LESS THAN 0.2 RADIANS. THE FOLLOWING ) (TWO COMPUTATIONS ARE DESIGNED WITH THIS IN MIND. THE FIRST CALCULATION IS ) (A SINGLE STEP 30 DEGREE BENDING MAGNET AND THE SECOND COMPUTATION IS A TEN ) (STEP CALCULATION ADDING UP TO 30 DEGREES. OBVIOUSLY, THE RESULTS OF THE TWO ) (CALCULATIONS SHOULD AGREE. NORMALIZED DIMENSIONS ARE USED AND BR = 10 KG) (METERS. ) 0SENTINEL 0 13 ELEMENTS USED OUT OF A MAXIMUM ALLOWABLE 3129 49 NUMBERS USED OUT OF A MAXIMUM ALLOWABLE 13160 1(15) N=1/2 BETA=1/4 30.0 DEGREE BEND NO FRINGE FIELDS NORM UNITS *BEAM* 1. 299.79248 MEV 0.000 CM 0.000 2.000 M 0.000 3.000 R 0.000 0.000 4.000 M 0.000 0.000 0.000 5.000 R 0.000 0.000 0.000 0.000 6.000 M 0.000 0.000 0.000 0.000 0.000 7.000 N 0.000 0.000 0.000 0.000 0.000 *2ND ORDER* 17. GAUSSIAN DISTRIBUTION 2. 2. *EPS* 16. "BETA" 1. 0.25000E+00 *BEND* 4. 52.36000 CM 10.00000 KG 0.50000 ( 100.000 CM , 30.000 DEG ) 52.360 CM *TRANSFORM 1* 0.93224 0.51172 0.00000 0.00000 0.00000 0.13552 -0.25586 0.93224 0.00000 0.00000 0.00000 0.51172 0.00000 0.00000 0.93224 0.51172 0.00000 0.00000 0.00000 0.00000 -0.25586 0.93224 0.00000 0.00000 -0.51172 -0.13552 0.00000 0.00000 1.00000 -0.02376 0.00000 0.00000 0.00000 0.00000 0.00000 1.00000 0*2ND ORDER TRANSFORM* 1 11 -3.235E-02 1 12 4.886E-01 1 22 6.470E-02 1 13 0.000E+00 1 23 0.000E+00 1 33 -7.652E-04 1 14 0.000E+00 1 24 0.000E+00 1 34 1.156E-02 1 44 -6.623E-02 1 15 0.000E+00 1 25 0.000E+00 1 35 0.000E+00 1 45 0.000E+00 1 55 0.000E+00 1 16 1.964E-01 1 26 5.803E-02 1 36 0.000E+00 1 46 0.000E+00 1 56 0.000E+00 1 66 -1.278E-01 2 11 1.222E-01 2 12 6.470E-02 2 22 -2.443E-01 2 13 0.000E+00 2 23 0.000E+00 2 33 -5.779E-03 2 14 0.000E+00 2 24 0.000E+00 2 34 6.470E-02 2 44 -2.443E-01 2 15 0.000E+00 2 25 0.000E+00 2 35 0.000E+00 2 45 0.000E+00 2 55 0.000E+00 2 16 2.731E-01 2 26 -6.241E-02 2 36 0.000E+00 2 46 0.000E+00 2 56 0.000E+00 2 66 -5.230E-01 3 11 0.000E+00 3 12 0.000E+00 3 22 0.000E+00 3 13 -6.470E-02 3 23 -2.312E-02 3 33 0.000E+00 3 14 4.886E-01 3 24 1.294E-01 3 34 0.000E+00 3 44 0.000E+00 3 15 0.000E+00 3 25 0.000E+00 3 35 0.000E+00 3 45 0.000E+00 3 55 0.000E+00 3 16 0.000E+00 3 26 0.000E+00 3 36 6.241E-02 3 46 3.443E-02 3 56 0.000E+00 3 66 0.000E+00 4 11 0.000E+00 4 12 0.000E+00 4 22 0.000E+00 4 13 5.779E-03 4 23 1.530E-03 4 33 0.000E+00 4 14 -6.623E-02 4 24 -1.156E-02 4 34 0.000E+00 4 44 0.000E+00 4 15 0.000E+00 4 25 0.000E+00 4 35 0.000E+00 4 45 0.000E+00 4 55 0.000E+00 4 16 0.000E+00 4 26 0.000E+00 4 36 2.502E-01 4 46 6.547E-02 4 56 0.000E+00 4 66 0.000E+00 5 11 -4.033E-05 5 12 -6.699E-02 5 22 -2.617E-01 5 13 0.000E+00 5 23 0.000E+00 5 33 -5.739E-03 5 14 0.000E+00 5 24 0.000E+00 5 34 6.393E-02 5 44 -2.384E-01 5 15 0.000E+00 5 25 0.000E+00 5 35 0.000E+00 5 45 0.000E+00 5 55 0.000E+00 5 16 -1.164E-02 5 26 -1.386E-01 5 36 0.000E+00 5 46 0.000E+00 5 56 0.000E+00 5 66 -3.242E-04 -7.480 10.445 M -33.539 37.914 R 0.898 0.000 7.276 M 0.000 0.000 0.000 8.808 R 0.000 0.000 0.304 -8.424 11.389 M 0.081 0.203 0.000 0.000 0.000 7.000 N 0.091 0.094 0.000 0.000 -0.015 0*LENGTH* 52.36000 CM 1 0"(16) N=1/2 BETA=1/4 30.0 DEGREE BEND 10 STEPS NO FRINGE FIELDS " 0 0 15. 1.00000 "M " 100.00000 ; 15. 2.00000 "R " 1000.00000 ; 15. 5.00000 "M " 100.00000 ; 15. 8.00000 "CM " 0.01000 ; 15. 11.00000 "MEV " 0.00100 ; 15. 6.00000 "N " 100.00000 ; 1.000000 2.00000 3.00000 4.00000 5.00000 6.00000 7.00000 299.79248; 13. 2.00000; 17. 2.00000 2.00000; 16.00 "BETA" 1.00000 0.25000; 9. 10.00000; 4.000 5.23600 10.00000 0.50000; 9. 0.00000; 13. 4.00000; 13. 1.00000; (NOTE THE USE OF THE REPEAT ELEMENT TYPE CODE 9.0 IN SETTING UP THIS PROBLEM ) 0SENTINEL 0 15 ELEMENTS USED OUT OF A MAXIMUM ALLOWABLE 3129 53 NUMBERS USED OUT OF A MAXIMUM ALLOWABLE 13160 1(16) N=1/2 BETA=1/4 30.0 DEGREE BEND 10 STEPS NO FRINGE FIELDS *BEAM* 1. 299.79248 MEV 0.000 CM 0.000 2.000 M 0.000 3.000 R 0.000 0.000 4.000 M 0.000 0.000 0.000 5.000 R 0.000 0.000 0.000 0.000 6.000 M 0.000 0.000 0.000 0.000 0.000 7.000 N 0.000 0.000 0.000 0.000 0.000 *2ND ORDER* 17. GAUSSIAN DISTRIBUTION 2. 2. *EPS* 16. "BETA" 1. 0.25000E+00 *BEND* 4. 5.23600 CM 10.00000 KG 0.50000 ( 100.000 CM , 3.000 DEG ) 5.236 CM *BEND* 4. 5.23600 CM 10.00000 KG 0.50000 ( 100.000 CM , 3.000 DEG ) 10.472 CM *BEND* 4. 5.23600 CM 10.00000 KG 0.50000 ( 100.000 CM , 3.000 DEG ) 15.708 CM *BEND* 4. 5.23600 CM 10.00000 KG 0.50000 ( 100.000 CM , 3.000 DEG ) 20.944 CM *BEND* 4. 5.23600 CM 10.00000 KG 0.50000 ( 100.000 CM , 3.000 DEG ) 26.180 CM *BEND* 4. 5.23600 CM 10.00000 KG 0.50000 ( 100.000 CM , 3.000 DEG ) 31.416 CM *BEND* 4. 5.23600 CM 10.00000 KG 0.50000 ( 100.000 CM , 3.000 DEG ) 36.652 CM *BEND* 4. 5.23600 CM 10.00000 KG 0.50000 ( 100.000 CM , 3.000 DEG ) 41.888 CM *BEND* 4. 5.23600 CM 10.00000 KG 0.50000 ( 100.000 CM , 3.000 DEG ) 47.124 CM *BEND* 4. 5.23600 CM 10.00000 KG 0.50000 ( 100.000 CM , 3.000 DEG ) 52.360 CM *TRANSFORM 1* 0.93224 0.51172 0.00000 0.00000 0.00000 0.13552 -0.25586 0.93224 0.00000 0.00000 0.00000 0.51172 0.00000 0.00000 0.93224 0.51172 0.00000 0.00000 0.00000 0.00000 -0.25586 0.93224 0.00000 0.00000 -0.51172 -0.13552 0.00000 0.00000 1.00000 -0.02376 0.00000 0.00000 0.00000 0.00000 0.00000 1.00000 0*2ND ORDER TRANSFORM* 1 11 -3.235E-02 1 12 4.886E-01 1 22 6.470E-02 1 13 0.000E+00 1 23 0.000E+00 1 33 -7.652E-04 1 14 0.000E+00 1 24 0.000E+00 1 34 1.156E-02 1 44 -6.623E-02 1 15 0.000E+00 1 25 0.000E+00 1 35 0.000E+00 1 45 0.000E+00 1 55 0.000E+00 1 16 1.964E-01 1 26 5.803E-02 1 36 0.000E+00 1 46 0.000E+00 1 56 0.000E+00 1 66 -1.278E-01 2 11 1.222E-01 2 12 6.470E-02 2 22 -2.443E-01 2 13 0.000E+00 2 23 0.000E+00 2 33 -5.779E-03 2 14 0.000E+00 2 24 0.000E+00 2 34 6.470E-02 2 44 -2.443E-01 2 15 0.000E+00 2 25 0.000E+00 2 35 0.000E+00 2 45 0.000E+00 2 55 0.000E+00 2 16 2.731E-01 2 26 -6.241E-02 2 36 0.000E+00 2 46 0.000E+00 2 56 0.000E+00 2 66 -5.230E-01 3 11 0.000E+00 3 12 0.000E+00 3 22 0.000E+00 3 13 -6.470E-02 3 23 -2.312E-02 3 33 0.000E+00 3 14 4.886E-01 3 24 1.294E-01 3 34 0.000E+00 3 44 0.000E+00 3 15 0.000E+00 3 25 0.000E+00 3 35 0.000E+00 3 45 0.000E+00 3 55 0.000E+00 3 16 0.000E+00 3 26 0.000E+00 3 36 6.241E-02 3 46 3.443E-02 3 56 0.000E+00 3 66 0.000E+00 4 11 0.000E+00 4 12 0.000E+00 4 22 0.000E+00 4 13 5.779E-03 4 23 1.530E-03 4 33 0.000E+00 4 14 -6.623E-02 4 24 -1.156E-02 4 34 0.000E+00 4 44 0.000E+00 4 15 0.000E+00 4 25 0.000E+00 4 35 0.000E+00 4 45 0.000E+00 4 55 0.000E+00 4 16 0.000E+00 4 26 0.000E+00 4 36 2.502E-01 4 46 6.547E-02 4 56 0.000E+00 4 66 0.000E+00 5 11 -4.031E-05 5 12 -6.699E-02 5 22 -2.617E-01 5 13 0.000E+00 5 23 0.000E+00 5 33 -5.739E-03 5 14 0.000E+00 5 24 0.000E+00 5 34 6.393E-02 5 44 -2.384E-01 5 15 0.000E+00 5 25 0.000E+00 5 35 0.000E+00 5 45 0.000E+00 5 55 0.000E+00 5 16 -1.164E-02 5 26 -1.386E-01 5 36 0.000E+00 5 46 0.000E+00 5 56 0.000E+00 5 66 -3.241E-04 -7.480 10.445 M -33.539 37.914 R 0.898 0.000 7.276 M 0.000 0.000 0.000 8.808 R 0.000 0.000 0.304 -8.424 11.389 M 0.081 0.203 0.000 0.000 0.000 7.000 N 0.091 0.094 0.000 0.000 -0.015 0*LENGTH* 52.36000 CM 1 0"(17) N=1/4 BETA=1/4 30.0 DEGREE BEND NO FRINGE FIELDS NORM UNITS " 0 0 15. 1.00000 "M " 100.00000 ; 15. 2.00000 "R " 1000.00000 ; 15. 5.00000 "M " 100.00000 ; 15. 8.00000 "CM " 0.01000 ; 15. 11.00000 "MEV " 0.00100 ; 15. 6.00000 "N " 100.00000 ; 1.000000 2.00000 3.00000 4.00000 5.00000 6.00000 7.00000 299.79248; 13. 2.00000; 17. 2.00000 2.00000; 16.00 "BETA" 1.00000 0.25000; 4.000 52.36000 10.00000 0.25000; 13. 4.00000; 13. 1.00000; (THIS CALCULATION IS INCLUDED SO AS TO HAVE A BENDING MAGNET CASE WHERE N ) (NEITHER EQUALS ZERO NOR 1/2. NORMALIZED UNITS ARE USED AND BR = 10 KG METERS) 0SENTINEL 0 13 ELEMENTS USED OUT OF A MAXIMUM ALLOWABLE 3129 49 NUMBERS USED OUT OF A MAXIMUM ALLOWABLE 13160 1(17) N=1/4 BETA=1/4 30.0 DEGREE BEND NO FRINGE FIELDS NORM UNITS *BEAM* 1. 299.79248 MEV 0.000 CM 0.000 2.000 M 0.000 3.000 R 0.000 0.000 4.000 M 0.000 0.000 0.000 5.000 R 0.000 0.000 0.000 0.000 6.000 M 0.000 0.000 0.000 0.000 0.000 7.000 N 0.000 0.000 0.000 0.000 0.000 *2ND ORDER* 17. GAUSSIAN DISTRIBUTION 2. 2. *EPS* 16. "BETA" 1. 0.25000E+00 *BEND* 4. 52.36000 CM 10.00000 KG 0.25000 ( 100.000 CM , 30.000 DEG ) 52.360 CM *TRANSFORM 1* 0.89894 0.50584 0.00000 0.00000 0.00000 0.13475 -0.37938 0.89894 0.00000 0.00000 0.00000 0.50584 0.00000 0.00000 0.96593 0.51764 0.00000 0.00000 0.00000 0.00000 -0.12941 0.96593 0.00000 0.00000 -0.50584 -0.13475 0.00000 0.00000 1.00000 -0.02368 0.00000 0.00000 0.00000 0.00000 0.00000 1.00000 0*2ND ORDER TRANSFORM* 1 11 -9.595E-02 1 12 4.547E-01 1 22 6.056E-02 1 13 0.000E+00 1 23 0.000E+00 1 33 1.646E-02 1 14 0.000E+00 1 24 0.000E+00 1 34 1.168E-02 1 44 -6.583E-02 1 15 0.000E+00 1 25 0.000E+00 1 35 0.000E+00 1 45 0.000E+00 1 55 0.000E+00 1 16 2.228E-01 1 26 6.230E-02 1 36 0.000E+00 1 46 0.000E+00 1 56 0.000E+00 1 66 -1.264E-01 2 11 -2.980E-08 2 12 2.980E-08 2 22 -2.529E-01 2 13 0.000E+00 2 23 0.000E+00 2 33 6.031E-02 2 14 0.000E+00 2 24 0.000E+00 2 34 6.583E-02 2 44 -2.412E-01 2 15 0.000E+00 2 25 0.000E+00 2 35 0.000E+00 2 45 0.000E+00 2 55 0.000E+00 2 16 3.838E-01 2 26 -3.311E-02 2 36 0.000E+00 2 46 0.000E+00 2 56 0.000E+00 2 66 -5.117E-01 3 11 0.000E+00 3 12 0.000E+00 3 22 0.000E+00 3 13 1.151E-03 3 23 -5.759E-03 3 33 0.000E+00 3 14 5.001E-01 3 24 1.332E-01 3 34 0.000E+00 3 44 0.000E+00 3 15 0.000E+00 3 25 0.000E+00 3 35 0.000E+00 3 45 0.000E+00 3 55 0.000E+00 3 16 0.000E+00 3 26 0.000E+00 3 36 3.235E-02 3 46 2.930E-02 3 56 0.000E+00 3 66 0.000E+00 4 11 0.000E+00 4 12 0.000E+00 4 22 0.000E+00 4 13 1.250E-01 4 23 3.331E-02 4 33 0.000E+00 4 14 -1.150E-03 4 24 5.759E-03 4 34 0.000E+00 4 44 0.000E+00 4 15 0.000E+00 4 25 0.000E+00 4 35 0.000E+00 4 45 0.000E+00 4 55 0.000E+00 4 16 0.000E+00 4 26 0.000E+00 4 36 1.338E-01 4 46 3.541E-02 4 56 0.000E+00 4 66 0.000E+00 5 11 4.305E-03 5 12 -3.198E-02 5 22 -2.557E-01 5 13 0.000E+00 5 23 0.000E+00 5 33 -4.394E-03 5 14 0.000E+00 5 24 0.000E+00 5 34 3.195E-02 5 44 -2.442E-01 5 15 0.000E+00 5 25 0.000E+00 5 35 0.000E+00 5 45 0.000E+00 5 55 0.000E+00 5 16 -5.621E-03 5 26 -1.362E-01 5 36 0.000E+00 5 46 0.000E+00 5 56 0.000E+00 5 66 -1.588E-04 -7.417 10.420 M -32.416 37.333 R 0.902 0.000 7.246 M 0.000 0.000 0.000 6.350 R 0.000 0.000 0.332 -8.468 11.446 M 0.090 0.201 0.000 0.000 0.000 7.000 N 0.091 0.095 0.000 0.000 -0.014 0*LENGTH* 52.36000 CM 1 0"(18) N=1/2 BETA=1/4 84.85 DEGREE BEND WITH FRINGE FIELDS NORM UNIT " 0 0 15. 1.00000 "M " 100.00000 ; 15. 2.00000 "R " 1000.00000 ; 15. 5.00000 "M " 100.00000 ; 15. 8.00000 "CM " 0.01000 ; 15. 11.00000 "MEV " 0.00100 ; 15. 6.00000 "N " 100.00000 ; 1.000000 2.00000 3.00000 4.00000 5.00000 6.00000 7.00000 299.79248; 13. 2.00000; 17. 2.00000 2.00000; 16.00 "BETA" 1.00000 0.25000; 3.0 244.93999; 2.0 0.00000; 4.000 148.10001 10.00000 0.50000; 2.0 0.00000; 3.0 244.93999; 13. 4.00000; 13. 1.00000; (THE FOLLOWING THREE CASES ARE INCLUDED BECAUSE THEY ARE COMPOSITE SYSTEMS ) (INCLUDING FRINGING FIELDS, DRIFT DISTANCES AND VARIOUS SECOND-ORDER ) (CORRECTIONS. NORMALIZED UNITS ARE USED IN ALL CASES AND BR = 10 KG METERS. ) (NOTE THAT, TO INCLUDE THE FRINGING FIELD MATRIX ELEMENTS IN THE CALCULATION ) (THE 2. ELEMENTS MUST BE ADDED TO THE PROGRAM LISTING EVEN IF THE ROTATION ) (ANGLE OF THE ENTRANCE AND/OR EXIT POLE FACE IS ZERO. THUS, IN THE FOLLOWING ) (CALCULATION, 2. 0. ELEMENTS ARE ADDED BEFORE AND AFTER THE 4.0 BENDING ) (MAGNET ENTRY. ) 0SENTINEL 0 17 ELEMENTS USED OUT OF A MAXIMUM ALLOWABLE 3129 57 NUMBERS USED OUT OF A MAXIMUM ALLOWABLE 13160 1(18) N=1/2 BETA=1/4 84.85 DEGREE BEND WITH FRINGE FIELDS NORM UNIT *BEAM* 1. 299.79248 MEV 0.000 CM 0.000 2.000 M 0.000 3.000 R 0.000 0.000 4.000 M 0.000 0.000 0.000 5.000 R 0.000 0.000 0.000 0.000 6.000 M 0.000 0.000 0.000 0.000 0.000 7.000 N 0.000 0.000 0.000 0.000 0.000 *2ND ORDER* 17. GAUSSIAN DISTRIBUTION 2. 2. *EPS* 16. "BETA" 1. 0.25000E+00 *DRIFT* 3. 244.93997 CM 244.940 CM *ROTAT* 2. 0.00000 DEG 244.940 CM *BEND* 4. 148.10001 CM 10.00000 KG 0.50000 ( 100.000 CM , 84.855 DEG ) 393.040 CM *ROTAT* 2. 0.00000 DEG 393.040 CM *DRIFT* 3. 244.93997 CM 637.980 CM *TRANSFORM 1* -0.99999 0.00002 0.00000 0.00000 0.00000 3.99999 -0.61238 -0.99999 0.00000 0.00000 0.00000 1.22476 0.00000 0.00000 -0.99999 0.00002 0.00000 0.00000 0.00000 0.00000 -0.61238 -0.99999 0.00000 0.00000 -1.22476 -3.99999 0.00000 0.00000 1.00000 -0.51247 0.00000 0.00000 0.00000 0.00000 0.00000 1.00000 0*2ND ORDER TRANSFORM* 1 11 3.333E-01 1 12 3.266E+00 1 22 5.333E+00 1 13 0.000E+00 1 23 0.000E+00 1 33 -9.167E-01 1 14 0.000E+00 1 24 0.000E+00 1 34 -4.082E+00 1 44 -6.666E+00 1 15 0.000E+00 1 25 0.000E+00 1 35 0.000E+00 1 45 0.000E+00 1 55 0.000E+00 1 16 3.324E+00 1 26 8.677E+00 1 36 0.000E+00 1 46 0.000E+00 1 56 0.000E+00 1 66 -3.980E+00 2 11 2.041E-01 2 12 1.333E+00 2 22 1.633E+00 2 13 0.000E+00 2 23 0.000E+00 2 33 -4.083E-01 2 14 0.000E+00 2 24 0.000E+00 2 34 -1.667E+00 2 44 -2.041E+00 2 15 0.000E+00 2 25 0.000E+00 2 35 0.000E+00 2 45 0.000E+00 2 55 0.000E+00 2 16 8.996E-01 2 26 1.990E+00 2 36 0.000E+00 2 46 0.000E+00 2 56 0.000E+00 2 66 -1.391E+00 3 11 0.000E+00 3 12 0.000E+00 3 22 0.000E+00 3 13 -8.333E-01 3 23 -4.082E+00 3 33 0.000E+00 3 14 -4.082E+00 3 24 -1.333E+01 3 34 0.000E+00 3 44 0.000E+00 3 15 0.000E+00 3 25 0.000E+00 3 35 0.000E+00 3 45 0.000E+00 3 55 0.000E+00 3 16 0.000E+00 3 26 0.000E+00 3 36 3.010E+00 3 46 1.255E+01 3 56 0.000E+00 3 66 0.000E+00 4 11 0.000E+00 4 12 0.000E+00 4 22 0.000E+00 4 13 -2.041E-01 4 23 -6.666E-01 4 33 0.000E+00 4 14 -1.667E+00 4 24 -4.082E+00 4 34 0.000E+00 4 44 0.000E+00 4 15 0.000E+00 4 25 0.000E+00 4 35 0.000E+00 4 45 0.000E+00 4 55 0.000E+00 4 16 0.000E+00 4 26 0.000E+00 4 36 1.142E+00 4 46 4.676E+00 4 56 0.000E+00 4 66 0.000E+00 5 11 -4.658E-01 5 12 -1.990E+00 5 22 -4.339E+00 5 13 0.000E+00 5 23 0.000E+00 5 33 -1.167E+00 5 14 0.000E+00 5 24 0.000E+00 5 34 -4.676E+00 5 44 -6.275E+00 5 15 0.000E+00 5 25 0.000E+00 5 35 0.000E+00 5 45 0.000E+00 5 55 0.000E+00 5 16 1.621E+00 5 26 1.294E+00 5 36 0.000E+00 5 46 0.000E+00 5 56 0.000E+00 5 66 -1.891E+00 -327.033 424.121 M -110.202 134.836 R 0.988 0.000 494.157 M 0.000 0.000 0.000 178.705 R 0.000 0.000 0.996 -309.147 283.725 M 0.819 0.841 0.000 0.000 0.000 7.000 N 0.066 0.064 0.000 0.000 -0.013 0*LENGTH* 637.97998 CM 1 0"(19) N=0 90 DEGREE BEND WITH FRINGE FIELDS NORMALIZED UNITS " 0 0 15. 1.00000 "M " 100.00000 ; 15. 2.00000 "R " 1000.00000 ; 15. 5.00000 "M " 100.00000 ; 15. 8.00000 "CM " 0.01000 ; 15. 11.00000 "MEV " 0.00100 ; 15. 6.00000 "N " 100.00000 ; 1.000000 2.00000 3.00000 4.00000 5.00000 6.00000 7.00000 299.79248; 13. 2.00000; 17. 2.00000 2.00000; 16.00 "G/2 " 5.00000 0.03333; 16.00 "K1 " 7.00000 0.46000; 16.00 "K2 " 8.00000 2.75000; 16.00 "1/R1" 12.00000 0.00358; 16.00 "1/R2" 13.00000 0.00358; 3.0 210.59799; 2.0 27.71000; 4.000 157.08000 10.00000 0.00000; 2.0 27.71000; 3.0 210.59799; 13. 4.00000; 13. 1.00000; 0SENTINEL 0 21 ELEMENTS USED OUT OF A MAXIMUM ALLOWABLE 3129 69 NUMBERS USED OUT OF A MAXIMUM ALLOWABLE 13160 1(19) N=0 90 DEGREE BEND WITH FRINGE FIELDS NORMALIZED UNITS *BEAM* 1. 299.79248 MEV 0.000 CM 0.000 2.000 M 0.000 3.000 R 0.000 0.000 4.000 M 0.000 0.000 0.000 5.000 R 0.000 0.000 0.000 0.000 6.000 M 0.000 0.000 0.000 0.000 0.000 7.000 N 0.000 0.000 0.000 0.000 0.000 *2ND ORDER* 17. GAUSSIAN DISTRIBUTION 2. 2. * G/2 * 16. "G/2 " 5. 0.33333E-01 * K1 * 16. "K1 " 7. 0.46000E+00 * K2 * 16. "K2 " 8. 0.27500E+01 * 1/R1 * 16. "1/R1" 12. 0.35800E-02 * 1/R2 * 16. "1/R2" 13. 0.35800E-02 *DRIFT* 3. 210.59799 CM 210.598 CM *ROTAT* 2. 27.71000 DEG 279.32959 CM 210.598 CM *BEND* 4. 157.08000 CM 10.00000 KG 0.00000 ( 100.000 CM , 90.000 DEG ) 367.678 CM *ROTAT* 2. 27.71000 DEG 279.32959 CM 367.678 CM *DRIFT* 3. 210.59799 CM 578.276 CM *TRANSFORM 1* -0.99978 0.00062 0.00000 0.00000 0.00000 4.21212 -0.72413 -0.99978 0.00000 0.00000 0.00000 1.52524 0.00000 0.00000 -1.00017 -0.00056 0.00000 0.00000 0.00000 0.00000 -0.59554 -1.00017 0.00000 0.00000 -1.52524 -4.21212 0.00000 0.00000 1.00000 -0.57080 0.00000 0.00000 0.00000 0.00000 0.00000 1.00000 0*2ND ORDER TRANSFORM* 1 11 -5.878E-02 1 12 3.636E-01 1 22 5.021E-01 1 13 0.000E+00 1 23 0.000E+00 1 33 -1.660E+00 1 14 0.000E+00 1 24 0.000E+00 1 34 -6.921E+00 1 44 -1.170E+01 1 15 0.000E+00 1 25 0.000E+00 1 35 0.000E+00 1 45 0.000E+00 1 55 0.000E+00 1 16 4.462E+00 1 26 1.087E+01 1 36 0.000E+00 1 46 0.000E+00 1 56 0.000E+00 1 66 -4.318E+00 2 11 6.895E-02 2 12 3.808E-01 2 22 1.817E-01 2 13 0.000E+00 2 23 0.000E+00 2 33 -7.860E-01 2 14 0.000E+00 2 24 0.000E+00 2 34 -3.130E+00 2 44 -4.251E+00 2 15 0.000E+00 2 25 0.000E+00 2 35 0.000E+00 2 45 0.000E+00 2 55 0.000E+00 2 16 1.575E+00 2 26 3.413E+00 2 36 0.000E+00 2 46 0.000E+00 2 56 0.000E+00 2 66 -1.878E+00 3 11 0.000E+00 3 12 0.000E+00 3 22 0.000E+00 3 13 -1.907E+00 3 23 -6.967E+00 3 33 0.000E+00 3 14 -8.473E+00 3 24 -2.340E+01 3 34 0.000E+00 3 44 0.000E+00 3 15 0.000E+00 3 25 0.000E+00 3 35 0.000E+00 3 45 0.000E+00 3 55 0.000E+00 3 16 0.000E+00 3 26 0.000E+00 3 36 1.806E+00 3 46 1.042E+01 3 56 0.000E+00 3 66 0.000E+00 4 11 0.000E+00 4 12 0.000E+00 4 22 0.000E+00 4 13 -2.904E-01 4 23 -8.020E-01 4 33 0.000E+00 4 14 -3.138E+00 4 24 -6.967E+00 4 34 0.000E+00 4 44 0.000E+00 4 15 0.000E+00 4 25 0.000E+00 4 35 0.000E+00 4 45 0.000E+00 4 55 0.000E+00 4 16 0.000E+00 4 26 0.000E+00 4 36 6.278E-01 4 46 4.398E+00 4 56 0.000E+00 4 66 0.000E+00 5 11 -8.101E-01 5 12 -3.412E+00 5 22 -5.437E+00 5 13 0.000E+00 5 23 0.000E+00 5 33 -1.274E+00 5 14 0.000E+00 5 24 0.000E+00 5 34 -4.295E+00 5 44 -5.018E+00 5 15 0.000E+00 5 25 0.000E+00 5 35 0.000E+00 5 45 0.000E+00 5 55 0.000E+00 5 16 2.326E+00 5 26 2.211E+00 5 36 0.000E+00 5 46 0.000E+00 5 56 0.000E+00 5 66 -2.450E+00 -526.324 581.513 M -208.980 222.545 R 0.993 0.000 522.651 M 0.000 0.000 0.000 189.845 R 0.000 0.000 0.980 -318.031 277.790 M 0.924 0.946 0.000 0.000 0.000 7.000 N 0.051 0.048 0.000 0.000 -0.014 0*LENGTH* 578.27600 CM 1 0"(20) N=1/2 BETA= 0 169.7 DEGREE BEND WITH FRINGE FIELDS NORM UNIT " 0 0 15. 1.00000 "M " 100.00000 ; 15. 2.00000 "R " 1000.00000 ; 15. 5.00000 "M " 100.00000 ; 15. 8.00000 "CM " 0.01000 ; 15. 11.00000 "MEV " 0.00100 ; 15. 6.00000 "N " 100.00000 ; 1.000000 2.00000 3.00000 4.00000 5.00000 6.00000 7.00000 299.79248; 13. 2.00000; 17. 2.00000 2.00000; 16.00 "BETA" 1.00000 0.00000; 3.0 81.65000; 2.0 0.00000; 4.000 296.19000 10.00000 0.50000; 2.0 0.00000; 3.0 81.65000; 13. 4.00000; 13. 1.00000; 0SENTINEL 0 17 ELEMENTS USED OUT OF A MAXIMUM ALLOWABLE 3129 57 NUMBERS USED OUT OF A MAXIMUM ALLOWABLE 13160 1(20) N=1/2 BETA= 0 169.7 DEGREE BEND WITH FRINGE FIELDS NORM UNIT *BEAM* 1. 299.79248 MEV 0.000 CM 0.000 2.000 M 0.000 3.000 R 0.000 0.000 4.000 M 0.000 0.000 0.000 5.000 R 0.000 0.000 0.000 0.000 6.000 M 0.000 0.000 0.000 0.000 0.000 7.000 N 0.000 0.000 0.000 0.000 0.000 *2ND ORDER* 17. GAUSSIAN DISTRIBUTION 2. 2. *EPS* 16. "BETA" 1. 0.00000E+00 *DRIFT* 3. 81.65000 CM 81.650 CM *ROTAT* 2. 0.00000 DEG 81.650 CM *BEND* 4. 296.19000 CM 10.00000 KG 0.50000 ( 100.000 CM , 169.704 DEG ) 377.840 CM *ROTAT* 2. 0.00000 DEG 377.840 CM *DRIFT* 3. 81.65000 CM 459.490 CM *TRANSFORM 1* -0.99999 0.00002 0.00000 0.00000 0.00000 3.99999 -0.61238 -0.99999 0.00000 0.00000 0.00000 1.22476 0.00000 0.00000 -0.99999 0.00002 0.00000 0.00000 0.00000 0.00000 -0.61238 -0.99999 0.00000 0.00000 -1.22476 -3.99999 0.00000 0.00000 1.00000 -3.47429 0.00000 0.00000 0.00000 0.00000 0.00000 1.00000 0*2ND ORDER TRANSFORM* 1 11 3.750E-01 1 12 1.225E+00 1 22 2.000E+00 1 13 0.000E+00 1 23 0.000E+00 1 33 -1.625E+00 1 14 0.000E+00 1 24 0.000E+00 1 34 -2.041E+00 1 44 -3.333E+00 1 15 0.000E+00 1 25 0.000E+00 1 35 0.000E+00 1 45 0.000E+00 1 55 0.000E+00 1 16 2.064E+00 1 26 9.190E+00 1 36 0.000E+00 1 46 0.000E+00 1 56 0.000E+00 1 66 2.372E+00 2 11 5.543E-06 2 12 3.623E-05 2 22 6.124E-01 2 13 0.000E+00 2 23 0.000E+00 2 33 -6.124E-01 2 14 0.000E+00 2 24 0.000E+00 2 34 -1.000E+00 2 44 -1.021E+00 2 15 0.000E+00 2 25 0.000E+00 2 35 0.000E+00 2 45 0.000E+00 2 55 0.000E+00 2 16 1.033E+00 2 26 3.564E+00 2 36 0.000E+00 2 46 0.000E+00 2 56 0.000E+00 2 66 3.843E-01 3 11 0.000E+00 3 12 0.000E+00 3 22 0.000E+00 3 13 -2.500E-01 3 23 -2.041E+00 3 33 0.000E+00 3 14 -2.041E+00 3 24 -6.667E+00 3 34 0.000E+00 3 44 0.000E+00 3 15 0.000E+00 3 25 0.000E+00 3 35 0.000E+00 3 45 0.000E+00 3 55 0.000E+00 3 16 0.000E+00 3 26 0.000E+00 3 36 -1.064E+00 3 46 -1.025E+00 3 56 0.000E+00 3 66 0.000E+00 4 11 0.000E+00 4 12 0.000E+00 4 22 0.000E+00 4 13 6.124E-01 4 23 2.000E+00 4 33 0.000E+00 4 14 -1.000E+00 4 24 -2.041E+00 4 34 0.000E+00 4 44 0.000E+00 4 15 0.000E+00 4 25 0.000E+00 4 35 0.000E+00 4 45 0.000E+00 4 55 0.000E+00 4 16 0.000E+00 4 26 0.000E+00 4 36 1.921E-01 4 46 4.362E-01 4 56 0.000E+00 4 66 0.000E+00 5 11 -8.811E-01 5 12 -3.564E+00 5 22 -4.595E+00 5 13 0.000E+00 5 23 0.000E+00 5 33 -3.437E-01 5 14 0.000E+00 5 24 0.000E+00 5 34 -4.362E-01 5 44 5.124E-01 5 15 0.000E+00 5 25 0.000E+00 5 35 0.000E+00 5 45 0.000E+00 5 55 0.000E+00 5 16 -5.342E-01 5 26 -5.745E+00 5 36 0.000E+00 5 46 0.000E+00 5 56 0.000E+00 5 66 -2.356E+00 26.407 288.971 M -10.974 92.509 R 0.945 0.000 114.937 M 0.000 0.000 0.000 43.939 R 0.000 0.000 0.390 -153.005 215.420 M -0.870 -0.727 0.000 0.000 0.000 7.000 N 0.097 0.093 0.000 0.000 -0.113 0*LENGTH* 459.49002 CM 1 0"(21) N=1/2 BETA=1/4 169.7 DEGREE BEND WITH FRINGE FIELDS NORM UNIT " 0 0 15. 1.00000 "M " 100.00000 ; 15. 2.00000 "R " 1000.00000 ; 15. 5.00000 "M " 100.00000 ; 15. 8.00000 "CM " 0.01000 ; 15. 11.00000 "MEV " 0.00100 ; 15. 6.00000 "N " 100.00000 ; 1.000000 2.00000 3.00000 4.00000 5.00000 6.00000 7.00000 299.79248; 13. 2.00000; 17. 2.00000 2.00000; 16.00 "BETA" 1.00000 0.25000; 3.0 81.65000; 2.0 0.00000; 4.000 296.19000 10.00000 0.50000; 2.0 0.00000; 3.0 81.65000; 13. 4.00000; 16.00 15.00000 56.60000; 3.0 0.00000; 13. 4.00000; 16.00 15.00000 -56.60000; 3.0 0.00000; 16.00 15.00000 0.00000; 16.00 15.00000 27.70000; 3.0 0.00000; 13. 4.00000; 16.00 15.00000 0.00000; 13. 1.00000; (THE 16. 15. ALPHA. TYPE CODE IS USED IN THIS EXAMPLE TO ROTATE TO THE X AND ) (Y FOCAL PLANES. THE X FOCAL PLANE CORRESPONDS TO THE ANGLE FOR WHICH THE) (126 MATRIX ELEMENT = 0 ; THE Y FOCAL PLANE CORRESPONDS TO THE ANGLE FOR ) (WHICH THE 346 MATRIX ELEMENT = 0. ) 0SENTINEL 0 27 ELEMENTS USED OUT OF A MAXIMUM ALLOWABLE 3129 82 NUMBERS USED OUT OF A MAXIMUM ALLOWABLE 13160 1(21) N=1/2 BETA=1/4 169.7 DEGREE BEND WITH FRINGE FIELDS NORM UNIT *BEAM* 1. 299.79248 MEV 0.000 CM 0.000 2.000 M 0.000 3.000 R 0.000 0.000 4.000 M 0.000 0.000 0.000 5.000 R 0.000 0.000 0.000 0.000 6.000 M 0.000 0.000 0.000 0.000 0.000 7.000 N 0.000 0.000 0.000 0.000 0.000 *2ND ORDER* 17. GAUSSIAN DISTRIBUTION 2. 2. *EPS* 16. "BETA" 1. 0.25000E+00 *DRIFT* 3. 81.65000 CM 81.650 CM *ROTAT* 2. 0.00000 DEG 81.650 CM *BEND* 4. 296.19000 CM 10.00000 KG 0.50000 ( 100.000 CM , 169.704 DEG ) 377.840 CM *ROTAT* 2. 0.00000 DEG 377.840 CM *DRIFT* 3. 81.65000 CM 459.490 CM *TRANSFORM 1* -0.99999 0.00002 0.00000 0.00000 0.00000 3.99999 -0.61238 -0.99999 0.00000 0.00000 0.00000 1.22476 0.00000 0.00000 -0.99999 0.00002 0.00000 0.00000 0.00000 0.00000 -0.61238 -0.99999 0.00000 0.00000 -1.22476 -3.99999 0.00000 0.00000 1.00000 -3.47429 0.00000 0.00000 0.00000 0.00000 0.00000 1.00000 0*2ND ORDER TRANSFORM* 1 11 -4.621E-06 1 12 1.440E-05 1 22 2.358E-05 1 13 0.000E+00 1 23 0.000E+00 1 33 -1.250E+00 1 14 0.000E+00 1 24 0.000E+00 1 34 -8.165E-01 1 44 -1.333E+00 1 15 0.000E+00 1 25 0.000E+00 1 35 0.000E+00 1 45 0.000E+00 1 55 0.000E+00 1 16 1.855E+00 1 26 6.057E+00 1 36 0.000E+00 1 46 0.000E+00 1 56 0.000E+00 1 66 2.907E-01 2 11 2.772E-06 2 12 1.812E-05 2 22 7.222E-06 2 13 0.000E+00 2 23 0.000E+00 2 33 -6.124E-01 2 14 0.000E+00 2 24 0.000E+00 2 34 -1.000E+00 2 44 -4.082E-01 2 15 0.000E+00 2 25 0.000E+00 2 35 0.000E+00 2 45 0.000E+00 2 55 0.000E+00 2 16 1.161E+00 2 26 1.855E+00 2 36 0.000E+00 2 46 0.000E+00 2 56 0.000E+00 2 66 -1.097E+00 3 11 0.000E+00 3 12 0.000E+00 3 22 0.000E+00 3 13 5.000E-01 3 23 -8.165E-01 3 33 0.000E+00 3 14 -8.165E-01 3 24 -2.667E+00 3 34 0.000E+00 3 44 0.000E+00 3 15 0.000E+00 3 25 0.000E+00 3 35 0.000E+00 3 45 0.000E+00 3 55 0.000E+00 3 16 0.000E+00 3 26 0.000E+00 3 36 -8.546E-01 3 46 2.108E+00 3 56 0.000E+00 3 66 0.000E+00 4 11 0.000E+00 4 12 0.000E+00 4 22 0.000E+00 4 13 6.124E-01 4 23 2.000E+00 4 33 0.000E+00 4 14 -1.000E+00 4 24 -8.165E-01 4 34 0.000E+00 4 44 0.000E+00 4 15 0.000E+00 4 25 0.000E+00 4 35 0.000E+00 4 45 0.000E+00 4 55 0.000E+00 4 16 0.000E+00 4 26 0.000E+00 4 36 6.406E-02 4 46 2.145E+00 4 56 0.000E+00 4 66 0.000E+00 5 11 -2.937E-01 5 12 -1.855E+00 5 22 -3.029E+00 5 13 0.000E+00 5 23 0.000E+00 5 33 -9.311E-01 5 14 0.000E+00 5 24 0.000E+00 5 34 -2.145E+00 5 44 -1.054E+00 5 15 0.000E+00 5 25 0.000E+00 5 35 0.000E+00 5 45 0.000E+00 5 55 0.000E+00 5 16 -1.781E-01 5 26 -4.582E+00 5 36 0.000E+00 5 46 0.000E+00 5 56 0.000E+00 5 66 -1.943E+00 *FOTILT* 16. 15. 0.56600E+02 *DRIFT* 3. 0.00000 CM 459.490 CM *TRANSFORM 1* -0.99999 0.00002 0.00000 0.00000 0.00000 3.99999 -0.61238 -0.99999 0.00000 0.00000 0.00000 1.22476 0.00000 0.00000 -0.99999 0.00002 0.00000 0.00000 0.00000 0.00000 -0.61238 -0.99999 0.00000 0.00000 -1.22476 -3.99999 0.00000 0.00000 1.00000 -3.47429 0.00000 0.00000 0.00000 0.00000 0.00000 1.00000 0*2ND ORDER TRANSFORM* 1 11 9.287E-01 1 12 1.517E+00 1 22 -1.114E-05 1 13 0.000E+00 1 23 0.000E+00 1 33 -1.250E+00 1 14 0.000E+00 1 24 0.000E+00 1 34 -8.165E-01 1 44 -1.333E+00 1 15 0.000E+00 1 25 0.000E+00 1 35 0.000E+00 1 45 0.000E+00 1 55 0.000E+00 1 16 -3.718E+00 1 26 -9.110E-03 1 36 0.000E+00 1 46 0.000E+00 1 56 0.000E+00 1 66 7.720E+00 2 11 2.772E-06 2 12 1.812E-05 2 22 7.222E-06 2 13 0.000E+00 2 23 0.000E+00 2 33 -6.124E-01 2 14 0.000E+00 2 24 0.000E+00 2 34 -1.000E+00 2 44 -4.082E-01 2 15 0.000E+00 2 25 0.000E+00 2 35 0.000E+00 2 45 0.000E+00 2 55 0.000E+00 2 16 1.161E+00 2 26 1.855E+00 2 36 0.000E+00 2 46 0.000E+00 2 56 0.000E+00 2 66 -1.097E+00 3 11 0.000E+00 3 12 0.000E+00 3 22 0.000E+00 3 13 1.429E+00 3 23 -8.166E-01 3 33 0.000E+00 3 14 7.000E-01 3 24 -2.667E+00 3 34 0.000E+00 3 44 0.000E+00 3 15 0.000E+00 3 25 0.000E+00 3 35 0.000E+00 3 45 0.000E+00 3 55 0.000E+00 3 16 0.000E+00 3 26 0.000E+00 3 36 -4.569E+00 3 46 -3.958E+00 3 56 0.000E+00 3 66 0.000E+00 4 11 0.000E+00 4 12 0.000E+00 4 22 0.000E+00 4 13 6.124E-01 4 23 2.000E+00 4 33 0.000E+00 4 14 -1.000E+00 4 24 -8.165E-01 4 34 0.000E+00 4 44 0.000E+00 4 15 0.000E+00 4 25 0.000E+00 4 35 0.000E+00 4 45 0.000E+00 4 55 0.000E+00 4 16 0.000E+00 4 26 0.000E+00 4 36 6.406E-02 4 46 2.145E+00 4 56 0.000E+00 4 66 0.000E+00 5 11 -2.937E-01 5 12 -1.855E+00 5 22 -3.029E+00 5 13 0.000E+00 5 23 0.000E+00 5 33 -9.311E-01 5 14 0.000E+00 5 24 0.000E+00 5 34 -2.145E+00 5 44 -1.054E+00 5 15 0.000E+00 5 25 0.000E+00 5 35 0.000E+00 5 45 0.000E+00 5 55 0.000E+00 5 16 -1.781E-01 5 26 -4.582E+00 5 36 0.000E+00 5 46 0.000E+00 5 56 0.000E+00 5 66 -1.943E+00 *FOTILT* 16. 15. -0.56600E+02 *DRIFT* 3. 0.00000 CM 459.490 CM *FOTILT* 16. 15. 0.00000E+00 *FOTILT* 16. 15. 0.27700E+02 *DRIFT* 3. 0.00000 CM 459.490 CM *TRANSFORM 1* -0.99999 0.00002 0.00000 0.00000 0.00000 3.99999 -0.61238 -0.99999 0.00000 0.00000 0.00000 1.22476 0.00000 0.00000 -0.99999 0.00002 0.00000 0.00000 0.00000 0.00000 -0.61238 -0.99999 0.00000 0.00000 -1.22476 -3.99999 0.00000 0.00000 1.00000 -3.47429 0.00000 0.00000 0.00000 0.00000 0.00000 1.00000 0*2ND ORDER TRANSFORM* 1 11 3.215E-01 1 12 5.250E-01 1 22 1.156E-05 1 13 0.000E+00 1 23 0.000E+00 1 33 -1.250E+00 1 14 0.000E+00 1 24 0.000E+00 1 34 -8.165E-01 1 44 -1.333E+00 1 15 0.000E+00 1 25 0.000E+00 1 35 0.000E+00 1 45 0.000E+00 1 55 0.000E+00 1 16 -7.438E-02 1 26 3.957E+00 1 36 0.000E+00 1 46 0.000E+00 1 56 0.000E+00 1 66 2.863E+00 2 11 2.772E-06 2 12 1.812E-05 2 22 7.222E-06 2 13 0.000E+00 2 23 0.000E+00 2 33 -6.124E-01 2 14 0.000E+00 2 24 0.000E+00 2 34 -1.000E+00 2 44 -4.082E-01 2 15 0.000E+00 2 25 0.000E+00 2 35 0.000E+00 2 45 0.000E+00 2 55 0.000E+00 2 16 1.161E+00 2 26 1.855E+00 2 36 0.000E+00 2 46 0.000E+00 2 56 0.000E+00 2 66 -1.097E+00 3 11 0.000E+00 3 12 0.000E+00 3 22 0.000E+00 3 13 8.215E-01 3 23 -8.166E-01 3 33 0.000E+00 3 14 -2.915E-01 3 24 -2.667E+00 3 34 0.000E+00 3 44 0.000E+00 3 15 0.000E+00 3 25 0.000E+00 3 35 0.000E+00 3 45 0.000E+00 3 55 0.000E+00 3 16 0.000E+00 3 26 0.000E+00 3 36 -2.141E+00 3 46 7.915E-03 3 56 0.000E+00 3 66 0.000E+00 4 11 0.000E+00 4 12 0.000E+00 4 22 0.000E+00 4 13 6.124E-01 4 23 2.000E+00 4 33 0.000E+00 4 14 -1.000E+00 4 24 -8.165E-01 4 34 0.000E+00 4 44 0.000E+00 4 15 0.000E+00 4 25 0.000E+00 4 35 0.000E+00 4 45 0.000E+00 4 55 0.000E+00 4 16 0.000E+00 4 26 0.000E+00 4 36 6.406E-02 4 46 2.145E+00 4 56 0.000E+00 4 66 0.000E+00 5 11 -2.937E-01 5 12 -1.855E+00 5 22 -3.029E+00 5 13 0.000E+00 5 23 0.000E+00 5 33 -9.311E-01 5 14 0.000E+00 5 24 0.000E+00 5 34 -2.145E+00 5 44 -1.054E+00 5 15 0.000E+00 5 25 0.000E+00 5 35 0.000E+00 5 45 0.000E+00 5 55 0.000E+00 5 16 -1.781E-01 5 26 -4.582E+00 5 36 0.000E+00 5 46 0.000E+00 5 56 0.000E+00 5 66 -1.943E+00 *FOTILT* 16. 15. 0.00000E+00 88.228 224.390 M -73.741 91.872 R -0.496 0.000 73.186 M 0.000 0.000 0.000 80.763 R 0.000 0.000 0.040 -164.903 182.927 M -0.789 0.474 0.000 0.000 0.000 7.000 N 0.125 0.093 0.000 0.000 -0.133 0*LENGTH* 459.49002 CM 1 0"(22) TEST OF SECOND ORDER MATRIX ELEMENTS FOR STRONGFOCUS " 0 0 15. 0.00000 " " 0.00000 ; 1.000000 2.00000 5.00000 2.00000 5.00000 0.00000 2.00000 10.00000; 17. 2.00000 2.00000; 4.000 "BEND" 2.00000 5.00000 -500.00000; 13. 4.00000; (THIS WAS PREVIOUSLY THE A.G.B.M. TEST ) (UNITS ARE RESET TO THEIR DEFAULT VALUE L=CMS FOR THE BEAM PARAMETERS) (THIS IS AN EXAMPLE OF SECOND ORDER MATRIX ELEMENTS FOR A STRONG FOCUSING) (BENDING MAGNET. IT IS REPEATED FOR BOTH POLARITIES OF THE MAGNET) 0SENTINEL 0 5 ELEMENTS USED OUT OF A MAXIMUM ALLOWABLE 3129 22 NUMBERS USED OUT OF A MAXIMUM ALLOWABLE 13160 1(22) TEST OF SECOND ORDER MATRIX ELEMENTS FOR STRONGFOCUS *BEAM* 1. 10.00000 GEV 0.000 M 0.000 2.000 CM 0.000 5.000 MR 0.000 0.000 2.000 CM 0.000 0.000 0.000 5.000 MR 0.000 0.000 0.000 0.000 0.000 CM 0.000 0.000 0.000 0.000 0.000 2.000 PC 0.000 0.000 0.000 0.000 0.000 *2ND ORDER* 17. GAUSSIAN DISTRIBUTION 2. 2. *BEND* 4. "BEND" 2.00000 M 5.00000 KG -500.00000 ( 66.713 M , 1.718 DEG ) 2.000 M *TRANSFORM 1* 0.78318 0.18533 0.00000 0.00000 0.00000 0.02887 -2.08619 0.78318 0.00000 0.00000 0.00000 0.27780 0.00000 0.00000 1.23323 0.21532 0.00000 0.00000 0.00000 0.00000 2.41899 1.23323 0.00000 0.00000 -0.02778 -0.00289 0.00000 0.00000 1.00000 -0.00029 0.00000 0.00000 0.00000 0.00000 0.00000 1.00000 0*2ND ORDER TRANSFORM* 1 11 -5.907E-05 1 12 1.775E-05 1 22 9.223E-07 1 13 0.000E+00 1 23 0.000E+00 1 33 1.622E-05 1 14 0.000E+00 1 24 0.000E+00 1 34 0.000E+00 1 44 -1.444E-06 1 15 0.000E+00 1 25 0.000E+00 1 35 0.000E+00 1 45 0.000E+00 1 55 0.000E+00 1 16 2.089E-03 1 26 1.439E-04 1 36 0.000E+00 1 46 0.000E+00 1 56 0.000E+00 1 66 -2.778E-04 2 11 -2.670E-04 2 12 -5.549E-05 2 22 -1.790E-05 2 13 0.000E+00 2 23 0.000E+00 2 33 1.560E-04 2 14 0.000E+00 2 24 0.000E+00 2 34 0.000E+00 2 44 -1.389E-05 2 15 0.000E+00 2 25 0.000E+00 2 35 0.000E+00 2 45 0.000E+00 2 55 0.000E+00 2 16 1.924E-02 2 26 2.081E-03 2 36 0.000E+00 2 46 0.000E+00 2 56 0.000E+00 2 66 -2.563E-03 3 11 0.000E+00 3 12 0.000E+00 3 22 0.000E+00 3 13 6.720E-05 3 23 6.984E-06 3 33 0.000E+00 3 14 3.426E-05 3 24 3.560E-06 3 34 0.000E+00 3 44 0.000E+00 3 15 0.000E+00 3 25 0.000E+00 3 35 0.000E+00 3 45 0.000E+00 3 55 0.000E+00 3 16 0.000E+00 3 26 0.000E+00 3 36 -2.418E-03 3 46 -1.563E-04 3 56 0.000E+00 3 66 0.000E+00 4 11 0.000E+00 4 12 0.000E+00 4 22 0.000E+00 4 13 3.849E-04 4 23 4.000E-05 4 33 0.000E+00 4 14 6.720E-05 4 24 6.984E-06 4 34 0.000E+00 4 44 0.000E+00 4 15 0.000E+00 4 25 0.000E+00 4 35 0.000E+00 4 45 0.000E+00 4 55 0.000E+00 4 16 0.000E+00 4 26 0.000E+00 4 36 -2.595E-02 4 46 -2.418E-03 4 56 0.000E+00 4 66 0.000E+00 5 11 -1.538E-04 5 12 1.930E-04 5 22 -8.630E-05 5 13 0.000E+00 5 23 0.000E+00 5 33 -1.842E-04 5 14 0.000E+00 5 24 0.000E+00 5 34 -2.604E-04 5 44 -1.164E-04 5 15 0.000E+00 5 25 0.000E+00 5 35 0.000E+00 5 45 0.000E+00 5 55 0.000E+00 5 16 1.958E-05 5 26 -2.684E-05 5 36 0.000E+00 5 46 0.000E+00 5 56 0.000E+00 5 66 1.255E-07 0*LENGTH* 2.00000 M 1 0"(23) TEST FOR OPPOSITE POLARITY " 0 1 15. 0.00000 " " 0.00000 ; 1.000000 2.00000 5.00000 2.00000 5.00000 0.00000 2.00000 10.00000; 17. 2.00000 2.00000; * 4.000 "BEND" 2.00000 5.00000 500.00000; 13. 4.00000; 0SENTINEL 0 5 ELEMENTS USED OUT OF A MAXIMUM ALLOWABLE 3129 20 NUMBERS USED OUT OF A MAXIMUM ALLOWABLE 13160 1(23) TEST FOR OPPOSITE POLARITY *BEAM* 1. 10.00000 GEV 0.000 M 0.000 2.000 CM 0.000 5.000 MR 0.000 0.000 2.000 CM 0.000 0.000 0.000 5.000 MR 0.000 0.000 0.000 0.000 0.000 CM 0.000 0.000 0.000 0.000 0.000 2.000 PC 0.000 0.000 0.000 0.000 0.000 *2ND ORDER* 17. GAUSSIAN DISTRIBUTION 2. 2. *BEND* 4. "BEND" 2.00000 M 5.00000 KG 500.00000 ( 66.713 M , 1.718 DEG ) 2.000 M *TRANSFORM 1* 1.23275 0.21529 0.00000 0.00000 0.00000 0.03112 2.41380 1.23275 0.00000 0.00000 0.00000 0.32271 0.00000 0.00000 0.78360 0.18535 0.00000 0.00000 0.00000 0.00000 -2.08234 0.78360 0.00000 0.00000 -0.03227 -0.00311 0.00000 0.00000 1.00000 -0.00031 0.00000 0.00000 0.00000 0.00000 0.00000 1.00000 0*2ND ORDER TRANSFORM* 1 11 7.662E-05 1 12 4.480E-05 1 22 2.160E-06 1 13 0.000E+00 1 23 0.000E+00 1 33 -1.748E-05 1 14 0.000E+00 1 24 0.000E+00 1 34 0.000E+00 1 44 -1.556E-06 1 15 0.000E+00 1 25 0.000E+00 1 35 0.000E+00 1 45 0.000E+00 1 55 0.000E+00 1 16 -2.408E-03 1 26 -1.556E-04 1 36 0.000E+00 1 46 0.000E+00 1 56 0.000E+00 1 66 -3.227E-04 2 11 4.188E-04 2 12 8.076E-05 2 22 -1.112E-05 2 13 0.000E+00 2 23 0.000E+00 2 33 -1.813E-04 2 14 0.000E+00 2 24 0.000E+00 2 34 0.000E+00 2 44 -1.614E-05 2 15 0.000E+00 2 25 0.000E+00 2 35 0.000E+00 2 45 0.000E+00 2 55 0.000E+00 2 16 -2.589E-02 2 26 -2.418E-03 2 36 0.000E+00 2 46 0.000E+00 2 56 0.000E+00 2 66 -3.462E-03 3 11 0.000E+00 3 12 0.000E+00 3 22 0.000E+00 3 13 -6.720E-05 3 23 -6.480E-06 3 33 0.000E+00 3 14 2.529E-05 3 24 2.438E-06 3 34 0.000E+00 3 44 0.000E+00 3 15 0.000E+00 3 25 0.000E+00 3 35 0.000E+00 3 45 0.000E+00 3 55 0.000E+00 3 16 0.000E+00 3 26 0.000E+00 3 36 2.082E-03 3 46 1.434E-04 3 56 0.000E+00 3 66 0.000E+00 4 11 0.000E+00 4 12 0.000E+00 4 22 0.000E+00 4 13 -2.841E-04 4 23 -2.739E-05 4 33 0.000E+00 4 14 -6.720E-05 4 24 -6.480E-06 4 34 0.000E+00 4 44 0.000E+00 4 15 0.000E+00 4 25 0.000E+00 4 35 0.000E+00 4 45 0.000E+00 4 55 0.000E+00 4 16 0.000E+00 4 26 0.000E+00 4 36 1.921E-02 4 46 2.082E-03 4 56 0.000E+00 4 66 0.000E+00 5 11 -1.840E-04 5 12 -2.604E-04 5 22 -1.164E-04 5 13 0.000E+00 5 23 0.000E+00 5 33 -1.536E-04 5 14 0.000E+00 5 24 0.000E+00 5 34 1.930E-04 5 44 -8.630E-05 5 15 0.000E+00 5 25 0.000E+00 5 35 0.000E+00 5 45 0.000E+00 5 55 0.000E+00 5 16 -2.564E-05 5 26 -3.359E-05 5 36 0.000E+00 5 46 0.000E+00 5 56 0.000E+00 5 66 -1.443E-07 0*LENGTH* 2.00000 M Title :TRANSPORT Keywords :Optics, Quadropoles, Sextapoles, Bending Magnets, EELS Computer :DEC VAX 11/730-785 Operating System :VAXVMS, Programming Language :Fortran IV Hardware Requirements :None Author(s) :K.L.Brown, F.Rothacker D.C., Carey, Ch. Iselin Correspondence Address :Stanford linear Accelerator Center, Stanford CA. USA :Fermi National Accelerator Lab. Batavia, IL. USA : CERN, Geneva, Switzerland Source Code: ------------------------------------------------------------------------------ PROGRAM TRANS C (INPUT=513,OUTPUT=513,PUNCH=65,TAPE4=PUNCH, C TAPE5=INPUT,TAPE6=OUTPUT) C C PROGRAM TRANSPORT C DESCRIBED IN CERN 73-16, SLAC 91, NAL 91 C BY BROWN, ROTHACKER, CAREY, AND ISELIN C MODIFIED FOR VAX 8/7/85 C BY S.SISSELMAN C C MAIN PROGRAM C C ---------------------------------------------------------------------- C ---------------------------------------------------------------------- C C DESCRIPTION OF FUNCTIONS AND SUBROUTINES C C ---------------------------------------------------------------------- C EXPANSION FOR TRANSFER MATRIX IS USED C SUBROUTINE ADVANC(I) USES O(1,*,*) X0(1,*) TO ADVANCE OTHER ARRAYS AND C MATRICES ALONG BEAM LINE. C SUBROUTINE ALTER USES CHANGE DATA IN CA(*,1) AND MODIFIES THE DATA C ARRAY. C SUBROUTINE ASSESS CALCULATES THE CURRENT VALUE OF A CONSTRAINED C VARIABLE AND PLACES RESULT IN COC. C SUBROUTINE BEAM CALCULATES THE BEAM MATRIX EITHER FROM PARAMETERS ON C BEAM CARD, OR FROM SI AND RC2. C SUBROUTINE CAB(C,A,B) CALCULATES MATRIX PRODUCT C = A X B. C SUBROUTINE CABD2(C,C2,A,A2,B,B2) COMPUTES RCV AND TCV FROM C PRELIMINARY CALCULATIONS C SUBROUTINE CABD3(C,C2,C3,A,A2,A3,B,B2,B3,D2) COMPUTES RCV, TCV, AND C UCV, FROM PRELIMINARY CALCULATIONS C SUBROUTINE CABT(C,A,B) CALCULATES MATRIX PRODUCT C = A X B(TRANSPOSE). C SUBROUTINE CAB2(C,C2,A,A2,B,B2,TRDUN) CALCULATES MATRIX PRODUCT IN C SECOND ORDER C SUBROUTINE CAB3(C,C2,C3,A,A2,A3,B,B2,B3,URDUN) CALCULATES MATRIX C PRODUCT IN THIRD ORDER C SUBROUTINE CHEK(CKK) SEARCHES FOR THE BENDING MAGNET ASSOCIATED WITH C 2. CARD. C SUBROUTINE CLI(LOGIC) CHECKS FOR LIMITS ON 10. CARD. C SUBROUTINE COMBIN FORMS CONSTRAINTS FROM ALGEBRAIC COMBINATIONS C OF MATRIX ELEMENTS C SUBROUTINE CONDOR CALCULATES PARTIALS FOR THIRD-ORDER FITTING C SUBROUTINE CONSEC CALCULATES PARTIALS FOR SECOND-ORDER FITTING. C SUBROUTINE CONSTR CALCULATES PARTIALS AND FIRST-ORDER CONSTRAINTS. C SUBROUTINE DEFINE KEEPS TRACK OF DEFINED SECTIONS (TYPE CODE 24.) C REAL FUNC. DEN(X) PREVENTS DIVISION BY ZERO. C SUBROUTINE DERIVE WALKS THROUGH BEAM LINE AND MULTIPLIES R AND T C MATRICES AND THEIR DERIVATIVES FOR ENTIRE SYSTEM. C SUBROUTINE DETUNE INCORPORATES EFFECT OF MISALIGNMENT INTO C FIRST-ORDER TRANSFER MATRIX C SUBROUTINE DFOCUS CALCULATES DERIVATIVE OF MATRIX ELEMENTS OF QUAD < C DIPOLE WITH RESPECT TO B < GRADIENT. C SUBROUTINE DFOL PARTIALS OF R WITH RESPECT TO LENGTH FOR QUAD AND C DIPOLE. C SUBROUTINE ELICIT ACCUMULATES MATRICES WHEN NOT FITTING. C SUBROUTINE ELMENT(NWK) EVALUATES NUMERICAL EFFECT OF EACH ELEMENT BY C SUBSTITUTION ON ALGEBRAIC EQUATION FROM SLAC 75. C SUBROUTINE ENRICH CALCULATES NEW TRANSFER MATRIX ABOUT C DISPLACED TRAJECTORY C SUBROUTINE EXTENT CALCULATES PARTIALS RESULTING FROM A CONSTRAINT ON C BEAM SIZE < DIFFERENCES BETWEEN DESIRED < ACTUAL C VALUES. C SUBROUTINE FITTIN READS IN ALL DATA, UNSCRAMBLES, AND FITS INTO DATA C ARRAY. C SUBROUTINE FOCUS CALCULATES R MATRIX FOR BENDING MAGNET < QUADRUPOLE. C SUBROUTINE FORM SETS UP NORMAL EQUATIONS FOR FITTING. SEE PAGES C F38 OF SLAC 91. C SUBROUTINE GATHER COLLECTS ALL PARTIALS ALONG WITH DIFFERENCES OF C CONSTRAINED QUANTITIES, AND PUTS INTO NORMAL C EQUATIONS. C SUBROUTINE GROPE ACCUMULATES PARTIAL DERIVATIVES OF LAYOUT C COORDINATES W.R.T. VARIED PARAMETERS C SUBROUTINE HUNT2 SEARCHES FOR AN EXIT FRINGE FIELD FOR A BENDING C MAGNET C SUBROUTINE INFECT ADVANCES THE MISALIGNMENT TABLE WHEN OFF-AXIS C SUBROUTINE INITZE INITIALIZES ALL VARIABLES AT THE BEGINNING OF BEAM C LINE TO SPECIFIED VALUES. C SUBROUTINE INIT1 RESETS PARAMETERS THAT SHOULD BE CHANGED WHEN A BEAM C CARD IS ENCOUNTERED. C SUBROUTINE INQ INVERTS MATRIX OF NORMAL EQUATIONS FOR FITTING C ROUTINE. SEE PAGE F38 OF SLAC 91. C SUBROUTINE IO HANDLES INPUT/OUTPUT OPTIONS VIA 13. TYPE CODE ENTRY C REAL FUNC. LIMIT(TYPE,N,K) IMPOSES LIMITS ON VARIED QUANTITIES. WILL C PROBABLY BE MODIFIED. C SUBROUTINE MALIGN CALCULATES MISALIGNMENTS. C INT. FUNC. NIV(TYPE) RETURNS TOTAL NUMBER OF POSSIBLY INDICATED VARIED C PARAMETERS. C INT. FUNC. NV(TYPE) RETURNS TOTAL NUMBER OF VARIED PARAMETERS FOR A C GIVEN ELEMENT. C SUBROUTINE OUTFIT MAKES A RUN THROUCH THE BEAM TRANSPORT ELEMENT AND C PRINTS OUTPUT. C SUBROUTINE PARSEC CALCULATES PARTIALS OF SECOND-ORDER MATRIX OF A C SINGLE BEAM ELEMENT WITH RESPECT TO THE VARIED C QUANTITY. C SUBROUTINE PARTLS CALCULATES PARTIALS OF FIRST-ORDER MATRIX OF A C SINGLE BEAM ELEMENT WITH RESPECT TO THE VARIED C QUANTITY. C SUBROUTINE PARTRJ CALCULATES PARTIALS OF THIRD-ORDER MATRIX OF A C SINGLE BEAM ELEMENT WITH RESPECT TO THE VARIED C QUANTITY. C SUBROUTINE PICKUP STORES BEAM MATRIX ON UPDATE FOR USE IN C MISALIGNMENT CALCULATION C SUBROUTINE PREML3 FORMS PRELIMINARY PRODUCT OF U AND TWO FACTORS OF R C SUBROUTINE PREMUL FORMS PRELIMINARY PRODUCT OF T AND R C SUBROUTINE PREVUE DETERMINES BEGINNING AND END OF SECTION WHERE C FITTING OCCURS C SUBROUTINE PRINT1 PRINTS OUT THE DATA FOR ONE ELEMENT C SUBROUTINE PUNCH1 PUNCHES TRANSFER MATRICES ONTO CARDS. C SUBROUTINE QEO PRINTS BEAM ENVELOPE MATRIX, ACCUMULATED LENGTH AND C MAGNET COORDINATES. C C SUBROUTINES RANNU, RANGET, RANSET AND RANST HAVE BEEN MODIFIED FOR THE VAX C C REAL FUNC. RANNU GENERATES RANDOM NUMBERS FOR MISALIGNMENTS C SUBROUTINE RANGET SAVES CURRENT VALUE OF RANDOM NUMBER C SUBROUTINE RANSET SETS RANDOM NUMBER SEED TO CLOCK VALUE C THE VAX USES 'SECONDS' ROUTINE RATHER THAN CLOCK C C SUBROUTINE RANST SETS RANDOM NUMBER SEED TO DEFAULT VALUE C SUBROUTINE RCALC CALCULATES R OR T MATRIX WHEN IT IS TO BE PRINTED C VIA A 13. 4. OR 13.24. CARD. C SUBROUTINE RCOUT PRINTS R OR T MATRICES. C SUBROUTINE RDELMT READS AND PRINTS DATA FOR ONE ELEMENT C SUBROUTINE RDFIX READS ONE INTEGER C SUBROUTINE RDFLT READS ONE FLOATING-POINT NUMBER C SUBROUTINE RDNEXT READS NEXT INPUT CHARACTER AND OPTIONALLY SKIPS C BLANK CHARACTERS C C SUBROUTINE RDPACK HAS BEEN MODIFIED FOR THE VAX C C SUBROUTINE RDPACK PACKS ZERO TO FOUR CHARACTERS INTO ONE WORD C SUBROUTINE RDSTRG READS A CHARACTER STRING C SUBROUTINE RECALL RESETS MATRICES AND PARAMETERS TO VALUES C AT BEGINNING OF SECTION WHERE FITTING OCCURS C SUBROUTINE REPEAT(DONE) KEEPS TRACK OF TYPE CODE 9 (REPEAT ELEMENT). C SUBROUTINE RESET(I) RESETS MATRICES THAT ARE USED FOR MISALIGNMENT. C SUBROUTINE RETAIN STORES MATRICES AND PARAMETERS AT BEGINNING C OF SECTION WHERE FITTING OCCURS C SUBROUTINE SECORD CALCULATES NUMERICAL VALUE OF SECOND-ORDER MATRIX C ELEMENTS FROM ALGEBRAIC EQUATIONS GIVEN IN SLAC 75. C REAL FUNC. SIGNF(X) RETURNS THE SIGN OF A NUMBER OR ZERO. C SUBROUTINE SOLVE DIRECTS FITTING AND PRINTS OUT RESULTS. C SUBROUTINE SPESHL(JA) HANDLES TYPE CODE 16. ENTRIES. C SUBROUTINE SQUIRM CALCULATES PARTIAL DERIVATIVES OF ELEMENT FLOOR C COORDINATE TRANSFORMATION C SUBROUTINE STEER SHIFTS THE BEAM CENTROID FOR EXTRA OR VERTICAL BEND. C SUBROUTINE SURVEY PRINTS COORDINATE LAYOUT C SUBROUTINE TFL CALCULATES GENERAL CASE OF EQU 5 PAGE A 78 OF SLAC 91 C FROM O AND X0. C SUBROUTINE THOR CALCULATES THIRD-ORDER MATRIX ELEMENTS. C SUBROUTINE THREAD CALCULATES TRANSFORMED IMAGE OF BEAM CENTROID C SUBROUTINE THRED1 CALCULATES FIRST ORDER IMAGE OF BEAM CENTROID C SUBROUTINE TWITCH ADVANCES PARTIAL DERIVATIVE OF TRANSFER MATRIX C ABOUT DISPLACED ORBIT C SUBROUTINE UNITS MAKES UNITS CHANGES VIA TYPE CODE 15. ENTRIES. C SUBROUTINE UPDATE RESETS FLAGS SO THAT ACCUMMULATION OF THE R1 MATRIX C WILL BEGIN ANEW. C SUBROUTINE UPDAT2 SAME AS UPDATE, BUT FOR R2 MATRIX. C SUBROUTINE UPDAT3 SAME AS UPDATE, BUT FOR R3 MATRIX. C SUBROUTINE UPMIS UPDATES MISALIGNMENT TABLE C SUBROUTINE UPSIG UPDATES BEAM MATRIX AND ITS PARTIALS. C INT. FUNC. VARSP(TYPE,JV) KEEPS TRACK OF VARIED SPECIAL PARAMETERS. C SUBROUTINE WOBBLE CALCULATES PARTIAL DERIVATIVES OF BEAM MATRIX C WITH RESPECT TO MISALIGNMENT PARAMETERS C SUBROUTINE WOE PRINTS MISALIGNMENT TABLE C ---------------------------------------------------------------------- C ---------------------------------------------------------------------- C C DESCRIPTION OF COMMON BLOCKS AND VARIABLES C C ---------------------------------------------------------------------- C BLOC1 REPRESENTATION OF BEAM LINE COMMON /BLOC1/ NEL, NUM, NDIF, I, ISTOR(3129), DATA(13160) C NEL TOTAL NUMBER OF ELEMENTS IN SYSTEM C NUM NUMBER OF ELEMENT CURRENTLY BEING TREATED C NDIF INCREMENT FOR CURRENT ELEMENT NUMBER C I POINTER TO ELEMENT DATA C ISTOR(3129) POINTERS TO ELEMENT DATA FOR ALL ELEMENTS C DATA(13160) STORAGE FOR TYPE CODES AND PARAMETERS C ---------------------------------------------------------------------- C BLOC2 FORTRAN I/O UNITS COMMON /BLOC2/ NIN, NOUT, NPUNCH C NIN UNIT NUMBER FOR INPUT DATA. C NOUT UNIT NUMBER FOR PRINTOUT. C NPUNCH UNIT NUMBER FOR CARDS TO BE PUNCHED. C ---------------------------------------------------------------------- C BLOC3 PERTAINS TO A SINGLE ELEMENT COMMON /BLOC3/ TYPE, L, LV INTEGER TYPE REAL L, LV C TYPE INTEGER ELEMENT TYPE CODE. C L REAL LENGTH OF A GIVEN ELEMENT. C LV REAL DERIVATIVE OF THE LENGTH OF AN ELEMENT WITH C RESPECT TO WHAT IS BEING VARIED. C ---------------------------------------------------------------------- C BLOC4 ACCUMULATED EFFECT COMMON /BLOC4/ LC, TOTANG, TOTROT, LCV(20), LUP(3) REAL LC, LCV, LUP C LC REAL TOTAL ACCUMULATED LENGTH -- PRINTED BEFORE BEAM C ELLIPS. C TOTANG TOTAL ANGLE -- NOT USED. C TOTROT TOTAL Z ROTATION C LCV(20) REAL DERIVATIVE OF ACCUMULATED LENGTH C LUP(3) REAL ACCUMULATED LENGTH AT LAST UPDATE C ---------------------------------------------------------------------- C BLOC5 PERTAINS TO VARY CODES OR LABELS COMMON /BLOC5/ VSTOR(20), TIE(13160), LABEL(3129), LABM(10) INTEGER VSTOR, TIE C VSTOR(20) INTEGER STORAGE FOR INPUT VARY CODES C TIE(13160) INTEGER INTERNAL (EXTERNAL) VARY CODES. CORRESPONDS C TO THE DATA ARRAY. C LABEL(3129) CONTAINS USER PROVIDED LABELS C LABM(10) LABELS OF MISALIGNED ELEMENTS C ---------------------------------------------------------------------- C BLOC11 MATRICES FOR A SINGLE ELEMENT COMMON /BLOC11/ R(6,6), RV(6,6), T(5,21), TV(5,21), U(5,56), 1 UV(5,56) C R(6,6) FIRST ORDER TRANSFER MATRIX. C RV(6,6) PARTIALS MATRIX FOR ONE OF THE VARIED C PARAMETERS. C T(5,21) SECOND ORDER TRANSFER MATRIX FOR A SINGLE C ELEMENT C TV(5,21) PARTIALS OF T WITH RESPECT TO ONE OF THE VARIED C PARAMETERS C U(5,56) THIRD ORDER TRANSFER MATRIX FOR A SINGLE ELEMEN C UV(5,56) PARTIALS OF U WITH RESPECT TO ONE OF THE VARIED C PARAMETERS C ---------------------------------------------------------------------- C BLOC12 R1 MATRICES COMMON /BLOC12/ RC(6,6), RCV(6,6,20), TC(5,21), UC(5,56), RCP, 1 RVP(20) LOGICAL RCP, RVP C RC(6,6) CUMULATIVE R MATRIX FROM LAST R1 UPDATE THROUGH C LAST R2 UPDATE. C RCV(6,6,20) CUMULATIVE PARTIALS MATRIX FROM LAST R1 UPDATE C THROUGH LAST R2 UPDATE. C TC(5,21) CUMULATIVE T MATRIX FROM LAST R1 UPDATE THROUGH C LAST R2 UPDATE. C UC(5,56) CUMULATIVE U MATRIX FROM LAST R1 UPDATE THROUGH C LAST R2 UPDATE. C RCP LOGICAL TRUE IF ACCUMULATION OF RC HAS BEGUN. C RVP(20) LOGICAL TRUE IF ACCUMULATION OF RCV HAS BEGUN C ---------------------------------------------------------------------- C BLOC13 R2 MATRICES COMMON /BLOC13/ RC2(6,6), R2V(6,6,20), TC2(5,21), T2V(5,21,10), 1 UC2(5,56), U2V(5,56,10), R2P, R2VP(20) LOGICAL R2P, R2VP C RC2(6,6) CUMULATIVE R MATRIX FROM LAST R2 UPDATE. C R2V(6,6,20) CUMULATIVE PARTIALS MATRIX FROM LAST R2 UPDATE C TC2(5,21) CUMULATIVE T MATRIX FROM LAST R2 UPDATE C T2V(5,21,10) CUMULATIVE T PARTIALS MATRIX FROM LAST R2 C UPDATE. C UC2(5,56) CUMULATIVE U MATRIX FROM LAST R2 UPDATE C U2V(5,21,10) CUMULATIVE T PARTIALS MATRIX FROM LAST R2 C UPDATE C R2P LOGICAL TRUE IF ACCUMULATION OF RC2 MATRIX HAS BEGUN. C R2VP(20) LOGICAL TRUE IF ACCUMULATION OF R2V HAS BEGUN C ---------------------------------------------------------------------- C BLOC14 MATRICES USED IN FITTING COMMON /BLOC14/ RC3(6,6), TC3(5,21), UC3(5,56), R3P LOGICAL R3P C RC3(6,6) CUMULATIVE R MATRIX BETWEEN VARIED ELEMENTS, C CONSTRAINTS, OR R2 UPDATES. C TC3(5,21) SAME AS RC3, BUT FOR SECOND-ORDER TERMS C UC3(5,56) SAME AS RC3, BUT FOR THIRD-ORDER TERMS C R3P LOGICAL TRUE IF ACCUMULATION OF RC3 MATRIX HAS BEGUN. C ---------------------------------------------------------------------- C BLOC15 TEMPORARY STORAGE FOR MATRIX MULTIPLY COMMON /BLOC15/ RS(6,6), RT(6,6), TS(5,21), TT(5,21), US(5,56), 1 UT(5,56) C RS(6,6) C RT(6,6) C TS(5,21) C TT(5,21) C US(5,56) C UT(5,56) C ---------------------------------------------------------------------- C BLOC16 BEAM MATRIX AT LAST R2 UPDATE COMMON /BLOC16/ SI(6,6), SV(6,6,20), CO(6), COV(6,20), RI, 1 SVP(20), CVP(20), SOFA LOGICAL SVP, CVP, SOFA C SI(6,6) SIGMA MATRIX. C SV(6,6,20) PARTIALS OF SI WITH RESPECT TO VARIED C PARAMETERS. C CO(6) BEAM CENTROID AT LAST R2 UPDATE. C COV(6,20) PARTIALS OF CO C RI BEAM RIGIDITY (MOMENTUM). C SVP(20) LOGICAL TRUE IF VARIED PARAMETER AFFECTS THE BEAM C ELLIPSE. C CVP(20) LOGICAL TRUE IF VARIED PARAMETER AFFECTS THE C BEAM CENTROID C SOFA LOGICAL TRUE IF THE BEAM CENTROID MAY BE OFF AXIS. C ---------------------------------------------------------------------- C BLOC17 COMMON /BLOC17/ COD(6), COF(6), PSIX, PSIY, PSIX1, PSIY1, NOPH LOGICAL NOPH C COD(6) SHIFT IN BEAM CENTROID. C COF(6) FIRST ORDER POSITION OF BEAM CENTROID C PSIX PHASE SHIFT IN HORIZONTAL PLANE C PSIY PHASE SHIFT IN VERTICAL PLANE C PSIX1 PHASE SHIFT IN HORIZONTAL PLANE AT LAST R2 C UPDATE C PSIY1 PHASE SHIFT IN VERTICAL PLANE AT LAST R2 C UPDAT3 C NOPH LOGICAL TRUE IF BEAM HAS ZERO PHASE SPACE C ---------------------------------------------------------------------- C BLOC18 DESCRIBES BEAM AT PRESENT LOCATION COMMON /BLOC18/ SIT(6,6), CEN(6), RECENT LOGICAL RECENT C SIT(6,6) TEMPORARY SIGMA MATRIX, CALCULATED ONLY WHEN C NEEDED. C CEN(6) TEMPORARY CENTRIOD SHIFT, CALCULATED ONLY WHEN C NEEDED. PRINTED WITH BEAM MATRIX. (R X CO). C RECENT LOGICAL TRUE IF SIT REPRESENTS THE CURRENT BEAM MATRIX. C ---------------------------------------------------------------------- C BLOC19 A STEP IN MATRIX MULTIPLICATION COMMON /BLOC19/ TR(5,6,6), TRA(5,6,6), URR(5,21,6), NORDE C TR(5,6,6) PRODUCT OF T X R OVER ONE INDEX ONLY C TRA(5,6,6) ARRAY TR AS ACTUALLY USED C URR(5,21,6) PRODUCT OF U X R X R OVER TWO INDICES ONLY C NORDE MAXIMUM ORDER FOR OCCURANCE OF NONZERO MATRIX C ELEMENTS FOR PRESENT PHYSICAL ELEMENT C ---------------------------------------------------------------------- C BLOC20 ETA FOR ACCELERATOR PARAMETERS COMMON /BLOC20/ ETA(6), DETA(6,20), RAY, EVP(20) LOGICAL RAY, EVP C ETA ACCELERATOR ETA FUNCTION (MOMENTUM DEPENDENCE) C DETA DERIVATIVE OF ETA C RAY LOGICAL IF ETA IS BEING USED C EVP LOGICAL TRUE IF VARIED PARAMETER AFFECTS ETA C ---------------------------------------------------------------------- C BLOC21 TYPE 2 INPUT PARAMETERS COMMON /BLOC21/ EN, ES, BE, APB(2), LAYK, LAYL, LAYX, RABT REAL LAYK, LAYL, LAYX C EN PARAMETER OF POLE FACE ROTATION C ES PARAMETER OF POLE FACE ROTATION C BE ANGLE BETA. C APB(2) PARAMETER ON 16. 4. AND 16. 5. CARDS. C LAYK REAL K(0) ON 16. 2. CARD, PAGE 16.4 SLAC 91. C LAYL REAL K(1) ON 16. 7. CARD, PAGE 16-4 SLAC 91. C LAYX REAL K(2) ON 16. 8. CARD, PAGE 16-4 SLAC 91. C RABT CURVATURE OF BENDING MAGNET POLE FACE C ---------------------------------------------------------------------- C BLOC22 TYPE 2 CALCULATED QUANTITIES -- SEE PAGE 2-3 OF COMMON /BLOC22/ LBEND, BE1, SB, TB, TB1, NBVARY, BEFORE LOGICAL BEFORE REAL LBEND C LBEND LENGTH OF BENDING MAGNET C SLAC 91. C BE1 BETA - PSI. C SB (1 + SIN(B)**2) / COS(B). C TB TAN (BETA). C TB1 TAN(BE1). C NBVARY VARY CODE OF ASSOCIATED MAGNETIC FIELD C BEFORE TELLS IF ENTRANCE OR EXIT POLE FACE ROTATION C ---------------------------------------------------------------------- C BLOC23 TYPE 4 COMMON /BLOC23/ H0, AL, NB, BDB, RMPS, VRN, NPN, BDBP, RNMS, DCOV LOGICAL DCOV REAL NB, NPN C H0 1/RADIUS OF CURVATURE. C AL ANGLE OF BEND. C NB REAL NORMALIZED FIELD GRADIENT (SMALL N). C BDB NORMALIZED SECOND DERIVATIVE OF B. C RMPS MULTIPLICATIVE FACTOR FOR FIELD OF BEND MAGNET C VRN NORMALIZED VERTICALLY BENDING COMPONENT OF C BEND FIELD C (DOES NOT AFFECT REFERENCE TRAJECTORY) C NPN NORMALIZED FIELD GRADIENT OF VERTICALLY C BENDING FIELD C BDBP NORMALIZED SECOND DERIVATIVE OF VRN. C RNMS COMMON MULTIPLICATIVE FACTOR FOR NON-MIDPLANE- C SYMMETRIC MULTIPOLES C DCOV LOGICAL CALCULATE PARTIAL DERIVATIVES OF CENTROID C POSITION WITH RESPECT TO VARIED PARAMETERS C ---------------------------------------------------------------------- C BLOC24 TYPES 4 AND 5 COMMON /BLOC24/ B, KQ2, KVK, K2H, K2V, CS, SN, DISN, DSVN, J REAL KQ2, KVK, K2H, K2V C B FIELD IN KILOGAUSS. C KQ2 REAL K SQUARED TERM IN HARMONIC OSCILATOR EQUATION. C KVK REAL SCALER TO MULTIPLY MATRIX TO GET PARTIAL WITH C RESPECT TO B OR N. C K2H REAL KQ2 FOR HORIZONTAL PLANE. C K2V REAL KQ2 FOR VERTICAL PLANE. C CS COSINE-LIKE FUNCTION USED IN CALCULATING THE C TRANSFER MATRIX FOR A SINGLE ELEMENT. C SN SINE-LIKE FUNCTION. C DISN (1 - COS(KXL)) / KX* C DSVN (1 - COS(KYL)) / KY**2 C J INDEX TELLING IF HORIZONTAL OR VERTICAL PLANE. C ---------------------------------------------------------------------- C BLOC25 TYPE 6 COMMON /BLOC25/ AP, CAP, JA LOGICAL CAP C AP APERTURE. C CAP LOGICAL TRUE IF 13. 10. IS PRESENT. C JA SECOND ITEM ON A 6. CARD (ALWAYS ZERO). C ---------------------------------------------------------------------- C BLOC26 TYPE 8 INPUT OR IMMEDIATELY CALCULATED C QUANTITIES COMMON /BLOC26/ O(4,3,3), X0(4,3), IR, RORC, TYT, ALIGN, TMK, 1 FEO, CHORD LOGICAL ALIGN, TMK, FEO, CHORD INTEGER RORC, TYT C O(4,3,3) TRANSFORMATIONS BETWEEN COORDINATE SYSTEMS. C X0(4,3) LOCATION VECTORS WITH RESPECT TO EACH OF THE C FOUR COORDINATE SYSTEMS. C IR INDEX TELLING IF MISALIGNMENT IS SINCE THE LAST C ELEMENT, R1, OR R2 UPDATES. C RORC INTEGER INDEX ON A MISALIGNMENT CARD. C TYT INTEGER PARTIAL DECODING ON INDEX ON MISALIGNMENT CARD. C ALIGN LOGICAL TRUE IF A MISALIGNMENT IS INCLUDED IN THIS RUN. C INCLUDED IN MISALIGNMENT CALCULATION C TMK LOGICAL TRUE IF THE PIVOT POINT OF A MISALIGNMENT IS AS C INDICATED ON A 13. 20/22 CARD. C FEO LOGICAL TRUE IF ONLY FOCUSING EFFECT OF MISALIGNMENT C IS TO BE COMPUTED C CHORD LOGICAL TRUE IF MISALIGNMENT Z AXIS IS CHORD OF BENDING C MAGNET C ---------------------------------------------------------------------- C BLOC27 TYPE 8 QUANTITIES USED IN MISALIGNMENT C CALCULATIONS COMMON /BLOC27/ CT(6,6), CT0(6,6), CT1(3,3), X0L(3), VM(6), 1 VMT(6), COM(6,6,10), OR(3,3), XR(3), LMIS(2,10), 2 DMC, NM LOGICAL DMC REAL LMIS C CT(6,6) TERM A1 OR QUANTITY (A1-RA0) IN EQUATION (8) C PAGE A-79 SLAC 91. C CT0(6,6) TERM A0 IN EQUATION (8) PAGE A-79 SLAC 91. C CT1(3,3) MATRIX USED TO EVALUATE CROSS PRODUCT. C X0L(3) LOCATION OF MISALIGNMENT PIVOT FOR C MISALIGNMENT ABOUT MAGNET CENTER C VM(6) TERM M IN EQUATION (8) PAGE A-79 SLAC 91. C VMT(6) VM TIMES RANDOM NUMBERS WHEN RANDOM C MISALIGNMENT IS SPECIFIED C COM(6,6,10) DISPLACEMENT OF BEAM CENTROID FROM C MISALIGNED MAGNET C OR(3,3) ORIENTATION OF REFERENCE FRAME FOR MISALIGNMENT C XR(3) POSITION OF ORIGIN FOR REFERENCE FRAME FOR C MISALIGNMENT C LMIS(2,10) REAL LIMITS OF ACCUMULATED LENGTH OF MISALIGNED C SECTION C DMC LOGICAL INDICATOR THAT MISALIGNMENT CALCULATION IS TO C BE DONE C NM NUMBER OF ENTRIES IN MISALIGNMENT TABLE C ---------------------------------------------------------------------- C BLOC28 TYPE 10 INPUT QUANTITIES COMMON /BLOC28/ COC, DE0, SD, CTY, JV, NC, NV1, NV2, NV3 INTEGER CTY C COC PRESENT VALUE OF CONSTRAINED QUANTITY. PRINTED C AFTER 10. CARD. C DE0 DESIRED VALUE OF CONSTRAINED QUANTITY AS GIVEN C ON 10. CARD. C SD TOLERANCE. C CTY INTEGER INDICATES UPPER OR LOWER LIMIT OF A CONSTRAINT. C JV INDEX TELLING WHICH PARAMETER OF AN ELEMENT IS C BEING VARIED. C NC NUMBER OF CONSTRAINTS. C NV1 NUMBER OF VARIED PARAMETERS ENCOUNTERED SO FAR. C NV2 VARIED PARAMETER CURRENTLY BEING DEALT WITH. C NV3 EXTRA STORAGE FOR NV1. C ---------------------------------------------------------------------- C BLOC29 TYPE 10 PARTIALS, ETC. COMMON /BLOC29/ A(21), CW, CA(21,21), SCALE(21), CASAV(21,21), 1 PMARQ, CHSMIN, XNORM, GNORM, EPS C A(21) DIFFERENCE BETWEEN ACTUAL AND DESIRED VALUES OF C CONSTRAINED QUANTITIES. C CW WEIGHTING = 1/TOLERANCE SQUARED FOR CONSTRAINED C QUANTITY. C CA(21,21) MATRIX OF NORMAL EQUATIONS C SCALE(21) SCALING FACTOR FOR HESSIAN C CASAV(21,21) CA ARRAY AT LOWEST CHI-SQUARED C PMARQ MARQUARDT - LEVENBERG FIT PARAMETER C CHSMIN MINIMUM VALUE OF CHI-SQUARED ENCOUNTERED C XNORM MAGNITUDE OF STEP SIZE C GNORM MAGNITUDE OF GRADIENT OF CHI SQUARED C EPS CONTRACTION FACTOR FOR MARQUARDT-LEVENBERG C PARAMETER C ---------------------------------------------------------------------- C BLOC30 TYPE 13 COMMON /BLOC30/ CDB, NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, 1 LCPR, ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, 2 LAY191, NPFR INTEGER CDB LOGICAL NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, LCPR, 1 ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, LAY191 C CDB INTEGER SECOND ITEM ON A 13 CARD. C NOR LOGICAL TRUE IF BEAM MATRIX IS TO BE PRINTED AFTER EACH C ELEMENT. C LAY LOGICAL TRUE IF A LAYOUT OF COORDINATES IS TO BE DONE C VIA A 13. 12. CARD. C RAT LOGICAL TRUE IF TRANSFER MATRIX IS TO BE PRINTED AFTER C EACH ELEMENT C BAX LOGICAL TRUE IF BEAM LINE IS TO BE REALIGNED ALONG C BEAM CENTROID C R1P LOGICAL TRUE IF BEAM CENTROID IS CURRENTLY DISPLACED C WITH REALIGNMENT TO OCCUR C SUPP LOGICAL TRUE IF PHYSICAL PARAMETERS ARE NOT TO BE C PRINTED C ONLY LOGICAL TRUE IF ONLY FITTING INFORMATION IS TO BE C PRINTED C TERSE LOGICAL TRUE IF ABBREVIATED PRINT FORMAT IS TO BE USED C LCPR LOGICAL TRUE IF ACCUMULATED LENGTH HAS BEEN PRINTED C ANIN LOGICAL TRUE IF BEND MAGNET INPUT DATA IS TO BE C LENGTH AND ANGLE C REFER LOGICAL TRUE IF TRANSFER MATRIX IS TO BE CALCULATED C IN ORIGINAL COORDINATE SYSTEM C ACCEL LOGICAL TRUE IF BEAM MATRIX IS TO BE EXPRESSED IN C ACCELERATOR NOTATION C UNRO LOGICAL TRUE IF VARIED PARAMETERS ARE TO BE PRINTED C WITH EXTRA PRECISION C ABOUT DISPLACED TRAJECTORY C HTGQ LOGICAL TRUE IF QUADRUPOLE TYPE CODE REPRESENTS C A QUADRUPOLE (NOT A LITHIUM LENS) C ELPR LOGICAL TRUE IF ELEMENTS ARE TO BE PRINTED IN OUTPUT C LAY191 LOGICAL TRUE OF EXTRA PRECISION LAYOUT IS TO BE PRINTED C NPFR POLE FACE ROTATION ANGLE SPECIFICATION OPTION C ---------------------------------------------------------------------- C BLOC31 TYPE 14 ARBITRARY R MATRIX COMMON /BLOC31/ J1, TYP1 INTEGER TYP1 C J1 WHICH ROW OF ARBITRARY R MATRIX IS BEING C CONSIDERED. C TYP1 INTEGER TYPE CODE ON LAST CARD. C ---------------------------------------------------------------------- C BLOC32 TYPE 15 UNITS CHANGES COMMON /BLOC32/ UNIT(12), XDIME(12) C UNIT(12) CONVERSION UNITS C XDIME(12) NAME OF UNIT C ---------------------------------------------------------------------- C BLOC33 TYPE 16 COMMON /BLOC33/ FOTILT, SM, TH, PREF C FOTILT TILT OF FOCAL PLANE ON 16. 15. ELEMENT. C SM MASS OF PARTICLES ON 16. 3. ELEMENT. C TH COORDINATE ROTATION ANGLE C PREF REFERENCE MOMENTUM FOR MAGNET SETTINGS C ---------------------------------------------------------------------- C BLOC34 TYPE 17 SECOND ORDER CALCULATIONS COMMON /BLOC34/ NORD1, NORD2, NORD3, NORDX, LINEAR, JH, SIG LOGICAL LINEAR C NORD1 ORDER TO WHICH TRANSFER MATRICES ARE COMPUTED C NORD2 ORDER TO WHICH TRANSFER MATRICES ARE C ACCUMULATED C NORD3 ORDER TO WHICH TRANSFER MATRICES ARE DISPLAYED C NORDX SECOND PHYSICAL PARAMETER ON 17. CARD C LAST UPDATE OR BEGINNING OF SYSTEM. C LINEAR LOGICAL TELLS IF FITTING PROBLEM IS LINEAR C JH COORDINATE CORRESPONDING TO LOCAL HORIZONTAL C SIG MULTIPLICATION FACTOR FOR COORDINATE REVERSAL C ---------------------------------------------------------------------- C BLOC35 TYPE 19 SOLENOID COMMON /BLOC35/ KL, KO REAL KL, KO C KL REAL K * LENGTH. C KO REAL K TERM IN HARMONIC OSCILATOR EQUATION. C ---------------------------------------------------------------------- C BLOC36 SECOND ORDER FITTING COMMON /BLOC36/ VARS(8), SEXMAX, SEXLIM INTEGER VARS LOGICAL SEXLIM C VARS(8) INTEGER TELLS IF SPECIAL PARAMETER IS BEING VARIED. C SEXMAX LIMIT ON STRENGTH OF SEXTUPOLE GIVEN ON 10.N C CARD. C SEXLIM LOGICAL TRUE IF A LIMIT HAS BEEN IMPOSED ON THE C SEXTUPOLE STRENGTHS IN A SECOND ORDER RUN. C ---------------------------------------------------------------------- C BLOC38 BEAM MATRIX AT BEGINNING OF MISALIGNED SECTIONS COMMON /BLOC38/ SIOL(3,6,6), COLD(3,6), RCO(3,6,6), R2O(6,6), 1 SPO(3), RCPO(3), R2PO LOGICAL SPO, RCPO, R2PO C SIOL(3,6,6) SAVED SIGMA MATRIX C COLD(3,6) SAVED BEAM CENTROID C RCO(3,6,6) RC TRANSFER MATRIX AT BEGINNING OF MISALIGNED C SECTION C R2O(6,6) R2 TRANSFER MATRIX AT BEGINNING OF MISALIGNED C SECTION C SPO LOGICAL TRUE IF SAVED BEAM CENTROID MAY BE OFF AXIS C RCPO(3) LOGICAL TRUE IF ACCUMULATION OF RC HAD BEGUN AT C BEGINNING OF MISALIGNED SECTION C R2PO LOGICAL TRUE OF ACCUMULATION OF R2 HAD BEGIN AT C BEGINNING OF MISALIGNED SECTION C ---------------------------------------------------------------------- C BLOC39 INTERMEDIATE QUANTITIES IN MISALIGNMENT CALCULATION COMMON /BLOC39/ XM(6), XMB(6), DXM(6), GXXM(6,6) C XM(6) LINEAR CENTROID DISPLACEMENT TERM C XMB(6) BILINEAR CENTROID DISPLACEMENT TERM C DXM(6) POSSIBLE CENTROID SHIFT WITHIN MISALIGNED C SECTION C GXXM(6) BILINEAR MATRIX FOLDED WITH SIGMA MATRIX AND C MISALIGNMENT PARAMETERS C --------------------------------------------------------------------- C BLOC40 PARTIAL DERIVATIVES OF FLOOR COORDINATES COMMON /BLOC40/ OV(3,3,20), X0V(3,20), OIV(3,3), XIV(3), OVP(20) LOGICAL OVP C OV ACCUMULATED DERIVATIVES OF COORDINATE C ROTATION MATRIX C X0V ACCUMULATED DERIVATIVES OF FLOOR POSITIONS C OIV LOCAL DERIVATIVE OF COORDINATE ROTATION MATRIX C XIV LOCAL DERIVATIVES OF FLOOR POSITIONS C OVP LOGICAL TRUE IF ACCUMULATION OF OV HAS BEGUN C ---------------------------------------------------------------------- C BLOC41 RUN TITLE, INDICATOR, DATA OF LAST ELEMENT READ COMMON /BLOC41/ LW, IMAGE(20), FLUSH, INDIC, NTYPE, LABLE, LENGTH, 1 NWORD, NVARY, DATUM(30), VARY(30) INTEGER VARY, TEXT(30) LOGICAL FLUSH EQUIVALENCE (TEXT(1),DATUM(1)) C LW LENGTH OF TITLE READ C IMAGE (20) TITLE FOR RUN (20A4) C FLUSH LOGICAL INDICATES DATA ERROR C INDIC INDICATOR C NTYPE TYPE CODE OF LAST ELEMENT READ C LABLE LABEL OF THIS ELEMENT C LENGTH STORAGE LENGTH REQUIRED FOR ELEMENT READ C NWORD NUMBER OF DATA ITEMS READ FOR THIS ELEMENT C NVARY NUMBER OF VARY CODES READ FOR THIS ELEMENT C DATUM(30) DATA OF THIS ELEMENT C VARY(30) INTEGER VARY CODES FOR THIS ELEMENT C -------------------------------------------------------------------- C BLOC42 HOLLERITH CODES USED FOR FREE-FORMAT DECODING COMMON /BLOC42/ TABLE(36), PLUS, MINUS, BLANK, PERIOD, SPEC(10) INTEGER TABLE, PLUS, MINUS, BLANK, PERIOD, SPEC C TABLE(36) INTEGER DIGITS AND LETTERS C PLUS INTEGER + C MINUS - C BLANK INTEGER BLANK SPACE C PERIOD INTEGER . C SPEC(10) INTEGER , ; * $ " ' = / ( ) C -------------------------------------------------------------------- C BLOC43 CONTAINS CURRENT INPUT CARD (LINE) COMMON /BLOC43/ NCD, CARD(80), MC, EMPTY, ITEM, INDP INTEGER CARD LOGICAL EMPTY C NCD NUMBER OF CURRENT CARD C CARD(80) INTEGER CARD IMAGE, 1 CHARACTER PER MACHINE WORD C MC CURRENT CHARACTER POSITION C EMPTY LOGICAL TRUE IF CURRENT CARD HAS BEEN TERMINATED C ITEM CURRENT CHARACTER VALUE C INDP TENS AND UNITS PART OF INDICATOR C ---------------------------------------------------------------------- C BLOC44 STORAGE REGISTERS FOR ALGEBRAIC COMBINATIONS C OF MATRIX ELEMENTS COMMON /BLOC44/ REG(20), DREG(20,20), LREG(20) LOGICAL LREG C REG(20) VALUES IN REGISTERS C DREG(20,20) PARTIAL DERIVATIVES OF VALUES IN REGISTERS C LREG(20) IF REGISTR HAS VALUE IN IT C --------------------------------------------------------------------- C BLOC45 HORIZONTAL AND VERTICAL TRANSFER MATRIX ELEMENTS COMMON /BLOC45/ CSH, SOKH, SKH, DISP, DDISP, CSV, SOKV, SKV C CSH HORIZONTAL COSINELIKE TRAJECTORY C SOKH HORIZONTAL SINELIKE TRAJECTORY C SKH DERIVATIVE OF HORIZONTAL COSINELIKE TRAJECTORY C DISP DISPERSION FUNCTION C DDISP DERIVATIVE OF DISPERSION FUNCTION C CSV VERTICAL COSINELIKE TRAJECTORY C SOKV VERTICAL SINELIKE TRAJECTORY C SKV DERIVATIVE OF VERTICAL SINELIKE TRAJECTORY C --------------------------------------------------------------------- C BLOC47 TYPE 24 -- DEFINE SECTION AND REPEATS COMMON /BLOC47/ IC(4), IS(4), IP, NNDS, NDLEV C IC(4) NUMBER OF PASSES REMAINING IN REPEAT SECTION C IS(4) NUM AT BEGINNING OF REPEAT SECTION C IP LEVEL OF NESTED REPEATS C NNDS NUMBER OF NAMES OF DEFINED SECTIONS C NDLEV LEVEL OF NESTING C ---------------------------------------------------------------------- C BLOC48 MARKERS FOR ELEMENTS WHEN FITTING COMMON /BLOC48/ NUMB, NUME, NCT, NCTV, NCTC, NCTS, NCTF C NUMB NUM WHERE FIRST VARY CODE OCCURS C NUME NUM WHERE LAST CONSTRAINT OCCURS C NCT RUNNING COUNT OF ELEMENTS C NCTV RUNNING COUNT WHERE FIRST VARY CODE OCCURS C NCTC RUNNING COUNT WHERE LAST CONSTRAINT OCCURS C NCTS RUNNING COUNT FOR START OF SECTION TO BE FIT C NCTF RUNNING COUNG FOR END OF SAME SECTION C ---------------------------------------------------------------------- C BLOC 49 RANDOM VARIATION OF PHYSICAL PARAMETERS COMMON /BLOC49/ PRAN2, PRAN3, PRAN4(3), PRAN5(3), PRAN7(6), 1 PRAN11(4), PRAN16(30), PRAN18(3), PRAN19(2), 2 PRAN20, PRAN25(3) C PRAN2 RANDOM VARIATION FOR PHYSICAL PARAMETERS C OF TYPE CODE 2. (POLE FACE ROTATION) C PRAN3 RANDOM VARIATION FOR PHYSICAL PARAMETERS C OF TYPE CODE 3. (DRIFT SPACE) C PRAN4(3) RANDOM VARIATION FOR PHYSICAL PARAMETERS C OF TYPE CODE 4. (BENDING MAGNET) C PRAN5(3) RANDOM VARIATION FOR PHYSICAL PARAMETERS C OF TYPE CODE 5. (QUADRUPOLE) C PRAN7(6) RANDOM VARIATION FOR PHYSICAL PARAMETERS C OF TYPE CODE 7. (CENTROID SHIFT) C PRAN11(4) RANDOM VARIATION FOR PHYSICAL PARAMETERS C OF TYPE CODE 11. (ACCELERATOR) C PRAN16(30) RANDOM VARIATION FOR PHYSICAL PARAMETERS C OF TYPE CODE 16. (SPECIAL PARAMETERS) C PRAN18(3) RANDOM VARIATION FOR PHYSICAL PARAMETERS C OF TYPE CODE 18. (SEXTUPOLE) C PRAN19(2) RANDOM VARIATION FOR PHYSICAL PARAMETERS C OF TYPE CODE 19. (SOLENOID) C PRAN20 RANDOM VARIATION FOR PHYSICAL PAREMETERS C OF TYPE CODE 20. (COORDINATE ROTATION) C PRAN25 RANDOM VARIATION FOR PHYSICAL PARAMETERS C OF TYPE CODE 25. (OCTUPOLE) C ---------------------------------------------------------------------- C BLOC50 INPUT VALUES FOR SPECIAL PARAMETERS COMMON /BLOC50/ BDBI, LAYKI, LAYLI, LAYXI, RAB1I, RAB2I, RMPSI, 1 VRNI, NPNI, BDBPI, RNMSI REAL LAYKI, LAYLI, LAYXI, NPNI C BDBI INPUT VALUE FOR BDB C LAYKI REAL INPUT VALUE FOR LAYK C LAYLI REAL INPUT VALUE FOR LAYL C LAYXI REAL INPUT VALUE FOR LAYX C RAB1I INPUT VALUE FOR RAB1 C RAB2I INPUT VALUE FOR RAB2 C RMPSI INPUT VALUE FOR RMPS C VRNI INPUT VALUE FOR VRN C NPNI REAL INPUT VALUE FOR NPN C BDBPI INPUT VALUE FOR BDBP C RNMSI INPUT VALUE FOR RNMS C ---------------------------------------------------------------------- C BLOC51 TYPE 11 ACCELERATOR COMMON /BLOC51/ EGAIN, PHASEL, WAVEL C EGAIN ENERGY GAIN (GEV) C PHASEL PHASE LAG (DEGREES) C WAVEL WAVELENGTH IN CM. C ---------------------------------------------------------------------- C BLC101 TEMPORARY STORAGE FOR BLOC1 COMMON /BLC101/ NUMS, NDIFS C NUMS STORAGE FOR NUM C NDIFS STORAGE FOR NDIF C ---------------------------------------------------------------------- C BLC104 TEMPORARY STORAGE FOR BLOC4 COMMON /BLC104/ LCS, TOTRTS REAL LCS C LCS STORAGE FOR LC C TOTRTS STORAGE FOR TOTROT C ---------------------------------------------------------------------- C BLC111 TEMPORARY STORAGE FOR BLOC11 COMMON /BLC111/ RSS(6,6), TSS(5,21) C RSS STORAGE FOR R C TSS STORAGE FOR T C -------------------------------------------------------------------- C BLC112 TEMPORARY STORAGE FOR BLOC12 COMMON /BLC112/ RCS(6,6), RCPS LOGICAL RCPS C RCS STORAGE FOR RC C RCPS LOGICAL STORAGE FOR RCP C ---------------------------------------------------------------------- C BLC113 TEMPORARY STORAGE FOR BLOC13 COMMON /BLC113/ RC2S(6,6), TC2S(5,21), UC2S(5,56), R2PS LOGICAL R2PS C RC2S STORAGE FOR RC2 C TC2S STORAGE FOR TC2 C UC2S STORAGE FOR UC2 C R2PS LOGICAL STORAGE FOR R2P C ---------------------------------------------------------------------- C BLC116 TEMPORARY STORAGE FOR BLOC16 COMMON /BLC116/ SIS(6,6), COS(6), RIS, SOFAS LOGICAL SOFAS C SIS STORAGE FOR SI C COS STORAGE FOR CO C RIS STORAGE FOR RI C SOFAS LOGICAL STORAGE FOR SOFA C ---------------------------------------------------------------------- C BLC117 TEMPORARY STORAGE FOR BLOC17 COMMON /BLC117/ COFS(6) C COFS STORAGE FOR COF C ---------------------------------------------------------------------- C BLC120 TEMPORARY STORAGE FOR BLOC20 COMMON /BLC120/ ETAS(6), RAYS LOGICAL RAYS C ETAS STORAGE FOR ETA C RAYS LOGICAL STORAGE FOR RAY C ---------------------------------------------------------------------- C BLC121 TEMPORARY STORAGE FOR BLOC21 COMMON /BLC121/ APBS(2) C APBS(2) STORAGE FOR APB C ---------------------------------------------------------------------- C BLC126 TEMPORARY STORAGE FOR BLOC26 COMMON /BLC126/ OS(4,3,3), X0S(4,3), RORCS INTEGER RORCS C OS STORAGE FOR O C X0S STORAGE FOR X0 C RORCS INTEGER STORAGE FOR RORC C ---------------------------------------------------------------------- C BLC127 TEMPORARY STORAGE FOR BLOC27 COMMON /BLC127/ VMS(6) C VMS STORAGE FOR VM C ---------------------------------------------------------------------- C BLC130 TEMPORARY STORAGE FOR BLOC30 COMMON /BLC130/ LAYS, R1PS, ANINS, HTGQS, NPFRS LOGICAL LAYS, R1PS, ANINS, HTGQS C LAYS STORAGE FOR LAY C R1PS STORAGE FOR R1P C ANINS STORAGE FOR ANIN C HTGQS STORAGE FOR HTGQ C NPFRS STORAGE FOR NPFR C ---------------------------------------------------------------------- C BLC133 TEMPORARY STORAGE FOR BLOC34 COMMON /BLC133/ FOTLTS, SMS C FOTLTS STORAGE FOR FOTILT C SMS STORAGE FOR SM C ---------------------------------------------------------------------- C BLC134 TEMPORARY STORAGE FOR BLOC34 COMMON /BLC134/ JHS, SIGS C JHS STORAGE FOR JH C SIGS STORAGE FOR SIG C ---------------------------------------------------------------------- C BLC138 TEMPORARY STORAGE FOR BLOC38 COMMON /BLC138/ SIOLS(3,6,6), COLDS(3,6), RCOS(3,6,6), R2OS(6,6), 1 SPOS(3), RCPOS(3), R2POS LOGICAL SPOS, RCPOS, R2POS C SIOLS STORAGE FOR SIOL C COLDS STORAGE FOR COLD C RCOS STORAGE FOR RCO C R2OS STORAGE FOR R2O C SPOS LOGICAL STORAGE FOR SPO C RCPOS LOGICAL STORAGE FOR RCPO C R2POS LOGICAL STORAGE FOR R2PO C ---------------------------------------------------------------------- C BLC144 TEMPORARY STORAGE FOR BLOC44 COMMON /BLC144/ REGS(20), LREGS(20) LOGICAL LREGS C REGS STORAGE FOR REG C LREGS LOGICAL STORAGE FOR LREG C ---------------------------------------------------------------------- C BLC147 TEMPORARY STORAGE FOR BLOC47 COMMON /BLC147/ ICS(4), ISS(4), IPS, NNDSS, NDLEVS C ICS TEMPORARY STORAGE FOR IC C ISS TEMPORARY STORAGE FOR IS C IPS TEMPORARY STORAGE FOR IP C NNDSS TEMPORARY STORAGE FOR NNDS C NDLEVS TEMPORARY STORAGE FOR NDLEV C ---------------------------------------------------------------------- C BLC149 TEMPORARY STORAGE FOR BLOC49 COMMON /BLC149/ PRAN2S, PRAN3S, PRAN4S(3), PRAN5S(3), PRAN7S(6), 1 PRN11S(4), PRN16S(30), PRN18S(3), PRN19S(2), 2 PRN20S, PRN25S(3) C PRAN2S TEMPORARY STORAGE FOR PRAN2 C PRAN3S TEMPORARY STORAGE FOR PRAN3 C PRAN4S(3) TEMPORARY STORAGE FOR PRAN4 C PRAN5S(3) TEMPORARY STORAGE FOR PRAN5 C PRAN7S(6) TEMPORARY STORAGE FOR PRAN7 C PRN11S(4) TEMPORARY STORAGE FOR PRAN11 C PRN16S(30) TEMPORARY STORAGE FOR PRAN16 C PRN18S(3) TEMPORARY STORAGE FOR PRAN18 C PRN19S(2) TEMPORARY STORAGE FOR PRAN19 C PRN20S TEMPORARY STORAGE FOR PRAN20 C PRN25S(3) TEMPORARY STORAGE FOR PRAN25 C ---------------------------------------------------------------------- C BLC150 TEMPORARY STORAGE FOR BLOC50 COMMON /BLC150/ BDBIS, LAYKIS, LAYLIS, LAYXIS, RAB1IS, RAB2IS, 1 RMPSIS, VRNIS, NPNIS, BDBPIS, RNMSIS REAL LAYKIS, LAYLIS, LAYXIS, NPNIS C BDBIS TEMPORARY STORAGE FOR BDBI C LAYKIS TEMPORARY STORAGE FOR LAYKI C LAYLIS TEMPORARY STORAGE FOR LAYLI C LAYXIS TEMPORARY STORAGE FOR LAYXI C RAB1IS TEMPORARY STORAGE FOR RAB1I C RAB2IS TEMPORARY STORAGE FOR RAB2I C RMPSIS TEMPORARY STORAGE FOR RMPSIS C VRNIS TEMPORARY STORAGE FOR VRNI C NPNIS REAL TEMPORARY STORAGE FOR NPNI C BDBPIS TEMPORARY STORAGE FOR BDBPI C RNMSIS TEMPORARY STORAGE FOR RNMSI C ---------------------------------------------------------------------- C ---------------------------------------------------------------------- C COMMON /CONSTS/ PI, RADIAN, CLIGHT, EMASS COMMON /LIMITS/ NDATA, NNEL COMMON /UORIG/ UORIG(12), XORIG(12) C RADIAN = 180.0/PI NV3 = 20 1 CALL FITTIN NV3 = NV1 INDS = INDIC/100 IF (INDS .EQ. 3) GO TO 1 IF (NV1 * NC .EQ. 0) GO TO 3 CALL PREVUE IF (INDS .EQ. 1 .OR. INDS .EQ. 2) GO TO 2 NSAVE = NV1 CALL OUTFIT NV1 = NSAVE 2 CALL SOLVE 3 IF (INDS .NE. 2) CALL OUTFIT GO TO 1 END BLOCK DATA COMMON /BLOC2/ NIN, NOUT, NPUNCH COMMON /BLOC27/ CT(6,6), CT0(6,6), CT1(3,3), X0L(3), VM(6), 1 VMT(6), COM(6,6,10), OR(3,3), XR(3), LMIS(2,10), 2 DMC, NM LOGICAL DMC REAL LMIS COMMON /BLOC32/ UNIT(12), XDIME(12) COMMON /BLOC42/ TABLE(36), PLUS, MINUS, BLANK, PERIOD, SPEC(10) INTEGER TABLE, PLUS, MINUS, BLANK, PERIOD, SPEC COMMON /CONSTS/ PI, RADIAN, CLIGHT, EMASS COMMON /HSINT/ HSCX, HSSX, HSCY, HSSY, HSLCY, HSLSY, 1 HSGLP, HSCX2, HSCSX, HSCCM, HSCSM, HSSX2, HSSCM, HSSSM, 2 HSCY2, HSCSY, HSSY2, HSCDX, HSSDX, HSDCM, HSCDY, HSDSM, 3 HSSDY, HSDX2 COMMON /HPINT/ HPCX, HPSX, HPCY, HPSY, HPLCY, HPLSY, 1 HPGLP, HPCX2, HPCSX, HPCCM, HPCSM, HPSX2, HPSCM, HPSSM, 2 HPCY2, HPCSY, HPSY2, HPCDX, HPSDX, HPDCM, HPCDY, HPDSM, 3 HPSDY, HPDX2 COMMON /LIMITS/ NDATA, NNEL COMMON /VSINT/ VSCX, VSSX, VSDX, VSCY, VSSY, VSDY, VSLCX, 1 VSLSX, VSCX2, VSCSX, VSCCM, VSCSM, VSSX2, VSSCM, VSSSM, 2 VSCY2, VSCSY, VSSY2, VSCDX, VSCDM, VSSDX, VSSDM, VSDCM, 3 VSDSM, VSDX2, VSDDM COMMON /VPINT/ VPCX, VPSX, VPDX, VPCY, VPSY, VPDY, VPLCX, 1 VPLSX, VPCX2, VPCSX, VPCCM, VPCSM, VPSX2, VPSCM, VPSSM, 2 VPCY2, VPCSY, VPSY2, VPCDX, VPCDM, VPSDX, VPSDM, VPDCM, 3 VPDSM, VPDX2, VPDDM COMMON /UORIG/ UORIG(12), XORIG(12) C DATA NIN, NOUT, NPUNCH /5, 6, 4/ DATA TABLE / 1H0, 1H1, 1H2, 1H3, 1H4, 1H5, 1H6, 1H7, 1H8, 1H9, 1 1HA, 1HB, 1HC, 1HD, 1HE, 1HF, 1HG, 1HH, 1HI, 1HJ, 2 1HK, 1HL, 1HM, 1HN, 1HO, 1HP, 1HQ, 1HR, 1HS, 1HT, 3 1HU, 1HV, 1HW, 1HX, 1HY, 1HZ / DATA PLUS / 1H+ / DATA MINUS / 1H- / DATA BLANK / 1H / DATA PERIOD/ 1H. / DATA SPEC /1H,, 1H;, 1H*,1H$,1H",1H',1H=,1H/,1H(,1H)/ DATA CT, CT0, CT1, VM /36*0.0,36*0.0,9*0.0,6*0.0/ DATA PI /3.1415926535897932/, CLIGHT /2.997924580E-2/, 1 EMASS /.5110041E-3/ DATA NDATA /13160/, NNEL /3129/ DATA UORIG /0.01,1.E-03,0.01,1.E-03,0.01,0.010,0.0,1.0,1.0, 1 0.0,1.0,0.0/ DATA XORIG /2HCM, 2HMR, 2HCM, 2HMR, 2HCM, 2HPC, 3HDEG, 1HM, 1 2HKG ,2HMO, 3HGEV, 3HDEG/ END SUBROUTINE ADVANC(I) COMMON /BLOC12/ RC(6,6), RCV(6,6,20), TC(5,21), UC(5,56), RCP, 1 RVP(20) LOGICAL RCP, RVP COMMON /BLOC13/ RC2(6,6), R2V(6,6,20), TC2(5,21), T2V(5,21,10), 1 UC2(5,56), U2V(5,56,10), R2P, R2VP(20) LOGICAL R2P, R2VP COMMON /BLOC14/ RC3(6,6), TC3(5,21), UC3(5,56), R3P LOGICAL R3P COMMON /BLOC26/ O(4,3,3), X0(4,3), IR, RORC, TYT, ALIGN, TMK, 1 FEO, CHORD INTEGER RORC, TYT LOGICAL ALIGN, TMK, FEO, CHORD REAL O1(3,3) C IF (I .EQ. 3 .AND. .NOT. (R2P .OR. R3P)) GO TO 10 IF (I .EQ. 2 .AND. .NOT. (RCP .OR. R2P .OR. R3P)) GO TO 10 C DO 3 J = 1, 3 S = 0.0 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 S = S + O(I,K,J)*X0(1,K) 2 CONTINUE X0(I,J) = X0(I,J) + S 3 CONTINUE DO 4 J = 1, 3 DO 4 J1 = 1, 3 O(I,J1,J) = O1(J1,J) 4 CONTINUE RETURN 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 RETURN END SUBROUTINE ALTER(CHANGE) COMMON /BLOC1/ NEL, NUM, NDIF, I, ISTOR(3129), DATA(13160) COMMON /BLOC2/ NIN, NOUT, NPUNCH COMMON /BLOC5/ VSTOR(20), TIE(13160), LABEL(3129), LABM(10) INTEGER VSTOR, TIE COMMON /BLOC28/ COC, DE0, SD, CTY, JV, NC, NV1, NV2, NV3 INTEGER CTY COMMON /BLOC29/ A(21), CW, CA(21,21), SCALE(21), CASAV(21,21), 1 PMARQ, CHSMIN, XNORM, GNORM, EPS COMMON /BLOC30/ CDB, NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, 1 LCPR, ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, 2 LAY191, NPFR INTEGER CDB LOGICAL NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, LCPR, 1 ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, LAY191 INTEGER TYPE, VARY REAL CHANGE(21) REAL LIMIT C C CHANGE VARIED PARAMETERS TO NEW VALUES C DO 80 IRU = 1, 2 DO 70 NUM = 1, NEL I = ISTOR(NUM) TYPE = DATA(I) IF (TYPE .LE. 0 .OR. TYPE .GE. 50) GO TO 70 NVT = NIV(TYPE) IF (NVT .LT. 1) GO TO 70 DO 60 J = 1, NVT IPLUSJ = I + J VARY = TIE(IPLUSJ) IF (VARY .EQ. 0) GO TO 60 IVARY = IABS(VARY) 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) 40 CHANGE(IVARY+1) = (X2 - DATA(IPLUSJ))*SIG GO TO 60 50 DATA(IPLUSJ) = X2 60 CONTINUE 70 CONTINUE 80 CONTINUE C C PRINT OUT CHANGES APPLIED C IF (ONLY) RETURN WRITE (NOUT,1000) EPS, CA(1,1), (CHANGE(J+1), J = 1, NV1) 1000 FORMAT (1X,E12.5,1X,1H(,E12.5,1H),10F10.4/28X,10F10.4) RETURN END SUBROUTINE ASSESS COMMON /BLOC1/ NEL, NUM, NDIF, I, ISTOR(3129), DATA(13160) COMMON /BLOC2/ NIN, NOUT, NPUNCH COMMON /BLOC4/ LC, TOTANG, TOTROT, LCV(20), LUP(3) REAL LC, LCV, LUP COMMON /BLOC12/ RC(6,6), RCV(6,6,20), TC(5,21), UC(5,56), RCP, 1 RVP(20) LOGICAL RCP, RVP COMMON /BLOC13/ RC2(6,6), R2V(6,6,20), TC2(5,21), T2V(5,21,10), 1 UC2(5,56), U2V(5,56,10), R2P, R2VP(20) LOGICAL R2P, R2VP DIMENSION RC2L(36), R2VL(36,20), TC2L(105), T2VL(105,10), 1 UC2L(280), U2VL(280,10) EQUIVALENCE (RC2(1,1),RC2L(1)), (R2V(1,1,1),R2VL(1,1)), 1 (TC2(1,1),TC2L(1)), (T2V(1,1,1),T2VL(1,1)), 2 (UC2(1,1),UC2L(1)), (U2V(1,1,1),U2VL(1,1)) COMMON /BLOC15/ RS(6,6), RT(6,6), TS(5,21), TT(5,21), US(5,56), 1 UT(5,56) DIMENSION RSL(36), RTL(36), TSL(105), TTL(105), USL(280), 1 UTL(280) EQUIVALENCE (RS(1,1),RSL(1)), (RT(1,1),RTL(1)), 1 (TS(1,1),TSL(1)), (TT(1,1),TTL(1)), 2 (US(1,1),USL(1)), (UT(1,1),UTL(1)) COMMON /BLOC16/ SI(6,6), SV(6,6,20), CO(6), COV(6,20), RI, 1 SVP(20), CVP(20), SOFA LOGICAL SVP, CVP, SOFA COMMON /BLOC17/ COD(6), COF(6), PSIX, PSIY, PSIX1, PSIY1, NOPH LOGICAL NOPH COMMON /BLOC18/ SIT(6,6), CEN(6), RECENT LOGICAL RECENT COMMON /BLOC20/ ETA(6), DETA(6,20), RAY, EVP(20) LOGICAL RAY, EVP COMMON /BLOC26/ O(4,3,3), X0(4,3), IR, RORC, TYT, ALIGN, TMK, 1 FEO, CHORD INTEGER RORC, TYT LOGICAL ALIGN, TMK, FEO, CHORD COMMON /BLOC28/ COC, DE0, SD, CTY, JV, NC, NV1, NV2, NV3 INTEGER CTY COMMON /BLOC30/ CDB, NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, 1 LCPR, ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, 2 LAY191, NPFR INTEGER CDB LOGICAL NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, LCPR, 1 ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, LAY191 COMMON /BLOC32/ UNIT(12), XDIME(12) COMMON /BLOC34/ NORD1, NORD2, NORD3, NORDX, LINEAR, JH, SIG LOGICAL LINEAR COMMON /BLOC44/ REG(20), DREG(20,20), LREG(20) LOGICAL LREG COMMON /CONSTS/ PI, RADIAN, CLIGHT, EMASS C J = DATA(I + 1) K = DATA(I + 2) COC = 0.0 IF (J .EQ. 0 .AND. K .EQ. 0) GO TO 50 IF (J .EQ. 8) GO TO 60 IF (J .EQ. 9) GO TO 95 IF (J .EQ. 18) GO TO 1150 IF (J .EQ. 100) GO TO 1200 IF (J .LT. - 20) GO TO 100 IF (J .LT. - 10) GO TO 150 IF (J .LT. 0) GO TO 200 GO TO 250 C C SYSTEM LENGTH CONSTRAINT C 50 COC = LC / UNIT(8) RETURN C C FLOOR COORDINATE CONSTRAINT C 60 IF (K .GE. 4) GO TO 70 COC = X0(4,K)/UNIT(8) RETURN C 70 IF (K .EQ. 5) GO TO 80 IF (K .EQ. 6) GO TO 90 C THETA = ATAN(O(4,3,1)/O(4,3,3)) IF (O(4,3,3) .GE. 0.0) GO TO 72 SHIFT = SIGN(PI,O(4,3,1)) THETA = SHIFT - THETA 72 COC = THETA/UNIT(7) RETURN C 80 COC = ASIN(O(4,3,2))/UNIT(7) RETURN C 90 PITCH = ATAN(O(4,1,2)/O(4,2,2)) IF (O(4,2,2) .GE. 0.0) GO TO 92 SHIFT = SIGN(PI,O(4,1,2)) PITCH = SHIFT - PITCH 92 COC = PITCH/UNIT(7) RETURN C C CONSTRAINT ON ALGEBRAIC COMBINATION OF MATRIX ELEMENTS C 95 IF (K .GT. 20) RETURN IF (LREG(K)) COC = REG(K) RETURN C C R2 MATRIX CONSTRAINT C 100 IF (NORD3 .LT. 1) RETURN JMIN2 = - (J + 20) IF (K .GT. 10) GO TO 1050 COC = RC2(JMIN2,K) * UNIT(K) / UNIT(JMIN2) RETURN C C AGS MACHINE CONSTRAINT C 150 IF (NORD3 .LT. 1) RETURN JMIN1 = - (10 + J) IF (RCP) GO TO 160 COC = 0.5*(RC2(JMIN1,JMIN1) + RC2(K,K)) GO TO 175 160 IF (R2P) GO TO 165 COC = 0.5 * (RC(JMIN1,JMIN1) + RC(K,K)) GO TO 175 165 DO 170 L1 = 1, 6 COC = COC + RC2(JMIN1,L1)*RC(L1,JMIN1) + RC2(K,L1)*RC(L1,K) 170 CONTINUE COC = 0.5*COC 175 IF (ABS(COC) .LE. 1.0) GO TO 180 WRITE (NOUT,9010) 9010 FORMAT (45H ARGUMENT OF ARCCOSINE GREATER THAN ONE) COC = 0.0 RETURN C 180 COC = ACOS(COC)/(2.0*PI) RETURN C C R MATRIX CONSTRAINT C 200 IF (NORD3 .LT. 1) RETURN JMIN = - J IF (K .GT. 10) GO TO 1050 IF (RCP) GO TO 220 COC = RC2(JMIN,K)*UNIT(K)/UNIT(JMIN) RETURN C 220 IF (R2P) GO TO 230 COC = RC(JMIN,K) * UNIT(K) / UNIT(JMIN) RETURN C 230 DO 240 L1 = 1, 6 COC = COC + RC2(JMIN,L1)*RC(L1,K) 240 CONTINUE COC = COC*UNIT(K)/UNIT(JMIN) RETURN C C CONSTRAINTS ON BEAM MATRIX C 250 IF (J .EQ. K) GO TO 300 IF (J .GT. 10 .AND. J .LE. 16) GO TO 350 IF (J .EQ. 0 .OR. J .EQ. 7) GO TO 450 IF (J .EQ. 27) GO TO 500 GO TO 400 C C BEAM SIZE CONSTRAINT C 300 IF (NORD3 .LT. 1) RETURN IF (.NOT. RECENT) CALL BEAM IF (ACCEL) GO TO 310 COC = SIT(J,J) COC = SQRT(COC)/UNIT(J) RETURN C 310 IF (J .EQ. 2 .OR. J .EQ. 4) GO TO 320 IF (J .GE. 5) RETURN COC = SIT(J,J)*UNIT(J+1)/UNIT(J) RETURN C 320 COC = - SIT(J-1,J) RETURN C C BEAM CORRELATION CONSTRAINT C 350 IF (NORD3 .LT. 1) RETURN IF (.NOT. RECENT) CALL BEAM JMIN = J - 10 SIJK = SIT(JMIN,K) SIJJ = SIT(JMIN,JMIN) SIKK = SIT(K,K) COC = SIJK/SQRT(SIJJ*SIKK) RETURN C C BEAM MATRIX CONSTRAINT C 400 IF (NORD3 .LT. 1) RETURN IF (.NOT. RECENT) CALL BEAM COC = SIT(J,K) COC = COC/(UNIT(J)*UNIT(K)) RETURN C C FIRST MOMENT CONSTRAINT C 450 COC = 0.0 IF (SOFA) COC = CO(K)/UNIT(K) RETURN C C CONSTRAINT ON ACCELERATOR ETA FUNCTION C 500 COC = 0.0 IF (RAY) COC = ETA(K)/UNIT(K) RETURN C C T MATRIX CONSTRAINT C 1050 IF (K .GT. 100) GO TO 1070 IF (NORD3 .LT. 2) RETURN KM = K K = KM/10 M = KM - 10*K IF (J .LT. - 20) J = J + 20 J = - J KM = K + M*(M-1)/2 COC = TC2(J,KM)*UNIT(K)*UNIT(M)/UNIT(J) IF (K .NE. M) COC = 2.0*COC RETURN C C U MATRIX CONSTRAINT C 1070 IF (NORD3 .LT. 3) RETURN KMN = K K = KMN/100 MN = KMN - 100*K M = MN/10 N = MN - 10*M IF (J .LT. -20) J = J + 20 J = - J KMN = K + M*(M-1)/2 + N*(N+1)*(N-1)/6 COC = UC2(J,KMN)*UNIT(K)*UNIT(M)*UNIT(N)/UNIT(J) IF (K .NE. M .OR. K .NE. N .OR. M .NE. N) COC = 3.0*COC IF (K .NE. M .AND. K .NE. N .AND. M .NE. N) COC = 2.0*COC RETURN C C LIMITATIONS ON SEXTUPOLE STRENGTH C 1150 COC = 0.0 RETURN C C NUMERICAL CONSTANT C 1200 COC = DATA(I+2) RETURN END SUBROUTINE BEAM COMMON /BLOC12/ RC(6,6), RCV(6,6,20), TC(5,21), UC(5,56), RCP, 1 RVP(20) LOGICAL RCP, RVP COMMON /BLOC13/ RC2(6,6), R2V(6,6,20), TC2(5,21), T2V(5,21,10), 1 UC2(5,56), U2V(5,56,10), R2P, R2VP(20) DIMENSION RC2L(36), R2VL(36,20), TC2L(105), T2VL(105,10), 1 UC2L(280), U2VL(280,10) EQUIVALENCE (RC2(1,1),RC2L(1)), (R2V(1,1,1),R2VL(1,1)), 1 (TC2(1,1),TC2L(1)), (T2V(1,1,1),T2VL(1,1)), 2 (UC2(1,1),UC2L(1)), (U2V(1,1,1),U2VL(1,1)) LOGICAL R2P, R2VP COMMON /BLOC14/ RC3(6,6), TC3(5,21), UC3(5,56), R3P LOGICAL R3P COMMON /BLOC15/ RS(6,6), RT(6,6), TS(5,21), TT(5,21), US(5,56), 1 UT(5,56) DIMENSION RSL(36), RTL(36), TSL(105), TTL(105), USL(280), 1 UTL(280) EQUIVALENCE (RS(1,1),RSL(1)), (RT(1,1),RTL(1)), 1 (TS(1,1),TSL(1)), (TT(1,1),TTL(1)), 2 (US(1,1),USL(1)), (UT(1,1),UTL(1)) COMMON /BLOC16/ SI(6,6), SV(6,6,20), CO(6), COV(6,20), RI, 1 SVP(20), CVP(20), SOFA LOGICAL SVP, CVP, SOFA COMMON /BLOC17/ COD(6), COF(6), PSIX, PSIY, PSIX1, PSIY1, NOPH LOGICAL NOPH COMMON /BLOC18/ SIT(6,6), CEN(6), RECENT LOGICAL RECENT COMMON /BLOC19/ TR(5,6,6), TRA(5,6,6), URR(5,21,6), NORDE COMMON /BLOC30/ CDB, NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, 1 LCPR, ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, 2 LAY191, NPFR INTEGER CDB LOGICAL NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, LCPR, 1 ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, LAY191 COMMON /BLOC34/ NORD1, NORD2, NORD3, NORDX, LINEAR, JH, SIG LOGICAL LINEAR COMMON /CONSTS/ PI, RADIAN, CLIGHT, EMASS C DO 1 J = 1, 6 CEN(J) = 0.0 IF (SOFA) CEN(J) = CO(J) 1 CONTINUE C C FIRST ORDER BEAM MATRIX C IF (NORD3 .LT. 1) GO TO 540 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 RETURN C C BEAM MATRIX CALCULATED FROM TRANSFER MATRIX C AND PREVIOUS BEAM MATRIX C 200 DO 205 JK = 1, 36 205 RSL(JK) = RC2L(JK) IF (NORD1 .EQ. 1) GO TO 220 DO 206 JKL = 1, 105 206 TSL(JKL) = TC2L(JKL) IF (NORD1 .LE. 2) GO TO 220 DO 207 JKLM = 1, 280 207 USL(JKLM) = UC2L(JKLM) 220 CALL CAB(RT,RS,SI) DO 240 J = 1, 6 DO 240 K = 1, J SS = 0.0 DO 235 L1 = 1, 6 SS = SS + RT(J,L1)*RS(K,L1) 235 CONTINUE SIT(J,K) = SS 240 CONTINUE C IF (.NOT. ACCEL) GO TO 300 PSIXO = PSIX PSIYO = PSIY SNPX = RC2(1,2)/SQRT(SI(1,1)*SIT(1,1)) CSPX = RC2(1,1)*SQRT(SI(1,1)/SIT(1,1)) + SI(1,2)*SNPX PSIX = ATAN(SNPX/CSPX) IF (RCP) PSIX = PSIX + PSIX1 IF (CSPX .LT. 0.0) PSIX = PSIX + PI 262 IF (PSIX .GE. PSIXO) GO TO 265 PSIX = PSIX + 2.0*PI GO TO 262 265 SNPY = RC2(3,4)/SQRT(SI(3,3)*SIT(3,3)) CSPY = RC2(3,3)*SQRT(SI(3,3)/SIT(3,3)) + SI(3,4)*SNPY PSIY = ATAN(SNPY/CSPY) IF (RCP) PSIY = PSIY + PSIY1 IF (CSPY .LT. 0.0) PSIY = PSIY + PI 267 IF (PSIY .GE. PSIYO) GO TO 500 PSIY = PSIY + 2.0*PI GO TO 267 C C SECOND ORDER CONTRIBUTIONS C 300 IF (NORD3 .EQ. 1) GO TO 500 C C CENTROID ADJUSTMENT DUE TO SECOND-ORDER TERMS ACTING ON C BEAM WIDTH C DO 360 J = 1, 5 SS = 0.0 IND = 0 DO 355 L1 = 1, 6 DO 355 K = 1, L1 IND = IND + 1 SS = SS + TC2(J,IND)*SI(K,L1) 355 CONTINUE IND1 = 0 DO 356 L1 = 1, 5 L1P1 = L1 + 1 IND1 = IND1 + L1P1 IND = IND1 DO 356 K = L1P1, 6 SS = SS + TC2(J,IND)*SI(L1,K) IND = IND + K 356 CONTINUE CEN(J) = CEN(J) + SS 360 CONTINUE C DO 410 J = 1, 5 DO 410 L1 = 1, 6 INDA = 0 INDB0 = 0 DO 410 K = 1, 6 SS = 0.0 DO 405 L2 = 1, K INDA = INDA + 1 SS = SS + TS(J,INDA)*SI(L1,L2) 405 CONTINUE IF (K .EQ. 6) GO TO 408 KP1 = K + 1 INDB0 = INDB0 + KP1 INDB = INDB0 DO 406 L2 = KP1, 6 SS = SS + TS(J,INDB)*SI(L1,L2) INDB = INDB + L2 406 CONTINUE 408 TR(J,K,L1) = SS 410 CONTINUE C DO 440 J = 1, 5 DO 440 K = 1, J TSST = 0.0 DO 435 L1 = 1, 6 DO 435 L2 = 1, 6 TSST = TSST + TR(J,L1,L2)*TR(K,L2,L1) 435 CONTINUE SIT(J,K) = SIT(J,K) + 2.0*TSST 440 CONTINUE C C SYMMETRIZATION OF RESULT C 500 DO 520 J = 2, 6 JM1 = J - 1 DO 520 K = 1, JM1 SIT(K,J) = SIT(J,K) 520 CONTINUE 540 RECENT = .TRUE. RETURN END SUBROUTINE CAB(C,A,B) DIMENSION C(6,6), A(6,6), B(6,6) C DO 2 J = 1, 6 S1 = 0.0 S2 = 0.0 S3 = 0.0 S4 = 0.0 S5 = 0.0 S6 = 0.0 DO 1 K = 1, 6 BKJ = B(K,J) IF (BKJ .EQ. 0.0) GO TO 1 S1 = S1 + A(1,K)*BKJ S2 = S2 + A(2,K)*BKJ S3 = S3 + A(3,K)*BKJ S4 = S4 + A(4,K)*BKJ S5 = S5 + A(5,K)*BKJ S6 = S6 + A(6,K)*BKJ 1 CONTINUE C(1,J) = S1 C(2,J) = S2 C(3,J) = S3 C(4,J) = S4 C(5,J) = S5 C(6,J) = S6 2 CONTINUE RETURN END SUBROUTINE CABD2(RC,TC,RA,TA,RB,TB) C C COMPUTES RESULT FROM R AND T MATRICES C USING PRELIMINARY CALCULATION C RB AND TB ARE DERIVATIVES C COMMON /BLOC19/ TR(5,6,6), TRA(5,6,6), URR(5,21,6), NORDE DIMENSION RA(6,6), RB(6,6), RC(6,6) DIMENSION TA(5,21), TB(5,21), TC(5,21) DIMENSION S(36) C CALL CAB(RC,RA,RB) C C DO 40 I1 = 1, 5 DO 22 I23 = 1, 21 S(I23) = 0.0 22 CONTINUE DO 30 I4 = 1, 5 RAII = RA(I1,I4) IF (RAII .EQ. 0.0) GO TO 30 I23 = 0 DO 28 I3 = 1, 6 DO 28 I2 = 1, I3 I23 = I23 + 1 S(I23) = S(I23) + RAII*TB(I4,I23) 28 CONTINUE 30 CONTINUE I23 = 0 DO 35 I3 = 1, 6 DO 35 I2 = 1, I3 I23 = I23 + 1 TC(I1,I23) = S(I23) 35 CONTINUE 40 CONTINUE C I230 = 0 DO 60 I3 = 1, 6 DO 43 I12 = 1, 30 S(I12) = 0.0 43 CONTINUE DO 50 I4 = 1, 6 RBII = RB(I4,I3) IF (RBII .EQ. 0.0) GO TO 50 I12 = 0 DO 48 I1 = 1, 5 DO 48 I2 = 1, I3 I12 = I12 + 1 S(I12) = S(I12) + TR(I1,I2,I4)*RBII 48 CONTINUE 50 CONTINUE I12 = 0 DO 55 I1 = 1, 5 I23 = I230 DO 55 I2 = 1, I3 I12 = I12 + 1 I23 = I23 + 1 TC(I1,I23) = TC(I1,I23) + S(I12) 55 CONTINUE I230 = I230 + I3 60 CONTINUE C I230 = 0 DO 90 I2 = 1, 6 DO 73 I13 = 1, 30 S(I13) = 0.0 73 CONTINUE DO 80 I4 = 1, 6 RBII = RB(I4,I2) IF (RBII .EQ. 0.0) GO TO 80 I13 = 0 DO 78 I1 = 1, 5 DO 78 I3 = I2, 6 I13 = I13 + 1 S(I13) = S(I13) + TR(I1,I3,I4)*RBII 78 CONTINUE 80 CONTINUE I13 = 0 I230 = I230 + I2 DO 85 I1 = 1, 5 I23 = I230 DO 85 I3 = I2, 6 I13 = I13 + 1 TC(I1,I23) = TC(I1,I23) + S(I13) I23 = I23 + I3 85 CONTINUE 90 CONTINUE RETURN END SUBROUTINE CABD3(RC,TC,UC,RA,TA,UA,RB,TB,UB,TU) C C COMPUTES RESULT FROM R, T, AND U MATRICES C AND THEIR DERIVATIVES C COMMON /BLOC19/ TR(5,6,6), TRA(5,6,6), URR(5,21,6), NORDE COMMON /BLOC32/ UNIT(12), XDIME(12) DIMENSION RA(6,6), RB(6,6), RC(6,6) DIMENSION TA(5,21), TB(5,21), TC(5,21) DIMENSION UA(5,56), UB(5,56), UC(5,56) DIMENSION TU(5,21) DIMENSION URRL(630) EQUIVALENCE (URR(1,1,1),URRL(1)) DIMENSION S(105) C CALL CABD2(RC,TC,RA,TA,RB,TB) C C PART OF UC FROM RA X DUB C 100 DO 140 I1 = 1, 5 DO 122 I234 = 1, 56 S(I234) = 0.0 122 CONTINUE DO 130 I5 = 1, 5 RAII = RA(I1,I5) IF (RAII .EQ. 0.0) GO TO 130 DO 128 I234 = 1, 56 S(I234) = S(I234) + RAII*UB(I5,I234) 128 CONTINUE 130 CONTINUE DO 135 I234 = 1, 56 UC(I1,I234) = S(I234) 135 CONTINUE 140 CONTINUE C C PART OF UC FROM TA X RB X DTB C TWOTH = 2./3. DO 230 I1 = 1, 5 IND = 0 INDA = 0 INDB0 = 0 DO 220 I4 = 1, 6 INDC = 0 DO 218 I3 = 1, I4 INDA = INDA + 1 INDB = INDB0 DO 216 I2 = 1, I3 IND = IND + 1 INDB = INDB + 1 INDC = INDC + 1 SS = 0.0 DO 210 I6 = 1, 5 SS = SS + TR(I1,I2,I6)*TB(I6,INDA) 1 + TR(I1,I3,I6)*TB(I6,INDB) + TR(I1,I4,I6)*TB(I6,INDC) 210 CONTINUE UC(I1,IND) = UC(I1,IND) + TWOTH*SS 216 CONTINUE 218 CONTINUE INDB0 = INDB0 + I4 220 CONTINUE 230 CONTINUE C C PART OF UC FROM TA X DRB X TB C DO 270 I2 = 1, 6 DO 243 I13 = 1, 30 S(I13) = 0.0 243 CONTINUE C IND0 = 0 DO 260 I4 = 1, 6 RBII = RB(I4,I2) IND1 = IND0 + 1 IND0 = IND0 + I4 IF (RBII .EQ. 0) GO TO 260 I4M1 = I4 - 1 IIM = 6 - I4M1 I13 = 0 DO 248 I1 = 1, 5 IND = IND0 I13 = I13 + I4M1 DO 248 I3 = I4, 6 I13 = I13 + 1 S(I13) = S(I13) + TA(I1,IND)*RBII IND = IND + I3 248 CONTINUE IF (I4 .EQ. 1) GO TO 260 I13 = 0 DO 258 I1 = 1, 5 IND = IND1 DO 255 I3 = 1, I4M1 I13 = I13 + 1 S(I13) = S(I13) + TA(I1,IND)*RBII IND = IND + 1 255 CONTINUE I13 = I13 + IIM 258 CONTINUE 260 CONTINUE C I13 = 0 DO 265 I1 = 1, 5 DO 265 I3 = 1, 6 I13 = I13 + 1 TRA(I1,I2,I3) = S(I13) 265 CONTINUE 270 CONTINUE C DO 300 I1 = 1, 5 IND = 0 INDA = 0 INDB0 = 0 DO 290 I4 = 1, 6 INDC = 0 DO 288 I3 = 1, I4 INDA = INDA + 1 INDB = INDB0 DO 286 I2 = 1, I3 IND = IND + 1 INDB = INDB + 1 INDC = INDC + 1 SS = 0.0 DO 280 I6 = 1, 5 SS = SS + TRA(I1,I2,I6)*TU(I6,INDA) 1 + TRA(I1,I3,I6)*TU(I6,INDB) + TRA(I1,I4,I6)*TU(I6,INDC) 280 CONTINUE UC(I1,IND) = UC(I1,IND) + TWOTH*SS 286 CONTINUE 288 CONTINUE INDB0 = INDB0 + I4 290 CONTINUE 300 CONTINUE C C PART OF UC FROM TA X RB X RB X DRB C DO 350 I1 = 1, 5 DO 302 I234 = 1, 56 S(I234) = 0.0 302 CONTINUE DO 330 I4 = 1, 6 DO 330 I7 = 1, 6 RBII = RB(I7,I4) IF (RBII .EQ. 0.0) GO TO 330 I234 = I4*(I4-1)*(I4+1)/6 IND = 0 DO 305 I3 = 1, I4 DO 305 I2 = 1, I3 I234 = I234 + 1 IND = IND + 1 S(I234) = S(I234) + URR(I1,IND,I7)*RBII 305 CONTINUE C I2430 = I4*(I4-1)*(I4+1)/6 IND0 = I4*(I4-1)/2 DO 316 I3 = I4, 6 I2430 = I2430 + I3*(I3-1)/2 I243 = I2430 IND = IND0 DO 315 I2 = 1, I4 I243 = I243 + 1 IND = IND + 1 S(I243) = S(I243) + URR(I1,IND,I7)*RBII 315 CONTINUE IND0 = IND0 + I3 316 CONTINUE C I4230 = I4*(I4+1)*(I4+2)/6 I4230D = I4*(I4+3)/2 I423D0 = I4*(I4+1)/2 IND0 = I4*(I4-1)/2 DO 326 I2 = I4, 6 I423 = I4230 I423D = I423D0 IND0 = IND0 + I2 IND = IND0 DO 325 I3 = I2, 6 S(I423) = S(I423) + URR(I1,IND,I7)*RBII I423 = I423 + I423D I423D = I423D + I3 + 1 IND = IND + I3 325 CONTINUE I4230 = I4230 + I4230D I4230D = I4230D + I2 + 2 I423D0 = I423D0 + I2 + 1 326 CONTINUE 330 CONTINUE C I234 = 0 DO 335 I4 = 1, 6 DO 335 I3 = 1, I4 DO 335 I2 = 1, I3 I234 = I234 + 1 I234C = I2 + I3*(I3-1)/2 + I4*(I4-1)*(I4+1)/6 UC(I1,I234) = UC(I1,I234) + S(I234) 335 CONTINUE 350 CONTINUE RETURN END SUBROUTINE CABT(C,A,B) DIMENSION C(6,6), A(6,6), B(6,6) 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 CAB2(RC,TC,RA,TA,RB,TB,TRDUN) C C COMPUTES RESULT FROM R AND T MATRICES C COMMON /BLOC19/ TR(5,6,6), TRA(5,6,6), URR(5,21,6), NORDE LOGICAL TRDUN DIMENSION RA(6,6), RB(6,6), RC(6,6) DIMENSION TA(5,21), TB(5,21), TC(5,21) DIMENSION TRL(180), TRAL(180) EQUIVALENCE (TR(1,1,1),TRL(1)), (TRA(1,1,1),TRAL(1)) DIMENSION S(36) C CALL CAB(RC,RA,RB) C IF (TRDUN) GO TO 50 CALL PREMUL(TA,RB,TRA) GO TO 100 C 50 DO 60 I1 = 1, 180 60 TRAL(I1) = TRL(I1) C 100 DO 140 I1 = 1, 5 DO 122 I23 = 1, 21 S(I23) = 0.0 122 CONTINUE DO 130 I4 = 1, 5 RAII = RA(I1,I4) IF (RAII .EQ. 0.0) GO TO 130 I23 = 0 DO 128 I3 = 1, 6 DO 128 I2 = 1, I3 I23 = I23 + 1 S(I23) = S(I23) + RAII*TB(I4,I23) 128 CONTINUE 130 CONTINUE I23 = 0 DO 135 I3 = 1, 6 DO 135 I2 = 1, I3 I23 = I23 + 1 TC(I1,I23) = S(I23) 135 CONTINUE 140 CONTINUE C I230 = 0 DO 160 I3 = 1, 6 DO 143 I12 = 1, 30 S(I12) = 0.0 143 CONTINUE DO 150 I4 = 1, 6 RBII = RB(I4,I3) IF (RBII .EQ. 0.0) GO TO 150 I12 = 0 DO 148 I1 = 1, 5 DO 148 I2 = 1, I3 I12 = I12 + 1 S(I12) = S(I12) + TRA(I1,I2,I4)*RBII 148 CONTINUE 150 CONTINUE I12 = 0 DO 155 I1 = 1, 5 I23 = I230 DO 155 I2 = 1, I3 I12 = I12 + 1 I23 = I23 + 1 TC(I1,I23) = TC(I1,I23) + S(I12) 155 CONTINUE I230 = I230 + I3 160 CONTINUE RETURN END SUBROUTINE CAB3(RC,TC,UC,RA,TA,UA,RB,TB,UB,URDUN) C C COMPUTES RESULT FROM R AND T MATRICES C COMMON /BLOC19/ TR(5,6,6), TRA(5,6,6), URR(5,21,6), NORDE DIMENSION RA(6,6), RB(6,6), RC(6,6) DIMENSION TA(5,21), TB(5,21), TC(5,21) DIMENSION UA(5,56), UB(5,56), UC(5,56) DIMENSION URA(5,21,6) DIMENSION URRL(630), URAL(630) EQUIVALENCE (URR(1,1,1),URRL(1)), (URA(1,1,1),URAL(1)) DIMENSION S(105) LOGICAL URDUN C CALL CAB2(RC,TC,RA,TA,RB,TB,URDUN) C IF (URDUN) GO TO 50 CALL PREML3(UA,RB,URA) GO TO 100 C 50 DO 60 I1 = 1, 630 60 URAL(I1) = URRL(I1) C C PART OF UC FROM RA X UB C 100 DO 140 I1 = 1, 5 DO 122 I234 = 1, 56 S(I234) = 0.0 122 CONTINUE DO 130 I5 = 1, 5 RAII = RA(I1,I5) IF (RAII .EQ. 0.0) GO TO 130 DO 128 I234 = 1, 56 S(I234) = S(I234) + RAII*UB(I5,I234) 128 CONTINUE 130 CONTINUE DO 135 I234 = 1, 56 UC(I1,I234) = S(I234) 135 CONTINUE 140 CONTINUE C C PART OF UC FROM TA X RB X TB C TWOTH = 2./3. DO 230 I1 = 1, 5 IND = 0 INDA = 0 INDB0 = 0 DO 220 I4 = 1, 6 INDC = 0 DO 218 I3 = 1, I4 INDA = INDA + 1 INDB = INDB0 DO 216 I2 = 1, I3 IND = IND + 1 INDB = INDB + 1 INDC = INDC + 1 SS = 0.0 DO 210 I6 = 1, 5 SS = SS + TRA(I1,I2,I6)*TB(I6,INDA) 1 + TRA(I1,I3,I6)*TB(I6,INDB) + TRA(I1,I4,I6)*TB(I6,INDC) 210 CONTINUE UC(I1,IND) = UC(I1,IND) + TWOTH*SS 216 CONTINUE 218 CONTINUE INDB0 = INDB0 + I4 220 CONTINUE 230 CONTINUE C C PART OF UC FROM TA X RB X RB X RB C DO 330 I4 = 1, 6 DO 302 I123 = 1, 105 S(I123) = 0.0 302 CONTINUE DO 308 I7 = 1, 6 RBII = RB(I7,I4) IF (RBII .EQ. 0.0) GO TO 308 I123 = 0 DO 305 I1 = 1, 5 IND = 0 DO 305 I3 = 1, 6 DO 305 I2 = 1, I3 I123 = I123 + 1 IND = IND + 1 S(I123) = S(I123) + URA(I1,IND,I7)*RBII 305 CONTINUE 308 CONTINUE C I1230 = 0 I2340 = I4*(I4-1)*(I4+1)/6 DO 318 I1 = 1, 5 I123 = I1230 I234 = I2340 DO 315 I3 = 1, I4 DO 315 I2 = 1, I3 I123 = I123 + 1 I234 = I234 + 1 UC(I1,I234) = UC(I1,I234) + S(I123) 315 CONTINUE I1230 = I1230 + 21 318 CONTINUE 330 CONTINUE RETURN END SUBROUTINE CHEK (CKK) COMMON /BLOC1/ NEL, NUM, NDIF, I, ISTOR(3129), DATA(13160) COMMON /BLOC2/ NIN, NOUT, NPUNCH COMMON /BLOC5/ VSTOR(20), TIE(13160), LABEL(3129), LABM(10) INTEGER VSTOR, TIE COMMON /BLOC16/ SI(6,6), SV(6,6,20), CO(6), COV(6,20), RI, 1 SVP(20), CVP(20), SOFA LOGICAL SVP, CVP, SOFA COMMON /BLOC21/ EN, ES, BE, APB(2), LAYK, LAYL, LAYX, RABT REAL LAYK, LAYL, LAYX COMMON /BLOC22/ LBEND, BE1, SB, TB, TB1, NBVARY, BEFORE LOGICAL BEFORE REAL LBEND COMMON /BLOC24/ B, KQ2, KVK, K2H, K2V, CS, SN, DISN, DSVN, J REAL KQ2, KVK, K2H, K2V COMMON /BLOC23/ H0, AL, NB, BDB, RMPS, VRN, NPN, BDBP, RNMS, DCOV LOGICAL DCOV REAL NB, NPN COMMON /BLOC30/ CDB, NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, 1 LCPR, ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, 2 LAY191, NPFR INTEGER CDB LOGICAL NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, LCPR, 1 ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, LAY191 COMMON /BLOC32/ UNIT(12), XDIME(12) COMMON /BLOC33/ FOTILT, SM, TH, PREF COMMON /BLOC49/ PRAN2, PRAN3, PRAN4(3), PRAN5(3), PRAN7(6), 1 PRAN11(4), PRAN16(30), PRAN18(3), PRAN19(2), 2 PRAN20, PRAN25(3) COMMON /BLOC50/ BDBI, LAYKI, LAYLI, LAYXI, RAB1I, RAB2I, RMPSI, 1 VRNI, NPNI, BDBPI, RNMSI REAL LAYKI, LAYLI, LAYXI, NPNI REAL L C CKK = 1. C C* CHEK TO SEE IF INTERVENING CARDS ARE I/O CONTROLS C J = NUM DO 10 K = 1, 5 J = J + NDIF IF (J .LE. 0) GO TO 20 IF (J .GT. NEL) GO TO 20 II = ISTOR(J) IF (DATA(II) .EQ. 4.0) GO TO 50 IF (DATA(II) .NE. 13.0) GO TO 20 10 CONTINUE 20 J = NUM DO 30 K = 1, 5 J = J - NDIF IF (J .LE. 0) GO TO 40 IF (J .GT. NEL) GO TO 40 II = ISTOR(J) IF (DATA(II) .EQ. 4.0) GO TO 60 IF (DATA(II) .NE. 13.0) GO TO 40 30 CONTINUE 40 WRITE (NOUT, 140) 140 FORMAT (44H0*** 4. TYPE CODE NOT FOUND FOR 2. TYPE CODE) CKK = 0. RETURN C C SET FRINGING FIELD PARAMETERS C 50 BEFORE = .TRUE. ES = 1.0 EN = 1.0 LBEND = DATA(II+1)*UNIT(8) IF (PRAN4(1) .NE. 0.0) 1 LBEND = LBEND + PRAN4(1)*RANDIS(-1) PAR2 = DATA(II+2) IF (PRAN4(2) .NE. 0.0) 1 PAR2 = PAR2 + PRAN4(2)*RANDIS(-1) RMPS = RMPSI IF (PRAN16(22) .NE. 0.0) 1 RMPS = RMPS + PRAN16(22)*RANDIS(-1) NB = DATA(II+3) IF (PRAN4(3) .NE. 0.0) NB = NB + PRAN4(3)*RANDIS(-1) IF (ANIN) GO TO 55 B = PAR2*UNIT(9)*RI/PREF H0 = B/RI B = B*(1.0 + RMPS) AL = H0*LBEND GO TO 70 55 AL = PAR2*UNIT(7) H0 = AL/LBEND B = RI*H0*(1.0 + RMPS) GO TO 70 C 60 BEFORE = .FALSE. ES = - 1.0 EN = 0.0 C 70 NBVARY = TIE(II+2) IF (NPFR .EQ. 0) RETURN IF (NPFR .EQ. 1) BE = 0.5*AL IF (NPFR .EQ. 2 .AND. BEFORE) BE = 0.0 IF (NPFR .EQ. 2 .AND. .NOT. BEFORE) BE = AL IF (NPFR .EQ. 3 .AND. BEFORE) BE = AL IF (NPFR .EQ. 3 .AND. .NOT. BEFORE) BE = 0.0 IF (PRAN2 .NE. 0.0) BE = BE + PRAN2*RANDIS(-1)*UNIT(7) DATA(I+1) = BE/UNIT(7) RETURN END SUBROUTINE CLI(LOGIC) COMMON /BLOC28/ COC, DE0, SD, CTY, JV, NC, NV1, NV2, NV3 INTEGER CTY COMMON /BLOC29/ A(21), CW, CA(21,21), SCALE(21), CASAV(21,21), 1 PMARQ, CHSMIN, XNORM, GNORM, EPS LOGICAL LOGIC C LOGIC = .FALSE. IF (CTY .EQ. 0) RETURN IF ((CTY .EQ. 1) .AND. (A(1) .GT. 0.0)) RETURN IF ((CTY .EQ. 2) .AND. (A(1) .LT. 0.0)) RETURN A(1) = 0.0 NC = NC - 1 LOGIC = .TRUE. RETURN END SUBROUTINE COMBIN(ID) COMMON /BLOC1/ NEL, NUM, NDIF, I, ISTOR(3129), DATA(13160) COMMON /BLOC28/ COC, DE0, SD, CTY, JV, NC, NV1, NV2, NV3 INTEGER CTY COMMON /BLOC44/ REG(20), DREG(20,20), LREG(20) LOGICAL LREG C K1 = DATA(I+1) K2 = DATA(I+2) IOP = DATA(I+3) J = DATA(I+4) IF (J .GT. 20 .OR. K1 .GT. 20) RETURN IF (.NOT. LREG(K1)) RETURN IF (NV1 .GE. 20) GO TO 6 NP1 = NV1 + 1 DO 5 JJ = NP1, 20 5 DREG(J,JJ) = 0.0 6 GO TO (10,20,30,40,50), IOP C C ADDITION C 10 IF (K2 .GT. 20) RETURN IF (.NOT. LREG(K2)) RETURN REG(J) = REG(K1) + REG(K2) LREG(J) = .TRUE. IF (ID .EQ. 0) RETURN DO 15 N = 1, NV1 15 DREG(J,N) = DREG(K1,N) + DREG(K2,N) RETURN C C SUBTRACTION C 20 IF (K2 .GT. 20) RETURN IF (.NOT. LREG(K2)) RETURN REG(J) = REG(K1) - REG(K2) LREG(J) = .TRUE. IF (ID .EQ. 0) RETURN DO 25 N = 1, NV1 25 DREG(J,N) = DREG(K1,N) - DREG(K2,N) RETURN C C MULTIPLICATION C 30 IF (K2 .GT. 20) RETURN IF (.NOT. LREG(K2)) RETURN PROD = REG(K1)*REG(K2) IF (ID .EQ. 0) GO TO 38 DO 35 N = 1, NV1 35 DREG(J,N) = REG(K1)*DREG(K2,N) + DREG(K1,N)*REG(K2) 38 REG(J) = PROD LREG(J) = .TRUE. RETURN C C DIVISION C 40 IF (K2 .GT. 20) RETURN IF (.NOT. LREG(K2)) RETURN QUOT = REG(K1)/REG(K2) IF (ID .EQ. 0) GO TO 48 DO 45 N = 1, NV1 45 DREG(J,N) = (REG(K2)*DREG(K1,N) - REG(K1)*DREG(K2,N))/REG(K2)**2 48 REG(J) = QUOT LREG(J) = .TRUE. RETURN C C SQUARE ROOT C 50 ROOT = SQRT(REG(K1)) IF (ID .EQ. 0) GO TO 58 DO 55 N = 1, NV1 55 DREG(J,N) = 0.5*DREG(K1,N)/ROOT 58 REG(J) = ROOT LREG(J) = .TRUE. RETURN END SUBROUTINE CONDOR COMMON /BLOC1/ NEL, NUM, NDIF, I, ISTOR(3129), DATA(13160) COMMON /BLOC3/ TYPE, L, LV INTEGER TYPE REAL L, LV COMMON /BLOC12/ RC(6,6), RCV(6,6,20), TC(5,21), UC(5,56), RCP, 1 RVP(20) LOGICAL RCP, RVP COMMON /BLOC13/ RC2(6,6), R2V(6,6,20), TC2(5,21), T2V(5,21,10), 1 UC2(5,56), U2V(5,56,10), R2P, R2VP(20) LOGICAL R2P, R2VP COMMON /BLOC14/ RC3(6,6), TC3(5,21), UC3(5,56), R3P LOGICAL R3P COMMON /BLOC16/ SI(6,6), SV(6,6,20), CO(6), COV(6,20), RI, 1 SVP(20), CVP(20), SOFA LOGICAL SVP, CVP, SOFA COMMON /BLOC28/ COC, DE0, SD, CTY, JV, NC, NV1, NV2, NV3 INTEGER CTY COMMON /BLOC29/ A(21), CW, CA(21,21), SCALE(21), CASAV(21,21), 1 PMARQ, CHSMIN, XNORM, GNORM, EPS COMMON /BLOC30/ CDB, NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, 1 LCPR, ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, 2 LAY191, NPFR INTEGER CDB LOGICAL NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, LCPR, 1 ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, LAY191 COMMON /BLOC32/ UNIT(12), XDIME(12) C J = DATA(I+1) K = DATA(I+2) DE0 = 0.0 SD = 1.0 IF (TYPE .NE. 10) GO TO 10 DE0 = DATA(I+3) SD = DATA(I+4) NC = NC + 1 10 NP1 = NV1 + 1 IF (J .LT. 0) GO TO 70 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 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 = UNIT(K)*UNIT(LL)*UNIT(M)/UNIT(J) A(1) = - UC2(J,KLM)*FAC IF (K .NE. LL .OR. LL .NE. M .OR. K .NE. M) A(1) = 3.0*A(1) IF (K .NE. LL .AND. LL .NE. M .AND. K .NE. M) A(1) = 2.0*A(1) A(1) = DE0 + A(1) C IF (NV1 .LT. 1) GO TO 120 DO 110 N = 1, NV1 IF (.NOT. R2VP(N)) GO TO 110 IF (R2VP(N)) A(N+1) = U2V(J,KLM,N)*FAC IF (K .NE. LL .OR. LL .NE. M .OR. K .NE. M ) A(N+1) = 3.0*A(N+1) IF (K .NE. LL .AND. LL .NE. M .AND. K .NE. M ) A(N+1) = 2.0*A(N+1) 110 CONTINUE 120 CALL GATHER RETURN C C MINIMIZATION OF CONTRIBUTION OF THIRD-ORDER ABERRATIONS TO BEAM C 200 IF (ACCEL) RETURN CW = 1.0/SD**2 RETURN END SUBROUTINE CONSEC COMMON /BLOC1/ NEL, NUM, NDIF, I, ISTOR(3129), DATA(13160) COMMON /BLOC3/ TYPE, L, LV INTEGER TYPE REAL L, LV COMMON /BLOC12/ RC(6,6), RCV(6,6,20), TC(5,21), UC(5,56), RCP, 1 RVP(20) LOGICAL RCP, RVP COMMON /BLOC13/ RC2(6,6), R2V(6,6,20), TC2(5,21), T2V(5,21,10), 1 UC2(5,56), U2V(5,56,10), R2P, R2VP(20) LOGICAL R2P, R2VP DIMENSION RC2L(36), R2VL(36,20), TC2L(105), T2VL(105,10), 1 UC2L(280), U2VL(280,10) EQUIVALENCE (RC2(1,1),RC2L(1)), (R2V(1,1,1),R2VL(1,1)), 1 (TC2(1,1),TC2L(1)), (T2V(1,1,1),T2VL(1,1)), 2 (UC2(1,1),UC2L(1)), (U2V(1,1,1),U2VL(1,1)) COMMON /BLOC14/ RC3(6,6), TC3(5,21), UC3(5,56), R3P LOGICAL R3P COMMON /BLOC15/ RS(6,6), RT(6,6), TS(5,21), TT(5,21), US(5,56), 1 UT(5,56) DIMENSION RSL(36), RTL(36), TSL(105), TTL(105), USL(280), 1 UTL(280) EQUIVALENCE (RS(1,1),RSL(1)), (RT(1,1),RTL(1)), 1 (TS(1,1),TSL(1)), (TT(1,1),TTL(1)), 2 (US(1,1),USL(1)), (UT(1,1),UTL(1)) COMMON /BLOC16/ SI(6,6), SV(6,6,20), CO(6), COV(6,20), RI, 1 SVP(20), CVP(20), SOFA LOGICAL SVP, CVP, SOFA COMMON /BLOC28/ COC, DE0, SD, CTY, JV, NC, NV1, NV2, NV3 INTEGER CTY COMMON /BLOC29/ A(21), CW, CA(21,21), SCALE(21), CASAV(21,21), 1 PMARQ, CHSMIN, XNORM, GNORM, EPS COMMON /BLOC30/ CDB, NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, 1 LCPR, ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, 2 LAY191, NPFR INTEGER CDB LOGICAL NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, LCPR, 1 ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, LAY191 COMMON /BLOC32/ UNIT(12), XDIME(12) COMMON /BLOC34/ NORD1, NORD2, NORD3, NORDX, LINEAR, JH, SIG LOGICAL LINEAR COMMON /BLOC36/ VARS(8), SEXMAX, SEXLIM INTEGER VARS LOGICAL SEXLIM REAL TCS(11), TCSX(6,6,11) C J = DATA(I+1) K = DATA(I+2) DE0 = 0.0 SD = 1.0 IF (TYPE .NE. 10) GO TO 10 DE0 = DATA(I+3) SD = DATA(I+4) NC = NC + 1 10 NP1 = NV1 + 1 IF (J .EQ. 18) GO TO 300 IF (J .LT. 0) GO TO 70 GO TO 200 C C SECOND ORDER MATRIX ELEMENT CONSTRAINT C 70 IF (J .LT. - 20) J = J + 20 J = - J KM = K K = KM/10 M = KM - 10*K KM = K + M*(M-1)/2 DO 80 L1 = 1, NP1 80 A(L1) = 0.0 CW = 1.0/SD**2 FAC = UNIT(K)*UNIT(M)/UNIT(J) A(1) = - TC2(J,KM)*FAC IF (K .NE. M) A(1) = 2.0*A(1) A(1) = DE0 + A(1) C IF (NV1 .LT. 1) GO TO 140 DO 130 N = 1, NV1 IF (.NOT. R2VP(N)) GO TO 130 A(N+1) = T2V(J,KM,N)*FAC IF (K .NE. M) A(N+1) = 2.0*A(N+1) 130 CONTINUE 140 CALL GATHER RETURN C C MINIMIZATION OF CONTRIBUTION OF SECOND-ORDER ABERRATIONS TO BEAM C 200 IF (ACCEL) RETURN CW = 1.0/(SD*UNIT(J))**2 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 IND = 0 DO 211 L2 = 2, 6 L2M1 = L2 - 1 IND = IND + 1 DO 211 L1 = 1, L2M1 IND = IND + 1 SS = SS + TC2(J,IND)*SI(L1,L2) 211 CONTINUE TCS(1) = - SS C IF (NV1 .LT. 1) GO TO 225 DO 220 N = 1, NV1 SS = 0.0 IF (.NOT. R2VP(N)) GO TO 217 IND = 0 DO 215 L2 = 1, 6 DO 215 L1 = 1, L2 IND = IND + 1 SS = SS + T2V(J,IND,N)*SI(L1,L2) 215 CONTINUE IND = 0 DO 216 L2 = 2, 6 L2M1 = L2 - 1 IND = IND + 1 DO 216 L1 = 1, L2M1 IND = IND + 1 SS = SS + T2V(J,IND,N)*SI(L1,L2) 216 CONTINUE 217 TCS(N+1) = SS 220 CONTINUE C 225 IND0 = 0 IND1 = 0 DO 230 L1 = 1, 6 L1P1 = L1 + 1 IND0 = IND0 + L1 - 1 IND1 = IND1 + L1P1 DO 230 L2 = 1, 6 SS = 0.0 IND = IND0 DO 227 L3 = 1, L1 IND = IND + 1 SS = SS + TC2(J,IND)*SI(L2,L3) 227 CONTINUE IND = IND1 IF (L1 .EQ. 6) GO TO 229 DO 228 L3 = L1P1, 6 SS = SS + TC2(J,IND)*SI(L2,L3) IND = IND + L3 228 CONTINUE 229 TCSX(L1,L2,1) = - SS 230 CONTINUE C IF (NV1 .LT. 1) GO TO 241 DO 240 N = 1, NV1 IND0 = 0 IND1 = 0 DO 240 L1 = 1, 6 L1P1 = L1 + 1 IND0 = IND0 + L1 - 1 IND1 = IND1 + L1P1 DO 240 L2 = 1, 6 SS = 0.0 IND = IND0 IF (.NOT. R2VP(N)) GO TO 238 DO 235 L3 = 1, L1 IND = IND + 1 SS = SS + T2V(J,IND,N)*SI(L2,L3) 235 CONTINUE IND = IND1 IF (L1 .EQ. 6) GO TO 238 DO 236 L3 = L1P1, 6 SS = SS + T2V(J,IND,N)*SI(L2,L3) IND = IND + L3 236 CONTINUE 238 TCSX(L1,L2,N+1) = SS 240 CONTINUE C 241 DO 250 L1 = 1, NP1 DO 250 L2 = 1, L1 SS = 0.0 DO 245 L3 = 1, 6 DO 245 L4 = 1, 6 SS = SS + TCSX(L3,L4,L1)*TCSX(L4,L3,L2) 245 CONTINUE CA(L1,L2) = CA(L1,L2) + (TCS(L1)*TCS(L2) + 2.0*SS)*CW 250 CONTINUE RETURN C C LIMITATIONS ON SEXTUPOLE STRENGTH C 300 SEXLIM = .TRUE. SEXMAX = SD*UNIT(9) RETURN END SUBROUTINE CONSTR COMMON /BLOC1/ NEL, NUM, NDIF, I, ISTOR(3129), DATA(13160) COMMON /BLOC2/ NIN, NOUT, NPUNCH COMMON /BLOC3/ TYPE, L, LV INTEGER TYPE REAL L, LV COMMON /BLOC4/ LC, TOTANG, TOTROT, LCV(20), LUP(3) REAL LC, LCV, LUP COMMON /BLOC5/ VSTOR(20), TIE(13160), LABEL(3129), LABM(10) INTEGER VSTOR, TIE COMMON /BLOC12/ RC(6,6), RCV(6,6,20), TC(5,21), UC(5,56), RCP, 1 RVP(20) LOGICAL RCP, RVP COMMON /BLOC13/ RC2(6,6), R2V(6,6,20), TC2(5,21), T2V(5,21,10), 1 UC2(5,56), U2V(5,56,10), R2P, R2VP(20) LOGICAL R2P, R2VP DIMENSION RC2L(36), R2VL(36,20), TC2L(105), T2VL(105,10), 1 UC2L(280), U2VL(280,10) EQUIVALENCE (RC2(1,1),RC2L(1)), (R2V(1,1,1),R2VL(1,1)), 1 (TC2(1,1),TC2L(1)), (T2V(1,1,1),T2VL(1,1)), 2 (UC2(1,1),UC2L(1)), (U2V(1,1,1),U2VL(1,1)) COMMON /BLOC14/ RC3(6,6), TC3(5,21), UC3(5,56), R3P LOGICAL R3P COMMON /BLOC15/ RS(6,6), RT(6,6), TS(5,21), TT(5,21), US(5,56), 1 UT(5,56) DIMENSION RSL(36), RTL(36), TSL(105), TTL(105), USL(280), 1 UTL(280) EQUIVALENCE (RS(1,1),RSL(1)), (RT(1,1),RTL(1)), 1 (TS(1,1),TSL(1)), (TT(1,1),TTL(1)), 2 (US(1,1),USL(1)), (UT(1,1),UTL(1)) COMMON /BLOC16/ SI(6,6), SV(6,6,20), CO(6), COV(6,20), RI, 1 SVP(20), CVP(20), SOFA LOGICAL SVP, CVP, SOFA COMMON /BLOC17/ COD(6), COF(6), PSIX, PSIY, PSIX1, PSIY1, NOPH LOGICAL NOPH COMMON /BLOC18/ SIT(6,6), CEN(6), RECENT LOGICAL RECENT COMMON /BLOC20/ ETA(6), DETA(6,20), RAY, EVP(20) LOGICAL RAY, EVP COMMON /BLOC24/ B, KQ2, KVK, K2H, K2V, CS, SN, DISN, DSVN, J REAL KQ2, KVK, K2H, K2V COMMON /BLOC26/ O(4,3,3), X0(4,3), IR, RORC, TYT, ALIGN, TMK, 1 FEO, CHORD INTEGER RORC, TYT LOGICAL ALIGN, TMK, FEO, CHORD COMMON /BLOC28/ COC, DE0, SD, CTY, JV, NC, NV1, NV2, NV3 INTEGER CTY COMMON /BLOC29/ A(21), CW, CA(21,21), SCALE(21), CASAV(21,21), 1 PMARQ, CHSMIN, XNORM, GNORM, EPS COMMON /BLOC30/ CDB, NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, 1 LCPR, ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, 2 LAY191, NPFR INTEGER CDB LOGICAL NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, LCPR, 1 ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, LAY191 COMMON /BLOC32/ UNIT(12), XDIME(12) COMMON /BLOC34/ NORD1, NORD2, NORD3, NORDX, LINEAR, JH, SIG LOGICAL LINEAR COMMON /BLOC40/ OV(3,3,20), X0V(3,20), OIV(3,3), XIV(3), OVP(20) LOGICAL OVP COMMON /BLOC44/ REG(20), DREG(20,20), LREG(20) LOGICAL LREG COMMON /CONSTS/ PI, RADIAN, CLIGHT, EMASS LOGICAL LOGIC C CTY = TIE(I+1) IF (CTY .EQ. 21) CTY = 1 IF (CTY .EQ. 30) CTY = 2 J = DATA(I + 1) K = DATA(I + 2) DE0 = 0.0 SD = 1.0 IF (TYPE .NE. 10) GO TO 10 DE0 = DATA(I + 3) SD = DATA(I + 4) NC = NC + 1 10 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) 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 CW = 1.0/SD**2 A(1) = DE0 - LC/UNIT(8) CALL CLI (LOGIC) IF (LOGIC) RETURN IF (NV1 .LT. 1) GO TO 105 DO 101 N = 1, NV1 A(N+1) = LCV(N)/UNIT(8) 101 CONTINUE 105 CALL GATHER RETURN C C FLOOR COORDINATE CONSTRAINT C 110 IF (K .GE. 4) GO TO 120 CW = 1.0/SD**2 A(1) = DE0 - X0(4,K)/UNIT(8) IF (NV1 .LT. 1) GO TO 115 DO 111 N = 1, NV1 IF (.NOT. OVP(N)) GO TO 111 A(N+1) = X0V(K,N)/UNIT(8) 111 CONTINUE 115 CALL GATHER RETURN C 120 CW = 1.0/SD**2 IF (K .EQ. 5) GO TO 125 IF (K .EQ. 6) GO TO 130 THETA = ATAN(O(4,3,1)/O(4,3,3)) IF (O(4,3,3) .GE. 0.0) GO TO 121 SHIFT = SIGN(PI,O(4,3,1)) THETA = THETA + SHIFT 121 A(1) = DE0 - THETA/UNIT(7) IF (NV1 .LT. 1) GO TO 124 DO 123 N = 1, NV1 IF (.NOT. OVP(N)) GO TO 123 A(N+1) = (O(4,3,3)*OV(3,1,N) - O(4,3,1)*OV(3,3,N))/ 1 (O(4,3,3)**2 + O(4,3,1)**2) A(N+1) = A(N+1)/UNIT(7) 123 CONTINUE 124 CALL GATHER RETURN C 125 A(1) = DE0 - ASIN(O(4,3,2))/UNIT(7) IF (NV1 .LT. 1) GO TO 128 DO 126 N = 1, NV1 IF (.NOT. OVP(N)) GO TO 126 A(N+1) = (OV(3,2,N)/SQRT(1.0 - O(4,3,2)**2))/UNIT(7) 126 CONTINUE 128 CALL GATHER RETURN C 130 PITCH = ATAN(O(4,1,2)/O(4,2,2)) IF (O(4,2,2) .GE. 0.0) GO TO 131 SHIFT = SIGN(PI,O(4,1,2)) PITCH = PITCH + SHIFT 131 A(1) = DE0 - PITCH/UNIT(7) IF (NV1 .LT. 1) GO TO 134 DO 133 N = 1, NV1 IF (.NOT. OVP(N)) GO TO 133 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)/UNIT(7) 133 CONTINUE 134 CALL GATHER RETURN C C CONSTRAINT ON ALGEBRAIC COMBINATION OF MATRIX ELEMENTS C 135 IF (K .GT. 20) RETURN IF (.NOT. LREG(K)) RETURN CW = 1.0/SD**2 A(1) = DE0 - REG(K) IF (NV1 .LT. 1) GO TO 138 DO 136 N = 1, NV1 136 A(N+1) = DREG(K,N) 138 CALL GATHER RETURN C C TRANSFER MATRIX CONSTRAINTS C 140 IF (R3P) CALL UPDAT3 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 IF (NORD3 .LT. 1) RETURN IF (K .GT. 10) GO TO 180 J = - (J + 20) CW = 1.0/SD**2 FAC = UNIT(K)/UNIT(J) A(1) = DE0 - RC2(J,K)*FAC CALL CLI(LOGIC) IF (LOGIC) RETURN C IF (NV1 .LT. 1) GO TO 165 DO 160 N = 1, NV1 IF (.NOT. R2VP(N)) GO TO 160 A(N+1) = R2V(J,K,N)*FAC 160 CONTINUE 165 CALL GATHER RETURN C C T2 MATRIX CONSTRAINT C 180 IF (K .GT. 100) GO TO 190 IF (NORD3 .GE. 2) CALL CONSEC RETURN C C U2 MATRIX CONSTRAINT C 190 IF (NORD3 .GE. 3) CALL CONDOR RETURN C C AGS MACHINE CONSTRAINT C 200 IF (NORD3 .LT. 1) RETURN J = - (J + 10) IF (RCP) GO TO 210 RCT = RC2(J,J) + RC2(K,K) GO TO 215 210 IF (R2P) GO TO 212 RCT = RC(J,J) + RC(K,K) GO TO 215 212 RCT = 0.0 DO 213 L1 = 1, 6 RCT = RCT + RC2(J,L1)*RC(L1,J) + RC2(K,L1)*RC(L1,K) 213 CONTINUE 215 A(1) = 2.0*COS(2.0*PI*DE0) - RCT CALL CLI(LOGIC) IF (LOGIC) RETURN C CW = ( - 1.0/(4.0*PI*SIN(2.0*PI*DE0)*SD))**2 IF (NV1 .LT. 1) GO TO 245 DO 240 N = 1, NV1 RCTV = 0.0 IF (.NOT. (RVP(N) .OR. R2VP(N))) GO TO 240 IF (RCP) GO TO 225 RCTV = R2V(J,J,N) + R2V(K,K,N) GO TO 235 225 IF (R2P) GO TO 228 RCTV = RCV(J,J,N) + RCV(K,K,N) GO TO 235 228 IF (R2VP(N)) GO TO 230 DO 229 L1 = 1, 6 RCTV = RCTV + RC2(J,L1)*RCV(L1,J,N) + RC2(K,L1)*RCV(L1,K,N) 229 CONTINUE GO TO 235 230 IF (RVP(N)) GO TO 232 DO 231 L1 = 1, 6 RCTV = RCTV + R2V(J,L1,N)*RC(L1,J) + R2V(K,L1,N)*RC(L1,K) 231 CONTINUE GO TO 235 232 DO 233 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) 233 CONTINUE 235 A(N+1) = RCTV 240 CONTINUE 245 CALL GATHER RETURN C C R MATRIX CONSTRAINT C 250 IF (NORD3 .LT. 1) RETURN IF (K .GT. 10) GO TO 297 J = - J CW = 1.0/SD**2 FAC = UNIT(K)/UNIT(J) IF (RCP) GO TO 260 RCT = RC2(J,K) GO TO 265 260 IF (R2P) GO TO 262 RCT = RC(J,K) GO TO 265 262 RCT = 0.0 DO 263 L1 = 1, 6 RCT = RCT + RC2(J,L1)*RC(L1,K) 263 CONTINUE 265 A(1) = DE0 - RCT*FAC CALL CLI(LOGIC) IF (LOGIC) RETURN C IF (NV1 .LT. 1) GO TO 295 DO 290 N = 1, NV1 RCTV = 0.0 IF (.NOT. (RVP(N) .OR. R2VP(N))) GO TO 285 IF (RCP) GO TO 277 RCTV = R2V(J,K,N) GO TO 285 277 IF (R2P) GO TO 278 RCTV = RCV(J,K,N) GO TO 285 278 IF (R2VP(N)) GO TO 280 DO 279 L1 = 1, 6 RCTV = RCTV + RC2(J,L1)*RCV(L1,K,N) 279 CONTINUE GO TO 285 280 IF (RVP(N)) GO TO 282 DO 281 L1 = 1, 6 RCTV = RCTV + R2V(J,L1,N)*RC(L1,K) 281 CONTINUE GO TO 285 282 DO 283 L1 = 1, 6 RCTV = RCTV + R2V(J,L1,N)*RC(L1,K) + RC2(J,L1)*RCV(L1,K,N) 283 CONTINUE 285 A(N+1) = RCTV*FAC 290 CONTINUE 295 CALL GATHER RETURN C C T MATRIX CONSTRAINT C 297 IF (K .GT. 100) GO TO 298 IF (NORD3 .GE. 2) CALL CONSEC RETURN C C U MATRIX CONSTRAINT C 298 IF (NORD3 .GE. 3) CALL CONDOR RETURN C C BEAM CONSTRAINTS C 300 IF (J .EQ. K) GO TO 350 IF (J .GT. 10 .AND. J .LE. 16) GO TO 400 IF (J .EQ. 0 .OR. J .EQ. 7) GO TO 450 IF (J .EQ. 27) GO TO 500 C C BEAM MATRIX CONSTRAINT C IF (NORD3 .LT. 1) RETURN IF (ACCEL) RETURN IF (.NOT. RECENT) CALL BEAM CW = 1.0/SD**2 FAC = 1.0/(UNIT(J)*UNIT(K)) IF (J .GT. 6 .OR. K .GT. 6) WRITE (NOUT,3000) J, K A(1) = DE0 - SIT(J,K)*FAC CALL CLI(LOGIC) IF (LOGIC) RETURN C IF (NV1 .LT. 1) GO TO 345 DO 340 N = 1, NV1 IF (R2P) GO TO 310 IF (.NOT. SVP(N)) GO TO 340 SVJK = SV(J,K,N) GO TO 330 310 SVJK = 0.0 IF (.NOT. SVP(N)) GO TO 320 DO 311 L1 = 1, 6 DO 311 L2 = 1, 6 SVJK = SVJK + RC2(J,L1)*SV(L1,L2,N)*RC2(K,L2) 311 CONTINUE 320 IF (.NOT. R2VP(N)) GO TO 330 DO 321 L1 = 1, 6 DO 321 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) 321 CONTINUE 330 A(N+1) = SVJK*FAC 340 CONTINUE 345 CALL GATHER RETURN C C BEAM SIZE CONSTRAINT C 350 IF (NORD3 .LT. 1) RETURN IF (ACCEL) GO TO 360 CALL EXTENT RETURN C C ACCELERATOR PARAMETER BEAM CONSTRAINT C 360 IF (.NOT. RECENT) CALL BEAM CW = 1.0/SD**2 IF (J .GE. 5) RETURN IF (J .EQ. 2 .OR. J .EQ. 4) GO TO 361 FAC = UNIT(J+1)/UNIT(J) GO TO 362 361 J = J - 1 K = J + 1 FAC = -1.0 362 A(1) = DE0 - SIT(J,K)*FAC CALL CLI(LOGIC) IF (LOGIC) RETURN C IF (NV1 .LT. 1) GO TO 385 DO 380 N = 1, NV1 IF (R2P) GO TO 365 IF (.NOT. SVP(N)) GO TO 380 SVJK = SV(J,K,N) GO TO 378 365 SVJK = 0.0 IF (.NOT. SVP(N)) GO TO 370 DO 368 L1 = 1, 6 DO 368 L2 = 1, 6 SVJK = SVJK + RC2(J,L1)*SV(L1,L2,N)*RC2(K,L2) 368 CONTINUE 370 IF (.NOT. R2VP(N)) GO TO 378 DO 375 L1 = 1, 6 DO 375 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) 375 CONTINUE 378 A(N+1) = SVJK*FAC 380 CONTINUE 385 CALL GATHER RETURN C C BEAM CORRELATION CONSTRAINT C 400 IF (NORD3 .LT. 1) RETURN IF (ACCEL) RETURN IF (.NOT. RECENT) CALL BEAM J = J - 10 IF (J .GT. 6 .OR. K .GT. 6) WRITE (NOUT,3000) J, K 3000 FORMAT (25H3 NO BEAM MATRIX ELEMENT,2I6) SIJJ = SIT(J,J) SIKK = SIT(K,K) SIJK = SIT(J,K) W = SIJK/SQRT(SIJJ*SIKK) CW = 1.0/SD**2 A(1) = DE0 - W CALL CLI(LOGIC) IF (LOGIC) RETURN 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 SVJJ = SV(J,J,N) SVKK = SV(K,K,N) SVJK = SV(J,K,N) GO TO 430 410 SVJJ = 0.0 SVKK = 0.0 SVJK = 0.0 IF (.NOT. SVP(N)) GO TO 420 C DO 411 L1 = 1, 6 DO 411 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) 411 CONTINUE 420 IF (.NOT. R2VP(N)) GO TO 430 DO 421 L1 = 1, 6 DO 421 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) 421 CONTINUE 430 ANC = SVJK/SIJK - 0.5*(SVJJ/SIJJ + SVKK/SIKK) A(N+1) = W*ANC 440 CONTINUE 445 CALL GATHER RETURN C C FIRST MOMENT CONSTRAINT C 450 CW = 1.0/SD**2 COC = 0.0 IF (SOFA) COC = CO(K) A(1) = DE0 - COC/UNIT(K) CALL CLI(LOGIC) IF (LOGIC) RETURN C IF (.NOT. SOFA) GO TO 495 IF (NV1 .LT. 1) GO TO 495 DO 490 N = 1, NV1 IF (.NOT. CVP(N)) GO TO 490 COTV = COV(K,N) 485 A(N+1) = COTV/UNIT(K) 490 CONTINUE 495 CALL GATHER RETURN C C CONSTRAINT ON ACCELERATOR FUNCTION ETA C 500 CW = 1.0/SD**2 COC = 0.0 IF (RAY) COC = ETA(K) A(1) = DE0 - COC/UNIT(K) CALL CLI(LOGIC) IF (LOGIC) RETURN C IF (.NOT. RAY) GO TO 545 IF (NV1 .LT. 1) GO TO 545 DO 540 N = 1, NV1 IF (.NOT. EVP(N)) GO TO 540 ETAV = DETA(K,N) 535 A(N+1) = ETAV/UNIT(K) 540 CONTINUE 545 CALL GATHER RETURN C C SEXTUPOLE STRENGTH LIMITS C 550 IF (NORD3 .GE. 2) CALL CONSEC RETURN C C NUMERICAL CONSTANT C 600 A(1) = - DATA(I+2) DO 610 N = 1, 20 610 A(N+1) = 0.0 CALL GATHER RETURN END SUBROUTINE DEFINE COMMON /BLOC1/ NEL, NUM, NDIF, I, ISTOR(3129), DATA(13160) COMMON /BLOC2/ NIN, NOUT, NPUNCH COMMON /BLOC4/ LC, TOTANG, TOTROT, LCV(20), LUP(3) COMMON /BLOC47/ IC(4), IS(4), IP, NNDS, NDLEV EQUIVALENCE (DNAME,NAME) DIMENSION NDN(10), NDB(10), NDE(10), NDC(10), NDI(10), NDS(10), 1 TRIN(10) C J = DATA(I+1) GO TO (100,200,300,300), J C 100 DNAME = DATA(I+2) IF (NNDS .EQ. 0) GO TO 120 IF (NDLEV .EQ. 0) GO TO 105 IF (NAME .EQ. NDN(NDI(NDLEV))) GO TO 250 RETURN C 105 DO 110 N = 1, NNDS IF (NAME .EQ. NDN(N) .AND. NUM .NE. NDB(N)) GO TO 130 IF (NAME .EQ. NDN(N)) GO TO 125 110 CONTINUE IF (NNDS .GE. 10) GO TO 140 120 NNDS = NNDS + 1 NDN(NNDS) = NAME NDB(NNDS) = NUM TRIN(NNDS) = TOTROT NDE(NNDS) = 0 125 RETURN C 130 WRITE (NOUT,1000) NAME 1000 FORMAT (23H0DEFINED SECTION NAME ",A4,14H" ALREADY USED) STOP 140 WRITE (NOUT,1001) 1001 FORMAT (38H0NUMBER OF DEFINED SECTIONS EXCEEDS 10) STOP C 200 DNAME = DATA(I+2) IF (NDLEV .EQ. 0) GO TO 205 IF (NAME .EQ. NDN(NDI(NDLEV))) GO TO 250 RETURN C 205 DO 210 N = 1, NNDS NN = N IF (NAME .EQ. NDN(N)) GO TO 220 210 CONTINUE GO TO 230 220 NDE(NN) = NUM IF (ABS(TOTROT - TRIN(NN)) .GT. 0.1) GO TO 240 RETURN C 230 WRITE (NOUT,1002) NAME 1002 FORMAT (41H0NO BEGINNING FOUND FOR DEFINED SECTION ",A4,1H") STOP 240 WRITE (NOUT,1004) NAME 1004 FORMAT (31H0NON ZERO TOTAL Z ROTATION IN ",A4,1H") STOP C 250 NUM = NDC(NDLEV) NDIF = NDIF*NDS(NDLEV) NDLEV = NDLEV - 1 RETURN C 300 NDLEV = NDLEV + 1 NDC(NDLEV) = NUM DNAME = DATA(I+2) DO 310 N = 1, NNDS NN = N IF (NAME .EQ. NDN(N)) GO TO 320 310 CONTINUE GO TO 380 320 NDI(NDLEV) = NN IF (NDE(NN) .EQ. 0) GO TO 390 IF (J .EQ. 3) NDS(NDLEV) = 1 IF (J .EQ. 4) NDS(NDLEV) = -1 NDIF = NDIF*NDS(NDLEV) IF (NDIF .EQ. 1) NUM = NDB(NN) IF (NDIF .EQ. -1) NUM = NDE(NN) RETURN C 380 WRITE (NOUT,1003) NAME 1003 FORMAT (21H0NO DEFINED SECTION ",A4,1H") STOP 390 WRITE (NOUT,1005) NAME 1005 FORMAT (35H0NO END FOUND FOR DEFINED SECTION ",A4,1H") STOP END REAL FUNCTION DEN(X) C IF( X .NE. 0. ) GO TO 1 DEN = (1.E-16) RETURN 1 DEN = X RETURN END SUBROUTINE DERIVE COMMON /BLOC1/ NEL, NUM, NDIF, I, ISTOR(3129), DATA(13160) COMMON /BLOC3/ TYPE, L, LV INTEGER TYPE REAL L, LV COMMON /BLOC4/ LC, TOTANG, TOTROT, LCV(20), LUP(3) REAL LC, LCV, LUP COMMON /BLOC5/ VSTOR(20), TIE(13160), LABEL(3129), LABM(10) INTEGER VSTOR, TIE COMMON /BLOC11/ R(6,6), RV(6,6), T(5,21), TV(5,21), U(5,56), 1 UV(5,56) DIMENSION RL(36), RVL(36), TL(105), TVL(105), UL(280), 1 UVL(280) EQUIVALENCE (R(1,1),RL(1)), (RV(1,1),RVL(1)), 1 (T(1,1),TL(1)), (TV(1,1),TVL(1)), 2 (U(1,1),UL(1)), (UV(1,1),UVL(1)) COMMON /BLOC12/ RC(6,6), RCV(6,6,20), TC(5,21), UC(5,56), RCP, 1 RVP(20) LOGICAL RCP, RVP COMMON /BLOC13/ RC2(6,6), R2V(6,6,20), TC2(5,21), T2V(5,21,10), 1 UC2(5,56), U2V(5,56,10), R2P, R2VP(20) LOGICAL R2P, R2VP DIMENSION RC2L(36), R2VL(36,20), TC2L(105), T2VL(105,10), 1 UC2L(280), U2VL(280,10) EQUIVALENCE (RC2(1,1),RC2L(1)), (R2V(1,1,1),R2VL(1,1)), 1 (TC2(1,1),TC2L(1)), (T2V(1,1,1),T2VL(1,1)), 2 (UC2(1,1),UC2L(1)), (U2V(1,1,1),U2VL(1,1)) COMMON /BLOC14/ RC3(6,6), TC3(5,21), UC3(5,56), R3P LOGICAL R3P DIMENSION RC3L(36), TC3L(105), UC3L(280) EQUIVALENCE (RC3(1,1),RC3L(1)), (TC3(1,1),TC3L(1)), 1 (UC3(1,1),UC3L(1)) DIMENSION RSH(6,6), TSH(5,21), USH(5,56) DIMENSION RSHL(36), TSHL(105), USHL(280) EQUIVALENCE (RC3(1,1),RSH(1,1)), (TC3(1,1),TSH(1,1)), 1 (UC3(1,1),USH(1,1)) EQUIVALENCE (RSH(1,1),RSHL(1)), (TSH(1,1),TSHL(1)), 1 (USH(1,1),USHL(1)) COMMON /BLOC15/ RS(6,6), RT(6,6), TS(5,21), TT(5,21), US(5,56), 1 UT(5,56) DIMENSION RSL(36), RTL(36), TSL(105), TTL(105), USL(280), 1 UTL(280) EQUIVALENCE (RS(1,1),RSL(1)), (RT(1,1),RTL(1)), 1 (TS(1,1),TSL(1)), (TT(1,1),TTL(1)), 2 (US(1,1),USL(1)), (UT(1,1),UTL(1)) COMMON /BLOC16/ SI(6,6), SV(6,6,20), CO(6), COV(6,20), RI, 1 SVP(20), CVP(20), SOFA LOGICAL SVP, CVP, SOFA COMMON /BLOC17/ COD(6), COF(6), PSIX, PSIY, PSIX1, PSIY1, NOPH LOGICAL NOPH COMMON /BLOC18/ SIT(6,6), CEN(6), RECENT LOGICAL RECENT COMMON /BLOC19/ TR(5,6,6), TRA(5,6,6), URR(5,21,6), NORDE COMMON /BLOC20/ ETA(6), DETA(6,20), RAY, EVP(20) LOGICAL RAY, EVP COMMON /BLOC22/ LBEND, BE1, SB, TB, TB1, NBVARY, BEFORE LOGICAL BEFORE REAL LBEND COMMON /BLOC23/ H0, AL, NB, BDB, RMPS, VRN, NPN, BDBP, RNMS, DCOV LOGICAL DCOV REAL NB, NPN COMMON /BLOC26/ O(4,3,3), X0(4,3), IR, RORC, TYT, ALIGN, TMK, 1 FEO, CHORD INTEGER RORC, TYT LOGICAL ALIGN, TMK, FEO, CHORD COMMON /BLOC27/ CT(6,6), CT0(6,6), CT1(3,3), X0L(3), VM(6), 1 VMT(6), COM(6,6,10), OR(3,3), XR(3), LMIS(2,10), 2 DMC, NM LOGICAL DMC REAL LMIS COMMON /BLOC28/ COC, DE0, SD, CTY, JV, NC, NV1, NV2, NV3 INTEGER CTY COMMON /BLOC30/ CDB, NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, 1 LCPR, ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, 2 LAY191, NPFR INTEGER CDB LOGICAL NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, LCPR, 1 ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, LAY191 COMMON /BLOC32/ UNIT(12), XDIME(12) COMMON /BLOC34/ NORD1, NORD2, NORD3, NORDX, LINEAR, JH, SIG LOGICAL LINEAR COMMON /BLOC48/ NUMB, NUME, NCT, NCTV, NCTC, NCTS, NCTF COMMON /CONSTS/ PI, RADIAN, CLIGHT, EMASS INTEGER VARSP LOGICAL VARLET DIMENSION SVT(6,6), COS(6), COT(6), COTF(6), ETAS(6), ETAT(6) C IF (NCTS .EQ. 1) CALL INITZE IF (NCTS .GT. 1) CALL RECALL NCT = NCTS - 1 1 I = ISTOR(NUM) TYPE = DATA(I) IF (TYPE .LE. 0 .OR. TYPE .GE. 50) GO TO 810 NCT = NCT + 1 IF (NCT .GT. NCTF) GO TO 900 CALL ELMENT(NWK) GO TO (170,200,200,200,200,810,170,170,810,700, 1 200,100,200,200,810,200,810,200,200,200, 2 810,700,750,810,200,810,170), TYPE 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 (.NOT. SVP(N)) GO TO 120 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 120 CONTINUE C 170 NVTYPE = NV(TYPE) IF (NVTYPE .EQ. 0) GO TO 810 DO 180 JV = 1, NVTYPE IPLJV = I + JV NV2 = TIE(IPLJV) IF (NV2 .EQ. 0) GO TO 180 NV1 = MAX0(NV1,IABS(NV2)) CALL PARTLS 180 CONTINUE GO TO 810 C C ELEMENTS HAVING A TRANSFER MATRIX C 200 NVTYPE = NV(TYPE) NVSHOW = NIV(TYPE) IF (NWK .EQ. 1) GO TO 202 IF (NVTYPE .GE. 1) GO TO 808 GO TO 810 202 IF (NVTYPE .LT. 1) GO TO 215 DO 210 JV = 1, NVTYPE IF (JV .GT. NVSHOW) GO TO 205 IPLJV = I + JV NV2 = TIE(IPLJV) IF (NV2 .NE. 0) GO TO 300 GO TO 210 205 NV2 = VARSP(TYPE,JV) IF (NV2 .NE. 0) GO TO 300 210 CONTINUE 215 IF (.NOT. SOFA .AND. .NOT. RAY) GO TO 240 DO 220 N = 1, NV1 IF (CVP(N) .OR. EVP(N)) GO TO 300 220 CONTINUE C C UNVARIED ELEMENT C 240 VARLET = .FALSE. IF (.NOT. RAY) GO TO 250 DO 245 J = 1, 6 245 ETAT(J) = ETA(J) CALL THREAD(R,T,U,ETAT) 250 IF (.NOT. SOFA) GO TO 260 IF (.NOT. R1P) GO TO 255 DO 251 J = 1, 6 251 COTF(J) = COF(J) CALL THRED1(R,COTF) 255 DO 258 J = 1, 6 258 COT(J) = CO(J) CALL THREAD(R,T,U,COT) IF (NORD1 .GE. 2 .AND. NORD2 .GE. 1) CALL ENRICH(R,T,U,CO) 260 IF (NORD2 .LT. 1) GO TO 290 IF (R3P) GO TO 270 DO 262 JK = 1, 36 262 RC3L(JK) = RL(JK) IF (NORD2 .EQ. 1) GO TO 290 DO 265 JKM = 1, 105 265 TC3L(JKM) = TL(JKM) IF (NORD2 .LE. 2) GO TO 290 DO 266 JKLM = 1, 280 266 UC3L(JKLM) = UL(JKLM) GO TO 290 C 270 IF (NORD2 .GT. 1) GO TO 271 CALL CAB(RS,R,RC3) GO TO 275 271 IF (NORD2 .GT. 2) GO TO 272 CALL CAB2(RS,TS,R,T,RC3,TC3,.FALSE.) GO TO 275 272 CALL CAB3(RS,TS,US,R,T,U,RC3,TC3,UC3,.FALSE.) 275 DO 280 JK = 1, 36 280 RC3L(JK) = RSL(JK) IF (NORD2 .EQ. 1) GO TO 290 DO 285 JKM = 1, 105 285 TC3L(JKM) = TSL(JKM) IF (NORD2 .LE. 2) GO TO 290 DO 286 JKLM = 1, 280 286 UC3L(JKLM) = USL(JKLM) 290 IF (.NOT. SOFA) GO TO 298 IF (.NOT. R1P) GO TO 295 DO 292 J = 1, 6 292 COF(J) = COTF(J) 295 DO 297 J = 1, 6 297 CO(J) = COT(J) 298 IF (.NOT. RAY) GO TO 800 DO 299 J = 1, 6 299 ETA(J) = ETAT(J) GO TO 800 C C VARIED ELEMENT C 300 VARLET = .TRUE. IF (R3P) CALL UPDAT3 IF (.NOT. RAY) GO TO 305 DO 301 J = 1, 6 301 ETAT(J) = ETA(J) CALL THREAD(R,T,U,ETAT) 305 DO 306 J = 1, 36 306 RSHL(J) = RL(J) IF (NORD1 .LE. 1) GO TO 310 DO 307 J = 1, 105 307 TSHL(J) = TL(J) IF (NORD1 .LE. 2) GO TO 310 DO 308 J = 1, 280 308 USHL(J) = UL(J) 310 IF (.NOT. SOFA) GO TO 320 IF (.NOT. R1P) GO TO 315 DO 312 J = 1, 6 312 COTF(J) = COF(J) CALL THRED1(R,COTF) 315 DO 318 J = 1, 6 318 COT(J) = CO(J) CALL THREAD(R,T,U,COT) IF (NORD1 .GE. 2 .AND. NORD2 .GE. 1) CALL ENRICH(RSH,TSH,USH,CO) 320 IF (NORD2 .LE. 1 .OR. .NOT. R2P) GO TO 322 CALL PREMUL(TSH,RC2,TR) IF (NORD2 .EQ. 3) CALL PREML3(USH,RC2,URR) 322 IF (NV1 .LT. 1) GO TO 400 C C R TIMES DERIVATIVE OF ACCUMULATED R2 C IF (NWK .NE. 1) GO TO 400 DO 380 N = 1, NV1 NV2 = N IF (.NOT. R2VP(N)) GO TO 340 IF (NORD2 .LT. 1) GO TO 340 IF (NORD2 .GT. 1) GO TO 325 CALL CAB(RS,RSH,R2VL(1,N)) GO TO 330 325 IF (NORD2 .GT. 2) GO TO 326 CALL CABD2(RS,TS,RSH,TSH,R2VL(1,N),T2VL(1,N)) GO TO 330 326 CALL CABD3(RS,TS,US,RSH,TSH,USH,R2VL(1,N),T2VL(1,N),U2VL(1,N), 1 TC2L(1)) C 330 DO 332 JK = 1, 36 332 R2VL(JK,N) = RSL(JK) IF (NORD2 .EQ. 1) GO TO 340 DO 333 IJK = 1, 105 333 T2VL(IJK,N) = TSL(IJK) IF (NORD2 .LE. 2) GO TO 340 DO 335 IJKL = 1, 280 335 U2VL(IJKL,N) = USL(IJKL) C 340 IF (CVP(N) .OR. EVP(N)) CALL TWITCH IF (.NOT. CVP(N)) GO TO 380 IF (NORD1 .LT. 2 .OR. NORD2 .LT. 1) GO TO 380 IF (R2P) GO TO 350 DO 345 JK = 1, 36 345 R2VL(JK,N) = RTL(JK) IF (NORD2 .EQ. 1) GO TO 348 DO 346 IJK = 1, 105 346 T2VL(IJK,N) = TTL(IJK) IF (NORD2 .LE. 2) GO TO 348 DO 347 IJKL = 1, 280 347 U2VL(IJKL,N) = UTL(IJKL) 348 R2VP(N) = .TRUE. GO TO 380 C 350 IF (NORD2 .GT. 1) GO TO 355 CALL CAB(RS,RT,RC2) GO TO 360 355 IF (NORD2 .GT. 2) GO TO 356 CALL CAB2(RS,TS,RT,TT,RC2,TC2,.TRUE.) GO TO 360 356 CALL CAB3(RS,TS,US,RT,TT,UT,RC2,TC2,UC2,.TRUE.) C 360 IF (R2VP(N)) GO TO 370 DO 365 JK = 1, 36 365 R2VL(JK,N) = RSL(JK) IF (NORD2 .EQ. 1) GO TO 368 DO 366 IJK = 1, 105 366 T2VL(IJK,N) = TSL(IJK) IF (NORD2 .LE. 2) GO TO 368 DO 367 IJKL = 1, 280 367 U2VL(IJKL,N) = USL(IJKL) 368 R2VP(N) = .TRUE. GO TO 380 C 370 DO 375 JK = 1, 36 375 R2VL(JK,N) = R2VL(JK,N) + RSL(JK) IF (NORD2 .EQ. 1) GO TO 380 DO 376 IJK = 1, 105 376 T2VL(IJK,N) = T2VL(IJK,N) + TSL(IJK) IF (NORD2 .LE. 2) GO TO 380 DO 377 IJKL = 1, 280 377 U2VL(IJKL,N) = U2VL(IJKL,N) + USL(IJKL) 380 CONTINUE C C DERIVATIVE OF R TIMES ACCUMULATED R2 C 400 DO 550 JV = 1, NVTYPE IF (JV .GT. NVSHOW) GO TO 405 IPLJV = I + JV NV2 = TIE(IPLJV) GO TO 410 405 NV2 = VARSP(TYPE,JV) 410 IF (NV2 .EQ. 0) GO TO 550 LV = 0.0 DO 412 JK = 1, 36 412 RVL(JK) = 0.0 IF (NORD1 .LT. 2) GO TO 420 DO 414 JKM = 1, 105 414 TVL(JKM) = 0.0 IF (NORD1 .LE. 2) GO TO 420 DO 416 JKM = 1, 280 416 UVL(JKM) = 0.0 C 420 NV1 = MAX0(NV1,IABS(NV2)) CALL PARTLS IF (NV2 .GT. 0) GO TO 440 NV2 = IABS(NV2) LV = - LV DO 422 JK = 1, 36 422 RVL(JK) = - RVL(JK) IF (NORD1 .EQ. 1) GO TO 440 DO 424 JKM = 1, 105 424 TVL(JKM) = - TVL(JKM) IF (NORD1 .LE. 2) GO TO 440 DO 426 JKLM = 1, 280 426 UVL(JKLM) = - UVL(JKLM) C 440 IF (.NOT. RAY) GO TO 450 DO 442 J = 1, 6 442 ETAS(J) = ETA(J) CALL THREAD(RV,TV,UV,ETAS) IF (EVP(NV2)) GO TO 445 DO 443 J = 1, 6 443 DETA(J,NV2) = ETAS(J) EVP(NV2) = .TRUE. GO TO 450 445 DO 448 J = 1, 6 448 DETA(J,NV2) = DETA(J,NV2) + ETAS(J) 450 IF (.NOT. SOFA) GO TO 500 DO 452 J = 1, 6 452 COS(J) = CO(J) CALL THREAD(RV,TV,UV,COS) IF (CVP(NV2)) GO TO 455 DO 453 J = 1, 6 453 COV(J,NV2) = COS(J) CVP(NV2) = .TRUE. GO TO 460 455 DO 458 J = 1, 6 458 COV(J,NV2) = COV(J,NV2) + COS(J) 460 IF (NORD1 .GE. 2 .AND. NORD2 .GE. 1) CALL ENRICH(RV,TV,UV,CO) C 500 IF (NORD2 .LT. 1) GO TO 545 IF (R2P) GO TO 510 DO 502 JK = 1, 36 502 R2VL(JK,NV2) = RVL(JK) IF (NORD2 .EQ. 1) GO TO 540 DO 504 JKM = 1, 105 504 T2VL(JKM,NV2) = TVL(JKM) IF (NORD2 .LE. 3) GO TO 540 DO 506 JKLM = 1, 280 506 U2VL(JKLM,NV2) = UVL(JKLM) GO TO 540 C 510 IF (NORD2 .EQ. 3) GO TO 514 IF (NORD2 .EQ. 2) GO TO 512 CALL CAB(RS,RV,RC2) GO TO 516 512 CALL CAB2(RS,TS,RV,TV,RC2,TC2,.FALSE.) GO TO 516 514 CALL CAB3(RS,TS,US,RV,TV,UV,RC2,TC2,UC2,.FALSE.) 516 IF (R2VP(NV2)) GO TO 530 C DO 522 JK = 1, 36 522 R2VL(JK,NV2) = RSL(JK) IF (NORD2 .EQ. 1) GO TO 540 DO 524 JKM = 1, 105 524 T2VL(JKM,NV2) = TSL(JKM) IF (NORD2 .LE. 3) GO TO 540 DO 526 JKLM = 1, 280 526 U2VL(JKLM,NV2) = USL(JKLM) GO TO 540 C 530 DO 532 JK = 1, 36 532 R2VL(JK,NV2) = R2VL(JK,NV2) + RSL(JK) IF (NORD2 .EQ. 1) GO TO 540 DO 534 JKM = 1, 105 534 T2VL(JKM,NV2) = T2VL(JKM,NV2) + TSL(JKM) IF (NORD2 .LE. 3) GO TO 540 DO 536 JKLM = 1, 280 536 U2VL(JKLM,NV2) = U2VL(JKLM,NV2) + USL(JKLM) 540 CONTINUE R2VP(NV2) = .TRUE. 545 LCV(NV2) = LCV(NV2) + LV 550 CONTINUE C C ACCUMULATED R2 MATRIX C 600 IF (NWK .NE. 1) GO TO 810 IF (.NOT. RAY) GO TO 610 DO 605 J = 1, 6 605 ETA(J) = ETAT(J) 610 IF (.NOT. SOFA) GO TO 620 IF (.NOT. R1P) GO TO 615 DO 612 J = 1, 6 612 COF(J) = COTF(J) 615 DO 617 J = 1, 6 617 CO(J) = COT(J) C 620 IF (NORD2 .LT. 1) GO TO 800 DO 625 JK = 1, 36 625 RL(JK) = RSHL(JK) IF (NORD2 .EQ. 1) GO TO 630 DO 626 JKM = 1, 105 626 TL(JKM) = TSHL(JKM) IF (NORD2 .LE. 2) GO TO 630 DO 627 JKLM = 1, 280 627 UL(JKLM) = USHL(JKLM) C 630 IF (R2P) GO TO 640 DO 635 JK = 1, 36 635 RC2L(JK) = RL(JK) IF (NORD2 .EQ. 1) GO TO 800 DO 636 JKM = 1, 105 636 TC2L(JKM) = TL(JKM) IF (NORD2 .LE. 2) GO TO 800 DO 637 JKLM = 1, 280 637 UL(JKLM) = USHL(JKLM) GO TO 800 C 640 IF (NORD2 .GT. 2) GO TO 645 IF (NORD2 .EQ. 2) GO TO 642 CALL CAB(RS,R,RC2) GO TO 650 642 CALL CAB2(RS,TS,R,T,RC2,TC2,.TRUE.) GO TO 650 645 CALL CAB3(RS,TS,US,R,T,U,RC2,TC2,UC2,.TRUE.) C 650 DO 660 JK = 1, 36 660 RC2L(JK) = RSL(JK) IF (NORD2 .EQ. 1) GO TO 800 DO 670 JKM = 1, 105 670 TC2L(JKM) = TSL(JKM) IF (NORD2 .LE. 2) GO TO 800 DO 671 JKLM = 1, 280 671 UC2L(JKLM) = USL(JKLM) GO TO 800 C C CONSTRAINT C 700 CALL CONSTR GO TO 810 C C ALGEBRAIC COMBINATIONS C 750 CALL COMBIN(1) GO TO 810 C C ADVANCE TO NEXT ELEMENT C 800 IF (.NOT. ALIGN) GO TO 805 CALL ADVANC(2) CALL ADVANC(3) 805 IF (.NOT. VARLET) R3P = .TRUE. IF (VARLET) R2P = .TRUE. IF (DMC) CALL MALIGN IF (DCOV) CALL STEER 808 IF (LAY) CALL GROPE 810 NUM = NUM + NDIF IF (NUM .LE. NEL) GO TO 1 900 IF (NCTF .LT. NCTC .AND. R3P) CALL UPDAT3 RETURN END SUBROUTINE DETUNE COMMON /BLOC12/ RC(6,6), RCV(6,6,20), TC(5,21), UC(5,56), RCP, 1 RVP(20) LOGICAL RCP, RVP COMMON /BLOC13/ RC2(6,6), R2V(6,6,20), TC2(5,21), T2V(5,21,10), 1 UC2(5,56), U2V(5,56,10), R2P, R2VP(20) LOGICAL R2P, R2VP COMMON /BLOC15/ RS(6,6), RT(6,6), TS(5,21), TT(5,21), US(5,56), 1 UT(5,56) COMMON /BLOC19/ TR(5,6,6), TRA(5,6,6), URR(5,21,6), NORDE DIMENSION GT(5,6,6) EQUIVALENCE (TR(1,1,1), GT(1,1,1)) COMMON /BLOC26/ O(4,3,3), X0(4,3), IR, RORC, TYT, ALIGN, TMK, 1 FEO, CHORD INTEGER RORC, TYT LOGICAL ALIGN, TMK, FEO, CHORD COMMON /BLOC27/ CT(6,6), CT0(6,6), CT1(3,3), X0L(3), VM(6), 1 VMT(6), COM(6,6,10), OR(3,3), XR(3), LMIS(2,10), 2 DMC, NM LOGICAL DMC REAL LMIS COMMON /BLOC38/ SIOL(3,6,6), COLD(3,6), RCO(3,6,6), R2O(6,6), 1 SPO(3), RCPO(3), R2PO LOGICAL SPO, RCPO, R2PO C DO 10 J = 1, 6 DO 10 K = 1, 6 S = 0.0 IF (J .EQ. 6) GO TO 6 DO 5 M = 1, 6 S = S + GT(J,K,M)*VM(M) 5 CONTINUE 6 RT(J,K) = S 10 CONTINUE C IF (IR .EQ. 2) GO TO 200 IF (IR .EQ. 1 .AND. R2PO) GO TO 100 DO 20 J = 1, 6 DO 20 K = 1, 6 RC2(J,K) = RC2(J,K) + RT(J,K) 20 CONTINUE IF (IR .EQ. 1 .AND. RCPO(1)) GO TO 50 IF (IR .EQ. 3 .AND. RCPO(3)) GO TO 150 DO 30 J = 1, 6 DO 30 K = 1, 6 RC(J,K) = RC(J,K) + RT(J,K) 30 CONTINUE RETURN C 50 DO 60 J = 1, 6 DO 60 K = 1, 6 S = 0.0 DO 55 M = 1, 6 S = S + RT(J,M)*RCO(1,M,K) 55 CONTINUE RC(J,K) = RC(J,K) + S 60 CONTINUE RETURN C 100 DO 110 J = 1, 6 DO 110 K = 1, 6 S = 0.0 DO 105 M = 1, 6 S = S + RT(J,M)*R2O(M,K) 105 CONTINUE RS(J,K) = S RC2(J,K) = RC2(J,K) + S 110 CONTINUE IF (RCPO(1)) GO TO 130 DO 120 J = 1, 6 DO 120 K = 1, 6 RC(J,K) = RC(J,K) + RS(J,K) 120 CONTINUE RETURN C 130 DO 140 J = 1, 6 DO 140 K = 1, 6 S = 0.0 DO 135 M = 1, 6 S = S + RS(J,M)*RCO(1,M,K) 135 CONTINUE RC(J,K) = RC(J,K) + S 140 CONTINUE RETURN C 150 DO 160 J = 1, 6 DO 160 K = 1, 6 S = 0.0 DO 155 M = 1, 6 S = S + RT(J,M)*RCO(1,M,K) 155 CONTINUE RC(J,K) = RC(J,K) + S 160 CONTINUE RETURN C 200 DO 210 J = 1, 6 DO 210 K = 1, 6 RC(J,K) = RC(J,K) + RT(J,K) 210 CONTINUE RETURN END SUBROUTINE DFOCUS COMMON /BLOC3/ TYPE, L, LV INTEGER TYPE REAL L, LV COMMON /BLOC11/ R(6,6), RV(6,6), T(5,21), TV(5,21), U(5,56), 1 UV(5,56) COMMON /BLOC24/ B, KQ2, KVK, K2H, K2V, CS, SN, DISN, DSVN, J REAL KQ2, KVK, K2H, K2V COMMON /BLOC30/ CDB, NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, 1 LCPR, ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, 2 LAY191, NPFR INTEGER CDB LOGICAL NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, LCPR, 1 ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, LAY191 COMMON /BLOC34/ NORD1, NORD2, NORD3, NORDX, LINEAR, JH, SIG LOGICAL LINEAR C RV(J,J) = L * R(J+1,J)*KVK RV(J+1,J+1) = RV(J,J) RV(J,J+1) = ( - R(J,J+1) + L * R(J,J)) * KVK RV(J+1,J) = (R(J+1,J) - KQ2 * L * R(J,J)) * KVK IF (.NOT. (NORD1 .GT. 1 .OR. R1P) .OR. TYPE .NE. 5) GO TO 100 TV(J,J+15) = 0.5*(KQ2*L**2*R(J,J) - L*R(J+1,J))*KVK TV(J+1,J+16) = TV(J,J+15) TV(J,J+16) = 0.5*( - R(J,J+1) + L*R(J,J) + KQ2*L**2*R(J,J+1))*KVK TV(J+1,J+15) = 0.5*( - R(J+1,J) + 3.0*KQ2*L*R(J,J) 1 + KQ2*L**2*R(J+1,J))*KVK TV(5,J*(J+1)/2) = - 0.25*(2.0*KQ2*L*KVK + RV(J+1,J)*R(J,J) 1 + R(J+1,J)*RV(J,J)) TV(5,J*(J+3)/2) = - 0.5*(RV(J,J+1)*R(J+1,J) + R(J,J+1)*RV(J+1,J)) TV(5,J*(J+3)/2+1) = - 0.25*(RV(J,J)*R(J,J+1) 1 + R(J,J)*RV(J,J+1)) 100 RETURN END SUBROUTINE DFOL COMMON /BLOC3/ TYPE, L, LV INTEGER TYPE REAL L, LV COMMON /BLOC11/ R(6,6), RV(6,6), T(5,21), TV(5,21), U(5,56), 1 UV(5,56) COMMON /BLOC24/ B, KQ2, KVK, K2H, K2V, CS, SN, DISN, DSVN, J REAL KQ2, KVK, K2H, K2V COMMON /BLOC30/ CDB, NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, 1 LCPR, ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, 2 LAY191, NPFR INTEGER CDB LOGICAL NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, LCPR, 1 ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, LAY191 COMMON /BLOC32/ UNIT(12), XDIME(12) COMMON /BLOC34/ NORD1, NORD2, NORD3, NORDX, LINEAR, JH, SIG LOGICAL LINEAR C IF (TYPE .EQ. 4 .AND. ANIN) GO TO 200 RV(J,J+1) = R(J,J) * UNIT(8) RV(J+1,J) = - KQ2 * RV(J,J+1) RV(J+1,J+1) = R(J+1,J) * UNIT(8) RV(J,J) = RV(J+1,J+1) IF (.NOT. (NORD1 .GT. 1 .OR. R1P) .OR. TYPE .NE. 5) GO TO 100 TV(J,J+15) = 0.5*( - R(J+1,J) + KQ2*L*R(J,J))*UNIT(8) TV(J+1,J+16) = TV(J,J+15) TV(J,J+16) = 0.5*(RV(J,J+1) - LV*R(J,J) - L*RV(J,J)) TV(J+1,J+15) = 0.5*(2.0*KQ2*R(J,J) + KQ2*L*R(J+1,J))*UNIT(8) TV(5,J*(J+1)/2) = - 0.25*(KQ2*LV + RV(J+1,J)*R(J,J) 1 + R(J+1,J)*RV(J,J)) TV(5,J*(J+3)/2) = - 0.5*(RV(J,J+1)*R(J+1,J) + R(J,J+1)*RV(J+1,J)) TV(5,J*(J+3)/2+1) = - 0.25*(LV + RV(J,J)*R(J,J+1) 1 + R(J,J)*RV(J,J+1)) 100 RETURN C 200 RV(J,J+1) = R(J,J+1)*UNIT(8)/L RV(J+1,J) = - R(J+1,J)*UNIT(8)/L RETURN END SUBROUTINE ELICIT COMMON /BLOC1/ NEL, NUM, NDIF, I, ISTOR(3129), DATA(13160) COMMON /BLOC3/ TYPE, L, LV INTEGER TYPE REAL L, LV COMMON /BLOC11/ R(6,6), RV(6,6), T(5,21), TV(5,21), U(5,56), 1 UV(5,56) DIMENSION RL(36), RVL(36), TL(105), TVL(105), UL(280), 1 UVL(280) EQUIVALENCE (R(1,1),RL(1)), (RV(1,1),RVL(1)), 1 (T(1,1),TL(1)), (TV(1,1),TVL(1)), 2 (U(1,1),UL(1)), (UV(1,1),UVL(1)) COMMON /BLOC13/ RC2(6,6), R2V(6,6,20), TC2(5,21), T2V(5,21,10), 1 UC2(5,56), U2V(5,56,10), R2P, R2VP(20) LOGICAL R2P, R2VP DIMENSION RC2L(36), R2VL(36,20), TC2L(105), T2VL(105,10), 1 UC2L(280), U2VL(280,10) EQUIVALENCE (RC2(1,1),RC2L(1)), (R2V(1,1,1),R2VL(1,1)), 1 (TC2(1,1),TC2L(1)), (T2V(1,1,1),T2VL(1,1)), 2 (UC2(1,1),UC2L(1)), (U2V(1,1,1),U2VL(1,1)) COMMON /BLOC15/ RS(6,6), RT(6,6), TS(5,21), TT(5,21), US(5,56), 1 UT(5,56) DIMENSION RSL(36), RTL(36), TSL(105), TTL(105), USL(280), 1 UTL(280) EQUIVALENCE (RS(1,1),RSL(1)), (RT(1,1),RTL(1)), 1 (TS(1,1),TSL(1)), (TT(1,1),TTL(1)), 2 (US(1,1),USL(1)), (UT(1,1),UTL(1)) COMMON /BLOC16/ SI(6,6), SV(6,6,20), CO(6), COV(6,20), RI, 1 SVP(20), CVP(20), SOFA LOGICAL SVP, CVP, SOFA COMMON /BLOC17/ COD(6), COF(6), PSIX, PSIY, PSIX1, PSIY1, NOPH LOGICAL NOPH COMMON /BLOC20/ ETA(6), DETA(6,20), RAY, EVP(20) LOGICAL RAY, EVP COMMON /BLOC23/ H0, AL, NB, BDB, RMPS, VRN, NPN, BDBP, RNMS, DCOV LOGICAL DCOV REAL NB, NPN COMMON /BLOC26/ O(4,3,3), X0(4,3), IR, RORC, TYT, ALIGN, TMK, 1 FEO, CHORD INTEGER RORC, TYT LOGICAL ALIGN, TMK, FEO, CHORD COMMON /BLOC27/ CT(6,6), CT0(6,6), CT1(3,3), X0L(3), VM(6), 1 VMT(6), COM(6,6,10), OR(3,3), XR(3), LMIS(2,10), 2 DMC, NM LOGICAL DMC REAL LMIS COMMON /BLOC30/ CDB, NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, 1 LCPR, ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, 2 LAY191, NPFR INTEGER CDB LOGICAL NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, LCPR, 1 ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, LAY191 COMMON /BLOC34/ NORD1, NORD2, NORD3, NORDX, LINEAR, JH, SIG LOGICAL LINEAR DIMENSION COT(6), COTF(6) C C DETERMINE EFFECT OF ELEMENT C CALL ELMENT(NWK) IF (TYPE .EQ. 13 .AND. IFIX(DATA(I+1)) .EQ. 9) GO TO 330 IF (TYPE .EQ. 16 .AND. 1 (IFIX(DATA(I+1)) .EQ. 19 .OR. IFIX(DATA(I+1)) .EQ. 20)) 2 GO TO 330 IF (NWK .NE. 1) RETURN C C MULTIPLY TRANSFER MATRICES C IF (RAY) CALL THREAD(R,T,U,ETA) IF (.NOT. SOFA) GO TO 120 IF (R1P) CALL THRED1(R,COF) 110 DO 113 J = 1, 6 113 COT(J) = CO(J) CALL THREAD(R,T,U,COT) IF (NORD1 .GE. 2 .AND. NORD2 .GE. 1) CALL ENRICH(R,T,U,CO) 120 IF (NORD2 .LT. 1) GO TO 300 IF (R2P) GO TO 200 DO 130 JK = 1, 36 130 RC2L(JK) = RL(JK) IF (NORD2 .EQ. 1) GO TO 300 DO 140 JKM = 1, 105 140 TC2L(JKM) = TL(JKM) IF (NORD2 .LE. 2) GO TO 300 DO 150 JKLM = 1, 280 150 UC2L(JKLM) = UL(JKLM) GO TO 300 C 200 IF (NORD2 .GT. 1) GO TO 210 CALL CAB(RS,R,RC2) GO TO 215 210 IF (NORD2 .GT. 2) GO TO 211 CALL CAB2(RS,TS,R,T,RC2,TC2,.FALSE.) GO TO 215 211 CALL CAB3(RS,TS,US,R,T,U,RC2,TC2,UC2,.FALSE.) 215 DO 220 JK = 1, 36 220 RC2L(JK) = RSL(JK) IF (NORD2 .EQ. 1) GO TO 300 DO 240 JKM = 1, 105 240 TC2L(JKM) = TSL(JKM) IF (NORD2 .LE. 2) GO TO 300 DO 250 JKLM = 1, 280 250 UC2L(JKLM) = USL(JKLM) C 300 IF (.NOT. SOFA) GO TO 310 DO 305 J = 1, 6 305 CO(J) = COT(J) 310 IF (.NOT. ALIGN) GO TO 320 CALL ADVANC(2) CALL ADVANC(3) 320 R2P = .TRUE. 330 IF (LAY) CALL ADVANC(4) IF (SOFA .AND. NM .GE. 1) CALL INFECT IF (DMC) CALL MALIGN IF (DCOV) CALL STEER RETURN END SUBROUTINE ELMENT(NWK) COMMON /BLOC1/ NEL, NUM, NDIF, I, ISTOR(3129), DATA(13160) COMMON /BLOC2/ NIN, NOUT, NPUNCH COMMON /BLOC3/ TYPE, L, LV INTEGER TYPE REAL L, LV COMMON /BLOC4/ LC, TOTANG, TOTROT, LCV(20), LUP(3) REAL LC, LCV, LUP COMMON /BLOC5/ VSTOR(20), TIE(13160), LABEL(3129), LABM(10) INTEGER VSTOR, TIE COMMON /BLOC11/ R(6,6), RV(6,6), T(5,21), TV(5,21), U(5,56), 1 UV(5,56) DIMENSION RL(36) EQUIVALENCE (R(1,1),RL(1)) COMMON /BLOC12/ RC(6,6), RCV(6,6,20), TC(5,21), UC(5,56), RCP, 1 RVP(20) LOGICAL RCP, RVP COMMON /BLOC13/ RC2(6,6), R2V(6,6,20), TC2(5,21), T2V(5,21,10), 1 UC2(5,56), U2V(5,56,10), R2P, R2VP(20) LOGICAL R2P, R2VP COMMON /BLOC14/ RC3(6,6), TC3(5,21), UC3(5,56), R3P LOGICAL R3P COMMON /BLOC16/ SI(6,6), SV(6,6,20), CO(6), COV(6,20), RI, 1 SVP(20), CVP(20), SOFA LOGICAL SVP, CVP, SOFA COMMON /BLOC17/ COD(6), COF(6), PSIX, PSIY, PSIX1, PSIY1, NOPH LOGICAL NOPH COMMON /BLOC18/ SIT(6,6), CEN(6), RECENT LOGICAL RECENT COMMON /BLOC20/ ETA(6), DETA(6,20), RAY, EVP(20) LOGICAL RAY, EVP COMMON /BLOC21/ EN, ES, BE, APB(2), LAYK, LAYL, LAYX, RABT REAL LAYK, LAYL, LAYX COMMON /BLOC22/ LBEND, BE1, SB, TB, TB1, NBVARY, BEFORE LOGICAL BEFORE REAL LBEND COMMON /BLOC23/ H0, AL, NB, BDB, RMPS, VRN, NPN, BDBP, RNMS, DCOV LOGICAL DCOV REAL NB, NPN COMMON /BLOC24/ B, KQ2, KVK, K2H, K2V, CS, SN, DISN, DSVN, J REAL KQ2, KVK, K2H, K2V COMMON /BLOC25/ AP, CAP, JA LOGICAL CAP COMMON /BLOC26/ O(4,3,3), X0(4,3), IR, RORC, TYT, ALIGN, TMK, 1 FEO, CHORD INTEGER RORC, TYT LOGICAL ALIGN, TMK, FEO, CHORD COMMON /BLOC27/ CT(6,6), CT0(6,6), CT1(3,3), X0L(3), VM(6), 1 VMT(6), COM(6,6,10), OR(3,3), XR(3), LMIS(2,10), 2 DMC, NM LOGICAL DMC REAL LMIS COMMON /BLOC30/ CDB, NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, 1 LCPR, ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, 2 LAY191, NPFR INTEGER CDB LOGICAL NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, LCPR, 1 ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, LAY191 COMMON /BLOC31/ J1, TYP1 INTEGER TYP1 COMMON /BLOC32/ UNIT(12), XDIME(12) COMMON /BLOC33/ FOTILT, SM, TH, PREF COMMON /BLOC34/ NORD1, NORD2, NORD3, NORDX, LINEAR, JH, SIG LOGICAL LINEAR COMMON /BLOC35/ KL, KO REAL KL, KO COMMON /BLOC45/ CSH, SOKH, SKH, DISP, DDISP, CSV, SOKV, SKV COMMON /BLOC49/ PRAN2, PRAN3, PRAN4(3), PRAN5(3), PRAN7(6), 1 PRAN11(4), PRAN16(30), PRAN18(3), PRAN19(2), 2 PRAN20, PRAN25(3) COMMON /BLOC50/ BDBI, LAYKI, LAYLI, LAYXI, RAB1I, RAB2I, RMPSI, 1 VRNI, NPNI, BDBPI, RNMSI REAL LAYKI, LAYLI, LAYXI, NPNI COMMON /BLOC51/ EGAIN, PHASEL, WAVEL COMMON /CONSTS/ PI, RADIAN, CLIGHT, EMASS INTEGER TYPER REAL LEL, NPR C 1 IF (TYPE .EQ. 2) GO TO 50 IF (TYPE .EQ. 3) GO TO 50 IF (TYPE .EQ. 4) GO TO 50 IF (TYPE .EQ. 5) GO TO 50 IF (TYPE .EQ. 11) GO TO 50 IF (TYPE .EQ. 13 .AND. IFIX(DATA(I+1)) .EQ. 9) GO TO 70 IF (TYPE .EQ. 14 .AND. .NOT. (TYP1 .EQ. 14)) GO TO 50 IF (TYPE .EQ. 16 .AND. IFIX(DATA(I+1)) .GE. 16 1 .AND. IFIX(DATA(I+1)) .LE. 20) GO TO 70 IF (TYPE .EQ. 18) GO TO 50 IF (TYPE .EQ. 19) GO TO 50 IF (TYPE .EQ. 20 .AND. .NOT. REFER) GO TO 50 IF (TYPE .EQ. 25) GO TO 50 GO TO 80 50 L = 0.0 IF (NORD1 .LT. 1) GO TO 70 DO 55 J = 1, 36 55 RL(J) = 0.0 DO 60 J = 1, 36, 7 60 RL(J) = 1.0 70 IF (ALIGN .OR. LAY) CALL RESET(1) IF (.NOT. ALIGN) GO TO 80 IF (TYPE .EQ. 13 .OR. TYPE .EQ. 16) GO TO 80 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 LAST = LABEL(NUM) 80 NWK = 0 GO TO (100,200,300,400,500,600,700,800,900,5003, 1 1100,1200,1300,1400,1500,1600,1700,1800,1900,2000, 2 2100,5003,5003,2400,2500,2600,2700), TYPE C C 1. -- BEAM C 100 IF (ISTOR(NUM+1) .GT. I + 8) GO TO 150 RI = DATA(I+7)*UNIT(11) IF (PREF .EQ. 0.0) PREF = RI DO 105 J = 1, 6 CO(J) = 0.0 105 CONTINUE IF (R3P .OR. R2P) CALL UPDAT2 IF (NORD3 .LT. 1) GO TO 140 IF (ACCEL) GO TO 130 NOPH = .TRUE. DO 110 J = 1, 6, 1 IPLUSJ = I+J SIJJ = (DATA(IPLUSJ)*UNIT(J))**2 IF (SIJJ .GT. 0.0) NOPH = .FALSE. SI(J,J) = SIJJ 110 CONTINUE 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 SI(1,1) = DATA(I+1)*UNIT(1)/UNIT(2) SI(1,2) = - DATA(I+2) SI(2,1) = SI(1,2) SI(2,2) = (1.0 + DATA(I+2)**2)*UNIT(2)/(DATA(I+1)*UNIT(1)) SI(3,3) = DATA(I+3)*UNIT(3)/UNIT(4) SI(3,4) = - DATA(I+4) SI(4,3) = SI(3,4) SI(4,4) = (1.0 + DATA(I+4)**2)*UNIT(4)/(DATA(I+3)*UNIT(3)) IF (RAY) GO TO 138 DO 135 J = 1, 5 135 ETA(J) = 0.0 ETA(6) = UNIT(J) RAY = .TRUE. 138 SIGX = 0.0 SIGY = 0.0 140 CALL INIT1 GO TO 5003 C 150 IF (DATA(I+8) .NE. 0.0) GO TO 5003 IF (ACCEL) GO TO 180 RI = RI + DATA(I+7)*UNIT(11) IF (NORD3 .LT. 1) GO TO 5003 DO 160 J = 1, 6 IPLUSJ = I + J SI(J,J) = SI(J,J) + (DATA(IPLUSJ)*UNIT(J))**2 IF (SI(J,J) .GT. 0.0) NOPH = .FALSE. 160 CONTINUE RECENT = .FALSE. GO TO 5003 C 180 WRITE (NOUT,9001) 9001 FORMAT (44H0RMS ADDITION NOT PERMITTED WITH ACCELERATOR, 1 9H NOTATION) STOP C C 2. -- POLE FACE ROTATION C 200 IF (NPFR .NE. 0) GO TO 210 BE = DATA(I+1) IF (PRAN2 .NE. 0.0) BE = BE + PRAN2*RANDIS(-1) BE = BE*UNIT(7) C C* CHEK TO SEE IF INTERVENING CARDS ARE I/O CONTROLS C 210 CALL CHEK (CKK) IF (CKK .EQ. 0.) RETURN IF (NORD1 .LT. 1) GO TO 250 TB = TAN(BE) CB = COS(BE) SB = (1.0 + SIN(BE)**2)/CB IF (RORC .NE. 3 .AND. RORC .NE. 4) GO TO 230 IF (R2P .OR. R3P) CALL UPDAT2 IF (NM .GE. 10) GO TO 230 IF (.NOT. BEFORE) GO TO 225 CALL PICKUP(3) 225 IR = 3 DMC = .NOT. BEFORE 230 H0 = B/RI LAYL = LAYLI IF (PRAN16(7) .NE. 0.0) 1 LAYL = LAYL + PRAN16(7)*RANDIS(-1) LAYX = LAYXI IF (PRAN16(8) .NE. 0.0) 1 LAYX = LAYX + PRAN16(8)*RANDIS(-1) TCOR = 2.0*H0*APB(2)*LAYL BE1 = BE - TCOR*SB*(1. - LAYX*TCOR*TB ) TB1 = TAN(BE1) JU = 4 - JH R(JH+1,JH) = H0*TB R(JU+1,JU) = - H0*TB1 SB = 1.0/CB C 250 IF (.NOT. (ALIGN .OR. LAY)) GO TO 5001 JHL = (JH + 1)/2 LAYK = LAYKI X0(1,JHL) = - 4.0*ES*H0*APB(2)**2*LAYK GO TO 5001 C C 3. -- DRIFT SPACE C 300 L = DATA(I+1) IF (PRAN3 .NE. 0.0) L = L + PRAN3*RANDIS(-1) L = L*UNIT(8) IF (NORD1 .LT. 1) GO TO 310 R(1,2) = L R(3,4) = L R(5,6) = L*SM**2/(RI**2 + SM**2) C 310 IF (.NOT. (ALIGN .OR. LAY)) GO TO 5001 X0(1,3) = L GO TO 5001 C C 4. -- BENDING MAGNET C 400 IF (RORC .NE. 3 .AND. RORC .NE. 4) GO TO 410 IF (NM .GE. 10) GO TO 410 CALL HUNT2 IF (IR .NE. 1 .OR. DMC) GO TO 405 IF (R2P .OR. R3P) CALL UPDAT2 CALL PICKUP(3) 405 LABM(NM+1) = LABEL(NUM) C 410 IF (.NOT. BEFORE) GO TO 412 L = LBEND GO TO 420 412 L = DATA(I+1) IF (PRAN4(1) .NE. 0.0) L = L + PRAN4(1)*RANDIS(-1) L = L*UNIT(8) RMPS = RMPSI IF (PRAN16(22) .NE. 0.0) 1 RMPS = RMPS + PRAN16(22)*RANDIS(-1) NB = DATA(I+3) IF (PRAN4(3) .NE. 0.0) NB = NB + PRAN4(3)*RANDIS(-1) 415 IF (ANIN) GO TO 418 B = DATA(I+2) IF (PRAN4(2) .NE. 0.0) B = B + PRAN4(2)*RANDIS(-1) B = B*UNIT(9)*RI/PREF H0 = B/RI B = B*(1.0 + RMPS) AL = H0*L GO TO 420 418 AL = DATA(I+2) IF (PRAN4(2) .NE. 0.0) AL = AL + PRAN4(2)*RANDIS(-1) AL = AL*UNIT(7) H0 = AL/L B = RI*H0*(1.0 + RMPS) C 420 TOTANG = TOTANG + AL H = B/RI RH = 1.0 + RMPS IF (NORD1 .LT. 1) GO TO 430 IF (NB .EQ. 1.0) NB = 1.000001 J = JH WMN = (1.0 - NB) + RMPS*(2.0 - NB) KQ2 = H0**2*WMN K2H = KQ2 CALL FOCUS CSH = R(JH,JH) SOKH = R(JH,JH+1) SKH = - R(JH+1,JH) JU = 4 - JH J = JU KQ2 = H0**2*RH*NB K2V = KQ2 CALL FOCUS CSV = R(JU,JU) SOKV = R(JU,JU+1) SKV = - R(JU+1,JU) IF (CSH .GT. 0.5) DISN = SOKH**2/(1.0 + CSH) IF (CSH .LE. 0.5) DISN = (1.0 - CSH)/(WMN*H0**2) DISP = H*DISN R(JH,6) = SIG*DISP R(5,JH+1) = - SIG*H0*DISN DDISP = H*SOKH R(JH+1,6) = SIG*DDISP R(5,JH) = - SIG*H0*SOKH R(5,6) = - RH*(L - R(JH,JH+1))/WMN 1 + L*SM**2/(RI**2 + SM**2) IF (CSV .GT. 0.5) DSVN = SOKV**2/(1.0 + CSV) IF (CSV .LE. 0.5) DSVN = (1.0 - CSV)/(NB*H*H0) BEFORE = .FALSE. C 430 VRN = VRNI IF (PRAN16(23) .NE. 0.0) 1 VRN = VRN + PRAN16(23)*RANDIS(-1) NPN = NPNI IF (PRAN16(24) .NE. 0.0) 1 NPN = NPN + PRAN16(24)*RANDIS(-1) BDBP = BDBPI IF (PRAN16(25) .NE. 0.0) 1 BDBP = BDBP + PRAN16(25)*RANDIS(-1) RNMS = RNMSI IF (PRAN16(26) .NE. 0.0) 1 RNMS = RNMS + PRAN16(26)*RANDIS(-1) IF (RMPS .EQ. 0.0 .AND. VRN .EQ. 0.0 .AND. NPN .EQ. 0.0 1 .AND. BDBP .EQ. 0.0) GO TO 440 IF (RMPS .NE. 0.0 .OR. (RNMS .NE. 0.0 .AND. VRN .NE. 0.0)) 1 DCOV = .TRUE. HEX = H0*RMPS VR = RNMS*VRN NPR = NPN*RNMS COD(JH) = - SIG*RMPS*H0*DISN COD(JH+1) = - SIG*RMPS*H0*SOKH COD(JU) = SIG*VR*H0*DSVN COD(JU+1) = SIG*VR*H0*SOKV COD(5) = 0.0 COD(6) = 0.0 IF (NORD1 .LT. 1) GO TO 440 CXY = (VR - NPR) CYX = RH*(NPR - 2.0*VR) WM2N = 1.0 - 2.0*NB + RMPS*(2.0 - 2.0*NB) R(JH,JU) = CXY*(CSV - CSH)/WM2N R(JH,JU+1) = CXY*(SOKV - SOKH)/WM2N R(JH+1,JU) = CXY*(SKH - SKV)/WM2N R(JH+1,JU+1) = CXY*(CSV - CSH)/WM2N R(JU,JH) = CYX*(CSH - CSV)/WM2N R(JU,JH+1) = CYX*(SOKH - SOKV)/WM2N R(JU+1,JH) = CYX*(SKV - SKH)/WM2N R(JU+1,JH+1) = CYX*(CSH - CSV)/WM2N R(JU,6) = - VR*H0*DSVN 1 + H0*CYX*(DISN - DSVN)/WM2N R(JU+1,6) = - VR*H0*SOKV 1 + H0*CYX*(SOKH - SOKV)/WM2N R(5,JU) = H0*CXY*(SOKH - SOKV)/WM2N R(5,JU+1) = H0*CXY*(DISN - DSVN)/WM2N C 440 IF (.NOT. (ALIGN .OR. LAY)) GO TO 5001 JHL = (JH + 1)/2 AL0 = H0*L CSAL = COS(AL0) SNAL = SIN(AL0) O(1,JHL,JHL) = CSAL O(1,3,3) = CSAL O(1,JHL,3) = SIG*SNAL O(1,3,JHL) = - SIG*SNAL IF (H0 .EQ. 0.0) GO TO 441 IF (CSAL .GT. 0.5) X0(1,JHL) = - SIG*SNAL**2/(H0*(1.0 + CSAL)) IF (CSAL .LE. 0.5) X0(1,JHL) = - SIG*(1.0 - CSAL)/H0 X0(1,3) = SNAL/H0 GO TO 5001 441 X0(1,3) = L GO TO 5001 C C 5. -- QUADRUPOLE C 500 IF (RORC .NE. 3 .AND. RORC .NE. 5) GO TO 501 IF (NM .GE. 10) GO TO 501 LABM(NM+1) = LABEL(NUM) DMC = .TRUE. 501 L = DATA(I+1) IF (PRAN5(1) .NE. 0.0) L = L + PRAN5(1)*RANDIS(-1) L = L*UNIT(8) B = DATA(I+2) IF (PRAN5(2) .NE. 0.0) B = B + PRAN5(2)*RANDIS(-1) B = B*UNIT(9)*RI/PREF AP = DATA(I+3) IF (PRAN5(3) .NE. 0.0) AP = AP + PRAN5(3)*RANDIS(-1) AP = AP*UNIT(1) IF (NORD1 .LT. 1) GO TO 510 J = JH KQ2 = B/(AP*RI) K2H = KQ2 CALL FOCUS J = 4 - JH IF (HTGQ) KQ2 = - KQ2 K2V = KQ2 CALL FOCUS R(5,6) = L*SM**2/(RI**2 + SM**2) C 510 IF (.NOT. (ALIGN .OR. LAY)) GO TO 5001 X0(1,3) = L GO TO 5001 C C 6. -- UPDATE C 600 JA = DATA(I+1) IF (JA .NE. 0) GO TO 5003 IF (.NOT. SOFA .OR. NORD3 .EQ. 1 .OR. NOPH .OR. .NOT. R2P) 1 GO TO 605 DO 602 M = 1, 200 WRITE (NOUT,9003) 9003 FORMAT (45H UPDATE NOT PERMITTED WITH OFF-AXIS EXPANSION, 1 53H NONZERO PHASE SPACE, AND SECOND-ORDER MATRIX DISPLAY) 602 CONTINUE STOP 605 K = DATA(I+2) IF (K .EQ. 1) GO TO 610 IF (K .EQ. 2) GO TO 620 GO TO 5003 610 IF (RCP .OR. R2P .OR. R3P) CALL UPDATE GO TO 5003 620 IF (R2P .OR. R3P) CALL UPDAT2 GO TO 5003 C C 7. -- BEAM CENTROID SHIFT C 700 DO 710 J = 1, 6 IPLUSJ = I + J COD(J) = DATA(IPLUSJ) IF (PRAN7(J) .NE. 0.0) 1 COD(J) = COD(J) + PRAN7(J)*RANDIS(-1) COD(J) = COD(J)*UNIT(J) 710 CONTINUE RECENT = .FALSE. IF (.NOT. SOFA) GO TO 715 DO 712 J = 1, 6 712 CO(J) = CO(J) + COD(J) GO TO 5003 715 DO 716 J = 1, 6 716 CO(J) = COD(J) SOFA = .TRUE. NORD1 = NORDX IF (.NOT. BAX) GO TO 5003 DO 720 J = 1, 6 720 COF(J) = CO(J) R1P = .TRUE. GO TO 5003 C C 8. -- MAGNET MISALIGNMENT C 800 IF (ACCEL) GO TO 850 VMMAX = 0.0 DO 810 J = 1, 6 IPLUSJ = I + J I2MOD = 2 - MOD(J,2) VM(J) = DATA(IPLUSJ)*UNIT(I2MOD) VMMAX = AMAX1(VMMAX,ABS(VM(J))) 810 CONTINUE TYT = DATA(I+7) IF (VMMAX .EQ. 0.0) TYT = 0 RORC = MOD(TYT,10) IF (VMMAX .EQ. 0.0) GO TO 5003 IF (RORC .GE. 3) GO TO 5003 IR = RORC + 1 IF (MOD(TYT/10,10) .EQ. 1 .AND. NM .GE. 10) GO TO 5003 IF (MOD(TYT/10,10) .EQ. 1) LABM(NM+1) = LAST CALL MALIGN IF (TYT/10 .EQ. 0) NOPH = .FALSE. GO TO 5003 C 850 WRITE (NOUT,9002) 9002 FORMAT (54H0MISALIGNMENTS NOT PERMITTED WITH ACCELERATOR NOTATION) STOP C C 9. -- REPEAT C 900 CALL REPEAT GO TO 5003 C C 11. -- ACCELERATOR C 1100 L = DATA(I+1) IF (PRAN11(1) .NE. 0.0) L = L + PRAN11(1)*RANDIS(-1) L = L*UNIT(8) EGAIN = DATA(I+2) IF (PRAN11(2) .NE. 0.0) 1 EGAIN = EGAIN + PRAN11(2)*RANDIS(-1) EGAIN = EGAIN*UNIT(11) PHASEL = DATA(I+3) IF (PRAN11(3) .NE. 0.0) 1 PHASEL = PHASEL + PRAN11(3)*RANDIS(-1) PHASEL = PHASEL/RADIAN COSPHI = COS(PHASEL) SINPHI = SIN(PHASEL) WAVEL = DATA(I+4) IF (PRAN11(4) .NE. 0.0) 1 WAVEL = WAVEL + PRAN11(4)*RANDIS(-1) WAVEL = WAVEL*UNIT(5) IF (NORD1 .LT. 1) GO TO 1180 DEE = EGAIN*COSPHI DUM = EGAIN*SINPHI IF (SM .NE. 0.0) GO TO 1150 IF (ABS(DEE/RI) .LT. 0.01) GO TO 1120 R(1,2) = L*(RI*ALOG(1. + DEE/RI)/DEE) GO TO 1130 1120 R(1,2) = L*(1.0 - 0.5*DEE/RI + 0.333333*(DEE/RI)**2) 1130 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) RI = RI + DEE GO TO 1180 C 1150 J = 1 LEL = L EOLD = SQRT(RI**2 + SM**2) ENEW = EOLD + DEE RINEW = SQRT(ENEW**2 - SM**2) L = SM*LEL*(ALOG(RINEW + ENEW) - ALOG(RI + EOLD))/DEE KQ2 = 0.0 IF (WAVEL .NE. 0.0) KQ2 = - PI*DUM/(RI*WAVEL*LEL) CALL FOCUS R(1,2) = RI*R(1,2)/SM R(2,1) = SM*R(2,1)/RINEW R(2,2) = RI*R(2,2)/RINEW 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) = RINEW*EOLD/(RI*ENEW) R(5,6) = LEL*RI*(RINEW/ENEW - RI/EOLD)/DEE IF (WAVEL .EQ. 0.0) GO TO 1160 R(5,5) = R(5,5) - LEL*DUM*(1.0 - RINEW*EOLD/(RI*ENEW))/DEE 1 *(2.0*PI/WAVEL) R(6,5) = (DUM*ENEW/RINEW**2)*(2.0*PI/WAVEL) 1160 R(6,6) = (RI/RINEW)**2*(ENEW/EOLD) RI = RINEW L = LEL C 1180 IF (.NOT. (ALIGN .OR. LAY)) GO TO 5001 X0(1,3) = L GO TO 5001 C C 12. -- CORRELATIONS IN BEAM ELLIPSE C 1200 IF (NORD3 .LT. 1) GO TO 5003 N = 0 DO 1210 J = 2, 6, 1 JMIN1 = J - 1 DO 1210 K = 1, JMIN1, 1 N = N + 1 IPLUSN = I + N SI(K,J) = DATA(IPLUSN)*SQRT(SI(J,J)*SI(K,K)) SI(J,K) = SI(K,J) 1210 CONTINUE GO TO 5003 C C 13. -- INPUT-OUTPUT OPTIONS C 1300 CDB = DATA(I+1) IF (CDB .EQ. 7) GO TO 1307 IF (CDB .EQ. 9) GO TO 1309 IF (CDB .EQ. 12) GO TO 1312 IF (CDB .EQ. 13) GO TO 1313 IF (CDB .EQ. 18) GO TO 1318 IF (CDB .EQ. 20) GO TO 1320 IF (CDB .EQ. 21) GO TO 1321 IF (CDB .EQ. 22) GO TO 1322 IF (CDB .GE. 40 .AND. CDB .LE. 43) GO TO 1340 IF (CDB .EQ. 47) GO TO 1347 IF (CDB .EQ. 48) GO TO 1348 IF (CDB .EQ. 97) GO TO 1397 IF (CDB .EQ. 98) GO TO 1398 IF (CDB .EQ. 191) GO TO 13191 GO TO 5003 C C ACCELERATOR NOTATION FOR BEAM MATRIX C 1307 ACCEL = .TRUE. NORD1 = NORDX NORD2 = 1 NORD3 = 1 GO TO 5003 C C SHIFT REMAINING BEAM LINE TO CENTER BEAM C 1309 IF (.NOT. R1P) GO TO 5003 R1P = .FALSE. IF (.NOT. (ALIGN .OR. LAY)) GO TO 5003 THETA = ATAN(COF(2)) CST = COS(THETA) SNT = SIN(THETA) PHI = ATAN(COF(4)*CST) CSP = COS(PHI) SNP = SIN(PHI) 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 IF (ALIGN) CALL ADVANC(2) IF (ALIGN) CALL ADVANC(3) SOFA = .FALSE. DO 13091 J = 1, 6 CO(J) = CO(J) - COF(J) IF (NORD1 .GT. 1 .AND. CO(J) .NE. 0.0) SOFA = .TRUE. 13091 CONTINUE RECENT = .FALSE. GO TO 5003 C C FLOOR COORDINATES C 1312 LAY = .TRUE. GO TO 5003 C C REFER TRANSFER MATRIX TO ORIGINAL COORDINATE SYSTEM C 1313 REFER = .TRUE. GO TO 5003 C C SUPPRESS PRINTING OF CORRECTIONS AND COVARIANCE TABLE C 1318 ONLY = .TRUE. GO TO 5003 C C MISALIGNMENT PIVOT C 1320 TMK = .TRUE. GO TO 5003 C C EFFECT OF MISALIGNMENT OF FOCUSING ONLY C 1321 FEO = .TRUE. GO TO 5003 C C MISALIGNMENT ABOUT CHORD OF BEND MAGNET C 1322 CHORD = .TRUE. GO TO 5003 C C POLE FACE ROTATION ANGLE SPECIFICATION C 1340 NPFR = CDB - 40 GO TO 5003 C C BENDING MAGNET SPECIFIED BY LENGTH AND FIELD C 1347 ANIN = .FALSE. GO TO 5003 C C BENDING MAGNET SPECIFIED BY LENGTH AND BEND ANGLE C 1348 ANIN = .TRUE. GO TO 5003 C C ORDINARY OLD FAMILIAR GARDEN VARIETY WELL KNOWN QUADRUPOLE C 1397 HTGQ = .TRUE. GO TO 5003 C C LITHIUM LENS C 1398 HTGQ = .FALSE. GO TO 5003 C C FLOOR COORDINATES WITH EXTRA PRECISION C 13191 LAY191 = .TRUE. GO TO 5003 C C 14. -- ARBITRARY MATRIX C 1400 J1 = DATA(I+7) DO 1410 K = 1, 6 IPLUSK = I + K R(J1,K) = DATA(IPLUSK)*UNIT(J1)/UNIT(K) 1410 CONTINUE IF (NDIF .EQ. 1 .AND. NUM + 1 .GT. NEL) GO TO 5001 IF (NDIF .EQ. -1 .AND. NUM - 1 .LE. 0) GO TO 5001 IPNOTY = ISTOR(NUM + NDIF) IF (IFIX(DATA(IPNOTY)) .EQ. TYPE) GO TO 5002 GO TO 5001 C C 15. -- UNITS C 1500 J = DATA(I+1) CALL UNITS(J) GO TO 5003 C C 16. -- SPECIAL PARAMETERS C 1600 J = DATA(I+1) IF (J .LE. 0 .OR. (J .GT. 26 .AND. J .LT. 100) 1 .OR. (J .GT. 110 .AND. J .LT. 200) .OR. J .GT. 202) 2 GO TO 1699 IF (J .GT. 26) GO TO 5003 CALL SPESHL(J) GO TO 5003 1699 WRITE (NOUT,3390) 3390 FORMAT (35H0 ERROR - CHECK INPUT DATA TYPE 16) GO TO 5003 C C 17. -- SECOND ORDER CALCULATION C 1700 NORDX = DATA(I+1) NORDX = MAX0(NORDX,1) NORDY = DATA(I+2) IF (ACCEL) NORDY = 1 NORDX = MAX0(NORDX,NORDY) NORD1 = NORDY NORD3 = NORDY NORD2 = NORD3 IF (ALIGN .OR. SOFA .OR. ACCEL) NORD1 = NORDX IF (ALIGN) NORD2 = NORD1 LINEAR = .TRUE. GO TO 5003 C C 18. -- SEXTUPOLE C 1800 IF (RORC .NE. 3 .AND. RORC .NE. 6) GO TO 1801 IF (NM .GE. 10) GO TO 1801 LABM(NM+1) = LABEL(NUM) DMC = .TRUE. 1801 L = DATA(I+1) B = DATA(I+2) IF (PRAN18(2) .NE. 0.0) B = B + PRAN18(2)*RANDIS(-1) B = B*UNIT(9)*RI/PREF AP = DATA(I+3) IF (PRAN18(3) .NE. 0.0) 1 AP = AP + PRAN18(3)*RANDIS(-1) AP = AP*UNIT(1) IF (PRAN18(1) .NE. 0.0) L = L + PRAN18(1)*RANDIS(-1) L = L*UNIT(8) IF (NORD1 .LT. 1) GO TO 1810 R(1,2) = L R(3,4) = L R(5,6) = L*SM**2/(RI**2 + SM**2) C 1810 IF (.NOT. (ALIGN .OR. LAY)) GO TO 5001 X0(1,3) = L GO TO 5001 C C 19. -- SOLENOID C 1900 IF (REFER) GO TO 2030 IF (ACCEL) GO TO 2040 L = DATA(I+1) IF (PRAN19(1) .NE. 0.0) L = L + PRAN19(1)*RANDIS(-1) L = L*UNIT(8) B = DATA(I+2) IF (PRAN19(2) .NE. 0.0) B = B + PRAN19(2)*RANDIS(-1) B = B*UNIT(9)*RI/PREF IF (NORD1 .LT. 1) GO TO 1910 KO = DEN(B/RI) KL = KO*L 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) R(5,6) = L*SM**2/(RI**2 + SM**2) C 1910 IF (.NOT. (ALIGN .OR. LAY)) GO TO 5001 X0(1,3) = L GO TO 5001 C C 20. -- BEAM ROTATION C 2000 TH = DATA(I+1) IF (PRAN20 .NE. 0.0) TH = TH + PRAN20*RANDIS(-1) TOTROT = TOTROT + TH TH = TH/RADIAN IF (NDIF .LT. 0) TH = - TH CS = COS(TH) IF (ABS(CS) .LT. 0.00001) CS = 0.0 SN = SIN(TH) IF (ABS(SN) .LT. 0.00001 .AND. ABS(TH) .GT. 1.0) SN = 0.0 IF (ACCEL .AND. SN .NE. 0.0 .AND. CS .NE. 0.0) GO TO 2040 IF (REFER) GO TO 2020 IF (NORD1 .LT. 1) GO TO 2010 R(4,4) = CS R(3,3) = CS R(2,2) = CS R(1,1) = CS R(2,4) = SN R(1,3) = SN R(4,2) = - SN R(3,1) = - SN 2010 IF (.NOT. (ALIGN .OR. LAY)) GO TO 5001 O(1,1,1) = CS O(1,1,2) = SN O(1,2,1) = - SN O(1,2,2) = CS IF (RORC .LT. 3) GO TO 5001 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 5001 C 2020 IF (SN .EQ. 0.0 .AND. CS .GT. 0.5) GO TO 5003 IF (SN .NE. 0.0 .AND. CS .NE. 0.0) GO TO 2030 IF (SN .EQ. 0.0) JHR = 1 IF (CS .EQ. 0.0) JHR = 3 SIGR = 1.0 IF (SN .LT. 0.0 .OR. CS .LT. 0.0) SIGR = - 1.0 SIG = SIG*SIGR JH = JH*JHR IF (JH .EQ. 9) SIG = - SIG JH = MOD(JH,4) GO TO 5003 C 2030 WRITE (NOUT,2099) 2099 FORMAT (40H0ROTATION INCOMPATABLE WITH 13. 13. CARD) STOP 2040 WRITE (NOUT,2098) 2098 FORMAT (49H0 ROTATION INCOMPATABLE WITH ACCELERATOR NOTATION) STOP 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 = DATA(I+1) IF (DATA(I+3) .NE. 0.0) GO TO 2130 TYT = 110 VM(J) = DATA(I+2) GO TO 2140 2130 TYT = 0 VM(J) = DATA(I+3) 2140 VM(J) = VM(J)*UNIT(9)*UNIT(8)/RI CALL MALIGN GO TO 5003 C C 24. -- DEFINE SECTION C 2400 CALL DEFINE GO TO 5003 C C 25. -- OCTUPOLE C 2500 L = DATA(I+1) IF (PRAN25(1) .NE. 0.0) L = L + PRAN25(1)*RANDIS(-1) L = L*UNIT(8) B = DATA(I+2) IF (PRAN25(2) .NE. 0.0) B = B + PRAN25(2)*RANDIS(-1) B = B*UNIT(9)*RI/PREF IF (NORD1 .LT. 1) GO TO 2510 R(1,2) = L R(3,4) = L R(5,6) = L*SM**2/(RI**2 + SM**2) C 2510 IF (.NOT. (ALIGN .OR. LAY)) GO TO 5001 X0(1,3) = L GO TO 5001 C C 26. -- RANDOM CHANGE OF PHYSICAL PARAMETER C 2600 TYPER = DATA(I+1) NPAR = DATA(I+2) DPAR = DATA(I+3) IF (TYPER .GT. 27) GO TO 5003 GO TO (5003,2602,2603,2604,2605,5003,2607,5003,5003,5003, 1 2611,5003,5003,5003,5003,2616,5003,2618,2619,2620, 2 5003,5003,5003,5003,2625,5003,5003), TYPER C 2602 IF (NPAR .NE. 1) GO TO 5003 PRAN2 = DPAR GO TO 5003 C 2603 IF (NPAR .NE. 1) GO TO 5003 PRAN3 = DPAR GO TO 5003 C 2604 IF (NPAR .LT. 1 .OR. NPAR .GT. 3) GO TO 5003 PRAN4(NPAR) = DPAR GO TO 5003 C 2605 IF (NPAR .LT. 1 .OR. NPAR .GT. 3) GO TO 5003 PRAN5(NPAR) = DPAR GO TO 5003 C 2607 IF (NPAR .LT. 1 .OR. NPAR .GT. 6) GO TO 5003 PRAN7(NPAR) = DPAR GO TO 5003 C 2611 IF (NPAR .LT. 1 .OR. NPAR .GT. 4) GO TO 5003 PRAN11(NPAR) = DPAR GO TO 5003 C 2616 IF (NPAR .LT. 1 .OR. NPAR .GT. 30) GO TO 5003 PRAN16(NPAR) = DPAR GO TO 5003 C 2618 IF (NPAR .LT. 1 .OR. NPAR .GT. 3) GO TO 5003 PRAN18(NPAR) = DPAR GO TO 5003 C 2619 IF (NPAR .LT. 1 .OR. NPAR .GT. 2) GO TO 5003 PRAN19(NPAR) = DPAR GO TO 5003 C 2620 IF (NPAR .NE. 1) GO TO 5003 PRAN20 = DPAR GO TO 5003 C 2625 IF (NPAR .LT. 1 .OR. NPAR .GT. 3) GO TO 5003 PRAN25(NPAR) = DPAR GO TO 5003 C C 27. -- ACCELERATOR ETA FUNCTION C 2700 RAY = .TRUE. NORD1 = NORDX DO 2710 J = 1, 6 IPLUSJ = I + J ETA(J) = DATA(IPLUSJ)*UNIT(J) 2710 CONTINUE GO TO 5003 C C INDICATE WHETHER ELEMENT HAS MATRIX C 5001 NWK = 1 RECENT = .FALSE. 5002 IF (NORD1 .GE. 2) CALL SECORD TYP1 = TYPE LC = LC + L RETURN C 5003 NWK = 2 RETURN END SUBROUTINE ENRICH(RA,TA,UA,COR) COMMON /BLOC34/ NORD1, NORD2, NORD3, NORDX, LINEAR, JH, SIG LOGICAL LINEAR DIMENSION RA(6,6), TA(5,21), UA(5,56), COR(6) C C CONTRIBUTION OF SECOND ORDER TERMS TO FIRST ORDER MATRIX C DO 50 J = 1, 5 IND0 = 0 IND1 = 0 DO 50 K = 1, 6 SS = RA(J,K) DO 10 L1 = 1, K IND0 = IND0 + 1 SS = SS + 2.0*TA(J,IND0)*COR(L1) 10 CONTINUE KP1 = K + 1 IND1 = IND1 + KP1 IND = IND1 IF (K .EQ. 6) GO TO 45 DO 40 L1 = KP1, 6 SS = SS + 2.0*TA(J,IND)*COR(L1) IND = IND + L1 40 CONTINUE 45 RA(J,K) = SS 50 CONTINUE C C CONTRIBUTION OF THIRD-ORDER TERMS TO FIRST-ORDER MATRIX C IF (NORD1 .LT. 3) GO TO 200 DO 100 J = 1, 5 IND0 = 0 IND1 = 0 IND2 = 2 IND2D = 4 DO 100 K = 1, 6 SS = RA(J,K) DO 60 L2 = 1, K DO 60 L1 = 1, L2 IND0 = IND0 + 1 SS = SS + 3.0*UA(J,IND0)*COR(L1)*COR(L2) 60 CONTINUE C IF (K .EQ. 6) GO TO 95 KP1 = K + 1 INDA1 = IND1 INDD1 = K*KP1/2 DO 70 L2 = KP1, 6 INDA1 = INDA1 + INDD1 INDD1 = INDD1 + L2 IND = INDA1 DO 70 L1 = 1, K IND = IND + 1 SS = SS + 3.0*UA(J,IND)*COR(L1)*COR(L2) 70 CONTINUE IND1 = IND1 + K*(K+3)/2 C INDA2 = IND2 IND2 = IND2 + IND2D IND2D = IND2D + K + 2 INDAD = KP1*(K+2)/2 DO 80 L1 = KP1, 6 IND = INDA2 INDA2 = INDA2 + INDAD INDAD = INDAD + L1 + 1 INDD = L1*(L1-1)/2 DO 80 L2 = L1, 6 IND = IND + INDD INDD = INDD + L2 SS = SS + 3.0*UA(J,IND)*COR(L1)*COR(L2) 80 CONTINUE 95 RA(J,K) = SS 100 CONTINUE C C CONTRIBUTION OF THIRD-ORDER TERMS TO SECOND-ORDER MATRIX C IF (NORD2 .LT. 2) GO TO 200 DO 150 J = 1, 5 INC = 0 IND1 = 0 IND2 = 0 IND2D = 1 IND3 = 0 IND3D = 2 DO 150 K = 1, 6 IND2A = IND2 IND2 = IND2 + IND2D IND2D = IND2D + K + 1 IND3A = IND3 IND3 = IND3 + IND3D IND3D = IND3D + K + 2 DO 150 L1 = 1, K INC = INC + 1 SS = TA(J,INC) DO 110 L2 = 1, L1 IND1 = IND1 + 1 SS = SS + 3.0*UA(J,IND1)*COR(L2) 110 CONTINUE C IF (L1 .EQ. 6) GO TO 145 IF (L1 .EQ. K) GO TO 121 L1P1 = L1 + 1 IND2A = IND2A + L1 + 1 IND = IND2A DO 120 L2 = L1P1, K SS = SS + 3.0*UA(J,IND)*COR(L2) IND = IND + L2 120 CONTINUE C 121 IF (K .EQ. 6) GO TO 145 KP1 = K + 1 IND3A = IND3A + 1 IND = IND3A INDD = K*KP1/2 DO 130 L2 = KP1, 6 IND = IND + INDD INDD = INDD + L2 SS = SS + 3.0*UA(J,IND)*COR(L2) 130 CONTINUE 145 TA(J,INC) = SS 150 CONTINUE C 200 RETURN END SUBROUTINE EXTENT COMMON /BLOC3/ TYPE, L, LV INTEGER TYPE REAL L, LV COMMON /BLOC13/ RC2(6,6), R2V(6,6,20), TC2(5,21), T2V(5,21,10), 1 UC2(5,56), U2V(5,56,10), R2P, R2VP(20) LOGICAL R2P, R2VP COMMON /BLOC16/ SI(6,6), SV(6,6,20), CO(6), COV(6,20), RI, 1 SVP(20), CVP(20), SOFA LOGICAL SVP, CVP, SOFA COMMON /BLOC18/ SIT(6,6), CEN(6), RECENT LOGICAL RECENT COMMON /BLOC24/ B, KQ2, KVK, K2H, K2V, CS, SN, DISN, DSVN, J REAL KQ2, KVK, K2H, K2V COMMON /BLOC28/ COC, DE0, SD, CTY, JV, NC, NV1, NV2, NV3 INTEGER CTY COMMON /BLOC29/ A(21), CW, CA(21,21), SCALE(21), CASAV(21,21), 1 PMARQ, CHSMIN, XNORM, GNORM, EPS COMMON /BLOC32/ UNIT(12), XDIME(12) COMMON /BLOC34/ NORD1, NORD2, NORD3, NORDX, LINEAR, JH, SIG LOGICAL LINEAR LOGICAL LOGIC DIMENSION RSV(6,20) C IF (DE0 .EQ. 0.0 .AND. TYPE .EQ. 10) GO TO 100 IF (.NOT. RECENT) CALL BEAM CW = 1.0/SD**2 SIJJ = SIT(J,J) SSJJ = SQRT(SIJJ) A(1) = DE0 - SSJJ/UNIT(J) 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 COVJ = 0.0 IF (.NOT. SVP(N)) GO TO 20 DO 11 L1 = 1, 6 DO 11 L2 = 1, 6 SVJJ = SVJJ + RC2(J,L1)*SV(L1,L2,N)*RC2(J,L2) 11 CONTINUE 20 IF (.NOT. R2VP(N)) GO TO 30 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 30 A(N+1) = 0.5*SVJJ/(SSJJ*UNIT(J)) 40 CONTINUE 50 CALL GATHER RETURN C C MINIMIZATION OF BEAM SIZE C 100 CW = 1.0/(SD*UNIT(J))**2 SS = 0.0 DO 110 L1 = 1, 6 DO 110 L2 = 1, 6 SS = SS + RC2(J,L1)*RC2(J,L2)*SI(L1,L2) 110 CONTINUE CA(1,1) = CA(1,1) + SS*CW C IF (NV1 .LT. 1) GO TO 150 DO 120 N = 1, NV1 DO 120 L1 = 1, 6 SS = 0.0 DO 115 L2 = 1, 6 SS = SS + R2V(J,L2,N)*SI(L1,L2) 115 CONTINUE RSV(L1,N) = SS 120 CONTINUE C DO 130 N = 1, NV1 SS = 0.0 DO 125 K = 1, 6 SS = SS + RC2(J,K)*RSV(K,N) 125 CONTINUE CA(N+1,1) = CA(N+1,1) - SS*CW 130 CONTINUE C DO 140 N1 = 1, NV1 DO 140 N2 = 1, N1 SS = 0.0 DO 135 K = 1, 6 SS = SS + R2V(J,K,N1)*RSV(K,N2) 135 CONTINUE CA(N1+1,N2+1) = CA(N1+1,N2+1) + SS*CW 140 CONTINUE 150 CONTINUE C IF (NORD3 .GE. 2) CALL CONSEC RETURN END SUBROUTINE FITTIN C READ IN DATA FOR NEXT CASE COMMON /BLOC1/ NEL, NUM, NDIF, I, ISTOR(3129), DATA(13160) COMMON /BLOC2/ NIN, NOUT, NPUNCH COMMON /BLOC5/ VSTOR(20), TIE(13160), LABEL(3129), LABM(10) INTEGER VSTOR, TIE COMMON /BLOC26/ O(4,3,3), X0(4,3), IR, RORC, TYT, ALIGN, TMK, 1 FEO, CHORD INTEGER RORC, TYT LOGICAL ALIGN, TMK, FEO, CHORD COMMON /BLOC28/ COC, DE0, SD, CTY, JV, NC, NV1, NV2, NV3 INTEGER CTY COMMON /BLOC30/ CDB, NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, 1 LCPR, ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, 2 LAY191, NPFR INTEGER CDB LOGICAL NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, LCPR, 1 ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, LAY191 COMMON /BLOC34/ NORD1, NORD2, NORD3, NORDX, LINEAR, JH, SIG LOGICAL LINEAR COMMON /BLOC41/ LW, IMAGE(20), FLUSH, INDIC, NTYPE, LABLE, LENGTH, 1 NWORD, NVARY, DATUM(30), VARY(30) INTEGER VARY, TEXT(30) LOGICAL FLUSH EQUIVALENCE (TEXT(1),DATUM(1)) COMMON /BLOC42/ TABLE(36), PLUS, MINUS, BLANK, PERIOD, SPEC(10) INTEGER TABLE, PLUS, MINUS, BLANK, PERIOD, SPEC INTEGER PARENC EQUIVALENCE (PARENC,SPEC(10)) COMMON /BLOC43/ NCD, CARD(80), MC, EMPTY, ITEM, INDP INTEGER CARD LOGICAL EMPTY COMMON /LIMITS/ NDATA, NNEL LOGICAL SEC C C READ AND PRINT TITLE AND INDICATOR C 1 INDP = 0 CALL RDNEXT(2) CALL RDSTRG(IMAGE,20,LW) IF (LW .EQ. -1) STOP WRITE (NOUT,1005) 1005 FORMAT (1H1) 2 CALL RDNEXT(1) CALL RDSTRG(TEXT,29,L) IF (L .EQ. -1) GO TO 3 WRITE (NOUT,1004) (DATUM(J), J = 1, L), PARENC 1004 FORMAT (1H0,7X,1H(,29A4,A1) GO TO 2 3 CALL RDFIX(INDIC,IFLAG) 4 CALL RDNEXT(0) IF (ITEM .EQ. BLANK .AND. MC .LE. 80 .AND. .NOT. EMPTY) GO TO 4 IF (.NOT. EMPTY) CALL RDFIX(NORAYS,IFLAG) IF (INDIC .EQ. -1 .OR. INDIC .EQ. 2) INDIC = 101 IF (INDIC .EQ. 3) INDIC = 301 INDS = MOD(INDIC,10) INDP = MOD(INDIC,100) IF (INDP .LT. 10 .OR. INDP .GE. 20) WRITE (NOUT,9000) IMAGE INDW = INDIC IF (INDS .EQ. 3) INDW = INDIC - 3 IF ((INDP .LT. 10 .OR. INDP .GE. 20) 1 .AND. (INDS .NE. 3 .OR. EMPTY)) WRITE (NOUT,9005) INDW IF ((INDP .LT. 10 .OR. INDP .GE. 20) 1 .AND. (INDS .EQ. 3 .AND. .NOT. EMPTY)) 2 WRITE (NOUT,9006) INDW, NORAYS EMPTY = .TRUE. IF (INDS .LE. 4 .AND. IFLAG .EQ. 0) GO TO 10 WRITE (NOUT, 9010) INDIC = 0 10 IF (INDS .NE. 0 .AND. INDS .NE. 4) GO TO 200 C C READ NEW SYSTEM C 100 NEL = 0 I = 1 ISTOR(1) = 1 FLUSH = .FALSE. 110 CALL RDELMT IF (NWORD .EQ. 0) GO TO 400 IF (INDP .LT. 10) CALL PRINT1(LABLE,NWORD,DATUM,VARY,0) IF (NTYPE .EQ. 0) GO TO 110 NEL = NEL + 1 FLUSH = NEL+1 .GT. NNEL .OR. I + LENGTH .GT. NDATA IF (FLUSH) GO TO 150 LABEL(NEL) = LABLE DO 120 J = 1, LENGTH DATA(I) = DATUM(J) TIE (I) = VARY (J) 120 I = I + 1 ISTOR(NEL+1) = I GO TO 110 150 I = I + LENGTH GO TO 110 C C CONVERT INTERNAL VARY CODES TO EXTERNAL C 200 SEC = .FALSE. DO 210 NUM = 1, NEL I = ISTOR(NUM) NTYPE = DATA(I) IF (NTYPE .LE. 0 .OR. NTYPE .GE. 50) GO TO 210 IF (NTYPE .EQ. 17) SEC = .TRUE. NVARY = NIV(NTYPE) IF (NVARY .EQ. 0) GO TO 210 DO 205 JV = 1, NVARY I = I + 1 K = IABS(TIE(I)) IF (K .NE. 0) TIE(I) = ISIGN(VSTOR(K), TIE(I)) 205 CONTINUE 210 CONTINUE C C MODIFY EXISTING SYSTEM C 220 NUM = 0 230 CALL RDELMT IF (NWORD .EQ. 0) GO TO 400 IF (FLUSH) GO TO 230 IF (LABLE .NE. BLANK) GO TO 250 IF (NTYPE) 270,232,270 232 IF (INDP .LT. 10) CALL PRINT1(LABLE,NWORD,DATUM,VARY,0) GO TO 230 250 J1 = NUM + 1 DO 260 J = J1, NEL IF (LABLE .EQ. LABEL(J)) GO TO 300 260 CONTINUE IF (NUM .NE. 0) GO TO 220 270 WRITE (NOUT, 9270) LABLE FLUSH = .TRUE. GO TO 230 C C LABEL HAS BEEN FOUND. NOW REPLACE ELEMENT C 300 NUM = J I = IABS(ISTOR(NUM)) K = I L = IABS(ISTOR(NUM+1)) - I IF (NTYPE .EQ. 0) GO TO 310 IF (LENGTH .LE. L) GO TO 320 WRITE (NOUT, 9300) LABLE FLUSH = .TRUE. GO TO 230 310 NWORD = L 320 DO 330 J = 1, NWORD DATA(I) = DATUM(J) 330 I = I + 1 DO 340 J = 1, L TIE(K) = VARY(J) 340 K = K + 1 ISTOR(NUM) = - ISTOR(NUM) IF (NUM - NEL) 250, 220, 220 C C OPTIONALLY PRINT MODIFIED SYSTEM C 400 IF (INDS .EQ. 0) GO TO 402 DO 401 NUM = 1, NEL IPI = 0 I = IABS(ISTOR(NUM)) L = IABS(ISTOR(NUM+1)) - I IF (I .EQ. ISTOR(NUM)) GO TO 401 IPI = 1 ISTOR(NUM) = I 401 IF (INDP .LT. 10) CALL PRINT1(LABEL(NUM),L,DATA(I),TIE(I),IPI) 402 IF (INDP .LT. 10) WRITE (NOUT,9400) C C CONVERT EXTERNAL VARY CODES TO INTERNAL C 500 IF (FLUSH) WRITE (NOUT,9150) IF (FLUSH .OR. INDP .LE. 10) 1 WRITE (NOUT,9160) NEL, NNEL, I, NDATA IF (FLUSH) GO TO 1 ALIGN = .FALSE. BAX = .FALSE. SEC = .FALSE. NORD1 = 1 NORD2 = 1 NORD3 = 1 NC = 0 NV1 = 0 NVMAX = 20 DO 510 J = 1, 20 510 VSTOR(J) = 0 DO 520 NUM = 1, NEL I = ISTOR(NUM) NTYPE = DATA(I) IF (NTYPE .LE. 0) GO TO 520 IF (NTYPE .EQ. 8) ALIGN = .TRUE. IF (NTYPE .EQ. 10) NC = NC + 1 IF (NTYPE .EQ. 13 .AND. IFIX(DATA(I+1)) .EQ. 9) BAX = .TRUE. IF (NTYPE .NE. 17) GO TO 520 NORD1 = IFIX(DATA(I+1)) NORD2 = NORD1 NORD3 = IFIX(DATA(I+2)) 520 CONTINUE IF (ALIGN) SEC = .FALSE. IF (SEC) NVMAX = 10 IF (SEC) NORD1 = 2 DO 700 NUM = 1, NEL I = ISTOR(NUM) NTYPE = DATA(I) IF (NTYPE .LE. 0 .OR. NTYPE .GE. 50) GO TO 700 NVARY = NIV(NTYPE) IF (NVARY .EQ. 0) GO TO 700 DO 690 JV = 1, NVARY I = I + 1 IVARY = IABS(TIE(I)) IF (IVARY - 1) 690, 650, 610 610 IF (IVARY .LT. 7 .OR. IVARY .GT. 9) GO TO 620 IVARY = IVARY - 5 TIE(I) = - TIE(I) 620 IF (NV1 .EQ. 0) GO TO 650 DO 630 N = 1, NV1 IF (VSTOR(N) .EQ. IVARY) GO TO 680 630 CONTINUE 650 IF (NV1 .LT. NVMAX) GO TO 670 660 WRITE (NOUT, 9660) JV, NUM TIE(I) = 0 GO TO 690 670 NV1 = NV1 + 1 VSTOR(NV1) = IVARY N = NV1 680 TIE(I) = ISIGN(N, TIE(I)) 690 CONTINUE 700 CONTINUE RETURN C 9000 FORMAT (2H0",20A4,1H") 9005 FORMAT (1H0,I5) 9006 FORMAT (1H0,2I10) 9010 FORMAT (48H0INDICATOR VALUE WRONG OR MISSING - ZERO ASSUMED) 9150 FORMAT (27H0DATA OVERFLOW, RUN FLUSHED) 9160 FORMAT (1H0,I5,41H ELEMENTS USED OUT OF A MAXIMUM ALLOWABLE,I5/ 1 1H ,I5,40H NUMBERS USED OUT OF A MAXIMUM ALLOWABLE,I6) 9270 FORMAT (27H0NO MATCH FOUND FOR LABEL ",A4,1H") 9300 FORMAT (8H0LABEL ",A4,35H" CANNOT BE REPLACED - DATA OVERLAP) 9400 FORMAT (9H0SENTINEL) 9410 FORMAT (28H0MODIFIED SYSTEM FOLLOWS ...) 9660 FORMAT (10H0PARAMETER,I3,12H OF ELEMENT ,I4, 1 33H NOT VARIED - TOO MANY PARAMETERS) END SUBROUTINE FOCUS COMMON /BLOC3/ TYPE, L, LV INTEGER TYPE REAL L, LV COMMON /BLOC11/ R(6,6), RV(6,6), T(5,21), TV(5,21), U(5,56), 1 UV(5,56) COMMON /BLOC24/ B, KQ2, KVK, K2H, K2V, CS, SN, DISN, DSVN, J REAL KQ2, KVK, K2H, K2V REAL KL C KL = SQRT( ABS(KQ2)) * L IF ( KQ2 .GE. 0.) GO TO 349 Y = EXP(KL) WOY = 1.0/Y CS = 0.5*(Y + WOY) SN = 0.5*(Y - WOY) GO TO 350 349 CS = COS(KL) SN = SIN(KL) 350 R(J+1,J+1) = CS R(J,J) = CS IF (KL .EQ. 0.) GO TO 351 R(J,J+1) = L*SN/KL GO TO 352 351 R(J,J+1) = L 352 R(J+1,J) = - KQ2 * R(J,J+1) RETURN END SUBROUTINE FORM COMMON /BLOC1/ NEL, NUM, NDIF, I, ISTOR(3129), DATA(13160) COMMON /BLOC5/ VSTOR(20), TIE(13160), LABEL(3129), LABM(10) INTEGER VSTOR, TIE COMMON /BLOC28/ COC, DE0, SD, CTY, JV, NC, NV1, NV2, NV3 INTEGER CTY COMMON /BLOC29/ A(21), CW, CA(21,21), SCALE(21), CASAV(21,21), 1 PMARQ, CHSMIN, XNORM, GNORM, EPS LOGICAL ACTIV(21) INTEGER TYPE, VARY REAL LIMIT 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 CALL DERIVE C C SYMMETRIZE MATRIX C DO 20 L1 = 2, NV1, 1 L1P1 = L1 + 1 DO 20 L2 = L1P1, NP1 CA(L1,L2) = CA(L2,L1) 20 CONTINUE C C DETERMINE WHICH VARIABLES WILL NOT HIT LIMITS C IF (CHSMIN .GT. 0.0 .AND. CA(1,1) .GE. CHSMIN) RETURN CHSMIN = CA(1,1) DO 30 N = 1, NP1 30 ACTIV(N) = .TRUE. DO 70 NUM = 1, NEL I = ISTOR(NUM) TYPE = DATA(I) IF (TYPE .LE. 0 .OR. TYPE .GE. 50) GO TO 70 NVT = NIV(TYPE) IF (NVT .LT. 1) GO TO 70 DO 60 J = 1, NVT IPLUSJ = I + J VARY = TIE(IPLUSJ) IF (VARY .EQ. 0) 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 40 SI = LIMIT(TYPE,J,1) IF (X2 .GT. SI) GO TO 40 ACTIV(IVARY) = ACTIV(IVARY) .AND. SIG*CA(IVARY,1) .GT. 0.0 C 40 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) .LT. 0.0 60 CONTINUE 70 CONTINUE C DO 80 N = 2, NP1 IF (ACTIV(N)) GO TO 80 DO 75 J = 1, NP1 CA(J,N) = 0.0 75 CA(N,J) = 0.0 80 CONTINUE C C CALCULATE SCALING FACTOR FOR NORMAL MATRIX C SCALE(1) = 1.0 DO 90 J = 2, NP1 SCALE(J) = 0.0 IF (CA(J,J) .GT. 0.0) SCALE(J) = 1.0/SQRT(CA(J,J)) 90 CONTINUE C C SAVE CA ARRAY C DO 100 J = 2, NP1 DO 100 K = 1, NP1 100 CASAV(J,K) = CA(J,K) C C CALCULATE MAGNITUDE OF GRADIENT C GNORM = 0.0 DO 110 J = 2, NP1 CAJ1 = CA(J,1) 110 GNORM = GNORM + CAJ1*CAJ1 GNORM = SQRT(GNORM) RETURN END SUBROUTINE GATHER COMMON /BLOC1/ NEL, NUM, NDIF, I, ISTOR(3129), DATA(13160) COMMON /BLOC3/ TYPE, L, LV INTEGER TYPE REAL L, LV COMMON /BLOC28/ COC, DE0, SD, CTY, JV, NC, NV1, NV2, NV3 INTEGER CTY COMMON /BLOC29/ A(21), CW, CA(21,21), SCALE(21), CASAV(21,21), 1 PMARQ, CHSMIN, XNORM, GNORM, EPS COMMON /BLOC44/ REG(20), DREG(20,20), LREG(20) LOGICAL LREG C NP1 = NV1 + 1 IF (TYPE .NE. 10) GO TO 100 DO 710 L1 = 1, NP1 DO 710 L2 = 1, L1 CA(L1,L2) = CA(L1,L2) + CW * A(L1) * A(L2) 710 CONTINUE RETURN C 100 J = DATA(I+3) LREG(J) = .TRUE. REG(J) = - A(1) DO 110 N = 1, 20 110 DREG(J,N) = 0.0 IF (NV1 .LT. 1) GO TO 150 DO 120 N = 1, NV1 120 DREG(J,N) = A(N+1) 150 RETURN END SUBROUTINE GROPE COMMON /BLOC1/ NEL, NUM, NDIF, I, ISTOR(3129), DATA(13160) COMMON /BLOC3/ TYPE, L, LV INTEGER TYPE REAL L, LV COMMON /BLOC5/ VSTOR(20), TIE(13160), LABEL(3129), LABM(10) INTEGER VSTOR, TIE COMMON /BLOC16/ SI(6,6), SV(6,6,20), CO(6), COV(6,20), RI, 1 SVP(20), CVP(20), SOFA LOGICAL SVP, CVP, SOFA COMMON /BLOC17/ COD(6), COF(6), PSIX, PSIY, PSIX1, PSIY1, NOPH LOGICAL NOPH COMMON /BLOC26/ O(4,3,3), X0(4,3), IR, RORC, TYT, ALIGN, TMK, 1 FEO, CHORD INTEGER RORC, TYT LOGICAL ALIGN, TMK, FEO, CHORD COMMON /BLOC28/ COC, DE0, SD, CTY, JV, NC, NV1, NV2, NV3 INTEGER CTY COMMON /BLOC40/ OV(3,3,20), X0V(3,20), OIV(3,3), XIV(3), OVP(20) LOGICAL OVP INTEGER VARSP DIMENSION OS(3,3), XS(3) C C INDIVIDUAL COORDINATE TRANSFORM TIMES DERIVATIVE OF C ACCUMULATED COORDINATE TRANSFORM C IF (NV1 .LT. 1) GO TO 200 DO 150 N = 1, NV1 IF (.NOT. OVP(N)) GO TO 150 DO 113 J = 1, 3 S = 0.0 DO 112 K = 1, 3 S1 = 0.0 DO 111 M = 1, 3 S1 = S1 + O(1,J,M)*OV(M,K,N) 111 CONTINUE OS(J,K) = S1 S = S + OV(K,J,N)*X0(1,K) 112 CONTINUE X0V(J,N) = X0V(J,N) + S 113 CONTINUE DO 114 J = 1, 3 DO 114 J1 = 1, 3 OV(J,J1,N) = OS(J,J1) 114 CONTINUE 150 CONTINUE C C DERIVATIVE OF INDIVIDUAL COORDINATE TRANSFORM TIMES C ACCUMULATED COORDINATE TRANSFORM C 200 NVTYPE = NV(TYPE) NVSHOW = NIV(TYPE) IF (NVTYPE .EQ. 0) GO TO 300 DO 250 JV = 1, NVTYPE IF (TYPE .EQ. 13) GO TO 203 IF (JV .GT. NVSHOW) GO TO 201 IPLJV = I + JV NV2 = TIE(IPLJV) GO TO 202 201 NV2 = VARSP(TYPE,JV) 202 IF (NV2 .EQ. 0) GO TO 250 NV1 = MAX0(NV1,IABS(NV2)) GO TO 205 203 NV2 = JV IF (.NOT. CVP(NV2)) GO TO 250 205 CALL SQUIRM IF (NV2 .GT. 0) GO TO 210 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 C 210 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 C IF (OVP(NV2)) GO TO 230 DO 225 J = 1, 3 X0V(J,NV2) = XS(J) DO 225 K = 1, 3 OV(J,K,NV2) = OS(J,K) 225 CONTINUE GO TO 240 C 230 DO 235 J = 1, 3 X0V(J,NV2) = X0V(J,NV2) + XS(J) DO 235 K = 1, 3 OV(J,K,NV2) = OV(J,K,NV2) + OS(J,K) 235 CONTINUE C 240 OVP(NV2) = .TRUE. 250 CONTINUE C C ACCUMULATED FLOOR COORDINATES C 300 CALL ADVANC(4) RETURN END SUBROUTINE HUNT2 COMMON /BLOC1/ NEL, NUM, NDIF, I, ISTOR(3129), DATA(13160) COMMON /BLOC21/ EN, ES, BE, APB(2), LAYK, LAYL, LAYX, RABT REAL LAYK, LAYL, LAYX COMMON /BLOC22/ LBEND, BE1, SB, TB, TB1, NBVARY, BEFORE LOGICAL BEFORE REAL LBEND COMMON /BLOC27/ CT(6,6), CT0(6,6), CT1(3,3), X0L(3), VM(6), 1 VMT(6), COM(6,6,10), OR(3,3), XR(3), LMIS(2,10), 2 DMC, NM LOGICAL DMC REAL LMIS C C CHECK FOR FOLLOWING FRINGE FIELD SPECIFICATION C DMC = .TRUE. 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) IF (DATA(II) .EQ. 2.0) GO TO 30 IF (DATA(II) .NE. 13.0) GO TO 50 10 CONTINUE C C DETERMINE IF IT PERTAINS TO THIS MAGNET C 30 NUMA = NUM NUM = J CALL CHEK(CKK) DMC = BEFORE .OR. CKK .EQ. 0.0 NUM = NUMA 50 RETURN END SUBROUTINE INFECT COMMON /BLOC11/ R(6,6), RV(6,6), T(5,21), TV(5,21), U(5,56), 1 UV(5,56) COMMON /BLOC27/ CT(6,6), CT0(6,6), CT1(3,3), X0L(3), VM(6), 1 VMT(6), COM(6,6,10), OR(3,3), XR(3), LMIS(2,10), 2 DMC, NM LOGICAL DMC REAL LMIS DIMENSION FOOD(6) C DO 50 N = 1, NM DO 50 M = 1, 6 DO 10 L = 1, 6 S = 0.0 DO 5 K = 1, 6 S = S + R(L,K)*COM(K,M,N) 5 CONTINUE FOOD(L) = S 10 CONTINUE DO 20 L = 1, 6 COM(L,M,N) = FOOD(L) 20 CONTINUE 50 CONTINUE RETURN END SUBROUTINE INITZE COMMON /BLOC1/ NEL, NUM, NDIF, I, ISTOR(3129), DATA(13160) COMMON /BLOC4/ LC, TOTANG, TOTROT, LCV(20), LUP(3) REAL LC, LCV, LUP COMMON /BLOC12/ RC(6,6), RCV(6,6,20), TC(5,21), UC(5,56), RCP, 1 RVP(20) LOGICAL RCP, RVP COMMON /BLOC13/ RC2(6,6), R2V(6,6,20), TC2(5,21), T2V(5,21,10), 1 UC2(5,56), U2V(5,56,10), R2P, R2VP(20) LOGICAL R2P, R2VP COMMON /BLOC14/ RC3(6,6), TC3(5,21), UC3(5,56), R3P LOGICAL R3P COMMON /BLOC16/ SI(6,6), SV(6,6,20), CO(6), COV(6,20), RI, 1 SVP(20), CVP(20), SOFA LOGICAL SVP, CVP, SOFA COMMON /BLOC18/ SIT(6,6), CEN(6), RECENT LOGICAL RECENT COMMON /BLOC20/ ETA(6), DETA(6,20), RAY, EVP(20) LOGICAL RAY, EVP COMMON /BLOC21/ EN, ES, BE, APB(2), LAYK, LAYL, LAYX, RABT REAL LAYK, LAYL, LAYX COMMON /BLOC22/ LBEND, BE1, SB, TB, TB1, NBVARY, BEFORE LOGICAL BEFORE REAL LBEND COMMON /BLOC23/ H0, AL, NB, BDB, RMPS, VRN, NPN, BDBP, RNMS, DCOV LOGICAL DCOV REAL NB, NPN COMMON /BLOC25/ AP, CAP, JA LOGICAL CAP COMMON /BLOC26/ O(4,3,3), X0(4,3), IR, RORC, TYT, ALIGN, TMK, 1 FEO, CHORD INTEGER RORC, TYT LOGICAL ALIGN, TMK, FEO, CHORD COMMON /BLOC27/ CT(6,6), CT0(6,6), CT1(3,3), X0L(3), VM(6), 1 VMT(6), COM(6,6,10), OR(3,3), XR(3), LMIS(2,10), 2 DMC, NM LOGICAL DMC REAL LMIS COMMON /BLOC28/ COC, DE0, SD, CTY, JV, NC, NV1, NV2, NV3 INTEGER CTY COMMON /BLOC30/ CDB, NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, 1 LCPR, ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, 2 LAY191, NPFR INTEGER CDB LOGICAL NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, LCPR, 1 ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, LAY191 COMMON /BLOC31/ J1, TYP1 INTEGER TYP1 COMMON /BLOC33/ FOTILT, SM, TH, PREF COMMON /BLOC34/ NORD1, NORD2, NORD3, NORDX, LINEAR, JH, SIG LOGICAL LINEAR COMMON /BLOC36/ VARS(8), SEXMAX, SEXLIM INTEGER VARS LOGICAL SEXLIM COMMON /BLOC40/ OV(3,3,20), X0V(3,20), OIV(3,3), XIV(3), OVP(20) LOGICAL OVP COMMON /BLOC44/ REG(20), DREG(20,20), LREG(20) LOGICAL LREG COMMON /BLOC47/ IC(4), IS(4), IP, NNDS, NDLEV COMMON /BLOC49/ PRAN2, PRAN3, PRAN4(3), PRAN5(3), PRAN7(6), 1 PRAN11(4), PRAN16(30), PRAN18(3), PRAN19(2), 2 PRAN20, PRAN25(3) COMMON /BLOC50/ BDBI, LAYKI, LAYLI, LAYXI, RAB1I, RAB2I, RMPSI, 1 VRNI, NPNI, BDBPI, RNMSI REAL LAYKI, LAYLI, LAYXI, NPNI C NUM = 1 IF (NV3 .LT. 1) GO TO 10 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 10 CONTINUE NC = 0 NV1 = 0 NDIF = 1 NM = 0 LC = 0.0 TOTANG = 0.0 TOTROT = 0.0 RCP = .FALSE. R2P = .FALSE. R3P = .FALSE. SOFA = .FALSE. RECENT = .FALSE. RAY = .FALSE. DMC = .FALSE. APB(1) = 0.0 APB(2) = 0.0 BEFORE = .FALSE. DCOV = .FALSE. CAP = .FALSE. IR = 1 RORC = 0 TMK = .FALSE. FEO = .FALSE. CHORD = .FALSE. NOR = .FALSE. RAT = .FALSE. R1P = .FALSE. LAY = .FALSE. SUPP = .FALSE. ONLY = .FALSE. TERSE = .FALSE. LCPR = .TRUE. ANIN = .FALSE. REFER = .FALSE. ACCEL = .FALSE. UNRO = .FALSE. HTGQ = .TRUE. ELPR = .TRUE. LAY191 = .FALSE. NPFR = 0 TYP1 = 0 FOTILT = 0.0 SM = 0.0 PREF = 0.0 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, 20 30 LREG(N) = .FALSE. JH = 1 SIG = 1.0 IP = 0 NNDS = 0 NDLEV = 0 PRAN2 = 0.0 PRAN3 = 0.0 DO 41 J = 1, 3 41 PRAN4(J) = 0.0 DO 42 J = 1, 3 42 PRAN5(J) = 0.0 DO 43 J = 1, 6 43 PRAN7(J) = 0.0 DO 44 J = 1, 4 44 PRAN11(J) = 0.0 DO 45 J = 1, 30 45 PRAN16(J) = 0.0 DO 46 J = 1, 3 46 PRAN18(J) = 0.0 DO 47 J = 1, 2 47 PRAN19(J) = 0.0 PRAN20 = 0.0 DO 48 J = 1, 3 48 PRAN25(J) = 0.0 BDBI = 0.0 LAYKI = 0.5 LAYLI = .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 CALL RESET(2) CALL RESET(3) CALL RESET(4) CALL UNITS(0) CALL RANST RETURN END SUBROUTINE INIT1 COMMON /BLOC16/ SI(6,6), SV(6,6,20), CO(6), COV(6,20), RI, 1 SVP(20), CVP(20), SOFA LOGICAL SVP, CVP, SOFA COMMON /BLOC17/ COD(6), COF(6), PSIX, PSIY, PSIX1, PSIY1, NOPH LOGICAL NOPH COMMON /BLOC18/ SIT(6,6), CEN(6), RECENT LOGICAL RECENT COMMON /BLOC28/ COC, DE0, SD, CTY, JV, NC, NV1, NV2, NV3 INTEGER CTY C IF (NV1 .LT. 1) GO TO 110 DO 100 IR2P = 1, NV1, 1 SVP(IR2P) = .FALSE. 100 CONTINUE 110 RECENT = .FALSE. SOFA = .FALSE. PSIX = 0.0 PSIY = 0.0 RETURN END SUBROUTINE INQ COMMON /BLOC28/ COC, DE0, SD, CTY, JV, NC, NV1, NV2, NV3 INTEGER CTY COMMON /BLOC29/ A(21), CW, CA(21,21), SCALE(21), CASAV(21,21), 1 PMARQ, CHSMIN, XNORM, GNORM, EPS COMMON /BLOC34/ NORD1, NORD2, NORD3, NORDX, LINEAR, JH, SIG LOGICAL LINEAR INTEGER ROW(21),COL(21) REAL CAT(21) C C NORMALIZE ROWS AND COLUMNS C N = NV1 + 1 DO 15 I = 2, N DO 15 J = 1, N 15 CA(I,J) = CA(I,J)*SCALE(I)*SCALE(J) CM0 = 1.0E-5 C C ADD MARQUARDT-LEVENBERG PARAMETER C IF (PMARQ .EQ. 0.0) GO TO 20 DO 18 J = 2, N 18 CA(J,J) = CA(J,J) + PMARQ 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 .LE. CM) GO TO 25 CM = CM1 KI = I 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 .LE. CM) GO TO 30 CM = CM1 KJ = J 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 .LE. CM) GO TO 40 CM = CM1 KI = I KJ = J 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 .EQ. K) GO TO 80 DO 75 J = 1, N IF (J .NE. K) CA(I,J) = CA(I,J) + CK1*CAT(J) 75 CONTINUE 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) PMARQ = SQRT(DNUM/DEN) 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 C DETERMINE STEP SIZE C XNORM = 0.0 DO 180 J = 2, N CAJ1 = CA(J,1) 180 XNORM = XNORM + CAJ1*CAJ1 XNORM = SQRT(XNORM) RETURN END SUBROUTINE IO C C IO -- IN GREEK MYTHOLOGY, A MAIDEN LOVED BY ZEUS C AND CHANGED INTO A HEIFER BY JEALOUS HERA C OR, IN SOME TALES, BY ZEUS, TO PROTECT HER: C SHE WAS WATCHED BY HUNDRED-EYED ARGUS C AND WAS DRIVEN TO EGYPT, C WHERE SHE REGAINED HER NATURAL FORM. C COMMON /BLOC2/ NIN, NOUT, NPUNCH COMMON /BLOC4/ LC, TOTANG, TOTROT, LCV(20), LUP(3) REAL LC, LCV, LUP COMMON /BLOC12/ RC(6,6), RCV(6,6,20), TC(5,21), UC(5,56), RCP, 1 RVP(20) LOGICAL RCP, RVP COMMON /BLOC13/ RC2(6,6), R2V(6,6,20), TC2(5,21), T2V(5,21,10), 1 UC2(5,56), U2V(5,56,10), R2P, R2VP(20) LOGICAL R2P, R2VP COMMON /BLOC16/ SI(6,6), SV(6,6,20), CO(6), COV(6,20), RI, 1 SVP(20), CVP(20), SOFA LOGICAL SVP, CVP, SOFA COMMON /BLOC18/ SIT(6,6), CEN(6), RECENT LOGICAL RECENT COMMON /BLOC25/ AP, CAP, JA LOGICAL CAP COMMON /BLOC27/ CT(6,6), CT0(6,6), CT1(3,3), X0L(3), VM(6), 1 VMT(6), COM(6,6,10), OR(3,3), XR(3), LMIS(2,10), 2 DMC, NM LOGICAL DMC REAL LMIS COMMON /BLOC30/ CDB, NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, 1 LCPR, ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, 2 LAY191, NPFR INTEGER CDB LOGICAL NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, LCPR, 1 ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, LAY191 COMMON /BLOC32/ UNIT(12), XDIME(12) COMMON /BLOC34/ NORD1, NORD2, NORD3, NORDX, LINEAR, JH, SIG LOGICAL LINEAR DATA IUP /4H UP/, IDOWN /4HDOWN/ 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. 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 .GE. 29 .AND. CDB .LE. 36) GO TO 300 RETURN C C PRINT BEAM MATRIX SIGMA C 10 IF (NOR .OR. (RAT .AND. TERSE)) RETURN IF (.NOT. SOFA .AND. NORD3 .LT. 1) RETURN CALL QEO RETURN C C SUPPRESS BEAM MATRIX PRINT C 20 NOR = .FALSE. RETURN C C PRINT BEAM MATRIX AFTER EACH ELEMENT C 30 NOR = .TRUE. IF (ACCEL) WRITE (NOUT,1001) RETURN C C PRINT TRANSFER MATRIX R OR R2 C 40 IF (RAT .OR. (NOR .AND. TERSE)) RETURN IF (.NOT. TERSE .AND. .NOT. SOFA .AND. NORD3 .LT. 1) RETURN IF (RCP .OR. R2P) CALL RCOUT RETURN C C SUPPRESS AUTOMATIC TRANSFER MATRIX PRINT C 50 RAT = .FALSE. RETURN C C PRINT TRANSFER MATRIX AFTER EACH ELEMENT C 60 IF (RAT) RETURN IF (TERSE) WRITE (NOUT,1000) 1000 FORMAT (1H ,35X,3HR11,6X,3HR12,6X,3HR21,6X,3HR22,10X,3HR33,6X, 1 3HR34,6X,3HR43,6X,3HR44,10X,3HR16,6X,3HR26) IF ((TERSE .OR. SOFA .OR. NORD3 .GE. 1) .AND. (RCP .OR. R2P)) 1 CALL RCOUT RAT = .TRUE. RETURN C C ACCELERATOR PARAMETERS C 70 IF (NOR .AND. NORD3 .EQ. 1) WRITE (NOUT,1001) 1001 FORMAT (1H ,36X,4HPSIX,6X,4HPSIY,6X,5HBETAX,5X,5HBETAY,5X, 1 6HALPHAX,4X,6HALPHAY,4X,4HETAX,6X,4HETAY,6X,5HETAPX,5X,5HETAPY) RETURN C C PRINT MISALIGNMENT PARTIAL DERIVATIVE TABLE C 80 IF (NM .GE. 1) CALL WOE RETURN C C PRINT FLOOR COORDINATES AFTER BEAM LINE REALIGNMENT C 90 IF (LAY) CALL SURVEY RETURN C C OBSERVE MAGNET APERTURES C 100 CAP = .TRUE. RETURN 110 CONTINUE RETURN C C PRINT POSITIONS OF HORIZONTAL AND VERTICAL WAISTS C 140 IF (NORD3 .LT. 1) RETURN IF (.NOT. RECENT) CALL BEAM SIT11 = SIT(1,1) SIT12 = SIT(1,2) SIT22 = SIT(2,2) IF (SIT22 .LE. 0.0) GO TO 144 ADIFF = - SIT12/(SIT22*UNIT(8)) IF (ADIFF .LT. 0.0) IPOS = IUP IF (ADIFF .GE. 0.0) IPOS = IDOWN ALONG = LC/UNIT(8) + ADIFF ADIFF = ABS(ADIFF) XSIZE = (SIT11 - SIT12**2/SIT22) IF (ACCEL) GO TO 143 XSIZE = SQRT(XSIZE)/UNIT(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,1X, 1 A4,9HSTREAM AT,F10.3,1X,A4) GO TO 144 143 XSIZE = XSIZE*UNIT(2)/UNIT(1) WRITE (NOUT,1004) XSIZE, ADIFF, XDIME(8), IPOS, ALONG, XDIME(8) 1004 FORMAT (1H ,32X,4HBETA,F8.3,1X,16HHORIZONTAL WAIST,F10.3,1X,A4,1X, 1 A4,9HSTREAM AT,F10.3,1X,A4) 144 SIT33 = SIT(3,3) SIT34 = SIT(3,4) SIT44 = SIT(4,4) IF (SIT44 .EQ. 0.0) RETURN ADIFF = - SIT34/(SIT44*UNIT(8)) IF (ADIFF .LT. 0.0) IPOS = IUP IF (ADIFF .GE. 0.0) IPOS = IDOWN ALONG = LC/UNIT(8) + ADIFF ADIFF = ABS(ADIFF) YSIZE = (SIT33 - SIT34**2/SIT44) IF (ACCEL) GO TO 147 YSIZE = SQRT(YSIZE)/UNIT(3) WRITE (NOUT,1003) YSIZE, XDIME(1), ADIFF, XDIME(8), IPOS, ALONG, 1 XDIME(8) 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) RETURN 147 YSIZE = YSIZE*UNIT(4)/UNIT(3) WRITE (NOUT,1005) YSIZE, ADIFF, XDIME(8), IPOS, ALONG, XDIME(8) 1005 FORMAT (1H ,32X,4HBETA,F8.3,1X,16H VERTICAL WAIST,F10.3,1X,A4,1X, 1 A4,9HSTREAM AT,F10.3,1X,A4) RETURN C C EXTRA PRECISION FOR VARIED PARAMETERS C 160 UNRO = .TRUE. RETURN C C SUPPRESS PRINTING OF PHYSICAL PARAMETERS C 170 SUPP = .TRUE. ONLY = .FALSE. RETURN C C PRINT ONLY ITEMS RELATED TO FITTING C 180 ONLY = .TRUE. SUPP = .FALSE. RETURN C C PRINT ABBREVIATED OUTPUT C 190 TERSE = .TRUE. IF (RAT) WRITE (NOUT,1000) RETURN C C TURN OFF PRINTING OF ELEMENTS C 260 ELPR = .FALSE. DO 261 J = 1, 3 WRITE (NOUT,1006) 261 CONTINUE 1006 FORMAT (1H ,15X,1H.) RETURN C C RESTORE PRINTING OF ELEMENTS C 270 ELPR = .TRUE. RETURN C C PUNCH TRANSFER MATRIX ON CARDS C 300 IF (NORD3 .GE. 1) CALL PUNCH1 RETURN END REAL FUNCTION LIMIT( TYPE, N, K) COMMON /BLOC30/ CDB, NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, 1 LCPR, ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, 2 LAY191, NPFR INTEGER CDB LOGICAL NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, LCPR, 1 ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, LAY191 COMMON /BLOC32/ UNIT(12), XDIME(12) COMMON /BLOC34/ NORD1, NORD2, NORD3, NORDX, LINEAR, JH, SIG LOGICAL LINEAR INTEGER TYPE C C LIMITS ONLY SPECIFIED FOR FOLLOWING TYPES AND DATA: C LIMITS STORED IN A(K,L) L=1,5 C L=1 DEFAULT LIMITS TO AVOID DIVERGENCES C L=2 TYPE CODE 1 LIMITS TO AVIOD DIMENSIONS GOING -VE C L=3 TYPE 2 TO LIMIT ANGLE OF ROTATION TO 60 DEG C L=4 TYPES 3,4,5,11,18,19 TO AVOID NEGATIVE LENGTHS C L=5 TYPE 20 TO LIMIT ANGLES TO 360 DEG + OR - C REAL A(4,6) DATA A /-1.E10, 1.,1.E10, 1., 1 0., 1., 0., 0., 2 -1.04720,1.0,1.04720,1.0, 3 0., 1., 0., 0., 4 -.99999, 1., .99999, 1., 5 -360., 1., 360., 1. / C LIMIT = A(K,1) IF (TYPE .EQ. 1 .AND. .NOT. ACCEL) LIMIT = A(K,2) IF (TYPE .EQ. 2) LIMIT = A(K,3)/UNIT(7) IF (TYPE .LT. 3) RETURN IF (TYPE .LT. 6) GO TO 3 IF (TYPE .EQ. 12) LIMIT = A(K,5) IF (TYPE .EQ. 20) LIMIT = A(K,6) IF (TYPE .NE. 11 .AND. TYPE .NE. 18 .AND. TYPE .NE. 19) RETURN 3 IF (N .NE. 1) RETURN LIMIT = A(K,4) RETURN END SUBROUTINE MALIGN COMMON /BLOC4/ LC, TOTANG, TOTROT, LCV(20), LUP(3) REAL LC, LCV, LUP COMMON /BLOC11/ R(6,6), RV(6,6), T(5,21), TV(5,21), U(5,56), 1 UV(5,56) COMMON /BLOC12/ RC(6,6), RCV(6,6,20), TC(5,21), UC(5,56), RCP, 1 RVP(20) LOGICAL RCP, RVP COMMON /BLOC13/ RC2(6,6), R2V(6,6,20), TC2(5,21), T2V(5,21,10), 1 UC2(5,56), U2V(5,56,10), R2P, R2VP(20) LOGICAL R2P, R2VP DIMENSION SIM(36,6,10) EQUIVALENCE (U2V(1,1,1),SIM(1,1,1)) COMMON /BLOC14/ RC3(6,6), TC3(5,21), UC3(5,56), R3P LOGICAL R3P COMMON /BLOC15/ RS(6,6), RT(6,6), TS(5,21), TT(5,21), US(5,56), 1 UT(5,56) COMMON /BLOC16/ SI(6,6), SV(6,6,20), CO(6), COV(6,20), RI, 1 SVP(20), CVP(20), SOFA LOGICAL SVP, CVP, SOFA COMMON /BLOC17/ COD(6), COF(6), PSIX, PSIY, PSIX1, PSIY1, NOPH LOGICAL NOPH COMMON /BLOC18/ SIT(6,6), CEN(6), RECENT LOGICAL RECENT COMMON /BLOC19/ TR(5,6,6), TRA(5,6,6), URR(5,21,6), NORDE DIMENSION GT(5,6,6), GTL(180) EQUIVALENCE (GT(1,1,1),GTL(1)) EQUIVALENCE (TR(1,1,1),GT(1,1,1)) COMMON /BLOC20/ ETA(6), DETA(6,20), RAY, EVP(20) LOGICAL RAY, EVP COMMON /BLOC26/ O(4,3,3), X0(4,3), IR, RORC, TYT, ALIGN, TMK, 1 FEO, CHORD INTEGER RORC, TYT LOGICAL ALIGN, TMK, FEO, CHORD COMMON /BLOC27/ CT(6,6), CT0(6,6), CT1(3,3), X0L(3), VM(6), 1 VMT(6), COM(6,6,10), OR(3,3), XR(3), LMIS(2,10), 2 DMC, NM LOGICAL DMC REAL LMIS DIMENSION CTL(36), CT0L(36), CT1L(9) EQUIVALENCE (CT(1,1),CTL(1)), (CT0(1,1),CT0L(1)), 1 (CT1(1,1),CT1L(1)) COMMON /BLOC30/ CDB, NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, 1 LCPR, ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, 2 LAY191, NPFR INTEGER CDB LOGICAL NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, LCPR, 1 ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, LAY191 COMMON /BLOC32/ UNIT(12), XDIME(12) COMMON /BLOC34/ NORD1, NORD2, NORD3, NORDX, LINEAR, JH, SIG LOGICAL LINEAR COMMON /BLOC38/ SIOL(3,6,6), COLD(3,6), RCO(3,6,6), R2O(6,6), 1 SPO(3), RCPO(3), R2PO LOGICAL SPO, RCPO, R2PO COMMON /BLOC39/ XM(6), XMB(6), DXM(6), GXXM(6,6) DIMENSION OT(3,3), CTT(6,6) 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 IF (CHORD) GO TO 200 C C PIVOT POINT AT ENTRANCE FACE C DO 112 J = 1, 3 DO 112 K = 1, 3 OT(J,K) = 0.0 112 CONTINUE DO 113 J = 1, 3 OT(J,J) = 1.0 113 CONTINUE DO 115 J = 1, 3 DO 115 K = 1, 3 OR(J,K) = O(IR,J,K) 115 CONTINUE DO 118 J = 1, 3 118 XR(J) = X0(IR,J) CT0(5,5) = 1. CT0(3,3) = 1. CT0(2,4) = 1. CT0(1,1) = 1. CT0(4,2) = -1. C C PIVOT POINT AS INDICATED C IF (.NOT. TMK) GO TO 300 DO 122 J = 1, 3 122 X0L(J) = 0.0 S = 0.0 DO 125 J = 1, 3 S = S + X0(IR,J)**2 125 CONTINUE X0L(3) = - 0.5*S/X0(IR,3) DO 128 J = 1, 3 128 XR(J) = XR(J) + X0L(J) CT0(1,4) = X0L(3) CT0(3,2) = - X0L(3) GO TO 300 C C MISALIGNMENT ABOUT CHORD OF BENDING MAGNET C 200 S = 0.0 DO 212 J = 1, 3 S = S + X0(IR,J)**2 212 CONTINUE XNORM = SQRT(S) DO 215 J = 1, 3 OT(J,3) = X0(IR,J)/XNORM 215 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 .NE. 0.0) GO TO 225 COST = 1.0 SINT = 0.0 GO TO 230 225 COST = OT(1,3)/SINA SINT = OT(2,3)/SINA 230 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 DO 233 J = 1, 3 233 XR(J) = 0.0 S = 0.0 DO 235 J = 1, 3 235 S = S + X0(IR,J)**2 XR(3) = SQRT(S) C C PIVOT POINT AT ENTRANCE FACE C DO 245 J = 1, 3 DO 245 K = 1, 3 CT0(2*J-1,2*K-1) = OT(J,K) 245 CONTINUE DO 250 K = 1, 3 CT0(2,2*K) = OT(2,K) CT0(4,2*K) = - OT(1,K) 250 CONTINUE C C PIVOT POINT AT CHORD MIDPOINT C IF (.NOT. TMK) GO TO 270 DO 257 J = 1, 3 257 XR(J) = 0.5*XR(J) 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 260 J = 1, 3 DO 260 K = 1, 3 S = 0.0 DO 258 N = 1, 3 S = S + OT(J,N)*CT1(N,K) 258 CONTINUE CT0(2*J-1,2*K) = S 260 CONTINUE C C COORDINATE TRANSFORMATION FOR EXIT FACE C 270 DO 280 J = 1, 3 DO 280 K = 1, 3 S = 0.0 DO 275 N = 1, 3 S = S + O(IR,J,N)*OT(N,K) 275 CONTINUE OR(J,K) = S 280 CONTINUE C C EFFECT OF MISALIGNMENT ON CENTROID DISPLACEMENT C 300 CALL TFL IF (R2P .OR. R3P) CALL UPDAT2 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 370 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 370 IF (NORD1 .LE. 1) GO TO 400 DO 380 J = 1, 5 DO 380 K2 = 1, 5 IND0 = 0 IND1 = 0 DO 380 K1 = 1, 5 S = 0.0 DO 375 M = 1, K1 IND0 = IND0 + 1 S = S + TS(J,IND0)*CT0(M,K2) 375 CONTINUE K1P1 = K1 + 1 IND1 = IND1 + K1P1 IND = IND1 DO 376 M = K1P1, 5 S = S + TS(J,IND)*CT0(M,K2) IND = IND + M 376 CONTINUE GT(J,K1,K2) = GT(J,K1,K2) - 2.0*S 380 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 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 .LE. 1) GO TO 500 DO 490 J = 1, 5 K1K2 = 0 DO 490 K2 = 1, 6 DO 490 K1 = 1, K2 S = 0.0 IND = 0 K1K2 = K1K2 + 1 DO 480 L2 = 1, 6 DO 480 L1 = 1, L2 IND = IND + 1 S = S + TS(J,IND)*CT0(L1,K1)*CT0(L2,K2) 480 CONTINUE IND1 = 0 DO 485 L2 = 1, 5 L2P1 = L2 + 1 IND1 = IND1 + L2P1 IND = IND1 DO 485 L1 = L2P1, 6 S = S + TS(J,IND)*CT0(L1,K1)*CT0(L2,K2) IND = IND + L1 485 CONTINUE TT(J,K1K2) = S 490 CONTINUE C C UNCERTAINTY IN POSITION SHOWN IN BEAM MATRIX C 500 IF (TYT/100 .NE. 0) GO TO 700 IF (MOD(TYT/10,10) .NE. 0) GO TO 600 IF (NORD1 .LE. 1 .OR. FEO) GO TO 510 DO 505 J = 1, 5 S = 0.0 KK = 0 DO 504 K = 1, 6 KK = KK + K S = S + TT(J,KK)*VM(K)**2 504 CONTINUE CO(J) = CO(J) + S IF (RAY) ETA(J) = ETA(J) + S IF (S .NE. 0.0) SOFA = .TRUE. 505 CONTINUE C 510 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 511 N = 1, 6 S = S + CT(J,N)*CT(K,N)*VM(N)**2 511 CONTINUE C IF (NORD1 .LE. 1) GO TO 520 L1L2 = 0 DO 515 L2 = 1, 6 DO 515 L1 = 1, L2 L1L2 = L1L2 + 1 S = S + 2.0*TT(J,L1L2)*TT(K,L1L2)*VM(L1)**2*VM(L2)**2 515 CONTINUE L1L20 = 0 DO 518 L2 = 1, 5 L2P1 = L2 + 1 L1L20 = L1L20 + L2P1 L1L2 = L1L20 DO 518 L1 = L2P1, 6 S = S + 2.0*TT(J,L1L2)*TT(K,L1L2)*VM(L1)**2*VM(L2)**2 L1L2 = L1L2 + L1 518 CONTINUE C 520 IF (.NOT. SPO(IR)) GO TO 530 DO 525 L = 1, 6 DO 525 M = 1, 6 S = S + (CT(J,M)*GT(K,L,M) + CT(K,M)*GT(J,L,M))*COLD(IR,L)* 1 VM(M)**2 525 CONTINUE C 530 DO 535 L1 = 1, 6 DO 535 L2 = 1, 6 DO 535 M = 1, 6 S = S + GT(J,L1,M)*GT(K,L2,M)*SIOL(IR,L1,L2)*VM(M)**2 535 CONTINUE 540 SI(J,K) = SI(J,K) + S SI(K,J) = SI(J,K) 550 CONTINUE RECENT = .FALSE. GO TO 900 C C UNCERTAINTY IN POSITION SHOWN IN MISALIGNMENT TABLE C 600 NM = NM + 1 LMIS(1,NM) = LUP(IR) LMIS(2,NM) = LC IF (SOFA) GO TO 606 DO 605 J = 1, 6 DO 605 M = 1, 6 COM(J,M,NM) = 0.0 605 CONTINUE GO TO 610 606 DO 608 J = 1, 6 DO 608 M = 1, 6 COM(J,M,NM) = CO(J) 608 CONTINUE C 610 IF (NORD1 .LE. 1 .OR. FEO) GO TO 620 DO 615 J = 1, 5 MM = 0 DO 615 M = 1, 6 MM = MM + M COM(J,M,NM) = COM(J,M,NM) + TT(J,MM)*VM(M)**2 615 CONTINUE 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 .EQ. 6) GO TO 640 IF (FEO) GO TO 630 S = CT(J,M)*CT(K,M)*VM(M)**2 IF (NORD1 .GE. 2) S = S + 2.0*(TT(J,MM)*VM(M)**2)**2 IF (.NOT. SPO(IR)) GO TO 630 DO 625 L = 1, 6 S = S + (CT(J,M)*GT(K,L,M) + CT(K,M)*GT(J,L,M))* 1 COLD(IR,L)*VM(M)**2 625 CONTINUE 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 640 SIM(JPK,M,NM) = SI(J,K) + S SIM(KPJ,M,NM) = SIM(JPK,M,NM) 650 CONTINUE GO TO 900 C C KNOWN DISPLACEMENT SHOWN IN BEAM MATRIX C 700 IF (MOD(TYT/10,10) .NE. 0) GO TO 800 DO 701 J = 1, 6 701 VMT(J) = VM(J) IF (TYT .LT. 200) GO TO 710 DO 702 J = 1, 6 702 VMT(J) = VMT(J)*(2.0*RANNU(J) - 1.0) C 710 DO 720 J = 1, 6 S = 0.0 IF (FEO) GO TO 718 DO 715 K = 1, 6 S = S + CT(J,K)*VMT(K) 715 CONTINUE 718 XM(J) = S 720 CONTINUE C IF (NORD1 .LE. 1 .OR. FEO) GO TO 740 DO 730 J = 1, 5 S = 0.0 IND = 0 DO 724 L2 = 1, 6 DO 724 L1 = 1, L2 IND = IND + 1 S = S + TT(J,IND)*VMT(L1)*VMT(L2) 724 CONTINUE IND0 = 0 DO 725 L2 = 1, 5 L2P1 = L2 + 1 IND0 = IND0 + L2P1 IND = IND0 DO 725 L1 = L2P1, 6 S = S + TT(J,IND)*VMT(L1)*VMT(L2) IND = IND + L1 725 CONTINUE XM(J) = XM(J) + S 730 CONTINUE C 740 DO 745 J = 1, 5 DO 745 K = 1, 6 S = 0.0 DO 744 M = 1, 6 S = S + GT(J,K,M)*VMT(M) 744 CONTINUE RT(J,K) = S 745 CONTINUE IF (.NOT. SPO(IR)) GO TO 760 DO 750 J = 1, 5 S = 0.0 DO 748 K = 1, 6 S = S + RT(J,K)*COLD(IR,K) 748 CONTINUE XMB(J) = S 750 CONTINUE C 760 DO 762 J = 1, 5 COD(J) = XM(J) 762 CONTINUE IF (.NOT. SPO(IR)) GO TO 768 DO 765 J = 1, 5 COD(J) = COD(J) + XMB(J) 765 CONTINUE 768 DO 770 J = 1, 5 CO(J) = CO(J) + COD(J) IF (RAY) ETA(J) = ETA(J) + COD(J) 770 CONTINUE C IF (NORD3 .LT. 1) GO TO 790 DO 775 J = 1, 5 DO 775 K = 1, 6 S = 0.0 DO 773 L = 1, 6 S = S + RT(J,L)*SIOL(IR,L,K) 773 CONTINUE GXXM(J,K) = S 775 CONTINUE DO 780 J = 1, 5 DO 780 K = 1, J S = 0.0 DO 778 L = 1, 6 S = S + GXXM(J,L)*RS(K,L) + GXXM(K,L)*RS(J,L) S = S + GXXM(J,L)*RT(K,L) 778 CONTINUE SI(J,K) = SI(J,K) + S SI(K,J) = SI(J,K) 780 CONTINUE 790 IF (.NOT. FEO) SOFA = .TRUE. RECENT = .FALSE. CALL DETUNE GO TO 900 C C KNOWN DISPLACEMENT SHOWN IN MISALIGNMENT TABLE C 800 NM = NM + 1 LMIS(1,NM) = LUP(IR) LMIS(2,NM) = LC C MM = 0 DO 880 M = 1, 6 MM = MM + M DO 805 J = 1, 6 XM(J) = 0.0 IF (.NOT. FEO) XM(J) = CT(J,M)*VM(M) 805 CONTINUE C IF (NORD1 .LE. 1 .OR. FEO) GO TO 810 DO 807 J = 1, 5 XM(J) = XM(J) + TT(J,MM)*VM(M)**2 807 CONTINUE C 810 DO 815 J = 1, 5 DO 815 K = 1, 6 RT(J,K) = GT(J,K,M)*VM(M) 815 CONTINUE C IF (.NOT. SPO(IR)) GO TO 830 DO 820 J = 1, 5 S = 0.0 DO 818 K = 1, 6 S = S + RT(J,K)*COLD(IR,K) 818 CONTINUE XMB(J) = S 820 CONTINUE C 830 DO 832 J = 1, 6 COD(J) = XM(J) 832 CONTINUE IF (.NOT. SPO(IR)) GO TO 840 DO 835 J = 1, 5 COD(J) = COD(J) + XMB(J) 835 CONTINUE C 840 IF (SOFA) GO TO 845 DO 842 J = 1, 6 COM(J,M,NM) = COD(J) 842 CONTINUE GO TO 850 845 DO 848 J = 1, 6 COM(J,M,NM) = CO(J) + COD(J) 848 CONTINUE C 850 IF (NORD3 .LT. 1) GO TO 900 DO 855 J = 1, 5 DO 855 K = 1, 6 S = 0.0 DO 852 L = 1, 6 S = S + RT(J,L)*SIOL(IR,L,K) 852 CONTINUE GXXM(J,K) = S 855 CONTINUE C DO 870 J = 1, 6 DO 870 K = 1, J JPK = 6*J + K - 6 KPJ = 6*K + J - 6 S = 0.0 IF (J .EQ. 6) GO TO 865 DO 860 L = 1, 6 S = S + GXXM(J,L)*RS(K,L) + RS(J,L)*GXXM(K,L) S = S + GXXM(J,L)*RT(K,L) 860 CONTINUE 865 SIM(JPK,M,NM) = SI(J,K) + S SIM(KPJ,M,NM) = SIM(JPK,M,NM) 870 CONTINUE 880 CONTINUE C 900 DMC = .FALSE. IR = 1 RETURN END INTEGER FUNCTION NIV(TYPE) COMMON /BLOC1/ NEL, NUM, NDIF, I, ISTOR(3129), DATA(13160) COMMON /BLOC34/ NORD1, NORD2, NORD3, NORDX, LINEAR, JH, SIG LOGICAL LINEAR INTEGER NV1(27), TYPE DATA NV1 /6,1,1,3,2,0,6,6,0,0,0,15,0,6,0,2,0,0,2,1,0,0,0,0,0,0,6/ 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 .AND. IFIX(DATA(I+1)) .GE. 16 1 .AND. IFIX(DATA(I+1)) .LE. 20) NV = 2 IF (TYPE .EQ. 16 .AND. IFIX(DATA(I+1)) .GE. 22 1 .AND. IFIX(DATA(I+1)) .LE. 25) NV = 2 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) COMMON /BLOC1/ NEL, NUM, NDIF, I, ISTOR(3129), DATA(13160) COMMON /BLOC28/ COC, DE0, SD, CTY, JV, NC, NVA, NVB, NVC INTEGER CTY COMMON /BLOC34/ NORD1, NORD2, NORD3, NORDX, LINEAR, JH, SIG LOGICAL LINEAR INTEGER NV1(27), NV2(27), TYPE DATA NV1 /6,2,1,7,2,0,6,6,0,0,0,15,0,6,0,0,0,0,2,1,0,0,0,0,0,0,6/ DATA NV2 /6,3,1,9,2,0,6,6,0,0,0,15,0,6,0,0,0,2,2,1,0,0,0,0,2,0,6/ C IF (NORD1 .EQ. 1) NV = NV1(TYPE) IF (NORD1 .GE. 2) NV = NV2(TYPE) IF (TYPE .EQ. 1 .AND. NORD3 .GT. 1) NV = 0 IF (TYPE .EQ. 8 .AND. NORD3 .GT. 1) NV = 0 IF (TYPE .EQ. 12 .AND. NORD3 .GT. 1) NV = 0 IF (TYPE .EQ. 13 .AND. IFIX(DATA(I+1)) .EQ. 9) NV = NVA IF (TYPE .EQ. 16 .AND. IFIX(DATA(I+1)) .GE. 16 1 .AND. IFIX(DATA(I+1)) .LE. 20) NV = 2 RETURN END SUBROUTINE OUTFIT COMMON /BLOC1/ NEL, NUM, NDIF, I, ISTOR(3129), DATA(13160) COMMON /BLOC2/ NIN, NOUT, NPUNCH COMMON /BLOC3/ TYPE, L, LV INTEGER TYPE REAL L, LV COMMON /BLOC4/ LC, TOTANG, TOTROT, LCV(20), LUP(3) REAL LC, LCV, LUP COMMON /BLOC5/ VSTOR(20), TIE(13160), LABEL(3129), LABM(10) INTEGER VSTOR, TIE COMMON /BLOC11/ R(6,6), RV(6,6), T(5,21), TV(5,21), U(5,56), 1 UV(5,56) COMMON /BLOC12/ RC(6,6), RCV(6,6,20), TC(5,21), UC(5,56), RCP, 1 RVP(20) LOGICAL RCP, RVP COMMON /BLOC13/ RC2(6,6), R2V(6,6,20), TC2(5,21), T2V(5,21,10), 1 UC2(5,56), U2V(5,56,10), R2P, R2VP(20) LOGICAL R2P, R2VP COMMON /BLOC16/ SI(6,6), SV(6,6,20), CO(6), COV(6,20), RI, 1 SVP(20), CVP(20), SOFA LOGICAL SVP, CVP, SOFA COMMON /BLOC17/ COD(6), COF(6), PSIX, PSIY, PSIX1, PSIY1, NOPH LOGICAL NOPH COMMON /BLOC18/ SIT(6,6), CEN(6), RECENT LOGICAL RECENT COMMON /BLOC21/ EN, ES, BE, APB(2), LAYK, LAYL, LAYX, RABT REAL LAYK, LAYL, LAYX COMMON /BLOC23/ H0, AL, NB, BDB, RMPS, VRN, NPN, BDBP, RNMS, DCOV LOGICAL DCOV REAL NB, NPN COMMON /BLOC24/ B, KQ2, KVK, K2H, K2V, CS, SN, DISN, DSVN, J REAL KQ2, KVK, K2H, K2V COMMON /BLOC25/ AP, CAP, JA LOGICAL CAP COMMON /BLOC26/ O(4,3,3), X0(4,3), IR, RORC, TYT, ALIGN, TMK, 1 FEO, CHORD INTEGER RORC, TYT LOGICAL ALIGN, TMK, FEO, CHORD COMMON /BLOC27/ CT(6,6), CT0(6,6), CT1(3,3), X0L(3), VM(6), 1 VMT(6), COM(6,6,10), OR(3,3), XR(3), LMIS(2,10), 2 DMC, NM LOGICAL DMC REAL LMIS COMMON /BLOC28/ COC, DE0, SD, CTY, JV, NC, NV1, NV2, NV3 INTEGER CTY COMMON /BLOC30/ CDB, NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, 1 LCPR, ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, 2 LAY191, NPFR INTEGER CDB LOGICAL NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, LCPR, 1 ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, LAY191 COMMON /BLOC32/ UNIT(12), XDIME(12) COMMON /BLOC33/ FOTILT, SM, TH, PREF COMMON /BLOC34/ NORD1, NORD2, NORD3, NORDX, LINEAR, JH, SIG LOGICAL LINEAR COMMON /BLOC41/ LW, IMAGE(20), FLUSH, INDIC, NTYPE, LABLE, LENGTH, 1 NWORD, NVARY, DATUM(30), VARY(30) INTEGER VARY, TEXT(30) LOGICAL FLUSH EQUIVALENCE (TEXT(1),DATUM(1)) COMMON /BLOC42/ TABLE(36), PLUS, MINUS, BLANK, PERIOD, SPEC(10) INTEGER TABLE, PLUS, MINUS, BLANK, PERIOD, SPEC INTEGER QUOTE EQUIVALENCE (QUOTE,SPEC(5)) COMMON /BLOC44/ REG(20), DREG(20,20), LREG(20) LOGICAL LREG COMMON /BLOC49/ PRAN2, PRAN3, PRAN4(3), PRAN5(3), PRAN7(6), 1 PRAN11(4), PRAN16(30), PRAN18(3), PRAN19(2), 2 PRAN20, PRAN25(3) COMMON /BLOC51/ EGAIN, PHASEL, WAVEL COMMON /CONSTS/ PI, RADIAN, CLIGHT, EMASS INTEGER TYP8, TYP16, CSYM(5) LOGICAL NBE, NRT REAL LOUT DIMENSION NAM(52), ICHAR(30) DIMENSION CODO(6), VMO(6) DATA TYP8 /8/, TYP16 /16/ DATA NAM /4H*EPS, 1H*, 4H* K0, 2H *, 4H*P M, 4HASS*, 4H*PAR, 1 3HAM*, 4H* G/, 3H2 *, 4H*LEN, 4HGTH*, 4H* K1, 2H *, 4H* K2, 2 2H *, 4H*PAR, 3HAM*, 4H*PAR, 3HAM*, 4H*PAR, 3HAM*, 4H* 1/, 3 4HR1 *, 4H* 1/, 4HR2 *, 4H*RAN, 3HNO*, 4H*FOT, 4HILT*, 4H*XBE, 4 4HGIN*, 4H*YBE, 4HGIN*, 4H*ZBE, 4HGIN*, 4H*THE, 4HTA0*, 5 4H*PHI, 3H0 * , 4H*PRE, 2HF*, 4H*RMP, 2HS*, 4H*BVE, 3HRT*, 6 4H*NPR, 4HIME*, 4H*EPS, 2HP*, 4H*RNM, 2HS*/ DATA CSYM /3HADD, 4HSUBT, 4HMULT, 3HDIV, 4HSQRT/ C WRITE (NOUT,8999) IMAGE 8999 FORMAT (1H1,20A4/) CALL INITZE IF (NEL .LE. 0) GO TO 5300 10 I = ISTOR(NUM) TYPE = DATA(I) IF (TYPE .LE. 0 .OR. TYPE .GE. 50) GO TO 5200 WORK1 = LC/UNIT(8) CALL ELICIT NBE = .TRUE. NRT = .TRUE. IF (.NOT. ELPR .AND. TYPE .NE. 13) GO TO 70 ILIM = QUOTE IF (LABEL(NUM) .EQ. BLANK) ILIM = BLANK DO 20 J = 1, 30 20 ICHAR(J) = BLANK IF (TYPE .EQ. 13) GO TO 30 IF (.NOT. LCPR) WRITE (NOUT,9026) WORK1, XDIME(8) 9026 FORMAT (1H ,F10.3,1X,A4) LCPR = .TRUE. C C DO VARY CODES C 30 IVA = 0 KV = NIV(TYPE) IF (KV .EQ. 0) GO TO 60 LX = 0 DO 50 JV = 1, KV K = I + JV ISIG = TIE(K) IVARY = IABS(ISIG) LX = LX + 1 IF (ISIG .GE. 0) GO TO 40 ICHAR(LX) = MINUS 40 LX = LX + 1 IF (IVARY .EQ. 0) GO TO 50 IVARY = VSTOR(IVARY) IVA = 1 50 ICHAR(LX) = TABLE(IVARY + 1) 60 IF (.NOT. ONLY) GO TO 70 IF (IVA .EQ. 0 .AND. TYPE .NE. 10 .AND. TYPE .NE. 22 1 .AND. TYPE .NE. 23) GO TO 5001 70 GO TO (100,200,300,400,500,600,700,800,5200,1000, 1 1100,1200,1300,1400,5200,1600,1700,1800,1900,2000, 2 2100,2200,2300,5200,2500,2600,2700), TYPE C C 1. -- BEAM C 100 NRT = .FALSE. WORK1 = RI / UNIT(11) IPLNO = ISTOR(NUM+1) IF (IPLNO .GT. I + 8) GO TO 130 NEXT = IFIX(DATA(IPLNO)) IF (NEXT .EQ. 12) NBE = .FALSE. IF (ACCEL .AND. NEXT .EQ. 7) NBE = .FALSE. IF (.NOT. ELPR) GO TO 5100 101 WRITE (NOUT,9001) TYPE, ILIM, LABEL(NUM), ILIM, WORK1, XDIME(11) 9001 FORMAT (7H *BEAM*,I11,1H.,5X,A1,A4,A1,F13.5,1X,A4) GO TO 5001 C 130 IF (.NOT. ELPR) GO TO 5100 IF (SUPP) GO TO 190 WRITE (NOUT,9002) TYPE, ILIM, LABEL(NUM), ILIM, WORK1, XDIME(11) 9002 FORMAT (14H *ADD TO BEAM*,I4,1H.,5X,A1,A4,A1,F13.5,1X,A4) GO TO 5001 190 WRITE (NOUT,9002) TYPE, ILIM, LABEL(NUM), ILIM GO TO 5001 C C 2. -- POLE FACE ROTATION C 200 IF (.NOT. ELPR) GO TO 5100 IF (SUPP) GO TO 230 BEO = BE/UNIT(7) IF (NORD1 .EQ. 1) GO TO 205 IF (RABT .NE. 0.0) GO TO 210 205 WRITE (NOUT,9003) TYPE, ILIM, LABEL(NUM), ILIM, BEO, XDIME(7) 9003 FORMAT (8H *ROTAT*,I10,1H.,5X,A1,A4,A1,F13.5,1X,A4) GO TO 220 C 210 RABO = 1.0/(RABT*UNIT(8)) WRITE (NOUT,9040) TYPE, ILIM, LABEL(NUM), ILIM, BEO, XDIME(7), 1 RABO, XDIME(8) 9040 FORMAT (8H *ROTAT*,I10,1H.,5X,A1,A4,A1,2(F13.5,1X,A4)) C 220 IF (PRAN16(2) .EQ. 0.0 .AND. PRAN16(7) .EQ. 0.0 1 .AND. PRAN16(8) .EQ. 0.0) GO TO 5001 WRITE (NOUT,9041) LAYK, LAYL, LAYX 9041 FORMAT (37X,12HFORM FACTORS,3F13.5) GO TO 5001 C 230 WRITE (NOUT,9003) TYPE, ILIM, LABEL(NUM), ILIM GO TO 5001 C C 3. -- DRIFT SPACE C 300 IF (.NOT. ELPR) GO TO 5100 IF (SUPP) GO TO 310 LOUT = L/UNIT(8) WRITE (NOUT,9004) TYPE, ILIM, LABEL(NUM), ILIM, LOUT, XDIME(8) 9004 FORMAT (8H *DRIFT*,I10,1H.,5X,A1,A4,A1,F13.5,1X,A4) GO TO 5001 C 310 WRITE (NOUT,9004) TYPE, ILIM, LABEL(NUM), ILIM GO TO 5001 C C 4. -- BENDING MAGNET C 400 IF (.NOT. ELPR) GO TO 5100 IF (SUPP) GO TO 450 DO 405 NPAR = 1, 30 IF (NPAR .GE. 2 .AND. NPAR .LE. 21) GO TO 405 IF (NPAR .GE. 27) GO TO 405 IF (PRAN16(NPAR) .EQ. 0.0) GO TO 405 JJ = 2*NPAR - 1 IF (NPAR .EQ. 1) PARAM = BDB IF (NPAR .EQ. 22) PARAM = RMPS IF (NPAR .EQ. 23) PARAM = VRN IF (NPAR .EQ. 24) PARAM = NPN IF (NPAR .EQ. 25) PARAM = BDBP IF (NPAR .EQ. 26) PARAM = RNMS FNPAR = NPAR WRITE (NOUT,9015) NAM(JJ), NAM(JJ+1), TYP16, BLANK, BLANK, BLANK, 1 FNPAR, PARAM 405 CONTINUE C LOUT = L/UNIT(8) BNORM = B/UNIT(9) IF (H0 .NE. 0.0) GO TO 415 WORK1 = 0.0 GO TO 416 415 WORK1 = 1.0/(H0*UNIT(8)) 416 WORK2 = AL/UNIT(7) WRITE (NOUT,9005) TYPE, ILIM, LABEL(NUM), ILIM, LOUT, XDIME(8), 1 BNORM, XDIME(9), NB, WORK1, XDIME(8), WORK2, XDIME(7) 9005 FORMAT (7H *BEND*,I11,1H.,5X,A1,A4,A1,2(F13.5,1X,A4), F13.5, 1 5X,2H (,F10.3,1X,A4,1H,,F8.3,1X,A4,1H)) C 420 IF (RORC .NE. 3 .AND. RORC .NE. 4) GO TO 5001 IF (TYT .LT. 200) GO TO 5001 I1 = TABLE(TYT/100 + 1) I2 = TABLE(MOD(TYT/10,10) + 1) I3 = TABLE(RORC + 1) DO 425 J = 1, 6 J2MOD = MOD(J-1,2) + 1 VMO(J) = VMT(J)/UNIT(J2MOD) 425 CONTINUE ILIM = BLANK IF (LABMIS .NE. BLANK) ILIM = QUOTE WRITE (NOUT,9009) TYP8, ILIM, LABMIS, ILIM, 1 VMO(1), XDIME(1), VMO(2), XDIME(2), VMO(3), XDIME(1), 2 VMO(4), XDIME(2), VMO(5), XDIME(1), VMO(6), XDIME(2), 3 I1, I2, I3 GO TO 5001 C 450 WRITE (NOUT,9005) TYPE, ILIM, LABEL(NUM), ILIM IF (RORC .NE. 3 .AND. RORC .NE. 4) GO TO 5001 ILIM = BLANK IF (LABMIS .NE. BLANK) ILIM = QUOTE WRITE (NOUT,9009) TYP8, ILIM, LABMIS, ILIM GO TO 5001 C C 5. -- QUADRUPOLE C 500 IF (.NOT. ELPR) GO TO 5100 IF (SUPP) GO TO 550 LOUT = L/UNIT(8) BNORM = B/UNIT(9) APOUT = AP/UNIT(1) IF (NORD1 .LT. 1) GO TO 510 IF (R(2,1) .NE. 0.0) GO TO 520 510 WORK1 = 0.0 GO TO 530 520 WORK1 = - 1.0/(R(2,1)*UNIT(8)) 530 WRITE (NOUT,9006) TYPE, ILIM, LABEL(NUM), ILIM, LOUT, 1 XDIME(8), BNORM, XDIME(9), APOUT, XDIME(1), WORK1, 2 XDIME(8) 9006 FORMAT (7H *QUAD*,I11,1H.,5X,A1,A4,A1,3(F13.5,1X,A4),2H (, 1 F11.5,1X,A4,1H)) C IF (RORC .NE. 3 .AND. RORC .NE. 5) GO TO 5001 IF (TYT .LT. 200) GO TO 5001 I1 = TABLE(TYT/100 + 1) I2 = TABLE(MOD(TYT/10,10) + 1) I3 = TABLE(RORC + 1) DO 535 J = 1, 6 J2MOD = MOD(J-1,2) + 1 VMO(J) = VMT(J)/UNIT(J2MOD) 535 CONTINUE ILIM = BLANK IF (LABMIS .NE. BLANK) ILIM = QUOTE WRITE (NOUT,9009) TYP8, ILIM, LABMIS, ILIM, 1 VMO(1), XDIME(1), VMO(2), XDIME(2), VMO(3), XDIME(1), 2 VMO(4), XDIME(2), VMO(5), XDIME(1), VMO(6), XDIME(2), 3 I1, I2, I3 GO TO 5001 C 550 WRITE (NOUT,9006) TYPE, ILIM, LABEL(NUM), ILIM IF (RORC .NE. 3 .AND. RORC .NE. 5) GO TO 5001 ILIM = BLANK IF (LABMIS .NE. BLANK) ILIM = QUOTE WRITE (NOUT,9009) TYP8, ILIM, LABMIS, ILIM GO TO 5001 C C 6. -- UPDATE C 600 NBE = .FALSE. NRT = .FALSE. IF (.NOT. ELPR) GO TO 5100 IF (SUPP) GO TO 610 WRITE (NOUT,9007) TYPE, ILIM, LABEL(NUM), ILIM, JA, DATA(I+2) 9007 FORMAT (9H *UPDATE*,I9,1H.,5X,A1,A4,A1,6X,1H(,I1,2H.),F10.1) GO TO 5001 C 610 WRITE (NOUT,9007) TYPE, ILIM, LABEL(NUM), ILIM GO TO 5001 C C 7. -- BEAM CENTROID SHIFT C 700 NRT = .FALSE. IF (.NOT. ELPR) GO TO 5100 IF (SUPP) GO TO 710 DO 705 J = 1, 6 705 CODO(J) = COD(J)/UNIT(J) WRITE (NOUT,9008) TYPE, ILIM, LABEL(NUM), ILIM, 1 (CODO(J), XDIME(J), J = 1, 6) 9008 FORMAT (13H *CENT SHIFT*,I5,1H.,5X,A1,A4,A1/1X, 1 6(F13.5,1X,A4)) GO TO 5001 C 710 WRITE (NOUT,9008) TYPE, ILIM, LABEL(NUM), ILIM GO TO 5001 C C 8. -- MAGNET MISALIGNMENT C 800 NRT = .FALSE. LABMIS = LABEL(NUM) IF (.NOT. ELPR) GO TO 5100 IF (RORC .GE. 3 .AND. TYT .GE. 200) GO TO 5100 IF (SUPP) GO TO 820 I1 = TABLE(TYT/100 + 1) I2 = TABLE(MOD(TYT/10,10) + 1) I3 = TABLE(RORC + 1) IF (TYT/10 .EQ. 20) GO TO 805 DO 802 J = 1, 6 IPJ = I + J VMO(J) = DATA(I+J) 802 CONTINUE GO TO 810 805 DO 807 J = 1, 6 J2MOD = MOD(J-1,2) + 1 VMO(J) = VMT(J)/UNIT(J2MOD) 807 CONTINUE 810 WRITE (NOUT,9009) TYPE, ILIM, LABEL(NUM), ILIM, 1 VMO(1), XDIME(1), VMO(2), XDIME(2), VMO(3), XDIME(1), 2 VMO(4), XDIME(2), VMO(5), XDIME(1), VMO(6), XDIME(2), 3 I1, I2, I3 9009 FORMAT (8H *ALIGN*,I10,1H.,5X,A1,A4,A1/1X,6(F13.5,1X,A4), 1 8H CODE,2X,3A1) GO TO 5001 C 820 WRITE (NOUT,9009) TYPE, ILIM, LABEL(NUM), ILIM GO TO 5001 C C 10. -- FITTING CONSTRAINTS C 1000 IF (.NOT. ELPR) GO TO 5100 CTY = TIE(I+1) IF (SUPP) GO TO 1010 CALL ASSESS WRITE (NOUT,9011) TYPE, TABLE(CTY+1), ILIM, LABEL(NUM), ILIM, 1 DATA(I+1), DATA(I+2), DATA(I+3), DATA(I+4), COC 9011 FORMAT (6H *FIT*,I12,1H.,A1,4X,A1,A4,A1,F8.0,F5.0,F14.5,2H /, 1 F7.5,8X,1H(,F10.5,2H )) GO TO 5200 C 1010 WRITE (NOUT,9011) TYPE, TABLE(CTY+1), ILIM, LABEL(NUM), ILIM GO TO 5200 C C 11. -- ACCELERATOR C 1100 IF (.NOT. ELPR) GO TO 5100 IF (SUPP) GO TO 1110 LOUT = L/UNIT(8) EGOUT = EGAIN/UNIT(11) WORK1 = RI/UNIT(11) PHOUT = PHASEL*RADIAN WOUT = WAVEL/UNIT(5) WRITE (NOUT,9012) TYPE, ILIM, LABEL(NUM), ILIM, LOUT, 1 XDIME(8), EGOUT, WORK1, XDIME(11), PHOUT, WOUT 9012 FORMAT (6H *ACC*,I12,1H.,5X,A1,A4,A1,F13.5,1X,A4,F13.5,5X,1H(, 1 F11.5,2H) ,A4,F13.5,F18.5) GO TO 5001 C 1110 WRITE (NOUT,9012) TYPE, ILIM, LABEL(NUM), ILIM GO TO 5001 C C 12. -- CORRELATIONS IN BEAM ELLIPSE C 1200 IF (.NOT. ELPR) GO TO 5100 IF (IVA .NE. 0) WRITE (NOUT,9029) TYPE, ILIM, LABEL(NUM), ILIM 9029 FORMAT (15H *CORRELATIONS*,I3,1H.,5X,A1,A4,A1) NRT = .FALSE. GO TO 5001 C C 13. -- INPUT-OUTPUT OPTIONS C 1300 IF (.NOT. ELPR) GO TO 1310 NIO = IFIX(DATA(I+1)) IF (NIO .NE. 9) GO TO 1310 WRITE (NOUT,9027) TYPE, ILIM, LABEL(NUM), ILIM 9027 FORMAT (13H *AXIS SHIFT*,I5,1H.,5X,A1,A4,A1) LCPR = .FALSE. 1310 IF (.NOT. ONLY) CALL IO GO TO 5200 C C 14. -- ARBITRARY MATRIX C 1400 IF (.NOT. ELPR) GO TO 5100 IF (DATA(I+8) .EQ. 0.0) GO TO 1410 WRITE (NOUT,9013) TYPE, ILIM, LABEL(NUM), ILIM, DATA(I+7) 9013 FORMAT (9H *MATRIX*,I9,1H.,5X,A1,A4,A1,7H ROW,F5.0) GO TO 1420 1410 WRITE (NOUT,9014) TYPE, ILIM, LABEL(NUM), ILIM, DATA(I+7) 9014 FORMAT (9H *MATRIX*,I9,1H.,5X,A1,A4,A1,7H ROW,F5.0, 1 18H + 2ND ORDER TERMS) 1420 IF (NUM + 1 .GT. NEL) GO TO 5001 IPLNO = ISTOR(NUM+1) IF (IFIX(DATA(IPLNO)) .EQ. 14) GO TO 5200 GO TO 5001 C C 16. -- SPECIAL PARAMETERS C 1600 NBE = .FALSE. NRT = .FALSE. IF (.NOT. ELPR) GO TO 5100 NPAR = IFIX(DATA(I+1)) J = 2.0*NPAR - 1.0 IF (J .GT. 52) J = 7 IF (SUPP) GO TO 1620 IF (NPAR .GT. 30) GO TO 1605 IF (PRAN16(NPAR) .NE. 0.0) GO TO 5001 1605 IF (NPAR .EQ. 14) GO TO 1610 WRITE (NOUT,9015) NAM(J), NAM(J+1), TYPE, ILIM, LABEL(NUM), ILIM, 1 DATA(I+1), DATA(I+2) 9015 FORMAT (1H ,2A4,I9,1H.,5X,A1,A4,A1,F8.0,E15.5) GO TO 5001 C 1610 WRITE (NOUT,9035) NAM(J), NAM(J+1), TYPE, ILIM, LABEL(NUM), ILIM, 1 DATA(I+1), DATA(I+2) 9035 FORMAT (1H ,2A4,I9,1H.,5X,A1,A4,A1,F8.0,I15) GO TO 5001 C 1620 WRITE (NOUT,9015) NAM(J), NAM(J+1), TYPE, ILIM, LABEL(NUM), ILIM GO TO 5001 C C 17. -- SECOND ORDER CALCULATION C 1700 IF (.NOT. ELPR) GO TO 5100 IF (NORDX .EQ. 3) GO TO 1720 IF (NORDX .EQ. 2) GO TO 1710 WRITE (NOUT,9010) TYPE, ILIM, LABEL(NUM), ILIM, NORDX, NORD3 9010 FORMAT (12H *1ST ORDER*,I6,1H.,5X,A1,A4,A1,31X, 1 I5,1H.,I5,1H.) GO TO 5200 C 1710 WRITE (NOUT,9016) TYPE, ILIM, LABEL(NUM), ILIM, NORDX, NORD3 9016 FORMAT (12H *2ND ORDER*,I6,1H.,5X,A1,A4,A1,10X, 1 21HGAUSSIAN DISTRIBUTION,I5,1H.,I5,1H.) GO TO 5200 C 1720 WRITE (NOUT,9031) TYPE, ILIM, LABEL(NUM), ILIM, NORDX, NORD3 9031 FORMAT (12H *3RD ORDER*,I6,1H.,5X,A1,A4,A1,10X, 1 21HGAUSSIAN DISTRIBUTION,I5,1H.,I5,1H.) GO TO 5200 C C 18. -- SEXTUPOLE C 1800 IF (.NOT. ELPR) GO TO 5100 IF (SUPP) GO TO 1820 LOUT = L/UNIT(8) BNORM = B/UNIT(9) APOUT = AP/UNIT(1) WRITE (NOUT,9017) TYPE, ILIM, LABEL(NUM), ILIM, LOUT, XDIME(8), 1 BNORM, XDIME(9), APOUT, XDIME(1) 9017 FORMAT (7H *SEXT*,I11,1H.,5X,A1,A4,A1,3(F13.5,1X,A4)) C IF (RORC .NE. 3) GO TO 5001 IF (TYT .LT. 200) GO TO 5001 I1 = TABLE(TYT/100 + 1) I2 = TABLE(MOD(TYT/10,10) + 1) I3 = TABLE(RORC + 1) DO 1805 J = 1, 6 J2MOD = MOD(J-1,2) + 1 VMO(J) = VMT(J)/UNIT(J2MOD) 1805 CONTINUE ILIM = BLANK IF (LABMIS .NE. BLANK) ILIM = QUOTE WRITE (NOUT,9009) TYP8, ILIM, LABMIS, ILIM, 1 VMO(1), XDIME(1), VMO(2), XDIME(2), VMO(3), XDIME(1), 2 VMO(4), XDIME(2), VMO(5), XDIME(1), VMO(6), XDIME(2), 3 I1, I2, I3 GO TO 5001 C 1820 WRITE (NOUT,9017) TYPE, ILIM, LABEL(NUM), ILIM IF (RORC .NE. 3) GO TO 5001 ILIM = BLANK IF (LABMIS .NE. BLANK) ILIM = QUOTE WRITE (NOUT,9009) TYP8, ILIM, LABMIS, ILIM GO TO 5001 C C 19. -- SOLENOID C 1900 IF (.NOT. ELPR) GO TO 5100 IF (SUPP) GO TO 1910 LOUT = L/UNIT(8) BNORM = B/UNIT(9) WRITE (NOUT,9018) TYPE, ILIM, LABEL(NUM), ILIM, 1 LOUT, XDIME(8), BNORM, XDIME(9) 9018 FORMAT (7H *SOLO*,I11,1H.,5X,A1,A4,A1,2(F13.5,1X,A4)) GO TO 5001 C 1910 WRITE (NOUT,9018) TYPE, ILIM, LABEL(NUM), ILIM GO TO 5001 C C 20. -- BEAM ROTATION C 2000 IF (.NOT. ELPR) GO TO 5100 IF (SUPP) GO TO 2010 THOUT = TH*RADIAN WRITE (NOUT,9019) TYPE, ILIM, LABEL(NUM), ILIM, THOUT 9019 FORMAT (7H *Z RO*,I11,1H.,5X,A1,A4,A1,F13.5,4H DEG) IF (REFER) GO TO 5200 GO TO 5001 C 2010 WRITE (NOUT,9019) TYPE, ILIM, LABEL(NUM), ILIM IF (REFER) GO TO 5200 GO TO 5001 C C 21. -- STRAY FIELD C 2100 NRT = .FALSE. IF (.NOT. ELPR) GO TO 5100 IF (SUPP) GO TO 2110 WRITE (NOUT,9020) TYPE, ILIM, LABEL(NUM), ILIM, DATA(I+1), 1 DATA(I+2), DATA(I+3) 9020 FORMAT (6H *E21*,I12,1H.,5X,A1,A4,A1,F13.0,2F18.5) GO TO 5001 C 2110 WRITE (NOUT,9020) TYPE, ILIM, LABEL(NUM), ILIM GO TO 5001 C C 22. -- DEFINE REGISTER CONTENTS C 2200 IF (.NOT. ELPR) GO TO 5100 CALL ASSESS J = DATA(I+3) REG(J) = COC LREG(J) = .TRUE. IF (ONLY) GO TO 5200 IF (SUPP) GO TO 2210 DAT2 = DATA(I+2) IF (J .EQ. 100) DAT2 = 0.0 WRITE (NOUT,9022) TYPE, ILIM, LABEL(NUM), ILIM, DATA(I+1), 1 DAT2, DATA(I+3), COC 9022 FORMAT (9H *DEF RC*,I9,1H.,5X,A1,A4,A1,F8.0,F5.0,5X,6HREG NO, 1 F5.0,1X,1H(,F10.5,2H )) GO TO 5200 C 2210 WRITE (NOUT,9022) TYPE, ILIM, LABEL(NUM), ILIM GO TO 5200 C C 23. -- ALGEBRAIC OPERATIONS C 2300 IF (.NOT. ELPR) GO TO 5100 K1 = DATA(I+1) K2 = DATA(I+2) IOP = DATA(I+3) J = DATA(I+4) REGK1 = REG(K1) IF (IOP .GT. 4) GO TO 2302 REGK2 = REG(K2) 2302 CALL COMBIN(0) REGJ = REG(J) IF (ONLY) GO TO 5200 IF (SUPP) GO TO 2310 IF (IOP .EQ. 5) GO TO 2305 WRITE (NOUT,9023) TYPE, ILIM, LABEL(NUM), ILIM, K1, REGK1, 1 K2, REGK2, IOP, CSYM(IOP), J, REGJ 9023 FORMAT (9H *COMBIN*,I9,1H.,5X,A1,A4,A1,6X,3HREG,I3,2X,1H(, 1 F10.5,2H ),3X,3HREG,I3,1X,1H(,F10.5,2H ),2X,5HOP NO,I2,2X,A4, 2 3X,3HREG,I3,1X,1H(,F10.5,2H )) GO TO 5200 C 2305 WRITE (NOUT,9024) TYPE, ILIM, LABEL(NUM), ILIM, K1, REGK1, 1 IOP, CSYM(IOP), J, REGJ 9024 FORMAT (9H *COMBIN*,I9,1H.,5X,A1,A4,A1,6X,3HREG,I3,2X,1H(, 1 F10.5,2H ),27X,5HOP NO,I2,2X,A4,2X,I3,1X,1H(,F10.5,2H )) GO TO 5200 C 2310 WRITE (NOUT,9023) TYPE, ILIM, LABEL(NUM), ILIM GO TO 5200 C C 25. -- OCTUPOLE C 2500 IF (.NOT. ELPR) GO TO 5100 IF (SUPP) GO TO 2510 LOUT = L/UNIT(8) BNORM = B/UNIT(9) WRITE (NOUT,9032) TYPE, ILIM, LABEL(NUM), ILIM, LOUT, 1 XDIME(8), BNORM, XDIME(9) 9032 FORMAT (6H *OCT*,I12,1H.,5X,A1,A4,A1,3(F13.5,1X,A4)) GO TO 5001 C 2510 WRITE (NOUT,9032) TYPE, ILIM, LABEL(NUM), ILIM GO TO 5001 C C 26. -- RANDOM ALTERATIONS TO PHYSICAL PARAMETERS C 2600 IF (.NOT. ELPR) GO TO 5100 IF (SUPP) GO TO 2620 NPAR = IFIX(DATA(I+1)) IF (NPAR .EQ. 16) GO TO 2610 WRITE (NOUT,9038) TYPE, ILIM, LABEL(NUM), ILIM, DATA(I+1), 1 DATA(I+2), DATA(I+3) 9038 FORMAT (15H *RANDOM ERROR*,I3,1H.,5X,A1,A4,A1,3X,4HTYPE,F5.0,3X, 1 9HPARAMETER,F5.0,3X,F13.5) GO TO 5200 C 2610 WRITE (NOUT,9037) TYPE, ILIM, LABEL(NUM), ILIM, DATA(I+1), 1 DATA(I+2), DATA(I+3) 9037 FORMAT (15H *RANDOM ERROR*,I3,1H.,5X,A1,A4,A1,3X,4HTYPE,F5.0,3X, 1 9HPARAMETER,F5.0,3X,E15.5) GO TO 5200 C 2620 WRITE (NOUT,9039) TYPE, ILIM, LABEL(NUM), ILIM 9039 FORMAT (15H *RANDOM ERROR*,I3,1H.,5X,A1,A4,A1) GO TO 5200 C C 27. -- ACCELERATOR FUNCTION ETA C 2700 IF (.NOT. ELPR) GO TO 5100 IF (.NOT. ACCEL) GO TO 2720 IF (SUPP) GO TO 2710 WRITE (NOUT,9036) TYPE, ILIM, LABEL(NUM), ILIM, 1 (DATA(I+J), XDIME(J), J = 1, 6) 9036 FORMAT (6H *ETA*,I12,1H.,5X,A1,A4,A1/1X, 1 6(F13.5,1X,A4)) GO TO 5001 C 2710 WRITE (NOUT,9036) TYPE, ILIM, LABEL(NUM), ILIM GO TO 5001 C 2720 IF (SUPP) GO TO 2730 WRITE (NOUT,9030) TYPE, ILIM, LABEL(NUM), ILIM, 1 (DATA(I+J), XDIME(J), J = 1, 6) 9030 FORMAT (6H *RAY*,I12,1H.,5X,A1,A4,A1/1X, 1 6(F13.5,1X,A4)) GO TO 5001 C 2730 WRITE (NOUT,9030) TYPE, ILIM, LABEL(NUM), ILIM GO TO 5001 C C PRINT VARY CODES C 5001 IF (IVA .EQ. 0) GO TO 5090 WRITE (NOUT,9025) ICHAR 9025 FORMAT (1H ,4X,12HVARY CODE = ,30A1) IF (.NOT. UNRO) GO TO 5090 DO 5010 JV = 1, KV K = I + JV ISIG = TIE(K) IF (ISIG .EQ. 0) GO TO 5010 PARAM = DATA(K) WRITE (NOUT,9028) PARAM 9028 FORMAT (1H ,4X,16HVARIED PARAMETER,9X,F18.10) 5010 CONTINUE 5090 IF (ONLY) GO TO 5200 C C PRINT COMPLETE ARBITRARY MATRIX C IF (TYPE .NE. 14) GO TO 5100 CDB = 14 CALL RCOUT C C PRINT BEAM ELLIPSE, TRANSFER MATRIX, AND COORDINATES C 5100 IF (.NOT. NBE) GO TO 5200 LCPR = .FALSE. IF (.NOT. ELPR) GO TO 5200 IF (LAY) CALL SURVEY IF (ACCEL .AND. .NOT. RECENT) CALL BEAM IF ((NOR .OR. (.NOT. NOR .AND. (TYPE .EQ. 1 .OR. TYPE .EQ. 12) 1 .AND. .NOT. SUPP)) .AND. (SOFA .OR. NORD3 .GE. 1)) 2 CALL QEO IF (.NOT. RAT .OR. .NOT. NRT) GO TO 5200 IF (.NOT. TERSE .AND. .NOT. SOFA .AND. NORD3 .LT. 1) GO TO 5200 CDB = 6 CALL RCOUT C C ADVANCE TO NEXT ELEMENT C 5200 NUM = NUM + NDIF IF (NUM .LE. NEL) GO TO 10 C C END OF BEAM LINE - PRINT LENGTH C 5300 CONTINUE WORK1 = LC/UNIT(8) WRITE (NOUT,9021) WORK1, XDIME(8) 9021 FORMAT (9H0*LENGTH*,F17.5,1X,A4) RETURN END SUBROUTINE PARSEC COMMON /BLOC1/ NEL, NUM, NDIF, I, ISTOR(3129), DATA(13160) COMMON /BLOC3/ TYPE, L, LV INTEGER TYPE REAL L, LV COMMON /BLOC5/ VSTOR(20), TIE(13160), LABEL(3129), LABM(10) INTEGER VSTOR, TIE COMMON /BLOC11/ R(6,6), RV(6,6), T(5,21), TV(5,21), U(5,56), 1 UV(5,56) COMMON /BLOC16/ SI(6,6), SV(6,6,20), CO(6), COV(6,20), RI, 1 SVP(20), CVP(20), SOFA LOGICAL SVP, CVP, SOFA COMMON /BLOC22/ LBEND, BE1, SB, TB, TB1, NBVARY, BEFORE LOGICAL BEFORE REAL LBEND COMMON /BLOC23/ H0, AL, NB, BDB, RMPS, VRN, NPN, BDBP, RNMS, DCOV LOGICAL DCOV REAL NB, NPN COMMON /BLOC24/ B, KQ2, KVK, K2H, K2V, CS, SN, DISN, DSVN, J REAL KQ2, KVK, K2H, K2V COMMON /BLOC25/ AP, CAP, JA LOGICAL CAP COMMON /BLOC28/ COC, DE0, SD, CTY, JV, NC, NV1, NV2, NV3 INTEGER CTY COMMON /BLOC29/ A(21), CW, CA(21,21), SCALE(21), CASAV(21,21), 1 PMARQ, CHSMIN, XNORM, GNORM, EPS COMMON /BLOC32/ UNIT(12), XDIME(12) COMMON /BLOC33/ FOTILT, SM, TH, PREF COMMON /BLOC34/ NORD1, NORD2, NORD3, NORDX, LINEAR, JH, SIG LOGICAL LINEAR COMMON /BLOC35/ KL, KO REAL KL, KO COMMON /BLOC36/ VARS(8), SEXMAX, SEXLIM INTEGER VARS LOGICAL SEXLIM COMMON /BLOC45/ CSH, SOKH, SKH, DISP, DDISP, CSV, SOKV, SKV COMMON /HSINT/ HSCX, HSSX, HSCY, HSSY, HSLCY, HSLSY, 1 HSGLP, HSCX2, HSCSX, HSCCM, HSCSM, HSSX2, HSSCM, HSSSM, 2 HSCY2, HSCSY, HSSY2, HSCDX, HSSDX, HSDCM, HSCDY, HSDSM, 3 HSSDY, HSDX2 COMMON /HPINT/ HPCX, HPSX, HPCY, HPSY, HPLCY, HPLSY, 1 HPGLP, HPCX2, HPCSX, HPCCM, HPCSM, HPSX2, HPSCM, HPSSM, 2 HPCY2, HPCSY, HPSY2, HPCDX, HPSDX, HPDCM, HPCDY, HPDSM, 3 HPSDY, HPDX2 COMMON /VSINT/ VSCX, VSSX, VSDX, VSCY, VSSY, VSDY, VSLCX, 1 VSLSX, VSCX2, VSCSX, VSCCM, VSCSM, VSSX2, VSSCM, VSSSM, 2 VSCY2, VSCSY, VSSY2, VSCDX, VSCDM, VSSDX, VSSDM, VSDCM, 3 VSDSM, VSDX2, VSDDM COMMON /VPINT/ VPCX, VPSX, VPDX, VPCY, VPSY, VPDY, VPLCX, 1 VPLSX, VPCX2, VPCSX, VPCCM, VPCSM, VPSX2, VPSCM, VPSSM, 2 VPCY2, VPCSY, VPSY2, VPCDX, VPCDM, VPSDX, VPSDM, VPDCM, 3 VPDSM, VPDX2, VPDDM C JU = 4 - JH IF (JH .EQ. 1) JD = 0 IF (JH .EQ. 3) JD = 1 IF (TYPE .EQ. 2) GO TO 200 IF (TYPE .EQ. 4) GO TO 400 IF (TYPE .EQ. 5) GO TO 5000 IF (TYPE .EQ. 18) GO TO 1800 IF (TYPE .EQ. 19) GO TO 1900 IF (TYPE .EQ. 25) GO TO 5100 RETURN C C 2. -- POLE FACE ROTATION C 200 GO TO (5000,5000,210), JV C 210 IF (SOFA) LINEAR = .FALSE. SB3 = SB**3 JU = 4 - JH TV(JH+1,1+5*JD) = 0.5*SIG*H0*SB3/UNIT(8) TV(JH+1,6-5*JD) = - 0.5*SIG*H0*SB3/UNIT(8) TV(JU+1,4) = - SIG*H0*SB3/UNIT(8) GO TO 5000 C C 4. -- BENDING MAGNET C 400 GO TO (5000,5000,5000,5000,5000,5000,5000,480,490), JV C 480 IF (SOFA) LINEAR = .FALSE. DBEB = 1.0/(H0*UNIT(1))**2 WMN = 1.0 - NB + RMPS*(2.0 - NB) WM5N = 1.0 - 5.0*NB + RMPS*(2.0 - 5.0*NB) HEX = RMPS*H0 H = H0 + HEX RH = 1.0 + RMPS C RV(JH,JH) = RV(JH,JH) + 2.0*HEX*H0*DBEB*HSCDX RV(JH,JH+1) = RV(JH,JH+1) + 2.0*RMPS*DBEB*HSSDX RV(JH,6) = RV(JH,6) + 2.0*HEX*DBEB*HSDX2 RV(JH+1,JH) = RV(JH+1,JH) + 2.0*HEX*H0*DBEB*HPCDX RV(JH+1,JH+1) = RV(JH+1,JH+1) + 2.0*HEX*DBEB*H0*HPSDX RV(JH+1,6) = RV(JH+1,6) + 2.0*HEX*DBEB*HPDX2 RV(JU,JU) = RV(JU,JU) - 2.0*HEX*DBEB*H0*VSDCM RV(JU,JU+1) = RV(JU,JU+1) - 2.0*RMPS*DBEB*VSDSM RV(JU+1,JU) = RV(JU+1,JU) - 2.0*HEX*DBEB*H0*VPDCM RV(JU+1,JU+1) = RV(JU+1,JU+1) - 2.0*HEX*DBEB*H0*VPDSM C TV(JH,1+5*JD) = - SIG*H0**2*H*DBEB*HSCX2 TV(JH,2+7*JD) = - 2.0*SIG*H0**2*H*DBEB*HSCSX TV(JH,3+7*JD) = - SIG*DBEB*H*HSSX2 TV(JH,6-5*JD) = SIG*H0**2*H*DBEB*HSCY2 TV(JH,9-7*JD) = 2.0*SIG*H*DBEB*HSCSY TV(JH,10-7*JD) = SIG*H*DBEB*HSSY2 TV(JH,JH+15) = - 2.0*H0*H*DBEB*HSCDX TV(JH,JH+16) = - 2.0*RH*DBEB*HSSDX TV(JH,21) = - SIG*H*DBEB*HSDX2 TV(JH+1,1+5*JD) = - SIG*H0**2*H*DBEB*HPCX2 TV(JH+1,2+7*JD) = - 2.0*SIG*H0**2*H*DBEB*HPCSX TV(JH+1,3+7*JD) = - SIG*H0**2*H*DBEB*HPSX2 TV(JH+1,6-5*JD) = SIG*H0**2*H*DBEB*HPCY2 TV(JH+1,9-7*JD) = 2.0*SIG*H0**2*H*DBEB*HPCSY TV(JH+1,10-7*JD) = SIG*H*DBEB*HPSY2 TV(JH+1,JH+15) = - 2.0*DBEB*H0*H*HPCDX TV(JH+1,JH+16) = - 2.0*H0*H*DBEB*HPSDX TV(JH+1,21) = - SIG*H*DBEB*HPDX2 TV(JU,4) = 2.0*SIG*H0**2*H*DBEB*VSCCM TV(JU,JH+4) = 2.0*SIG*H*DBEB*VSSCM TV(JU,JU+4) = 2.0*SIG*H*DBEB*VSCSM TV(JU,8) = 2.0*SIG*H*DBEB*VSSSM TV(JU,JU+15) = 2.0*H0*H*DBEB*VSDCM TV(JU,JU+16) = 2.0*RH*DBEB*VSDSM TV(JU+1,4) = 2.0*SIG*H0**2*H*DBEB*VPCCM TV(JU+1,JH+4) = 2.0*SIG*H0**2*H*DBEB*VPSCM TV(JU+1,JU+4) = 2.0*SIG*H0**2*H*DBEB*VPCSM TV(JU+1,8) = 2.0*SIG*H*DBEB*VPSSM TV(JU+1,JU+15) = 2.0*H0*H*DBEB*VPDCM TV(JU+1,JU+16) = 2.0*H0*H*DBEB*VPDSM TV(5,1+5*JD) = H0**2*DBEB*(3.0*L - SOKH*CSH - 2.0*SOKH)/(6.0*WMN) TV(5,2+7*JD) = 2.0*DBEB*(1.0 - CSH)/(3.0*WMN**2) 1 - 2.0*H0**2*DBEB*SOKH**2/(6.0*WMN) TV(5,3+7*JD) = DBEB*(3.0*L - 4.0*SOKH + SOKH*CSH)/(6.0*WMN**2) TV(5,6-5*JD) = - DBEB*(2.0*H0**2*(1.0 - 3.0*NB)*(L - SOKH)/WMN 1 - H0**2*(L - SOKV*CSV))/(2.0*WM5N) TV(5,9-7*JD) = - DBEB*(H0**2*SOKV**2/WM5N 1 - 2.0*(1.0 - CSH)/(WM5N*WMN)) IF (NB .NE. 0.0) GLOP = (L - SOKV*CSV)/(2.0*NB) IF (NB .EQ. 0.0) GLOP = H0**2*L**3/3.0 TV(5,10-7*JD) = - DBEB*(GLOP - 2.0*(L - SOKH)/WMN)/WM5N TV(5,JH+15) = SIG*DBEB*(H0*(SOKH - L*CSH)/WMN**2 1 - 2.0*H0*(L - SOKH)/(3.0*WMN**2) 2 - H0*(L - SOKH*CSH)/(3.0*WMN**2)) TV(5,JH+16) = SIG*DBEB*(4.0*H0*DISN/(3.0*WMN**2) 1 + (H0*L*SOKH - H0*SOKH**2/3.0)/WMN**2) TV(5,21) = DBEB*(4.0*(L - SOKH)/3.0 - SOKH + L*CSH 1 + (L - CSH*SOKH)/6.0)/WMN**3 GO TO 5000 C 490 IF (SOFA) LINEAR = .FALSE. DBEP = RNMS/(H0*UNIT(1))**2 495 WMN = 1.0 - NB + RMPS*(2.0 - NB) WM2N = 1.0 - 2.0*NB + RMPS*(2.0 - 2.0*NB) FNM4 = 5.0*NB - 4.0 + RMPS*(5.0*NB - 8.0) C TV(JH,4) = 2.0*DBEP*H0**3*HSCCM TV(JH,7-2*JD) = 2.0*DBEP*H0*HSCSM TV(JH,5+2*JD) = 2.0*DBEP*H0*HSSCM TV(JH,8) = 2.0*DBEP*H0*HSSSM TV(JH,19-JH) = 2.0*DBEP*HSDCM TV(JH,20-JH) = 2.0*DBEP*HSDSM TV(JH+1,4) = 2.0*DBEP*H0**3*HPCCM TV(JH+1,7-2*JD) = 2.0*DBEP*H0**3*HPCSM TV(JH+1,5+2*JD) = 2.0*DBEP*H0**3*HPSCM TV(JH+1,8) = 2.0*DBEP*H0*HPSSM TV(JH+1,19-JH) = 2.0*DBEP*H0**2*HPDCM TV(JH+1,20-JH) = 2.0*DBEP*H0**2*HPDSM TV(JU,1+5*JD) = DBEP*H0**3*VSCX2 TV(JU,2+7*JD) = 2.0*DBEP*H0*VSCSX TV(JU,3+7*JD) = DBEP*H0*VSSX2 TV(JU,15+JH) = 2.0*DBEP*VSCDX TV(JU,16+JH) = 2.0*DBEP*VSSDX TV(JU,21) = DBEP*H0*VSDX2 TV(JU,6-5*JD) = - DBEP*H0**3*VSCY2 TV(JU,9-7*JD) = - 2.0*DBEP*H0**3*VSCSY TV(JU,10-7*JD) = - DBEP*H0*VSSY2 TV(JU+1,1+5*JD) = DBEP*H0**3*VPCX2 TV(JU+1,2+7*JD) = 2.0*DBEP*H0**3*VPCSX TV(JU+1,3+7*JD) = DBEP*H0*VPSX2 TV(JU+1,15+JH) = 2.0*DBEP*H0**2*VPCDX TV(JU+1,16+JH) = 2.0*DBEP*VPSDX TV(JU+1,21) = DBEP*H0*VPDX2 TV(JU+1,6-5*JD) = - DBEP*H0**3*VPCY2 TV(JU+1,9-7*JD) = - 2.0*DBEP*H0**3*VPCSY TV(JU+1,10-7*JD) = - DBEP*H0**3*VPSY2 GO TO 5000 C C 18. -- SEXTUPOLE C 1800 IF (SOFA) LINEAR = .FALSE. W2 = 2.0*UNIT(9)/(PREF*AP**2) JU = 4 - JH S = - 0.25*W2*L**2 TV(JH,1+5*JD) = SIG*S TV(JH+1,1+5*JD) = 2.0*SIG*S/L S = - W2*L**4/24.0 TV(JH,3+7*JD) = SIG*S TV(JH+1,3+7*JD) = 4.0*SIG*S/L S = 0.25*W2*L**2 TV(JH,6-5*JD) = SIG*S TV(JH+1,6-5*JD) = 2.0*SIG*S/L S = W2*L**4/24.0 TV(JH,10-7*JD) = SIG*S TV(JH+1,10-7*JD) = 4.0*SIG*S/L S = - W2*L**3/6.0 TV(JH,2+7*JD) = SIG*S TV(JH+1,2+7*JD) = 3.0*SIG*S/L S = W2*L**3/6.0 TV(JH,9-7*JD) = SIG*S TV(JH+1,9-7*JD) = 3.0*SIG*S/L S = 0.5*W2*L**2 TV(JU,4) = SIG*S TV(JU+1,4) = 2.0*SIG*S/L S = W2*L**3/6.0 TV(JU,4+JH) = SIG*S TV(JU,4+JU) = SIG*S TV(JU+1,4+JH) = 3.0*SIG*S/L TV(JU+1,4+JU) = 3.0*SIG*S/L S = W2*L**4/12.0 TV(JU,8) = SIG*S TV(JU+1,8) = 4.0*SIG*S/L IF (.NOT. SEXLIM) GO TO 5000 NV2 = IABS(TIE(I+2)) CW = 1.0/SEXMAX**2 CA(1,1) = CA(1,1) + CW*B**2 CA(NV2+1,1) = CA(NV2+1,1) - CW*B*UNIT(9) CA(NV2+1,NV2+1) = CA(NV2+1,NV2+1) + CW*UNIT(9)**2 GO TO 5000 C C 19. -- SOLENOID C 1900 IF (SOFA) LINEAR = .FALSE. IF (JV .EQ. 2) GO TO 1910 LV = UNIT(8) 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 5000 C 1910 IF (SOFA) LINEAR = .FALSE. TEMP = 0.5*L*(SN + KL*CS)*UNIT(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)*UNIT(9)/PREF TV(1,17) = TEMP TV(3,19) = TEMP TEMP = - 0.5*L*(CS - KL*SN)*UNIT(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)*UNIT(9)/PREF TV(1,19) = TEMP TV(3,17) = - TEMP TEMP = 0.25*(3.0*KL*CS - KL**2*SN + SN)*UNIT(9)/PREF TV(2,16) = TEMP TV(4,18) = TEMP TEMP = 0.25*(3.0*KL*SN + KL**2*CS + 1.0 - CS)*UNIT(9)/PREF TV(2,18) = TEMP TV(4,16) = - TEMP C C CHANGE TRIANGULAR MATRIX INTO SQUARE MATRIX C 5000 DO 5010 IA = 1, 5 IND = 0 DO 5010 IC = 2, 6 ICM1 = IC - 1 IND = IND + 1 DO 5010 IB = 1, ICM1 IND = IND + 1 TV(IA,IND) = 0.5*TV(IA,IND) 5010 CONTINUE 5100 IF (NORD1 .GE. 3) CALL PARTRJ RETURN END SUBROUTINE PARTLS COMMON /BLOC1/ NEL, NUM, NDIF, I, ISTOR(3129), DATA(13160) COMMON /BLOC3/ TYPE, L, LV INTEGER TYPE REAL L, LV COMMON /BLOC11/ R(6,6), RV(6,6), T(5,21), TV(5,21), U(5,56), 1 UV(5,56) COMMON /BLOC16/ SI(6,6), SV(6,6,20), CO(6), COV(6,20), RI, 1 SVP(20), CVP(20), SOFA LOGICAL SVP, CVP, SOFA COMMON /BLOC17/ COD(6), COF(6), PSIX, PSIY, PSIX1, PSIY1, NOPH LOGICAL NOPH COMMON /BLOC18/ SIT(6,6), CEN(6), RECENT LOGICAL RECENT COMMON /BLOC20/ ETA(6), DETA(6,20), RAY, EVP(20) LOGICAL RAY, EVP COMMON /BLOC21/ EN, ES, BE, APB(2), LAYK, LAYL, LAYX, RABT REAL LAYK, LAYL, LAYX COMMON /BLOC22/ LBEND, BE1, SB, TB, TB1, NBVARY, BEFORE LOGICAL BEFORE REAL LBEND COMMON /BLOC23/ H0, AL, NB, BDB, RMPS, VRN, NPN, BDBP, RNMS, DCOV LOGICAL DCOV REAL NB, NPN COMMON /BLOC24/ B, KQ2, KVK, K2H, K2V, CS, SN, DISN, DSVN, J REAL KQ2, KVK, K2H, K2V COMMON /BLOC26/ O(4,3,3), X0(4,3), IR, RORC, TYT, ALIGN, TMK, 1 FEO, CHORD INTEGER RORC, TYT LOGICAL ALIGN, TMK, FEO, CHORD COMMON /BLOC28/ COC, DE0, SD, CTY, JV, NC, NV1, NV2, NV3 INTEGER CTY COMMON /BLOC30/ CDB, NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, 1 LCPR, ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, 2 LAY191, NPFR INTEGER CDB LOGICAL NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, LCPR, 1 ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, LAY191 COMMON /BLOC31/ J1, TYP1 INTEGER TYP1 COMMON /BLOC32/ UNIT(12), XDIME(12) COMMON /BLOC33/ FOTILT, SM, TH, PREF COMMON /BLOC34/ NORD1, NORD2, NORD3, NORDX, LINEAR, JH, SIG LOGICAL LINEAR COMMON /BLOC35/ KL, KO REAL KL, KO COMMON /BLOC45/ CSH, SOKH, SKH, DISP, DDISP, CSV, SOKV, SKV COMMON /CONSTS/ PI, RADIAN, CLIGHT, EMASS C IF (TYPE .LE. 8) GO TO 1 IF (TYPE .EQ. 12) GO TO 1200 IF (TYPE .EQ. 14) GO TO 1400 IF (TYPE .EQ. 18) GO TO 5000 IF (TYPE .EQ. 19) GO TO 1900 IF (TYPE .EQ. 20) GO TO 2000 IF (TYPE .EQ. 25) GO TO 5000 IF (TYPE .EQ. 27) GO TO 2700 RETURN 1 GO TO (100,200,300,400,500,5000,700,800), TYPE C C 1. -- BEAM C 100 SIGG = 1.0 IF (NV2 .LT. 0) SIGG = -1.0 NV2 = IABS(NV2) IF (NORD3 .LT. 1) RETURN IPLJV = I + JV IF (SVP(NV2)) GO TO 120 DO 110 J = 1, 6 COV(J,NV2) = 0.0 DO 110 K = 1, 6 SV(J,K,NV2) = 0.0 110 CONTINUE 120 IF (ACCEL) GO TO 130 SV(JV,JV,NV2) = SV(JV,JV,NV2) + 2.0*SIGG*DATA(IPLJV)*UNIT(JV)**2 GO TO 150 130 IF (JV .EQ. 2 .OR. JV .EQ. 4) GO TO 140 IF (JV .GE. 5) RETURN SV(JV,JV,NV2) = SIGG*UNIT(JV)/UNIT(JV+1) SV(JV+1,JV+1,NV2) = - SIGG*SI(JV+1,JV+1)/DATA(I+JV) GO TO 150 140 SV(JV-1,JV,NV2) = -SIGG SV(JV,JV-1,NV2) = -SIGG SV(JV,JV,NV2) = 2.0*SIGG*DATA(I+JV)*UNIT(JV)/ 1 (DATA(I+JV-1)*UNIT(JV-1)) 150 SVP(NV2) = .TRUE. RETURN C C 2. -- POLE FACE ROTATION C 200 GO TO (210,220,5000), JV C 210 LINEAR = .FALSE. JU = 4 - JH RV(JH+1,JH) = UNIT(7)*H0/COS(BE)**2 RV(JU+1,JU) = - UNIT(7)*H0*(1.0 - 2.0*H0*APB(2)*LAYL 1 *SIN(BE)*(1.0 + 2.0*SB**2))/COS(BE1)**2 RETURN C 220 LINEAR = .FALSE. JU = 4 - JH IF (ANIN) GO TO 230 RV(JH+1,JH) = UNIT(9)*TB/PREF RV(JU+1,JU) = - UNIT(9)*(TB1 + (BE1 - BE)*(1.0 + TB1**2))/PREF RETURN C 230 RV(JH+1,JH) = H0*UNIT(7)*TB/AL RV(JU+1,JU) = - H0*UNIT(7)*(TB1 + (BE1 - BE)*(1.0 + TB1**2))/AL RETURN C C 3. -- DRIFT SPACE C 300 LINEAR = .FALSE. LV = UNIT(8) RV(1,2) = LV RV(3,4) = LV RV(5,6) = SM**2*LV/(RI**2 + SM**2) RETURN C C 4. -- BENDING MAGNET C 400 GO TO (410,420,430,440,450,460,470,5000,5000), JV C 410 LINEAR = .FALSE. LV = UNIT(8) J = JH KQ2 = K2H CALL DFOL J = 4 - JH KQ2 = K2V CALL DFOL IF (ANIN) GO TO 415 RV(JH,6) = SIG*H0*R(JH,JH+1)*UNIT(8) RV(5,JH+1) = - RV(JH,6) RV(JH+1,6) = SIG*H0*R(JH,JH)*UNIT(8) RV(5,JH) = - RV(JH+1,6) RV(5,6) = (R(JH,JH) - 1.0)*UNIT(8)/(1.0 - NB) RETURN C 415 RV(JH,6) = R(JH,6)*UNIT(8)/L RV(5,JH+1) = R(5,JH+1)*UNIT(8)/L RV(5,6) = R(5,6)*UNIT(8)/L RETURN C 420 LINEAR = .FALSE. KVK = UNIT(9)*RI/(B*PREF) IF (ANIN) KVK = UNIT(7)/AL J = JH KQ2 = K2H CALL DFOCUS J = 4 - JH KQ2 = K2V CALL DFOCUS RV(JH,6) = (- 2.0*R(JH,6) - SIG*H0*L*R(JH+1,JH)/ABS(K2H) 1 + R(JH,6))*KVK RV(5,JH+1) = - RV(JH,6) RV(JH+1,6) = SIG*H0*RV(JH,JH+1) + KVK*R(JH+1,6) RV(5,JH) = - RV(JH+1,6) RV(5,6) = (- R(5,6) + SIG*H0*L*R(JH,6))*KVK RETURN C 430 LINEAR = .FALSE. J = JH KQ2 = K2H KVK = - 0.5/((1.0 - NB) + RMPS*(2.0 - NB)) CALL DFOCUS J = 4 - JH KQ2 = K2V KVK = 0.5/NB CALL DFOCUS RV(JH,6) = KVK*( - 2.0*R(JH,6) - SIG*H0*L*R(JH+1,JH)/ABS(K2H)) RV(5,JH+1) = - RV(JH,6) RV(JH+1,6) = SIG*H0*RV(JH,JH+1) RV(5,JH) = - RV(JH+1,6) RV(5,6) = ( - 3.0*R(5,6) + SIG*H0*L*R(JH,6))*KVK RETURN C 440 LINEAR = .FALSE. JU = 4 - JH HEX = RMPS*H0 H = H0 + HEX DHEX = H0 DCOV = .TRUE. DCXX = - H0*DHEX*(2.0 - NB) DCYY = - H0*DHEX*NB RV(JH,JH) = 0.5*DCXX*L*SOKH RV(JH,JH+1) = 0.5*DCXX*(SOKH - L*CSH)/K2H RV(JH+1,JH) = 0.5*DCXX*(SOKH + L*CSH) RV(JH+1,JH+1) = 0.5*DCXX*L*SOKH RV(JH,6) = SIG*DHEX*DISN 1 + H*DCXX*(1.0 - CSH - 0.5*L*SKH)/K2H**2 RV(JH+1,6) = SIG*DHEX*SOKH 1 + 0.5*H*DCXX*(SKH - K2H*L*CSH)/K2H**2 RV(JU,JU) = 0.5*DCYY*L*SOKV IF (K2V .NE. 0.0) RV(JU,JU+1) = 0.5*DCYY*(SOKV - L*CSV)/K2V RV(JU+1,JU) = 0.5*DCYY*(SOKV + L*CSV) RV(JU+1,JU+1) = 0.5*DCYY*L*SOKV GO TO 5000 C 450 JU = 4 - JH HEX = RMPS*H0 V = VRN*H0 IF (V .NE. 0.0) DCOV = .TRUE. DV = V H = H0 + HEX DCXY = H0*(V - H0*NPN) DCYX = H0*(2.0*V - H0*NPN) RV(JH,JU) = DCXY*(CSV - CSH)/(K2H - K2V) RV(JH,JU+1) = DCXY*(SOKV - SOKH)/(K2H - K2V) RV(JH+1,JU) = DCXY*(SKH - SKV)/(K2H - K2V) RV(JH+1,JU+1) = DCXY*(CSV - CSH)/(K2H - K2V) RV(JU,JH) = DCYX*(CSH - CSV)/(K2V - K2H) RV(JU,JH+1) = DCYX*(SOKH - SOKV)/(K2V - K2H) RV(JU+1,JH) = DCYX*(SKV - SKH)/(K2V - K2H) RV(JU+1,JH+1) = DCYX*(CSH - CSV)/(K2V - K2H) RV(JU,6) = - DV*SOKV**2/(1.0 + CSV) 1 + H*DCYX*(DSVN + (CSH - CSV)/(K2H - K2V))/K2H RV(JU+1,6) = - DV*SOKV 1 + H*DCYX*(SOKV - (SKH - SKV)/(K2H - K2V))/K2H GO TO 5000 C 460 JU = 4 - JH DCOV = .TRUE. DV = H0 HEX = RMPS*H0 H = H0 + HEX DCXY = H0*RNMS*DV DCYX = 2.0*H*RNMS*DV RV(JH,JU) = DCXY*(CSH - CSV)/(K2V - K2H) RV(JH,JU+1) = DCXY*(SOKH - SOKV)/(K2V - K2H) RV(JH+1,JU) = DCXY*(SKH - SKV)/(K2H - K2V) RV(JH+1,JU+1) = DCXY*(CSH - CSV)/(K2V - K2H) RV(JU,JH) = DCYX*(CSH - CSV)/(K2V - K2H) RV(JU,JH+1) = DCYX*(SOKH - SOKV)/(K2V - K2H) RV(JU+1,JH) = DCYX*(SKH - SKV)/(K2H - K2V) RV(JU+1,JH+1) = DCYX*(CSH - CSV)/(K2V - K2H) RV(JU,6) = - DV*RNMS*SOKV**2/(1.0 + CSV) 1 + H*DCYX*(DSVN + (CSH - CSV)/(K2H - K2V))/K2H RV(JU+1,6) = - DV*RNMS*SOKV 1 + H*DCYX*(SOKV - (SKH - SKV)/(K2H - K2V))/K2H GO TO 5000 C 470 JU = 4 - JH HEX = RMPS*H0 H = H0 + HEX DCXY = - H0**2*RNMS DCYX = - H0**2*RNMS RV(JH,JU) = DCXY*(CSV - CSH)/(K2H - K2V) RV(JH,JU+1) = DCXY*(SOKV - SOKH)/(K2H - K2V) RV(JH+1,JU) = DCXY*(SKH - SKV)/(K2H - K2V) RV(JH+1,JU+1) = DCXY*(CSV - CSH)/(K2H - K2V) RV(JU,JH) = DCYX*(CSH - CSV)/(K2V - K2H) RV(JU,JH+1) = DCYX*(SOKH - SOKV)/(K2V - K2H) RV(JU+1,JH) = DCYX*(SKH - SKV)/(K2H - K2V) RV(JU+1,JH+1) = DCYX*(CSH - CSV)/(K2V - K2H) RV(JU,6) = 1 H*DCYX*(DSVN + (CSH - CSV)/(K2H - K2V))/K2H RV(JU+1,6) = 1 H*DCYX*(SOKV - (SKH - SKV)/(K2H - K2V))/K2H RETURN C C 5. -- QUADRUPOLE C 500 LINEAR = .FALSE. IF (JV .EQ. 2) GO TO 520 LV = UNIT(8) J = 4 - JH CALL DFOL IF (HTGQ) KQ2 = - KQ2 J = JH CALL DFOL IF (HTGQ) KQ2 = - KQ2 GO TO 5000 C 520 J = 4 - JH KVK = 0.5*UNIT(9)*RI/(B*PREF) CALL DFOCUS J = JH IF (HTGQ) KQ2 = - KQ2 CALL DFOCUS GO TO 5000 C C 7. -- BEAM CENTROID SHIFT C 700 LINEAR = .FALSE. SIGG = 1.0 IF (NV2 .LT. 0) SIGG = - 1.0 NV2 = IABS(NV2) IF (CVP(NV2)) GO TO 720 DO 710 J = 1, 6 COV(J,NV2) = 0.0 710 CONTINUE 720 COV(JV,NV2) = COV(JV,NV2) + SIGG*UNIT(JV) CVP(NV2) = .TRUE. RETURN C C 8. -- MAGNET MISALIGNMENT C 800 IF (MOD(TYT/10,10) .NE. 0) RETURN IF (RORC .GE. 3) RETURN CALL WOBBLE RETURN C C 12. -- CORRELATIONS IN BEAM ELLIPSE C 1200 SIGG = 1.0 IF (NV2 .LT. 0) SIGG = -1.0 NV2 = IABS(NV2) IF (NORD3 .LT. 1) RETURN K = (3 + IFIX(SQRT(8.0*FLOAT(JV) - 6.99)))/2 J = JV - (K-1)*(K-2)/2 DSIG = SIGG*SQRT(SI(J,J)*SI(K,K)) IF (SVP(NV2)) GO TO 1220 DO 1210 J1 = 1, 6 DO 1210 K1 = 1, 6 SV(J1,K1,NV2) = 0.0 1210 CONTINUE 1220 SV(J,K,NV2) = SV(J,K,NV2) + DSIG SV(K,J,NV2) = SV(J,K,NV2) SVP(NV2) = .TRUE. RETURN C C 14. -- ARBITRARY MATRIX C 1400 RV(J1,JV) = UNIT(J1)/UNIT(JV) GO TO 5000 C C 19. -- SOLENOID C 1900 LINEAR = .FALSE. IF (JV .EQ. 1) GO TO 1910 IF (JV .EQ. 2) GO TO 1920 GO TO 1950 C 1910 LV = UNIT(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 1950 C 1920 RV(1,1) = - 0.5*L*SN/PREF RV(2,2) = RV(1,1) RV(1,2) = ( - SN + KL*CS)/(KO**2*PREF) RV(2,1) = - 0.25*(SN + KL*CS)/PREF RV(1,3) = 0.5*L*CS/PREF RV(2,4) = RV(1,3) RV(1,4) = (KL*SN - (1.0 - CS))/(KO**2*PREF) RV(2,3) = - 0.25*(KL*SN + (1.0 - CS))/PREF C 1950 CONTINUE DO 1951 J = 3, 4 DO 1951 J1 = 1, 2 RV(J,J1) = - RV(J-2,J1+2) 1951 CONTINUE DO 1955 J = 1, 2 DO 1955 J1 = 1, 2 RV(J+2,J1+2) = RV(J,J1) 1955 CONTINUE GO TO 5000 C C 20. -- BEAM ROTATION C 2000 IF (REFER) RETURN LINEAR = .FALSE. DSN = R(3,1)/RADIAN IF (NDIF .LT. 0) DSN = - DSN RV(1,1) = DSN RV(2,2) = DSN RV(3,3) = DSN RV(4,4) = DSN DCS = R(1,1)/RADIAN IF (NDIF .LT. 0) DCS = - DCS RV(2,4) = DCS RV(1,3) = DCS RV(4,2) = - DCS RV(3,1) = - DCS RETURN C C ACCELERATOR FUNCTION ETA C 2700 LINEAR = .FALSE. SIGG = 1.0 IF (NV2 .LT. 0) SIGG = - 1.0 NV2 = IABS(NV2) IF (EVP(NV2)) GO TO 2720 DO 2710 J = 1, 6 DETA(J,NV2) = 0.0 2710 CONTINUE 2720 DETA(JV,NV2) = DETA(JV,NV2) + SIGG*UNIT(JV) EVP(NV2) = .TRUE. RETURN C C SECOND ORDER DERIVATIVE TERMS C 5000 IF (NORD1 .GE. 2) CALL PARSEC RETURN END SUBROUTINE PARTRJ COMMON /BLOC1/ NEL, NUM, NDIF, I, ISTOR(3129), DATA(13160) COMMON /BLOC3/ TYPE, L, LV INTEGER TYPE REAL L, LV COMMON /BLOC11/ R(6,6), RV(6,6), T(5,21), TV(5,21), U(5,56), 1 UV(5,56) DIMENSION RL(36), RVL(36), TL(105), TVL(105), UL(280), 1 UVL(280) EQUIVALENCE (R(1,1),RL(1)), (RV(1,1),RVL(1)), 1 (T(1,1),TL(1)), (TV(1,1),TVL(1)), 2 (U(1,1),UL(1)), (UV(1,1),UVL(1)) COMMON /BLOC16/ SI(6,6), SV(6,6,20), CO(6), COV(6,20), RI, 1 SVP(20), CVP(20), SOFA LOGICAL SVP, CVP, SOFA COMMON /BLOC21/ EN, ES, BE, APB(2), LAYK, LAYL, LAYX, RABT REAL LAYK, LAYL, LAYX COMMON /BLOC22/ LBEND, BE1, SB, TB, TB1, NBVARY, BEFORE LOGICAL BEFORE REAL LBEND COMMON /BLOC23/ H0, AL, NB, BDB, RMPS, VRN, NPN, BDBP, RNMS, DCOV LOGICAL DCOV REAL NB, NPN COMMON /BLOC24/ B, KQ2, KVK, K2H, K2V, CS, SN, DISN, DSVN, J REAL KQ2, KVK, K2H, K2V COMMON /BLOC25/ AP, CAP, JA LOGICAL CAP COMMON /BLOC28/ COC, DE0, SD, CTY, JV, NC, NV1, NV2, NV3 INTEGER CTY COMMON /BLOC30/ CDB, NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, 1 LCPR, ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, 2 LAY191, NPFR INTEGER CDB LOGICAL NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, LCPR, 1 ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, LAY191 COMMON /BLOC31/ J1, TYP1 INTEGER TYP1 COMMON /BLOC32/ UNIT(12), XDIME(12) COMMON /BLOC33/ FOTILT, SM, TH, PREF COMMON /BLOC34/ NORD1, NORD2, NORD3, NORDX, LINEAR, JH, SIG LOGICAL LINEAR COMMON /BLOC35/ KL, KO REAL KL, KO COMMON /BLOC45/ CSH, SOKH, SKH, DISP, DDISP, CSV, SOKV, SKV C JU = 4 - JH IF (JH .EQ. 1) JD = 0 IF (JH .EQ. 3) JD = 1 GO TO (5100,200,300,400,500,5200,5200,5200,5200,5200, 1 5200,5200,5200,1400,5200,5200,5200,1800,1900,5200, 2 5200,5200,5200,5200,2500,5200,5200), TYPE C C 2. -- POLE FACE ROTATION C 200 CONTINUE GO TO 5100 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 BEB = BDB/H0**2 GAB = GAM/H0**3 UV(JH+1,1+9*JD) = - .5*H0**6*SOKH**3 UV(JH+1,2+14*JD) = 1.5*H0**4*CSH*SOKH**2 UV(JH,3+16*JD) = -.5*H0**2*SOKH**2 UV(JH+1,3+16*JD) = - 1.5*H0**2*SOKH*(1.0 - H0**2*SOKH**2) UV(JH,4+16*JD) = .5*SOKH*(CSH - 1.) UV(JH+1,4+16*JD) = - .5*H0**2*CSH*SOKH**2 UV(JH,17-10*JD) = - .5*H0**2*SOKH**2 UV(JH+1,17-10*JD) = - .5*H0**2*SOKH UV(JH,18-5*JD) = .5*SOKH*(CSH - 1.) UV(JH,36+5*JD) = .5*H0**3*SOKH**2 UV(JH+1,36+5*JD) = 1.5*H0**5*SOKH**3 UV(JH,38+7*JD) = H0*SOKH**2 - .5*(1. - CSH)/H0 UV(JH+1,38+7*JD) = 1.5*H0*SOKH*(1.0 - H0**2*SOKH**2) UV(JH+1,37+8*JD) = -3.*H0**3*CSH*SOKH**2 UV(JH,45-7*JD) = .5*(H0*SOKH**2 - (1. - CSH)/H0) UV(JH+1,45-7*JD) = .5*H0*SOKH UV(JH,50+JH) = - H0**2*SOKH**2 UV(JH+1,50+JH) = - H0**2*SOKH*(1.0 + 1.5*H0**2*SOKH**2) UV(JH+1,51+JH) = 1.5*H0**2*CSH*SOKH**2 UV(JH,56) = .5*H0*SOKH**2 UV(JH+1,56) = H0*SOKH*(1.0 + .5*H0**2*SOKH**2) UV(JU+1,11-2*JD) = .5*H0**4*SOKH**2 UV(JU+1,12+3*JD) = - H0**2*CSH*SOKH UV(JU,13+5*JD) = .5*(SOKH - L) UV(JU+1,13+5*JD) = -.5*H0**2*SOKH**2 UV(JU+1,42-2*JD) = -H0**3*SOKH**2 UV(JU,20-16*JD) = .5*(SOKH - L) UV(JU,43) = (1.0 - CSH)/H0 UV(JU+1,43) = H0*CSH*SOKH UV(JU+1,51+JU) = .5*H0**2*SOKH**2 GO TO 5000 C C 5. -- QUADRUPOLE C 500 J = JH KQ2 = K2H 510 IF (J .EQ. 1) JD = 0 IF (J .EQ. 3) JD = 1 JO = 4 - J CS = R(J,J) SK = - R(J+1,J) SOK = R(J,J+1) CSO = R(JO,JO) SKO = - R(JO+1,JO) SOKO = R(JO,JO+1) DCS = RV(J,J) DSK = - RV(J+1,J) DSOK = RV(J,J+1) DCSO = RV(JO,JO) DSKO = - RV(JO+1,JO) DSOKO = RV(JO,JO+1) C GO TO (520,540), JV C 520 UV(J,1+9*JD) = KQ2**2*(13.*DCS*SOK**2 + 26.*CS*SOK*DSOK 1 - 9*LV*SOK - 9.*L*DSOK)/48. UV(J,2+14*JD) = KQ2*(-22.*DSOK + 78.*KQ2*SOK**2*DSOK 1 + 6.*LV*CS + 6.*L*DCS)/32. UV(J,3+16*JD) = - KQ2*(13.*DCS*SOK**2 + 26.*CS*SOK*DSOK 1 + 3.*LV*SOK + 3.*L*DSOK)/16. UV(J,4+16*JD) = (- 9.*DSOK - 39.*KQ2*SOK**2*DSOK 1 + 9.*LV*CS + 9.*L*DCS)/48. UV(J,8-3*JD) = KQ2**2*(- 3.*DCS*SOKO**2 - 6.*CS*SOKO*DSOKO 1 + 2.*LV*SOK + 2.*L*DSOK - 3.*DSOK*SOKO*CSO - 3.*SOK*DSOKO*CSO 2 - 3.*SOK*SOKO*DCSO)/16. UV(J,14-8*JD) = 3.*KQ2*(- DCS*CSO*SOKO - CS*DCSO*SOKO 1 - CS*CSO*DSOKO + DSOK - KQ2*DSOK*SOKO**2 2 - 2.0*KQ2*SOK*SOKO*DSOKO)/8. UV(J,17-10*JD) = - KQ2*(3.*DCS*SOKO**2 + 6.*CS*SOKO*DSOKO 1 + 2.*LV*SOK + 2.*L*DSOK + 3.*DSOK*CSO*SOKO + 3.*SOK*DCSO*SOKO 2 + 3.*SOK*CSO*DSOKO)/16. UV(J,9+2*JD) = KQ2*(3.*DCS*CSO*SOKO + 3.*CS*DCSO*SOKO 1 + 3.*CS*CSO*DSOKO - 2.*LV*CS - 2.*L*DCS - 3.*DSOK*CSO**2 2 - 6.*SOK*CSO*DCSO - 6.*DSOK)/16. UV(J,15-3*JD) = 3.*KQ2*(DCS*SOKO**2 + 2.*CS*SOKO*DSOKO 1 - DSOK*CSO*SOKO - SOK*DCSO*SOKO - SOK*CSO*DSOKO)/8. UV(J,18-5*JD) = (3.*DCS*CSO*SOKO + 3.*CS*DCSO*SOKO 1 + 3.*CS*CSO*DSOKO + 2.*LV*CS + 2.*L*DCS - 3.*DSOK*CSO**2 2 - 6.*SOK*CSO*DCSO - 2.*DSOK)/16. UV(J+1,1+9*JD) = - KQ2**2*(7.*DSOK + 45.*KQ2*SOK**2*DSOK 1 + 9.*LV*CS + 9.*L*DCS)/48. UV(J+1,2+14*JD) = 3.*KQ2**2*(5.*DCS*SOK**2 + 10.*CS*SOK*DSOK 1 - LV*SOK - L*DSOK)/16. UV(J+1,3+16*JD) = KQ2*(-26.*DSOK + 90.*KQ2*SOK**2*DSOK 1 - 6.*LV*CS - 6.*L*DCS)/32. UV(J+1,4+16*JD) = - KQ2*(5.*DCS*SOK**2 + 10.*CS*SOK*DSOK 1 + 3.*LV*SOK + 3.*L*DSOK)/16. UV(J+1,8-3*JD) = KQ2**2*(2.*LV*CS + 2.*L*DCS - 9.*DCS*CSO*SOKO 1 - 9.*CS*DCSO*SOKO - 9.*CS*CSO*DSOKO - 9.*DSOK 2 - 11.*KQ2*DSOK*SOKO**2 - 22.*KQ2*SOK*SOKO*DSOKO)/16. UV(J+1,14-8*JD) = KQ2**2*(- 9.*DCS*SOKO**2 - 18.*CS*SOKO*DSOKO 1 - 11.*DSOK*SOKO*CSO - 11.*SOK*DSOKO*CSO - 11.*SOK*SOKO*DCSO)/8. UV(J+1,17-10*JD) = - KQ2*(2.*LV*CS + 2.*L*DCS + 9.*DCS*CSO*SOKO 1 + 9.*CS*DCSO*SOKO + 9.*CS*CSO*DSOKO + 11.*KQ2*DSOK*SOKO**2 2 + 22.*KQ2*SOK*SOKO*DSOKO + 5.*DSOK)/16. UV(J+1,9+2*JD) = KQ2**2*(11.*DCS*SOKO**2 + 22.*CS*SOKO*DSOKO 1 + 2.*LV*SOK + 2.*L*DSOK - 9.*DSOK*CSO*SOKO - 9.*SOK*DCSO*SOKO 2 - 9.*SOK*CSO*DSOKO)/16. UV(J+1,15-3*JD) = KQ2*(11.*DCS*CSO*SOKO + 11.*CS*DCSO*SOKO 1 + 11.*CS*CSO*DSOKO - 3.*DSOK - 9.*KQ2*DSOK*SOKO**2 2 - 18.*KQ2*SOK*SOKO*DSOKO)/8. UV(J+1,18-5*JD) = KQ2*(11.*DCS*SOKO**2 + 22.*CS*SOKO*DSOKO 1 - 2.*LV*SOK - 2.*L*DSOK - 9.*DSOK*CSO*SOKO - 9.*SOK*DCSO*SOKO 2 - 9.*SOK*CSO*DSOKO)/16. UV(J,50+J) = - KQ2*(3.*LV*SOK + 3.*L*DSOK + 2.*L*LV*CS 1 + L**2*DCS)/8. UV(J,51+J) = (- 2.0*KQ2*L*LV*SOK - KQ2*L**2*DSOK + LV*CS 1 + L*DCS - DSOK)/8. UV(J+1,50+J) = KQ2*(- 5.*LV*CS - 5.*L*DCS - 3.*DSOK 1 + 2.0*KQ2*L*LV*SOK + KQ2*L**2*DSOK)/8. UV(J+1,51+J) = KQ2*(-3.*LV*SOK - 3.*L*DSOK - 2.*L*LV*CS 1 - L**2*DCS)/8. GO TO 550 C 540 UV(J,1+9*JD) = 4.0*KVK*U(J,1+9*JD) 1 + KQ2**2*(13.*DCS*SOK**2 + 26.*CS*SOK*DSOK - 9.*L*DSOK)/48. UV(J,2+14*JD) = 6.0*KVK*U(J,2+14*JD) 1 + KQ2*(- 22.*DSOK + 52.*KQ2*KVK*SOK**3 + 78.*KQ2*SOK**2*DSOK 2 + 6.*L*DCS)/32. UV(J,3+16*JD) = 6.0*KVK*U(J,3+16*JD) 1 - KQ2*(13.*DCS*SOK**2 + 26.*CS*SOK*DSOK + 3.*L*DSOK)/16. UV(J,4+16*JD) = (-9.*DSOK - 26.*KQ2*KVK*SOK**3 1 - 39.*KQ2*SOK**2*DSOK + 9.*L*DCS)/48. UV(J,8-3*JD) = 12.0*KVK*U(J,8-3*JD) 1 + KQ2**2*(- 3.*DCS*SOKO**2 - 6.*CS*SOKO*DSOKO + 2.*L*DSOK 2 - 3.*DSOK*SOKO*CSO - 3.*SOK*DSOKO*CSO - 3.*SOK*SOKO*DCSO)/16. UV(J,14-8*JD) = 12.0*KVK*U(J,14-8*JD) 1 + 3.*KQ2*(- DCS*CSO*SOKO - CS*DCSO*SOKO - CS*CSO*DSOKO + DSOK 2 - 2.0*KQ2*KVK*SOK*SOKO**2 - KQ2*DSOK*SOKO**2 3 - 2.0*KQ2*SOK*SOKO*DSOKO)/8. UV(J,17-10*JD) = 6.0*KVK*U(J,17-10*JD) 1 - KQ2*(3.*DCS*SOKO**2 + 6.*CS*SOKO*DSOKO + 2.*L*DSOK 2 + 3.*DSOK*CSO*SOKO + 3.*SOK*DCSO*SOKO + 3.*SOK*CSO*DSOKO)/16. UV(J,9+2*JD) = 6.0*KVK*U(J,9+2*JD) 1 + KQ2*(3.*DCS*CSO*SOKO + 3.*CS*DCSO*SOKO + 3.*CS*CSO*DSOKO 2 - 2.*L*DCS - 3.*DSOK*CSO**2 - 6.*SOK*CSO*DCSO - 6.*DSOK)/16. UV(J,15-3*JD) = 12.0*KVK*U(J,15-3*JD) 1 + 3.*KQ2*(DCS*SOKO**2 + 2.*CS*SOKO*DSOKO - DSOK*CSO*SOKO 2 - SOK*DCSO*SOKO - SOK*CSO*DSOKO)/8. UV(J,18-5*JD) = (3.*DCS*CSO*SOKO + 3.*CS*DCSO*SOKO 1 + 3.*CS*CSO*DSOKO + 2.*L*DCS - 3.*DSOK*CSO**2 - 6.*SOK*CSO*DCSO 2 - 2.*DSOK)/16. UV(J+1,1+9*JD) = 4.0*KVK*U(J+1,1+9*JD) 1 - KQ2**2*(7.*DSOK + 30.*KQ2*KVK*SOK**3 + 45.*KQ2*SOK**2*DSOK 2 + 9.*L*DCS)/48. UV(J+1,2+14*JD) = 12.0*KVK*U(J+1,2+14*JD) 1 + 3.*KQ2**2*(5.*DCS*SOK**2 + 10.*CS*SOK*DSOK - L*DSOK)/16. UV(J+1,3+16*JD) = 6.0*KVK*U(J+1,3+16*JD) 1 + KQ2*(- 26.*DSOK + 60.*KQ2*KVK*SOK**3 + 90.*KQ2*SOK**2*DSOK 2 - 6.*L*DCS)/32. UV(J+1,4+16*JD) = 2.0*KVK*U(J+1,4+16*JD) 1 - KQ2*(5.*DCS*SOK**2 + 10.*CS*SOK*DSOK + 3.*L*DSOK)/16. UV(J+1,8-3*JD) = 12.0*KVK*U(J+1,8-3*JD) 1 + KQ2**2*(2.*L*DCS - 9.*DCS*CSO*SOKO - 9.*CS*DCSO*SOKO 2 - 9.*CS*CSO*DSOKO - 9.*DSOK - 22.*KQ2*KVK*SOK*SOKO**2 3 - 11.*KQ2*DSOK*SOKO**2 - 22.*KQ2*SOK*SOKO*DSOKO)/16. UV(J+1,14-8*JD) = 24.0*KVK*U(J+1,14-8*JD) 1 + KQ2**2*(- 9.*DCS*SOKO**2 - 18.*CS*SOKO*DSOKO 2 - 11.*DSOK*SOKO*CSO - 11.*SOK*DSOKO*CSO - 11.*SOK*SOKO*DCSO)/8. UV(J+1,17-10*JD) = 6.0*KVK*U(J+1,17-10*JD) 1 - KQ2*(2.*L*DCS + 9.*DCS*CSO*SOKO + 9.*CS*DCSO*SOKO 2 + 9.*CS*CSO*DSOKO + 22.*KQ2*KVK*SOK*SOKO**2 3 + 11.*KQ2*DSOK*SOKO**2 + 22.*KQ2*SOK*SOKO*DSOKO + 5.*DSOK)/16. UV(J+1,9+2*JD) = 12.0*KVK*U(J+1,9+2*JD) 1 + KQ2**2*(11.*DCS*SOKO**2 + 22.*CS*SOKO*DSOKO + 2.*L*DSOK 2 - 9.*DSOK*CSO*SOKO - 9.*SOK*DCSO*SOKO - 9.*SOK*CSO*DSOKO)/16. UV(J+1,15-3*JD) = 12.0*KVK*U(J+1,15-3*JD) 1 + KQ2*(11.*DCS*CSO*SOKO + 11.*CS*DCSO*SOKO + 11.*CS*CSO*DSOKO 2 - 3.*DSOK - 18.*KQ2*KVK*SOK*SOKO**2 - 9.*KQ2*DSOK*SOKO**2 3 - 18.*KQ2*SOK*SOKO*DSOKO)/8. UV(J+1,18-5*JD) = 6.0*KVK*U(J+1,18-5*JD) 1 + KQ2*(11.*DCS*SOKO**2 + 22.*CS*SOKO*DSOKO - 2.*L*DSOK 2 - 9.*DSOK*CSO*SOKO - 9.*SOK*DCSO*SOKO - 9.*SOK*CSO*DSOKO)/16. UV(J,50+J) = 6.0*KVK*U(J,50+J) 1 - KQ2*(3.*L*DSOK + L**2*DCS)/8. UV(J,51+J) = ( - 2.0*KQ2*KVK*L**2*SOK - KQ2*L**2*DSOK + L*DCS 1 - DSOK)/8. UV(J+1,50+J) = 6.0*KVK*U(J+1,50+J) 1 + KQ2*(- 5.*L*DCS - 3.*DSOK + 2.0*KQ2*KVK*L**2*SOK 2 + KQ2*L**2*DSOK)/8. UV(J+1,51+J) = 6.0*KVK*U(J+1,51+J) 1 + KQ2*(- 3.*L*DSOK - L**2*DCS)/8. C 550 IF (J .NE. JH) GO TO 5000 J = 4 - JH IF (HTGQ) KQ2 = K2V GO TO 510 C C 14. -- ARBITRARY MATRIX C 1400 IF (DATA(I+30) .NE. 0.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) = DATA(IX)*UNIT(J1)/(UNIT(J)*UNIT(K)*UNIT(M)) 1410 CONTINUE 1420 IF (NUM + 1 .GT. NEL) GO TO 5100 IPNOTY = ISTOR(NUM+1) IF (IFIX(DATA(IPNOTY)) .EQ. 14) RETURN GO TO 5100 C C 18. -- SEXTUPOLE C 1800 LINEAR = .FALSE. W2 = 2.0*B/(RI*AP**2) DW2 = 2.0*UNIT(9)/(PREF*AP**2) S = 2.0*W2*DW2*L**4/48. UV(1,1) = S UV(2,1) = 4.0*S/L UV(3,10) = S UV(4,10) = 4.0*S/L S = 2.0*W2*DW2*L**5/48. UV(1,2) = S UV(2,2) = 5.0*S/L UV(3,16) = S UV(4,16) = 5.0*S/L S = 2.0*W2*DW2*L**6/144. UV(1,3) = S UV(2,3) = 6.0*S/L UV(3,19) = S UV(4,19) = 6.0*S/L S = 2.0*W2*DW2*L**7/1008. UV(1,4) = S UV(2,4) = 7.*S/L UV(3,20) = S UV(4,20) = 7.*S/L S = 2.0*W2*DW2*L**4/48. UV(1,8) = S UV(2,8) = 4.0*S/L UV(3,5) = S UV(4,5) = 4.0*S/L S = 0.05*W2*DW2*L**5 UV(1,14) = S UV(2,14) = 5.0*S/L UV(3,6) = S UV(4,6) = 5.0*S/L S = 2.0*W2*DW2*L**6/240. UV(1,17) = S UV(2,17) = 6.0*S/L UV(3,7) = S UV(4,7) = 6.0*S/L S = - 2.0*W2*DW2*L**5/240. UV(1,9) = S UV(2,9) = 5.0*S/L UV(3,11) = S UV(4,11) = 5.0*S/L S = 2.0*W2*DW2*L**6/360. UV(1,15) = S UV(2,15) = 6.0*S/L UV(3,12) = S UV(4,12) = 6.0*S/L S = 2.0*W2*DW2*L**7/1008. UV(1,18) = S UV(2,18) = 7.0*S/L UV(3,13) = S UV(4,13) = 7.0*S/L S = DW2*(0.5*L)**2 UV(JH,36+5*JD) = SIG*S UV(JH+1,36+5*JD) = 2.0*SIG*S/L S = DW2*L**4/24. UV(JH,38+7*JD) = SIG*S UV(JH+1,38+7*JD) = 4.0*SIG*S/L S = - 0.25*DW2*L**2 UV(JH,41-5*JD) = SIG*S UV(JH+1,41-5*JD) = 2.0*SIG*S/L S = - DW2*L**4/24. UV(JH,45-7*JD) = SIG*S UV(JH+1,45-7*JD) = 4.0*SIG*S/L S = DW2*L**3/6. UV(JH,37+7*JD) = SIG*S UV(JH+1,37+7*JD) = 3.0*SIG*S/L S = - DW2*L**3/6. UV(JH,44-7*JD) = SIG*S UV(JH+1,44-7*JD) = 3.0*SIG*S/L S = - 0.5*DW2*L**2 UV(JU,39) = SIG*S UV(JU+1,39) = 2.0*SIG*S/L S = - DW2*L**3/6. UV(JU,39+JH) = SIG*S UV(JU,39+JU) = SIG*S UV(JU+1,39+JH) = 3.0*SIG*S/L UV(JU+1,39+JU) = 3.0*SIG*S/L S = - DW2*L**4/6. UV(JU,43) = SIG*S UV(JU+1,43) = 4.0*SIG*S/L GO TO 5000 C C 19. -- SOLENOID C 1900 CONTINUE GO TO 5000 C C 25. -- OCTUPOLE C 2500 IF (SOFA) LINEAR = .FALSE. AP = DATA(I+3)*UNIT(1) DW2 = UNIT(9)/(PREF*AP**3) S = - 0.5*DW2*L**2 UV(1,1) = S UV(2,1) = 2.0*S/L UV(3,10) = S UV(4,10) = 2.0*S/L S = - .5*DW2*L**3 UV(1,2) = S UV(2,2) = 3.*S/L UV(3,16) = S UV(4,16) = 3.0*S/L S = - 0.25*DW2*L**4 UV(1,3) = S UV(2,3) = 4.0*S/L UV(3,19) = S UV(4,19) = 4.0*S/L S = - .05*DW2*L**5 UV(1,4) = S UV(2,4) = 5.0*S/L UV(3,20) = S UV(4,20) = 5.0*S/L S = 1.5*DW2*L**2 UV(1,8) = S UV(2,8) = 2.0*S/L UV(3,5) = S UV(4,5) = 2.0*S/L S = DW2*L**3 UV(1,14) = S UV(2,14) = 3.0*S/L UV(3,6) = S UV(4,6) = 3.0*S/L S = 0.25*DW2*L**4 UV(1,17) = S UV(2,17) = 4.0*S/L UV(3,7) = S UV(4,7) = 4.0*S/L S = .5*DW2*L**3 UV(1,9) = S UV(2,9) = 3.0*S/L UV(3,11) = S UV(4,11) = 3.0*S/L S = .5*DW2*L**4 UV(1,15) = S UV(2,15) = 4.0*S/L UV(3,12) = S UV(4,12) = 4.0*S/L S = 0.15*DW2*L**5 UV(1,18) = S UV(2,18) = 5.0*S/L UV(3,13) = S UV(4,13) = 5.0*S/L GO TO 5000 C C CHANGE PYRAMIDAL MATRIX INTO CUBIC MATRIX C 5000 CONTINUE 5100 DO 5150 IA = 1, 5 IND = 0 DO 5150 ID = 1, 6 DO 5150 IC = 1, ID DO 5150 IB = 1, IC IND = IND + 1 IF (IB .NE. IC .OR. IB .NE. ID .OR. IC .NE. ID) 1 UV(IA,IND) = UV(IA,IND)/3.0 IF (IB .NE. IC .AND. IB .NE. ID .AND. IC .NE. ID) 1 UV(IA,IND) = UV(IA,IND)/2.0 5150 CONTINUE 5200 CONTINUE RETURN END SUBROUTINE PICKUP(I) COMMON /BLOC4/ LC, TOTANG, TOTROT, LCV(20), LUP(3) REAL LC, LCV, LUP COMMON /BLOC12/ RC(6,6), RCV(6,6,20), TC(5,21), UC(5,56), RCP, 1 RVP(20) LOGICAL RCP, RVP COMMON /BLOC13/ RC2(6,6), R2V(6,6,20), TC2(5,21), T2V(5,21,10), 1 UC2(5,56), U2V(5,56,10), R2P, R2VP(20) LOGICAL R2P, R2VP COMMON /BLOC15/ RS(6,6), RT(6,6), TS(5,21), TT(5,21), US(5,56), 1 UT(5,56) COMMON /BLOC16/ SI(6,6), SV(6,6,20), CO(6), COV(6,20), RI, 1 SVP(20), CVP(20), SOFA LOGICAL SVP, CVP, SOFA COMMON /BLOC18/ SIT(6,6), CEN(6), RECENT LOGICAL RECENT COMMON /BLOC27/ CT(6,6), CT0(6,6), CT1(3,3), X0L(3), VM(6), 1 VMT(6), COM(6,6,10), OR(3,3), XR(3), LMIS(2,10), 2 DMC, NM LOGICAL DMC COMMON /BLOC34/ NORD1, NORD2, NORD3, NORDX, LINEAR, JH, SIG LOGICAL LINEAR COMMON /BLOC38/ SIOL(3,6,6), COLD(3,6), RCO(3,6,6), R2O(6,6), 1 SPO(3), RCPO(3), R2PO LOGICAL SPO, RCPO, R2PO C LUP(I) = LC IF (.NOT. RECENT) CALL BEAM SPO(I) = SOFA DO 5 J = 1, 6 COLD(I,J) = CEN(J) 5 CONTINUE IF (NORD2 .LT. 1) RETURN DO 10 J = 1, 6 DO 10 K = 1, 6 SIOL(I,J,K) = SIT(J,K) 10 CONTINUE IF (.NOT. RCP) GO TO 30 DO 20 J = 1, 6 DO 20 K = 1, 6 RCO(I,J,K) = RC(J,K) 20 CONTINUE 30 IF (I .NE. 1) GO TO 50 DO 40 J = 1, 6 DO 40 K = 1, 6 R2O(J,K) = RC2(J,K) 40 CONTINUE 50 RCPO(I) = RCP IF (I .EQ. 1) R2PO = R2P RETURN END SUBROUTINE PREML3(UA,RB,URR) COMMON /BLOC32/ UNIT(12), XDIME(12) DIMENSION UA(5,56), RB(6,6), URR(5,21,6) DIMENSION S(180), UR(5,6,21) C DO 40 I2 = 1, 6 DO 3 I134 = 1, 105 S(I134) = 0.0 3 CONTINUE C C MULTIPLY U X R TO GET MATRIX PRODUCT UR C DO 30 I5 = 1, 6 I5M1 = I5 - 1 RBII = RB(I5,I2) IF (RBII .EQ. 0) GO TO 30 I1340 = I5*(I5+1)/2 IND = I5*(2 + I5*(3 + I5))/6 INDD = I5*(I5-1)/2 DO 8 I4 = I5, 6 DO 6 I3 = I5, I4 I134 = I1340 DO 5 I1 = 1, 5 S(I134) = S(I134) + UA(I1,IND)*RBII I134 = I134 + 21 5 CONTINUE I1340 = I1340 + 1 IND = IND + I3 6 CONTINUE I1340 = I1340 + I5M1 IND = IND + INDD 8 CONTINUE C IF (I5 .EQ. 1) GO TO 30 IND = I5*(-4 + I5*(3 + I5))/6 + 1 I1340 = INDD + 1 DO 18 I4 = I5, 6 DO 16 I3 = 1, I5M1 I134 = I1340 DO 15 I1 = 1, 5 S(I134) = S(I134) + UA(I1,IND)*RBII I134 = I134 + 21 15 CONTINUE I1340 = I1340 + 1 IND = IND + 1 16 CONTINUE I1340 = I1340 + I4 - I5M1 IND = IND + I4*(I4+1)/2 - I5M1 18 CONTINUE C I1340 = 1 IND0 = I5*(I5-1)*(I5+1)/6 IND = IND0 DO 28 I4 = 1, I5M1 DO 26 I3 = 1, I4 IND = IND + 1 I134 = I1340 DO 25 I1 = 1, 5 S(I134) = S(I134) + UA(I1,IND)*RBII I134 = I134 + 21 25 CONTINUE I1340 = I1340 + 1 26 CONTINUE 28 CONTINUE 30 CONTINUE C I134 = 0 DO 35 I1 = 1, 5 IND = 0 DO 35 I4 = 1, 6 DO 35 I3 = 1, I4 I134 = I134 + 1 IND = IND + 1 UR(I1,I2,IND) = S(I134) 35 CONTINUE 40 CONTINUE C C MULTIPLY UR X R TO GET DOUBLE MATRIX PRODUCT URR C DO 80 I3 = 1, 6 DO 53 I124 = 1, 180 S(I124) = 0.0 53 CONTINUE C IND0 = 0 IND1 = 0 DO 70 I6 = 1, 6 I6M1 = I6 - 1 IND0 = IND0 + I6 IND1 = IND1 + I6M1 RBII = RB(I6,I3) IF (RBII .EQ. 0) GO TO 70 I12400 = 6*I6M1 DO 58 I2 = 1, I3 I12400 = I12400 + 1 I1240 = I12400 IND = IND0 DO 58 I4 = I6, 6 I124 = I1240 DO 55 I1 = 1, 5 S(I124) = S(I124) + UR(I1,I2,IND)*RBII I124 = I124 + 36 55 CONTINUE I1240 = I1240 + 6 IND = IND + I4 58 CONTINUE C IF (I6 .EQ. 1) GO TO 70 I12400 = 1 DO 68 I2 = 1, I3 I1240 = I12400 IND = IND1 DO 66 I4 = 1, I6M1 I124 = I1240 IND = IND + 1 DO 65 I1 = 1, 5 S(I124) = S(I124) + UR(I1,I2,IND)*RBII I124 = I124 + 36 65 CONTINUE I1240 = I1240 + 6 66 CONTINUE I12400 = I12400 + 1 68 CONTINUE 70 CONTINUE C I12400 = 1 IND = I3*(I3-1)/2 DO 78 I2 = 1, I3 I1240 = I12400 IND = IND + 1 DO 76 I4 = 1, 6 I124 = I1240 DO 75 I1 = 1, 5 URR(I1,IND,I4) = S(I124) I124 = I124 + 36 75 CONTINUE I1240 = I1240 + 6 76 CONTINUE I12400 = I12400 + 1 78 CONTINUE 80 CONTINUE RETURN END SUBROUTINE PREMUL(TA,RB,TR) DIMENSION TA(5,21), RB(6,6), TR(5,6,6) DIMENSION S(30) C DO 30 I2 = 1, 6 DO 3 I13 = 1, 30 S(I13) = 0.0 3 CONTINUE C IND0 = 0 DO 20 I4 = 1, 6 RBII = RB(I4,I2) IND1 = IND0 + 1 IND0 = IND0 + I4 IF (RBII .EQ. 0) GO TO 20 I4M1 = I4 - 1 IIM = 6 - I4M1 I13 = 0 DO 8 I1 = 1, 5 IND = IND0 I13 = I13 + I4M1 DO 8 I3 = I4, 6 I13 = I13 + 1 S(I13) = S(I13) + TA(I1,IND)*RBII IND = IND + I3 8 CONTINUE IF (I4 .EQ. 1) GO TO 20 I13 = 0 DO 18 I1 = 1, 5 IND = IND1 DO 15 I3 = 1, I4M1 I13 = I13 + 1 S(I13) = S(I13) + TA(I1,IND)*RBII IND = IND + 1 15 CONTINUE I13 = I13 + IIM 18 CONTINUE 20 CONTINUE C I13 = 0 DO 25 I1 = 1, 5 DO 25 I3 = 1, 6 I13 = I13 + 1 TR(I1,I2,I3) = S(I13) 25 CONTINUE 30 CONTINUE RETURN END SUBROUTINE PREVUE COMMON /BLOC1/ NEL, NUM, NDIF, I, ISTOR(3129), DATA(13160) COMMON /BLOC3/ TYPE, L, LV INTEGER TYPE REAL L, LV COMMON /BLOC4/ LC, TOTANG, TOTROT, LCV(20), LUP(3) REAL LC, LCV, LUP COMMON /BLOC5/ VSTOR(20), TIE(13160), LABEL(3129), LABM(10) INTEGER VSTOR, TIE COMMON /BLOC47/ IC(4), IS(4), IP, NNDS, NDLEV COMMON /BLOC48/ NUMB, NUME, NCT, NCTV, NCTC, NCTS, NCTF C NUM = 1 NDIF = 1 TOTROT = 0 IP = 0 NNDS = 0 NDLEV = 0 NCT = 0 NCTV = 0 NPV = 0 IF (NEL .LE. 0) GO TO 5300 10 I = ISTOR(NUM) TYPE = DATA(I) IF (TYPE .LE. 0 .OR. TYPE .GE. 50) GO TO 5200 NCT = NCT + 1 C C DO VARY CODES C 30 KV = NIV(TYPE) IF (KV .EQ. 0) GO TO 70 IVA = 0 DO 50 JV = 1, KV K = I + JV ISIG = TIE(K) IF (ISIG .EQ. 0) GO TO 50 IVA = 1 50 CONTINUE NPV = NPV + 1 IF (IVA .EQ. 0) GO TO 5200 IF (NCTV .NE. 0) GO TO 5200 NUMB = NUM NCTV = NCT GO TO 5200 C 70 IF (TYPE .EQ. 9) GO TO 900 IF (TYPE .EQ. 10) GO TO 1000 IF (TYPE .EQ. 24) GO TO 2400 GO TO 5200 C C 9. -- REPEAT C 900 CALL REPEAT GO TO 5200 C C 10. -- FITTING CONSTRAINTS C 1000 NCTC = NCT NUME = NUM GO TO 5200 C C 24. -- DEFINED SECTION C 2400 CALL DEFINE GO TO 5200 C C ADVANCE TO NEXT ELEMENT C 5200 NUM = NUM + NDIF IF (NUM .LE. NEL) GO TO 10 IF (NPV .LE. -1) NCTV = 1 5300 CONTINUE RETURN END SUBROUTINE PRINT1(LABEL,NWORD,DATA,VARY,INDEX) C PRINT DATA FOR ONE ELEMENT COMMON /BLOC2/ NIN, NOUT, NPUNCH COMMON /BLOC42/ TABLE(36), PLUS, MINUS, BLANK, PERIOD, SPEC(10) INTEGER TABLE, PLUS, MINUS, BLANK, PERIOD, SPEC INTEGER SEMI, ASTER, QUOTE, PARENC EQUIVALENCE (SEMI,SPEC(2)), (ASTER,SPEC(3)), 1 (QUOTE,SPEC(5)), (PARENC,SPEC(10)) INTEGER VARY(30), CHAR(12), CHART(30), NV(27), NVT(5) EQUIVALENCE (CHAR(1), CHART(1)) REAL DATA(30) DATA NV /6,1,1,3,2,0,6,6,0,1,0,15,0,6,0,2,0,2,2,1,0,0,0,0,2,1,6/ DATA NVT /1,1,1,1,0/ C ILIM = QUOTE IF (LABEL .EQ. BLANK) ILIM = BLANK IF (INDEX .NE. 1) ILIMO = BLANK IF (INDEX .EQ. 1) ILIMO = ASTER C NTYPE = DATA(1) KTYPE = IABS(NTYPE) IF (KTYPE .EQ. 0) GO TO 70 IF (KTYPE .EQ. 15) GO TO 50 IF (KTYPE .EQ. 16 .AND. IFIX(DATA(2)) .EQ. 14) GO TO 81 IF (KTYPE .EQ. 24) GO TO 55 DO 10 J = 1, 30 10 CHART(J) = BLANK IF (NTYPE .LT. 0) GO TO 40 IF (NTYPE .GT. 27 .AND. NTYPE .LT. 50) GO TO 40 IF (NTYPE .GE. 55) GO TO 40 IF (NTYPE .LE. 27) KV = NV(NTYPE) IF (NTYPE .GE. 50) KV = NVT(NTYPE - 49) IF (KV .EQ. 0) GO TO 40 LV = 0 LPV = 0 DO 30 JV = 1, KV K = IABS(VARY(JV+1)) IF (VARY(JV+1) .GE. 0) GO TO 20 LV = LV + 1 CHAR(LV) = MINUS 20 LV = LV + 1 IF (K .GT. 1) LPV = LV 30 CHAR(LV) = TABLE(K+1) IF (KTYPE .EQ. 12 .AND. LPV .GT. 12) GO TO 45 40 IF (NWORD .LE. 1) GO TO 60 IF (KTYPE .EQ. 4) GO TO 42 41 WRITE (NOUT,940) ILIMO, NTYPE, CHAR, ILIM, LABEL, ILIM, 1 (BLANK, DATA(J), J = 2, NWORD), SEMI RETURN 42 WRITE (NOUT,942) ILIMO, NTYPE, CHAR, ILIM, LABEL, ILIM, 1 (DATA(J), J = 2, 4), SEMI RETURN 45 WRITE (NOUT,945) ILIMO, NTYPE, CHART, ILIM, LABEL, ILIM, 1 (DATA(J), J = 2, NWORD), SEMI RETURN 50 WRITE (NOUT,950) ILIMO, NTYPE, ILIM, LABEL, ILIM, 1 (DATA(J), J = 2, 4) RETURN 55 WRITE (NOUT,955) ILIMO, NTYPE, ILIM, LABEL, ILIM, DATA(2), DATA(3) RETURN 60 WRITE (NOUT,960) ILIMO, NTYPE, CHAR, ILIM, LABEL, ILIM RETURN 70 WRITE (NOUT,970) ILIMO, ILIM, LABEL, ILIM, 1 (DATA(J), J = 2, NWORD), PARENC RETURN 81 WRITE (NOUT,981) ILIMO, NTYPE, ILIM, LABEL, ILIM, 1 DATA(2), DATA(3) RETURN C 940 FORMAT (1H ,A1,I4,1H.,12A1,1X,A1,A4,A1,1X,A1,8(F11.5,A1)/ 1 (28X,8(F11.5,A1))) 942 FORMAT (1H ,A1,I4,1H.,12A1,1X,A1,A4,A1,1X,2F12.5,F13.5,A1) 945 FORMAT (1H ,A1,I4,1H.,30A1,1X,A1,A4,A1,7X,6(F12.5)/ 1 /27X,8F12.5/27X,F12.5,A1) 950 FORMAT (1H ,A1,I4,1H.,13X,A1,A4,A1,1X,F12.5,4H ",A4,4H" , 1 F12.5,2H ;) 955 FORMAT (1H ,A1,I4,1H.,13X,A1,A4,A1,1X,F12.5,4H ",A4,4H" ,2H ;) 960 FORMAT (1H ,A1,I4,1H.,12A1,1X,A1,A4,A1,1X,1H;) 970 FORMAT (1H ,A1,A1,A4,A1,2H (,29A4,A1) 981 FORMAT (1H ,I4,1H.,A1,A4,A1,1X,F12.5,I12,1H;) END SUBROUTINE PUNCH1 COMMON /BLOC2/ NIN, NOUT, NPUNCH COMMON /BLOC15/ RS(6,6), RT(6,6), TS(5,21), TT(5,21), US(5,56), 1 UT(5,56) COMMON /BLOC30/ CDB, NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, 1 LCPR, ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, 2 LAY191, NPFR INTEGER CDB LOGICAL NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, LCPR, 1 ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, LAY191 COMMON /BLOC32/ UNIT(12), XDIME(12) REAL OUTPUT(30) 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)*UNIT(K)/UNIT(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 (CDB.LT. 31) GO TO 13 N = CDB - 30 GO TO 20 13 N = 0 14 N = N + 1 20 JK = 0 DO 21 K = 1, J JK = JK + 1 TEMP = 2. IF (J .EQ. K) TEMP = 1.0 OUTPUT(K) = TS(N,JK)*UNIT(J)*UNIT(K)*TEMP/UNIT(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. 6) GO TO 31 GO TO 14 30 IF (N .EQ. 3) GO TO 31 N = 3 GO TO 20 31 RETURN END SUBROUTINE QEO COMMON /BLOC2/ NIN, NOUT, NPUNCH COMMON /BLOC4/ LC, TOTANG, TOTROT, LCV(20), LUP(3) REAL LC, LCV, LUP COMMON /BLOC16/ SI(6,6), SV(6,6,20), CO(6), COV(6,20), RI, 1 SVP(20), CVP(20), SOFA LOGICAL SVP, CVP, SOFA COMMON /BLOC17/ COD(6), COF(6), PSIX, PSIY, PSIX1, PSIY1, NOPH LOGICAL NOPH COMMON /BLOC18/ SIT(6,6), CEN(6), RECENT LOGICAL RECENT COMMON /BLOC20/ ETA(6), DETA(6,20), RAY, EVP(20) LOGICAL RAY, EVP COMMON /BLOC26/ O(4,3,3), X0(4,3), IR, RORC, TYT, ALIGN, TMK, 1 FEO, CHORD INTEGER RORC, TYT LOGICAL ALIGN, TMK, FEO, CHORD COMMON /BLOC30/ CDB, NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, 1 LCPR, ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, 2 LAY191, NPFR INTEGER CDB LOGICAL NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, LCPR, 1 ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, LAY191 COMMON /BLOC32/ UNIT(12), XDIME(12) COMMON /BLOC34/ NORD1, NORD2, NORD3, NORDX, LINEAR, JH, SIG LOGICAL LINEAR DIMENSION OUTPUT(10), SIO(6) C C CUMULATIVE LENGTH C ALONG = LC/UNIT(8) C C BEAM SIZE C IF (.NOT. RECENT) CALL BEAM IF (NORD3 .LT. 1) GO TO 11 IF (ACCEL) GO TO 200 DO 10 J = 1, 6 SIO(J) = SQRT(SIT(J,J)) 10 CONTINUE C C PRINT BEAM PARAMETERS C 11 IF (TERSE) GO TO 100 CENUN = CEN(1)/UNIT(1) SIUN = 0.0 IF (NORD3 .GE. 1) SIUN = SIO(1)/UNIT(1) IF (LCPR) GO TO 20 WRITE (NOUT,1016) ALONG, XDIME(8), CENUN, SIUN, XDIME(1) 1016 FORMAT (1H ,F10.3,1X,A4,52X,F12.3,F8.3,1X,A4) GO TO 30 20 WRITE (NOUT,1015) CENUN, SIUN, XDIME(1) 1015 FORMAT (1H ,67X,F12.3,F8.3,1X,A4) C 30 DO 40 J = 2, 6 JMIN1 = J - 1 CENUN = CEN(J)/UNIT(J) SIUN = 0.0 IF (NORD3 .GE. 1) SIUN = SIO(J)/UNIT(J) 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 WRITE (NOUT,1014) 1 CENUN, SIUN, XDIME(J), (OUTPUT(K), K = 1, JMIN1) 1014 FORMAT (68X,F12.3,F8.3,1X,A4,F9.3,4F7.3) 40 CONTINUE GO TO 300 C C SINGLE LINE OUTPUT C 100 IF (.NOT. NOPH .AND. NORD3 .GE. 1 .AND. .NOT. SOFA) GO TO 120 DO 110 J = 1, 6 OUTPUT(J) = CEN(J)/UNIT(J) 110 CONTINUE IF (LCPR) GO TO 115 WRITE (NOUT,1013) ALONG, XDIME(8), (OUTPUT(J), XDIME(J), J = 1, 6) 1013 FORMAT (1H ,F10.3,1X,A4,17X,6(F8.3,1X,A4),1X,2F9.3) GO TO 120 115 WRITE (NOUT,1017) (OUTPUT(J), XDIME(J), J = 1, 6) 1017 FORMAT (1H ,32X,6(F8.3,1X,A4),1X,2F9.3) C 120 IF (NOPH .OR. NORD3 .LT. 1) GO TO 300 DO 130 J = 1, 6 OUTPUT(J) = SIO(J)/UNIT(J) 130 CONTINUE OUTPUT(7) = SIT(1,2)/DEN(SIO(1)*SIO(2)) OUTPUT(8) = SIT(3,4)/DEN(SIO(3)*SIO(4)) IF (.NOT. SOFA) GO TO 140 WRITE (NOUT,1012) (OUTPUT(J), J = 1, 8) 1012 FORMAT (1H ,32X,6(F8.3,5X),1X,2F9.3) GO TO 300 140 IF (LCPR) GO TO 150 WRITE (NOUT,1013) ALONG, XDIME(8), (OUTPUT(J), XDIME(J), J=1,6), 1 OUTPUT(7), OUTPUT(8) GO TO 300 150 WRITE (NOUT,1017) (OUTPUT(J), XDIME(J), J = 1, 6), 1 OUTPUT(7), OUTPUT(8) GO TO 300 C C ACCELERATOR NOTATION C 200 OUTPUT(1) = PSIX/UNIT(12) OUTPUT(2) = PSIY/UNIT(12) OUTPUT(3) = SIT(1,1)*UNIT(2)/UNIT(1) OUTPUT(4) = SIT(3,3)*UNIT(4)/UNIT(3) OUTPUT(5) = - SIT(1,2) OUTPUT(6) = - SIT(3,4) OUTPUT(7) = ETA(1)/UNIT(1) OUTPUT(8) = ETA(3)/UNIT(3) OUTPUT(9) = ETA(2)/UNIT(2) OUTPUT(10) = ETA(4)/UNIT(4) IF (LCPR) GO TO 210 WRITE (NOUT,1025) ALONG, XDIME(8), (OUTPUT(J), J = 1, 10) 1025 FORMAT (1H ,F10.3,1X,A4,17X,10F10.4) GO TO 300 210 WRITE (NOUT,1026) (OUTPUT(J), J = 1, 10) 1026 FORMAT (1H ,32X,10F10.4) C 300 LCPR = .TRUE. RETURN END FUNCTION RANDIS(IX) C RANDIS = 2.0*RANNU(IX) - 1.0 RETURN END ! SUBROUTINE RANGET(IGET) C C *** FOR THE VAX, SUBROUTINE RANGET WAS ELIMINATED AND CALLED AS AN C ENTRY IN FUNCTION RANNU *** C FUNCTION RANNU(IX) DATA ISEED /322459527/ C C *** ALL CALCULATIONS NECESSARY TO GENERATE A RANDOM NUMBER ON THE CDC C WERE ELIMINATED *** C RANNU = RAN(ISEED) RETURN C C *** ON VAX, RANSET IS INCLUDED IN RANNU ROUTINE *** C ENTRY RANSET(ISET) IF (ISET .NE. 0) THEN ISEED = (ISET/2)*2+1 ISET = ISEED ELSE C C SECONDS ARE THE TOTAL NUMBER OF SECONDS SINCE MIDNIGHT C ISEED = SECNDS(0.)+1234560 ISEED = (ISEED/2)*2+1 END IF RETURN C C *** ON VAX, RANGET IS INCLUDED IN RANNU ROUTINE *** C ENTRY RANGET(IGET) IGET = ISEED RETURN C C *** ON VAX, RANST IS INCLUDED IN RANNU ROUTINE *** C ENTRY RANST DATA ISINIT /322459527/ C ISEED = ISINIT RETURN END ! SUBROUTINE RANSET(ISET) C C *** FOR THE VAX, SUBROUTINE RANSET IS CALLED AS AN ENTRY IN C FUNCTION RANNU *** C ! SUBROUTINE RANST C C *** FOR THE VAX, SUBROUTINE RANSET IS CALLED AS AN ENTRY IN C FUNCTION RANNU *** C SUBROUTINE RCALC COMMON /BLOC3/ TYPE, L, LV INTEGER TYPE REAL L, LV COMMON /BLOC11/ R(6,6), RV(6,6), T(5,21), TV(5,21), U(5,56), 1 UV(5,56) DIMENSION RL(36), RVL(36), TL(105), TVL(105), UL(280), 1 UVL(280) EQUIVALENCE (R(1,1),RL(1)), (RV(1,1),RVL(1)), 1 (T(1,1),TL(1)), (TV(1,1),TVL(1)), 2 (U(1,1),UL(1)), (UV(1,1),UVL(1)) COMMON /BLOC12/ RC(6,6), RCV(6,6,20), TC(5,21), UC(5,56), RCP, 1 RVP(20) LOGICAL RCP, RVP DIMENSION RCL(36), RCVL(36,20), TCL(105), UCL(280) EQUIVALENCE (RC(1,1),RCL(1)), (RCV(1,1,1), RCVL(1,1)), 1 (TC(1,1),TCL(1)), (UC(1,1),UCL(1)) COMMON /BLOC13/ RC2(6,6), R2V(6,6,20), TC2(5,21), T2V(5,21,10), 1 UC2(5,56), U2V(5,56,10), R2P, R2VP(20) LOGICAL R2P, R2VP DIMENSION RC2L(36), R2VL(36,20), TC2L(105), T2VL(105,10), 1 UC2L(280), U2VL(280,10) EQUIVALENCE (RC2(1,1),RC2L(1)), (R2V(1,1,1),R2VL(1,1)), 1 (TC2(1,1),TC2L(1)), (T2V(1,1,1),T2VL(1,1)), 2 (UC2(1,1),UC2L(1)), (U2V(1,1,1),U2VL(1,1)) COMMON /BLOC15/ RS(6,6), RT(6,6), TS(5,21), TT(5,21), US(5,56), 1 UT(5,56) DIMENSION RSL(36), RTL(36), TSL(105), TTL(105), USL(280), 1 UTL(280) EQUIVALENCE (RS(1,1),RSL(1)), (RT(1,1),RTL(1)), 1 (TS(1,1),TSL(1)), (TT(1,1),TTL(1)), 2 (US(1,1),USL(1)), (UT(1,1),UTL(1)) COMMON /BLOC16/ SI(6,6), SV(6,6,20), CO(6), COV(6,20), RI, 1 SVP(20), CVP(20), SOFA LOGICAL SVP, CVP, SOFA COMMON /BLOC18/ SIT(6,6), CEN(6), RECENT LOGICAL RECENT COMMON /BLOC19/ TR(5,6,6), TRA(5,6,6), URR(5,21,6), NORDE COMMON /BLOC26/ O(4,3,3), X0(4,3), IR, RORC, TYT, ALIGN, TMK, 1 FEO, CHORD INTEGER RORC, TYT LOGICAL ALIGN, TMK, FEO, CHORD COMMON /BLOC28/ COC, DE0, SD, CTY, JV, NC, NV1, NV2, NV3 INTEGER CTY COMMON /BLOC29/ A(21), CW, CA(21,21), SCALE(21), CASAV(21,21), 1 PMARQ, CHSMIN, XNORM, GNORM, EPS COMMON /BLOC30/ CDB, NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, 1 LCPR, ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, 2 LAY191, NPFR INTEGER CDB LOGICAL NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, LCPR, 1 ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, LAY191 COMMON /BLOC34/ NORD1, NORD2, NORD3, NORDX, LINEAR, JH, SIG LOGICAL LINEAR C IF (CDB .EQ. 14) GO TO 400 IF (CDB .EQ. 24) GO TO 10 IF (RCP) GO TO 100 C C DESIRED MATRIX EQUALS R2 MATRIX C 10 DO 20 JK = 1, 36 20 RSL(JK) = RC2L(JK) IF (NORD2 .EQ. 1) GO TO 50 DO 30 JKM = 1, 105 30 TSL(JKM) = TC2L(JKM) IF (NORD2 .LE. 2) GO TO 50 DO 40 JKLM = 1, 280 40 USL(JKLM) = UC2L(JKLM) 50 IF (CDB .LT. 0) GO TO 300 RETURN C C DESIRED MATRIX EQUALS RC MATRIX C 100 IF (R2P) GO TO 200 DO 120 JK = 1, 36 120 RSL(JK) = RCL(JK) IF (NORD2 .EQ. 1) GO TO 150 DO 130 JKM = 1, 105 130 TSL(JKM) = TCL(JKM) IF (NORD2 .LE. 2) GO TO 150 DO 140 JKLM = 1, 280 140 USL(JKLM) = UCL(JKLM) 150 IF (CDB .LT. 0) GO TO 300 RETURN C C DESIRED MATRIX EQUALS RC2 TIMES RC C 200 IF (NORD2 .GE. 2) GO TO 210 CALL CAB(RS,RC2,RC) GO TO 250 210 IF (NORD2 .EQ. 3) GO TO 220 CALL CAB2(RS,TS,RC2,TC2,RC,TC,.FALSE.) GO TO 250 220 CALL CAB3(RS,TS,US,RC2,TC2,UC2,RC,TC,UC,.FALSE.) 250 IF (CDB .LT. 0) GO TO 300 RETURN C C FIND INVERSE MATRIX C 300 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 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) IF (NORD3 .EQ. 1) RETURN DO 340 J = 1, 5 DO 340 IND = 1, 21 SS = 0.0 DO 335 K = 1, 5 SS = SS + RS(J,K)*TS(K,IND) 335 CONTINUE TT(J,IND) = - SS 340 CONTINUE DO 350 J = 1, 5 DO 350 L1 = 1, 6 IND0 = 0 IND1 = 0 DO 350 L2 = 1, 6 IND1 = IND1 + L2 IND = IND1 SS = 0.0 DO 345 K = 1, L2 IND0 = IND0 + 1 SS = SS + TT(J,IND0)*RS(K,L1) 345 CONTINUE IF (L2 .EQ. 6) GO TO 348 L2P1 = L2 + 1 DO 346 K = L2P1, 6 IND = IND + K - 1 SS = SS + TT(J,IND)*RS(K,L1) 346 CONTINUE 348 TR(J,L1,L2) = SS 350 CONTINUE DO 360 J = 1, 5 IND = 0 DO 360 L2 = 1, 6 DO 360 L1 = 1, L2 IND = IND + 1 SS = 0.0 DO 355 K = 1, 6 SS = SS + TR(J,L1,K)*RS(K,L2) 355 CONTINUE TS(J,IND) = SS 360 CONTINUE RETURN C C DESIRED MATRIX EQUALS R MATRIX (INDIVIDUAL ELEMENT) C 400 DO 420 JK = 1, 36 420 RSL(JK) = RL(JK) IF (NORD1 .EQ. 1) RETURN DO 430 JKM = 1, 105 430 TSL(JKM) = TL(JKM) IF (NORD1 .LE. 2) RETURN DO 440 JKLM = 1, 280 440 USL(JKLM) = UL(JKLM) RETURN END SUBROUTINE RCOUT COMMON /BLOC1/ NEL, NUM, NDIF, I, ISTOR(3129), DATA(13160) COMMON /BLOC2/ NIN, NOUT, NPUNCH COMMON /BLOC3/ TYPE, L, LV INTEGER TYPE REAL L, LV COMMON /BLOC4/ LC, TOTANG, TOTROT, LCV(20), LUP(3) REAL LC, LCV, LUP COMMON /BLOC5/ VSTOR(20), TIE(13160), LABEL(3129), LABM(10) COMMON /BLOC12/ RC(6,6), RCV(6,6,20), TC(5,21), UC(5,56), RCP, 1 RVP(20) LOGICAL RCP, RVP COMMON /BLOC13/ RC2(6,6), R2V(6,6,20), TC2(5,21), T2V(5,21,10), 1 UC2(5,56), U2V(5,56,10), R2P, R2VP(20) LOGICAL R2P, R2VP COMMON /BLOC15/ RS(6,6), RT(6,6), TS(5,21), TT(5,21), US(5,56), 1 UT(5,56) COMMON /BLOC16/ SI(6,6), SV(6,6,20), CO(6), COV(6,20), RI, 1 SVP(20), CVP(20), SOFA LOGICAL SVP, CVP, SOFA COMMON /BLOC18/ SIT(6,6), CEN(6), RECENT LOGICAL RECENT COMMON /BLOC30/ CDB, NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, 1 LCPR, ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, 2 LAY191, NPFR INTEGER CDB LOGICAL NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, LCPR, 1 ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, LAY191 COMMON /BLOC32/ UNIT(12), XDIME(12) COMMON /BLOC34/ NORD1, NORD2, NORD3, NORDX, LINEAR, JH, SIG LOGICAL LINEAR COMMON /BLOC42/ TABLE(36), PLUS, MINUS, BLANK, PERIOD, SPEC(10) INTEGER TABLE, PLUS, MINUS, BLANK, PERIOD, SPEC INTEGER QUOTE EQUIVALENCE (QUOTE,SPEC(5)) INTEGER IROW(10), ICOL(10), ISH1(9), ISH2(9), ISV1(6), ISV2(6) REAL OUTPUT(10) DATA IROW /1,1,2,2,3,3,4,4,1,2/ DATA ICOL /1,2,1,2,3,4,3,4,6,6/ 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 ACCUMULATED LENGTH C IF (LCPR) GO TO 10 ALONG = LC/UNIT(8) IF (.NOT. TERSE) WRITE (NOUT,1007) ALONG, XDIME(8) 1007 FORMAT (1H ,F10.3,1X,A4) C C DETERMINE TRANSFER MATRIX C 10 IF (NORD3 .GE. 1) CALL RCALC IF (TYPE .EQ. 13 .AND. RAT .AND. .NOT. TERSE) GO TO 200 ILIM = BLANK LABL = BLANK IF (TYPE .NE. 13) GO TO 100 IF (LABEL(NUM) .EQ. BLANK) GO TO 100 ILIM = QUOTE LABL = LABEL(NUM) C C PRINT FIRST ORDER TRANSFER MATRIX C 100 IF (TERSE) GO TO 150 NCOLS = 6 IF (CDB .NE. 14) GO TO 101 WRITE (NOUT,1002) 1002 FORMAT (17H0*ELEMENT MATRIX*) GO TO 110 101 IF (CDB .EQ. 4 .OR. CDB .EQ. 6) NR = 1 IF (CDB .EQ. 24) NR = 2 IF (CDB .EQ. -4) NR = -1 IF (SOFA) GO TO 105 WRITE (NOUT,1004) NR, ILIM, LABL, ILIM 1004 FORMAT (11H *TRANSFORM,I2,1H*,10X,A1,A4,A1) GO TO 110 105 IF (NORD3 .LT. 1) NCOLS = 1 IF (NORD3 .GE. 1) NCOLS = 7 WRITE (NOUT,1008) NR, ILIM, LABL, ILIM 1008 FORMAT (11H *TRANSFORM,I2,1H*,10X,A1,A4,A1,65X,3HREF) C 110 DO 130 J = 1, 6 IF (SOFA) OUTPUT(NCOLS) = CO(J)/UNIT(J) IF (NORD3 .GE. 1) GO TO 120 WRITE (NOUT,1015) OUTPUT(1) 1015 FORMAT (91X,F10.5) GO TO 130 120 DO 125 K = 1, 6 OUTPUT(K) = RS(J,K) * UNIT(K) / UNIT(J) 125 CONTINUE WRITE (NOUT,1003) (OUTPUT(K), K = 1, NCOLS) 1003 FORMAT (F21.5,5F10.5,20X,F10.5) 130 CONTINUE 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)*UNIT(IC)/UNIT(IR) 160 CONTINUE IF (LCPR) GO TO 170 WRITE (NOUT,1000) ALONG, XDIME(8), ILIM, LABL, ILIM, OUTPUT 1000 FORMAT (1H ,F10.3,1X,A4,8X,A1,A4,A1,3X,4F9.4,4X,4F9.4,4X,2F9.4) GO TO 200 170 WRITE (NOUT,1001) ILIM, LABL, ILIM, OUTPUT 1001 FORMAT (1H ,23X,A1,A4,A1,3X,4F9.4,4X,4F9.4,4X,2F9.4) C C PRINT SECOND ORDER TRANSFER MATRIX C 200 IF (NORD3 .LE. 1) GO TO 400 IF (TERSE) GO TO 250 IF (CDB .EQ. 6) RETURN WRITE (NOUT,1011) 1011 FORMAT (22H0*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)*UNIT(J)*UNIT(K)/UNIT(N) IF (J .NE. K) OUTPUT(K) = 2.0*OUTPUT(K) 208 CONTINUE WRITE (NOUT,1009) (N,K,J,OUTPUT(K), K = 1, J) 1009 FORMAT (6(I4,I2,I1,1PE11.3)) 209 CONTINUE WRITE (NOUT,1010) 1010 FORMAT (1H ) 210 CONTINUE GO TO 300 C 250 DO 280 J = 1, 9 K1 = ISH1(J) K2 = ISH2(J) K1K2 = K2*(K2-1)/2 + K1 OUTPUT(1) = TS(1,K1K2)*UNIT(K1)*UNIT(K2)/UNIT(1) OUTPUT(2) = TS(2,K1K2)*UNIT(K1)*UNIT(K2)/UNIT(2) IF (K1 .EQ. K2) GO TO 251 OUTPUT(1) = 2.0*OUTPUT(1) OUTPUT(2) = 2.0*OUTPUT(2) 251 IF (J .GT. 6) GO TO 260 L1 = ISV1(J) L2 = ISV2(J) L1L2 = L2*(L2-1)/2 + L1 OUTPUT(3) = TS(3,L1L2)*UNIT(L1)*UNIT(L2)/UNIT(3) OUTPUT(4) = TS(4,L1L2)*UNIT(L1)*UNIT(L2)/UNIT(4) IF (L1 .EQ. L2) GO TO 255 OUTPUT(3) = 2.0*OUTPUT(3) OUTPUT(4) = 2.0*OUTPUT(4) 255 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 C PRINT THIRD ORDER TRANSFER MATRIX C 300 IF (NORD3 .LE. 2) GO TO 400 WRITE (NOUT,1012) 1012 FORMAT (22H0*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)*UNIT(J)*UNIT(K)*UNIT(M)/UNIT(N) IF (J .NE. K .OR. K .NE. M .OR. J .NE. M) 1 OUTPUT(M) = 3.0*OUTPUT(M) IF (J .NE. K .AND. K .NE. M .AND. J .NE. M) 1 OUTPUT(M) = 2.0*OUTPUT(M) 308 CONTINUE WRITE (NOUT,1013) (N,M,K,J,OUTPUT(M), M = 1, K) 1013 FORMAT (6(I4,I2,2I1,1PE11.3)) 309 CONTINUE WRITE (NOUT,1010) 310 CONTINUE C 400 LCPR = .TRUE. RETURN END SUBROUTINE RDELMT C C READ IN DATA FOR ONE ELEMENT C COMMON /BLOC2/ NIN, NOUT, NPUNCH COMMON /BLOC41/ LW, IMAGE(20), FLUSH, INDIC, NTYPE, LABLE, LENGTH, 1 NWORD, NVARY, DATUM(30), VARY(30) INTEGER VARY, TEXT(30) LOGICAL FLUSH EQUIVALENCE (TEXT(1),DATUM(1)) COMMON /BLOC42/ TABLE(36), PLUS, MINUS, BLANK, PERIOD, SPEC(10) INTEGER TABLE, PLUS, MINUS, BLANK, PERIOD, SPEC INTEGER ESS EQUIVALENCE (ESS,TABLE(29)) INTEGER COMMA, SEMI, ASTER, DOLLAR, QUOTE, APOST, EQUAL, 1 SLASH, PARENO, PARENC EQUIVALENCE (COMMA,SPEC(1)), (SEMI,SPEC(2)), 1 (ASTER,SPEC(3)), (DOLLAR,SPEC(4)), 2 (QUOTE,SPEC(5)), (APOST,SPEC(6)), 3 (EQUAL,SPEC(7)), (SLASH,SPEC(8)), 4 (PARENO,SPEC(9)), (PARENC,SPEC(10)) COMMON /BLOC43/ NCD, CARD(80), MC, EMPTY, ITEM, INDP INTEGER CARD LOGICAL EMPTY COMMON /CONSTS/ PI, RADIAN, CLIGHT, EMASS EQUIVALENCE (VALUE,IVALUE) INTEGER NO1(27), NO2(5), UTABLE(14) REAL CTABLE(14) LOGICAL SNTNL, SEPAR DATA SNTNL / .FALSE. / DATA NO1 /8,2,2,4,4,3,7,8,2,5,5,16,2,8,4,3,3,4,3,2,4,4,5,3,4,4,7/ DATA NO2 /5,5,5,3,3/ DATA UTABLE / 2HCM , 1HM , 2HIN , 2HFT , 2HMM , 1HR , 2HMR , 1 2HPC , 4HP/10, 1HN , 3HMEV, 3HGEV, 2HKG , 1HG / DATA CTABLE / 1.0, 100.0, 2.54, 30.48, 0.1, 1000.0, 1.0, 1.0, 1 0.1, 100.0, 0.001, 1.0, 1.0, 0.001 / DATA IARROW / 1H^ / C C SET DEFAULT VALUES C 10 DO 20 J = 1, 30 DATUM(J) = 0.0 20 VARY (J) = 0 NWORD = 0 NVARY = 1 LABLE = BLANK C C HAS SENTINEL BEEN READ AT PREVIOUS CALL C IF (.NOT. SNTNL) GO TO 30 SNTNL = .FALSE. RETURN C 30 CALL RDNEXT (1) SEPAR = .TRUE. GO TO 110 C C SEPARATORS C 100 SEPAR = ITEM .EQ. BLANK CALL RDNEXT (- 1) 110 IF (ITEM .EQ. SEMI .OR. ITEM .EQ. ASTER .OR. ITEM .EQ. DOLLAR) 1 GO TO 500 IF (ITEM .EQ. QUOTE .OR. ITEM .EQ. APOST .OR. ITEM .EQ. EQUAL 1 .OR. ITEM .EQ. SLASH) GO TO 350 IF (ITEM .EQ. PARENO) GO TO 400 IF (ITEM .EQ. PARENC) GO TO 130 IF (ITEM .EQ. ESS) GO TO 450 IF (SEPAR) GO TO 150 130 WRITE (NOUT, 9130) CARD, (BLANK, J = 1, MC), IARROW CALL EXIT 150 IF (NWORD) 300, 200, 300 C C TYPE CODE C 200 CALL RDFIX (NTYPE, IFLAG) IF (IFLAG .NE. 0) GO TO 130 NWORD = 1 DATUM(1) = NTYPE NTYPE = IABS(NTYPE) IF (ITEM .NE. PERIOD) GO TO 100 C C VARY CODES C 210 CALL RDNEXT (0) IFLAG = 0 IF (ITEM .EQ. MINUS) GO TO 220 ISIG = 1 IF (ITEM .NE. PLUS) GO TO 240 GO TO 230 220 ISIG = - 1 230 CALL RDNEXT (0) IFLAG = 1 240 DO 250 J = 1, 36 IF (ITEM .EQ. TABLE(J)) GO TO 260 250 CONTINUE IF (IFLAG) 130, 100, 130 260 IF (NVARY .GE. 30) GO TO 210 NVARY = NVARY + 1 VARY(NVARY) = ISIGN(J - 1, ISIG) GO TO 210 C C DATA VALUE C 300 CALL RDFLT (VALUE, IFLT, IFLAG) IF (IFLT .NE. 0) GO TO 310 IF (NTYPE .NE. 16) GO TO 305 IF (NWORD .NE. 2) GO TO 305 IF (IFIX(DATUM(2)) .NE. 14) GO TO 305 GO TO 310 305 VALUE = FLOAT(IVALUE) 310 IF (IFLAG .NE. 0) GO TO 130 NWORD = NWORD + 1 IF (NWORD .LE. 30) DATUM(NWORD) = VALUE GO TO 100 C C LABEL C 350 CALL RDSTRG (IWORD, 1, L) IF (L .GT. 1) WRITE (NOUT, 9350) CALL RDNEXT (1) SEPAR = .TRUE. IF (NWORD .EQ. 2 .AND. NTYPE .EQ. 15) GO TO 360 IF (NWORD .EQ. 2 .AND. NTYPE .EQ. 24) GO TO 370 IF (LABLE .NE. BLANK) WRITE (NOUT, 9360) LABLE LABLE = IWORD GO TO 110 360 TEXT(3) = IWORD NWORD = 3 GO TO 110 370 TEXT(3) = IWORD NWORD = 3 GO TO 110 C C COMMENT C 400 IF (NWORD .NE. 0) GO TO 130 NTYPE = 0 CALL RDSTRG (TEXT(2), 29, L) IF (L .GT. 29) WRITE (NOUT, 9400) NWORD = MIN0(L+1, 30) LENGTH = 30 IF (MOD(INDIC,10) .EQ. 0) LENGTH = NWORD GO TO 700 C C SENTINEL C 450 EMPTY = .TRUE. IF (NWORD .EQ. 0) RETURN SNTNL = .TRUE. C C CHECK VALIDITY OF ELEMENT JUST READ C 500 IF (NWORD .EQ. 0) GO TO 130 IF (NTYPE .EQ. 0) GO TO 510 IF (NTYPE .LE. 27) GO TO 530 IF (NTYPE .LT. 50) GO TO 510 IF (NTYPE .GT. 54 .AND. NTYPE .NE. 60) GO TO 510 LENGTH = NO2(NTYPE - 49) IF (NTYPE .EQ. 53) LENGTH = MIN0(3,NWORD) IF (NTYPE .EQ. 53) LENGTH = MAX0(2,NWORD) IF (NWORD - LENGTH) 600, 700, 550 510 WRITE (NOUT, 9510) FLUSH = .TRUE. GO TO 700 530 LENGTH = NO1(NTYPE) IF (NTYPE .NE. 16) GO TO 535 ICODE = IFIX(DATUM(2)) IF (DATUM(1) .GT. 0 .AND. ICODE .EQ. 14) CALL RANSET(TEXT(3)) GO TO 545 535 IF (NTYPE .NE. 17) GO TO 545 IF (NWORD .EQ. 1) DATUM(2) = 2.0 IF (NWORD .LT. 3) DATUM(3) = DATUM(2) 545 IF (NWORD - LENGTH) 600, 700, 550 C C DATA OVERFLOW C 550 IF (DATUM(9) .NE. 0.0) GO TO 560 IF (NTYPE .EQ. 1) LENGTH = 9 IF (NTYPE .EQ. 14) LENGTH = 30 IF (NWORD - LENGTH) 600, 700, 560 560 WRITE (NOUT, 9560) GO TO 690 C C FILL IN INCOMPLETE 15 ELEMENT C 600 IF (MOD(INDIC,10) .NE. 0) GO TO 700 IF (NTYPE .NE. 15) GO TO 690 IF (NWORD - 2) 620, 610, 630 610 IF (DATUM(2) .NE. 0.0) GO TO 650 620 TEXT(3) = BLANK GO TO 690 630 DO 640 J = 1, 14 IF (TEXT(3) .EQ. UTABLE(J)) GO TO 660 640 CONTINUE 650 WRITE (NOUT, 9650) FLUSH = .TRUE. GO TO 700 660 DATUM(4) = CTABLE(J) IF (DATUM(2) .GT. 6.0 .AND. J .LT. 6) DATUM(4) = 0.01*DATUM(4) IF (DATUM(2) .EQ. 7.0) DATUM(4) = DATUM(4)*RADIAN/1000.0 690 NWORD = LENGTH C C PRINT OUT C 700 RETURN C 9130 FORMAT (52H0SCANNING STOPS DUE TO ERROR AT POSITION SHOWN BELOW/ 1 11X,80A1/10X,81A1) 9350 FORMAT (33H0NEXT LABEL TRUNCATED TO 4 CHARS.) 9360 FORMAT (8H0LABEL ",A4,33H" ON NEXT ELEMENT WAS OVERWRITTEN) 9400 FORMAT (37H0NEXT COMMENT TRUNCATED TO 116 CHARS.) 9500 FORMAT (36H0NEXT ELEMENT IS HISTOGRAM - IGNORED) 9510 FORMAT (38H0NEXT ELEMENT IS ILLEGAL - RUN FLUSHED) 9560 FORMAT (39H0DATA LIST FOR NEXT ELEMENT IS TOO LONG) 9650 FORMAT (31H0ERROR ON FOLLOWING 15. ELEMENT) END SUBROUTINE RDFIX (IVALUE, IFLAG) C READ AN INTEGER COMMON /BLOC42/ TABLE(36), PLUS, MINUS, BLANK, PERIOD, SPEC(10) INTEGER TABLE, PLUS, MINUS, BLANK, PERIOD, SPEC INTEGER NUMBER(10) EQUIVALENCE (NUMBER(1),TABLE(1)) COMMON /BLOC43/ NCD, CARD(80), MC, EMPTY, ITEM, INDP INTEGER CARD LOGICAL EMPTY C IFLAG = - 1 IVAL = 0 IF (ITEM .EQ. MINUS) GO TO 10 ISIG = 1 IF (ITEM .NE. PLUS) GO TO 30 GO TO 20 10 ISIG = - 1 20 CALL RDNEXT (0) 30 DO 40 J = 1, 10 IF (ITEM .EQ. NUMBER(J)) GO TO 50 40 CONTINUE IVALUE = ISIGN (IVAL, ISIG) RETURN C 50 IVAL = 10 * IVAL + J - 1 IFLAG = 0 GO TO 20 END SUBROUTINE RDFLT (VALUE, IFLT, IFLAG) C READ A FLOATING-POINT NUMBER COMMON /BLOC42/ TABLE(36), PLUS, MINUS, BLANK, PERIOD, SPEC(10) INTEGER TABLE, PLUS, MINUS, BLANK, PERIOD, SPEC INTEGER DEE, EEH, NUMBER(10) EQUIVALENCE (DEE,TABLE(14)), (EEH,TABLE(15)), 1 (NUMBER(1),TABLE(1)) COMMON /BLOC43/ NCD, CARD(80), MC, EMPTY, ITEM, INDP INTEGER CARD LOGICAL EMPTY EQUIVALENCE (VAL,IVAL) C IFLAG = - 1 IFLT = 0 IVAL = 0 NPL = 0 JPL = 0 NEX = 0 JL = 0 IF (ITEM .EQ. MINUS) GO TO 10 ISIG = 1 SIG = 1.0 IF (ITEM .NE. PLUS) GO TO 30 GO TO 20 10 ISIG = - 1 SIG = - 1.0 20 CALL RDNEXT (0) 30 DO 40 J = 1, 10 IF (ITEM .EQ. NUMBER(J)) GO TO 50 40 CONTINUE IF (ITEM .NE. PERIOD) GO TO 70 IF (JPL .NE. 0) GO TO 60 IFLT = 1 JPL = 1 NPL = JL VAL = FLOAT(IVAL) GO TO 20 50 JL = JL + 1 IFLAG = 0 IF (JPL .GT. 0) GO TO 52 IVAL = IVAL*10 + J - 1 GO TO 20 C C IF NUS BEYOND DECIMAL POINT DIVIDE 52 VAL = VAL + FLOAT(J-1)*10.**(NPL-JL) GO TO 20 60 IFLAG = 1 GO TO 90 70 IF (ITEM .NE. DEE .AND. ITEM .NE. EEH) GO TO 80 CALL RDNEXT (0) CALL RDFIX (NEX, IFLAG) GO TO 90 80 IF (ITEM .EQ. PLUS .OR. ITEM .EQ. MINUS) CALL RDFIX (NEX, IFLAG) 90 IF (IFLT .NE. 0) GO TO 95 IVAL = ISIGN(IVAL,ISIG) VALUE = VAL RETURN C 95 VALUE = SIGN(VAL,SIG)*10.**(NEX) RETURN END SUBROUTINE RDNEXT (ISKIP) C READ NEXT CHARACTER, OPTIONNALY SKIPPING BLANKS COMMON /BLOC2/ NIN, NOUT, NPUNCH COMMON /BLOC42/ TABLE(36), PLUS, MINUS, BLANK, PERIOD, SPEC(10) INTEGER TABLE, PLUS, MINUS, BLANK, PERIOD, SPEC INTEGER ESS EQUIVALENCE (ESS,TABLE(29)) COMMON /BLOC43/ NCD, CARD(80), MC, EMPTY, ITEM, INDP INTEGER CARD LOGICAL EMPTY LOGICAL LAST DATA LAST /.FALSE./ C IF (LAST) STOP IF (ISKIP .LT. 0) GO TO 40 IF (ISKIP .GE. 2) GO TO 20 IF (EMPTY) GO TO 20 10 IF (MC .LT. 80) GO TO 30 IF (ISKIP .NE. 0) GO TO 20 EMPTY = .TRUE. ITEM = BLANK RETURN C 20 MC = 0 EMPTY = .FALSE. READ (NIN,100,END=50) CARD IF (INDP .GE. 20) WRITE (NOUT,1000) CARD NCD = NCD + 1 30 MC = MC + 1 ITEM = CARD(MC) IF (ISKIP .EQ. 0) RETURN 40 IF (ITEM .EQ. BLANK) GO TO 10 RETURN C 50 LAST = .TRUE. ITEM = ESS RETURN 100 FORMAT (80A1) 1000 FORMAT (1H ,80A1) END SUBROUTINE RDPACK(CHAR,TEXT,N) COMMON /BLOC42/ TABLE(36), PLUS, MINUS, BLANK, PERIOD, SPEC(10) INTEGER TABLE,PLUS,MINUS,BLANK,PERIOD,SPEC INTEGER CHAR(4),TEXT CHARACTER*4 TEKST C C SUBROUTINE WILL NOW DO AN INTERNAL READ AND CHANGE INTEGER C DATA TO CHARACTER DATA C IF (N .LE. 0) RETURN WRITE(TEKST ,10) (CHAR(J), J = 1,4) 10 FORMAT(4A1) READ(TEKST, 20) TEXT 20 FORMAT(A4) CHAR(1) = BLANK CHAR(2) = BLANK CHAR(3) = BLANK CHAR(4) = BLANK RETURN END SUBROUTINE RDSTRG (STRING, LMAX, L) C READ A CHARACTER STRING COMMON /BLOC42/ TABLE(36), PLUS, MINUS, BLANK, PERIOD, SPEC(10) INTEGER TABLE, PLUS, MINUS, BLANK, PERIOD, SPEC INTEGER QUOTE, APOST, EQUAL, SLASH, PARENO, PARENC EQUIVALENCE (QUOTE,SPEC(5)), (APOST,SPEC(6)), 1 (EQUAL,SPEC(7)), (SLASH,SPEC(8)), 2 (PARENO,SPEC(9)), (PARENC,SPEC(10)) COMMON /BLOC43/ NCD, CARD(80), MC, EMPTY, ITEM, INDP INTEGER CARD LOGICAL EMPTY INTEGER STRING(LMAX), CHAR(4) C DO 10 L = 1, LMAX 10 STRING(L) = BLANK L = - 1 IF (ITEM .EQ. QUOTE .OR. ITEM .EQ. APOST .OR. ITEM .EQ. EQUAL 1 .OR. ITEM .EQ. SLASH .OR. ITEM .EQ. PARENO) GO TO 30 RETURN C 30 ISTOP = ITEM IF (ITEM .EQ. PARENO) ISTOP = PARENC L = 0 ISKIP = 1 40 IC = 0 50 CALL RDNEXT (ISKIP) IF (ITEM .EQ. ISTOP) GO TO 60 ISKIP = 0 IF (ITEM .EQ. BLANK .OR. LMAX .EQ. 1) ISKIP = 1 IC = IC + 1 CHAR(IC) = ITEM IF (IC - 4) 50, 70, 70 60 IF (IC .EQ. 0) RETURN 70 L = L + 1 IF (L .LE. LMAX) CALL RDPACK (CHAR, STRING(L), IC) IF (ITEM .NE. ISTOP) GO TO 40 RETURN END SUBROUTINE RECALL COMMON /BLOC1/ NEL, NUM, NDIF, I, ISTOR(3129), DATA(13160) COMMON /BLOC4/ LC, TOTANG, TOTROT, LCV(20), LUP(3) REAL LC, LCV, LUP COMMON /BLOC11/ R(6,6), RV(6,6), T(5,21), TV(5,21), U(5,56), 1 UV(5,56) DIMENSION RL(36), RVL(36), TL(105), TVL(105), UL(280), 1 UVL(280) EQUIVALENCE (R(1,1),RL(1)), (RV(1,1),RVL(1)), 1 (T(1,1),TL(1)), (TV(1,1),TVL(1)), 2 (U(1,1),UL(1)), (UV(1,1),UVL(1)) COMMON /BLOC12/ RC(6,6), RCV(6,6,20), TC(5,21), UC(5,56), RCP, 1 RVP(20) LOGICAL RCP, RVP DIMENSION RCL(36) EQUIVALENCE (RC(1,1),RCL(1)) COMMON /BLOC13/ RC2(6,6), R2V(6,6,20), TC2(5,21), T2V(5,21,10), 1 UC2(5,56), U2V(5,56,10), R2P, R2VP(20) LOGICAL R2P, R2VP DIMENSION RC2L(36), TC2L(105), UC2L(280) EQUIVALENCE (RC2(1,1),RC2L(1)), (TC2(1,1),TC2L(1)), 1 (UC2(1,1),UC2L(1)) COMMON /BLOC14/ RC3(6,6), TC3(5,21), UC3(5,56), R3P LOGICAL R3P COMMON /BLOC16/ SI(6,6), SV(6,6,20), CO(6), COV(6,20), RI, 1 SVP(20), CVP(20), SOFA LOGICAL SVP, CVP, SOFA COMMON /BLOC17/ COD(6), COF(6), PSIX, PSIY, PSIX1, PSIY1, NOPH LOGICAL NOPH COMMON /BLOC18/ SIT(6,6), CEN(6), RECENT LOGICAL RECENT COMMON /BLOC20/ ETA(6), DETA(6,20), RAY, EVP(20) LOGICAL RAY, EVP COMMON /BLOC21/ EN, ES, BE, APB(2), LAYK, LAYL, LAYX, RABT REAL LAYK, LAYL, LAYX COMMON /BLOC26/ O(4,3,3), X0(4,3), IR, RORC, TYT, ALIGN, TMK, 1 FEO, CHORD INTEGER RORC, TYT LOGICAL ALIGN, TMK, FEO, CHORD COMMON /BLOC27/ CT(6,6), CT0(6,6), CT1(3,3), X0L(3), VM(6), 1 VMT(6), COM(6,6,10), OR(3,3), XR(3), LMIS(2,10), 2 DMC, NM LOGICAL DMC REAL LMIS COMMON /BLOC28/ COC, DE0, SD, CTY, JV, NC, NV1, NV2, NV3 INTEGER CTY COMMON /BLOC30/ CDB, NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, 1 LCPR, ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, 2 LAY191, NPFR INTEGER CDB LOGICAL NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, LCPR, 1 ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, LAY191 COMMON /BLOC33/ FOTILT, SM, TH, PREF COMMON /BLOC34/ NORD1, NORD2, NORD3, NORDX, LINEAR, JH, SIG LOGICAL LINEAR COMMON /BLOC36/ VARS(8), SEXMAX, SEXLIM INTEGER VARS LOGICAL SEXLIM COMMON /BLOC38/ SIOL(3,6,6), COLD(3,6), RCO(3,6,6), R2O(6,6), 1 SPO(3), RCPO(3), R2PO LOGICAL SPO, RCPO, R2PO COMMON /BLOC40/ OV(3,3,20), X0V(3,20), OIV(3,3), XIV(3), OVP(20) LOGICAL OVP COMMON /BLOC44/ REG(20), DREG(20,20), LREG(20) LOGICAL LREG COMMON /BLOC47/ IC(4), IS(4), IP, NNDS, NDLEV COMMON /BLOC49/ PRAN2, PRAN3, PRAN4(3), PRAN5(3), PRAN7(6), 1 PRAN11(4), PRAN16(30), PRAN18(3), PRAN19(2), 2 PRAN20, PRAN25(3) COMMON /BLOC50/ BDBI, LAYKI, LAYLI, LAYXI, RAB1I, RAB2I, RMPSI, 1 VRNI, NPNI, BDBPI, RNMSI REAL LAYKI, LAYLI, LAYXI, NPNI COMMON /BLC101/ NUMS, NDIFS COMMON /BLC104/ LCS, TOTRTS REAL LCS COMMON /BLC111/ RSS(6,6), TSS(5,21) DIMENSION RSSL(36), TSSL(105) EQUIVALENCE (RSS(1,1),RSSL(1)), (TSS(1,1),TSSL(1)) COMMON /BLC112/ RCS(6,6), RCPS LOGICAL RCPS DIMENSION RCSL(36) EQUIVALENCE (RCS(1,1),RCSL(1)) COMMON /BLC113/ RC2S(6,6), TC2S(5,21), UC2S(5,56), R2PS LOGICAL R2PS DIMENSION RC2SL(36), TC2SL(105), UC2SL(280) EQUIVALENCE (RC2S(1,1),RC2SL(1)), (TC2S(1,1),TC2SL(1)), 1 (UC2S(1,1),UC2SL(1)) COMMON /BLC116/ SIS(6,6), COS(6), RIS, SOFAS LOGICAL SOFAS COMMON /BLC117/ COFS(6) COMMON /BLC120/ ETAS(6), RAYS LOGICAL RAYS COMMON /BLC121/ APBS(2) COMMON /BLC126/ OS(4,3,3), X0S(4,3), RORCS INTEGER RORCS COMMON /BLC127/ VMS(6) COMMON /BLC130/ LAYS, R1PS, ANINS, HTGQS, NPFRS LOGICAL LAYS, R1PS, ANINS, HTGQS COMMON /BLC133/ FOTLTS, SMS COMMON /BLC134/ JHS, SIGS COMMON /BLC138/ SIOLS(3,6,6), COLDS(3,6), RCOS(3,6,6), R2OS(6,6), 1 SPOS(3), RCPOS(3), R2POS LOGICAL SPOS, RCPOS, R2POS COMMON /BLC144/ REGS(20), LREGS(20) LOGICAL LREGS COMMON /BLC147/ ICS(4), ISS(4), IPS, NNDSS, NDLEVS COMMON /BLC149/ PRAN2S, PRAN3S, PRAN4S(3), PRAN5S(3), PRAN7S(6), 1 PRN11S(4), PRN16S(30), PRN18S(3), PRN19S(2), 2 PRN20S, PRN25S(3) COMMON /BLC150/ BDBIS, LAYKIS, LAYLIS, LAYXIS, RAB1IS, RAB2IS, 1 RMPSIS, VRNIS, NPNIS, BDBPIS, RNMSIS REAL LAYKIS, LAYLIS, LAYXIS, NPNIS COMMON /SEEDS/ ISEEDS 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 DO 10 J = 1, 36 RL(J) = RSSL(J) RCL(J) = RCSL(J) 10 RC2L(J) = RC2SL(J) RCP = RCPS IF (NORD1 .EQ. 1) GO TO 50 DO 20 J = 1, 105 TL(J) = TSSL(J) 20 TC2L(J) = TC2SL(J) IF (NORD1 .LE. 2) GO TO 50 DO 30 J = 1, 280 30 UC2L(J) = UC2SL(J) 50 R2P = R2PS R3P = .FALSE. 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) = COS(J) RI = RIS 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 C APB(1) = APBS(1) APB(2) = APBS(2) 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 ANIN = ANINS HTGQ = HTGQS NPFR = NPFRS FOTILT = FOTLTS SM = SMS JH = JHS SIG = SIGS 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 DO 260 J = 1, 20 REG(J) = REGS(J) 260 LREG(J) = LREG(J) IP = IPS IF (IP .EQ. 0) GO TO 270 DO 265 IPP = 1, IP IC(IPP) = ICS(IPP) 265 IS(IPP) = ISS(IPP) 270 NNDS = NNDSS NDLEV = NDLEVS C PRAN2 = PRAN2S PRAN3 = PRAN3S DO 310 J = 1, 3 310 PRAN4(J) = PRAN4S(J) DO 320 J = 1, 3 320 PRAN5(J) = PRAN5S(J) DO 330 J = 1, 6 330 PRAN7(J) = PRAN7S(J) DO 335 J = 1, 4 335 PRAN11(J) = PRN11S(J) DO 340 J = 1, 16 340 PRAN16(J) = PRN16S(J) DO 350 J = 1, 3 350 PRAN18(J) = PRN18S(J) DO 360 J = 1, 2 360 PRAN19(J) = PRN19S(J) PRAN20 = PRN20S DO 370 J = 1, 3 370 PRAN25(J) = PRN25S(J) C BDBI = BDBIS LAYKI = LAYKIS LAYLI = LAYLIS LAYXI = LAYXIS RAB1I = RAB1IS RAB2I = RAB2IS RMPSI = RMPSIS VRNI = VRNIS NPNI = NPNIS BDBPI = BDBPIS RNMSI = RNMSIS C CALL RANSET(ISEEDS) RETURN END SUBROUTINE REPEAT COMMON /BLOC1/ NEL, NUM, NDIF, I, ISTOR(3129), DATA(13160) COMMON /BLOC3/ TYPE, L, LV INTEGER TYPE REAL L, LV COMMON /BLOC47/ IC(4), IS(4), IP, NNDS, NDLEV C 10 NREP = DATA(I+1) IF ((NREP .EQ. 0 .AND. NDIF .EQ. 1) .OR. 1 (NREP .GT. 0 .AND. NDIF .EQ. -1)) GO TO 20 IP = IP + 1 IF (NDIF .EQ. 1) IC(IP) = NREP IF (NDIF .EQ. -1) IC(IP) = 0 IS(IP) = NUM GO TO 40 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 40 RETURN END SUBROUTINE RESET(I) COMMON /BLOC26/ O(4,3,3), X0(4,3), IR, RORC, TYT, ALIGN, TMK, 1 FEO, CHORD DIMENSION OL(36), X0L(12) EQUIVALENCE (O(1,1,1),OL(1)), (X0(1,1),X0L(1)) INTEGER RORC, TYT LOGICAL ALIGN, TMK, FEO, CHORD 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 RETURN END SUBROUTINE RETAIN COMMON /BLOC1/ NEL, NUM, NDIF, I, ISTOR(3129), DATA(13160) COMMON /BLOC4/ LC, TOTANG, TOTROT, LCV(20), LUP(3) REAL LC, LCV, LUP COMMON /BLOC11/ R(6,6), RV(6,6), T(5,21), TV(5,21), U(5,56), 1 UV(5,56) DIMENSION RL(36), RVL(36), TL(105), TVL(105), UL(280), 1 UVL(280) EQUIVALENCE (R(1,1),RL(1)), (RV(1,1),RVL(1)), 1 (T(1,1),TL(1)), (TV(1,1),TVL(1)), 2 (U(1,1),UL(1)), (UV(1,1),UVL(1)) COMMON /BLOC12/ RC(6,6), RCV(6,6,20), TC(5,21), UC(5,56), RCP, 1 RVP(20) LOGICAL RCP, RVP DIMENSION RCL(36) EQUIVALENCE (RC(1,1),RCL(1)) COMMON /BLOC13/ RC2(6,6), R2V(6,6,20), TC2(5,21), T2V(5,21,10), 1 UC2(5,56), U2V(5,56,10), R2P, R2VP(20) LOGICAL R2P, R2VP DIMENSION RC2L(36), TC2L(105), UC2L(280) EQUIVALENCE (RC2(1,1),RC2L(1)), (TC2(1,1),TC2L(1)), 1 (UC2(1,1),UC2L(1)) COMMON /BLOC16/ SI(6,6), SV(6,6,20), CO(6), COV(6,20), RI, 1 SVP(20), CVP(20), SOFA LOGICAL SVP, CVP, SOFA COMMON /BLOC17/ COD(6), COF(6), PSIX, PSIY, PSIX1, PSIY1, NOPH LOGICAL NOPH COMMON /BLOC20/ ETA(6), DETA(6,20), RAY, EVP(20) LOGICAL RAY, EVP COMMON /BLOC21/ EN, ES, BE, APB(2), LAYK, LAYL, LAYX, RABT REAL LAYK, LAYL, LAYX COMMON /BLOC26/ O(4,3,3), X0(4,3), IR, RORC, TYT, ALIGN, TMK, 1 FEO, CHORD INTEGER RORC, TYT LOGICAL ALIGN, TMK, FEO, CHORD COMMON /BLOC27/ CT(6,6), CT0(6,6), CT1(3,3), X0L(3), VM(6), 1 VMT(6), COM(6,6,10), OR(3,3), XR(3), LMIS(2,10), 2 DMC, NM LOGICAL DMC REAL LMIS COMMON /BLOC30/ CDB, NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, 1 LCPR, ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, 2 LAY191, NPFR INTEGER CDB LOGICAL NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, LCPR, 1 ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, LAY191 COMMON /BLOC33/ FOTILT, SM, TH, PREF COMMON /BLOC34/ NORD1, NORD2, NORD3, NORDX, LINEAR, JH, SIG LOGICAL LINEAR COMMON /BLOC38/ SIOL(3,6,6), COLD(3,6), RCO(3,6,6), R2O(6,6), 1 SPO(3), RCPO(3), R2PO LOGICAL SPO, RCPO, R2PO COMMON /BLOC44/ REG(20), DREG(20,20), LREG(20) LOGICAL LREG COMMON /BLOC47/ IC(4), IS(4), IP, NNDS, NDLEV COMMON /BLOC49/ PRAN2, PRAN3, PRAN4(3), PRAN5(3), PRAN7(6), 1 PRAN11(4), PRAN16(30), PRAN18(3), PRAN19(2), 2 PRAN20, PRAN25(3) COMMON /BLOC50/ BDBI, LAYKI, LAYLI, LAYXI, RAB1I, RAB2I, RMPSI, 1 VRNI, NPNI, BDBPI, RNMSI REAL LAYKI, LAYLI, LAYXI, NPNI COMMON /BLC101/ NUMS, NDIFS COMMON /BLC104/ LCS, TOTRTS REAL LCS COMMON /BLC111/ RSS(6,6), TSS(5,21) DIMENSION RSSL(36), TSSL(105) EQUIVALENCE (RSS(1,1),RSSL(1)), (TSS(1,1),TSSL(1)) COMMON /BLC112/ RCS(6,6), RCPS LOGICAL RCPS DIMENSION RCSL(36) EQUIVALENCE (RCS(1,1),RCSL(1)) COMMON /BLC113/ RC2S(6,6), TC2S(5,21), UC2S(5,56), R2PS LOGICAL R2PS DIMENSION RC2SL(36), TC2SL(105), UC2SL(280) EQUIVALENCE (RC2S(1,1),RC2SL(1)), (TC2S(1,1),TC2SL(1)), 1 (UC2S(1,1),UC2SL(1)) COMMON /BLC116/ SIS(6,6), COS(6), RIS, SOFAS LOGICAL SOFAS COMMON /BLC117/ COFS(6) COMMON /BLC120/ ETAS(6), RAYS LOGICAL RAYS COMMON /BLC121/ APBS(2) COMMON /BLC126/ OS(4,3,3), X0S(4,3), RORCS INTEGER RORCS COMMON /BLC127/ VMS(6) COMMON /BLC130/ LAYS, R1PS, ANINS, HTGQS, NPFRS LOGICAL LAYS, R1PS, ANINS, HTGQS COMMON /BLC133/ FOTLTS, SMS COMMON /BLC134/ JHS, SIGS COMMON /BLC138/ SIOLS(3,6,6), COLDS(3,6), RCOS(3,6,6), R2OS(6,6), 1 SPOS(3), RCPOS(3), R2POS LOGICAL SPOS, RCPOS, R2POS COMMON /BLC144/ REGS(20), LREGS(20) LOGICAL LREGS COMMON /BLC147/ ICS(4), ISS(4), IPS, NNDSS, NDLEVS COMMON /BLC149/ PRAN2S, PRAN3S, PRAN4S(3), PRAN5S(3), PRAN7S(6), 1 PRN11S(4), PRN16S(30), PRN18S(3), PRN19S(2), 2 PRN20S, PRN25S(3) COMMON /BLC150/ BDBIS, LAYKIS, LAYLIS, LAYXIS, RAB1IS, RAB2IS, 1 RMPSIS, VRNIS, NPNIS, BDBPIS, RNMSIS REAL LAYKIS, LAYLIS, LAYXIS, NPNIS COMMON /SEEDS/ ISEEDS C NUMS = NUM NDIFS = NDIF LCS = LC TOTRTS = TOTROT DO 10 J = 1, 36 RSSL(J) = RL(J) RCSL(J) = RCL(J) 10 RC2SL(J) = RC2L(J) RCPS = RCP IF (NORD1 .EQ. 1) GO TO 50 DO 20 J = 1, 105 TSSL(J) = TL(J) 20 TC2SL(J) = TC2L(J) IF (NORD1 .LE. 2) GO TO 50 DO 30 J = 1, 280 30 UC2SL(J) = UC2L(J) 50 R2PS = R2P C DO 110 J = 1, 6 DO 110 K = 1, 6 110 SIS(J,K) = SI(J,K) DO 120 J = 1, 6 120 COS(J) = CO(J) RIS = RI SOFAS = SOFA DO 130 J = 1, 6 130 COFS(J) = COF(J) DO 135 J = 1, 6 135 ETAS(J) = ETA(J) RAYS = RAY C APBS(1) = APB(1) APBS(2) = APB(2) 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 ANINS = ANIN HTGQS = HTGQ NPFRS = NPFR FOTLTS = FOTILT SMS = SM JHS = JH SIGS = SIG 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 DO 260 J = 1, 20 REGS(J) = REG(J) 260 LREGS(J) = LREG(J) IPS = IP IF (IPS .EQ. 0) GO TO 270 DO 265 IPP = 1, IPS ICS(IPP) = IC(IPP) 265 ISS(IPP) = IS(IPP) 270 NNDSS = NNDS NDLEVS = NDLEV C PRAN2S = PRAN2 PRAN3S = PRAN3 DO 310 J = 1, 3 310 PRAN4S(J) = PRAN4(J) DO 320 J = 1, 3 320 PRAN5S(J) = PRAN5(J) DO 330 J = 1, 6 330 PRAN7S(J) = PRAN7(J) DO 335 J = 1, 4 335 PRN11S(J) = PRAN11(J) DO 340 J = 1, 16 340 PRN16S(J) = PRAN16(J) DO 350 J = 1, 3 350 PRN18S(J) = PRAN18(J) DO 360 J = 1, 2 360 PRN19S(J) = PRAN19(J) PRN20S = PRAN20 DO 370 J = 1, 3 370 PRN25S(J) = PRAN25(J) C BDBIS = BDBI LAYKIS = LAYKI LAYLIS = LAYLI LAYXIS = LAYXI RAB1IS = RAB1I RAB2IS = RAB2I RMPSIS = RMPSI VRNIS = VRNI NPNIS = NPNI BDBPIS = BDBPI RNMSIS = RNMSI C CALL RANGET(ISEEDS) RETURN END SUBROUTINE SECORD COMMON /BLOC1/ NEL, NUM, NDIF, I, ISTOR(3129), DATA(13160) COMMON /BLOC3/ TYPE, L, LV INTEGER TYPE REAL L, LV COMMON /BLOC5/ VSTOR(20), TIE(13160), LABEL(3129), LABM(10) INTEGER VSTOR, TIE COMMON /BLOC11/ R(6,6), RV(6,6), T(5,21), TV(5,21), U(5,56), 1 UV(5,56) DIMENSION RL(36), RVL(36), TL(105), TVL(105), UL(280), 1 UVL(280) EQUIVALENCE (R(1,1),RL(1)), (RV(1,1),RVL(1)), 1 (T(1,1),TL(1)), (TV(1,1),TVL(1)), 2 (U(1,1),UL(1)), (UV(1,1),UVL(1)) COMMON /BLOC16/ SI(6,6), SV(6,6,20), CO(6), COV(6,20), RI, 1 SVP(20), CVP(20), SOFA LOGICAL SVP, CVP, SOFA COMMON /BLOC21/ EN, ES, BE, APB(2), LAYK, LAYL, LAYX, RABT REAL LAYK, LAYL, LAYX COMMON /BLOC22/ LBEND, BE1, SB, TB, TB1, NBVARY, BEFORE LOGICAL BEFORE REAL LBEND COMMON /BLOC23/ H0, AL, NB, BDB, RMPS, VRN, NPN, BDBP, RNMS, DCOV LOGICAL DCOV REAL NB, NPN COMMON /BLOC24/ B, KQ2, KVK, K2H, K2V, CS, SN, DISN, DSVN, J REAL KQ2, KVK, K2H, K2V COMMON /BLOC25/ AP, CAP, JA LOGICAL CAP COMMON /BLOC30/ CDB, NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, 1 LCPR, ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, 2 LAY191, NPFR INTEGER CDB LOGICAL NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, LCPR, 1 ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, LAY191 COMMON /BLOC31/ J1, TYP1 INTEGER TYP1 COMMON /BLOC32/ UNIT(12), XDIME(12) COMMON /BLOC33/ FOTILT, SM, TH, PREF COMMON /BLOC34/ NORD1, NORD2, NORD3, NORDX, LINEAR, JH, SIG LOGICAL LINEAR COMMON /BLOC35/ KL, KO REAL KL, KO COMMON /BLOC36/ VARS(8), SEXMAX, SEXLIM INTEGER VARS, VARSP LOGICAL SEXLIM COMMON /BLOC45/ CSH, SOKH, SKH, DISP, DDISP, CSV, SOKV, SKV COMMON /BLOC49/ PRAN2, PRAN3, PRAN4(3), PRAN5(3), PRAN7(6), 1 PRAN11(4), PRAN16(30), PRAN18(3), PRAN19(2), 2 PRAN20, PRAN25(3) COMMON /BLOC50/ BDBI, LAYKI, LAYLI, LAYXI, RAB1I, RAB2I, RMPSI, 1 VRNI, NPNI, BDBPI, RNMSI REAL LAYKI, LAYLI, LAYXI, NPNI COMMON /CONSTS/ PI, RADIAN, CLIGHT, EMASS COMMON /HSINT/ HSCX, HSSX, HSCY, HSSY, HSLCY, HSLSY, 1 HSGLP, HSCX2, HSCSX, HSCCM, HSCSM, HSSX2, HSSCM, HSSSM, 2 HSCY2, HSCSY, HSSY2, HSCDX, HSSDX, HSDCM, HSCDY, HSDSM, 3 HSSDY, HSDX2 COMMON /HPINT/ HPCX, HPSX, HPCY, HPSY, HPLCY, HPLSY, 1 HPGLP, HPCX2, HPCSX, HPCCM, HPCSM, HPSX2, HPSCM, HPSSM, 2 HPCY2, HPCSY, HPSY2, HPCDX, HPSDX, HPDCM, HPCDY, HPDSM, 3 HPSDY, HPDX2 COMMON /VSINT/ VSCX, VSSX, VSDX, VSCY, VSSY, VSDY, VSLCX, 1 VSLSX, VSCX2, VSCSX, VSCCM, VSCSM, VSSX2, VSSCM, VSSSM, 2 VSCY2, VSCSY, VSSY2, VSCDX, VSCDM, VSSDX, VSSDM, VSDCM, 3 VSDSM, VSDX2, VSDDM COMMON /VPINT/ VPCX, VPSX, VPDX, VPCY, VPSY, VPDY, VPLCX, 1 VPLSX, VPCX2, VPCSX, VPCCM, VPCSM, VPSX2, VPSCM, VPSSM, 2 VPCY2, VPCSY, VPSY2, VPCDX, VPCDM, VPSDX, VPSDM, VPDCM, 3 VPDSM, VPDX2, VPDDM REAL NBR, NMB, NNM2, NPR, NPMV C JU = 4 - JH IF (JH .EQ. 1) JD = 0 IF (JH .EQ. 3) JD = 1 IF (TYPE .EQ. 14 .AND. TYP1 .EQ. 14) GO TO 1400 DO 11 IA = 1, 105 11 TL(IA) = 0.0 GO TO (5100,200,300,400,500,5200,5200,5200,5200,5200, 1 5200,5200,5200,1400,5200,5200,5200,1800,1900,5200, 2 5200,5200,5200,5200,5100,5200,5200), TYPE C C 2. -- POLE FACE ROTATION C 200 TB2 = TB**2 SB2 = SB**2 SB3 = SB2* SB IF (BEFORE) GO TO 212 RABT = RAB2I IF (PRAN16(13) .NE. 0.0) 1 RABT = RABT + PRAN16(13)*RANDIS(-1) GO TO 213 212 RABT = RAB1I IF (PRAN16(12) .NE. 0.0) 1 RABT = RABT + PRAN16(12)*RANDIS(-1) 213 RABT = RABT/UNIT(8) T(JH+1,JH+15) = - H0*TB T(JU+1,JU+15) = H0*TB T(JH,1+5*JD) = - 0.5*SIG*ES*H0*TB2 T(JH,6-5*JD) = 0.5*SIG*ES*H0*SB2 T(JH+1,1+5*JD) = SIG*(0.5*H0*RABT*SB3 1 - TB*(NB + 0.5*(1.0 - EN)*TB2)*H0**2) T(JH+1,2+7*JD) = SIG*H0*ES*TB2 T(JH+1,6-5*JD) = SIG*(H0**2*TB*(NB + EN*(0.5 + TB2) 1 - 0.5*(1.0 - EN)*TB2) - 0.5*H0*RABT*SB3) T(JH+1,9-7*JD) = - SIG*H0*ES*TB2 T(JU,4) = SIG*H0*ES*TB2 T(JU+1,4) = SIG*( - H0*RABT*SB3 1 + H0**2*TB*(2.0*NB + (1.0 - EN)*SB2)) T(JU+1,4+JU) = - SIG*H0*ES*TB2 T(JU+1,4+JH) = - SIG*H0*ES*SB2 GO TO 5100 C C 3. -- DRIFT SPACE C 300 TANFO = SIG*TAN(FOTILT/RADIAN) T(JU,4+JU) = TANFO T(JH,2+7*JD) = 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 BDB = BDBI IF (PRAN16(1) .NE. 0.0) 1 BDB = BDB + PRAN16(1)*RANDIS(-1) BEB = BDB/(H0*UNIT(1))**2 RH = 1.0 + RMPS H = H0*RH HEX = RMPS*H0 WMN = 1.0 - NB + RMPS*(2.0 - NB) WM5N = 1.0 - 5.0*NB + RMPS*(2.0 - 5.0*NB) TNMB = 2.0*NB - BEB - 1.0 NMB = NB - BEB TBMN = 2.0*BEB - NB TMN = 2.0 - NB C HSCX = 0.5*L*SOKH HSSX = 0.5*(SOKH - L*CSH)/WMN HSDX = RH*(DISN - 0.5*L*SOKH)/WMN HSCX2 = (DISN + SOKH**2)/3.0 HSCSX = SOKH*DISN/3.0 HSSX2 = (2.0*DISN - SOKH**2)/(3.0*WMN) HSCY2 = 0.5*DISN*(1.0 + WMN/WM5N) - RH*NB*SOKV**2/WM5N HSCSY = (CSV*SOKV - SOKH)/WM5N HSSY2 = ( - 2*DISN + SOKV**2)/WM5N HSCDX = RH*( - (DISN + SOKH**2)/3.0 + 0.5*L*SOKH)/WMN HSSDX = RH*(SOKH + 2.0*SOKH*CSH - 3*L*CSH)/(6.0*WMN**2) HSDX2 = RH**2*(4.0*DISN - 3.0*L*SOKH + SOKH**2)/(3.0*WMN**2) HPCX = 0.5*(SOKH + L*CSH) HPSX = 0.5*L*SOKH HPDX = 0.5*RH*(SOKH - L*CSH)/WMN HPCX2 = SOKH*(1.0 + 2.0*CSH)/3.0 HPCSX = ( - DISN + 2.0*SOKH**2)/3.0 HPSX2 = 2.0*SOKH*DISN/3.0 HPCY2 = 0.5*SOKH*(1.0 + WMN/WM5N) - 2.0*RH*NB*CSV*SOKV/WM5N HPCSY = (WMN*DISN - 2.0*NB*SOKV**2)/WM5N HPSY2 = 2.0*(CSV*SOKV - SOKH)/WM5N HPCDX = RH*(3.0*L*CSH - 4.0*CSH*SOKH + SOKH)/(6.0*WMN) HPSDX = RH*(2.0*DISN + 3.0*L*SOKH - 4.0*SOKH**2)/(6.0*WMN) HPDX2 = RH**2*(2.0*CSH*SOKH + SOKH - 3.0*L*CSH)/(3.0*WMN**2) VSCY = 0.5*SOKV*L IF (NB .NE. 0.0) QUACK = (SOKV - L*CSV)/NB IF (NB .EQ. 0.0) QUACK = H0*H*L**3/3.0 VSSY = 0.5*QUACK/RH VSCCM = 0.5*(1.0 - WMN/WM5N)*SOKH*SOKV + WMN*CSV*DISN/WM5N VSCSM = (2.0*SOKH*CSV - SOKV*(1.0 + CSH))/WM5N VSSCM = 0.5*SOKV*(1.0 - CSH)/WMN 1 + 0.5*SOKV*(1.0 + CSH)/WM5N - SOKH*CSV/WM5N VSSSM = (2.0*CSV*DISN - SOKH*SOKV)/WM5N VSDCM = RH*( - CSV*DISN/WM5N + 0.5*L*SOKV/WMN 1 + 0.5*(1.0/WM5N - 1.0/WMN)*SOKH*SOKV) VSDSM = (RH*SOKV*(1.0 + CSH)/WM5N 1 - 2.0*RH*SOKH*CSV/WM5N + 0.5*QUACK)/WMN VPCY = 0.5*(SOKV + L*CSV) VPSY = 0.5*L*SOKV VPCCM = 0.5*(1.0 + WMN/WM5N)*SOKH*CSV 1 - RH*NB*SOKV*(1.0 + CSH)/WM5N VPCSM = 0.5*(1.0 + WMN/WM5N)*SOKH*SOKV 1 - WMN*CSV*DISN/WM5N VPSCM = 0.5*(1.0 + WMN/WM5N)*CSV*DISN 1 - RH*NB*SOKH*SOKV/WM5N VPSSM = 0.5*SOKV*((1.0 - CSH)/WMN - (1.0 + CSH)/WM5N) 1 + SOKH*CSV/WM5N VPDCM = RH*(RH*NB*SOKV*(1.0 + CSH)/(WMN*WM5N) 1 + 0.5*(SOKV + L*CSV)/WMN 2 - 0.5*(1.0/WMN + 1.0/WM5N)*SOKH*CSV) VPDSM = RH*(CSV*DISN/WM5N + 0.5*SOKV*L/WMN 1 - 0.5*(1.0/WMN + 1.0/WM5N)*SOKH*SOKV) C T(JH,1+5*JD) = SIG*H0**2*(TNMB*H*HSCX2 1 + 0.5*WMN**2*(H0 - HEX)*HSSX2) T(JH,2+7*JD) = SIG*H0*(H0*(2.0*H*TNMB - WMN*(H0 - HEX))*HSCSX 1 + SOKH) T(JH,3+7*JD) = SIG*(TNMB*H*HSSX2 1 + 0.5*(H0 - HEX)*HSCX2) T(JH,6-5*JD) = 0.5*SIG*H0**2*H*(TBMN*HSCY2 1 - NB**2*RH**2*HSSY2) T(JH,9-7*JD) = SIG*H*(TBMN + NB*RH)*HSCSY T(JH,10-7*JD) = 0.5*SIG*H*(TBMN*HSSY2 - HSCY2) T(JH,JH+15) = H*(2.0*TNMB*H0*HSCDX + TMN*H0*HSCX 1 - WMN*(H0 - HEX)*HSSX2) T(JH,JH+16) = RH*(2.0*TNMB*HSSDX + TMN*HSSX 1 + H0*(H0 - HEX)*HSCSX) T(JH,21) = SIG*RH*(TNMB*H0*HSDX2 + H0*TMN*HSDX 1 - H0*DISN + 0.5*RH*(H0 - HEX)*HSSX2) T(JH+1,1+5*JD) = SIG*H0**2*(TNMB*H*HPCX2 1 + 0.5*WMN**2*H0**2*(H0 - HEX)*HPSX2 + WMN*H0*SOKH*CSH) T(JH+1,2+7*JD) = SIG*H0**2*((2.0*H*TNMB - WMN*(H0 - HEX))*HPCSX 1 + WMN*H0*(2.0*SOKH**2 - DISN)) T(JH+1,3+7*JD) = SIG*(TNMB*H0**2*H*HPSX2 1 + 0.5*(H0 - HEX)*HPCX2 - H0*SOKH*CSH) T(JH+1,6-5*JD) = 0.5*SIG*H0**2*H*(TBMN*HPCY2 1 - NB**2*RH**2*HPSY2) T(JH+1,9-7*JD) = SIG*H*H0*(TBMN*H0 + NB*H)*HPCSY T(JH+1,10-7*JD) = 0.5*SIG*H*(TBMN*HPSY2 - HPCY2) T(JH+1,JH+15) = H0*H*(2.0*TNMB*HPCDX + TMN*HPCX 1 - WMN*H0*(H0 - HEX)*HPSX2 + WMN*H0**2*SOKH*DISN - SOKH*CSH) T(JH+1,JH+16) = H*(2.0*TNMB*H0*HPSDX + TMN*H0*HPSX 1 + (H0 - HEX)*HPCSX - H0*CSH*DISN - H0*SOKH**2) T(JH+1,21) = SIG*H*(TNMB*HPDX2 + TMN*HPDX 1 - SOKH + 0.5*H*(H0 - HEX)*HPSX2 - H0*H*SOKH*DISN) T(JU,4) = SIG*H*H0**2*(NB*WMN*VSSSM - 2.0*NMB*VSCCM) T(JU,JH+4) = - SIG*H*(NB*VSCSM + 2.0*NMB*VSSCM) T(JU,JU+4) = - SIG*(WMN*H0*VSSCM + 2.0*NMB*H*VSCSM - H0*SOKV) T(JU,8) = SIG*(H0*VSCCM - 2.0*NMB*H*VSSSM) T(JU,JU+15) = H*H0*(NB*VSCY - RH*NB*VSSSM 1 - 2.0*NMB*VSDCM) T(JU,JU+16) = RH*(NB*VSSY + VSSCM - 2.0*NMB*VSDSM) T(JU+1,4) = SIG*H*H0**2*(NB*WMN*VPSSM - 2.0*NMB*VPCCM 1 + NB*CSH*SOKV) T(JU+1,JH+4) = - SIG*H*H0**2*(NB*VPCSM + 2.0*NMB*VPSCM 1 - NB*SOKH*SOKV) T(JU+1,JU+4) = - SIG*H0**2*(WMN*H0*VPSCM + 2.0*NMB*H*VPCSM 1 - WMN*H0*CSV*DISN) T(JU+1,8) = SIG*(H0*VPCCM - 2.0*NMB*H*VPSSM - H0*SOKH*CSV) T(JU+1,JU+15) = H*(NB*H0*VPCY - NB*H*VPSSM 1 - 2.0*NMB*H0*VPDCM + NB*H0**2*SOKV*DISP) T(JU+1,JU+16) = H0*H*(NB*VPSY + VPSCM - 2.0*NMB*VPDSM 1 - CSV*DISN) FMTB = 5.0*NB - 2.0*BEB - 3.0 NNM2 = NB*(NB + 1.0) - 2.0*BEB TNSM = 3.0*NB**2 - 2.0*NB - 4.0*BEB + 3.0 TNTM = NB*(3.0*NB - 1.0) - 2.0*BEB GI2 = SM**2/(SM**2 + RI**2) T(5,1+5*JD) = - (TNTM*(L - SOKH*CSH) 1 + 4.0*NMB*(L - SOKH))*H0**2/(12.0*WMN) T(5,2+7*JD) = - 2.0*NMB*(1.0 - CSH)/(3.0*WMN**2) 1 + TNTM*H0**2*SOKH**2/(6.0*WMN) T(5,3+7*JD) = - (2.0*(FMTB + 2.0*NMB)*(L - SOKH) 1 - FMTB*(L - SOKH*CSH))/(12.0*WMN**2) - 0.25*(L + SOKH*CSH) T(5,JH+15) = SIG*( - NNM2*H0*(SOKH - L*CSH)/(2.0*WMN**2) 1 + 2.0*NMB*H0*(L - SOKH)/(3.0*WMN**2) 2 + TNTM*H0*(L - SOKH*CSH)/(6.0*WMN**2) + GI2*DDISP) T(5,JH+16) = SIG*(- TNSM*H0*DISN/(3.0*WMN**2) 1 + (NNM2*H0*L*SOKH/2.0 - TNTM*H0*SOKH**2/6.0)/WMN**2 + GI2*DISP) T(5,21) = - (4.0*NMB*(L - SOKH)/3.0 - NNM2*(SOKH - L*CSH)/2.0 2 + TNTM*(L - CSH*SOKH)/12.0)/WMN**3 + GI2*(L - SOKH) T(5,6-5*JD) = - (2.0*BEB*(1.0 - 3.0*NB)/WM5N - NB)*H0**2 1 *(L - SOKH)/(2.0*WMN) 2 - ( - 2.0*BEB/WM5N + NB)*H0**2*(L - SOKV*CSV)/4.0 T(5,9-7*JD) = - (BEB/WM5N - 0.5*NB)*H0**2*SOKV**2 1 + 2.0*BEB*(1.0 - CSH)/(WM5N*WMN) IF (NB .NE. 0.0) GLOP = (L - SOKV*CSV)/(2.0*NB) IF (NB .EQ. 0.0) GLOP = H0**2*L**3/3.0 T(5,10-7*JD) = - BEB*(GLOP - 2.0*(L - SOKH)/WMN)/WM5N 1 + (L - SOKH)/(2.0*WMN) - 0.25*(L + SOKV*CSV) C IF (RMPS .EQ. 0.0) GO TO 410 HEX = RMPS*H0 TNMB = 2.0*NB - BEB - 1.0 TNMTB = 3.0*NB - 2.0*BEB - 1.0 R(JH,JH) = R(JH,JH) + HEX*H0*(- 2.0*TNMB*HSCDX + WMN*HSSX2) R(JH,JH+1) = R(JH,JH+1) - RMPS*(2.0*TNMB*HSSDX + H0**2*HSCSX) R(JH,6) = R(JH,6) 1 - RMPS*(2.0*TNMB*H0*HSDX2 + TMN*H0*HSDX + HSSX2) R(JH+1,JH) = R(JH+1,JH) 1 + HEX*H0*(- 2.0*TNMB*HPCDX + WMN*H0**2*HPSX2 2 + CSH*SOKH - WMN*H0**2*SOKH*DISN) R(JH+1,JH+1) = R(JH+1,JH+1) 1 - HEX*H0*(2.0*TNMB*HPSDX + HPCSX 2 - SOKH**2 - CSH*DISN) R(JH+1,6) = R(JH+1,6) 1 - HEX*(2.0*TNMB*HPDX2 + TMN*HPDX + H0*HPSX2 2 - 2.0*H0*SOKH*DISP) R(JU,JU) = R(JU,JU) + 1 HEX*(NB*VSSSM + 2.0*NMB*H0*VSDCM) R(JU,JU+1) = R(JU,JU+1) + 1 RMPS*(2.0*NMB*VSDSM - VSSCM) R(JU+1,JU) = R(JU+1,JU) + 1 HEX*(NB*VPSSM + 2.0*NMB*H0*VPDCM - NB*H0**2*H*SOKV*DISN) R(JU+1,JU+1) = R(JU+1,JU+1) + 1 HEX*H0*(2.0*NMB*VPDSM - VPSCM + CSV*DISN) C 410 IF (RNMS .EQ. 0.0 .AND. VARSP(4,5) .EQ. 0) GO TO 5000 IF ((VRN .EQ. 0.0 .AND. NPN .EQ. 0.0 .AND. BDBP .EQ. 0.0) 1 .AND. (VARSP(4,6) .EQ. 0 .AND. VARSP(4,7) .EQ. 0 2 .AND. VARSP(4,8) .EQ. 0)) GO TO 5000 WP2R = 1.0 + 2.0*RMPS NBR = RH*NB VR = RNMS*VRN NPR = RNMS*NPN BEP = RNMS*BDBP/(H0*UNIT(1))**2 NPMV = NPR - VR WM2N = 1.0 - 2.0*NB + RMPS*(2.0 - 2.0*NB) FNM4 = 5.0*NB - 4.0 + RMPS*(5.0*NB - 8.0) TVMNP = 2.0*VR - NPR TBMNP = 2.0*BEP - NPR - VR TBTNP = 2.0*BEP - 3.0*NPR + VR BMTNP = BEP - 2.0*NPR HSCY = (WMN*DISN - NBR*DSVN)/WM2N HSSY = (SOKV - SOKH)/WM2N HSLCY = ((2.0*NB*RH*SOKV - WP2R*SOKH)/WM2N + L*CSV)/WM2N HSLSY = (2.0*(NBR*DSVN - WMN*DISN)/WM2N 1 + L*SOKV)/WM2N IF (NB .NE. 0.0) HSGLP = (HSSY - HSLCY)/NB IF (NB .EQ. 0.0) HSGLP = (H*H0)**2*L**5/60.0 HSCCM = (NBR*CSH*DSVN - 2.*WMN*SOKH*SOKV)/FNM4 HSCSM = - CSH*SOKV/FNM4 + 0.5*H0**2*SOKH*DSVN 1 + 0.5*SOKH*(1.0 + CSV)/FNM4 HSSCM = (2.0*CSH*SOKV - SOKH*(1.0 + CSV))/FNM4 HSSSM = 2.0*CSH*DSVN/FNM4 - SOKH*SOKV/FNM4 HSDCM = RH*(- CSH*(1.0 - CSV)/(WMN*FNM4) 1 - (CSH - CSV)/(WMN*WM2N) + 2.0*H0**2*SOKH*SOKV/FNM4) HSCDY = 0.5*RH*(1.0 - 3.0*WMN/WM5N)*DISN/WM2N 1 - RH*DSVN/WM2N + RH*SOKV**2/WM5N HSDSM = RH*(CSH*SOKV/(WMN*FNM4) - 0.5*SOKH*CSV/(WMN*FNM4) 1 - (1.0/WM2N + 0.5/FNM4)*SOKH/WMN 2 + SOKV/(WMN*WM2N)) - 0.5*H*H0*SOKH*DSVN/WMN HSSDY = 3.0*RH*(SOKH - SOKV)/(WM2N*WM5N) 1 + H*H0*SOKV*DSVN/WM5N HPCY = (WMN*SOKH - NBR*SOKV)/WM2N HPSY = (WMN*DISN - NBR*DSVN)/WM2N HPLCY = (WP2R*(WMN*DISN - NBR*DSVN)/WM2N - NBR*L*SOKV)/WM2N HPLSY = ((WP2R*SOKV - 2.0*WMN*SOKH)/WM2N + L*CSV)/WM2N IF (NB .NE. 0.0) HPGLP = (HPSY - HPLCY)/NB IF (NB .EQ. 0.0) 1 HPGLP = ( - 2.0*DISN + L**2)/WMN HPCCM = 0.5*CSH*SOKV*(1.0 + RH*NB/FNM4) 1 - WMN*SOKH*(1.0 + CSV)/FNM4 HPCSM = 0.5*CSH*DSVN*(1.0 + NBR/FNM4) - WMN*SOKH*SOKV/FNM4 HPSCM = - NBR*CSH*DSVN/FNM4 + 0.5*SOKH*SOKV*(1.0 + NBR/FNM4) HPSSM = 0.5*H*H0*SOKH*DSVN/RH - 0.5*SOKH*(1.0 + CSV)/FNM4 1 + CSH*SOKV/FNM4 HPDCM = RH*(SOKH/WM2N + SOKH*(1.0 + CSV)/FNM4 1 - RH*NB*SOKV/(WMN*WM2N) 2 - 0.5*(1.0 + RH*NB/FNM4)*CSH*SOKV/WMN) HPCDY = RH*(0.5*SOKH/WM2N - 1.5*WMN*SOKH/(WM2N*WM5N)) 1 + 2.0*RH*CSV*SOKV/WM5N - RH*SOKV/WM2N HPDSM = - 0.5*RH*(1.0 + NBR/FNM4)*CSH*DSVN/WMN 1 + RH*(WMN*DISN - NBR*DSVN)/(WMN*WM2N) + RH*SOKH*SOKV/FNM4 HPSDY = 3.0*RH*(CSH - CSV)/(WM5N*WM2N) 1 - H*H0*DSVN/WM5N + 2.0*H*H0*SOKV**2/WM5N VSCX = (WMN*DISN - NBR*DSVN)/WM2N VSSX = (SOKV - SOKH)/WM2N VSDX = RH*((NBR*DSVN - WMN*DISN)/(WMN*WM2N) + DSVN/WMN) IF (NB .EQ. 0.0) DMSLV = H0*H*L**4/24.0 IF (NB .NE. 0.0) DMSLV = (DSVN - 0.5*L*SOKV)/NB VSDY = DMSLV VSLCX = ((2.0*WMN*SOKH - WP2R*SOKV)/WM2N - L*CSH)/WM2N VSLSX = (2.0*(WMN*DISN - NBR*DSVN)/WM2N - L*SOKH)/WM2N VSCX2 = 0.5*(1.0 + NBR/FNM4)*DSVN - WMN*SOKH**2/FNM4 VSCSX = (CSH*SOKH - SOKV)/FNM4 VSSX2 = 0.5*(1.0 - NBR/FNM4)*DSVN/WMN + SOKH**2/FNM4 VSCY2 = (DSVN + SOKV**2)/3.0 VSCSY = SOKV*DSVN/3.0 IF (NB .EQ. 0.0) SNARK = 0.25*H0**2*L**4 IF (NB .NE. 0.0) SNARK = (2.0*DSVN - SOKV**2)/(NB*RH) VSSY2 = SNARK/3.0 VSCDX = - 0.5*H*H0*(1.0 + NBR/FNM4)*DSVN/WMN 1 - RH*(CSH - CSV)/(WMN*WM2N) + H*H0*SOKH**2/FNM4 VSCDM = - H*H0*CSH*DSVN/WM5N + 3.0*RH*(CSH - CSV)/(WM2N*WM5N) 1 + 2.0*H*H0*SOKH*SOKV/WM5N VSSDX = RH*( - CSH*SOKH/FNM4 - SOKH/WM2N 1 + SOKV*(1.0/WM2N + 1.0/FNM4))/WMN VSSDM = - 2.0*RH*CSH*SOKV/(WMN*WM5N) 1 + 0.5*RH*(1.0/WMN - 3.0/WM5N)*SOKV/WM2N 2 + 3.0*RH*SOKH/(WM2N*WM5N) - H*H0*SOKH*DSVN/WM5N VSDX2 = RH*(2.0*RH*(NBR*DSVN - WMN*DISN)/(WMN**2*WM2N) 1 - RH*SOKH**2/(WMN*FNM4) 2 + 0.5*RH*(3.0 + NBR/FNM4)*DSVN/WMN**2) VSDDM = RH*((RH*CSH*DSVN/WM5N 1 + 3.0*RH*(WMN*DISN - NBR*DSVN)/(WM2N*WM5N) 2 - 2.0*RH*SOKH*SOKV/WM5N + DMSLV)/WMN) VPCX = (WMN*SOKH - RH*NB*SOKV)/WM2N VPSX = (WMN*DISN - NBR*DSVN)/WM2N VPDX = RH*(SOKV - SOKH)/WM2N IF (NB .EQ. 0.0) SMLCV = H0**2*L**3/3.0 IF (NB .NE. 0.0) SMLCV = (SOKV - L*CSV)/NB VPDY = 0.5*SMLCV VPLCX = (WP2R*(CSH - CSV)/WM2N + H0**2*WMN*L*SOKH)/WM2N VPLSX = ((WP2R*SOKH - 2.0*NB*RH*SOKV)/WM2N - L*CSH)/WM2N VPCX2 = 0.5*(1.0 + RH*NB/FNM4)*SOKV 1 - 2.0*WMN*CSH*SOKH/FNM4 VPCSX = (NBR*DSVN - 2.0*WMN*SOKH**2)/FNM4 VPSX2 = 0.5*(1.0 - RH*NB/FNM4)*SOKV/WMN + 2.0*CSH*SOKH/FNM4 VPCY2 = SOKV*(1.0 + 2.0*CSV)/3.0 VPCSY = ( - DSVN + 2.0*SOKV**2)/3.0 VPSY2 = 2.0*SOKV*DSVN/3.0 VPCDX = RH*(2.0*CSH*SOKH/FNM4 + SOKH/WM2N 1 - (RH*(NB/WM2N + 0.5*NB/FNM4) + 0.5)*SOKV/WMN) VPCDM = RH*CSH*SOKV/WM5N - RH*(1.0/WM2N - 1.0/WM5N)*SOKV 1 + WMN*H*H0*SOKH*DSVN/WM2N 2 + 0.5*RH*(1.0/WM2N - 3.0*WMN/(WM2N*WM5N))*SOKH*CSV VPSDX = RH*( - (CSH - CSV)/(WMN*WM2N) 1 - (1.0 - CSV)/(WMN*FNM4) + 2.0*H0**2*SOKH**2/FNM4) VPSDM = RH*(0.5*(1.0 - 3.0*WMN/WM5N)*CSV*DISN/WM2N 1 - CSH*DSVN/WM2N + SOKH*SOKV/WM5N) VPDX2 = RH**2*(- 2.0*CSH*SOKH/(WMN*FNM4) - 2.0*SOKH/(WMN*WM2N) 1 + (RH*NB*(2.0/WM2N + 0.5/FNM4) + 1.5)*SOKV/WMN**2) VPDDM = RH*( - RH*CSH*SOKV/(WMN*WM5N) 1 + 0.5*RH*( - 1.0/WMN + 3.0/WM5N)*SOKH*CSV/WM2N 2 - H*H0*SOKH*DSVN/WM2N 3 + 0.5*SMLCV/WMN 4 + RH*SOKV*(1.0/WM2N - 1.0/WM5N)/WMN) C R(JH,JU) = R(JH,JU) + VR*H0**2*(TBMN*HSCDY + NB*HSSY2) R(JH,JU+1) = R(JH,JU+1) - VR*HSCSY + TBMN*VR*HSSDY R(JH+1,JU) = R(JH+1,JU) + VR*H0**2*(TBMN*HPCDY + NB*HPSY2) R(JH+1,JU+1) = R(JH+1,JU+1) - VR*H0**2*HPCSY 1 + TBMN*VR*HPSDY R(JU,JH) = R(JU,JH) - 2.0*VR*NMB*VSCDM 1 - VR*WMN*H0**2*VSSSM R(JU,JH+1) = R(JU,JH+1) + VR*(VSCSM - 2.0*NMB*VSSDM) R(JU,6) = R(JU,6) + VR*H0*(NB*VSDY + VSSSM - 2.0*NMB*VSDDM) 1 - VR*H0*DSVN R(JU+1,JH) = R(JU+1,JH) - VR*H0**2*(2.0*NMB*VPCDM + WMN*VPSSM) 1 - VR*H0**2*CSH*SOKV R(JU+1,JH+1) = R(JU+1,JH+1) + VR*H0**2*(VPCSM - 2.0*NMB*VPSDM) 1 - VR*H0**2*SOKH*SOKV R(JU+1,6) = R(JU+1,6) 1 + VR*H0*(NB*VPDY + VPSSM - 2.0*NMB*VPDDM) 2 - VR*H0*(SOKV + H0**2*DISN) C GLUG1 = H0**3*TBTNP*HSCCM GLUG2 = H0**3*NPMV*(0.5*(1.0 - WMN/WM5N) + 2.0*NMB/WM5N)* 1 (HSCY - HSCCM) GLUG3 = H0**3*NPMV*(BEB*WMN/WM5N + NMB)*HSSSM GLUG4 = H0**3*(- 2.*TNMB*NPMV - TBMN*TVMNP)*HSCCM/WM2N GLUG5 = 2.0*H0**3*TNMB*NPMV*HSCX2/WM2N GLUG6 = H0**3*TBMN*TVMNP*HSCY2/WM2N GLUG7 = NB*WMN*H0**3*(TVMNP - NPMV)*HSSSM/WM2N GLUG8 = WMN**2*H0**3*NPMV*HSSX2/WM2N GLUG9 = - NB**2*H0**3*TVMNP*HSSY2/WM2N T(JH,4) = GLUG1 + GLUG2 + GLUG3 + GLUG4 + GLUG5 1 + GLUG6 + GLUG7 + GLUG8 + GLUG9 GLUG1 = H0*TBTNP*HSCSM GLUG2 = 0.5*H0*NPMV*(HSSY - HSCSM) GLUG3 = H0*NPMV*( - 2.0*NMB + 0.5*WMN)*(HSSY + HSCSM)/WM5N GLUG4 = H0*NPMV*(4.0*NMB - WMN)*HSSCM/WM5N GLUG5 = H0*NPMV*(2.0*TNMB - WMN)*H0**2*HSCSX/WM2N GLUG6 = - H0*(2.*TNMB*NPMV + TBMN*TVMNP)*HSCSM/WM2N GLUG7 = - H0*WMN*(TVMNP - NPMV)*HSSCM/WM2N GLUG8 = 2.0*BEB*H0*TVMNP*HSCSY/WM2N GLUG9 = H0*NPMV*(SOKH - SOKV)/WM2N T(JH,7-2*JD) = GLUG1 + GLUG2 + GLUG3 + GLUG4 + GLUG5 1 + GLUG6 + GLUG7 + GLUG8 + GLUG9 GLUG1 = H0*TBTNP*HSSCM GLUG2 = - NPR*H0*(0.5*(1.0 - WMN/WM5N) + 2.0*NMB/WM5N)*HSSCM GLUG3 = - BEB*H0*NPMV*(HSSY + HSCSM)/WM5N GLUG4 = NMB*H0*NPMV*(HSSY - HSCSM)/WMN GLUG5 = NPMV*(2.0*TNMB - WMN)*H0**3*HSCSX/WM2N GLUG6 = - H0*NB*(TVMNP - NPMV)*HSCSM/WM2N GLUG7 = - H0*(2.0*TNMB*NPMV + TBMN*TVMNP)*HSSCM/WM2N GLUG8 = 2.0*BEB*H0*TVMNP*HSCSY/WM2N T(JH,5+2*JD) = GLUG1 + GLUG2 + GLUG3 + GLUG4 + GLUG5 1 + GLUG6 + GLUG7 + GLUG8 GLUG1 = H0*TBTNP*HSSSM GLUG2 = - H0*NPMV*(0.5*(1.0 - WMN/WM5N) + 2.0*NMB/WM5N)* 1 HSSSM GLUG3 = H0*NPMV*(4.0*NMB/WMN - 1.0)*(HSCY - HSCCM)/WM5N GLUG4 = H0*(TVMNP - NPMV)*HSCCM/WM2N GLUG5 = H0*NPMV*HSCX2/WM2N GLUG6 = - H0*(2.0*TNMB*NPMV + TBMN*TVMNP)*HSSSM/WM2N GLUG7 = 2.0*H0*TNMB*NPMV*HSSX2/WM2N GLUG8 = - H0*TVMNP*HSCY2/WM2N GLUG9 = H0*TBMN*TVMNP*HSSY2/WM2N T(JH,8) = GLUG1 + GLUG2 + GLUG3 + GLUG4 + GLUG5 1 + GLUG6 + GLUG7 + GLUG8 + GLUG9 GLUG1 = NPMV*H0**2*HSCY GLUG2 = TBTNP*HSDCM GLUG3 = - TBMN*VR*H0**2*HSCDY GLUG4 = - NB*VR*H0**2*HSSY2 GLUG5 = 2.0*NPMV*H0**2*BEB*(HSCY - HSCCM)/(WMN*WM5N) GLUG6 = - NPMV*(NMB/WMN + BEB/WM5N)*H0**2*HSSSM GLUG7 = - NPMV*(0.5*NB - NMB/WMN)*H0**2*HSLSY GLUG8 = TMN*NPMV*H0**2*(HSCX - HSCY)/WM2N GLUG9 = 2.0*TNMB*NPMV*H0**2*HSCDX/WM2N GLUGA = 3.0*VR*NB*H0**2*HSSSM/WM2N GLUGB = - WMN*NPMV*H0**2*HSSX2/WM2N GLUGC = - (2.*TNMB*NPMV + TBMN*TVMNP)*HSDCM/WM2N GLUGD = TBMN*TVMNP*H0**2*HSCDY/WM2N GLUGE = - NB*TVMNP*H0**2*HSSY2/WM2N T(JH,19-JH) = GLUG1 + GLUG2 + GLUG3 + GLUG4 + GLUG5 1 + GLUG6 + GLUG7 + GLUG8 + GLUG9 + GLUGA + GLUGB + GLUGC 2 + GLUGD + GLUGE GLUG1 = TBTNP*HSDSM GLUG2 = VR*HSCSY GLUG3 = - TBMN*VR*HSSDY GLUG4 = NPMV*(2.0*NMB/WMN - 0.5)*(HSSY + HSCSM)/WM5N GLUG5 = - 0.5*NPMV*(HSSY - HSCSM)/WMN GLUG6 = 0.5*NPMV*HSSY GLUG7 = 0.5*NPMV*HSLCY GLUG8 = NPMV*NMB*HSGLP/WMN GLUG9 = NPMV*(- 4.0*NMB/WMN + 1.0)*HSSCM/WM5N GLUGA = NPMV*H0**2*HSCSX/WM2N GLUGB = TMN*NPMV*HSSX/WM2N GLUGC = 2.0*TNMB*NPMV*HSSDX/WM2N GLUGD = - VR*HSSCM/WM2N GLUGE = TVMNP*HSCSY/WM2N GLUGF = - TMN*NPMV*HSSY/WM2N GLUGG = - (2.*TNMB*NPMV + TBMN*TVMNP)*HSDSM/WM2N GLUGH = TBMN*TVMNP*HSSDY/WM2N T(JH,20-JH) = GLUG1 + GLUG2 + GLUG3 + GLUG4 + GLUG5 1 + GLUG6 + GLUG7 + GLUG8 + GLUG9 + GLUGA + GLUGB + GLUGC 1 + GLUGD + GLUGE + GLUGF + GLUGG + GLUGH GLUG1 = H0**3*TBTNP*HPCCM GLUG2 = H0**3*NPMV*(0.5*(1.0 - WMN/WM5N) + 2.0*NMB/WM5N)* 1 (HPCY - HPCCM) GLUG3 = H0**3*NPMV*(BEB*WMN/WM5N + NMB)*HPSSM GLUG4 = H0**3*(- 2.*TNMB*NPMV - TBMN*TVMNP)*HPCCM/WM2N GLUG5 = 2.0*H0**3*TNMB*NPMV*HPCX2/WM2N GLUG6 = H0**3*TBMN*TVMNP*HPCY2/WM2N GLUG7 = NB*WMN*H0**3*(TVMNP - NPMV)*HPSSM/WM2N GLUG8 = WMN**2*H0**5*NPMV*HPSX2/WM2N GLUG9 = - NB**2*H0**3*TVMNP*HPSY2/WM2N GLUGA = H0**3*NPMV*(2.0*WMN*CSH*SOKH 1 - NB*CSH*SOKV - WMN*CSV*SOKH)/WM2N T(JH+1,4) = GLUG1 + GLUG2 + GLUG3 + GLUG4 + GLUG5 1 + GLUG6 + GLUG7 + GLUG8 + GLUG9 + GLUGA GLUG1 = H0**3*TBTNP*HPCSM GLUG2 = 0.5*H0**3*NPMV*(HPSY - HPCSM) GLUG3 = H0**3*NPMV*( - 2.0*NMB + 0.5*WMN)*(HPSY + HPCSM)/WM5N GLUG4 = H0**3*NPMV*(4.0*NMB - WMN)*HPSCM/WM5N GLUG5 = H0**3*NPMV*(2.0*TNMB - WMN)*HPCSX/WM2N GLUG6 = - H0**3*(2.*TNMB*NPMV + TBMN*TVMNP)*HPCSM/WM2N GLUG7 = - H0**3*WMN*(TVMNP - NPMV)*HPSCM/WM2N GLUG8 = 2.0*BEB*H0**3*TVMNP*HPCSY/WM2N GLUG9 = H0**3*NPMV*( - WMN*DISN*(1.0 + CSV) 1 + WMN*(2.0*SOKH**2 - SOKH*SOKV))/WM2N T(JH+1,7-2*JD) = GLUG1 + GLUG2 + GLUG3 + GLUG4 + GLUG5 1 + GLUG6 + GLUG7 + GLUG8 + GLUG9 GLUG1 = H0**3*TBTNP*HPSCM GLUG2 = - NPMV*H0**3*(0.5*(1.0 - WMN/WM5N) + 2.0*NMB/WM5N)*HPSCM GLUG3 = - BEB*H0**3*NPMV*(HPSY + HPCSM)/WM5N GLUG4 = NMB*H0**3*NPMV*(HPSY - HPCSM)/WMN GLUG5 = H0**3*NPMV*(2.0*TNMB - WMN)*HPCSX/WM2N GLUG6 = - H0**3*NB*(TVMNP - NPMV)*HPCSM/WM2N GLUG7 = - H0**3*(2.0*TNMB*NPMV + TBMN*TVMNP)*HPSCM/WM2N GLUG8 = 2.0*BEB*H0**3*TVMNP*HPCSY/WM2N GLUG9 = - H0**3*NPMV*(WMN*DISN + NB*CSH*DSVN 1 + NB*SOKH*SOKV - 2.0*WMN*SOKH**2)/WM2N T(JH+1,5+2*JD) = GLUG1 + GLUG2 + GLUG3 + GLUG4 + GLUG5 1 + GLUG6 + GLUG7 + GLUG8 + GLUG9 GLUG1 = H0*TBTNP*HPSSM GLUG2 = - H0*NPMV*(0.5*(1.0 - WMN/WM5N) + 2.0*NMB/WM5N)* 1 HPSSM GLUG3 = H0*NPMV*(4.0*NMB/WMN - 1.0)*(HPCY - HPCCM)/WM5N GLUG4 = H0*(TVMNP - NPMV)*HPCCM/WM2N GLUG5 = H0*NPMV*HPCX2/WM2N GLUG6 = - H0*(2.0*TNMB*NPMV + TBMN*TVMNP)*HPSSM/WM2N GLUG7 = 2.0*H0**3*TNMB*NPMV*HPSX2/WM2N GLUG8 = - H0*TVMNP*HPCY2/WM2N GLUG9 = H0*TBMN*TVMNP*HPSY2/WM2N GLUGA = H0*NPMV*(CSH*SOKV + CSV*SOKH - 2.0*CSH*SOKH)/WM2N T(JH+1,8) = GLUG1 + GLUG2 + GLUG3 + GLUG4 + GLUG5 1 + GLUG6 + GLUG7 + GLUG8 + GLUG9 + GLUGA GLUG1 = H0**2*TBTNP*HPDCM GLUG2 = NPMV*H0**2*HPCY GLUG3 = - TBMN*VR*H0**2*HPCDY GLUG4 = - NB*VR*H0**2*HPSY2 GLUG5 = 2.0*NPMV*H0**2*BEB*(HPCY - HPCCM)/(WMN*WM5N) GLUG6 = - NPMV*(NMB/WMN + BEB/WM5N)*H0**2*HPSSM GLUG7 = - NPMV*(0.5*NB - NMB/WMN)*H0**2*HPLSY GLUG8 = TMN*NPMV*H0**2*(HPCX - HPCY)/WM2N GLUG9 = 2.0*TNMB*NPMV*H0**2*HPCDX/WM2N GLUGA = 3.0*VR*NB*H0**2*HPSSM/WM2N GLUGB = - WMN*NPMV*H0**4*HPSX2/WM2N GLUGC = - (2.*TNMB*NPMV + TBMN*TVMNP)*H0**2*HPDCM/WM2N GLUGD = TBMN*TVMNP*H0**2*HPCDY/WM2N GLUGE = - NB*TVMNP*H0**2*HPSY2/WM2N GLUGF = H0**2*NPMV*(SOKH*(CSV - CSH) 1 + H0*DISP*(WMN*SOKH - NB*SOKV))/WM2N T(JH+1,19-JH) = GLUG1 + GLUG2 + GLUG3 + GLUG4 + GLUG5 1 + GLUG6 + GLUG7 + GLUG8 + GLUG9 + GLUGA + GLUGB + GLUGC 2 + GLUGD + GLUGE + GLUGF GLUG1 = H0**2*TBTNP*HPDSM GLUG2 = VR*H0**2*HPCSY GLUG3 = - TBMN*VR*HPSDY GLUG4 = NPMV*(2.0*NMB/WMN - 0.5)*H0**2*(HPSY + HPCSM)/WM5N GLUG5 = - 0.5*NPMV*H0**2*(HPSY - HPCSM)/WMN GLUG6 = 0.5*NPMV*H0**2*HPSY GLUG7 = 0.5*NPMV*H0**2*HPLCY GLUG8 = NPMV*NMB*H0**2*HPGLP/WMN GLUG9 = NPMV*(- 4.0*NMB/WMN + 1.0)*H0**2*HPSCM/WM5N GLUGA = NPMV*H0**2*HPCSX/WM2N GLUGB = TMN*NPMV*H0**2*HPSX/WM2N GLUGC = 2.0*TNMB*NPMV*H0**2*HPSDX/WM2N GLUGD = - VR*H0**2*HPSCM/WM2N GLUGE = TVMNP*H0**2*HPCSY/WM2N GLUGF = - TMN*NPMV*H0**2*HPSY/WM2N GLUGG = - (2.*TNMB*NPMV + TBMN*TVMNP)*H0**2*HPDSM/WM2N GLUGH = TBMN*TVMNP*HPSDY/WM2N GLUGI = NPMV*H0*DISP*(CSV - CSH)/WM2N GLUGJ = NPMV*H0**2*SOKH*(SOKV - SOKH)/WM2N T(JH+1,20-JH) = GLUG1 + GLUG2 + GLUG3 + GLUG4 + GLUG5 1 + GLUG6 + GLUG7 + GLUG8 + GLUG9 + GLUGA + GLUGB + GLUGC 2 + GLUGD + GLUGE + GLUGF + GLUGG + GLUGH + GLUGI + GLUGJ GLUG1 = H0**3*BMTNP*VSCX2 GLUG2 = 0.5*VR*H0**3*WMN**2*VSSX2 GLUG3 = TVMNP*H0**3*(TNMB + WMN)*VSDX/3.0 GLUG4 = H0**3*TVMNP*(2.0*TNMB - WMN)*VSSX2/6.0 GLUG5 = 2.0*H0**3*TVMNP*NMB*(VSCX2 - VSCCM)/WM2N GLUG6 = NB*H0**3*TVMNP*WMN*VSSSM/WM2N GLUG7 = - H0**3*TVMNP*WMN**2*VSSX2/WM2N T(JU,1+5*JD) = GLUG1 + GLUG2 + GLUG3 + GLUG4 + GLUG5 1 + GLUG6 + GLUG7 GLUG1 = H0*(2.0*BMTNP - VR*WMN)*VSCSX GLUG2 = H0*TVMNP*(2.0*TNMB/WMN - 1.0)*(VSSX - VSCSX)/3.0 GLUG3 = H0*TVMNP*(2.0*NMB + WMN)*(2.0*VSCSX - VSSCM)/WM2N GLUG4 = - H0*TVMNP*(2.0*NMB + NB)*VSCSM/WM2N GLUG5 = - H0*TVMNP*(SOKH - SOKV)/WM2N T(JU,2+7*JD) = GLUG1 + GLUG2 + GLUG3 + GLUG4 + GLUG5 GLUG1 = H0*BMTNP*VSSX2 GLUG2 = 0.5*H0*VR*VSCX2 GLUG3 = H0*TVMNP*( - 2.0*TNMB/WMN + 1.0)*VSSX2/6.0 GLUG4 = H0*TVMNP*(4.0*TNMB/WMN + 1.0)*VSDX/6.0 GLUG5 = H0*TVMNP*(VSCCM - VSCX2)/WM2N GLUG6 = 2.0*H0*TVMNP*NMB*(VSSX2 - VSSSM)/WM2N T(JU,3+7*JD) = GLUG1 + GLUG2 + GLUG3 + GLUG4 + GLUG5 1 + GLUG6 GLUG1 = 2.0*BMTNP*VSCDX GLUG2 = - TVMNP*H0**2*VSCX GLUG3 = VR*WMN*H0**2*(VSSSM - VSSX2) GLUG4 = 2.0*VR*NMB*VSCDM GLUG5 = TVMNP*(TNMB/WMN + 0.5*TMN)*H0**2*VSLSX GLUG6 = TVMNP*( - 2.0*TNMB/WMN + 1.0)*H0**2*VSSX2/3.0 GLUG7 = - 2.0*TVMNP*(TNMB/WMN + 1.0)*H0**2*VSDX/3.0 GLUG8 = NB*TVMNP*H0**2*(VSCY - VSCX)/WM2N GLUG9 = 2.0*TVMNP*NMB*(2.0*VSCDX - VSCDM - H0**2*VSDCM)/ 1 WM2N GLUGA = TVMNP*H0**2*VSSSM T(JU,15+JH) = GLUG1 + GLUG2 + GLUG3 + GLUG4 + GLUG5 1 + GLUG6 + GLUG7 + GLUG8 + GLUG9 + GLUGA GLUG1 = 2.0*BMTNP*VSSDX GLUG2 = - TVMNP*VSSX GLUG3 = VR*(VSCSX - VSCSM) GLUG4 = 2.*VR*NMB*VSSDM GLUG5 = - TVMNP*(TNMB/WMN + 0.5*TMN)*VSLCX/WMN GLUG6 = TVMNP*(2.0*TNMB/WMN - 1.0)*VSCSX/(3.0*WMN) GLUG7 = TVMNP*(2.0*TNMB/WMN + 3.0*TMN + 2.0)*VSSX/ 1 (6.0*WMN) GLUG8 = TVMNP*(VSSCM - VSCSM)/WM2N GLUG9 = NB*TVMNP*(VSSY - VSSX)/WM2N GLUGA = 2.*TVMNP*NMB*(2.0*VSSDX - VSSDM - VSDSM)/WM2N T(JU,16+JH) = GLUG1 + GLUG2 + GLUG3 + GLUG4 + GLUG5 1 + GLUG6 + GLUG7 + GLUG8 + GLUG9 + GLUGA GLUG1 = H0*BMTNP*VSDX2 GLUG2 = - 2.0*H0*TVMNP*VSDX GLUG3 = VR*H0*(DSVN - VSSSM + 0.5*VSSX2) GLUG4 = 2.0*VR*H0*NMB*VSDDM GLUG5 = - NB*H0*VR*VSDY GLUG6 = - H0*TVMNP*(TNMB/WMN + 0.5*TMN)*VSLSX/WMN GLUG7 = H0*TVMNP*(2.0*TNMB/WMN - 1.0)*VSSX2/(6.0*WMN) GLUG8 = H0*TVMNP*(4.0*TNMB/WMN + 3.0*TMN + 1.0)*VSDX/(3.0*WMN) GLUG9 = H0*TVMNP*(VSSX2 - VSSSM)/WM2N GLUGA = NB*H0*TVMNP*(VSDY - VSDX)/WM2N GLUGB = 2.0*H0*TVMNP*NMB*(VSDX2 - VSDDM)/WM2N T(JU,21) = GLUG1 + GLUG2 + GLUG3 + GLUG4 + GLUG5 1 + GLUG6 + GLUG7 + GLUG8 + GLUG9 + GLUGA + GLUGB GLUG1 = - 0.5*H0**3*TBMNP*VSCY2 GLUG2 = 0.5*H0**3*NB**2*VR*VSSY2 GLUG3 = 0.5*H0**3*BEB*TVMNP*WMN*VSDX/WM5N GLUG4 = 0.25*H0**3*TVMNP*(TBMN - NB)*VSDX GLUG5 = - H0**3*TVMNP*NB*BEB*VSSY2/WM5N GLUG6 = 2.0*H0**3*NPMV*NMB*(VSCY2 - VSCCM)/WM2N GLUG7 = H0**3*NB*WMN*NPMV*VSSSM/WM2N GLUG8 = - H0**3*NB**2*NPMV*VSSY2/WM2N T(JU,6-5*JD) = GLUG1 + GLUG2 + GLUG3 + GLUG4 + GLUG5 1 + GLUG6 + GLUG7 + GLUG8 GLUG1 = - (TBMNP + NB*VR)*H0**3*VSCSY GLUG2 = 2.0*H0*BEB*TVMNP*(H0**2*VSCSY - VSSX)/WM5N GLUG3 = NPMV*H0*(2.0*NMB + NB)*(2.0*H0**2*VSCSY - VSCSM)/WM2N GLUG4 = - H0*NPMV*(2.0*NMB + WMN)*VSSCM/WM2N T(JU,9-7*JD) = GLUG1 + GLUG2 + GLUG3 + GLUG4 GLUG1 = - 0.5*H0*TBMNP*VSSY2 GLUG2 = 0.5*H0*VR*VSCY2 GLUG3 = - H0*TVMNP*(TBMN/WM5N + 0.25*(1.0 + WMN/WM5N))*VSDX GLUG4 = H0*TVMNP*BEB*VSSY2/WM5N GLUG5 = H0*NPMV*(VSCCM - VSCY2)/WM2N GLUG6 = 2.0*H0*NPMV*NMB*(VSSY2 - VSSSM)/WM2N T(JU,10-7*JD) = GLUG1 + GLUG2 + GLUG3 + GLUG4 + GLUG5 1 + GLUG6 GLUG1 = H0**3*BMTNP*VPCX2 GLUG2 = 0.5*VR*H0**3*WMN**2*VPSX2 GLUG3 = TVMNP*H0**3*(TNMB + WMN)*VPDX/3.0 GLUG4 = H0**3*TVMNP*(2.0*TNMB - WMN)*VPSX2/6.0 GLUG5 = 2.0*H0**3*TVMNP*NMB*(VPCX2 - VPCCM)/WM2N GLUG6 = NB*H0**3*TVMNP*WMN*VPSSM/WM2N GLUG7 = - H0**3*TVMNP*WMN**2*VPSX2/WM2N GLUG8 = - H0**3*TVMNP*CSH*(WMN*SOKH - NB*SOKV)/WM2N T(JU+1,1+5*JD) = GLUG1 + GLUG2 + GLUG3 + GLUG4 + GLUG5 1 + GLUG6 + GLUG7 + GLUG8 GLUG1 = H0**3*(2.0*BMTNP - VR*WMN)*VPCSX GLUG2 = H0**3*TVMNP*(2.0*TNMB/WMN - 1.0)*(VPSX - VPCSX)/3.0 GLUG3 = H0**3*TVMNP*(2.0*NMB + WMN)*(2.0*VPCSX - VPSCM)/WM2N GLUG4 = - H0**3*TVMNP*(2.0*NMB + NB)*VPCSM/WM2N GLUG5 = H0**3*TVMNP*(WMN*DISN*(1.0 + CSV) + NB*SOKH*SOKV 1 - 2.0*WMN*SOKH**2)/WM2N T(JU+1,2+7*JD) = GLUG1 + GLUG2 + GLUG3 + GLUG4 + GLUG5 GLUG1 = H0*BMTNP*VPSX2 GLUG2 = 0.5*H0*VR*VPCX2 GLUG3 = H0*TVMNP*( - 2.0*TNMB/WMN + 1.0)*VPSX2/6.0 GLUG4 = H0*TVMNP*(4.0*TNMB/WMN + 1.0)*VPDX/6.0 GLUG5 = H0*TVMNP*(VPCCM - VPCX2)/WM2N GLUG6 = 2.0*H0*TVMNP*NMB*(VPSX2 - VPSSM)/WM2N GLUG7 = H0*TVMNP*SOKH*(CSH - CSV)/WM2N T(JU+1,3+7*JD) = GLUG1 + GLUG2 + GLUG3 + GLUG4 + GLUG5 1 + GLUG6 + GLUG7 GLUG1 = 2.0*H0**2*BMTNP*VPCDX GLUG2 = - TVMNP*H0**2*VPCX GLUG3 = VR*WMN*H0**2*(VPSSM - VPSX2) GLUG4 = 2.0*H0**2*VR*NMB*VPCDM GLUG5 = TVMNP*(TNMB/WMN + 0.5*TMN)*H0**2*VPLSX GLUG6 = TVMNP*( - 2.0*TNMB/WMN + 1.0)*H0**2*VPSX2/3.0 GLUG7 = - 2.0*TVMNP*(TNMB/WMN + 1.0)*H0**2*VPDX/3.0 GLUG8 = NB*TVMNP*H0**2*(VPCY - VPCX)/WM2N GLUG9 = 2.0*H0**2*TVMNP*NMB*(2.0*VPCDX - VPCDM - VPDCM)/ 1 WM2N GLUGA = TVMNP*H0**2*VPSSM GLUGB = H0**2*((TVMNP*CSH*(SOKH - SOKV) 1 - TVMNP*WMN*H0*SOKH*DISP + NB*TVMNP*H0*SOKV*DISP)/WM2N 2 + VR*CSH*SOKV) T(JU+1,15+JH) = GLUG1 + GLUG2 + GLUG3 + GLUG4 + GLUG5 1 + GLUG6 + GLUG7 + GLUG8 + GLUG9 + GLUGA + GLUGB GLUG1 = 2.0*BMTNP*VPSDX GLUG2 = 2.*VR*NMB*H0**2*VPSDM GLUG3 = - TVMNP*H0**2*VPSX GLUG4 = VR*H0**2*(VPCSX - VPCSM) GLUG5 = - TVMNP*(TNMB/WMN + 0.5*TMN)*VPLCX/WMN GLUG6 = TVMNP*(2.0*TNMB/WMN - 1.0)*H0**2*VPCSX/(3.0*WMN) GLUG7 = TVMNP*(2.0*TNMB/WMN + 3.0*TMN + 2.0)*H0**2*VPSX/ 1 (6.0*WMN) GLUG8 = TVMNP*H0**2*(VPSCM - VPCSM)/WM2N GLUG9 = NB*TVMNP*H0**2*(VPSY - VPSX)/WM2N GLUGA = 2.*TVMNP*NMB*(2.0*VPSDX - H0**2*(VPSDM + VPDSM))/WM2N GLUGB = TVMNP*H0**2*SOKH*(SOKH - SOKV)/WM2N GLUGC = TVMNP*H0*DISP*(CSH - CSV)/WM2N GLUGD = VR*H0**2*SOKH*SOKV T(JU+1,16+JH) = GLUG1 + GLUG2 + GLUG3 + GLUG4 + GLUG5 1 + GLUG6 + GLUG7 + GLUG8 + GLUG9 + GLUGA + GLUGB + GLUGC 2 + GLUGD GLUG1 = H0*BMTNP*VPDX2 GLUG2 = VR*H0*SOKV GLUG3 = - H0*VR*VPSSM GLUG4 = 0.5*H0*VR*VPSX2 GLUG5 = - 2.0*H0*TVMNP*VPDX GLUG6 = 2.0*H0*VR*NMB*VPDDM GLUG7 = - NB*H0*VR*VPDY GLUG8 = - H0*TVMNP*(TNMB/WMN + 0.5*TMN)*VPLSX/WMN GLUG9 = H0*TVMNP*(2.0*TNMB/WMN - 1.0)*VPSX2/(6.0*WMN) GLUGA = H0*TVMNP*(4.0*TNMB/WMN + 3.0*TMN + 1.0)*VPDX/(3.0*WMN) GLUGB = H0*TVMNP*(VPSX2 - VPSSM)/WM2N GLUGC = NB*H0*TVMNP*(VPDY - VPDX)/WM2N GLUGD = 2.0*H0*TVMNP*NMB*(VPDX2 - VPDDM)/WM2N GLUGE = H0**2*(TVMNP*DISP*(SOKH - SOKV)/WM2N 1 + VR*DISP*SOKV) T(JU+1,21) = GLUG1 + GLUG2 + GLUG3 + GLUG4 + GLUG5 1 + GLUG6 + GLUG7 + GLUG8 + GLUG9 + GLUGA + GLUGB + GLUGC 2 + GLUGD + GLUGE GLUG1 = - 0.5*H0**3*TBMNP*VPCY2 GLUG2 = 0.5*H0**5*NB**2*VR*VPSY2 GLUG3 = 0.5*H0**3*BEB*TVMNP*WMN*VPDX/WM5N GLUG4 = 0.25*H0**3*TVMNP*(TBMN - NB)*VPDX GLUG5 = - H0**5*TVMNP*NB*BEB*VPSY2/WM5N GLUG6 = 2.0*H0**3*NPMV*NMB*(VPCY2 - VPCCM)/WM2N GLUG7 = H0**3*NB*WMN*NPMV*VPSSM/WM2N GLUG8 = - H0**5*NB**2*NPMV*VPSY2/WM2N GLUG9 = H0**3*NB*NPMV*SOKV*(CSH - CSV)/WM2N T(JU+1,6-5*JD) = GLUG1 + GLUG2 + GLUG3 + GLUG4 + GLUG5 1 + GLUG6 + GLUG7 + GLUG8 + GLUG9 GLUG1 = - H0**3*(TBMNP + NB*VR)*VPCSY GLUG2 = 2.0*H0**3*BEB*TVMNP*(VPCSY - VPSX)/WM5N GLUG3 = H0**3*NPMV*(2.0*NMB + NB)*(2.0*VPCSY - VPCSM)/WM2N GLUG4 = - H0**3*NPMV*(2.0*NMB + WMN)*VPSCM/WM2N GLUG5 = H0**3*NPMV*(WMN*DISN + NB*CSH*DSVN)/WM2N GLUG6 = H0**3*NB*NPMV*SOKV*(SOKH - 2.0*SOKV)/WM2N T(JU+1,9-7*JD) = GLUG1 + GLUG2 + GLUG3 + GLUG4 + GLUG5 1 + GLUG6 GLUG1 = - 0.5*H0**3*TBMNP*VPSY2 GLUG2 = 0.5*H0*VR*VPCY2 GLUG3 = - H0*TVMNP*(TBMN/WM5N + 0.25*(1.0 + WMN/WM5N))*VPDX GLUG4 = H0**3*TVMNP*BEB*VPSY2/WM5N GLUG5 = H0*NPMV*(VPCCM - VPCY2)/WM2N GLUG6 = 2.0*NPMV*NMB*H0*(H0**2*VPSY2 - VPSSM)/WM2N GLUG7 = - H0*NPMV*CSV*(SOKH - SOKV)/WM2N T(JU+1,10-7*JD) = GLUG1 + GLUG2 + GLUG3 + GLUG4 + GLUG5 1 + GLUG6 + GLUG7 GO TO 5000 C C 5. -- QUADRUPOLE C 500 J = JH KQ2 = K2H 510 CS = R(J,J) SK = - R(J+1,J) SOK = R(J,J+1) T(J,J+15) = SK * L / 2. T(J+1,J+16) = SK * L / 2. T(J,J+16) = (SOK - 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 + R(J+1,J)*R(J,J)) T(5,J*(J+3)/2) = - 0.5*R(J,J+1)*R(J+1,J) T(5,J*(J+3)/2+1) = - 0.25*(L + R(J,J)*R(J,J+1)) IF (J .NE. JH) GO TO 5000 J = 4 - JH IF (HTGQ) KQ2 = K2V GO TO 510 C C 14. -- ARBITRARY MATRIX C 1400 IF (DATA(I+8) .NE. 0.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)*UNIT(J1)/(UNIT(J)*UNIT(K)) IND = IND + K IX = IX + 1 1408 CONTINUE 1410 CONTINUE 1420 IF (NUM + 1 .GT. NEL) GO TO 5100 IPNOTY = ISTOR(NUM+1) IF (IFIX(DATA(IPNOTY)) .EQ. 14) RETURN GO TO 5100 C C 18. -- SEXTUPOLE C 1800 W2 = 2.*B/(RI*AP**2) S = - W2*(0.5*L)**2 T(JH,1+5*JD) = SIG*S T(JH+1,1+5*JD) = 2.0*SIG*S/L S = - W2 * L **4 / 24. T(JH,3+7*JD) = SIG*S T(JH+1,3+7*JD) = 4.0*SIG*S/L S = W2 * (L / 2.) **2 T(JH,6-5*JD) = SIG*S T(JH+1,6-5*JD) = 2.0*SIG*S/L S = W2 * L **4 / 24. T(JH,10-7*JD) = SIG*S T(JH+1,10-7*JD) = 4.0*SIG*S/L S = - W2 * L **3 / 6. T(JH,2+7*JD) = SIG*S T(JH+1,2+7*JD) = 3.0*SIG*S/L S = W2 * L **3 / 6. T(JH,9-7*JD) = SIG*S T(JH+1,9-7*JD) = 3.0*SIG*S/L S = W2 * L **2 / 2. T(JU,4) = SIG*S T(JU+1,4) = 2.0*SIG*S/L S = W2 * L **3 / 6. T(JU,4+JH) = SIG*S T(JU,4+JU) = SIG*S T(JU+1,4+JH) = 3.0*SIG*S/L T(JU+1,4+JU) = 3.0*SIG*S/L S = W2 * L **4 / 12. T(JU,8) = SIG*S T(JU+1,8) = 4.0*SIG*S/L T(5,3) = - 0.5*L T(5,10) = - 0.5*L GO TO 5000 C C 19. -- SOLENOID C 1900 B = DATA(I+2)*UNIT(9)*RI/PREF 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 C C PATH LENGTH TERMS C 5000 T(5,21) = T(5,21) - L*(SM**2 + 1.5*RI**2)*SM**2/ 1 (SM**2 + RI**2)**2 T(5,20) = SM**2/(SM**2 + RI**2) C C CHANGE TRIANGULAR MATRIX INTO SQUARE MATRIX C 5100 DO 5150 IA = 1, 5 IND = 0 DO 5150 IC = 2, 6 ICM1 = IC - 1 IND = IND + 1 DO 5150 IB = 1, ICM1 IND = IND + 1 T(IA,IND) = 0.5*T(IA,IND) 5150 CONTINUE IF (NORD1 .GE. 3) CALL THOR 5200 CONTINUE RETURN END REAL FUNCTION SIGNF(X) IF (X) 1, 2, 1 1 SIGNF = SIGN(1.,X) RETURN 2 SIGNF = 0. RETURN END SUBROUTINE SOLVE COMMON /BLOC2/ NIN, NOUT, NPUNCH COMMON /BLOC28/ COC, DE0, SD, CTY, JV, NC, NV1, NV2, NV3 INTEGER CTY COMMON /BLOC29/ A(21), CW, CA(21,21), SCALE(21), CASAV(21,21), 1 PMARQ, CHSMIN, XNORM, GNORM, EPS COMMON /BLOC30/ CDB, NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, 1 LCPR, ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, 2 LAY191, NPFR INTEGER CDB LOGICAL NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, LCPR, 1 ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, LAY191 COMMON /BLOC34/ NORD1, NORD2, NORD3, NORDX, LINEAR, JH, SIG LOGICAL LINEAR COMMON /BLOC48/ NUMB, NUME, NCT, NCTV, NCTC, NCTS, NCTF LOGICAL OK REAL CS(21) REAL OUTPUT(20) C IF (.NOT. ONLY) WRITE (NOUT,1000) 1000 FORMAT (14H0*CORRECTIONS*) C C INITIALIZE VARIABLES AND MAKE FIRST PASS C IF (NCTV .EQ. 1) GO TO 10 NCTS = 1 NCTF = NCTV - 1 CALL DERIVE CALL RETAIN 10 NCTS = NCTV NCTF = NCTC NSTEP = 0 OK = .FALSE. NV2 = 0 CHSMIN = - 1.0 CALL FORM N1P1 = NV1 + 1 NMAR = 0 PAR = 0.0 PMARQ = PAR IF (LINEAR) GO TO 100 CRIT = AMAX0(1,NC-NV1) C C ITERATE FROM HERE IF NEW LOW CHI-SQUARED FOUND C 20 NSTEP = NSTEP + 1 IF (NSTEP .GT. 50) GO TO 200 CS(1) = CA(1,1) IF (CA(1,1) .LT. CRIT) GO TO 100 IF (NMAR .EQ. 0) PMARQ = 0.0 IF (NMAR .GE. 1) PMARQ = PAR*(2.0**NMAR - 1.0) CALL INQ IF (NMAR .NE. 0) GO TO 35 PAR = PMARQ PMARQ = 0.0 35 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) NMARO = NMAR CALL FORM CRIT = AMAX0(1,NC-NV1) IF (CA(1,1) .LT. CRIT) GO TO 100 IF (DS .EQ. 0.0) GO TO 200 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 C R = (CS(1) - CA(1,1))/DS IF (R .GT. 0.8 .AND. DS .LT. AMIN1(0.1*CA(1,1),CRIT) 1 .AND. NMAR .EQ. 0) GO TO 100 IF (DS .LT. CRIT .AND. GNORM .LT. 0.1*GOLD) 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. (XNORM .LT. 0.00001 .OR. PMARQ .GT. 0.5)) 1 GO TO 200 NMAR = NMAR + 1 IF (R .GT. 0.0) GO TO 20 90 DO 92 J = 2, N1P1 DO 92 K = 1, N1P1 92 CA(J,K) = CASAV(J,K) IF (NMAR .EQ. 0) PMARQ = 0.0 IF (NMAR .GE. 1) PMARQ = PAR*(2.0**NMAR - 1.0) CALL INQ IF (NMAR .EQ. 0) PAR = PMARQ DO 95 J = 2, N1P1 95 CS(J) = - CS(J) EPS = - 0.5**NMARO CALL ALTER(CS) DO 96 J = 2, N1P1 96 CS(J) = CA(J,1) EPS = 0.5**NMAR 97 CALL ALTER(CS) NMARO = NMAR CALL FORM CRIT = AMAX0(1,NC-NV1) IF (OK) GO TO 210 IF (CA(1,1) .LT. CRIT) GO TO 100 IF (CA(1,1) - CS(1)) 20, 80, 80 C C FITTING PROCEDURE SATISFIES CONVERGENCE TEST C 100 OK = .TRUE. IF (NMAR .EQ. 0) PMARQ = 0.0 IF (NMAR .GE. 1) PMARQ = PAR*(2.0**NMAR - 1.0) CALL INQ DO 140 J = 2, N1P1 140 CS(J) = CA(J,1) EPS = 0.5**NMAR CALL ALTER(CA) CALL FORM IF (LINEAR) GO TO 210 IF (CA(1,1) .LT. CS(1)) GO TO 210 DO 145 J = 2, N1P1 145 CS(J) = - CS(J) GO TO 97 C C CONCLUSION OF FITTING - PRINT OUT RESULT C 200 WRITE (NOUT,1012) 1012 FORMAT (9H0*FAILED*) C 210 PMARQ = 0.0 CALL INQ WRITE (NOUT,1013) CA(1,1) 1013 FORMAT (18H0*COVARIANCE (FIT,E12.5,2H )) IF (NV1 .LT. 1 .OR. ONLY) RETURN DO 250 J = 2, N1P1 CA(1,J) = SQRT(CA(J,J)) 250 CONTINUE DO 300 J = 2, N1P1 JMIN1 = J - 1 IF (J .GE. 3) GO TO 270 WRITE (NOUT,1020) CA(1,J) GO TO 300 270 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) 300 CONTINUE RETURN END SUBROUTINE SPESHL(JA) COMMON /BLOC1/ NEL, NUM, NDIF, I, ISTOR(3129), DATA(13160) COMMON /BLOC4/ LC, TOTANG, TOTROT, LCV(20), LUP(3) REAL LC, LCV, LUP COMMON /BLOC5/ VSTOR(20), TIE(13160), LABEL(3129), LABM(10) INTEGER VSTOR, TIE COMMON /BLOC21/ EN, ES, BE, APB(2), LAYK, LAYL, LAYX, RABT REAL LAYK, LAYL, LAYX COMMON /BLOC26/ O(4,3,3), X0(4,3), IR, RORC, TYT, ALIGN, TMK, 1 FEO, CHORD INTEGER RORC, TYT LOGICAL ALIGN, TMK, FEO, CHORD COMMON /BLOC28/ COC, DE0, SD, CTY, JV, NC, NV1, NV2, NV3 INTEGER CTY COMMON /BLOC32/ UNIT(12), XDIME(12) COMMON /BLOC33/ FOTILT, SM, TH, PREF COMMON /BLOC36/ VARS(8), SEXMAX, SEXLIM INTEGER VARS LOGICAL SEXLIM COMMON /BLOC50/ BDBI, LAYKI, LAYLI, LAYXI, RAB1I, RAB2I, RMPSI, 1 VRNI, NPNI, BDBPI, RNMSI REAL LAYKI, LAYLI, LAYXI, NPNI C J = JA GO TO (10,20,30,40,40,60,70,80,90,100,110,120,130,140,150, 1 160,160,160,190,200,210,220,230,240,250,260,900), J C C BENDING MAGNET FIELD SECOND DERIVATIVE C 10 BDBI = DATA(I+2) VARS(7) = TIE(I+2) RETURN C C FRINGING FIELD TRANSVERSE DISPLACEMENT INTEGRAL C 20 LAYKI = DATA(I+2) RETURN C C PARTICLE MASS C 30 SM = DATA(I+2) * UNIT(10) RETURN C C BENDING MAGNET APERTURES C 40 APB(J-3) = DATA(I+2) * UNIT(2*J-7) RETURN C C CUMULATIVE LENGTH OF SYSTEM C 60 LC = DATA(I+2) * UNIT(8) IF (NV1 .LT. 1) RETURN DO 65 N = 1, NV1 LCV(N) = 0.0 65 CONTINUE RETURN C C FRINGING FIELD INTEGRALS C 70 LAYLI = DATA(I+2) RETURN 80 LAYXI = DATA(I+2) RETURN C C JUNK C 90 RDL = DATA(I+2) RETURN 100 RDB = DATA(I+2) RETURN 110 RDT = DATA(I+2) RETURN C C BENDING MAGNET ENTRANCE AND EXIT FACE CURVATURES C 120 RAB1I = DATA(I+2) VARS(1) = TIE(I+2) RETURN C 130 RAB2I = DATA(I+2) VARS(2) = TIE(I+2) RETURN C C SEED FOR RANDOM NUMBER GENERATOR C 140 CALL RANSET(DATA(I+2)) RETURN C C TILT OF FOCAL PLANE C 150 FOTILT = DATA(I+2) RETURN C C FLOOR COORDINATES OF BEGINNING OF BEAM C 160 J = J - 15 X0(4,J) = DATA(I+2)*UNIT(8) RETURN C C INITIAL DIRECTION OF BEAM LINE C 190 TH = DATA(I+2)*UNIT(7) 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 RETURN C 200 PH = DATA(I+2)*UNIT(7) 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 RETURN C C REFERENCE MOMENTUM FOR WHICH MAGNETIC FIELDS ARE SET C 210 PREF = DATA(I+2)*UNIT(11) RETURN C C EXCESS FIELD OF A BENDING MAGNET C 220 RMPSI = DATA(I+2) VARS(3) = TIE(I+2) RETURN C C VERTICALLY BENDING FIELD OF A BENDING MAGNET C 230 VRNI = DATA(I+2) VARS(5) = TIE(I+2) RETURN C C NORMALIZED MIDPLANE-ANTISYMMETRIC QUADRUPOLE COMPONENT C 240 NPNI = DATA(I+2) VARS(6) = TIE(I+2) RETURN C C NORMALIZED MIDPLANE-ANTISYMMETRIC SEXTUPOLE COMPONENT C 250 BDBPI = DATA(I+2) VARS(8) = TIE(I+2) RETURN C C MULTIPLICATAVE CONSTANT FOR NON-MIDPLANE-SYMMETRIC MULTIPOLES C 260 RNMSI = DATA(I+2) VARS(4) = TIE(I+2) RETURN C C UNDEFINED OPERATIONS C 900 RETURN END SUBROUTINE SQUIRM COMMON /BLOC1/ NEL, NUM, NDIF, I, ISTOR(3129), DATA(13160) COMMON /BLOC3/ TYPE, L, LV INTEGER TYPE REAL L, LV COMMON /BLOC11/ R(6,6), RV(6,6), T(5,21), TV(5,21), U(5,56), 1 UV(5,56) COMMON /BLOC16/ SI(6,6), SV(6,6,20), CO(6), COV(6,20), RI, 1 SVP(20), CVP(20), SOFA LOGICAL SVP, CVP, SOFA COMMON /BLOC17/ COD(6), COF(6), PSIX, PSIY, PSIX1, PSIY1, NOPH LOGICAL NOPH COMMON /BLOC23/ H0, AL, NB, BDB, RMPS, VRN, NPN, BDBP, RNMS, DCOV LOGICAL DCOV COMMON /BLOC24/ B, KQ2, KVK, K2H, K2V, CS, SN, DISN, DSVN, J REAL KQ2, KVK, K2H, K2V COMMON /BLOC26/ O(4,3,3), X0(4,3), IR, RORC, TYT, ALIGN, TMK, 1 FEO, CHORD INTEGER RORC, TYT LOGICAL ALIGN, TMK, FEO, CHORD COMMON /BLOC28/ COC, DE0, SD, CTY, JV, NC, NV1, NV2, NV3 INTEGER CTY COMMON /BLOC30/ CDB, NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, 1 LCPR, ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, 2 LAY191, NPFR INTEGER CDB LOGICAL NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, LCPR, 1 ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, LAY191 COMMON /BLOC32/ UNIT(12), XDIME(12) COMMON /BLOC33/ FOTILT, SM, TH, PREF COMMON /BLOC34/ NORD1, NORD2, NORD3, NORDX, LINEAR, JH, SIG LOGICAL LINEAR COMMON /BLOC40/ OV(3,3,20), X0V(3,20), OIV(3,3), XIV(3), OVP(20) LOGICAL OVP COMMON /CONSTS/ PI, RADIAN, CLIGHT, EMASS C DO 50 J = 1, 3 XIV(J) = 0.0 DO 50 K = 1, 3 OIV(J,K) = 0.0 50 CONTINUE C 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. 20) GO TO 2000 RETURN C C 2. -- POLE FACE ROTATION C 200 RETURN C C 3. -- DRIFT SPACE C 300 XIV(3) = UNIT(8) RETURN C C 4. -- BENDING MAGNET C 400 JHL = (JH + 1)/2 GO TO (410,440,470,470,470,470,470), JV C 410 IF (ANIN) GO TO 420 OIV(JHL,JHL) = - SIG*O(1,JHL,3)*H0*UNIT(8) OIV(3,3) = OIV(JHL,JHL) OIV(JHL,3) = SIG*O(1,JHL,JHL)*H0*UNIT(8) OIV(3,JHL) = - OIV(JHL,3) XIV(JHL) = - O(1,JHL,3)*UNIT(8) XIV(3) = O(1,JHL,JHL)*UNIT(8) RETURN C 420 XIV(JHL) = X0(1,JHL)*UNIT(8)/L XIV(3) = X0(1,3)*UNIT(8)/L RETURN C 440 IF (.NOT. ANIN) ADOT = L*UNIT(9)/PREF IF (ANIN) ADOT = UNIT(7) OIV(JHL,JHL) = - SIG*O(1,JHL,3)*ADOT OIV(3,3) = OIV(JHL,JHL) OIV(JHL,3) = SIG*O(1,JHL,JHL)*ADOT OIV(3,JHL) = - OIV(JHL,3) XIV(JHL) = SIG*(1.0 - O(1,JHL,JHL) - SIG*AL*O(1,JHL,3))*ADOT/ 1 (H0**2*L) XIV(3) = (AL*O(1,JHL,JHL) - SIG*O(1,JHL,3))*ADOT/(H0**2*L) RETURN C 470 RETURN C C 5. -- QUADRUPOLE C 500 IF (JV .NE. 1) RETURN XIV(3) = UNIT(8) RETURN 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) RETURN C C 14. -- ARIBTRARY MATRIX C 1400 RETURN C C 16. -- SPECIAL PARAMETERS C 1600 J = DATA(I+1) IF (JV .NE. 2) RETURN 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 RETURN C 1610 XIV(J-15) = UNIT(8) RETURN C 1620 OIV(1,1) = - O(4,1,3)*UNIT(7) OIV(3,3) = OIV(1,1) OIV(1,3) = - O(4,1,1)*UNIT(7) OIV(3,1) = - OIV(1,3) RETURN C 1630 OIV(2,2) = O(1,2,3)*UNIT(7) OIV(2,3) = - O(1,2,2)*UNIT(7) OIV(3,2) = - OIV(2,3) OIV(3,3) = OIV(2,2) RETURN C C 19. -- SOLENOID C 1900 IF (JV .NE. 1) RETURN XIV(3) = UNIT(8) RETURN C C 20. -- BEAM ROTATION C 2000 IF (REFER) RETURN DCS = - R(2,4)/RADIAN IF (NDIF .LT. 0) DCS = - DCS OIV(1,1) = DCS OIV(2,2) = DCS DSN = R(4,4)/RADIAN IF (NDIF .LT. 0) DSN = - DSN OIV(1,2) = DSN OIV(2,1) = - DSN RETURN END SUBROUTINE STEER COMMON /BLOC2/ NIN, NOUT, NPUNCH COMMON /BLOC13/ RC2(6,6), R2V(6,6,20), TC2(5,21), T2V(5,21,10), 1 UC2(5,56), U2V(5,56,10), R2P, R2VP(20) LOGICAL R2P, R2VP COMMON /BLOC14/ RC3(6,6), TC3(5,21), UC3(5,56), R3P LOGICAL R3P COMMON /BLOC16/ SI(6,6), SV(6,6,20), CO(6), COV(6,20), RI, 1 SVP(20), CVP(20), SOFA LOGICAL SVP, CVP, SOFA COMMON /BLOC17/ COD(6), COF(6), PSIX, PSIY, PSIX1, PSIY1, NOPH LOGICAL NOPH COMMON /BLOC18/ SIT(6,6), CEN(6), RECENT LOGICAL RECENT COMMON /BLOC20/ ETA(6), DETA(6,20), RAY, EVP(20) LOGICAL RAY, EVP COMMON /BLOC23/ H0, AL, NB, BDB, RMPS, VRN, NPN, BDBP, RNMS, DCOV LOGICAL DCOV REAL NB, NPN COMMON /BLOC28/ COC, DE0, SD, CTY, JV, NC, NV1, NV2, NV3 INTEGER CTY COMMON /BLOC30/ CDB, NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, 1 LCPR, ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, 2 LAY191, NPFR INTEGER CDB LOGICAL NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, LCPR, 1 ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, LAY191 COMMON /BLOC34/ NORD1, NORD2, NORD3, NORDX, LINEAR, JH, SIG LOGICAL LINEAR COMMON /BLOC45/ CSH, SOKH, SKH, DISP, DDISP, CSV, SOKV, SKV INTEGER VARSP C IF (RMPS .EQ. 0.0 .AND. (RNMS .EQ. 0.0 .OR. VRN .EQ. 0.0)) 1 GO TO 100 DO 10 J = 1, 6 CO(J) = CO(J) + COD(J) 10 IF (RAY) ETA(J) = ETA(J) + COD(J) 100 JU = 4 - JH C NV2 = VARSP(4,4) IF (NV1 .EQ. 0 .OR. NV2 .EQ. 0) GO TO 200 COV(JH,NV2) = COV(JH,NV2) - SIG*DISP COV(JH+1,NV2) = COV(JH+1,NV2) - SIG*DDISP IF (.NOT. RAY) GO TO 200 DETA(JH,NV2) = DETA(JH,NV2) - SIG*DISP DETA(JH+1,NV2) = DETA(JH+1,NV2) - SIG*DDISP C 200 NV2 = VARSP(4,5) IF (NV1 .EQ. 0 .OR. NV2 .EQ. 0) GO TO 300 VN = VRN*H0 COV(JU,NV2) = COV(JU,NV2) + SIG*VN*SOKV**2/(1.0 + CSV) COV(JU+1,NV2) = COV(JU+1,NV2) + SIG*VN*SOKV IF (.NOT. RAY) GO TO 300 DETA(JU,NV2) = DETA(JU,NV2) + SIG*VN*SOKV**2/(1.0 + CSV) DETA(JU+1,NV2) = DETA(JU+1,NV2) + SIG*VN*SOKV C 300 NV2 = VARSP(4,6) IF (NV1 .EQ. 0 .OR. NV2 .EQ. 0) GO TO 400 COV(JU,NV2) = COV(JU,NV2) + SIG*RNMS*H0*SOKV**2/(1.0 + CSV) COV(JU+1,NV2) = COV(JU+1,NV2) + SIG*RNMS*H0*SOKV IF (.NOT. RAY) GO TO 400 DETA(JU,NV2) = DETA(JU,NV2) + SIG*RNMS*H0*SOKV**2/(1.0 + CSV) DETA(JU+1,NV2) = DETA(JU+1,NV2) + SIG*RNMS*H0*SOKV C 400 RECENT = .FALSE. SOFA = .TRUE. DCOV = .FALSE. RETURN END SUBROUTINE SURVEY COMMON /BLOC1/ NEL, NUM, NDIF, I, ISTOR(3129), DATA(13160) COMMON /BLOC2/ NIN, NOUT, NPUNCH COMMON /BLOC4/ LC, TOTANG, TOTROT, LCV(20), LUP(3) REAL LC, LCV, LUP COMMON /BLOC5/ VSTOR(20), TIE(13160), LABEL(3129), LABM(10) INTEGER VSTOR, TIE COMMON /BLOC26/ O(4,3,3), X0(4,3), IR, RORC, TYT, ALIGN, TMK, 1 FEO, CHORD INTEGER RORC, TYT LOGICAL ALIGN, TMK, FEO, CHORD COMMON /BLOC30/ CDB, NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, 1 LCPR, ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, 2 LAY191, NPFR INTEGER CDB LOGICAL NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, LCPR, 1 ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, LAY191 COMMON /BLOC32/ UNIT(12), XDIME(12) COMMON /CONSTS/ PI, RADIAN, CLIGHT, EMASS DIMENSION POS(3) C ALONG = LC/UNIT(8) DO 10 J = 1, 3 POS(J) = X0(4,J)/UNIT(8) 10 CONTINUE THETA = ATAN(O(4,3,1)/O(4,3,3)) IF (O(4,3,3) .GE. 0.0) GO TO 11 SHIFT = SIGN(PI,O(4,3,1)) THETA = THETA + SHIFT 11 THETA = THETA/UNIT(7) PHI = ASIN(O(4,3,2))/UNIT(7) IF (O(4,2,2) .NE. 0.0) PITCH = 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) PITCH = 0.5*PI IF (O(4,2,2) .EQ. 0.0 .AND. O(4,1,2) .LT. 0.0) PITCH = - 0.5*PI IF (O(4,2,2) .GE. 0.0) GO TO 13 SHIFT = SIGN(PI,O(4,1,2)) PITCH = PITCH + SHIFT 13 PITCH = PITCH/UNIT(7) WRITE (NOUT,1000) ALONG, XDIME(8), POS, XDIME(8), THETA, PHI, 1 PITCH, XDIME(7) IF (LAY191) 1 WRITE (NOUT,1001) LABEL(NUM), ALONG, POS, THETA, PHI, PITCH 1000 FORMAT (1H ,F10.3,1X,A4,15X,3F11.4,1X,A4,1X,3F10.3,1X,A4) 1001 FORMAT (2H %,A4,F12.5,6E22.5) LCPR = .TRUE. RETURN END SUBROUTINE TFL COMMON /BLOC26/ O(4,3,3), X0(4,3), IR, RORC, TYT, ALIGN, TMK, 1 FEO, CHORD INTEGER RORC, TYT LOGICAL ALIGN, TMK, FEO, CHORD COMMON /BLOC27/ CT(6,6), CT0(6,6), CT1(3,3), X0L(3), VM(6), 1 VMT(6), COM(6,6,10), OR(3,3), XR(3), LMIS(2,10), 2 DMC, NM LOGICAL DMC REAL LMIS DIMENSION CTL(36) EQUIVALENCE (CT(1,1),CTL(1)) C DO 397 JK = 1, 36 397 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) DO 400 J = 1, 3 DO 400 K = 1, 3 CT(2*J-1,2*K-1) = OR(J,K) S = 0.0 DO 399 N = 1, 3 S = S + OR(J,N)*CT1(N,K) 399 CONTINUE CT(2*J-1,2*K) = S 400 CONTINUE DO 402 K = 1, 3 CT(2,2*K) = OR(2,K) CT(4,2*K) = - OR(1,K) 402 CONTINUE RETURN END SUBROUTINE THOR COMMON /BLOC1/ NEL, NUM, NDIF, I, ISTOR(3129), DATA(13160) COMMON /BLOC3/ TYPE, L, LV INTEGER TYPE REAL L, LV COMMON /BLOC5/ VSTOR(20), TIE(13160), LABEL(3129), LABM(10) INTEGER VSTOR, TIE COMMON /BLOC11/ R(6,6), RV(6,6), T(5,21), TV(5,21), U(5,56), 1 UV(5,56) DIMENSION RL(36), RVL(36), TL(105), TVL(105), UL(280), 1 UVL(280) EQUIVALENCE (R(1,1),RL(1)), (RV(1,1),RVL(1)), 1 (T(1,1),TL(1)), (TV(1,1),TVL(1)), 2 (U(1,1),UL(1)), (UV(1,1),UVL(1)) COMMON /BLOC16/ SI(6,6), SV(6,6,20), CO(6), COV(6,20), RI, 1 SVP(20), CVP(20), SOFA LOGICAL SVP, CVP, SOFA COMMON /BLOC21/ EN, ES, BE, APB(2), LAYK, LAYL, LAYX, RABT REAL LAYK, LAYL, LAYX COMMON /BLOC22/ LBEND, BE1, SB, TB, TB1, NBVARY, BEFORE LOGICAL BEFORE REAL LBEND COMMON /BLOC23/ H0, AL, NB, BDB, RMPS, VRN, NPN, BDBP, RNMS, DCOV LOGICAL DCOV REAL NB, NPN COMMON /BLOC24/ B, KQ2, KVK, K2H, K2V, CS, SN, DISN, DSVN, J REAL KQ2, KVK, K2H, K2V COMMON /BLOC25/ AP, CAP, JA LOGICAL CAP COMMON /BLOC30/ CDB, NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, 1 LCPR, ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, 2 LAY191, NPFR INTEGER CDB LOGICAL NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, LCPR, 1 ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, LAY191 COMMON /BLOC31/ J1, TYP1 INTEGER TYP1 COMMON /BLOC32/ UNIT(12), XDIME(12) COMMON /BLOC33/ FOTILT, SM, TH, PREF COMMON /BLOC34/ NORD1, NORD2, NORD3, NORDX, LINEAR, JH, SIG LOGICAL LINEAR COMMON /BLOC35/ KL, KO REAL KL, KO COMMON /BLOC36/ VARS(8), SEXMAX, SEXLIM INTEGER VARS LOGICAL SEXLIM COMMON /BLOC45/ CSH, SOKH, SKH, DISP, DDISP, CSV, SOKV, SKV C JU = 4 - JH IF (JH .EQ. 1) JD = 0 IF (JH .EQ. 3) JD = 1 IF (TYPE .EQ. 14 .AND. TYP1 .EQ. 14) GO TO 1400 DO 11 IA = 1, 280 11 UL(IA) = 0.0 GO TO (5100,200,300,400,500,5200,5200,5200,5200,5200, 1 5200,5200,5200,1400,5200,5200,5200,1800,1900,5200, 2 5200,5200,5200,5200,2500,5200,5200), TYPE C C 2. -- POLE FACE ROTATION C 200 CONTINUE GO TO 5100 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 BEB = BDB/H0**2 GAB = GAM/H0**3 U(JH+1,1+9*JD) = - .5*H0**6*SOKH**3 U(JH+1,2+14*JD) = 1.5*H0**4*CSH*SOKH**2 U(JH,3+16*JD) = -.5*H0**2*SOKH**2 U(JH+1,3+16*JD) = - 1.5*H0**2*SOKH*(1.0 - H0**2*SOKH**2) U(JH,4+16*JD) = .5*SOKH*(CSH - 1.) U(JH+1,4+16*JD) = - .5*H0**2*CSH*SOKH**2 U(JH,17-10*JD) = - .5*H0**2*SOKH**2 U(JH+1,17-10*JD) = - .5*H0**2*SOKH U(JH,18-5*JD) = .5*SOKH*(CSH - 1.) U(JH,36+5*JD) = .5*H0**3*SOKH**2 U(JH+1,36+5*JD) = 1.5*H0**5*SOKH**3 U(JH,38+7*JD) = H0*SOKH**2 - .5*(1. - CSH)/H0 U(JH+1,38+7*JD) = 1.5*H0*SOKH*(1.0 - H0**2*SOKH**2) U(JH+1,37+8*JD) = -3.*H0**3*CSH*SOKH**2 U(JH,45-7*JD) = .5*(H0*SOKH**2 - (1. - CSH)/H0) U(JH+1,45-7*JD) = .5*H0*SOKH U(JH,50+JH) = - H0**2*SOKH**2 U(JH+1,50+JH) = - H0**2*SOKH*(1.0 + 1.5*H0**2*SOKH**2) U(JH+1,51+JH) = 1.5*H0**2*CSH*SOKH**2 U(JH,56) = .5*H0*SOKH**2 U(JH+1,56) = H0*SOKH*(1.0 + .5*H0**2*SOKH**2) U(JU+1,11-2*JD) = .5*H0**4*SOKH**2 U(JU+1,12+3*JD) = - H0**2*CSH*SOKH U(JU,13+5*JD) = .5*(SOKH - L) U(JU+1,13+5*JD) = -.5*H0**2*SOKH**2 U(JU+1,42-2*JD) = -H0**3*SOKH**2 U(JU,20-16*JD) = .5*(SOKH - L) U(JU,43) = (1.0 - CSH)/H0 U(JU+1,43) = H0*CSH*SOKH U(JU+1,51+JU) = .5*H0**2*SOKH**2 GO TO 5000 C C 5. -- QUADRUPOLE C 500 J = JH KQ2 = K2H 510 IF (J .EQ. 1) JD = 0 IF (J .EQ. 3) JD = 1 JO = 4 - J CS = R(J,J) SK = - R(J+1,J) SOK = R(J,J+1) CSO = R(JO,JO) SKO = - R(JO+1,JO) SOKO = R(JO,JO+1) U(J,1+9*JD) = KQ2**2*(13.*CS*SOK**2 - 9.*L*SOK)/48. U(J,2+14*JD) = KQ2*(- 22.*SOK + 26.*KQ2*SOK**3 + 6.*L*CS)/32. U(J,3+16*JD) = - KQ2*(13.*CS*SOK**2 + 3.*L*SOK)/16. U(J,4+16*JD) = (- 9.*SOK - 13.*KQ2*SOK**3 + 9.*L*CS)/48. U(J,8-3*JD) = KQ2**2*(- 3.*CS*SOKO**2 + 2.*L*SOK 1 - 3.*SOK*SOKO*CSO)/16. U(J,14-8*JD) = 3.*KQ2*(- CS*CSO*SOKO + SOK - KQ2*SOK*SOKO**2)/ 1 8. U(J,17-10*JD) = - KQ2*(3.*CS*SOKO**2 + 2.*L*SOK 1 + 3.*SOK*CSO*SOKO)/16. U(J,9+2*JD) = KQ2*(3.*CS*CSO*SOKO - 2.*L*CS - 3.*SOK*CSO**2 1 - 6.*SOK)/16. U(J,15-3*JD) = 3.*KQ2*(CS*SOKO**2 - SOK*CSO*SOKO)/8. U(J,18-5*JD) = (3.*CS*CSO*SOKO + 2.*L*CS - 3.*SOK*CSO**2 1 - 2.*SOK)/16. U(J+1,1+9*JD) = - KQ2**2*(7.*SOK + 15.*KQ2*SOK**3 1 + 9.*L*CS)/48. U(J+1,2+14*JD) = 3.*KQ2**2*(5.*CS*SOK**2 - L*SOK)/16. U(J+1,3+16*JD) = KQ2*(- 26.*SOK + 30.*KQ2*SOK**3 1 - 6.*L*CS)/32. U(J+1,4+16*JD) = - KQ2*(5.*CS*SOK**2 + 3.*L*SOK)/16. U(J+1,8-3*JD) = KQ2**2*(2.*L*CS - 9.*CS*CSO*SOKO - 9.*SOK 1 - 11.*KQ2*SOK*SOKO**2)/16. U(J+1,14-8*JD) = KQ2**2*(- 9.*CS*SOKO**2 - 11.*SOK*SOKO*CSO)/8. U(J+1,17-10*JD) = - KQ2*(2.*L*CS + 9.*CS*CSO*SOKO 1 + 11.*KQ2*SOK*SOKO**2 + 5.*SOK)/16. U(J+1,9+2*JD) = KQ2**2*(11.*CS*SOKO**2 + 2.*L*SOK 1 - 9.*SOK*CSO*SOKO)/16. U(J+1,15-3*JD) = KQ2*(11.*CS*CSO*SOKO - 3.*SOK 1 - 9.*KQ2*SOK*SOKO**2)/8. U(J+1,18-5*JD) = KQ2*(11.*CS*SOKO**2 - 2.*L*SOK 1 - 9.*SOK*CSO*SOKO)/16. U(J,50+J) = - KQ2*(3.*L*SOK + L**2*CS)/8. U(J,51+J) = (- KQ2*L**2*SOK + L*CS - SOK)/8. U(J+1,50+J) = KQ2*(- 5.*L*CS - 3.*SOK + KQ2*L**2*SOK)/8. U(J+1,51+J) = KQ2*(- 3.*L*SOK - L**2*CS)/8. IF (J .NE. JH) GO TO 5000 J = 4 - JH IF (HTGQ) KQ2 = K2V GO TO 510 C C 14. -- ARBITRARY MATRIX C 1400 IF (DATA(I+30) .NE. 0.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 U(J1,IND) = DATA(IX)*UNIT(J1)/(UNIT(J)*UNIT(K)*UNIT(M)) 1410 CONTINUE 1420 IF (NUM + 1 .GT. NEL) GO TO 5100 IPNOTY = ISTOR(NUM+1) IF (IFIX(DATA(IPNOTY)) .EQ. 14) RETURN GO TO 5100 C C 18. -- SEXTUPOLE C 1800 W2 = 2.0*B/(RI*AP**2) S = W2**2*L**4/48. U(1,1) = S U(2,1) = 4.0*S/L U(3,10) = S U(4,10) = 4.0*S/L S = W2**2*L**5/48. U(1,2) = S U(2,2) = 5.0*S/L U(3,16) = S U(4,16) = 5.0*S/L S = W2**2*L**6/144. U(1,3) = S U(2,3) = 6.0*S/L U(3,19) = S U(4,19) = 6.0*S/L S = W2**2*L**7/1008. U(1,4) = S U(2,4) = 7.*S/L U(3,20) = S U(4,20) = 7.*S/L S = W2**2*L**4/48. U(1,8) = S U(2,8) = 4.0*S/L U(3,5) = S U(4,5) = 4.0*S/L S = 0.025*W2**2*L**5 U(1,14) = S U(2,14) = 5.0*S/L U(3,6) = S U(4,6) = 5.0*S/L S = W2**2*L**6/240. U(1,17) = S U(2,17) = 6.0*S/L U(3,7) = S U(4,7) = 6.0*S/L S = - W2**2*L**5/240. U(1,9) = S U(2,9) = 5.0*S/L U(3,11) = S U(4,11) = 5.0*S/L S = W2**2*L**6/360. U(1,15) = S U(2,15) = 6.0*S/L U(3,12) = S U(4,12) = 6.0*S/L S = W2**2*L**7/1008. U(1,18) = S U(2,18) = 7.0*S/L U(3,13) = S U(4,13) = 7.0*S/L S = W2*(0.5*L)**2 U(JH,36+5*JD) = SIG*S U(JH+1,36+5*JD) = 2.0*SIG*S/L S = W2*L**4/24. U(JH,38+7*JD) = SIG*S U(JH+1,38+7*JD) = 4.0*SIG*S/L S = - 0.25*W2*L**2 U(JH,41-5*JD) = SIG*S U(JH+1,41-5*JD) = 2.0*SIG*S/L S = - W2*L**4/24. U(JH,45-7*JD) = SIG*S U(JH+1,45-7*JD) = 4.0*SIG*S/L S = W2*L**3/6. U(JH,37+7*JD) = SIG*S U(JH+1,37+7*JD) = 3.0*SIG*S/L S = - W2*L**3/6. U(JH,44-7*JD) = SIG*S U(JH+1,44-7*JD) = 3.0*SIG*S/L S = - 0.5*W2*L**2 U(JU,39) = SIG*S U(JU+1,39) = 2.0*SIG*S/L S = - W2*L**3/6. U(JU,39+JH) = SIG*S U(JU,39+JU) = SIG*S U(JU+1,39+JH) = 3.0*SIG*S/L U(JU+1,39+JU) = 3.0*SIG*S/L S = - W2*L**4/6. U(JU,43) = SIG*S U(JU+1,43) = 4.0*SIG*S/L GO TO 5000 C C 19. -- SOLENOID C 1900 CONTINUE GO TO 5000 C C 25. -- OCTUPOLE C 2500 AP = DATA(I+3)*UNIT(1) W2 = B/(RI*AP**3) 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 GO TO 5000 C C CHANGE PYRAMIDAL MATRIX INTO CUBIC MATRIX C 5000 CONTINUE 5100 DO 5150 IA = 1, 5 IND = 0 DO 5150 ID = 1, 6 DO 5150 IC = 1, ID DO 5150 IB = 1, IC IND = IND + 1 IF (IB .NE. IC .OR. IB .NE. ID .OR. IC .NE. ID) 1 U(IA,IND) = U(IA,IND)/3.0 IF (IB .NE. IC .AND. IB .NE. ID .AND. IC .NE. ID) 1 U(IA,IND) = U(IA,IND)/2.0 5150 CONTINUE 5200 CONTINUE RETURN END SUBROUTINE THREAD(RA,TA,UA,COR) COMMON /BLOC16/ SI(6,6), SV(6,6,20), CO(6), COV(6,20), RI, 1 SVP(20), CVP(20), SOFA LOGICAL SVP, CVP, SOFA COMMON /BLOC34/ NORD1, NORD2, NORD3, NORDX, LINEAR, JH, SIG LOGICAL LINEAR DIMENSION RA(6,6), TA(5,21), UA(5,56), COR(6) DIMENSION COT(6) C C TRANSFORMATION OF REFERENCE TRAJECTORY 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 SECOND ORDER TERMS C IF (NORD1 .EQ. 1) GO TO 200 DO 130 J = 1, 5 SS = COT(J) IND = 0 DO 110 L1 = 1, 6 DO 110 K = 1, L1 IND = IND + 1 SS = SS + TA(J,IND)*COR(K)*COR(L1) 110 CONTINUE C IND1 = 0 DO 120 L1 = 1, 5 L1P1 = L1 + 1 IND1 = IND1 + L1P1 IND = IND1 DO 120 K = L1P1, 6 SS = SS + TA(J,IND)*COR(K)*COR(L1) IND = IND + K 120 CONTINUE COT(J) = SS 130 CONTINUE C C THIRD-ORDER TERMS C IF (NORD1 .LE. 2) GO TO 200 DO 180 J = 1, 5 SS = 0.0 IND = 1 DO 160 L3 = 3, 6 IND = IND + L3 L3M1 = L3 - 1 DO 160 L2 = 2, L3M1 IND = IND + 1 L2M1 = L2 - 1 DO 160 L1 = 1, L2M1 IND = IND + 1 SS = SS + UA(J,IND)*COR(L1)*COR(L2)*COR(L3) 160 CONTINUE SS = 2.0*SS C IND = 0 DO 165 L3 = 2, 6 L3M1 = L3 - 1 IND = IND + L3M1 DO 165 L12 = 1, L3M1 IND = IND + L12 SS = SS + UA(J,IND)*COR(L12)**2*COR(L3) 165 CONTINUE C IND = 0 DO 170 L23 = 2, 6 L23M1 = L23 - 1 IND = IND + L23*(L23-1)/2 + 1 DO 170 L1 = 1, L23M1 IND = IND + 1 SS = SS + UA(J,IND)*COR(L1)*COR(L23)**2 170 CONTINUE SS = 3.0*SS C IND = 1 INDD = 3 INDDD = 3 DO 175 L123 = 1, 6 SS = SS + UA(J,IND)*COR(L123)**3 IND = IND + INDD INDD = INDD + INDDD INDDD = INDDD + 1 175 CONTINUE COT(J) = COT(J) + SS 180 CONTINUE C C RESET OFF-AXIS REFERENCE TRAJECTORY C 200 DO 220 J = 1, 6 220 COR(J) = COT(J) RETURN END SUBROUTINE THRED1(RA,COR) DIMENSION RA(6,6), COR(6) DIMENSION COT(6) C C TRANSFORMATION OF REFERENCE TRAJECTORY 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 REFERENCE TRAJECTORY C 200 DO 220 J = 1, 6 220 COR(J) = COT(J) RETURN END SUBROUTINE TWITCH COMMON /BLOC11/ R(6,6), RV(6,6), T(5,21), TV(5,21), U(5,56), 1 UV(5,56) COMMON /BLOC13/ RC2(6,6), R2V(6,6,20), TC2(5,21), T2V(5,21,10), 1 UC2(5,56), U2V(5,56,10), R2P, R2VP(20) LOGICAL R2P, R2VP COMMON /BLOC15/ RS(6,6), RT(6,6), TS(5,21), TT(5,21), US(5,56), 1 UT(5,56) DIMENSION RSL(36), RTL(36), TSL(105), TTL(105), USL(280), 1 UTL(280) EQUIVALENCE (RS(1,1),RSL(1)), (RT(1,1),RTL(1)), 1 (TS(1,1),TSL(1)), (TT(1,1),TTL(1)), 2 (US(1,1),USL(1)), (UT(1,1),UTL(1)) COMMON /BLOC16/ SI(6,6), SV(6,6,20), CO(6), COV(6,20), RI, 1 SVP(20), CVP(20), SOFA LOGICAL SVP, CVP, SOFA COMMON /BLOC17/ COD(6), COF(6), PSIX, PSIY, PSIX1, PSIY1, NOPH LOGICAL NOPH COMMON /BLOC20/ ETA(6), DETA(6,20), RAY, EVP(20) LOGICAL RAY, EVP COMMON /BLOC28/ COC, DE0, SD, CTY, JV, NC, NV1, NV2, NV3 INTEGER CTY COMMON /BLOC30/ CDB, NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, 1 LCPR, ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, 2 LAY191, NPFR INTEGER CDB LOGICAL NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, LCPR, 1 ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, LAY191 COMMON /BLOC32/ UNIT(12), XDIME(12) COMMON /BLOC34/ NORD1, NORD2, NORD3, NORDX, LINEAR, JH, SIG LOGICAL LINEAR DIMENSION COT(6), ETAT(6) 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 (NORD1 .LT. 2 .OR. NORD2 .LT. 1) GO TO 200 IF (.NOT. CVP(NV2)) GO TO 200 DO 20 J = 1, 5 IND0 = 0 IND1 = 0 DO 20 K = 1, 6 SS = 0.0 DO 10 L1 = 1, K IND0 = IND0 + 1 SS = SS + 2.0*T(J,IND0)*COV(L1,NV2) 10 CONTINUE IF (K .EQ. 6) GO TO 18 KP1 = K + 1 IND1 = IND1 + KP1 IND = IND1 DO 15 L1 = KP1, 6 SS = SS + 2.0*T(J,IND)*COV(L1,NV2) IND = IND + L1 15 CONTINUE 18 RT(J,K) = SS 20 CONTINUE DO 21 K = 1, 6 21 RT(6,K) = 0.0 C IF (NORD2 .LE. 1) GO TO 50 IF (NORD1 .GE. 3) GO TO 50 DO 40 J = 1, 105 40 TTL(J) = 0.0 GO TO 150 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 50 IF (NORD1 .LE. 2) GO TO 150 DO 95 J = 1, 5 IND0 = 0 IND1 = 0 IND2 = 2 IND2D = 4 DO 95 K = 1, 6 SS = RT(J,K) DO 60 L2 = 1, K DO 60 L1 = 1, L2 IND0 = IND0 + 1 SS = SS + 3.0*U(J,IND0)*(CO(L1)*COV(L2,NV2) + COV(L1,NV2)*CO(L2)) 60 CONTINUE C IF (K .EQ. 6) GO TO 90 KP1 = K + 1 INDA1 = IND1 INDD1 = K*KP1/2 DO 70 L2 = KP1, 6 INDA1 = INDA1 + INDD1 INDD1 = INDD1 + L2 IND = INDA1 DO 70 L1 = 1, K IND = IND + 1 SS = SS + 3.0*U(J,IND)*(CO(L1)*COV(L2,NV2) + COV(L1,NV2)*CO(L2)) 70 CONTINUE IND1 = IND1 + K*(K+3)/2 C INDA2 = IND2 IND2 = IND2 + IND2D IND2D = IND2D + K + 2 INDAD = KP1*(K+2)/2 DO 80 L1 = KP1, 6 IND = INDA2 INDA2 = INDA2 + INDAD INDAD = INDAD + L1 + 1 INDD = L1*(L1-1)/2 DO 80 L2 = L1, 6 IND = IND + INDD INDD = INDD + L2 SS = SS + 3.0*U(J,IND)*(CO(L1)*COV(L2,NV2) + COV(L1,NV2)*CO(L2)) 80 CONTINUE 90 RT(J,K) = SS 95 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 100 IF (NORD2 .LE. 1) GO TO 150 DO 140 J = 1, 5 INC = 0 IND1 = 0 IND2 = 0 IND2D = 1 IND3 = 0 IND3D = 2 DO 140 K = 1, 6 IND2A = IND2 IND2 = IND2 + IND2D IND2D = IND2D + K + 1 IND3A = IND3 IND3 = IND3 + IND3D IND3D = IND3D + K + 2 DO 140 L1 = 1, K INC = INC + 1 SS = 0.0 DO 110 L2 = 1, L1 IND1 = IND1 + 1 SS = SS + 3.0*U(J,IND1)*COV(L2,NV2) 110 CONTINUE C IF (L1 .EQ. 6) GO TO 135 IF (L1 .EQ. K) GO TO 125 L1P1 = L1 + 1 IND2A = IND2A + L1 + 1 IND = IND2A DO 120 L2 = L1P1, K SS = SS + 3.0*U(J,IND)*COV(L2,NV2) IND = IND + L2 120 CONTINUE C 125 IF (K .EQ. 6) GO TO 135 KP1 = K + 1 IND3A = IND3A + 1 IND = IND3A INDD = K*KP1/2 DO 130 L2 = KP1, 6 IND = IND + INDD INDD = INDD + L2 SS = SS + 3.0*U(J,IND)*COV(L2,NV2) 130 CONTINUE 135 TT(J,INC) = SS 140 CONTINUE C IF (NORD2 .LE. 2) GO TO 150 DO 145 J = 1, 5 DO 145 K = 1, 56 145 UT(J,K) = 0.0 C 150 R2VP(NV2) = .TRUE. C C TRANSFORM DERIVATIVE OF REFERENCE TRAJECTORY DISPLACEMENT C 200 IF (.NOT. EVP(NV2)) GO TO 300 DO 210 J = 1, 6 SS = 0.0 DO 205 K = 1, 6 SS = SS + R(J,K)*DETA(K,NV2) 205 CONTINUE ETAT(J) = SS 210 CONTINUE C C SECOND ORDER TERMS C IF (NORD1 .EQ. 1) GO TO 280 DO 240 J = 1, 5 SS = ETAT(J) IND = 0 DO 220 L1 = 1, 6 DO 220 K = 1, L1 IND = IND + 1 SS = SS + 2.0*T(J,IND)*ETA(K)*DETA(L1,NV2) 220 CONTINUE C IND1 = 0 DO 230 L1 = 1, 5 L1P1 = L1 + 1 IND1 = IND1 + L1P1 IND = IND1 DO 230 K = L1P1, 6 SS = SS + 2.0*T(J,IND)*ETA(K)*DETA(L1,NV2) IND = IND + K 230 CONTINUE ETAT(J) = SS 240 CONTINUE C C THIRD-ORDER TERMS C IF (NORD1 .LE. 2) GO TO 280 DO 270 J = 1, 5 SS = 0.0 IND = 1 DO 245 L3 = 3, 6 IND = IND + L3 L3M1 = L3 - 1 DO 245 L2 = 2, L3M1 IND = IND + 1 L2M1 = L2 - 1 DO 245 L1 = 1, L2M1 IND = IND + 1 SS = SS + 3.0*U(J,IND)*ETA(L1)*ETA(L2)*DETA(L3,NV2) 245 CONTINUE SS = 2.0*SS C IND = 0 DO 250 L3 = 2, 6 L3M1 = L3 - 1 IND = IND + L3M1 DO 250 L12 = 1, L3M1 IND = IND + L12 SS = SS + U(J,IND)*(ETA(L12)**2*DETA(L3,NV2) 1 + 2.0*ETA(L12)*ETA(L3)*DETA(L12,NV2)) 250 CONTINUE C IND = 0 DO 260 L23 = 2, 6 L23M1 = L23 - 1 IND = IND + L23*(L23-1)/2 + 1 DO 260 L1 = 1, L23M1 IND = IND + 1 SS = SS + U(J,IND)*(2.0*ETA(L1)*ETA(L23)*DETA(L23,NV2) 1 + 2.0*ETA(L23)**2*DETA(L1,NV2)) 260 CONTINUE SS = 3.0*SS C IND = 1 INDD = 3 INDDD = 3 DO 265 L123 = 1, 6 SS = SS + 3.0*U(J,IND)*ETA(L123)**2*DETA(L123,NV2) IND = IND + INDD INDD = INDD + INDDD INDDD = INDDD + 1 265 CONTINUE ETAT(J) = ETAT(J) + SS 270 CONTINUE C 280 DO 285 J = 1, 6 285 DETA(J,NV2) = ETAT(J) C C TRANSFORM DERIVATIVE OF ETA C 300 IF (.NOT. CVP(NV2)) GO TO 400 DO 310 J = 1, 6 SS = 0.0 DO 305 K = 1, 6 SS = SS + R(J,K)*COV(K,NV2) 305 CONTINUE COT(J) = SS 310 CONTINUE C C SECOND ORDER TERMS C IF (NORD1 .EQ. 1) GO TO 380 DO 340 J = 1, 5 SS = COT(J) IND = 0 DO 320 L1 = 1, 6 DO 320 K = 1, L1 IND = IND + 1 SS = SS + 2.0*T(J,IND)*CO(K)*COV(L1,NV2) 320 CONTINUE C IND1 = 0 DO 330 L1 = 1, 5 L1P1 = L1 + 1 IND1 = IND1 + L1P1 IND = IND1 DO 330 K = L1P1, 6 SS = SS + 2.0*T(J,IND)*CO(K)*COV(L1,NV2) IND = IND + K 330 CONTINUE COT(J) = SS 340 CONTINUE C C THIRD-ORDER TERMS C IF (NORD1 .LE. 2) GO TO 380 DO 370 J = 1, 5 SS = 0.0 IND = 1 DO 345 L3 = 3, 6 IND = IND + L3 L3M1 = L3 - 1 DO 345 L2 = 2, L3M1 IND = IND + 1 L2M1 = L2 - 1 DO 345 L1 = 1, L2M1 IND = IND + 1 SS = SS + 3.0*U(J,IND)*CO(L1)*CO(L2)*COV(L3,NV2) 345 CONTINUE SS = 2.0*SS C IND = 0 DO 350 L3 = 2, 6 L3M1 = L3 - 1 IND = IND + L3M1 DO 350 L12 = 1, L3M1 IND = IND + L12 SS = SS + U(J,IND)*(CO(L12)**2*COV(L3,NV2) 1 + 2.0*CO(L12)*CO(L3)*COV(L12,NV2)) 350 CONTINUE C IND = 0 DO 360 L23 = 2, 6 L23M1 = L23 - 1 IND = IND + L23*(L23-1)/2 + 1 DO 360 L1 = 1, L23M1 IND = IND + 1 SS = SS + U(J,IND)*(2.0*CO(L1)*CO(L23)*COV(L23,NV2) 1 + 2.0*CO(L23)**2*COV(L1,NV2)) 360 CONTINUE SS = 3.0*SS C IND = 1 INDD = 3 INDDD = 3 DO 365 L123 = 1, 6 SS = SS + 3.0*U(J,IND)*CO(L123)**2*COV(L123,NV2) IND = IND + INDD INDD = INDD + INDDD INDDD = INDDD + 1 365 CONTINUE COT(J) = COT(J) + SS 370 CONTINUE C 380 DO 385 J = 1, 6 385 COV(J,NV2) = COT(J) C 400 RETURN END SUBROUTINE UNITS(J) COMMON /BLOC1/ NEL, NUM, NDIF, I, ISTOR(3129), DATA(13160) COMMON /BLOC32/ UNIT(12), XDIME(12) COMMON /CONSTS/ PI, RADIAN, CLIGHT, EMASS COMMON /UORIG/ UORIG(12), XORIG(12) C IF (J .EQ. 0) GO TO 300 XDIME(J) = DATA(I+2) UNIT(J) = UORIG(J)*DATA(I+3) IF (J .EQ. 10 .OR. J .EQ. 11) UNIT(J) = UNIT(J)/CLIGHT C IF (J .GE. 3) GO TO 150 UNIT(J+2) = UNIT(J) XDIME(J+2) = XDIME(J) 150 RETURN C C RESET UNITS, EMPTY TYPE 15 CARD ENCOUNTERED C 300 UORIG(7) = 1.0/RADIAN UORIG(10) = EMASS UORIG(12) = 1.0/RADIAN DO 310 II = 1, 12 UNIT(II) = UORIG(II) XDIME(II) = XORIG(II) 310 CONTINUE UNIT(10) = UNIT(10)/CLIGHT UNIT(11) = UNIT(11)/CLIGHT RETURN END SUBROUTINE UPDATE COMMON /BLOC12/ RC(6,6), RCV(6,6,20), TC(5,21), UC(5,56), RCP, 1 RVP(20) LOGICAL RCP, RVP COMMON /BLOC13/ RC2(6,6), R2V(6,6,20), TC2(5,21), T2V(5,21,10), 1 UC2(5,56), U2V(5,56,10), R2P, R2VP(20) LOGICAL R2P, R2VP COMMON /BLOC14/ RC3(6,6), TC3(5,21), UC3(5,56), R3P LOGICAL R3P COMMON /BLOC26/ O(4,3,3), X0(4,3), IR, RORC, TYT, ALIGN, TMK, 1 FEO, CHORD INTEGER RORC, TYT LOGICAL ALIGN, TMK, FEO, CHORD COMMON /BLOC28/ COC, DE0, SD, CTY, JV, NC, NV1, NV2, NV3 INTEGER CTY C IF (NORD3 .GE. 1) CALL UPSIG RCP = .FALSE. R2P = .FALSE. R3P = .FALSE. IF (NV1 .LT. 1) GO TO 200 DO 100 N = 1, NV1 RVP(N) = .FALSE. R2VP(N) = .FALSE. 100 CONTINUE 200 RETURN END SUBROUTINE UPDAT2 COMMON /BLOC12/ RC(6,6), RCV(6,6,20), TC(5,21), UC(5,56), RCP, 1 RVP(20) LOGICAL RCP, RVP DIMENSION RCL(36), RCVL(36,20), TCL(105), UCL(280) EQUIVALENCE (RC(1,1),RCL(1)), (RCV(1,1,1),RCVL(1,1)), 1 (TC(1,1),TCL(1)), (UC(1,1),UCL(1)) COMMON /BLOC13/ RC2(6,6), R2V(6,6,20), TC2(5,21), T2V(5,21,10), 1 UC2(5,56), U2V(5,56,10), R2P, R2VP(20) LOGICAL R2P, R2VP DIMENSION RC2L(36), R2VL(36,20), TC2L(105), T2VL(105,10), 1 UC2L(280), U2VL(280,10) EQUIVALENCE (RC2(1,1),RC2L(1)), (R2V(1,1,1),R2VL(1,1)), 1 (TC2(1,1),TC2L(1)), (T2V(1,1,1),T2VL(1,1)), 2 (UC2(1,1),UC2L(1)), (U2V(1,1,1),U2VL(1,1)) COMMON /BLOC14/ RC3(6,6), TC3(5,21), UC3(5,56), R3P LOGICAL R3P DIMENSION RC3L(36), TC3L(105), UC3L(280) EQUIVALENCE (RC3(1,1),RC3L(1)), (TC3(1,1),TC3L(1)), 1 (UC3(1,1),UC3L(1)) COMMON /BLOC15/ RS(6,6), RT(6,6), TS(5,21), TT(5,21), US(5,56), 1 UT(5,56) DIMENSION RSL(36), RTL(36), TSL(105), TTL(105), USL(280), 1 UTL(280) EQUIVALENCE (RS(1,1),RSL(1)), (RT(1,1),RTL(1)), 1 (TS(1,1),TSL(1)), (TT(1,1),TTL(1)), 2 (US(1,1),USL(1)), (UT(1,1),UTL(1)) COMMON /BLOC19/ TR(5,6,6), TRA(5,6,6), URR(5,21,6), NORDE COMMON /BLOC26/ O(4,3,3), X0(4,3), IR, RORC, TYT, ALIGN, TMK, 1 FEO, CHORD INTEGER RORC, TYT LOGICAL ALIGN, TMK, FEO, CHORD COMMON /BLOC28/ COC, DE0, SD, CTY, JV, NC, NV1, NV2, NV3 INTEGER CTY COMMON /BLOC34/ NORD1, NORD2, NORD3, NORDX, LINEAR, JH, SIG LOGICAL LINEAR C IF (R3P) CALL UPDAT3 IF (NORD2 .LT. 1) GO TO 280 C C BEAM UPDATE C 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 CALL CAB(RS,RC2,RCVL(1,N)) 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 CALL CAB(RS,R2VL(1,N),RC) IF (RVP(N)) GO TO 160 142 DO 150 JK = 1, 36 150 RCVL(JK,N) = RSL(JK) GO TO 180 C 160 DO 165 JK = 1, 36 165 RCVL(JK,N) = RCVL(JK,N) + RSL(JK) 180 CONTINUE RVP(N) = RVP(N) .OR. R2VP(N) R2VP(N) = .FALSE. 190 CONTINUE C C ACCUMULATED R C 200 IF (RCP) GO TO 230 DO 210 JK = 1, 36 210 RCL(JK) = RC2L(JK) IF (NORD2 .EQ. 1) GO TO 280 DO 220 JKM = 1, 105 220 TCL(JKM) = TC2L(JKM) IF (NORD2 .LE. 2) GO TO 280 DO 225 JKLM = 1, 280 225 UCL(JKLM) = UC2L(JKLM) GO TO 280 C 230 IF (NORD2 .GE. 2) GO TO 240 CALL CAB(RS,RC2,RC) GO TO 250 240 IF (NORD2 .GT. 2) GO TO 245 CALL CAB2(RS,TS,RC2,TC2,RC,TC,.FALSE.) GO TO 250 245 CALL CAB3(RS,TS,US,RC2,TC2,UC2,RC,TC,UC,.FALSE.) 250 DO 260 JK = 1, 36 260 RCL(JK) = RSL(JK) IF (NORD2 .EQ. 1) GO TO 280 DO 270 JKM = 1, 105 270 TCL(JKM) = TSL(JKM) IF (NORD2 .LE. 2) GO TO 280 DO 275 JKLM = 1, 280 275 UCL(JKLM) = USL(JKLM) 280 RCP = RCP .OR. R2P R2P = .FALSE. RETURN END SUBROUTINE UPDAT3 COMMON /BLOC13/ RC2(6,6), R2V(6,6,20), TC2(5,21), T2V(5,21,10), 1 UC2(5,56), U2V(5,56,10), R2P, R2VP(20) LOGICAL R2P, R2VP DIMENSION RC2L(36), R2VL(36,20), TC2L(105), T2VL(105,10), 1 UC2L(280), U2VL(280,10) EQUIVALENCE (RC2(1,1),RC2L(1)), (R2V(1,1,1),R2VL(1,1)), 1 (TC2(1,1),TC2L(1)), (T2V(1,1,1),T2VL(1,1)), 2 (UC2(1,1),UC2L(1)), (U2V(1,1,1),U2VL(1,1)) COMMON /BLOC14/ RC3(6,6), TC3(5,21), UC3(5,56), R3P LOGICAL R3P DIMENSION RC3L(36), TC3L(105), UC3L(280) EQUIVALENCE (RC3(1,1),RC3L(1)), (TC3(1,1),TC3L(1)), 1 (UC3(1,1),UC3L(1)) COMMON /BLOC15/ RS(6,6), RT(6,6), TS(5,21), TT(5,21), US(5,56), 1 UT(5,56) DIMENSION RSL(36), RTL(36), TSL(105), TTL(105), USL(280), 1 UTL(280) EQUIVALENCE (RS(1,1),RSL(1)), (RT(1,1),RTL(1)), 1 (TS(1,1),TSL(1)), (TT(1,1),TTL(1)), 2 (US(1,1),USL(1)), (UT(1,1),UTL(1)) COMMON /BLOC19/ TR(5,6,6), TRA(5,6,6), URR(5,21,6), NORDE COMMON /BLOC28/ COC, DE0, SD, CTY, JV, NC, NV1, NV2, NV3 INTEGER CTY COMMON /BLOC34/ NORD1, NORD2, NORD3, NORDX, LINEAR, JH, SIG LOGICAL LINEAR C C PRELIMINARY CALCULATION C IF (NORD2 .LT. 1) GO TO 300 IF (.NOT. R2P .OR. NORD2 .EQ. 1) GO TO 100 CALL PREMUL(TC3,RC2,TR) IF (NORD2 .EQ. 3) CALL PREML3(UC3,RC2,URR) C C CUMULATIVE R2 MATRIX C 100 IF (R2P) GO TO 150 DO 110 JK = 1, 36 110 RC2L(JK) = RC3L(JK) IF (NORD2 .EQ. 1) GO TO 200 DO 120 JKM = 1, 105 120 TC2L(JKM) = TC3L(JKM) IF (NORD2 .LE. 2) GO TO 300 DO 130 JKLM = 1, 280 130 UC2L(JKLM) = UC3L(JKLM) GO TO 300 C 150 IF (NORD2 .GE. 2) GO TO 160 CALL CAB(RS,RC3,RC2) GO TO 170 160 IF (NORD2 .GE. 3) GO TO 165 CALL CAB2(RS,TS,RC3,TC3,RC2,TC2,.TRUE.) GO TO 170 165 CALL CAB3(RS,TS,US,RC3,TC3,UC3,RC2,TC2,UC2,.TRUE.) 170 DO 180 JK = 1, 36 180 RC2L(JK) = RSL(JK) IF (NORD2 .EQ. 1) GO TO 200 DO 190 JKM = 1, 105 190 TC2L(JKM) = TSL(JKM) IF (NORD2 .LE. 2) GO TO 200 DO 195 JKLM = 1, 280 195 UC2L(JKLM) = USL(JKLM) C C R3 TIMES DERIVATIVE OF R2 C 200 IF (NV1 .LT. 1) GO TO 300 DO 270 N = 1, NV1 IF (.NOT. R2VP(N)) GO TO 270 IF (NORD2 .GE. 2) GO TO 220 CALL CAB(RS,RC3,R2VL(1,N)) GO TO 240 220 IF (NORD2 .GE. 3) GO TO 230 CALL CABD2(RS,TS,RC3,TC3,R2VL(1,N),T2VL(1,N)) GO TO 240 230 CALL CABD3(RS,TS,US,RC3,TC3,UC3,R2VL(1,N),T2VL(1,N),U2VL(1,N), 1 TC2L(1)) 240 DO 250 JK = 1, 36 250 R2VL(JK,N) = RSL(JK) IF (NORD2 .EQ. 1) GO TO 270 DO 260 JKM = 1, 105 260 T2VL(JKM,N) = TSL(JKM) IF (NORD2 .LE. 2) GO TO 270 DO 265 JKLM = 1, 280 265 U2VL(JKLM,N) = USL(JKLM) 270 CONTINUE C 300 R2P = R2P .OR. R3P R3P = .FALSE. RETURN END SUBROUTINE UPMIS COMMON /BLOC13/ RC2(6,6), R2V(6,6,20), TC2(5,21), T2V(5,21,10), 1 UC2(5,56), U2V(5,56,10), R2P, R2VP(20) LOGICAL R2P, R2VP DIMENSION SIM(36,6,10) EQUIVALENCE (U2V(1,1,1),SIM(1,1,1)) COMMON /BLOC15/ RS(6,6), RT(6,6), TS(5,21), TT(5,21), US(5,56), 1 UT(5,56) COMMON /BLOC27/ CT(6,6), CT0(6,6), CT1(3,3), X0L(3), VM(6), 1 VMT(6), COM(6,6,10), OR(3,3), XR(3), LMIS(2,10), 2 DMC, NM LOGICAL DMC REAL LMIS COMMON /BLOC16/ SI(6,6), SV(6,6,20), CO(6), COV(6,20), RI, 1 SVP(20), CVP(20), SOFA LOGICAL SVP, CVP, SOFA COMMON /BLOC34/ NORD1, NORD2, NORD3, NORDX, LINEAR, JH, SIG LOGICAL LINEAR REAL FOOD(6), WORK(6,6) C C MISALIGNMENT TABLE BEAM CENTROID C IF (SOFA) GO TO 60 DO 50 N = 1, NM DO 50 M = 1, 6 DO 10 L = 1, 6 S = 0.0 DO 5 K = 1, 6 S = S + RC2(L,K)*COM(K,M,N) 5 CONTINUE FOOD(L) = S 10 CONTINUE DO 20 L = 1, 6 COM(L,M,N) = FOOD(L) 20 CONTINUE 50 CONTINUE C C MISALIGNMENT TABLE BEAM SIZE C 60 DO 100 N = 1, NM DO 100 M = 1, 6 DO 80 L1 = 1, 6 DO 80 L2 = 1, 6 S = 0.0 DO 75 L3 = 1, 6 LPL = 6*L3 + L2 - 6 S = S + RC2(L1,L3)*SIM(LPL,M,N) 75 CONTINUE WORK(L1,L2) = S 80 CONTINUE DO 90 L1 = 1, 6 DO 90 L2 = 1, L1 LPL = 6*L1 + L2 - 6 LXL = 6*L2 + L1 - 6 S = 0.0 DO 85 L3 = 1, 6 S = S + RC2(L1,L3)*WORK(L2,L3) 85 CONTINUE SIM(LPL,M,N) = S SIM(LXL,M,N) = SIM(LPL,M,N) 90 CONTINUE 100 CONTINUE RETURN END SUBROUTINE UPSIG COMMON /BLOC13/ RC2(6,6), R2V(6,6,20), TC2(5,21), T2V(5,21,10), 1 UC2(5,56), U2V(5,56,10), R2P, R2VP(20) LOGICAL R2P, R2VP COMMON /BLOC15/ RS(6,6), RT(6,6), TS(5,21), TT(5,21), US(5,56), 1 UT(5,56) COMMON /BLOC16/ SI(6,6), SV(6,6,20), CO(6), COV(6,20), RI, 1 SVP(20), CVP(20), SOFA LOGICAL SVP, CVP, SOFA COMMON /BLOC17/ COD(6), COF(6), PSIX, PSIY, PSIX1, PSIY1, NOPH LOGICAL NOPH COMMON /BLOC18/ SIT(6,6), CEN(6), RECENT LOGICAL RECENT COMMON /BLOC27/ CT(6,6), CT0(6,6), CT1(3,3), X0L(3), VM(6), 1 VMT(6), COM(6,6,10), OR(3,3), XR(3), LMIS(2,10), 2 DMC, NM LOGICAL DMC REAL LMIS COMMON /BLOC28/ COC, DE0, SD, CTY, JV, NC, NV1, NV2, NV3 INTEGER CTY COMMON /BLOC30/ CDB, NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, 1 LCPR, ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, 2 LAY191, NPFR INTEGER CDB LOGICAL NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, LCPR, 1 ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, LAY191 COMMON /BLOC34/ NORD1, NORD2, NORD3, NORDX, LINEAR, JH, SIG LOGICAL LINEAR REAL FOOD(6) 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 CALL CAB(RT,RC2,SV(1,1,N)) CALL CABT(SV(1,1,N),RC2,RT) C C EFFECT OF DERIVATIVE OF R MATRIX ON PREVIOUS BEAM PARAMETERS C CALL CABT(RT,R2V(1,1,N),RS) C IF (SVP(N)) GO TO 80 IF (SOFA) GO TO 75 DO 74 ISBK = 1, 6 COV(ISBK,N) = 0.0 74 CONTINUE 75 DO 76 JU = 1, 6 DO 76 KU = 1, 6 SV(JU,KU,N) = RT(JU,KU) + RT(KU,JU) 76 CONTINUE GO TO 95 C 80 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 95 CONTINUE SVP(N) = .TRUE. 100 CONTINUE C C NEW BEAM PARAMETERS C 110 DO 130 JU = 1, 6 DO 130 KU = 1, 6 SI(JU,KU) = SIT(JU,KU) 130 CONTINUE IF (.NOT. ACCEL) GO TO 140 PSIX1 = PSIX PSIY1 = PSIY 140 RETURN END INTEGER FUNCTION VARSP(TYPE,JV) COMMON /BLOC21/ EN, ES, BE, APB(2), LAYK, LAYL, LAYX, RABT REAL LAYK, LAYL, LAYX COMMON /BLOC22/ LBEND, BE1, SB, TB, TB1, NBVARY, BEFORE LOGICAL BEFORE REAL LBEND COMMON /BLOC36/ VARS(8), SEXMAX, SEXLIM INTEGER VARS LOGICAL SEXLIM INTEGER TYPE C IF (TYPE .EQ. 4) GO TO 200 IF (TYPE .EQ. 2) GO TO 100 VARSP = 0 RETURN C 100 IF (JV .EQ. 3) GO TO 110 VARSP = NBVARY RETURN C 110 IF (BEFORE) GO TO 120 VARSP = VARS(2) RETURN C 120 VARSP = VARS(1) RETURN C 200 NVAR = JV - 1 VARSP = VARS(NVAR) RETURN END SUBROUTINE WOBBLE COMMON /BLOC15/ RS(6,6), RT(6,6), TS(5,21), TT(5,21), US(5,56), 1 UT(5,56) COMMON /BLOC16/ SI(6,6), SV(6,6,20), CO(6), COV(6,20), RI, 1 SVP(20), CVP(20), SOFA LOGICAL SVP, CVP, SOFA COMMON /BLOC18/ SIT(6,6), CEN(6), RECENT LOGICAL RECENT COMMON /BLOC19/ TR(5,6,6), TRA(5,6,6), URR(5,21,6), NORDE DIMENSION GT(5,6,6) EQUIVALENCE (TR(1,1,1),GT(1,1,1)) COMMON /BLOC26/ O(4,3,3), X0(4,3), IR, RORC, TYT, ALIGN, TMK, 1 FEO, CHORD INTEGER RORC, TYT LOGICAL ALIGN, TMK, FEO, CHORD COMMON /BLOC27/ CT(6,6), CT0(6,6), CT1(3,3), X0L(3), VM(6), 1 VMT(6), COM(6,6,10), OR(3,3), XR(3), LMIS(2,10), 2 DMC, NM LOGICAL DMC REAL LMIS COMMON /BLOC28/ COC, DE0, SD, CTY, JV, NC, NV1, NV2, NV3 COMMON /BLOC32/ UNIT(12), XDIME(12) COMMON /BLOC34/ NORD1, NORD2, NORD3, NORDX, LINEAR, JH, SIG LOGICAL LINEAR COMMON /BLOC38/ SIOL(3,6,6), COLD(3,6), RCO(3,6,6), R2O(6,6), 1 SPO(3), RCPO(3), R2PO LOGICAL SPO, RCPO, R2PO COMMON /BLOC39/ XM(6), XMB(6), DXM(6), GXXM(6,6) C I2MOD = 2 - MOD(JV,2) IF (TYT/100 .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 .EQ. 6) GO TO 35 IF (.NOT. SPO(IR)) GO TO 20 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 20 DO 30 M = 1, 6 DO 30 N = 1, 6 S = S + GT(J,M,JV)*GT(K,N,JV)*SIOL(IR,M,N) 30 CONTINUE 35 S = 2.0*S*VM(JV)*UNIT(I2MOD) IF (SVP(NV2)) GO TO 40 SV(J,K,NV2) = S GO TO 45 40 SV(J,K,NV2) = SV(J,K,NV2) + S 45 SV(K,J,NV2) = SV(J,K,NV2) 50 CONTINUE SVP(NV2) = .TRUE. GO TO 200 C C KNOWN MISALIGNMENT C 100 DO 120 J = 1, 6 S = 0.0 IF (.NOT. FEO) S = CT(J,JV) IF (J .EQ. 6) GO TO 110 IF (.NOT. SPO(IR)) GO TO 110 DO 105 M = 1, 6 S = S + GT(J,M,JV)*COLD(IR,M) 105 CONTINUE 110 S = S*UNIT(I2MOD) IF (SVP(NV2)) GO TO 115 COV(J,NV2) = S GO TO 120 115 COV(J,NV2) = COV(J,NV2) + S 120 CONTINUE CVP(NV2) = .TRUE. C IF (NORD3 .LT. 1) GO TO 200 DO 190 J = 1, 6 DO 190 K = 1, J S = 0.0 IF (.NOT. FEO) S = CT(J,JV)*XM(K) + CT(K,JV)*XM(J) IF (J .EQ. 6) GO TO 150 DO 125 M = 1, 6 DO 125 N = 1, 6 S = S + (GT(J,M,JV)*RS(K,N) + GT(K,M,JV)*RS(J,N))*SIOL(IR,M,N) 125 CONTINUE DO 130 M = 1, 6 S = S + GXXM(J,M)*GT(K,M,JV) + GXXM(K,M)*GT(J,M,JV) 130 CONTINUE IF (.NOT. SPO(IR)) GO TO 150 S = S + CT(J,JV)*CEN(K) + CT(K,JV)*CEN(J) S = S + CT(J,JV)*XMB(K) + CT(K,JV)*XMB(J) DO 140 M = 1, 6 S = S + (XM(J)*GT(K,M,JV) + XM(K)*GT(J,M,JV))*COLD(IR,M) S = S + (DXM(J)*GT(K,M,JV) + DXM(K)*GT(J,M,JV))*COLD(IR,M) 140 CONTINUE 150 S = S*UNIT(I2MOD) IF (SVP(NV2)) GO TO 160 SV(J,K,NV2) = S GO TO 170 160 SV(J,K,NV2) = SV(J,K,NV2) + S 170 SV(K,J,NV2) = SV(J,K,NV2) 190 CONTINUE SVP(NV2) = .TRUE. C 200 RETURN END SUBROUTINE WOE COMMON /BLOC2/ NIN, NOUT, NPUNCH COMMON /BLOC4/ LC, TOTANG, TOTROT, LCV(20), LUP(3) REAL LC, LCV, LUP COMMON /BLOC5/ VSTOR(20), TIE(13160), LABEL(3129), LABM(10) COMMON /BLOC13/ RC2(6,6), R2V(6,6,20), TC2(5,21), T2V(5,21,10), 1 UC2(5,56), U2V(5,56,10), R2P, R2VP(20) LOGICAL R2P, R2VP DIMENSION SIM(36,6,10) EQUIVALENCE (U2V(1,1,1),SIM(1,1,1)) COMMON /BLOC15/ RS(6,6), RT(6,6), TS(5,21), TT(5,21), US(5,56), 1 UT(5,56) COMMON /BLOC26/ O(4,3,3), X0(4,3), IR, RORC, TYT, ALIGN, TMK, 1 FEO, CHORD INTEGER RORC, TYT LOGICAL ALIGN, TMK, FEO, CHORD COMMON /BLOC27/ CT(6,6), CT0(6,6), CT1(3,3), X0L(3), VM(6), 1 VMT(6), COM(6,6,10), OR(3,3), XR(3), LMIS(2,10), 2 DMC, NM LOGICAL DMC REAL LMIS COMMON /BLOC30/ CDB, NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, 1 LCPR, ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, 2 LAY191, NPFR INTEGER CDB LOGICAL NOR, LAY, RAT, BAX, R1P, SUPP, ONLY, TERSE, LCPR, 1 ANIN, REFER, ACCEL, UNRO, HTGQ, ELPR, LAY191 COMMON /BLOC32/ UNIT(12), XDIME(12) REAL LCM1, LCM2 DIMENSION OUTPUT(12) C IF (LCPR) GO TO 1 WORK = LC/UNIT(8) WRITE (NOUT,1004) WORK, XDIME(8) 1004 FORMAT (1H ,F10.3,1X,A4) LCPR = .TRUE. C 1 WRITE (NOUT,1010) 1010 FORMAT (1H0) IF (.NOT. CHORD) WRITE (NOUT,1007) 1007 FORMAT (41H *MISALIGNMENT ABOUT MAGNET ENTRANCE FACE) IF (CHORD) WRITE (NOUT,1008) 1008 FORMAT (33H *MISALIGNMENT ABOUT MAGNET CHORD) IF (TMK) WRITE (NOUT,1006) 1006 FORMAT (24H *PIVOT AT MAGNET CENTER) IF (FEO) WRITE (NOUT,1009) 1009 FORMAT (22H *FOCUSING EFFECT ONLY) DO 2 J = 1, 6 I2MOD = 2 - MOD(J,2) 2 OUTPUT(J) = VM(J)/UNIT(I2MOD) WRITE (NOUT,1000) 1000 FORMAT (48H *MISALIGNMENT EFFECT TABLE FOR MISALIGNMENTS OF ) WRITE (NOUT,1001) OUTPUT(1), XDIME(1), OUTPUT(2), XDIME(2), 1 OUTPUT(3), XDIME(1), OUTPUT(4), XDIME(2), 2 OUTPUT(5), XDIME(1), OUTPUT(6), XDIME(2) 1001 FORMAT (1H ,6(1X,F10.3,1X,A4,6X)) DO 100 N = 1, NM LCM1 = LMIS(1,N)/UNIT(8) LCM2 = LMIS(2,N)/UNIT(8) WRITE (NOUT,1002) LABM(N), LCM1, XDIME(8), LCM2, XDIME(8) 1002 FORMAT (17H0*MISALIGNMENT OF ,1X,A4,3H* (,F10.3,1X,A4,3H TO, 1 F10.3,1X,A4,1H)) DO 100 J = 1, 6 JJ = 7*J - 6 DO 30 K = 1, 6 IF (R2P) GO TO 10 CEO = COM(J,K,N) SIO = SQRT(SIM(JJ,K,N)) GO TO 20 10 CEO = 0.0 DO 15 L = 1, 6 CEO = CEO + RC2(J,L)*COM(L,K,N) 15 CONTINUE SIO = 0.0 DO 16 L1 = 1, 6 DO 16 L2 = 1, 6 LPL = 6*L1 + L2 - 6 SIO = SIO + RC2(J,L1)*SIM(LPL,K,N)*RC2(J,L2) 16 CONTINUE SIO = SQRT(SIO) 20 CONTINUE KL = 2*K - 1 KH = 2*K OUTPUT(KL) = CEO/UNIT(J) OUTPUT(KH) = SIO/UNIT(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 100 CONTINUE RETURN END