!- !-****************************************************************************** !- !- Copyright (c) 2009 The Gleason Works - all rights reserved. !- Original Author: Unknown !- Original Date: Unknown !- Description: Face Milling and Face Hobbing Spiral Bevel Blank Dimension !- and preliminary Cutter Specification calculations !- !-****************************************************************************** !- !- Revision 1.15 2009-05-12 16:21:15-04 rmiddleton !- Updated Header Information. !- !- Revision 1.14 2009-03-12 08:29:47-04 jhecker !- The Preliminary Secondary Face Angle calculations were bypassed. !- These were added to this blank calculation subroutine on or about !- January, 2006 (a10101.f95 version 1.10). With these preliminary calculations !- included in the code, it was found that some (not all) jobs resulted in !- incorrect Pinion Mean and Inner Toplands and Secondary Face Angles. !- !- Revision 1.13 2008-11-12 12:07:48-05 jhecker !- Modificatons were made to the logic used to calculate slot widths for SB/FS !- jobs having duplex taper. The actual slot widths are now calculated. !- !- Revision 1.12 2007-12-05 09:20:32-05 jhecker !- The Fixed Setting Gear Calculation switch can now be entered during !- Dimension Sheet calculations. Code was changed to reflect this !- change in CAGE4Win. !- !- Revision 1.11 2007-07-31 12:45:37-04 jhecker !- ( 1) Equivalencing of the Secondary Face Angle and Face Angle Junction !- to Crossing Point was added to the subroutine. !- !- ( 2) Duplication of setting variables "rad" and "blank" was eliminated. !- !- Revision 1.10 2006-01-03 08:01:20-05 jhecker !- ( 1) Added Secondary Face Angle calculations for Face Hobbing. These !- calculations were not debugged as a good test job could not be found. !- ( 2) Set cutter code (kutmx) equal to 6 so that the true Inner and Outer !- Slot Widths will be displayed on the Dimension Sheet. !- ( 3) Set wfg equal to wfgtmp when kdims=3 and kt2bl=2. !- !- Revision 1.9 2005-05-17 08:37:18-04 jhecker !- Changed logic to base whether the Gear Finishing Point Width, Pinion Outer !- Circular Thickness, or Pinion Mean Circular Thickness is given on the !- SP.A File code rather on a test checking to see which two are zero. !- This change allows the user to retain both a Point Width and Thickness on !- the file and use the code to determine which is used in the calculations. !- !- Revision 1.8 2005-02-22 06:17:09-05 jhecker !- Fix to allow the Pinion Outer Circular Thickness and Pinion Mean Circular !- Thickness to be given as input. !- !- Revision 1.7 2004-12-15 08:09:39-05 jhecker !- Modified the logic to calculate the Concave and Convex Pressure Angles as !- well as the Sum of the Pressure Angles. !- !- Revision 1.6 2004-07-12 12:24:52-04 jhecker !- Change to method of setting the FORMATE gear calculation switch (fgc0) !- !- Revision 1.5 2003-11-25 10:07:22-05 jhecker !- Revert to old way of setting the FORMATE Gear calculation switch !- !- Revision 1.4 2003-09-10 10:41:17-04 jhecker !- Modification to setting Stock Allowance. !- !- Revision 1.3 2002-12-17 14:24:43-05 jhecker !- Read in code to check to see if c1/k are given as input. !- Allow for both cutting and grinding stock allowance to be given. !- !- Revision 1.2 2002-10-23 13:08:35-04 bmiddleton !- Changed the code so that the blanks will be read from the OT section of !- the special analysis file for all types of runs except the dimension sheet. !- !- Revision 1.1 2002-10-17 13:11:28-04 jhecker !- Eliminated "call tcdata". !- !- Revision 1.0 2002-09-11 11:31:45-04 bmiddleton !- Initial revision !- !- Revision 1.1 2002-06-03 11:57:17-04 jhecker !- Fix to storing the Limit Pressure Angle - phltmp !- !- Revision 1.0 2002-03-13 14:16:15-05 jhecker !- Initial revision !- !- PROGRAM 101 - BLOCK 1 !- FORM K CHANGES - ADDITION OF METRIC CUTTERS !- - " " HELIXACT TOOTH PROPORTIONS !- !-****************************************************************************** !- subroutine a10101 ( ibmaix, msdos, mtrc, mpt, & spafl, fmd19, igt, jprnt1, kdimsi, kt2bli, atyp, & koprog ) !- USE ANGLE_MOD USE COMMON_PARAMETERS USE INI_OPERATIONS USE SPAFILEDEF USE TA101 USE TRC USE TOOL_DATA_INPUT_DEF !- TYPE (TOOLDATAINPUT) :: pobf_ToolData ! Pinion, outside blade, finishing tool data from spa file. TYPE (TOOLDATAINPUT) :: pobg_ToolData ! Pinion, outside blade, hard finishing tool data from spa file. TYPE (TOOLDATAINPUT) :: gibf_ToolData ! Gear, inside blade, finishing tool data from spa file. TYPE (TOOLDATAINPUT) :: gibg_ToolData ! Gear, inside blade, hard finishing tool data from spa file. !- CHARACTER*2 go character*4 acht(2) ! Four character "Cutter Blades Required" "STD"or "SPEC" character*4 acutm ! Cutting Method character*4 adrive ! Driving Member - "PIN", "GEAR" or "BOTH" character*4 ahand(2) ! Hand of Spiral - "LH" or "RH" - (1)=pinion, (2)=gear character*4 afkia ! Alphanumeric" Factor" - "MN" or "KI" character*4 aktt ! Alphanumeric Tooth Taper character*4 aprog ! Completing (T200) or SB/FS (A001) character*4 arot ! Direction of Rotation - "CW", "CCW", or "REV" character*4 asbd ! Alphanumeric "Strength Balanced Desired" character*4 asbo ! Alphanumeric "Strength Balanced Obtained" character*4 atap ! Alphanumeric Tooth Taper for D.S. output character*4 atyp ! Run Type (D= Dimension, S=Summary, ect...) character*4 atype ! Gear Type - blank or "NON-". Generated proerinted on D.S. character*4 dimcal ! T2000 Blank Calculations character*4 engr ! Engineer's Initials character*4 garea1 ! Geographical Area - part 1 of 7 character*4 garea2 ! Geographical Area - part 2 of 7 character*4 garea3 ! Geographical Area - part 3 of 7 character*4 garea4 ! Geographical Area - part 4 of 7 character*4 garea5 ! Geographical Area - part 5 of 7 character*4 garea6 ! Geographical Area - part 6 of 7 character*4 garea7 ! Geographical Area - part 7 of 7 character*4 sumno ! Summry Number - first of three parts character*4 sumlt ! Summry Number - second of three parts character*4 sumlta ! Summry Number - third of three parts character*4 xlet ! Summary Letter - " "=English, "M"=metric character*4 xnam1 ! Customer's Name - part 1 of 10 character*4 xnam2 ! Customer's Name - part 2 of 10 character*4 xnam3 ! Customer's Name - part 3 of 10 character*4 xnam4 ! Customer's Name - part 4 of 10 character*4 xnam5 ! Customer's Name - part 5 of 10 character*4 xnam6 ! Customer's Name - part 6 of 10 character*4 xnam7 ! Customer's Name - part 7 of 10 character*4 xnam8 ! Customer's Name - part 8 of 10 character*4 xnam9 ! Customer's Name - part 9 of 10 character*4 xnam10 ! Customer's Name - part 10 of 10 character*200 spafl ! Name of the Special Analysis File character*200 tmpfil ! Temporary file name character*200 fmd19 ! Not used !- logical r002 ! True=Completing job, False=Not Completing logical mdevs ! Not Used - True=Developed Settings, False=Undeveloped Settings INTEGER, DIMENSION(4) :: chpn ! Cutter Head Part Number INTEGER, DIMENSION(4) :: bbpn ! Blade Blank Part Number !- dimension blary(175) dimension csary1(25) dimension csary(100) dimension stary(100) dimension giary(50) dimension xmary(50) dimension ctlary(100) dimension adata(100) dimension bdata(200) dimension ddata(100) dimension edata(100) dimension fdata(200) !- As a general rule, variable names for angles end in the number "9". !- The variable names for the sine, cosine, and tangent of the angle !- begin with the letters "s", "c", and "t" respectively. REAL a1 ! Gear Cone Distance used in Face Hobbing calculations REAL a2 ! Gear Inner Cone Distance used in Face Hobbing calculations REAL aa ! Temporary storage in "call intp1s" dimension add9(2) ! Addendum Angle - (1)=pinion, (2)=gear dimension sadd9(2) dimension cadd9(2) dimension tadd9(2) REAL adg dimension adi(2) ! Inner Addendum - (1)=pinion, (2)=gear dimension adm(2) ! Mean Addendum - (1)=pinion, (2)=gear dimension adnc(2) ! Finishing Measuring Addendum (see tncf) - (1)=pinion, (2)=gear REAL adncrg ! Measuring Addendum - Gear Roughing REAL adncrp ! Measuring Addendum - Pinion Roughing dimension ado(2) ! Outer Addendum - (1)=pinion, (2)=gear REAL adp ! Pinion Mean Addendum dimension adt(2) ! Addendum at the point for which calculations are being made. (1=P, 2=G) REAL ai ! Inner Cone Distance - Gear REAL aip ! Inner Cone Distance - Pinion REAL alf ! Face Hobbing "alpha = ec/rcn" REAL am ! Mean Cone Distance - Gear REAL amp ! Mean Cone Distance - Pinion REAL ao ! Outer Cone Distance - Gear REAL aop ! Outer Cone Distance - Pinion REAL ap1 ! Temporary value dimension ar(2) ! Temporary value REAL at ! Gear Cone Distance at the point for which calculations are being made REAL axin ! Involute Cone Distance REAL axoam ! Ratio of the Involute Cone Distance to the Mean Cone Distance REAL axoao ! Ratio of the Involute Cone Distance to the Outer Cone Distance dimension back(2) ! Backing - No. 15 Blank Checker - (1)=pinion, (2)=gear REAL bangm ! Angular Backlash - Minimum REAL bangx ! Angular Backlash - Maximum REAL bb ! Temporary storage in "call intp1s" REAL bearf ! Bearling Length Factor or Pattern Length Factor REAL bf(4) ! Value returned from txcutd (Face Hobbing Cutter Info Subroutine) REAL bgam ! Face Angle Junction to Pitch Apex dimension bi(2) ! Front (Inner) Crown to Crossing Point REAL bm ! Dedendum used in the calculation of SP.A File (L,R) REAL bmax ! Maximum Backlash REAL bmax2 ! Backlash used in the calculation of Max Radius for No Interference (usually=bmax) REAL bmin ! Minimum Backlash REAL bn ! Face Hobbing - Number of Blade Groups REAL bpl1 REAL bpl1c REAL bpl1d REAL bpl2 REAL bt(4) REAL bt9 REAL bw(4) ! Value returned from txcutd (Face Hobbing Cutter Info Subroutine) REAL bwrg ! Value returned from txcutd (Face Hobbing Cutter Info Subroutine) REAL bwrp ! Value returned from txcutd (Face Hobbing Cutter Info Subroutine) REAL ca ! Value returned from txcutd (Face Hobbing Cutter Info Subroutine) REAL ckg ! Value returned from txcutd (Face Hobbing Cutter Info Subroutine) REAL ckp ! Value returned from txcutd (Face Hobbing Cutter Info Subroutine) dimension clear(2) ! Outer Clearance - (1)=pinion, (2)=gear dimension clri(2) ! Inner Clearance - (1)=pinion, (2)=gear REAL cmaxn ! Calculated Maximum Number of Blades in the Cutter REAL da REAL dalph REAL dapi REAL dapo REAL db REAL db1 REAL db2 REAL dmm REAL dc ! Cutter Diameter dimension dcd(2) ! Checking Diameter REAL ddl9 ! Delta(delta) - Dedendum Angle Increment (input) REAL tddl9 REAL ded7 dimension ded9(2) ! Dedendum Angle - (1)=pinion, (2)=gear dimension sded9(2) dimension cded9(2) dimension tded9(2) dimension dedi(2) ! Inner Dedendum - (1)=pinion, (2)=gear dimension dedm(2) ! Mean Dedendum - (1)=pinion, (2)=gear dimension dedo(2) ! Outer Dedendum - (1)=pinion, (2)=gear dimension dedt(2) ! Dedendum at the point for which calculations are being made. (1=P, 2=G) !- REAL deg ! Gear Mean Dedendum !- REAL deldp !- REAL delrg !- REAL delrp !- REAL dep ! Pinion Mean Dedendum !- REAL deta ! Value returned from txcutd (Face Hobbing Cutter Info Subroutine) !- REAL detao ! Value returned from txcutd (Face Hobbing Cutter Info Subroutine) !- REAL df !- REAL dgam dimension diao(2) ! Outside Diameter - (1)=pinion, (2)=gear dimension diap(2) ! Pitch Diameter - (1)=pinion, (2)=gear !- REAL dl !- REAL dphif dimension dpwcon(2) !- REAL dr !- REAL dsg9 ! Shaft Angle - 90.0 !- REAL dw !- REAL ebg ! Value returned from txcutd (Face Hobbing Cutter Info Subroutine) !- REAL ebp ! Value returned from txcutd (Face Hobbing Cutter Info Subroutine) !- REAL ec ! Face Hobbing ??? !- REAL effrcn ! Face Hobbing Effective Cutter Radius !- REAL ep ! Running Offset !- REAL ep1 !- REAL epa !- REAL epp !- REAL epp1 !- REAL eps !- REAL eps8 !- REAL es !- REAL eta !- REAL eta1 !- REAL etac !- REAL etai9 ! Gear Offset Angle at Inside (AGMA) Face Hobbing !- REAL etao9 ! Intermediate Angle (AGMA) Face Hobbing (Gear Offset Angle at Outside?) !- REAL etar !- REAL etarp dimension fac9(2) ! Face Angle - (1)=pinion, (2)=gear dimension face(2) ! Pitch Line Face Width - (1)=pinion, (2)=gear dimension facr(2) ! Root face Width - (1)=pinion, (2)=gear !- REAL facs ! Inner Face Angle of Pinion Blank !- REAL fgao ! Face Width in percent of Outer Cone Distance !- REAL fkx ! Cutter Radius Factor - KX !- REAL fsb ! Strength Balance Desirerd - Input dimension gab9(2) ! Back Angle - (1)=pinion, (2)=gear dimension gaf9(2) ! Front angle - (1)=pinion, (2)=gear dimension gam9(2) ! Pitch Angle - (1)=pinion, (2)=gear dimension sgam9(2) dimension cgam9(2) dimension tgam9(2) !- REAL gamp !- REAL gamp1 !- REAL gke dimension glg(2) ! SP.A File "L" dimension grg(2) ! SP.A File "R" !- REAL hdthk ! Head Thickness - Value returned from txcutd (Face Hobbing Cutter Info Subroutine) !- REAL hh ! Value returned from txcutd (Face Hobbing Cutter Info Subroutine) !- REAL hk ! Working Depth !- REAL hkm ! Mean Working Depth - Pinion !- REAL hkmg ! Mean Working Depth - Gear !- REAL hko !- REAL hsog ! Value returned from txcutd (Face Hobbing Cutter Info Subroutine) !- REAL hsop ! Value returned from txcutd (Face Hobbing Cutter Info Subroutine) dimension ht(2) ! Outer Whole Depth - (1)=pinion, (2)=gear dimension htm(2) ! Mean Whole Depth - (1)=pinion, (2)=gear !- REAL otwfg ! Outputted Gear Finishing POint Width (Milling) - to be entered on the SP.A File. !- REAL otwmg ! Outputted Gear Mean Slot Width (Hobbing) - to be entered on the SP.A File. !- REAL pcir ! Circular Pitch !- REAL pdia ! Diametral Pitch (transverse) !- REAL pdiam ! Diametral Pitch - Mean !- REAL ph1 !- REAL ph2 !- REAL pha9 ! Normal pressure Angle !- REAL cpha9 !- REAL spha9 !- REAL tpha9 !- REAL phi1 !- REAL phi1g !- REAL phi1t !- REAL phi2 !- REAL phi2g !- REAL phi2t dimension phi9(2) ! Pitch Pressure Angle - (1)=pinion drive, (2)=pinion coast dimension sphi9(2) dimension cphi9(2) dimension tphi9(2) !- REAL phic !- REAL phid !- REAL phio1 !- REAL phip1 !- REAL phip2 !- REAL phltmp !- REAL phm1 !- REAL phm2 dimension phr9(2) ! Root Pressure Angle - (1)=pinion drive, (2)=pinion coast dimension sphr9(2) dimension cphr9(2) dimension tphr9(2) !- REAL phs9 ! Sum of the OB and IB Pressure Angles !- REAL pht1 !- REAL pht2 !- REAL phtog1 !- REAL phtog2 !- REAL phtop1 !- REAL phtop2 !- REAL pm !- REAL pmn ! Mean Normal Diametral Pitch !- REAL pmnm ! Mean Normal Module !- REAL pmntmp ! Temporary variable used in the calc of "pmn" and "pmnm". !- REAL pn !- REAL pn1 !- REAL psi1 !- real psi9 ! Inner Spiral Angle - gear !- real spsi9 !- real cpsi9 !- real tpsi9 !- REAL psi9g ! Gear Inner Spiral Angle !- REAL psig1 !- REAL psig9 !- real psigt !- REAL psip !- REAL psip1 !- REAL psip9 !- REAL psipt dimension psm9(2) ! Mean Spiral Angle - (1)=pinion, (2)=gear dimension spsm9(1) dimension cpsm9(1) dimension tpsm9(2) !- REAL pso9 !- REAL cpso9 !- REAL spso9 !- REAL tpso9 !- REAL pso9g dimension psr9(2) ! Root Spiral Angle - (1)=pinion, (2)=gear !- REAL px9 !- real cpx9 !- REAL q19 !- REAL qfh ! Intermediate variable (AGMA) Face Hobbing !- REAL r1 !- REAL r2 dimension rab9(2) ! Root Angle - (1)=pinion, (2)=gear !- REAL rad1 !- REAL rcg1 !- REAL rcg2 !- REAL rcmx !- REAL rcn ! Nominal Cutter Radius !- REAL rcno !- REAL rct ! Theoretical Cutter Radius dimension ref(2) ! Edge Radius - (1)=pinion, (2)=gear !- REAL rep1 !- REAL rep2 dimension rest(2) ! Edge Radius Used in Strength - (1)=pinion, (2)=gear !- REAL rgp1 !- REAL rgp2 !- REAL rho1 !- REAL rho2 dimension rm(2) ! Mean radius - (1)=pinion, (2)=gear !- REAL rn !- REAL rn1 !- REAL rni !- REAL rnt !- REAL rp !- REAL rp1 !- REAL rp2 !- REAL rpn !- REAL rpn1 !- REAL rpni !- REAL rpnt !- REAL rr REAL rs(4) !- REAL rsrg !- REAL rsrp !- REAL rx !- REAL s !- REAL s1 !- Crown Gear to Cutter Center Distance (AGMA) - Face Hobbing !- REAL s2 !- REAL sig9 ! Shaft Angle !- REAL csig9 !- REAL ssig9 !- REAL tsig9 dimension smadl(2) !- REAL sst9 dimension stk(2) ! Total Stock Allowance - sum of stock left after roughing and after grinding. 1=pin, 2=gear dimension stkc(2) ! Total Stock for cutting. 1=pin, 2=gear dimension stkg(2) ! Total Stock for grinding. 1=pin, 2=gear dimension t1hk(16) ! Table of Working Depth Constants for "Automotive Spiral Bevel Tooth Proportions" (E.R. 4557 = pg 10) dimension t1ht(16) ! Table of Whole Depth Constants for "Automotive Spiral Bevel Tooth Proportions" (E.R. 4557 = pg 10) dimension t1a(7) ! Table of Gear Addendum Constants for "Automotive Spiral Bevel Tooth Proportions" (E.R. 4557 = pg 10) REAL t1b9 dimension tabc1(8) ! Table of standard C1 (Addendum) constants. dimension tabkh(8) ! Table of standard k (Depth) constants. dimension tadnc(2) !- REAL tav9 ! Gear Angular Face - Concave !- REAL tax9 ! Gear Angular Face - Convex !- dimension tcafl1(5) !- dimension tcafl2(5) dimension tcir(2) ! Outer Circular Thickness. 1=pinion, 2=gear dimension tcutr(34) ! Table of acceptable Cutter Radii dimension tdz9(2) !- REAL tg1 dimension the9(4) dimension sthe9(4) dimension cthe9(4) dimension tthe9(4) dimension tli(2) ! Inner Normal Topland - (1)=pinion, (2)=gear dimension tlm(2) ! Mean Normal Topland - (1)=pinion, (2)=gear dimension tlo(2) ! Outer Normal Topland - (1)=pinion, (2)=gear !- REAL tmd9 !- REAL tmn9 ! Minimum Angular Face !- REAL tmp1a !- REAL tmp1h !- dimension tmp1r(16) !- REAL tmp2a dimension tmp2d(2) !- REAL tmp2m dimension tmp3d(2) !- REAL tmp7c ! Smallest of Pinion Pitch, Pinion, Gear Pitch and Gear Root Face Widths Fmn (E.R 4241 Pg 15) dimension tmp8a(8) !- REAL tmp8b !- REAL tmp8c !- REAL tmp8r !- REAL tmp9r !- REAL tmpdb !- REAL tmpinp ! Given pinion mean circular thickness !- REAL tmpmd !- REAL tmptr !- REAL tmx9 ! Total Angular Face (Maximum Angular Face) dimension tncf(2) ! Measuring Thickness - Finishing (see adnc) - (1)=pinion, (2)=gear !- REAL tncrg ! Measuring Thickness - Gear Roughing !- REAL tncrp ! Measuring Thickness - Pinion Roughing !- REAL tog1 !- REAL top1 !- REAL topinp ! Given pinion outer circular thickness !- REAL topl !- REAL tp1 dimension trmx(10) !- REAL ts1 !- REAL tsmb1 !- REAL tsmb2 !- REAL tsmb3 !- REAL tsmb4 !- REAL tsmb5 dimension ttdz9(2) dimension ttncf(2) !- real vee9 ! Lead Angle of Cutter - Face Hobbing (AGMA) !- REAL wfg ! Gear Finishing Point Width (initially may also be Pinion Outer or Mean Thickness) !- REAL wfginp ! Inputted Gear Finishing Point Width !- REAL wfgtmp !- REAL wfptmp !- REAL wg1 !- REAL wgfe !- REAL wgsym ! Symmetrical Rack Gear Finishing Point Width !- REAL wgtmp dimension wli(2) ! Inner Slot Width - (1)=pinion, (2)=gear dimension wlm(2) ! Mean Slot Width - (1)=pinion, (2)=gear dimension wlo(2) ! Outer Slot Width - (1)=pinion, (2)=gear !- REAL wp !- REAL wp1 dimension wrp(2) ! Roughing Point Width - (1)=pinion, (2)=gear !- REAL ws !- REAL ws1 !- REAL wsm !- REAL x1trac ! Trace switch - DS/Summary !- REAL x2trac ! Trace switch - SP.A calculations !- REAL xc1h ! Addendum Factor !- REAL xembi ! English/Metric switch - Blank input !- REAL xembo ! English/Metric switch - Blank output !- REAL xemcsi ! English/Metric switch - Cutter spec input !- REAL xemcso ! English/Metric switch - Cutter spec output !- REAL xemmsi ! English/Metric switch - Machine setting input !- REAL xemmso ! English/Metric switch - Machine setting output !- REAL xf REAL xi(4) !- REAL xk3x !- REAL xkctmp !- REAL xkh !- REAL xkobas ! Bypass basics switch !- REAL xkp !- REAL xktca ! TCA switch (1=generated/2=non-generated) !- REAL xmod ! Module (transverse) !- real xnc ! Number of Teeth in Crown Gear !- REAL xngnp ! Number of Gear Teeth divided by Number of Pinion Teeth !- REAL xnpng ! Number of Pinion Teeth divided by Number of Gear Teeth dimension xo(2) ! Crown to Crossing Point - (1)=pinion, (2)=gear !- REAL xprog ! Program ID (0=completing/1=SBFS) !- REAL xpt4sw ! New PART4 switch !- REAL xrpig !- REAL xrpip !- REAL xrpmg !- REAL xrpmp !- REAL xrpog !- REAL xrpop !- REAL ylam9 ! First Auxiliary Angle (AGMA) Face Hobbing dimension ym(2) !- REAL working_depth_constant(16) REAL whole_depth_constant(16) !- dimension zn(2) ! Number of Teeth in Member - (1)=pinion, (2)=gear dimension z(2) ! Pitch Apex to Crown (Beyond Crossing Point) (Spirals) - (1)=pinion, (2)=gear !- REAL zk2 dimension zo(2) ! Face Apex Beyond Crossing Point - (1)=pinion, (2)=gear !- REAL zp !- real zp2 dimension zr(2) ! Root Apex Beyond Crossing Point - (1)=pinion, (2)=gear dimension fefile(45) !- integer isary(100) integer iblry(25) INTEGER icsry(25) integer istry(50) INTEGER idata(400) !- INTEGER i INTEGER i650 INTEGER ibmaix integer idatsrc ! Source for Face Hob Cutter Data (0-TXCUT Table, 1-Section 3 of SP.A File) INTEGER iemr INTEGER ifh ! Face Hobbing Code - 0 = No, 1 = Yes INTEGER ifhdim ! Face Hobbing D.S. INTEGER igt INTEGER ihand ! Hand of Spiral - Does not appear to be used. INTEGER ihk ! Face Hobbing blanks given? 0 = no, 1 = yes INTEGER ikwt ! Switch to determine which value is given as input (1=none or Gear Finishing PW, !- 2 = Pinion Outer Circular Thickness, 3 = Pinion Mean Circular Thickness) INTEGER imem ! Member - 1 = Pinion, 2 = Gear INTEGER inz ! Index based on No. of Pin Teeth to determine standard constants used to calc. c1 & k. INTEGER iprog ! 0 = Completing, 1 = SB/FS INTEGER irc ! Index used in the determination of the Cutter Radius INTEGER issg ! Single Side Gear Switch = 1 = Single Side, 2 = Not Single Side INTEGER izk2 ! Integer Machine Number INTEGER izp ! Number of Pinion Teeth.(Integer) INTEGER jgt ! Not used INTEGER jhand ! Not used INTEGER jhandg ! Gear Hand of Spiral - 1 = LH, 2 = RH INTEGER jhandp ! Pinion Hand of Spiral - 1 = LH, 2 = RH INTEGER jprnt1 ! Switch to control part ofthe trace output (0=don't print, 1=print) INTEGER jtt ! Tooth Taper code ! 1 = Standard Taper (aktt = '1') ! 2 = Parallel Depth (PLLD) (aktt = '2') ! 3 = Tilted Root Line around the Large End (old calc) TRLL (aktt = '3') ! 4 = Tilted Root Line around the Meam (old calc) TRLM (aktt = '4') ! 5 = No longer used? ! 6 = No longer used? ! 7 = No longer used? ! 8 = No longer used? ! 9 = Tilted Root Line around the Large End (new calc) TRLL (aktt = 'L') ! 10 = Tilted Root Line around the Large End (new calc) TRLL (aktt = 'M') ! 11 = ??? (aktt = 'D' or 'X') ! 12 = ??? (aktt = 'D' or 'X') ! 13 = ??? (aktt = 'H' ) ! 14 = ??? (aktt = 'H' ) ! 15 = Standard Taper (can give c1 and k) (aktt = 'S') ! 16 = Exact Duplex (aktt = 'G') INTEGER k3xbas INTEGER k3xp integer kcbn(2) ! ! Cut/CHF/Grind Switch (input) INTEGER kctsd INTEGER kcutm ! Cutting Method Code (1=Spread Blade, 9=Face Hobbing) - obsolete values: 2=Planing Generator, 3=EQUICURV SS, 4=UNITOOL, 5=Std SS INTEGER kddl9 INTEGER kdims INTEGER kdimsi INTEGER kemr INTEGER keng1 INTEGER kfcalc INTEGER kformg INTEGER kgiv INTEGER khand ! Pinion Hand of Spiral (1=LH, 2=RH) INTEGER khfswt INTEGER kobas ! Bypass Basic Calculations (=0, =1, =2) INTEGER koprog ! Error Code (Stop Number) INTEGER krad(2) ! INTEGER krcg ! Final Operation Switch (0=Rough, 1=Cut, 2=Grind) Job INTEGER kskps INTEGER ksp INTEGER kswifh INTEGER kswc1k INTEGER kt2bl INTEGER kt2bli INTEGER kttn INTEGER ktype ! Gear Type (1=Generated, 2=Non-Generated, 3=HELIXFORM) INTEGER kun INTEGER kut3x INTEGER kutmx INTEGER kutmx1 INTEGER kutmxsw INTEGER kwt ! Switch to determine which value is given as input (1=none or Gear Finishing PW, !- 2 = Pinion Outer Circular Thickness, 3 = Pinion Outer Circular Thickness) INTEGER l INTEGER machgf ! Gear Finishing Machine Number INTEGER machpf ! Pinion Finishing Machine Number INTEGER machpr ! Pinion Roughing Machine Number INTEGER mtrc ! Print unit number INTEGER md10 !- INTEGER md14 ! File designation for table ta101 INTEGER md19 ! File designation for table txcutr !- INTEGER md24 INTEGER mdupd INTEGER mhand INTEGER mpt ! Trace Unit Number INTEGER msdos ! Not Used??? INTEGER n INTEGER n1 INTEGER n2 INTEGER ndplx INTEGER nhelx INTEGER nkind INTEGER nr !- common /txary1/ ws, wp, pht1, pht2, phi1t, phi2t, phi1, phi2, & wgtmp common /cstopw/ wfptmp, wfgtmp common /fe1/ wgfe,fefile common /devtmp/ mdevs common /comfh/ ifhdim, ihk common /rpnxx/ xrpip, xrpig, xrpmp, xrpmg, xrpop, xrpog common /kutmxsw/ kutmx1 common /alfcom/ & sumno, sumlt, engr, & sumlta, xlet, garea1, garea2, garea3, & garea4, garea5, garea6, garea7, & xnam1, xnam2, xnam3, xnam4, xnam5, & xnam6, xnam7, xnam8, xnam9, xnam10, & ahand, adrive, arot, atype, asbd, asbo, atap, aktt, acutm, & acht, afkia !- common /aryt2/ isary, iblry, icsry, istry, idata, blary, & csary1,csary,stary,giary,xmary,ctlary,adata,bdata,ddata, & edata,fdata !- equivalence & (blary(1),zn), & (blary(3),pdia), (blary(4),xmod), & (blary(5),face), & (blary(7),facr), (blary(9),ep), (blary(10),pha9), & (blary(13),sig9), (blary(14),aop), (blary(15),ao), & (blary(16),amp), (blary(17),am), (blary(18),aip), & (blary(19),ai), (blary(20),diap), (blary(22),pcir), & (blary(23),ado), (blary(25),adm), (blary(27),adi), & (blary(29),dedo), (blary(31),dedm), (blary(33),dedi), & (blary(35),hk), (blary(38),ht), (blary(40),htm), & (blary(44),clear), (blary(48),clri), (blary(50),diao), & (blary(54),zo), (blary(56),zr), (blary(58),xo), & (blary(60),bgam), & (blary(62),bi), (blary(70),tlo), (blary(72),tlm), & (blary(74),tli), (blary(76),gam9), (blary(78),fac9), & (blary(80),facs), & (blary(82),rab9), (blary(84),add9), (blary(86),ded9), & (blary(88),pso9), (blary(89),pso9g), (blary(90),psm9), & (blary(92),psi9), (blary(93),psi9g), (blary(96),psr9), & (blary(104),bmin), (blary(105),bmax), & (blary(107),fgao), (blary(108),xkh), (blary(109),xc1h), & (blary(114),gaf9), (blary(116),gab9), & (blary(118),bmax2), (blary(122),rm), & (blary(124),phi9), (blary(126),sdp9), (blary(127),xnc), & (blary(128),pm), (blary(130),ddl9), (blary(138),ar), & (blary(140),phs9), (blary(145),pn), & (blary(147),phr9), (blary(151),eps8), (blary(163),psip9), & (blary(164),psig9), (blary(167),pmn), (blary(168),pmnm) equivalence & (csary(1),rct), (csary(2),rcn), (csary(3),dc), & (csary(6),wfg), (csary(7),wrp), (csary(13),wlo), & (csary(15),wlm), (csary(17),wli), (csary(31),ref), & (csary(88),wfginp), (csary(99),effrcn) equivalence & (stary(9),rest), (stary(17),fkx), (stary(18),axoao), & (stary(19),axoam) equivalence & (isary(1),kcutm), (isary(2),ktype), (isary(3),jtt), & (isary(6),kemr), (isary(7),ndplx), (isary(8),kutmx), & (isary(25),keng1), & (isary(62),kdims), & (isary(66),kformg), & (isary(86),ifh), (isary(89),kctsd), & (isary(91),jhandp), (isary(95),kut3x) equivalence & (xmary(1),tav9), (xmary(2),tax9), (xmary(3),tmx9), & (xmary(5),r002), (xmary(9),zk2), & (xmary(14),adncrp), (xmary(15),adncrg), (xmary(16),tncrp), & (xmary(17),tncrg), (xmary(18),adnc), & (xmary(20),tncf), & (xmary(23),bangm), (xmary(24),bangx), (xmary(25),dcd), & (xmary(27),back), & (xmary(33),bn), (xmary(34),deta), & (xmary(36),machpr), (xmary(37),machpf), (xmary(38),machgr), & (xmary(39),machgf), (xmary(48),dpwcon) equivalence & (ctlary(17),gke) equivalence & (iblry(1),izp), (iblry(8),k3xbas), & (iblry(14),kt2bl), & (iblry(20),jgt) equivalence & (blary(64),tcir), (blary(118),bmax2) equivalence & (csary(11),stk) equivalence & (stary(21),fsb), (stary(74),xkctmp) equivalence & (isary(9),khand), (isary(13),krad), & (isary(22),iemr), (isary(23),kwt) equivalence & (xmary(11),xkp), (xmary(13),tmp2m) equivalence & (ctlary(1),bearf) equivalence & (istry(2),kskps) equivalence & (iblry(13),ksp) equivalence & (istry(1),kun) !- data trmx/1.7500, 1.9685, 3.0000, 3.1496, & 3.7500, 3.9370, & 6.0000, 6.2992, 10.5, 9.8425/ data tabc1/ .090, .120, .150, .180, .210, & .210, .210, .210 / data tabkh/ 1.75, 1.85, 1.90, 1.95, 2.00, & 2.00, 2.00, 2.00 / !- !- Variable initialization !- imem = 0 t1b9 = 0.0 wgsym = 0.0 phm1 = 0.0 phm2 = 0.0 rho1 = 0.0 rcg2 = 0.0 rcg1 = 0.0 tmpinp = 0.0 topinp = 0.0 kdims = kdimsi kt2bl = kt2bli phltmp = 0.0 !- write (mpt,10001) 10001 format (' ' / ' START OF A10101' / ' ' ) !- !- Equate spa module variable names to program names !- keng1 = SPADATA%IN0000020202 ! xembo ! English/Metric switch - Blank output kemr = SPADATA%IN0000020301 ! xemcso ! English/Metric switch - Cutter spec output !-*** jprnt1 = SPADATA%IN0000020302 ! x1trac ! Trace switch - DS/Summary kobas = SPADATA%IN0000020304 ! xkobas ! Bypass basics switch !- kobas will be set equal to zero later if DS run. iprog = SPADATA%IN0000020305 ! xprog ! Program ID (0=completing/1=SBFS) !- garea1 = SPADATA%IN0000010101 ! gar10 ! Geographical area (1 of 7) garea2 = SPADATA%IN0000010102 ! gar20 ! Geographical area (2 of 7) garea3 = SPADATA%IN0000010103 ! gar30 ! Geographical area (3 of 7) garea4 = SPADATA%IN0000010104 ! gar40 ! Geographical area (4 of 7) garea5 = SPADATA%IN0000010105 ! gar50 ! Geographical area (5 of 7) garea6 = SPADATA%IN0000010106 ! gar60 ! Geographical area (6 of 7) garea7 = SPADATA%IN0000010107 ! gar70 ! Geographical area (7 of 7) xnam1 = SPADATA%IN0000010201 ! xna10 ! Customer's name ( 1 of 10) xnam2 = SPADATA%IN0000010202 ! xna20 ! Customer's name ( 2 of 10) xnam3 = SPADATA%IN0000010203 ! xna30 ! Customer's name ( 3 of 10) xnam4 = SPADATA%IN0000010204 ! xna40 ! Customer's name ( 4 of 10) xnam5 = SPADATA%IN0000010205 ! xna50 ! Customer's name ( 5 of 10) xnam6 = SPADATA%IN0000010206 ! xna60 ! Customer's name ( 6 of 10) xnam7 = SPADATA%IN0000010207 ! xna70 ! Customer's name ( 7 of 10) xnam8 = SPADATA%IN0000010208 ! xna80 ! Customer's name ( 8 of 10) xnam9 = SPADATA%IN0000010209 ! xna90 ! Customer's name ( 9 of 10) xnam10 = SPADATA%IN0000010210 ! xna100 ! Customer's name (10 of 10) sumno = SPADATA%IN0000010401 ! sumno0 ! Summary number (1 of 3) sumlt = SPADATA%IN0000010402 ! sumlt0 ! Summary number (2 of 3) sumlta = SPADATA%IN0000010403 ! sumla0 ! Summary number (3 of 3) if ( atyp .eq. ' D ' .or. atyp .eq. ' D ' .or. & atyp .eq. ' D' ) atyp = 'D ' if ( atyp .eq. ' S ' .or. atyp .eq. ' S ' .or. & atyp .eq. ' S' ) atyp = 'S ' if ( atyp .eq. ' T ' .or. atyp .eq. ' T ' .or. & atyp .eq. ' T' ) atyp = 'T ' if ( atyp .eq. ' L ' .or. atyp .eq. ' L ' .or. & atyp .eq. ' L' ) atyp = 'L ' if ( atyp .eq. ' U ' .or. atyp .eq. ' U ' .or. & atyp .eq. ' U' ) atyp = 'U ' if ( atyp .eq. ' F ' .or. atyp .eq. ' F ' .or. & atyp .eq. ' F' ) atyp = 'F ' if ( atyp .eq. ' X ' .or. atyp .eq. ' X ' .or. & atyp .eq. ' X' ) atyp = 'X ' if ( atyp .eq. ' C ' .or. atyp .eq. ' C ' .or. & atyp .eq. ' C' ) atyp = 'C ' if ( atyp .eq. ' Z ' .or. atyp .eq. ' Z ' .or. & atyp .eq. ' Z' ) atyp = 'Z ' if ( atyp .eq. ' P ' .or. atyp .eq. ' P ' .or. & atyp .eq. ' P' ) atyp = 'P ' if ( atyp .eq. ' M ' .or. atyp .eq. ' M ' .or. & atyp .eq. ' M' ) atyp = 'M ' engr = SPADATA%IN0000010503 ! engr0 ! Engineer's initials !- write ( mpt,6666 ) SPADATA%IN0000010503 ! engr0 ! Engineer's initials 6666 format ( ' ' / ' engr0 = ***', a4, '***' / ' ' ) !- if ( atyp .eq. 'D ' ) then kobas = 0 endif !- !- Equate spa module variable names to program names !- kswc1k = SPADATA%IN0000031401 ! ixc1k0 ! Switch (0=Explicit Tooth Proportion Entry, 1=Addendum Factor/Depth Factor Entry) zn(1) = SPADATA%IN0000030101 ! znp0 ! Number of Teeth - Pinion zn(2) = SPADATA%IN0000030102 ! zng0 ! Number of Teeth - Gear pdia = SPADATA%IN0000030103 ! pdia0 ! Diametral Pitch sig9 = SPADATA%IN0000030104 ! sig90 ! Shaft Angle ep = SPADATA%IN0000030105 ! ep0 ! Running Offset phi9(1) = SPADATA%IN0000030201 ! phin10 ! Pressure angle - Drive side phi9(2) = -abs(SPADATA%IN0000030202) ! Pressure angle - Coast side jhandp = SPADATA%IN0000030203 ! xhand0 ! Pinion Hand of Spiral (1=LH/2=RH) psm9(1) = SPADATA%IN0000030204 ! psd90 ! Desired pinion spiral angle bmin = SPADATA%IN0000030205 ! bmin0 ! Minimum Backlash bmax = SPADATA%IN0000030301 ! bmax0 ! Maximum Backlash rcn = SPADATA%IN0000030302 ! rcni0 ! Nominal Cutter Radius - Input hk = SPADATA%IN0000030303 ! hki0 ! Working Depth - Input ddl9 = SPADATA%IN0000030304 ! dd9i0 ! Delta Delta - Input bmax2 = SPADATA%IN0000030305 ! bmx2i0 ! BMAX2 - Input xc1h = SPADATA%IN0000030401 ! c1i0 ! C1 - Addendum Factor - Input xkh = SPADATA%IN0000030402 ! xki0 ! K - Depth Factor - Input xkctmp = SPADATA%IN0000031102 ! sizi0 ! Size Factor - Contact Stress - Input phs9 = SPADATA%IN0000030504 ! sp9i0 ! Sum of Pressure Angles - Input ikwt = SPADATA%IN0000030505 ! swfgi0 ! WFG Switch - Input wfg = SPADATA%IN0000030601 ! xwfgi0 ! WFG/top/tmp - Input wrp = SPADATA%IN0000030602 ! wrpi0 ! Wrp - Input fsb = SPADATA%IN0000030603 ! sbdi0 ! Strength Balance Desired - Input xkp = SPADATA%IN0000030604 ! xkpi0 ! KP - Profile Mismatch Facter - Input ktype = SPADATA%IN0000030605 ! xtype0 ! Gear Type (1=GEN/2=FORMATE/3=HELIXFORM) ksp = SPADATA%IN0000030701 ! xscal0 ! Strength Calculation Switch - Input kutmx = SPADATA%IN0000030702 ! xcutm0 ! Cutting Method Switch (KCUTM) - Input ado(2) = SPADATA%IN0000030703 ! adogi0 ! Addendum - Gear - Input kun = SPADATA%IN0000030801 ! xtqui0 ! Units for Torque - Input krcg = SPADATA%IN0000031304 ! ircfg0 ! Switch (0=Rough, 1=Cut, 2=Grind) Job !- otwmg = SPADATA%OT0001011903 ! otwmg0 ! FH Gear Mean Slot Width - Calc by D.S. otwfg = SPADATA%OT0001011904 ! otwfg0 ! FM Gear Finishiing Point Width - Calc by D.S. !- bn = SPADATA%IN0000390101 ! bn0 ! Number of Blade Groups (Face Hobbing) !- aktt = SPADATA%IN0000031201 ! tti0 ! Tooth Taper - Input adrive = SPADATA%IN0000031202 ! drvi0 ! Driving Member - Input arot = SPADATA%IN0000031203 ! roti0 ! Rotation of Driver - Input dimcal = SPADATA%IN0000031204 ! t2bci0 ! T2000 Blank Calculations - Input !- if ( kutmx .eq. 9 ) then ifh = 1 else ifh = 0 endif !- if ( phi9(2) .eq. 0.0 ) then phi9(2) = -phs9 + phi9(1) endif !- gab9(1) = 0.0 ! gabip0 ! Back Angle - Pinion gab9(2) = 0.0 ! gabig0 ! Back Angle - Gear gaf9(1) = 0.0 ! gafip0 ! Front Angle - Pinion gaf9(2) = 0.0 ! gafig0 ! Front Angle - Gear face(1) = SPADATA%IN0000040101 ! fwpi0 ! Face Width - Pinion - Input ht(1) = SPADATA%IN0000040102 ! htpi0 ! Whole Depth - Pinion - Input add9(1) = SPADATA%IN0000040103 ! ad9pi0 ! Addendum Angle - Pinion - Input ded9(1) = SPADATA%IN0000040104 ! dd9pi0 ! Dedendum Angle - Pinion - Input facr(1) = SPADATA%IN0000040105 ! frpi0 ! Root Line Face Width - Pinion - Input face(2) = SPADATA%IN0000050101 ! fwgi0 ! Face Width - Gear - Input ht(2) = SPADATA%IN0000050102 ! htgi0 ! Whole Depth - Gear - Input add9(2) = SPADATA%IN0000050103 ! ad9gi0 ! Addendum Angle - Gear - Input ded9(2) = SPADATA%IN0000050104 ! dd9gi0 ! Dedendum Angle - Gear - Input facr(2) = SPADATA%IN0000050105 ! frgi0 ! Root Line Face Width - Gear - Input !- stkc(1) = SPADATA%IN0000040401 ! sarfp0 ! Stock allowance between rough/finish - Pinion stkc(2) = SPADATA%IN0000050401 ! sarfg0 ! Stock allowance between rough/finish - Gear !- dpwcon(1) = SPADATA%IN0000040405/100.0 ! Pct of Mean Slot for Bld Pt-FH-Pin dpwcon(2) = SPADATA%IN0000050405/100.0 ! Pct of Mean Slot for Bld Pt-FH-Gear !- if ( dimcal .eq. 'P ' .or. dimcal .eq. 'p ' ) dimcal = 'P ' if ( dimcal .eq. ' P ' .or. dimcal .eq. ' p ' ) dimcal = 'P ' if ( dimcal .eq. ' P ' .or. dimcal .eq. ' p ' ) dimcal = 'P ' if ( dimcal .eq. ' P' .or. dimcal .eq. ' p' ) dimcal = 'P ' !- kfcalc = 1 if ( dimcal .eq. 'F ' .or. dimcal .eq. 'f ' ) kfcalc = 2 if ( dimcal .eq. ' F ' .or. dimcal .eq. ' f ' ) kfcalc = 2 if ( dimcal .eq. ' F ' .or. dimcal .eq. ' f ' ) kfcalc = 2 if ( dimcal .eq. ' F' .or. dimcal .eq. ' f' ) kfcalc = 2 ! bearf = SPADATA%IN0000200301 ! bpo0 ! Contact Pattern Length Factor - Pinion OB !- kformg = SPADATA%IN0000060103 ! fgc0 ! FORMATE Gear Calculation Switch (Completing) !- pobf_ToolData = GET_TOOL_DATA (FINISH, PINION, OUTSIDE) WRITE (mtrc, '(" Assign pinion outside blade finishing cutter specs to local variables. ")') !- zk2 = pobf_ToolData%xmchi0 ! xmchi0 ! Gleason Machine Indentifier (Machine Number) !- !- Do not set ref if program is returning from basgen or basng. !- Use the equivalenced value. The SP.A file has not yet been !- "stored". !- if ( kdims .ne. 3 ) ref(1) = pobf_ToolData%eri0 ! Edge Radius (input) !- gibf_ToolData = GET_TOOL_DATA (FINISH, GEAR, INSIDE) WRITE (mtrc, '(" Assign gear inside blade finishing cutter specs to local variables. ")') !- !- Do not set ref if program is returning from basgen or basng. !- Use the equivalenced value. The SP.A file has not yet been !- "stored". !- if ( kdims .ne. 3 ) ref(2) = gibf_ToolData%eri0 ! Edge Radius (input) !- pobg_ToolData = GET_TOOL_DATA (HARDFINISH, PINION, OUTSIDE) WRITE (mtrc, '(" Assign pinion outside blade hard finishing cutter specs to local variables. ")') !- kcbn(1) = pobg_ToolData%xcuti0 ! Cut/CHF/Grind Switch (input) gibg_ToolData = GET_TOOL_DATA (HARDFINISH, GEAR, INSIDE) WRITE (mtrc, '(" Assign gear inside blade hard finishing cutter specs to local variables. ")') !- kcbn(2) = gibg_ToolData%xcuti0 ! Cut/CHF/Grind Switch (input) !- if (adrive .eq. 'p' .OR. adrive .eq. 'P' ) adrive = 'PIN' if (adrive .eq. 'g' .OR. adrive .eq. 'G' ) adrive = 'GEAR' if (adrive .eq. 'b' .OR. adrive .eq. 'B' ) adrive = 'BOTH' if (adrive .eq. ' ' ) adrive = 'PIN' if (aktt .eq. ' ' ) aktt = '1' if (arot .eq. ' ' ) arot = 'REV' !- !- If hard finishing, set stock allowance to stock allowance !- between finishing and grinding. !- stkg(1) = 0.0 stkg(2) = 0.0 if ( krcg .eq. 2 ) & stkg(1) = SPADATA%IN0000040402 ! safgp0 ! Stock allowance between finish/grind - Pinion if ( krcg .eq. 2 ) & stkg(2) = SPADATA%IN0000050402 ! safgg0 ! Stock allowance between finish/grind - Gear !- stk(1) = stkc(1) + stkg(1) stk(2) = stkc(2) + stkg(2) !- aprog = 'T200' if ( iprog .eq. 1 ) aprog = 'A001' !- !- For Dimension Sheet calculationsn set top, tmp based on kwt (ikwt) !- if ( atyp .eq. 'D ' ) then if ( ikwt .eq. 2 ) then topinp = SPADATA%IN0000031301 ! topds0 ! Given pinion outer circular thickness wfg = 0.0 kwt = ikwt else if ( ikwt .eq. 3 ) then tmpinp = SPADATA%IN0000031302 ! tmpds0 ! Given pinion mean circular thickness wfg = 0.0 kwt = ikwt end if end if !- !- Set wfg equal to otwmg for Face Hobbing calculations !- other than D.S. calc if wfg equals zero. !- if ( atyp .ne. 'D ' .and. ifh .eq. 1 .and. wfg .eq. 0.0 ) then kwt = 1 wfg = otwmg write (mpt,11990) wfg 11990 format ( ' ' / & ' wmg not given as input ' / & ' wmg has been set equal to the stored wmg ' / & ' calculated by the Dimension Sheet. ' / & ' wmg = ', f12.6 / & ' ' ) else endif !- !- Set wfg equal to otwfg for Face Milling calculations !- other than D.S. calc if wfg equals zero. !- if ( atyp .ne. 'D ' .and. ifh .ne. 1 .and. wfg .eq. 0.0 ) then kwt = 1 wfg = otwfg write (mpt,11991) wfg 11991 format ( ' ' / & ' wfg not given as input ' / & ' wfg has been set equal to the stored wfg ' / & ' calculated by the Dimension Sheet. ' / & ' wfg = ', f12.6 / & ' ' ) else endif !- if ( kswc1k .ne. 1 ) then xc1h = 0.0 xkh = 0.0 else if ( kswc1k .eq. 1 ) then hk = 0.0 ht(1) = 0.0 ht(2) = 0.0 ado(2) = 0.0 add9(1) = 0.0 add9(2) = 0.0 ded9(1) = 0.0 ded9(2) = 0.0 end if !- !- Writing of Input Data to Trace File !- write ( mpt,11999 ) write ( mpt,12000 ) & keng1, kemr, kobas, iprog write ( mpt,12001 ) & garea1, garea2, garea3, garea4, garea5, garea6, garea7, & xnam1, xnam2, xnam3, xnam4, xnam5, xnam6, xnam7, xnam8, & xnam9, xnam10, sumno, sumlt, sumlta, atyp, engr write ( mpt,12002 ) & zn(1), zn(2), pdia, sig9, ep, & phi9(1), phi9(2), jhandp, psm9(1), bmin, & bmax, rcn, hk, ddl9, bmax2, & xc1h, xkh, phs9, kwt, wfg, & wrp(1), fsb, xkp, ktype, ksp, kutmx, & face(1), face(2), ado(2), ht(1), ht(2), & gab9(1), gab9(1), gaf9(1), gaf9(1), bn, & facr(1), facr(2), kswc1k, topinp, tmpinp, & tcir(1), tmp2m write ( mpt,12003 ) & add9(1), add9(2), ded9(1), ded9(2), & kun write ( mpt,12004 ) & aktt, adrive, arot, dimcal write ( mpt,12005 ) & stkc(1), stkc(2), stkg(1), stkg(2), stk(1), stk(2), & zk2, ref(1), kcbn(1), ref(2), kcbn(2) write ( mpt,12006 ) & gab9(1)*RADTODEG, gab9(2)*RADTODEG, gaf9(1)*RADTODEG, gaf9(2)*RADTODEG, & dpwcon(1), dpwcon(2) write ( mpt,12007 ) & krcg, kformg 11999 format ( ' ' / ' Start of a10101 - 11999' / ' ' ) 12000 format ( & ' ' / & ' keng1, kemr, kobas, iprog' / & ' ', 4i10 ) 12001 format ( & ' ' / & ' garea ' , 7a4 / & ' xname ' , 10a4 / & ' summary number ', 3a4 / & ' atyp ', a4 / & ' engr ', a4 ) 12002 format ( & ' ' / & ' zn(1), zn(2), pdia, sig9, ep, ' / & ' ', 5f10.4 / & ' phi9(1), phi9(2), jhandp, psm9(1), bmin, ' / & ' ', 2f10.4, i10, 2f10.4 / & ' bmax, rcn, hk, ddl9, bmax2, ' / & ' ', 5f10.4 / & ' xc1h, xkh, phs9, kwt, wfg, ' / & ' ', 3f10.4, i10, f10.4 / & ' wrp(1), fsb, xkp, ktype, ksp, kutmx, ' / & ' ', 3f10.4, 3i10 / & ' face(1), face(2), ado(2), ht(1), ht(2), ' / & ' ', 5f10.4 / & ' gab9(1), gab9(2), gaf9(1), gaf9(2), bn, ' / & ' ', 5f10.4 / & ' facr(1), facr(2) ' / & ' ', 2f10.4 / & ' kswc1k, topinp, tmpinp, tcir(1), tmp2m ' / & ' ', i10, 4f10.4 / & ' ' ) 12003 format ( & ' ' / & ' add9(1), add9(2), ded9(1), ded9(2), kun' / & ' ', 4f10.4, i10 / & ) 12004 format ( & ' ' / & ' aktt, adrive, arot, dimcal ' / & ' ', 4a4 ) 12005 format ( & ' ' / & ' stkc(1), stkc(2), stkg(1), stkg(2), ' / & ' ', 4f10.4 / & ' stk(1), stk(2), zk2, ref(1), kcbn(1), ' / & ' ', 4f10.4, i10 / & ' ref(2), kcbn(2) ' / & ' ', f10.4, i10 / & ) 12006 format ( & ' ' / & ' gab9(1)*rad, gab9(2)*rad, gaf9(1)*rad, gaf9(2)*rad, ' / & ' dpwcon(1), dpwcon(2) ' / & ' ', 4f10.4, & ' ', 2f10.4 / & ) 12007 format ( & ' ' / & ' krcg, kformg ' / & ' ', 2i10 / & ) !- xmod = METRIC/pdia khand = jhandp kcutm = kutmx if ( kutmx .eq. 9 ) kcutm = 1 if ( kutmx .eq. 7 ) kcutm = 1 kctsd = 0 if ( kutmx .eq. 10 ) kctsd = 1 pha9 = phi9(1) if ( imem .eq. 1 ) ihand = khand if ( imem .ne. 1 ) ihand = 3 - khand jhand = ihand i650 = 0 issg = 2 deta = 0.0 if ( ifh .ne. 1 ) go to 1462 if ( k3xbas .eq. 1 ) go to 1462 md19 = 19 !- call txcutd (ibmaix, msdos, mpt, md19, rcn, bn, & rcno, ebg, ebp, ckg, ckp, ca, detao, & bw, bt, rs, bf, rx, etarp, etar, rsrg, rsrp, & bwrg, bwrp, xi, hh, hsop, hsog, hdthk, chpn, & bbpn, idatsrc, koprog ) !- !- Reads the cutter data source value from ini file. !- IF (IN_CUTTER_DATA_SOURCE() .EQ. 1) THEN ! SPA FILE !- !- Set the pinion values equal to the gear or !- gear values to the pinion. This is because the !- txcut table used to contain information for both !- at the same time. !- IF (IN_MEMBER() .EQ. 1) THEN ! Pinion ebg = ebp ckg = ckp rsrg = rsrp hsog = hsop bw(1) = bw(4) bt(1) = bt(4) rs(1) = rs(4) bf(1) = bf(4) bw(2) = bw(3) bt(2) = bt(3) rs(2) = rs(3) bf(2) = bf(3) ELSE IF (IN_MEMBER() .EQ. 2) THEN ! Gear ebp = ebg ckp = ckg rsrp = rsrg hsop = hsog bw(4) = bw(1) bt(4) = bt(1) rs(4) = rs(1) bf(4) = bf(1) bw(3) = bw(2) bt(3) = bt(2) rs(3) = rs(2) bf(3) = bf(2) END IF !- END IF !- if ( koprog .ne. 0 ) go to 1200 !- deta = detao !- 1462 continue !- if ( dpwcon(1) .eq. 0.0 ) dpwcon(1) = 0.8 if ( dpwcon(2) .eq. 0.0 ) dpwcon(2) = 0.8 if ( ifh .ne. 1 ) dpwcon(1) = BLANK if ( ifh .ne. 1 ) dpwcon(2) = BLANK !- k3xbas = 0 if ( kutmx .eq. 11 ) k3xbas = 1 !- !- md14 = 14 !- tmpfil = 'ta101' !- open ( unit=md14, file = tmpfil, & !- status = "old", access = "sequential", & !- form = "formatted" ) !- md24 = 24 !- tmpfil = 'trc' !- open ( unit=md24, file = tmpfil, & !- status = "old", access = "sequential", & !- form = "formatted" ) !- ifhdim = 0 if ( ifh .eq. 1 .and. (dimcal .eq. 'p' .or. dimcal .eq. 'P') ) & ifhdim = 1 tcir(1) = 0.0 tmp2m = 0.0 if ( kwt .eq. 0 ) kwt = 1 go to (9901,9902,9903),kwt go to 9901 9902 continue tcir(1) = topinp wfg = 0.0 tmp2m = 0.0 wprim = 0.0 go to 9904 9903 continue tmp2m = tmpinp wfg = 0.0 tcir(1) = 0.0 wprim = 0.0 go to 9904 9901 tcir(1) = 0.0 tmp2m = 0.0 wprim = 0.0 9904 continue if (bmax2 .eq. 0.0) bmax2 = bmax !- if ( kdims .eq. 3 ) go to 917 !- !- Only set rest and krad the first time through a10101. !- do 925 i=1,2 rest(i) = ref(i) krad(i) = 0 if ( ref(i) .ne. 0.0 ) krad(i) = 1 925 continue 917 continue !- if (face(1)) 908, 908, 912 908 face(1) = face(2) 912 do 909 i = 1,2 if (facr(i)) 916,916,909 916 facr(i) = face(i) 909 continue !- ihk = 0 if ( hk .ne. 0.0 ) ihk = 1 izk2 = zk2 izp = zn(1) ksw1fh = 0 do 1067 i=1,2 glg(i) = 0.0 grg(i) = 0.0 tadnc(i) = 0.0 ttncf(i) = 0.0 1067 continue if ( kdims .eq. 3 .and. kt2bl .ne. 2 ) r002 = .true. psm9(2) = psm9(1) !- acht(1) = ' ' acht(2) = ' ' !- atype = ' ' if ( ktype .gt. 1 ) atype = 'NON-' iemr = kemr if ( ifh .eq. 1 ) iemr = 1 !- if ( khand .eq. 1 ) then ahand(1) = 'LH' ahand(2) = 'RH' else if ( khand .eq. 2 ) then ahand(1) = 'RH' ahand(2) = 'LH' end if !- if ( mdevs) write ( mpt, 2063 ) 2063 format ( ' mdevs = true' ) if ( .not. mdevs) write ( mpt, 2064 ) 2064 format ( ' mdevs = false' ) WRITE ( mpt,2061 ) atyp, kdims, kobas, kt2bl, wfginp, wfgtmp 2061 format ( ' ' / ' 2061 TRACE ' / & ' atyp ', '***', a4, '***' / & ' KDIMS ', i5 / & ' KOBAS ', i5 / & ' KT2BL ', i5 / & ' wfginp = ', f10.5 / & ' wfgtmp = ', f10.5 / & ' ' ) !- if ( kdims .eq. 3 ) go to 1055 if ( kobas .eq. 1 ) go to 1059 if ( kobas .eq. 2 ) go to 1055 go to 1056 1055 continue if ( r002 ) go to 1059 if ( kt2bl .eq. 2 ) go to 1059 if ( kctsd .eq. 1 .and. kobas .ne. 2 ) go to 1059 if ( kobas .eq. 2 .and. atyp .eq. 'C ' ) go to 2060 if ( kobas .eq. 2 ) go to 2059 2060 continue !- go to 1059 2059 continue 1059 continue !- ado(1) = SPADATA%OT0001010801 ! adop0 ! Outer Addendum - Pinion ado(2) = SPADATA%OT0001010402 ! adog0 ! Outer Addendum - Gear ht(1) = SPADATA%OT0001010201 ! htp0 ! Outer Whole Depth - Pinion ht(2) = SPADATA%OT0001010403 ! htg0 ! Outer Whole Depth - Gear fac9(1)= SPADATA%OT0001010202 ! fac9p0 ! Face Angle - Pinion fac9(2)= SPADATA%OT0001010405 ! fac9g0 ! Face Angle = Gear gam9(1)= SPADATA%OT0001011001 ! gam9p0 ! Pitch Angle - Pinion gam9(2)= SPADATA%OT0001010502 ! gam9g0 ! Pitch Angle - Gear rab9(1)= SPADATA%OT0001010203 ! rab9p0 ! Root Angle - Pinion rab9(2)= SPADATA%OT0001010501 ! rab9g0 ! Root Angle - Gear !- write ( mpt, 12010 ) ado(1), ado(2), ht(1), ht(2), & fac9(1), fac9(2), gam9(1), gam9(2), rab9(1), rab9(2) 12010 format ( ' ' / & ' a10101 - after return from basgen or basng ' / & ' ado(1), ado(2), ' / & ' ', 2f10.4 / & ' ht(1), ht(2), ' / & ' ', 2f10.4 / & ' fac9(1), fac9(2), ' / & ' ', 2f10.4 / & ' gam9(1), gam9(2), ' / & ' ', 2f10.4 / & ' rab9(1), rab9(2) ' / & ' ', 2f10.4 / & ' ' ) !- do 1060 i=1,2 ded9(i) = gam9(i) - rab9(i) add9(i) = fac9(i) - gam9(i) 1060 continue hk = ado(1) + ado(2) aktt = '1' !- write ( mpt,7774 ) kdims, kt2bl 7774 format ( ' ' / 'a10101 - 7774 - kdims, kt2bl = ', 2i10 / ' ' ) !- if ( kdims .ne. 3 ) go to 1056 if ( kt2bl .eq. 2 ) go to 1057 !- write ( mpt,7768 ) mtrc, mpt, spafl 7768 format ( ' ' / 'a10101 - 7768 ' / & ' mca = ' i10 / & ' mpt = ' i10 / & ' spafl = ' a20 / & ' ' ) !- wfg = wfgtmp !- write ( mpt,7775 ) rcg1, rcg2, wfg 7775 format ( ' ' / ' a10101 - rcg1, rcg2, wfg = ', 3f10.5 ) !- 1062 continue go to 1056 1057 continue wfg = wfgtmp !- 1056 continue !- if ( kcutm .eq. 0 ) kcutm = 1 if (kcutm .ge. 6) kcutm=1 go to (1985,1986,1987,1988,1989),kcutm 1985 acutm = 'SB ' go to 1983 1986 acutm = 'PG ' go to 1983 1987 acutm = 'EQ-C' go to 1983 1988 acutm = 'UNIT' go to 1983 1989 acutm = 'STSS' 1983 continue if (kutmx.eq.7) wrp(1)=0 9950 continue !- * * * 9926 continue 325 format (' ' / ' END OF INPUT DATA') !- !- read (md14,8997) t1hk,t1ht,tmp8a,tmp1r,t1a !- 8997 format (16f4.3/16f4.3/8f4.3/14f4.3,2f6.3/7f4.3) !- t1hk = GET_WORKING_DEPTH_CONSTANTS () t1ht = GET_WHOLE_DEPTH_CONSTANTS () tmp8a = GET_DUPLEX_HELICAL_GEAR_ADENDUM_MULTIPLIERS () !RMM tmp1r = GET_CUTTER_RADII_XXX () ! Not Used t1a = GET_GEAR_ADDENDUM_CONSTANTS () !- !- read (md24,8998) tcutr !- 8998 format (13f6.4/ 13f6.4/ 8f6.4) tcutr = GET_STANDARD_CUTTER_RADII () !- !- close (md24) !- close (md14) 1640 continue nhelx = 1 ndplx = 1 if (aktt .ne. '1' ) go to 1660 jtt = 1 go to 1673 1660 if (aktt .ne. '2' ) go to 1661 jtt = 2 go to 1673 1661 if (aktt .ne. '3' ) go to 1662 jtt = 3 go to 1673 1662 if (aktt .ne. '4' ) go to 1663 jtt = 4 go to 1673 1663 if (aktt .ne. '5' ) go to 1664 if(ktype - 1) 1657, 1656, 1657 1656 jtt = 5 go to 1690 1664 if (aktt .ne. '6' ) go to 1665 1657 jtt = 6 go to 1690 1665 if (aktt .ne. 'F' ) go to 1666 jtt = 7 go to 1673 1666 if (aktt .ne. 'C' ) go to 1667 jtt = 8 go to 1673 1667 if (aktt .ne. 'L' ) go to 1668 jtt = 9 go to 1673 1668 if (aktt .ne. 'M' ) go to 1669 jtt = 10 go to 1673 1669 if (aktt .ne. 'D' ) go to 1674 1682 if (ktype - 1) 1655, 1658, 1659 1655 koprog = 3 nkind = 6 go to 9999 1658 jtt = 11 go to 1690 1659 jtt = 12 go to 1690 1674 if (aktt .ne. 'X' ) go to 1681 nhelx = 2 go to 1682 1681 if (aktt .ne. 'H' ) go to 2101 if (ktype .ne. 1) go to 1683 jtt = 13 go to 1679 1683 jtt = 14 go to 1679 2101 if (aktt .ne. 'S') go to 2102 jtt = 15 go to 1673 2102 if (aktt .ne. 'G') go to 1675 jtt = 16 go to 1679 1679 nhelx = 2 1690 ndplx = 2 go to 1673 1675 if (hk) 1677, 1677, 1680 1677 write (mpt,1678) aktt 1678 format (' STOP 7, TT = ',a4) koprog = 7 go to 9998 1680 jtt = 1 write (mpt,643) 1673 continue !- !- Set "kutmx1 = 1" if SB/FS Duplex Job so that true Pinion !- Inner and Outer Slot Widths will be calculated in a10102 and !- outputted on the Spiral Bevel Dimension Sheet. !- kutmx1 = 0 if ( iprog .eq. 1 .and. ndplx .eq. 2 .and. ifh .eq. 0 ) & kutmx1 = 1 !- kutmx1 = 0 if ( iprog .eq. 1 .and. ndplx .eq. 2 .and. ifh .eq. 0 ) & kutmx1 = 1 !- if ( ifh .ne. 1 ) go to 1645 if ( jtt .eq. 1 ) go to 1643 if ( jtt .eq. 2 .or. jtt .eq. 15 ) go to 1645 write (mpt,1641) 1641 format ( ' INCORRECT TOOTH TAPER GIVEN FOR FACE HOBBING '/ & ' TOOTH TAPER BEING SET EQUAL TO 2 ') 1644 continue aktt = '2' go to 1640 1643 continue if ( hk .eq. 0.0 ) go to 1644 1645 continue if (hk .ne. 0.0 .and. .not. r002) aktt = 'GIVN' if (r002) aktt ='T200' if ( r002 .and. kdims .eq. 3 ) aktt ='T2DS' go to (2100, 8995), ndplx 8995 continue !- tmp1r(8) = 2.250 2100 go to (8996, 8996, 621, 621, 8996, 8996, 8996, 8996, 621, 621, & 8996, 8996, 8996, 8996, 8996, 8996), jtt 621 continue 8996 continue diap(1)=zn(1)/pdia diap(2)=zn(2)/pdia ssig9= sin(sig9) csig9= cos(sig9) xngnp=zn(2)/zn(1) if (kutmx.eq.7) go to 645 go to (645, 646), nhelx 645 if (kemr .eq. 1 ) go to 647 648 n1 = 1 n2 = 18 go to 649 646 if (kemr .eq. 2 ) go to 648 647 n1 = 20 n2 = 33 649 if (rcn .eq. 0.0) go to 650 do 651 n = n1, n2 if (abs(rcn - tcutr(n)) - 0.003) 650, 650, 651 651 continue if ( ifh .eq. 1 ) go to 650 write (mpt,652) rcn 652 format (' CUTTER RADIUS NOT STANDARD', f8.3) 650 continue call cmp4 (face(2),face(1),facr(2),facr(1),tmp7c,tmp8c) do 615 i=1,2 if (face(i) .lt. facr(i)) go to 613 tmp2d(i) = face(i) tmp3d(i) = facr(i) go to 615 613 tmp2d(i) = facr(i) tmp3d(i) = face(i) 615 continue tgam9(1)=ssig9/(xngnp + csig9) call angle(gam9(1),sgam9(1),cgam9(1),tgam9(1),4) gam9(2)=sig9-gam9(1) if( abs(gam9(2)-90.0*DEGTORAD)-0.0014544) 196,197,197 196 tgam9(2) = 10000.0 cgam9(2) = 0.00001 sgam9(2)= sin(gam9(2)) go to 1197 197 call angle(gam9(2),sgam9(2),cgam9(2),tgam9(2),1) if (gam9(2) - 90.0*DEGTORAD) 1197,1197,0241 241 if (ktype .eq. 2) go to 1197 write (mpt,239) gam9(2)*RADTODEG 239 format (' GEAR PITCH ANGLE = ', f7.2, ' AND GEAR IS GENERATED'/ & ' IF GEAR IS INTERNAL IT SHOULD BE NON-GENERATED'/) if (jtt .ne. 5 .and. jtt .ne. 11 .and. jtt .ne. 13) go to 1197 if (jtt .eq. 11) go to 1190 if (jtt .eq. 13) go to 1187 jtt = 6 go to 1189 1187 jtt = 14 go to 1189 1190 jtt = 12 1189 write (mpt,1188) 1188 format (' TT CHANGED TO SFDH') 1197 ao = 0.5*diap(2)/sgam9(2) am =ao - 0.5*tmp7c ai = ao - tmp7c fgao=face(2)/ao*100.0 xnc = zn(2)/sgam9(2) pcir = pi/pdia call angle(psm9(1),spsm9(1),cpsm9(1),tpsm9(1),1) pdiam = 1.0/(2.0*am*sgam9(2)/zn(2)) pmntmp = ao*pdia/am pmn = pmntmp*cpsm9(1) pmnm = METRIC*cpsm9(1)/pmntmp if(zn(1)-zn(2)) 187,185,187 185 tmp1a = 1.0 go to 195 187 if (zn(2)*cgam9(1)/1000.0 - zn(1)*cgam9(2)) 194,193,193 193 tmp1a=10000.0 go to 195 194 tmp1a = abs( zn(2)* cgam9(1)/(zn(1)*cgam9(2))) 195 pha9= phs9/2.0 call angle (pha9,spha9,cpha9,tpha9,1) 102 if (zn(1) -5.0) 11,103,103 11 koprog = 2 nkind = 0 go to 9999 103 continue !- !- PREVIOUS LOCATION OF FACE HOBBING CALCULATIONS !- if(hk) 994,900,210 994 nkind = 5 go to 999 210 if(psm9(1)-10.0*DEGTORAD) 211,600,600 211 if(rcn) 998,203,600 900 if (kcutm - 3) 229,901,200 229 if (kcutm - 2) 200,231,200 231 if (jtt .eq. 1 .or. jtt .eq. 15) go to 200 232 jtt = 1 write (mpt,0904) 904 format (' TT SET TO STD(1) - PLANING GEN. JOB') go to 200 901 if (jtt - 2) 902,200,902 902 jtt = 2 write (mpt,0903) 903 format (' TT SET EQUAL TO PLLD - EQ-C JOB') 200 if(psm9(1)- 10.0*DEGTORAD)202,199,199 999 koprog = 3 go to 9999 199 kgiv=2 if (jtt .eq. 13 .or. jtt .eq. 14) go to 1684 if (jtt .ge. 15) go to 2120 if (zn(1)-12.0)104,105,105 202 if (rcn) 998,203,201 998 nkind = 1 go to 999 203 koprog = 4 nkind = 0 go to 9999 104 n=zn(1)-4.0 go to(191,191,191,191,801,801,191,191,191,191,801,801),jtt 191 continue if ( ifh .ne. 1) & ado(2)=t1a(n)/pdia !- !- IF FACE HOBBING, GEAR ADDENDUM WILL BE CALCULATED LATER. !- if ( ifh .eq. 1) ado(2)=0.0 go to 106 105 n=8 go to(190,190,190,190,801,801,190,190,190,190,801,801),jtt 801 n=n+8 ado(2) = (0.450 + 0.475/tmp1a)*tmp8a(n-8)/pdia ht(1)=0.002 go to 106 2120 if (xc1h .ne. 0.0 .and. xkh .ne. 0.0) go to 1684 inz = izp - 4 if (izp .gt. 12) inz = 8 xkh = tabkh(inz) if (izp .ge. 10) go to 2121 xc1h = tabc1(inz) go to 2123 2121 xc1h = 0.210 + (0.290/xngnp**2) 2123 continue go to 1684 190 if ( ifh .ne. 1) & ado(2) = 0.460/pdia + 0.390/(pdia*tmp1a) 106 if ( ifh .eq. 1 ) go to 1106 hk = t1hk(n)/pdia ht(1)=ht(1)+t1ht(n)/pdia go to 1105 1106 continue if (zn(1) .ge. 10.0) xk3x = 2.0 if (zn(1) .eq. 9.0) xk3x = 1.95 if (zn(1) .eq. 8.0) xk3x = 1.9 if (zn(1) .eq. 7.0) xk3x = 1.85 if (zn(1) .eq. 6.0) xk3x = 1.8 if (zn(1) .eq. 5.0) xk3x = 1.75 if ( ifhdim .ne. 1 ) go to 4000 !- !- OLD FACE HOB BLANK CALCULATIONS !- ksw1fh = 1 rr = am*sin(gam9(2)) hkmg = xk3x*cos(psm9(2))/zn(2)*2*rr clear(2) = 0.125*hkmg go to 4002 4003 continue ksw1fh = 2 dedm(1)=hkmg/2+clear(2) if(bpl1d .lt. dedm(1)) dedm(1)=bpl1d if(bpl1c .lt. dedm(1)) dedm(1)=bpl1c if(bpl1 .lt. dedm(1)) dedm(1)=bpl1 if(bpl2 .lt. dedm(1)) dedm(1)=bpl2 adm(2)=dedm(1)-clear(2) dedm(2)=hkmg+clear(2)-adm(2) adm(1) = hkmg - adm(2) hk = adm(1) + adm(2) ht(1) = adm(1) + dedm(1) ht(2) = adm(2) + dedm(2) ado(2) = adm(2) add9(1) = 0.0 add9(2) = 0.0 ded9(1) = 0.0 ded9(2) = 0.0 dedo(2) = ht(2) - ado(2) go to 1105 !- 4000 continue hkmg = xk3x*cos(psm9(2))/pdiam clear(2) = 0.125*hkmg hko = (ao/am)*(xk3x*cos(psm9(2))/pdiam) if ( ado(2) .eq. 0.0 ) & adm(2) = 0.270*hko*pdia/pdiam + & 0.229*hko*pdia/(pdiam*tmp1a) if ( ado(2) .ne. 0.0 ) & adm(2) = ado(2) dedm(1) = adm(2) + clear(2) dedm(2) = hkmg + clear(2) - adm(2) adm(1) = hkmg - adm(2) hk = adm(1) + adm(2) ht(1) = adm(1) + dedm(1) ht(2) = adm(2) + dedm(2) ado(2) = adm(2) add9(1) = 0.0 add9(2) = 0.0 ded9(1) = 0.0 ded9(2) = 0.0 dedo(2) = ht(2) - ado(2) 1105 continue ht(2)=ht(1) atap = 'STD ' call abcl (hk,ht(2),ht(1),ado(2),ado(1),dedo(2),dedo(1), & clear(2),clear(1)) go to(107,701,107,107,804,804,107,107,107,107,804,804),jtt 1684 if (zn(1) .lt. 9.0) go to 1685 tmp1h = 9.0 go to 1686 1685 tmp1h = zn(1) 1686 if (jtt .eq. 15 .or. jtt .eq. 16) go to 2126 xkh = (2.0 - 0.035 * sqrt((9.0 - tmp1h)**3)) go to 2126 2126 hkm = (xkh * cpsm9(1) * am) / (pdia * ao) 2125 clear(1) = .150 * hkm if (jtt .le. 14) clear(1) = 0.125 * hkm + 0.002 htm(1) = hkm + clear(1) clear(2) = clear(1) if (jtt .ge. 15) go to 1688 if (jtt .eq. 14) go to 1692 if (zn(1) .le. 11.0) go to 1687 xc1h = 0.270 + 0.230/xngnp**2 go to 1688 1687 xc1h = 0.270 - 0.030 * (11.0 - zn(1)) go to 1688 1692 if (zn(1) .le. 20.0) go to 1693 write (mpt,1694) 1694 format (' MORE THAN 20 TEETH IN PINION - GIVE TOOTH PROPORTIONS') koprog = 1020 go to 9998 1693 if (zn(1) .gt. 9.0) go to 1695 xc1h = 0.170 - 0.020 * (9.0 - zn(1)) go to 1688 1695 xc1h = .170 go to 1688 1688 adm(2) = xc1h * hkm adm(1) = hkm - adm(2) dedm(1) = htm(1) - adm(1) dedm(2) = htm(1) - adm(2) atap = 'DPLX' if (jtt .eq. 15) atap = 'STD ' if ( ifh .eq. 1 ) go to 1701 ded9(1) = atan(dedm(1)/am) ded9(2) = atan(dedm(2)/am) go to 1702 1701 continue if ( kgiv .eq. 1 ) go to 1702 ded9(1) = 0.0 ded9(2) = 0.0 1702 continue ts1 = ded9(1) + ded9(2) if (jtt .eq. 15) go to 807 go to 186 804 if (jtt .ne. 5 .and. jtt .ne. 6) go to 635 kttn = 1 tmp8b = 0.98268/(t1hk(n)*tpha9) ded9(1)=tmp8b*ado(2)/ao ded9(2)=tmp8b*ado(1)/ao sdp9 = ded9(1) + ded9(2) 635 kttn = 2 sdp9 = 0.62560*pi/(xnc*tpha9) ded9(1) = sdp9*ado(2)/hk ded9(2) = sdp9*ado(1)/hk go to 807 701 ded9(1)=0.0 ded9(2)= 0.0 atap = 'PLLD' go to 807 107 continue if ( ifh .eq. 1 ) go to 1107 ded9(1)= atan(dedo(1)/ao) ded9(2)= atan(dedo(2)/ao) go to 1108 1107 continue ded9(1) = 0.0 ded9(2) = 0.0 1108 continue 807 call angle (ded9(1),sded9(1),cded9(1),tded9(1),1) call angle (ded9(2),sded9(2),cded9(2),tded9(2),1) if (r002) go to 164 !- !- THE GOTO WAS CHANGED FROM 161 TO 164 TO ELIM. A T2000 !- PROBLEM ON "RERUNS" WHEN KTT=1. THE ADDENDUM ANGLES WERE !- NOT BEING CALCULATED WHEN THE PROGRAM LOOPED BACK. !- 108 go to (189,189,189,189,811,810,189,189,189,189,811,810,811, 810, & 189, 186), jtt 810 atap = 'DPLX' 812 ts1=sdp9 186 rct=am*spsm9(1)/(1.0-(ts1 *xnc*tpha9*cpsm9(1)/pi)) do 183 nr = n1, n2 if (abs(rct - tcutr(nr)) - abs(rct - tcutr(nr +1)))180, 183, 183 180 tmp8r = tcutr(nr) go to 177 183 continue 177 go to (844, 821), ndplx 811 atap = 'DPLX' go to 812 189 sst9=ded9(1)+ded9(2) go to (188,188,410,410,410,410,188,188,410,410,410,410,410, 410, & 188, 410), jtt 188 ts1=tded9(1) + tded9(2) go to 186 821 continue if ( izk2 .eq. 2 ) go to 860 if ( izk2 .eq. 102 ) go to 860 go to 861 860 irc = 3 - kemr go to 868 861 continue if (izk2 .eq. 7) go to 862 go to 863 862 irc = 5 - kemr go to 868 863 if (izk2 .eq. 106) go to 864 go to 874 864 irc = 7 - kemr go to 868 874 continue if ( izk2 .eq. 116 .or. izk2 .eq. 122) go to 866 if ( izk2 .eq. 640 ) go to 866 if ( izk2 .eq. 641 ) go to 866 if ( izk2 .eq. 647 ) go to 866 if ( izk2 .eq. 642 ) go to 866 if ( izk2 .eq. 643 ) go to 866 if ( izk2 .eq. 644 ) go to 866 if ( izk2 .eq. 631 ) go to 866 if ( izk2 .eq. 635 ) go to 866 if ( izk2 .eq. 2010 .or. izk2 .eq. 2020 ) go to 866 if ( izk2 .eq. 660 .or. izk2 .eq. 665 .or. izk2 .eq. 175 .or. & izk2 .eq. 250 .or. izk2 .eq. 500 ) go to 866 if ( izk2 .eq. 660 ) go to 866 if ( izk2 .eq. 6.31 ) go to 866 if ( izk2 .eq. 646 ) go to 866 if ( izk2 .lt. 641 ) go to 822 if ( izk2 .gt. 641 ) go to 875 875 if (izk2 - 645) 822, 876, 877 876 irc = 11 - kemr go to 868 877 if (izk2 - 650) 822, 876, 865 865 continue go to 867 866 irc = 9 - kemr go to 868 867 if (izk2 .eq. 16) go to 866 go to 822 868 rcmx = trmx(irc) if (rcn) 998, 820, 870 870 if (rcn - rcmx) 843, 843, 871 871 write (mpt,872) rcn, rcmx 872 format (' NOTE 25', 2f9.3) go to 843 822 continue go to 866 820 if (tmp8r - rcmx) 844, 844, 826 826 tmp8r = rcmx 854 rct=tmp8r rcn=rct go to 856 844 if(rcn) 998,848,843 843 go to (853, 846), ndplx 853 sdp9=(pi/(xnc*tpha9*cpsm9(1)))*(1.0-am*spsm9(1)/rcn) go to 167 848 rcn=tmp8r 850 go to (853, 853, 168, 168, 858, 854, 853, 853, 168, 168,858, 854, & 852, 852, 852, 852), jtt 168 koprog = 6 nkind = 0 go to 9999 846 if (rcn - tmp8r) 852, 851, 852 851 go to (850, 852), nhelx 852 tmp8r=rcn rct=rcn 856 tmp9r = pi/(xnc*tpha9*cpsm9(1)) * (1.0-am*spsm9(1)/tmp8r) if (jtt .lt. 15) tmp9r = tmp9r *(1.0+ao*bmin/ & (am*pcir*cpsm9(1))) if (jtt .eq. 15) go to 2130 if (jtt .eq. 13 .or. jtt .eq. 14 .or. jtt .eq. 16) go to 703 ded9(2)= tmp9r*ado(1)/hk ded9(1)= tmp9r*ado(2)/hk call angle (ded9(1),sded9(1),cded9(1),tded9(1),1) call angle (ded9(2),sded9(2),cded9(2),tded9(2),1) if (jtt .ne. 5 .and. jtt .ne. 6) go to 636 sdp9 = ded9(1) + ded9(2) go to 167 703 ded9(1) = xc1h * tmp9r ded9(2) = tmp9r - ded9(1) go to 164 636 sdp9 = tmp9r go to 167 2130 go to 164 858 atap = 'DPLX' 167 continue if ( ifh .ne. 1 ) go to 12 !- !- START OF THREE AXIS BLANK CALCULATIONS !- !- SKIP TO THIS POINT FOR OLD FACE HOBBING BLANK CALCULATIONS !- THEN GO BACK TO STATEMENT 4003 AFTER DO 1355 DO LOOP !- 4002 continue !- psip9 = psm9(1) psig9 = psm9(2) dsg9 = sig9 - 90.0*DEGTORAD rm(2) = am*sgam9(2) ec = am*cos(psm9(2))*bn/xnc alf = asin(ec/rcn) xlam = 90.0*DEGTORAD - psm9(2) + alf s = sqrt ( am**2 + rcn**2 - 2*am*rcn*cos(xlam) ) etac = acos ( am*cos(psm9(2))/(s*(1.0-bn/(xnc+bn))) ) rad1 = rcn - ec*tan(etac)/cos(alf) s2 = sqrt ( am**2 + rad1**2 - 2.0*am*rad1*cos(xlam) ) bt9 = asin (am*sin(xlam)/s2) effrcn = rad1*sin(bt9)/sin(alf+bt9) if ( jprnt1 .eq. 1 ) & write (mpt,7760) xnc,ec,alf,xlam,s,etac,rad1,am, & s2,bt9,effrcn,t1b9*RADTODEG, psm9(2)*RADTODEG, rm(2), xnc, zn(2) 7760 format ( ' TRACE 7760' / ' ', 7f10.5 / ' ', 7f10.5 / & ' ', 7f10.5 / ' ', 7f10.5 ) 37 continue if ( ifhdim .eq. 0 ) write (mpt,1379) effrcn if ( ifhdim .eq. 1 .and. ksw1fh .eq. 2 ) write (mpt,1379) effrcn 1379 format ( ' ' / ' EFFECTIVE CUTTER RADIUS = ', f9.4 / ) if ( jprnt1 .eq. 1 ) & write (mpt,7761) & zn(1), zn(2), sig9*RADTODEG, ep, am, & face(2), gam9(2)*RADTODEG, 0.0, 0.0, psm9(2)*RADTODEG, & phs9*RADTODEG, phltmp*RADTODEG, rcn, wgsym, ktype, & dsg9*RADTODEG 7761 format ( ' TRACE 7761' / ' ', 5f10.5 / ' ', 5f10.5 / & ' ', 4f10.5, i10 / ' ', f10.5 ) 7777 format ( ' A' , 7f10.5 ) xnc = zn(2)/sin(gam9(2)) xnpng = zn(1)/zn(2) rr = am*sin(gam9(2)) zp = am*cos(gam9(2)) dphif = 0.0 if ( ktype .gt. 1 ) & dphif = 0.5*sin(psm9(2))/tan(gam9(2))*face(2)/am phid = 0.5*phs9 + phltmp phic = 0.5*phs9 - phltmp epa=asin(ep/(rr+zp)/tan(gam9(2))) gamp=asin(cos(gam9(2))*cos(epa)*cos(dsg9)+ & sin(gam9(2))*sin(dsg9)) eta=asin(cos(gam9(2))*sin(epa)/cos(gamp)) rp=(rr*cos(epa)*sin(dsg9)+zp*cos(dsg9))/cos(eta) epp=asin(sin(epa)*cos(dsg9)/cos(gamp)) psip=psm9(2)+epp ec = am*cos(psm9(2))*bn/xnc alf = asin(ec/rcn) xlam = 90.0*DEGTORAD - psm9(2) + alf s = sqrt ( am**2 + rcn**2 - 2*am*rcn*cos(xlam) ) etac = acos ( am*cos(psm9(2))/(s*(1.0-bn/(xnc+bn))) ) es = ec/cos(etac) a2 = am - face(2)/2.0 zp2 = zp - face(2)/2.0*cos(gam9(2)) q19 = psm9(2) + etac if ( jprnt1 .eq. 1 ) & write (mpt,7776) xnc, xnpng, rr, zp, ec, alf, xlam, & s, etac, es, a2, zp2, epa, gamp, eta, rp, epp, psip, q19 7776 format ( ' TRACE 7776'/ ' ', 7f10.6 / ' ', 7f10.6 / & ' ', 7f10.6 / ' ', 7f10.6 / ' ', 7f10.5 ) do 1355 i=1,2 rho2 = sqrt( a2**2 + (s-es)**2 - 2*a2*(s-es)*cos(q19)) psig1 = acos ( (s-es)*sin(q19)/rho2 ) r2 = a2*sin(gam9(2)) ep1 = asin ( ep/(r2+zp2/tan(gam9(2))) ) gamp1 = & asin( cos(gam9(2))*cos(ep1)*cos(dsg9) + & sin(gam9(2))*sin(dsg9) ) epp1 = asin ( sin(ep1)*cos(dsg9)/cos(gamp1) ) eta1 = asin ( cos(gam9(2))*sin(ep1)/cos(gamp1) ) rp2 = (r2*cos(ep1)*sin(dsg9) + zp2*cos(dsg9))/cos(eta1) psip1=psig1+epp1 da = (rp2*cos(psip1)-xnpng*r2*cos(psig1))/ & (xnpng*cos(psig1)*cos(gam9(2))+cos(gamp1)*cos(psip1)) a1=a2+da/tan(gam9(2)) r1=a1*sin(gam9(2)) rp1=rp2-da/tan(gam9(2)) ap1=rp1/sin(gamp1) phio1=-atan((ap1*sin(psip1)-a1*sin(psig1))/ & (r1/cos(gam9(2))+rp1/cos(gamp1))) rn=r1/(cos(gam9(2))*cos(psig1)**2) rpn=rp1/(cos(gamp1)*cos(psip1)**2) phi1g=phid phi2g=phic if ( ktype .gt. 1 ) phi1g=phi1g-dphif if ( ktype .gt. 1 ) phi2g=phi2g+dphif phi1=phi1g-phio1 phi2=phi2g+phio1 if(i.eq.2) go to 1356 if ( hk .eq. 0.0 ) go to 1353 clear(2) = ht(2) - hk dedo(2) = ht(2) - ado(2) adm(2) = ado(2) - 0.5*face(2)*tan(add9(2)) dedm(2) = dedo(2) - 0.5*face(2)*tan(ded9(2)) hkmg = adm(2) + dedm(2) - clear(2) adm(1) = hkmg - adm(2) dedm(1) = adm(2) + clear(2) go to 1354 1353 continue 1354 continue pn=360*DEGTORAD*am*cos(psm9(2))/xnc wgtmp = 0.5*pn - (hkmg/2.0+clear(2))*(tpha9+tpha9) if ( wfg .ne. 0.0 ) wgtmp = wfg ws=0.5*(pn-(hkmg+2*clear(2))*(tan(phi1g)+tan(phi2g))) wp = 2*ws - wgtmp rep1 = ( 0.5 * 0.667 * ws - 0.005)/ & (1.0/cos(phi1g)-tan(phi1g)) rep2 = ( 0.5 * 0.667 * ws - 0.005)/ & (1.0/cos(phi2g)-tan(phi2g)) db1=rep1*(1-sin(phi1g)) db2=rep2*(1-sin(phi2g)) if ( (db1 -db2 ) .le. 0.0 ) db=db1 if ( (db1 -db2 ) .gt. 0.0 ) db=db2 1356 if ( ktype .gt. 1 ) go to 1357 bpl1 = rpn*(sin(phi1))**2 + db1 bpl2 = rpn*(sin(phi2))**2 + db2 go to 1358 1357 rho1 = 0.5*rn/cos(phi1) rho2 = 0.5*rn/cos(phi2) phip1 = atan (rho1*sin(phi1)/(rpn+0.5*rn)) phip2 = atan(rho2*sin(phi2)/(rpn+0.5*rn)) rgp1 = 2.0*rho1*cos(0.5*(phi1+phip1)) rgp2 = 2.0*rho2*cos(0.5*(phi2+phip2)) bpl1 = rgp1 - rn + da + db1 bpl2 = rgp2 - rn + da + db2 1358 if ( i .eq. 2 ) go to 1371 bpl1d = bpl1 bpl1c = bpl2 psigt = psig1 psipt = psip1 phi1t = phi1 phi2t = phi2 rni = rn rpni = rpn 1371 continue if ( jprnt1 .eq. 1 ) & write (mpt,7762) rho2, psig1, r2, ep1, gamp1, epp1, eta1, & rp2, psip1, da, a1, r1, rp1, ap1, & phio1, rn, rpn, phi1, phi2, hkmg, clear(2), & pn, ws, wp, rep1, rep2, db, rho1, & rho2 7762 format ( ' TRACE 7762'/ ' ', 7f10.5 / ' ', 7f10.5 / & ' ', 7f10.5 / ' ', 7f10.5 / ' ', 7f10.5 / & ' ', 7f10.5 / ' ', 7f10.5 / ' ', 7f10.5 ) a2=am+face(2)/2.0 zp2=zp+face(2)/2.0*cos(gam9(2)) 1355 continue !- pso9 = psip1 !- pso9g = psig1 !- psi9 = psipt !- psi9g = psigt !- !- AGMA Face Hobbing Inner and Outer Spiral Angle Calculations - added 6/2013 vee9 = asin (am*bn*cos(psm9(2))/(rcn*xnc) ) ylam9 = 90.0*DEGTORAD - psm9(2) + vee9 s1 = sqrt ( (am**2) + (rcn**2) - (2.0*am*rcn*cos(ylam9)) ) qfh = s1/(1.0+(bn/xnc)) etai9 = acos ( (ai**2 + s1**2 - rcn**2)/(2.0*ai*s1) ) psi9 = atan ( (ai - qfh*cos(etai9))/(qfh*sin(etai9)) ) psi9g = psi9 etao9 = acos ( (ao**2 + s1**2 - rcn**2)/(2.0*ao*s1) ) pso9 = atan ( (ao - qfh*cos(etao9))/(qfh*sin(etao9)) ) pso9g = pso9 !- if ( jprnt1 .eq. 1 ) & write (mpt,1359) bpl1d, bpl1c, bpl1, bpl2, & psigt*RADTODEG, psipt*RADTODEG, psig1*RADTODEG, psip1*RADTODEG, & phi1t*RADTODEG, phi2t*RADTODEG, phi1*RADTODEG, phi2*RADTODEG, & rni, rpni, rn, rpn , & hkmg, clear(2), wgtmp, ksw1fh 1359 format ( ' TRACE 1359' / & ' BPDT, BPCT, BPDH, BPCH ', 4f11.6 / & ' PSIGT, PSIPT, PSIGH, PSIPH ', 4f11.6 / & ' PHIDT, PHICT, PHIDH, PHICH ', 4f11.6 / & ' RNT, RPNT, RNH, RPNH ', 4f11.6 / & ' HKMG, CLEAR(2), WGTMP, KSW1FH ', 3f11.6, i11 ) !- if ( ksw1fh .eq. 1 ) go to 4003 !- k3xp = 0 if ( hk .ne. 0.0 ) k3xp = 1 if ( hk .ne. 0.0 ) go to 1378 1378 continue eta=180/(bn*RADTODEG) rn1=rr/(cos(gam9(2))*cos(psm9(2))**2) rpn1=rp/(cos(gamp)*cos(psm9(2))**2) a1=am psi1 = psm9(2) ph1 = phid ph2 = phic adg=adm(2) adp=adm(1) deg=dedm(2) dep=dedm(1) if ( jprnt1 .eq. 1 ) & write (mpt,7778) dedm(1),adm(1),dedm(2),adm(2),eta,rn1,rpn1, & psi1,ph1,ph2 7778 format ( ' ' / ' TRACE 7778' / ' ', 7f10.5 / ' ', 7f10.5 / & ' ', 7f10.5 / ' ', 7f10.5 / ' ', 7f10.5 ) do 1373 i=1,3 !- if ( jprnt1 .eq. 1 ) & write(mpt,5556) i, & xrpmp, xrpmg, phm1, phm2, a1, & psi1, ph1, ph2, rn1, rpn1, & adg, adp, deg, dep, & xrpip, xrpig, pht1, pht2, & xrpop, xrpog 5556 format ( ' TRACE 5556 - I = ', i5 / & ' XRPMP, XRPMG, PHM1, PHM2, A1, ' / & ' ', 5f12.6 / & ' PSI1, PH1, PH2, RN1, RPN1, ' / & ' ', 5f12.6 / & ' ADG, ADP, DEG, DEP ' / & ' ', 4f12.6 / & ' XRPIP, XRPIG, PHT1, PHT2, ' / & ' ', 4f12.6 / & ' XRPOP, XRPOG ' / & ' ', 2f12.6 / & ' ' ) !- pn1 = 360.0*a1*cos(psi1)/(xnc*RADTODEG) ws1 = 0.5*(pn1-(dedm(1)+dedm(2))*(tan(ph1)+tan(ph2))) if ( i .ne. 1 ) go to 1372 dw = wgtmp - ws1 wsm = ws1 wg1 = wgtmp wp1 = wgtmp - 2.0*dw + (bmin+bmax)/2.0 wp = wp1 go to 1374 1372 continue wg1 = wgtmp - (eta+2.0*deta)/eta*(wsm-ws1) wp1 = wp - (eta-2.0*deta)/eta*(wsm-ws1) !- 1374 continue tg1 = pn1 - wg1 - deg *(tan(ph1)+tan(ph2)) tp1 = pn1 - wp1 - dep *(tan(ph1)+tan(ph2)) rnt = rn1 + adg rpnt = rpn1 + adp phtog1 = acos(rn1/rnt*cos(ph1)) phtog2 = acos(rn1/rnt*cos(ph2)) phtop1 = acos(rpn1/rpnt*cos(ph1)) phtop2 = acos(rpn1/rpnt*cos(ph2)) if ( ktype .gt. 1 ) go to 13 tog1 = rnt * (tg1/rn1 + tan(ph1) - ph1 - tan(phtog1) + & phtog1+ tan(ph2) - ph2 - tan(phtog2) + phtog2 ) top1 = rpnt * (tp1/rpn1 + tan(ph1) - ph1 - & tan(phtop1) + phtop1+ tan(ph2) - ph2 - & tan(phtop2) + phtop2 ) go to 14 13 tog1 = tg1 - adg *(tan(ph1)+tan(ph2)) top1 = rpnt*(tp1/rpn1 + tan(ph1) - ph1 - tan(phtop1) + & phtop1+ tan(ph2) - ph2 - tan(phtop2) + phtop2 ) - & adp**2 / 2.0 / rn1*(1.0/sin(ph1)+1.0/sin(ph2)) 14 continue !- if ( jprnt1 .eq. 1 ) & write(mpt,5555) i, & pn1, ws1, dw, wsm, wp1, & wg1, tp1, tg1, rnt, rpnt, & phtog1*RADTODEG, phtog2*RADTODEG, phtop1*RADTODEG, phtop2*RADTODEG, top1, & tog1, wgtmp, eta*RADTODEG, deta*RADTODEG, wp, & psm9(2)*RADTODEG, psigt*RADTODEG, psig1*RADTODEG, & ph1*RADTODEG, ph2*RADTODEG, adg, a1, psi1*RADTODEG, & pn, hkmg, clear(2), xnc 5555 format ( ' TRACE 5555 - I = ', i5 / & ' PN1, WS1, DW, WSM, WP1, ' / & ' ', 5f12.6 / & ' WG1, TP1, TG1, RNT, RPNT, ' / & ' ', 5f12.6 / & ' PHTOG1, PHTOG2, PHTOP1, PHTOP2, TOP1, ' / & ' ', 5f12.6 / & ' TOG1, WGTMP, ETA, DETA, WP, ' / & ' ', 5f12.6 / & ' PSM9(2), PSIGT, PSIG1, ' / & ' ', 3f12.6 / & ' PH1, PH2, ADG, A1, PSI1, ' / & ' ', 5f12.6 / & ' PN, HKMG, CLEAR(2), XNC ' / & ' ', 4f12.6 / ' ' ) !- go to ( 1375, 1376, 1377 ), i 1375 wlm(1) = wp1 wlm(2) = wg1 tlm(1) = top1 tlm(2) = tog1 xrpmp = rpnt/rpn1 xrpmg = rnt/rn1 if ( ktype .gt. 1 ) xrpmg = 1.0 phm1 = phi1t phm2 = phi2t a1 = am - face(2)/2.0 psi1 = psigt ph1 = phi1t ph2 = phi2t rn1 = rni rpn1 = rpni adg=adm(2)-0.5*face(2)*tan(add9(2)) adp=adm(1)-0.5*face(2)*tan(add9(1)) deg=dedm(2)-0.5*face(2)*tan(ded9(2)) dep=dedm(1)-0.5*face(2)*tan(ded9(1)) go to 1373 1376 wli(1) = wp1 wli(2) = wg1 tli(1) = top1 tli(2) = tog1 xrpip = rpnt/rpn1 xrpig = rnt/rn1 if ( ktype .gt. 1 ) xrpig = 1.0 pht1 = phi1t pht2 = phi2t a1 = am + face(2)/2.0 psi1 = psig1 ph1 = phi1 ph2 = phi2 rn1 = rn rpn1 = rpn adg=adm(2)+0.5*face(2)*tan(add9(2)) adp=adm(1)+0.5*face(2)*tan(add9(1)) deg=dedm(2)+0.5*face(2)*tan(ded9(2)) dep=dedm(1)+0.5*face(2)*tan(ded9(1)) go to 1373 1377 wlo(1) = wp1 wlo(2) = wg1 tlo(1) = top1 tlo(2) = tog1 xrpop = rpnt/rpn1 xrpog = rnt/rn1 if ( ktype .gt. 1 ) xrpog = 1.0 1373 continue if ( jprnt1 .eq. 1 ) & write (mpt,7779) wli(1), wli(2), wlm(1), wlm(2), wlo(1), & wlo(2) 7779 format ( ' TRACE 7779' / ' ', 7f10.5 / ' ', 7f10.5 ) glg(1) = am*cos(gam9(2)) grg(1) = am*sin(gam9(2)) glg(2) = glg(1) grg(2) = grg(1) go to 163 !- !- END OF THREE AXIS BLANK CALCULATIONS !- 39 continue 12 continue 163 continue go to (161,164),kgiv 164 continue if ( ifh .eq. 1 ) go to 1698 add9(2)=ded9(1) add9(1)=ded9(2) go to 1699 1698 add9(1) = 0.0 add9(2) = 0.0 1699 continue 161 call angle(add9(1),sadd9(1),cadd9(1),tadd9(1),1) call angle (add9(2), sadd9(2),cadd9(2),tadd9(2),1) if (jtt .le. 12) go to 198 do 1691 i = 1,2 call angle (ded9(i), sded9(i), cded9(i), tded9(i), 1) dedo(i) = dedm(i) + 0.5 * tmp7c * tded9(i) ado(i) = adm(i) + 0.5 * tmp7c * tadd9(i) ht(i) = ado(i) + dedo(i) 1691 continue hk = ado(1) + ado(2) clear(1) = ht(1) - hk clear(2) = ht(2) - hk 198 continue do 116 i=1,2 call angle ( phi9(i), sphi9(i), cphi9(i), tphi9(i), 1) sphr9(i) = sphi9(i)*cded9(2) + cphi9(i)*sded9(2)*spsm9(1) call angle (phr9(i),sphr9(i),cphr9(i),tphr9(i),2) psr9(i) = psm9(i) fac9(i)= gam9(i) + add9(i) rab9(i)= gam9(i) - ded9(i) ar(i) = am*sgam9(i)/sin(rab9(i)) diao(i)=diap(i)+ 2.0*ado(i)*cgam9(i) xo(i)=ao*cgam9(i)-ado(i)*sgam9(i) z(i) = 0.0 zo(i)=diao(i)/(2*tan(fac9(i)))-xo(i) zr(i) = ((ao * tded9(i) - dedo(i)) * cded9(i)) / & sin(rab9(i)) bi(i) = xo(i) - face(i) * cos(fac9(i)) / cadd9(i) adi(i)= ado(i)-tmp7c *tadd9(i) dedi(i)= dedo(i)-tmp7c *tded9(i) dedm(i)=dedo(i)-0.5*tmp7c *tded9(i) adm(i)=ado(i)-0.5*tmp7c *tadd9(i) htm(i) = adm(i) + dedm(i) 116 continue rm(2)=am*sgam9(2)/cded9(2) rm(1)=rm(2)/xngnp aop = ao amp = am aip = ai clri(1)= dedi(1)-adi(2) clri(2)= dedi(2)-adi(1) delrp=0.5*diao(1)-xo(1)*tan(fac9(1)) delrg=0.5*diao(2)-xo(2)*tan(fac9(2)) eps8 = 0.0 zp = am*cgam9(2) if (kutmx.ne.7 .or. jtt.eq.1) go to 120 hk=hk-face(2)/2*tan(ded9(1)+ded9(2)) ht(2)=hk+clear(2) ht(1)=ht(2) ado(2)=ado(2)-face(2)/2*tan(fac9(2)-gam9(2)) add9(1)=0 add9(2)=0 ded9(2)=0 ded9(1)=0 kcutm=7 go to 9950 120 dc = 2.0*rcn if ( ifh .eq. 1 ) go to 123 spso9=(am*(dc*spsm9(1)-am) + ao**2.0)/(dc*ao) call angle (pso9,spso9,cpso9,tpso9,2) pso9g = pso9 spsi9=(am*(dc*spsm9(1)-am) + ai**2.0)/(dc*ai) call angle (psi9,spsi9,cpsi9,tpsi9,2) psi9g = psi9 123 continue if ( psm9(1) .ge. 10.0*DEGTORAD ) go to 121 fkx = 1.0 go to 122 121 if ( ifh .ne. 1 ) & fkx = 0.7889 + 0.2111 * & (rcn/am)**(0.2788/log10(spsm9(1))) if ( ifh .eq. 1 ) & fkx = 0.7889 + & 0.2111 * (effrcn/am)**(0.2788/log10(spsm9(1))) if ( fkx .lt. 1.0 .and. kcutm .ne. 2 ) fkx = 1.0 if ( fkx .gt. 1.15 ) fkx = 1.15 122 continue if (r002) atap = 'DPLX' if (kutmx .eq. 7) atap='PLLD' if ( ifh .eq. 1 .and. ihk .eq. 0 ) atap = ' FH' if ( ifh .eq. 1 .and. ihk .eq. 0 .and. & ifhdim .ne. 0 ) atap = ' OFH' if ( ifh .eq. 1 .and. ihk .ne. 0 ) atap = 'GVFH' !- !- Start of Three Axis Secondary Face Angle Code being bypassed. !- See Fogbugz Case Number 4217 - Graziano job SP8403. !- goto 1226 !- if ( ifh .ne. 1 ) go to 1226 !- !- * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * !- THREE AXIS SECONDARY FACE ANGLE CALCULATIONS !- !- Calculate the Limit topland equal to half pinion slot width. !- !- If the Inside Topland is greater than limit, there will be no !- calculation of a Secondary Face Angle. !- !- If the Inside Topland is less than the limit and the Mean Topland !- and Outer Topland are OK: !- Find the distance from inside where topland is OK using rate of !- topland change from mean to inside. Then calculate the !- Addendum Angle change. !- !- If the Inside Topland and Mean Topland are less than the limit !- and the Outer Topland is OK: !- Find the distance from mean where topland is ok using rate of !- topland change from outside to mean. Then calculate the !- Addendum Angle change. !- !- If the Inside, Mean and Outside Toplands are less than the limit: !- Calculate depth change needed at inside and outside to achieve !- acceptable toplands. Then calculate Addendum Angle change. !- if (jprnt1 .ne. 0) & write (mpt,1230) k3xbas, hkmg, wp, wp/2.0, & face(1), face(2), adm(1), adm(2), dedm(1), dedm(2), & tli(1), tli(2), tlm(1)/pdia, tlm(2)/pdia, & tlo(1), tlo(2), top1, tog1,& pht1, pht2, phi1t, phi2t 1230 format ( ' ' / ' a10101 - Trace 1230' / & ' K3XBAS, HKMG', i10, f10.4 / & ' WP, WP/2.0', 2f10.4 / & ' FACE', 2f10.4 / & ' MEAN ADDENDUM', 2f10.4 / & ' MEAN DEDENDUM', 2f10.4 / & ' TLI', 2f10.4 / & ' TLM', 2f10.4 / & ' TLO', 2f10.4 / & ' TOP1, TOG1', 2f10.4 / & ' PHT1, PHT2', 2f10.4 / & ' PHI1T, PHI2T', 2f10.4 ) df = 0.0 topl = (wp/2.0)*pdia if ( k3xbas .eq. 1 ) go to 1365 if ( tli(1) .ge. wp/2.0 ) go to 1365 if ( tlm(1)/pdia .ge. wp/2.0 ) go to 1366 if ( top1 .ge. wp/2.0 ) go to 1367 dapi = (0.5*wp-tli(1))/(tan(pht1)+tan(pht2)) dapo = (.5*wp-top1)/(tan(phi1t)+tan(phi2t)) dalph = (dapi-dapo)/face(2) adm(1)=adm(1)-(dapo+dapi)/2.0 dedm(2)=dedm(2)-(dapo+dapi)/2.0 hkmg=hkmg-(dapo + dapi)/2.0 df=face(2) tli(1)=topl tlm(1)=topl tlo(1)=topl go to 400 1365 dalph=0 facs=BLANK bgam=BLANK dgam=BLANK go to 1368 1366 df=(0.5*wp-tli(1))/((tlm(1)/pdia)-tli(1))*face(2)/2.0 if( df .lt. .10*face(2)) go to 1365 dapi=(.5*wp-tli(1))/(tan(pht1)+tan(pht2)) dalph=atan(dapi/df) tli(1)=topl go to 400 1367 df=(.5*wp-tli(1))/(top1-tli(1))*face(2) dapi=(.5*wp-tli(1))/(tan(phi1)+tan(phi2)) dalph=atan(dapi/df) tli(1)=topl tlm(1)=topl 400 facs=fac9(1)+dalph bgam=bi(1)+df*cos(gam9(1)) dgam=BLANK 1368 continue if ( jprnt1 .eq. 1 ) write (mpt,1369) & adm(1), adm(2), & dedm(1), dedm(2), & wli(1), wli(2), & wlm(1), wlm(2), & wlo(1), wlo(2), & wp1, wg1, & tli(1), tli(2), & tlm(1)/pdia, tlm(2)/pdia, & tlo(1), tlo(2), & top1, tog1, & wp, wp/2.0, & dalph*RADTODEG, df, & facs*RADTODEG, bgam 1369 format ( ' ' / ' subroutine a10101 - Trace 1369' / & ' ADM(1), ADM(2) ', 2f11.6 / & ' DEDM(1), DEDM(2) ', 2f11.6 / & ' WLI(1), WLI(2) ', 2f11.6 / & ' WLM(1), WLM(2) ', 2f11.6 / & ' WLO(1), WLO(2) ', 2f11.6 / & ' WP1, WG1 ', 2f11.6 / & ' TLI(1), TLI(2) ', 2f11.6 / & ' TLM(1)/PDIA, TLM(2)/PDIA ', 2f11.6 / & ' TLO(1), TLO(2) ', 2f11.6 / & ' TOP1, TOG1 ', 2f11.6 / & ' WP, WP/2.0 ', 2f11.6 / & ' DALPH*RAD, DF ', 2f11.6 / & ' facs*RAD, bgam ', 2f15.10 / & ) !- !- END THREE AXIS SECONDARY FACE ANGLE CALCULATIONS !- * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * !- !- End of Three Axis Secondary Face Angle Code being bypassed. !- 1226 continue !- gaf9(1) = gam9(1) gaf9(2) = gam9(2) gab9(1) = gam9(1) gab9(2) = gam9(2) !- ym(1)=(adm(1)+adm(2)+clear(2))/cos(phr9(1)) ym(2)=(adm(1)+adm(2)+clear(2))/cos(phr9(2)) deldp=fac9(2)-rab9(2) smadl(1)=deldp*cos(psr9(2))/ & (cos(phr9(1))+sin(phr9(1))*sin(deldp)/ & cos(deldp)*sin(psr9(2))) smadl(1) = smadl(1)*RADTODEG smadl(2)=deldp*cos(psr9(2))/ & (cos(phr9(2))+sin(phr9(2))*sin(deldp)/ & cos(deldp)*sin(psr9(2))) smadl(2) = smadl(2)*RADTODEG xf=0.5*face(2)/cos(psr9(2)) !- !- CALCULATION OF CONE DISTANCE FOR INVOLUTE LENGTHWISE CURVATURE !- TO OUTER CONE DISTANCE RATIO !- axin = sqrt (am**2 - 2.0 * am* rcn * spsm9(1) + & 2.0 * rcn**2) if ( ifh .ne. 1 ) go to 155 es = ec/cos(etac) do 152 i=1,20 cpx9 = (s**2+axin**2-rcn**2)/(2*s*axin) px9 = acos(cpx9) rx = sqrt ( axin**2 + (s-es)**2 - 2.0*axin*(s-es)*cpx9 ) eps = rx - axin*sin(px9) if ( jprnt1 .eq. 1 ) & write (mpt,153) & i, axin, rcn, px9, rx, eps, s, & es 153 format ( ' TRACE 153' / ' ', i10, 6f8.5 / ' ', f8.5) if ( abs(eps) .le. 0.0001 ) go to 155 call intp1s (axin,eps,i,-0.05,aa,bb) 152 continue write (mpt,154) 154 format ( ' PROGRAM UNABLE TO CALCULATE AX' ) koprog = 1021 go to 9998 155 continue axoao = axin/ao axoam = axin/am !- !- CALC OF TAU X AND TAU V !- if ( atyp .eq. 'D ' ) go to 1499 if (kcutm-1) 1497,1480,1497 1480 if (gam9(2)-60.0*DEGTORAD) 1497,1481,1481 1481 tsmb3 = rcn**2*cpsm9(1)**2 + (am-rcn*spsm9(1))**2 tsmb4 = 2.0*sqrt(tsmb3) do 1495 i=1,4 ts1 = -(-1)**i ts9 = (-1)**i if (i-2) 1485,1485,1486 1485 tsmb1 = (adi(2)+dedi(2))*tpha9 tsmb2 = ai**2 go to 1487 1486 tsmb1 = (ado(2)+dedo(2))*tpha9 tsmb2 = ao**2 1487 continue tsmb5 = rcn+ts1*wfg/2.0-ts9*tsmb1 cthe9(i) = (tsmb5**2+tsmb3-tsmb2)/(tsmb4*tsmb5) call angle (the9(i),sthe9(i),cthe9(i),tthe9(i),3) 1495 continue tav9 = the9(3)-the9(1) tax9 = the9(4)-the9(2) tmx9 = the9(4)-the9(1) tmn9 = the9(3)-the9(2) cmaxn = 360*DEGTORAD/tmx9 go to 1499 1497 tav9 = BLANK tax9 = BLANK tmx9 = BLANK tmn9 = BLANK cmaxn = BLANK 1499 continue !- if ( ifh .eq. 1 ) go to 1505 psipt = psi9 psip1 = pso9 psigt = psi9 psig1 = pso9 1505 continue !- if ( k3xbas .eq. 1 ) go to 131 if ( kctsd .eq. 1 ) go to 129 if ( kobas .eq. 2 ) go to 500 go to 129 131 continue bm = (ht(2)+clear(2))/2.0 dbm = bm - dedm(2) dl = -dbm*sin(rab9(2)) dr = dbm*cos(rab9(2)) glg(1) = glg(1) + dl glg(2) = glg(2) + dl grg(1) = grg(1) + dr grg(2) = grg(2) + dr 129 continue !- jhandg = 3 - jhandp if ( jhandp .eq. 0 ) jhandg = 0 !- !- New update of SP.A file !- md10 = 10 mdupd = 69 !- SPADATA%OT0001010101 = rcn SPADATA%OT0001010102 = phi9(1) SPADATA%OT0001010103 = phi9(2) SPADATA%OT0001010104 = psm9(1) SPADATA%OT0001010105 = face(1) SPADATA%OT0001010201 = ht(1) SPADATA%OT0001010202 = fac9(1) SPADATA%OT0001010203 = rab9(1) SPADATA%OT0001010204 = gab9(1) SPADATA%OT0001010205 = gaf9(1) SPADATA%OT0001010301 = 0.0 if ( bgam .ne. BLANK ) SPADATA%OT0001010302 = bgam if ( facs .ne. BLANK ) SPADATA%OT0001010303 = facs if ( bgam .eq. BLANK ) SPADATA%OT0001010302 = 0.0 if ( facs .eq. BLANK ) SPADATA%OT0001010303 = 0.0 SPADATA%OT0001010304 = face(2) SPADATA%OT0001010305 = gaf9(2) SPADATA%OT0001010401 = gab9(2) SPADATA%OT0001010402 = ado(2) SPADATA%OT0001010403 = ht(2) SPADATA%OT0001010404 = clear(2) SPADATA%OT0001010405 = fac9(2) SPADATA%OT0001010501 = rab9(2) SPADATA%OT0001010502 = gam9(2) SPADATA%OT0001010503 = 0.0 SPADATA%OT0001010504 = 0.0 SPADATA%OT0001010505 = 0.0 SPADATA%OT0001010601 = 0.0 SPADATA%OT0001010602 = glg(1) SPADATA%OT0001010603 = grg(1) SPADATA%OT0001010604 = glg(2) SPADATA%OT0001010605 = grg(2) SPADATA%OT0001010701 = psr9(1) SPADATA%OT0001010704 = am SPADATA%OT0001010801 = ado(1) SPADATA%OT0001010802 = dedo(1) SPADATA%OT0001010803 = clear(1) SPADATA%OT0001010804 = diao(1) SPADATA%OT0001010805 = z(1) SPADATA%OT0001010901 = zo(1) SPADATA%OT0001010902 = zr(1) SPADATA%OT0001010903 = xo(1) SPADATA%OT0001010904 = bi(1) SPADATA%OT0001010905 = amp SPADATA%OT0001011001 = gam9(1) if ( ifh .eq. 0 ) SPADATA%OT0001011002 = pso9 if ( ifh .ne. 0 ) SPADATA%OT0001011002 = psip1 SPADATA%OT0001011003 = psm9(1) if ( ifh .eq. 0 ) SPADATA%OT0001011004 = psi9 if ( ifh .ne. 0 ) SPADATA%OT0001011004 = psipt SPADATA%OT0001011005 = khand SPADATA%OT0001011101 = aop SPADATA%OT0001012001 = aip SPADATA%OT0001011102 = delrp SPADATA%OT0001011302 = dedo(2) SPADATA%OT0001011304 = diao(2) SPADATA%OT0001011305 = z(2) SPADATA%OT0001011401 = zo(2) SPADATA%OT0001011402 = zr(2) SPADATA%OT0001011403 = xo(2) SPADATA%OT0001011404 = bi(2) if ( ifh .eq. 0 ) SPADATA%OT0001011502 = pso9g if ( ifh .ne. 0 ) SPADATA%OT0001011502 = psig1 SPADATA%OT0001011503 = psm9(2) if ( ifh .eq. 0 ) SPADATA%OT0001011504 = psi9g if ( ifh .ne. 0 ) SPADATA%OT0001011504 = psigt SPADATA%OT0001011601 = ao SPADATA%OT0001012002 = ai SPADATA%OT0001011602 = delrg SPADATA%OT0001011603 = psr9(2) SPADATA%OT0001011701 = ktype SPADATA%OT0001011801 = bmin SPADATA%OT0001011802 = bmax !- SPADATA%OT0001011005 = khand mhand = 3 - khand SPADATA%OT0001011505 = mhand !- SPADATA%OT0001012004 = phltmp !- 500 continue !- if ( ifh .ne. 1 ) effrcn = BLANK if ( ifh .ne. 1 ) bn = BLANK !- go to 1200 !- 600 if(jtt - 1)602,601,602 602 if (r002) go to 601 jtt = 1 ndplx = 1 nhelx = 1 if (kutmx .ne. 7) write (mpt,643) 643 format (' TT CHANGED TO GIVEN') 9990 format (' TYPE GO') 601 call abcl (hk,ht(2),ht(1),ado(2),ado(1),dedo(2),dedo(1), & clear(2),clear(1)) do 607 i = 1,2 if (kcutm - 2) 607,604,607 604 ded7 = atan(dedo(i)/ao) if (abs(ded7-ded9(i))-0.00058177) 607,607,235 235 write (mpt,0907) i 907 format (' NOTE 20 ',i2) 607 continue if (r002) go to 807 atap = 'GIVN' kgiv=1 go to 807 410 sdp9=(pi/(xnc*tpha9*cpsm9(1)))*(1.0-am*spsm9(1)/rcn) if (jtt .ne. 3 .and. jtt .ne. 4) go to 622 kttn = 1 if(zn(1)-12.0)420,422,422 420 tmptr=0.02*zn(1)+1.06 go to 426 422 tmptr=1.30 426 tmpmd=sdp9/sst9 if (tmpmd-tmptr)430,430,435 430 tmd9 = sdp9 go to 440 435 tmd9 =sst9*tmptr 440 ddl9 = 0.5*(tmd9-sst9) tddl9= sin(ddl9)/ cos(ddl9) if (jtt-4)445,450,445 445 tmpdb =0.0 atap = 'GIVN' go to 455 450 tmpdb = face(2)*0.5*tddl9 atap = 'TRL ' 455 do 460 i=1,2 ded9(i)=ded9(i)+ddl9 if(sdp9) 905,906,906 905 ded9(i) = 0.0 906 call angle (ded9(i),sded9(i),cded9(i),tded9(i),1) 460 dedo(i)=dedo(i)+tmpdb ado(2)=dedo(1)-clear(2) ado(1)=dedo(2)-clear(2) hk=ado(2)+ado(1) ht(2)=hk +clear(2) ht(1)=ht(2) go to 188 622 kttn = 2 if (zn(1) .ge. 12.0) go to 623 sdmx9 = (1.06 + 0.02*zn(1))*sst9 go to 624 623 sdmx9 = 1.30*sst9 624 if (sdp9 .gt. sdmx9) go to 625 tmd9 = sdp9 go to 626 625 tmd9 = sdmx9 626 if (jtt .ne. 9) go to 627 at = ao atap = 'GIVN' go to 628 627 at = am atap = 'TRL ' 628 do 640 i=1,2 l = 3-i adt(i) = ado(i)-(ao-at)*tded9(l) dedt(i)= dedo(i)-(ao-at)*tded9(i) 640 continue do 634 i =1,2 l = 3-i ded9(i) = tmd9 * adt(l)/(adt(1) + adt(2)) call angle (ded9(i),sded9(i),cded9(i),tded9(i),1) 634 continue do 642 i = 1,2 l = 3 - i ado(i) = adt(i) + (ao-at)*tded9(l) dedo(i)= dedt(i)+ (ao-at)*tded9(i) ht(i) = ado(i) + dedo(i) 642 continue hk = ado(1) + ado(2) clear(1) = ht(1)-hk clear(2) = ht(2)-hk go to 188 201 rct = rcn if (zn(1)-13.0)204,206,206 204 koprog = 8 nkind = 0 go to 9999 206 go to (1676, 236, 236, 236, 236, 236, 214, 214, 236, 236, 236, & 236, 236, 236), jtt 1676 if(abs(40.0*DEGTORAD-phs9)-0.00145) 125,125,207 125 kddl9=1 go to 214 207 if(abs(45.0*DEGTORAD-phs9)-0.00145) 126,126,208 126 kddl9=2 go to 214 208 if(abs(50.0*DEGTORAD-phs9)-0.00145) 127,127,209 127 kddl9=3 go to 214 209 koprog = 9 nkind = 0 go to 9999 214 ht(1)=2.188/pdia if (jtt .ne. 1) go to 218 if(ddl9 - 0.001*DEGTORAD) 217,218,217 217 ht(1) = ht(1) + 0.002 218 ht(2)=ht(1) hk=2.0/pdia ado(2)=0.540/pdia + 0.460/(pdia*tmp1a) call abcl (hk,ht(2),ht(1),ado(2),ado(1),dedo(2),dedo(1), & clear(2),clear(1)) go to 228 228 if (ddl9)224,216,224 224 atap = 'SPEC' go to 225 216 if(psm9(1)) 237,220,237 237 atap = 'SPEC' go to 225 220 if (jtt .ne. 1) go to 612 tmp2a=(5.0/face(2)* & sqrt(1.0/(xnc*pdia*(tgam9(1)+abs(tgam9(2)))))) + & 0.2333*pdia/xnc atap = 'DPLX' go to (221,222,223),kddl9 221 ddl9 =(111.1333/xnc -tmp2a)*DEGTORAD go to 225 222 ddl9 =(81.1333/xnc -tmp2a)*DEGTORAD go to 225 223 ddl9 =(56.8666/xnc - tmp2a)*DEGTORAD 225 do 230 i=1,2 ttdz9(i)=dedo(i)/ao tdz9(i)= atan(ttdz9(i)) ded9(i)=tdz9(i) + ddl9 230 continue go to 618 612 if (jtt .eq. 7) go to 616 tmd9 = 1.8153*pi/xnc atap = 'GIVN' go to 617 616 tmd9 = pi/(xnc*tpha9) - & pi*sqrt(1.0/ & (xnc*pdia*(tgam9(1)+abs(tgam9(2)))))/(18.0*tmp7c) atap = 'DPLX' 617 ded9(1) = tmd9*ado(2)/hk ded9(2) = tmd9*ado(1)/hk 618 do 619 i=1,2 call angle(ded9(i),sded9(i),cded9(i),tded9(i),1) 619 continue go to 164 236 write (mpt,0910) 910 format (' STOP 10 0') koprog = 10 go to 9998 9999 write (mpt,9911) koprog,nkind 9911 format (' STOP',2i4) 9998 write (mpt,9997) 9997 format (' EOJ - NO DIM SHEET') if ( koprog .eq. 0 ) koprog = 999 go to 1200 !- 1200 continue !- if ( koprog .ne. 0 ) go to 9000 !- 9000 continue !- END SUBROUTINE