Google
 

Trailing-Edge - PDP-10 Archives - decus_20tap4_198111 - decus/20-0120/cush2.for
There are 2 other files named cush2.for in the archive. Click here to see a list.
00010		PARAMETER NMAT=3
00020		DIMENSION CPAD(22,3),TOLCST(22,3),CCV(46),ICPTRS(22)
00030		DIMENSION WTFAC(22),ITHK(22,3,3),TWT(22,3),VOL(22,3)
00040		DIMENSION CUWT(22,3)
00050		DIMENSION TOPL(22,3),TOPW(22,3),TOPT(22,3),SIDEL(22,3)
00060		DIMENSION SIDEH(22,3)
00070		DIMENSION  SIDET(22,3),ENDH(22,3),ENDW(22,3),ENDT(22,3)
00080		DIMENSION VTF(22),VEF(22),VSF(22),CUCST(22,3),CCST(22,3)
00090		DIMENSION SHCST(22,3),CHGT(22,3),CWIDE(22,3),CLTH(22,3)
00100		DIMENSION COAREA(22,3),CTCCU(22,3),CUAREA(22,3),CTCLO(22,3)
00110		DIMENSION WA(3),FR(3),COT(22,3),COWT(22,3),MLIST(22,12)
00120		DIMENSION A(18,6,22)
00130		DIMENSION SMALL(18,6,NMAT)
00140		EQUIVALENCE (A(1),SMALL(1))
00150		INTEGER NAMFIL
00160		INTEGER NUMFIL(7)
00170		INTEGER DH
00180		DIMENSION CCSQ(4),CWSQ(4)
00190		DIMENSION RPPMF(9),RPPAF(9),RCMMF(4),RCMAF(4)
00200		INTEGER RSC,FTC,CTYPE,YES,NO,ANS,NFILES(8)
00210		REAL ITHK
00220		INTEGER OPTION,ARG2,ARG3,ARG4
00230		DATA NUMFIL/'DH12','DH18','DH24','DH30','DH36',0,0/
00240		DATA IMASK/"377777777777/
00250		DATA RMASK/"377777777777/
00260		DATA MLIST/4H 1  ,4H 2  ,4H 3  ,4H 4  ,4H 5  ,4H 6  ,4H 7  ,
00270	     1	4H 8  ,4H 9  ,4H10  ,4H11  ,4H12  ,4H13  ,
00280	     1	4H14  ,4H15  ,4H16  ,4H17  ,4H18  ,4H19  ,
00290	     1	4H20# ,4H21  ,4H22  ,
00300	     1	4HPOLY,4HPOLY,4HPOLY,4HPOLY,4HPOLY,4HPOLY,4HRUBB,
00310	     1	4HRUBB,4HRUBB,4HPOLY,4HPOLY,4HPOLY,4HPOLY,
00320	     1	4HPOLY,4HCONV,4HCONV,4HCONV,4HCONV,
00330	     1	4HKIMP,4HAIRC,4HWOOD,4HWOOD,
00340	     1	4HURET,4HURET,4HURET,4HURTE,4HURET,4HURET,4HERIZ,
00350	     1	4HERIZ,4HERIZ,4HETHY,4HETHY,4HSTYR,4HSTYR,
00360	     1	4HETHY,4H. ET,4H. ET,4H. ET,4H. ET,
00370	     1	4HAK  ,4HAP T,4HFIBE,4HFIBE,
00380	     1	4HHANE,4HHANE,4HHANE,4HHANE,4HHANE,4HHANE,4HED H,
00390	     1	4HED H,4HED H,4HLENE,4HLENE,4HENE ,4HENE ,
00400	     1	4HLENE,4HHER ,4HHER ,4HHER ,4HHER ,
00410	     1	4H    ,4HYPE ,4HR FE,4HR FE,
00420	     1	4H-ETH,4H-ETH,4H-ETH,4H-EST,4H-EST,4H-EST,4HAIR ,
00430	     1	4HAIR ,4HAIR ,4H FOA,4H FOA,4HFOAM,4HFOAM,
00440	     1	4H MIN,4HPOLY,4HPOLY,4HPOLY,4HPOLY,
00450	     1	4H    ,4HSD-2,4HLT  ,4HLT  ,
00460	     1	4HER  ,4HER  ,4HER  ,4HER  ,4HER  ,4HER  ,4HTYPE,
00470	     1	4HTYPE,4HTYPE,4HM   ,4HM   ,4H    ,4H    ,
00480	     1	4HICEL,4H. 1',4H. 2',4H. 1',4H. 2',
00490	     1	4H    ,4H40  ,4H    ,4H    ,
00500	     1	4H    ,4H    ,4H    ,4H    ,4H    ,4H    ,4H II ,
00510	     1	4H III,4H IV ,4H    ,4H    ,4H    ,4H    ,
00520	     1	4HL L-,4H 2' ,4H 4' ,4H 2' ,4H 4' ,
00530	     1	4H    ,4H    ,4H    ,4H    ,
00540	     1	4H    ,4H    ,4H    ,4H    ,4H    ,4H    ,4H    ,
00550	     1	4H    ,4H    ,4H    ,4H    ,4H    ,4H    ,
00560	     1	4H200 ,4H3'  ,4H6'  ,4H3'  ,4H6'  ,
00570	     1	4H    ,4H    ,4H    ,4H    ,
00580	     1	4HX   ,4HX   ,4HX   ,4HX   ,4HX   ,4HX   ,4HX    ,
00590	     1	4HX   ,4HX   ,4HX   ,4HX   ,4HX   ,4HX   ,
00600	     1	4HX   ,4HX   ,4HX   ,
00610	     1	4HX   ,4HX   ,4HX   ,4HX   ,4HX   ,4HX   ,
00620	     1	4H  X ,4H  X ,4H  X ,4H  X ,4H  X ,4H  X ,4H  X ,
00630	     1	4H  X ,4H  X ,4H  X ,4H  X ,4H  X ,4H  X ,
00640	     1	4H  X ,4H    ,4H    ,
00650	     1	4H    ,4H    ,4H    ,4H    ,4H    ,4H    ,
00660	     1	4H    ,4H    ,4H    ,4H    ,4H    ,4H    ,4H    ,
00670	     1	4H    ,4H    ,4H    ,4H    ,4H    ,4H    ,
00680	     1	4H    ,4H    ,4H    ,
00690	     1	4H    ,4H    ,4H    ,4H    ,4H    ,4H    ,
00700	     1	4HX   ,4HX   ,4HX   ,4HX   ,4HX   ,4HX   ,4H    ,
00710	     1	4H    ,4H    ,4H    ,4H    ,4H    ,4H    ,
00720	     1	4H    ,4HX   ,4HX   ,
00730	     1	4HX   ,4HX   ,4HX   ,4HX   ,4H    ,4H    /
00740		DATA RSC,FTC,YES,NO/3HRSC,3HFTC,3HYES,2HNO/
00750		DATA CCV/0.1388,0.2002,0.41,0.194,0.2522,0.5156,0.0,0.0,0.0,
00760	     1	0.4139,0.525,0.1012,0.225,0.0,0.1539,0.1539,
00770	     1	0.1855,0.1855,0.0886,0.124,0.0,0.0,
00780	     1	0.095,0.095,0.095,0.095,0.095,0.095,
00790	     1	0.1,0.1,0.1,0.1,0.1,0.1,
00800	     1	0.11,0.11,0.11,0.11,0.11,0.11,
00810	     1	0.4972,0.4818,0.4818,0.6206,0.6170,0.6179/
00820		DATA WTFAC/1.5,2.0,4.0,1.5,2.0,4.0,1.1,1.5,2.0,2.0,
00830	     1	4.0,1.5,2.5,2.0,1.15,1.15,1.5,1.5,2.0,0.691,
00840	     1	1.5,2.0/
00850		DATA CCSQ/0.06,0.094,0.07,0.1395/
00860		DATA CWSQ/0.22,0.39,0.32,0.31/
00870		DATA RPPMF/.025,2*.055,.062,.071,.105,.132,.168,.205/
00880		DATA RPPAF/.60,.65,.65,.70,.75,.80,.90,1.0,1.05/
00890		DATA RCMMF/0.0,0.0168,0.0168,0.0143/
00900		DATA RCMAF/16.4,6.4,6.4,6.4/
00910		IRETRN=1
00920	1	NFILE=0
00930		IANS=0
00940	C	MASK COST FOR CERTAIN MATERIALS TO TYPE AS SPACES
00950		DO 3 I3=1,3
00960		CCV(I3+6)=RMASK
00970	3	CONTINUE
00980		CCV(14)=RMASK
00990	C
01000	C
01010	C
01020	C	SECTION TO TYPE INSTRUCTIONS AND TABLES OF DATA
01030	C
01040	C
01050	C
01060		TYPE 5
01070	5	FORMAT(/,/)
01080		CALL P(' P A C K A G E   D E S I G N   P R O G R A M')
01090		TYPE 5
01100		TYPE 5
01110		CALL P(' INSTRUCTIONS? YES OR NO. (LAST CHANGED 15 AUG. 74)')
01120		CALL P('          (MATERIAL PRICES LAST CHANGED 16 APR 76)')
01130		ACCEPT 29999,ANS
01140		IF (ANS.EQ.NO) GO TO 10
01150		IANS=1
01160		CALL P(' SEVERAL OPTIONS, OR A COMBINATION OF OPTIONS,')
01170		CALL P('   ARE AVAILABLE TO THE USER.  TO SELECT THE OPTION')
01180		CALL P('   TYPE IN THE OPTION NUMBER.')
01190		CALL P(' OPTION 1 - PEAK ACCEL FOR AN EXISTING CUSHION PACK.')
01200		CALL P(' OPTION 2 - COMPLETE CUSHION ENCAPSULATION OF AN ITEM.')
01210		CALL P(' OPTION 3 - CORNER PAD CUSHIONING.')
01220		CALL P(' OPTION 4 - CUSHION WRAP.')
01230		TYPE 5
01240		CALL P('THE FOLLOWING TABLE LISTS THE MATERIALS CONSIDERED')
01250		CALL P('BY THE PROGRAM AND THEIR USES.  THEY ARE REFERENCED')
01260		CALL P('BY THE NUMBER IN THE LEFT MOST COLUMN.')
01270		TYPE 5
01280		TYPE 2000
01290	2000	FORMAT(' MAT',5X,'MATERIAL NAME',16X,'USES',9X,
01300	     1	'DENSITY',4X,'COST')
01310		TYPE 2010
01320	2010	FORMAT('+___',5X,'________ ____',16X,'____',9X,
01330	     1	'_______',4X,'____')
01340		TYPE 2020
01350	2020	FORMAT(' ',30X,'ENCAP C-PADS WRAP  LBS/CU FT  $/BD FT')
01360		DO 2050 I2050=1,NMAT
01370		TYPE 2040,(MLIST(I2050,I2030),I2030=1,12),
01380	     1	WTFAC(I2050),CCV(I2050)
01390	2040	FORMAT(' ',12A4,F8.3,4X,F7.4)
01400	2050	CONTINUE
01410		CALL P('# DATA AVAILABLE FOR 1, 2, & 3 IN. THICKNESSES ONLY')
01420		TYPE 5
01430		TYPE 2060
01440	2060	FORMAT(' COST FOR SPECIAL MATERIALS:')
01450		TYPE 2070
01460	2070	FORMAT(10H MAT.   1',6X,2H2',6X,2H3',6X,2H4',6X,2H5',6X,2H6')
01470		TYPE 2080,(CCV(I2080),I2080=23,28)
01480	2080	FORMAT('  7  ',6F8.4)
01490		TYPE 2090,(CCV(I2090),I2090=29,34)
01500	2090	FORMAT('  8  ',6F8.4)
01510		TYPE 2100,(CCV(I2100),I2100=35,40)
01520	2100	FORMAT('  9  ',6F8.4)
01530		TYPE 2110,(CCV(I2110),I2110=41,46)
01540	2110	FORMAT(' 14  ',6F8.4)
01550		TYPE 5
01560		CALL P('CONTAINER MATERIAL DATA- ')
01570		CALL P('NUM MATERIAL TYPE      COST/SQ. FT     WGT./SQ. FT.')
01580		CALL P(' 1  SINGLE WALL V3C      $ .0600         .22 LBS.')
01590		CALL P(' 2  DOUBLE WALL V11C     $ .0940         .39 LBS.')
01600		CALL P(' 3  SOLID WALL V2S       $ .0700         .32 LBS.')
01610		CALL P(' 4  SOLID WALL V3S       $ .1395         .31 LBS.')
01620		TYPE 5
01630		TYPE 5
01640		CALL P('      TRANSPORTATION TABLE')
01650		CALL P('MODE       TYPE       DISTANCE')
01660		CALL P(' 1    PARCEL POST     ZONE 1-8 ( 0 FOR LOCAL )')
01670		CALL P(' 2    COMMERCIAL AIR  AIR MILES')
01680		CALL P(' 3    TRUCK           ROAD MILES')
01690		CALL P(' 4    LOGAIR          AIR MILES')
01700		CALL P(' 5    NO SHIPPING COST COMPUTATION (USE 0 FOR DIST)')
01710		TYPE 5
01720	C
01730	C
01740	C
01750	C	SECTION TO ACCEPT DATA FOR CALCULATIONS
01760	C
01770	C
01780	C
01790	C	SET FLAGS INDICATING CALCULATIONS HAVE NOT BEEN DONE
01800	10	IOPT2=0
01810		IOPT3=0
01820		IOPT4=0
01830	11	CALL P(' OPTION?')
01840	15	ACCEPT 15999,OPTION
01850	15999	FORMAT (I)
01860		IF (OPTION.GE.1.AND.OPTION.LE.4) GO TO 1030
01870		CALL P(' OPTION SELECTED IS NOT AVAILABLE. PLEASE RE-INPUT')
01880		GO TO 15
01890	C	IF IOPTT = 0  ALL DATA IS TO BE INITIALIZED
01900	1030	IOPTT=IOPT2+IOPT3+IOPT4
01910		IF(IOPTT.EQ.0)  GO TO 21
01920	C	REQUEST FOR MORE CALCULATIONS USING DATA ALREADY SUPPLIED
01930		GO TO ( 21 ,1032,1034,1036), OPTION
01940	C	CHECK TO DETERMINE IF OPTION REQUESTED HAS BEEN COMPLETED
01950	C	IF CALCULATIONS COMPLETE SET JJ THEN TYPE
01960	C	OTHERWISE TRANSFER TO COMPLETE CALCULATIONS
01970	1032	IF(IOPT2.EQ.0)  GO TO 200
01980		JJ=1
01990		GO TO 1720
02000	1034	IF(IOPT3.EQ.0)  GO TO 300
02010		JJ=2
02020		GO TO 1720
02030	1036	IF(IOPT4.EQ.0)  GO TO 400
02040		JJ=3
02050		GO TO 1720
02060	C
02070	21	CALL P(' DROP HEIGHT IN INCHES.')
02080	20	ACCEPT 29998,DH
02090	C	VALIDATE DROP HEIGHT
02100		INTDH=DH/6
02110		IF (INTDH*6.NE.DH) GO TO 25
02120	C
02130	C	NORMALIZE INTDH TO 1,2,...
02140	C
02150		INTDH=INTDH-1
02160	C
02170	C	IF WE ALREADY HAVE THAT FILE OPEN, SKIP ACCESSING IT
02180	C
02190		IF (NFILE.EQ.INTDH) GO TO 13
02200		IF (INTDH.LE.7) GO TO 24
02210	25	CALL P('DROP HEIGHT MUST BE 12, 18, 24, 30, 36, 42, OR 48')
02220		CALL P('PLEASE RE-INPUT.')
02230		GO TO 20
02240	22	TYPE 22999,NAMFIL
02250	22999	FORMAT (' ACCESS ERROR ',A10)
02260		STOP
02270	C	SET DROP HEIGHT FILE FLAG AND READ,PERM. FILE DATA FOR THE DH
02280	24	IF(NFILE.EQ.0)  GO TO 26
02290	C	RELEASE ACCESS TO DROP HEIGHT FILE SO ANOTHER CAN BE READ
02300		CLOSE (UNIT=1)
02310	26	NAMFIL=NUMFIL(INTDH)
02320		NFILE=INTDH
02330		IF (NAMFIL.NE.0) GO TO 2699
02340		TYPE 2799
02350	2799	FORMAT (' NO FILE FOR THIS HEIGHT - TRY AGAIN')
02360		GO TO 21
02370	C	OBTAIN ACCESS TO PERM FILE OF DROP HEIGHT DATA
02380	2699	OPEN (UNIT=1,FILE=NAMFIL,ACCESS='SEQIN')
02390	C	READ 18 COEFFICIENTS DESCRIBING 3 EQNS. OF DEGREE 3
02400		READ(1,27) SMALL
02410	27	FORMAT(6F)
02420	C
02430	13	IF (OPTION.EQ.1) GO TO 100
02440	C
02450	C	READ DATA FOR OPTIONS 2, 3, & 4
02460	C
02470	32	CALL P('INPUT DIMENSIONS OF ITEM IN ORDER OF LENGTH,')
02480		CALL P('WIDTH, HEIGHT.  ALL DIMENSIONS MUST BE IN INCHES.')
02490		ACCEPT 29997,RLTH,WIDE,HGT
02500		IF(RLTH.GE.WIDE.AND.WIDE.GE.HGT)  GO TO 34
02510		CALL P('DIMENSIONS MUST HAVE LONGEST FIRST & SHORTEST LAST')
02520		GO TO 32
02530	C
02540	34	CALL P('WEIGHT IN POUNDS?')
02550		ACCEPT 29997,WGT
02560	C
02570		CALL P('FRAGILITY RATINGS OF TOP,SIDE, AND END FACES.')
02580		ACCEPT 29997,FR
02590	C
02600		CALL P('TYPE OF CONTAINER- INDICATE "RSC" FOR REGULAR SLOTTED')
02610		CALL P(' CONTAINER')
02620		CALL P('          OR "FTC" FOR FULL TELESCOPE CONTAINER,')
02630	1045	ACCEPT 29999,CTYPE
02640		IF(CTYPE.EQ.RSC.OR.CTYPE.EQ.FTC)  GO TO 1050
02650		CALL P(' TYPE OF CONTAINER MUST BE EITHER RSC OR FTC')
02660		GO TO 1045
02670	C
02680	1050	CALL P('CONTAINER MAT. NUM. (1 THRU 4 ARE STD.)')
02690		ACCEPT 29998,NCON
02700	29998	FORMAT (I)
02710	29997	FORMAT (F)
02720		IF(NCON.LT.1.OR.NCON.GT.4)  GO TO 1060
02730	C	STANDARD CONTAINER - GET COST & DENSITY FROM STORAGE
02740		CCSQF=CCSQ(NCON)
02750		CWSQF=CWSQ(NCON)
02760		GO TO 1070
02770	C	USER CHOOSES TO INPUT HIS OWN CONTAINER COST & DENSITY SPECS.
02780	1060	CALL P('CONTAINER MAT. DATA- COST/SQ. FT. & WGT./SQ. FT.')
02790		ACCEPT 29997,CCSQF,CWSQF
02800	C
02810	1070	CALL P('TRANSPORTATION MODE & DISTANCE?')
02820	1075	ACCEPT 29998,ITTYPE,ITDIST
02830		IF(ITTYPE.GE.1.AND.ITTYPE.LE.5)  GO TO 1077
02840		CALL P('MODE MUST BE 1, 2, 3, OR 4- PLEASE REINPUT.')
02850		GO TO 1075
02860	1077	IF(ITTYPE.NE.3)  GO TO 1080
02870		IF(WGT.LT.100.)  GO TO 1080
02880		CALL P('SHIPPING COST MAY NOT BE VALID FOR WGT > 100')
02890		CALL P('IF SHIPPING COST DESIRED INPUT 3 - ELSE INPUT 5')
02900		ACCEPT 29998,ITTYPE
02910	1080	IF(ITTYPE.NE.1)  GO TO 1085
02920	C	FOR PARCEL POST MODIFY ZONE INDICATOR
02930		ITDIST=ITDIST+1
02940		IF(ITDIST.GT.0.AND.ITDIST.LT.10)  GO TO 1085
02950		CALL P('INCORRECT ZONE FOR PARCEL POST-   RE-ENTER')
02960		GO TO 1070
02970	C
02980	C	CALCULATE STATIC STRESS FOR EACH FACE
02990	1085	WA(1)=WGT/(RLTH*WIDE)
03000		WA(2)=WGT/(RLTH*HGT)
03010		WA(3)=WGT/(WIDE*HGT)
03020	C
03030	C	TRANSFER TO DO CALCULATIONS FOR OPTION CHOSEN
03040		GO TO (100,200,300,400),OPTION
03050	C
03060	C
03070	C
03080	C	*** THIS SECTION COMPUTES PEAK ACCELERATION ***
03090	C
03100	C
03110	C
03120	C	READ,MATERIAL IDENTIFIER AND VALIDATE
03130	100	CALL P('INPUT NUMBER OF MATERIAL')
03140	110	ACCEPT 29998,I
03150		IF(I.GT.0.AND.I.LE.NMAT)  GO TO 105
03160		CALL P('NO DATA AVAIL. OR INCORRECT CODE-  RE-INPUT')
03170		GO TO 110
03180	105	CALL P('INPUT WEIGHT(IN POUNDS) AND AREA (SQ. IN.).')
03190	120	ACCEPT 29997,WGT1,AREA
03200		JJ=0
03210	C	CALCULATE STATIC STRESS FOR THE ITEM
03220		WA0=WGT1/AREA
03230	115	CALL P('INPUT THICKNESS OF MATERIAL.')
03240	130	ACCEPT 29997,TK
03250	13099	FORMAT (2A)
03260		K=IFIX(TK)
03270		XK=K
03280	C	VALIDATE GIVEN THICKNESS- 6' MAX.
03290		IF(I.EQ.15.AND.TK.GT.3.0)  GO TO 127
03300		IF (TK.GE.1.AND.TK.LE.6.0)  GO TO 125
03310	C
03320	127	CALL P('THICKNESS MUST BE BETWEEN 1 & 6 INCHES.')
03330		CALL P('(1.0 & 3.0 FOR MATERIAL 15)')
03340		CALL P('PLEASE RE-INPUT.')
03350		GO TO 130
03360	C	LOOP TO LOCATE PROPER SECTION OF THICKNESS CURVE
03370	C	AND CALCULATE PEAK ACCELERATION
03380	125	L=1
03390	126	ARG1=WA0
03400		ARG2=I
03410		ARG3=K
03420		ARG4=L
03430		IRETRN=1
03440	C	TRANSFER TO CALCULATE LEVEL OF PROTECTION
03450		GO TO 4000
03460	152	GO TO (150,1000,19),IFLAG
03470	150	L=L+6
03480	C	TRY NEXT SECTION OF CURVE
03490		IF(L.LT.18)  GO TO 126
03500	C
03510	1010	TYPE 10109,WA0
03520	10109	FORMAT('INSUFFICIENT DATA FOR WGT, TO AREA RATIO OF ',F10.5)
03530		GO TO 19
03540	C	*** IF THE THICKNESS IS AN INTEGER, INTERPOLATION NOT NEEDED
03550	1000	IF(TK.EQ.XK)  GO TO 170
03560	C	INCREMENT SUBSCRIPT FOR NEXT THICKNESS AND SAVE ACCELERATION
03570		K=K+1
03580		Y1=Y
03590	C	SET PARAMETERS FOR LEVEL OF PROTECTION CALCULATION
03600		LL=1
03610	155	ARG1=WA0
03620		ARG2=I
03630		ARG3=K
03640		ARG4=LL
03650		IRETRN=2
03660	C	TRANSFER TO CALCULATE LEVEL OF PROTECTION
03670		GO TO 4000
03680	162	Y2=Y
03690		GO TO (160,165,19),IFLAG
03700	160	LL=LL+6
03710	C	TRY NEXT SECTION OF CURVE
03720		IF(LL.LT.16)  GO TO 155
03730		GO TO 1010
03740	C	LINEAR INTERPOLATION BETWEEN VALUES
03750	165	Y=Y1-(TK-XK)*(Y1-Y2)
03760	170	CONTINUE
03770	C	PRINT,RESULT
03780		TYPE 5
03790		TYPE 190,Y
03800	190	FORMAT ('   PEAK ACCELERATION ='F10.3)
03810		TYPE 5
03820	C	TRANSFER TO CHECK FOR END OF TIME-SHARING SESSION
03830		GO TO 19
03840	C
03850	C
03860	C
03870	C	THIS SECTION COMPUTES DATA FOR COMPLETE ENCAPSULATION
03880	C
03890	C
03900	C
03910	C	SET FLAG INDICATING THAT ENCAPSULATION HAS BEEN ACCOMPLISHED
03920	200	IOPT2=1
03930		JJ=1
03940	C	LOOP TO VARY THE MATERIAL CONSIDERED
03950		I=0
03960	202	I=I+1
03970		TOLCST(I,JJ)=0
03980	C	LOOP TO VARY THE FACES OF THE ITEM
03990		II=0
04000	204	II=II+1
04010		YTEMP=0.0
04020		Y=0.0
04030		KTHK=6
04040		IF(I.EQ.15)  KTHK=3
04050		ITHK(I,JJ,II)=0
04060	C	LOOP TO VARY THE MATERIAL THICKNESS USED
04070		K=0
04080	206	K=K+1
04090	C	LOOP TO VARY THE SECTION OF THICKNESS CURVE TO BE CONSIDERED
04100		L=1
04110	208	ARG1=WA(II)
04120		ARG2=I
04130		ARG3=K
04140		ARG4=L
04150		IRETRN=3
04160		GO TO 4000
04170	242	GO TO (240,260,210),IFLAG
04180	C	IF 'ACCELERATION > FRAGILITY' INADEQUATE PROTECTION
04190	260	IF(Y.GT.FR(II))  GO TO 236
04200	C	THICKNESS 'K' PROVIDES PROTECTION
04210	C	TRANSFER IF INTERPOLATION CAN BE TRIED
04220		IF(YTEMP.NE.0.0)  GO TO 253
04230	C	ASSIGN THICKNESS 'K'
04240	250	ITHK(I,JJ,II)=K
04250		GO TO 220
04260	C	LINEAR INTERPOLATION MIDWAY BETWEEN CURVES
04270	253	DIFF=(YTEMP+Y)/2
04280	C	IF INTERPOLATED VALUE IS WITHIN 5% OF FRAGILITY USE THE
04290	C	INTERPOLATED THICKNESS
04300		IF (FR(II)-(.95*DIFF)) 250,254,254
04310	C	ASSIGN THE INTERPOLATED THICKNESS
04320	254	ITHK(I,JJ,II)=K-.5
04330		GO TO 220
04340	235	IF(K.LT.KTHK)  GO TO 251
04350		GO TO 210
04360	C	IF ACCELERATION IS WITHIN 5% OF FRAGILITY USE THICKNESS 'K'
04370	236	IF(FR(II)-(0.95*Y)) 235,250,250
04380	240	L=L+6
04390	C	TRANSFER TO START LOOP FOR NEXT SECTION OF CURVE
04400		IF(L.LT.18)  GO TO 208
04410		IF(K.LT.KTHK)  GO TO 206
04420	245	GO TO 210
04430	C	SAVE CALCULATED ACCELERATION FOR INTERPOLATION
04440	251	YTEMP=Y
04450		IF(I.GT.14.AND.I.LT.19)  YTEMP=0.0
04460	C	TRANSFER TO START LOOP FOR NEXT MATERIAL THICKNESS
04470	230	IF(K.LT.KTHK)  GO TO 206
04480	C	TRANSFER TO START LOOP FOR NEXT FACE OF ITEM
04490	220	IF(II.LT.3)  GO TO 204
04500		TOLCST(I,JJ)=-1.0
04510	C	TRANSFER TO START OF LOOP FOR NEXT MATERIAL
04520	210	IF(I.LT.NMAT)  GO TO 202
04530	C
04540	C	ALL MATERIALS HAVE BEEN CONSIDERED- TRANSFER TO CALC. COSTS
04550	C
04560		GO TO 700
04570	C
04580	C
04590	C
04600	C	THIS SECTION COMPUTES DATA FOR CORNER PADS
04610	C
04620	C
04630	C
04640	300	IOPT3=1
04650		JJ=2
04660		KTHK=6
04670	C	LOOP TO VARY MATERIAL BEING CONSIDERED
04680		I=0
04690	302	I=I+1
04700		IF(I.GT.14)  GO TO 497
04710		TOLCST(I,JJ)=0
04720	C	LOOP TO VARY THE FACE TO BE CONSIDERED
04730		II=0
04740	304	II=II+1
04750		ITHK(I,JJ,II)=0
04760	C	LOOP TO VARY THE THICKNESS BEING CONSIDERED
04770		K=0
04780	306	K=K+1
04790		XU=0.0
04800		XMID=0.0
04810	C	LOOP TO VARY THE SECTION OF CURVE BEING CONSIDERED
04820		LX=1
04830	308	L=14-LX
04840		L=14-LX
04850	C	RIGHT HAND BOUNDARY
04860		U=A(L+5,K,I)
04870	C	LEFT HAND BOUNDARY
04880		V=A(L+4,K,I)
04890	C	COEFFICIENTS FOR THE THIRD, SECOND, & FIRST DEGREE TERMS
04900		C1=A(L+3,K,I)
04910		C2=A(L+2,K,I)
04920		C3=A(L+1,K,I)
04930	C	CONSTANT TERM
04940		C4=A(L,K,I)
04950	C	CHECK FOR PROPER SECTION OF CURVE
04960		IF (WA(II).GT.U) GO TO 500
04970		IF(V.LT.WA(II))  V=WA(II)
04980	C	CHECK FOR A LINE PARALLEL TO THE X-AXIS
04990		IF (C1.EQ.0.AND.C2.EQ.0.AND.C3.EQ.0) GO TO 1020
05000		GO TO 1025
05010	1020	IF (C4.GT.FR(II))  GO TO 500
05020		XMID=U
05030		GO TO 560
05040	C	IF QUADRATIC EQN. LET X1 EQUAL THE CRITICAL VALUE OF THE EQN.
05050	1025	IF (C1.EQ.0.AND.C2.NE.0) X1=-C3/(C2*2.0)
05060	C	IF LINEAR EQN. LET X1 EQUAL 0 ( NO CRITICAL VALUE )
05070		IF (C1.EQ.0.AND.C2.EQ.0)  X1=0
05080	C	X2 IS THE SECOND CRITICAL VALUE
05090		X2=0
05100		IF(C1.EQ.0)  GO TO 506
05110	C	CUBIC EQN. - FIND CRITICAL POINTS  USING THE DERIVITIVE
05120	505	VAL=(-2.*C2)**2-4.*3.*C1*C3
05130	C	VAL IS THE DISCRIMINANT WHEN THE QUADRATIC DERIVITIVE IS
05140	C	SOLVED BY FORMULA SUBSTITUTION
05150		IF (VAL.GE.0) GO TO 503
05160	C	IF VAL IS NEGATIVE THE EQN. IS MONOTONIC INCREASING OR
05170	C	MONOTONIC DECREASING
05180		X1=0
05190		X2=0
05200		ISW=1
05210		GO TO 508
05220	C	COMPUTE THE 2 CRITICAL VALUES
05230	503	X1=(-2.*C2+SQRT(VAL))/(2.*3.*C1)
05240		X2=(-2.*C2-SQRT(VAL))/(2.*3.*C1)
05250	C
05260	C	USE 'ISW' TO INDICATE WHERE THE CRITICAL VALUES LIE IN
05270	C	RELATION TO THE EQUATION BOUNDARIES-
05280	C	1- BOTH VALUES OUTSIDE INTERVAL, 2- X1 IN THE INTERVAL
05290	C	3- X2 IN THE INTERVAL, 4- BOTH VALUES INSIDE INTERVAL
05300	C
05310	506	ISW=1
05320		IF (X1.GT.V.AND.X1.LT.U) GO TO 507
05330		IF (X2.GT.V.AND.X2.LT.U) ISW=3
05340		GO TO 508
05350	507	ISW =2
05360		IF (X2.GT.V.AND.X2.LT.U) ISW=4
05370	C	CALCULATE PEAK ACCELERATION AT BOUNDARY & CRITICAL POINTS
05380	508	YX1=C1*X1**3+C2*X1**2+C3*X1+C4
05390		YX2=C1*X2**3+C2*X2**2+C3*X2+C4
05400		YU=C1*U**3+C2*U**2+C3*U+C4
05410		YV=C1*V**3+C2*V**2+C3*V+C4
05420		IF(YU.LT.0.0.OR.YV.LT.0.0)  GO TO 513
05430		IF(YX1.LT.0.0.AND.ISW.EQ.2)  GO TO 513
05440		IF(YX1.LT.0.0.AND.ISW.EQ.4)  GO TO 513
05450		IF(YX2.LT.0.0.AND.ISW.EQ.3)  GO TO 513
05460		IF(YX2.LT.0.0.AND.ISW.EQ.4)  GO TO 513
05470	C	DETERMINE IF THE RIGHT HAND BOUNDARY CAN BE USED
05480		IF (U.LE.XU)  GO TO 504
05490		XU=U
05500		IF(FR(II).LE.YU)  GO TO 504
05510		XMID=XU
05520		GO TO 560
05530	C	TRANSFER BASED ON THE SLOPE AT THE RIGHT HAND BOUNDARY
05540	504	IF(3.*C1*U**2 +2.*C2*U +C3) 509,555,550
05550	C	TRANSFER BASED ON THE LOCATION OF THE CRITICAL VALUES
05560	509	GO TO (510,520,530,540),ISW
05570	550	GO TO (515,525,535,545),ISW
05580	555	IF(3.*C1*(U-.01)**2+2.*C2*(U-.01+C3)) 509,509,550
05590	C	ITERATE TO FIND THE PROPER STATIC STRESS BETWEEN EST1 & EST2
05600	511	XMID=(EST1+EST2)/2.0
05610		YM=C1*XMID**3+C2*XMID**2+C3*XMID+C4
05620	C	VERIFY THAT PEAK ACCELERATION IS > 0
05630		IF(YM.GT.0.0)  GO TO 512
05640	C	TYPE ERROR MESSAGES
05650	513	TYPE 3000
05660		TYPE 3010,NFILE,I,K,XMID
05670		TYPE 3020
05680		GO TO 497
05690	C	IS PEAK ACCELERATION WITHIN 1% OF FRAGILITY
05700	512	IF (YM.GT.(.99*FR(II)).AND.YM.LT.(1.01*FR(II))) GO TO 560
05710	C	RESET ONE BOUNDARY VALUE
05720		IF (YM.GT.FR(II)) EST1=XMID
05730		IF (YM.LT.FR(II)) EST2=XMID
05740		GO TO 511
05750	C	STATEMENTS '510, 515, ... ,545' SET THE BOUNDARIES FOR
05760	C	ITERATION AND DETERMINE IF THE ITERATION WILL SUCCEED
05770	510	EST1=V
05780		EST2=U
05790		IF (FR(II).GE.YU.AND.FR(II).LE.YV) GO TO 511
05800		GO TO 500
05810	515	EST1=U
05820		EST2=V
05830		IF (FR(II).GE.YV.AND.FR(II).LE.YU) GO TO 511
05840		GO TO 500
05850	520	EST1=X1
05860		EST2=U
05870		IF(FR(II).GE.YU.AND.FR(II).LE.YX1) GO TO 511
05880		EST2=V
05890		IF (FR(II).GE.YV.AND.FR(II).LE.YX1) GO TO 511
05900		GO TO 500
05910	525	EST1=U
05920		EST2=X1
05930		IF (FR(II).GE.YX1.AND.FR(II).LE.YU) GO TO 511
05940		EST1=V
05950		IF (FR(II).GE.YX1.AND.FR(II).LE.YV) GO TO 511
05960		GO TO 500
05970	530	EST1=X2
05980		EST2=U
05990		IF (FR(II).GE.YU.AND.FR(II).LE.YX2) GO TO 511
06000		EST2=V
06010		IF (FR(II).GE.YV.AND.FR(II).LE.YX2) GO TO 511
06020		GO TO 500
06030	535	EST1=U
06040		EST2=X2
06050		IF (FR(II).GE.YX2.AND.FR(II).LE.YU) GO TO 511
06060		EST1=V
06070		IF (FR(II).GE.YX2.AND.FR(II).LE.YV) GO TO 511
06080		GO TO 500
06090	540	IF (X1-X2) 541,530,542
06100	541	EST1=X2
06110		EST2=U
06120		IF (FR(II).GE.YU.AND.FR(II).LE.YX2) GO TO 511
06130		EST2=X1
06140		IF (FR(II).GE.YX1.AND.FR(II).LE.YX2) GO TO 511
06150		EST1=V
06160		IF (FR(II).GE.YX1.AND.FR(II).LE.YV) GO TO 511
06170		GO TO 500
06180	542	EST1=X1
06190		EST2=U
06200		IF (FR(II).GE.YU.AND.FR(II).LE.YX1) GO TO 511
06210		EST2=X2
06220		IF (FR(II).GE.YX2.AND.FR(II).LE.YX1) GO TO 511
06230		EST1=V
06240		IF (FR(II).GE.YX2.AND.FR(II).LE.YV) GO TO 511
06250		GO TO 500
06260	545	IF (X1-X2) 546,535,547
06270	546	EST1=U
06280		EST2=X2
06290		IF (FR(II).GE.YX2.AND.FR(II).LE.YU) GO TO 511
06300		EST1=X1
06310		IF (FR(II).GE.YX2.AND.FR(II).LE.YX1) GO TO 511
06320		EST2=V
06330		IF (FR(II).GE.YV.AND.FR(II).LE.YX1) GO TO 511
06340		GO TO 500
06350	547	EST1=U
06360		EST2=X1
06370		IF (FR(II).GE.YX1.AND.FR(II).LE.YU) GO TO 511
06380		EST1=X2
06390		IF (FR(II).GE.YX1.AND.FR(II).LE.YX2) GO TO 511
06400		EST2=V
06410		IF (FR(II).GE.YV.AND.FR(II).LE.YX2) GO TO 511
06420		GO TO 500
06430	560	IF(K.LT.KTHK)  GO TO 561
06440		IF(WA(II).LT.XMID)  GO TO 565
06450	559	GO TO 497
06460	C	IF STATIC STRESS 'XMID' TOO SMALL TRY NEXT THICKNESS
06470	561	IF(WA(II).LE.XMID)  GO TO 565
06480		GO TO 499
06490	C	ASSIGN THICKNESS OF CUSHIONING
06500	565	ITHK(I,JJ,II)=K
06510	C	CALCULATE CUSHIONING AREA
06520		BAREA=(WGT/XMID)/4.0
06530		CPAD(I,II)=SQRT(BAREA)
06540		GO TO 498
06550	500	LX=LX+6
06560	C	TRANSFER TO TRY NEXT SECTION OF CURVE
06570		IF(LX.LT.18)  GO TO 308
06580	C	TRANSFER TO TRY NEXT THICKNESS OF MATERIAL
06590	499	IF(K.LT.KTHK)  GO TO 306
06600		GO TO 497
06610	C	TRANSFER TO CALCULATE FOR NEXT FACE
06620	498	IF(II.LT.3)  GO TO 304
06630	C	SAVE RESULTS FOR FACE 2- IN CASE RESTORATION NECESSARY
06640		CPAD2=CPAD(I,2)
06650		THK2=ITHK(I,JJ,2)
06660	C
06670	C	ASSIGN THE SAME THICKNESS AND AREA TO FACES 2 & 3
06680		IF(ITHK(I,JJ,2).LT.ITHK(I,JJ,3)) GO TO 591
06690		IF (ITHK(I,JJ,2).GT.ITHK(I,JJ,3)) GO TO 592
06700		IF (CPAD(I,2).LT.CPAD(I,3)) GO TO 591
06710		IF (CPAD(I,2).GT.CPAD(I,3)) GO TO 592
06720		GO TO 593
06730	591	ITHK(I,JJ,2) = ITHK(I,JJ,3)
06740		CPAD (I,2)=CPAD(I,3)
06750		GO TO 593
06760	592	ITHK(I,JJ,3) = ITHK(I,JJ,2)
06770		CPAD(I,3)=CPAD(I,2)
06780	593	CONTINUE
06790	C	LOOP TO CALCULATE THE SIZE OF EACH PAD BASED ON THE SIZE
06800	C	OF THE PAD FOR FACE 1
06810		DO 597 II=1,3
06820		BAREA = CPAD (I,II)**2
06830		CPAD(I,II) = BAREA/CPAD(I,1)
06840	597	CONTINUE
06850	C	CHECK TO VERIFY THAT THE CALCULATED SIZES ARE ACCEPTABLE
06860		IF(CPAD(I,1)*2.GT.RLTH.OR.CPAD(I,1)*2.GT.WIDE) GO TO 577
06870		IF(CPAD(I,2)*2.GT.RLTH.OR.CPAD(I,2)*2.GT.HGT) GO TO 577
06880		IF(CPAD(I,3)*2.GT.WIDE.OR.CPAD(I,3)*2.GT.HGT) GO TO 577
06890	C	CALCULATE THE COMBINED VOLUME OF ALL 8 CORNER PADS
06900		VOL(I,JJ)=8.0*(CPAD(I,1)**2*ITHK(I,JJ,1)+
06910	     1	(CPAD(I,2)+ITHK(I,JJ,1))*ITHK(I,JJ,2)*CPAD(I,1)+
06920	     1	(CPAD(I,3)+ITHK(I,JJ,1))*(CPAD(I,1)+ITHK(I,JJ,2))*ITHK(I,JJ,3))
06930		CUAREA(I,JJ)=8.0*(CPAD(I,1)**2+(CPAD(I,2)+ITHK(I,JJ,1))*
06940	     1	CPAD(I,1)+(CPAD(I,3)+ITHK(I,JJ,11))*
06950	     1	(CPAD(I,1)+ITHK(I,JJ,2)))/144.0
06960		TOLCST(I,JJ)=-1.0
06970	497	IF(I.LT.NMAT) GO TO 302
06980	C	ALL MATERIALS HAVE BEEN CONSIDERED- TRANSFER TO CALC. COSTS
06990		GO TO 700
07000	C	PADS FOR SIDE OR END OVERLAP EACH OTHER --
07010	C	IF POSSIBLE TRY THICKER PADS FOR FACES 2 & 3
07020	577	IF(K.LT.6) GO TO 578
07030		ITHK(I,JJ,II)=0
07040		GO TO 497
07050	C	RESET ORIGINAL SIZE OF FACE 2, THEN TRY NEXT THICKNESS
07060	578	CPAD(I,2)=CPAD2
07070		ITHK(I,JJ,2)=THK2
07080		GO TO 499
07090	C
07100	C
07110	C
07120	C	THIS SECTION COMPUTES DATA FOR WRAPPING THE ITEM
07130	C
07140	C
07150	C
07160	400	JJ=3
07170		IOPT4=1
07180		CALL P('INPUT PLY THICKNESS (USED FOR ALL MATERIALS)')
07190		ACCEPT 29997,PLYTK
07200	C	LOOP TO VARY THE MATERIALS
07210		I=0
07220	402	I=I+1
07230		IF(I.GT.20) GO TO 410
07240		IF(I.GT.6.AND.I.LT.15) GO TO 410
07250		TOLCST(I,JJ)=0
07260		KTHK=6
07270		IF(I.EQ.15) KTHK=3
07280	C	LOOP TO VARY THE FACE BEING CONSIDERED
07290		II=0
07300	404	II=II+1
07310		ITHK(I,3,II)=0.0
07320		Y=0.0
07330		YTEMP=0.0
07340	C	LOOP TO VARY THE MATERIAL THICKNESS
07350		KX=0
07360	406	KX=KX+1
07370	C	LOOP TO VARY THE SECTION OF THE CURVE BEING CONSIDERED
07380		L=1
07390	408	ARG1=WA(II)
07400		ARG1=WA(II)
07410		ARG2=I
07420		ARG3=KX
07430		ARG4=L
07440		IRETRN=4
07450	C	TRANSFER TO CALCULATE LEVEL OF PROTECTION
07460		GO TO 4000
07470	432	GO TO (440,460,410),IFLAG
07480	460	RKX=KX
07490	C	TRANSFER IF PROTECTION IS ADEQUATE
07500		IF(FR(II).GE.(0.95*Y)) GO TO 450
07510		IF(KX.LT.KTHK) GO TO 435
07520		GO TO 410
07530	C	DETERMINE IF LINEAR INTERPOLATION CAN BE USED
07540	450	IF(YTEMP.EQ.0.0) GO TO 480
07550	C	CALCULATE INTERPOLATED VALUE
07560		DIFF=(YTEMP+Y)/2.0
07570	C	IF INTERPOLATED VALUE IS ADEQUATE REDUCE REQUIRED THICKNESS
07580		IF(FR(II).GE.(0.95*DIFF)) RKX=KX-0.5
07590	C	CALCULATE & SAVE THE REQUIRED NUMBER OF PLYS OF MATERIAL
07600	480	NPLYS=RKX/PLYTK
07610		IF(RKX-NPLYS*PLYTK.GE.0.125) NPLYS=NPLYS+1
07620		ITHK(I,JJ,II)=NPLYS
07630		GO TO 420
07640	440	L=L+6
07650	C	TRANSFER TO TRY NEXT SECTION OF CURVE
07660		IF(L.LT.18) GO TO 408
07670	C	SAVE THE EXCESSIVE ACCELERATION FOR INTERPOLATION
07680	435	YTEMP=Y
07690	C	TRANSFER TO TRY NEXT THICKNESS OF MATERIAL
07700	430	IF(KX.LT.KTHK) GO TO 406
07710	425	GO TO 410
07720	C	TRANSFER TO CALCULATE FOR NEXT FACE
07730	420	IF(II.LT.3) GO TO 404
07740	C	DETERMINE THE MAXIMUM NUMBER OF PLYS NEEDED
07750		MAXPLY=ITHK(I,JJ,1)
07760		IF(ITHK(I,JJ,2).GT.MAXPLY) MAXPLY=ITHK(I,JJ,2)
07770		IF(ITHK(I,JJ,3).GT.MAXPLY) MAXPLY=ITHK(I,JJ,3)
07780	C	CALCULATE & SAVE THE THICKNESS OF CUSHIONING
07790		THK=MAXPLY*PLYTK
07800		ITHK(I,JJ,1)=THK
07810		ITHK(I,JJ,2)=THK
07820		ITHK(I,JJ,3)=THK
07830	C	LOOP TO START CALCULATION OF LENGTH OF WRAP NEEDED
07840		WLT=0.0
07850		DO 415 I415=1,MAXPLY
07860		WLT=WLT+(2.0*I415-1)*PLYTK/2.0
07870	415	CONTINUE
07880	C
07890	C	CALCULATE LENGTH, AREA, WIDTH, & VOLUME OF MATERIAL
07900		TOPL(I,JJ)=2.0*MAXPLY*(WIDE+HGT)+6.28*WLT
07910		CUAREA(I,JJ)=TOPL(I,JJ)*(RLTH+HGT)/144.0
07920		TOPW(I,JJ)=RLTH+HGT
07930		VOL(I,JJ)=TOPL(I,JJ)*(RLTH+HGT)*PLYTK
07940		TOLCST(I,JJ)=-1.0
07950	C	TRANSFER TO CONSIDER NEXT MATERIAL
07960	410	IF(I.LT.NMAT) GO TO 402
07970	C	ALL MATERIALS CONSIDERED- TRANSFER TO CALC. COSTS
07980		GO TO 700
07990	C
08000	C
08010	C
08020	C	THIS SECTION COMPUTES COSTS FOR ALL MATERIALS THAT
08030	C	PROVIDE ADEQUATE PROTECTION
08040	C
08050	C
08060	C
08070	700	DO 799 I=1,NMAT
08080		IF(TOLCST(I,JJ).EQ.0.0) GO TO 799
08090		IF(JJ.NE.1) GO TO 750
08100	C	*** CALCULATES CUSHION DIMENSIONS ***
08110	C	FOR COMPLETE ENCAPSULATION
08120	710	TOPL(I,JJ)=RLTH
08130		TOPW(I,JJ)=WIDE
08140		TOPT(I,JJ)=ITHK(I,JJ,1)
08150		SIDEL(I,JJ)=RLTH
08160		SIDEH(I,JJ)=HGT+2*ITHK(I,JJ,1)
08170		SIDET(I,JJ)=ITHK(I,JJ,2)
08180		ENDH(I,JJ)=HGT+2*ITHK(I,JJ,1)
08190		ENDT(I,JJ)=ITHK(I,JJ,3)
08200		ENDW(I,JJ)=WIDE+2*ITHK(I,JJ,2)
08210	C	*** CALCULATE SURFACE AREA OF CUSHIONING MATERIAL ***
08220		CUAREA(I,JJ)=2.0*(TOPL(I,JJ)*TOPW(I,JJ)+
08230	     1	SIDEL(I,JJ)*SIDEH(I,JJ)*ENDH(I,JJ)*ENDW(I,JJ))/144.0
08240	C	*** CALCULATES CUSHION VOLUMES ***
08250		VTF(I)=2*TOPL(I,JJ)*TOPW(I,JJ)*TOPT(I,JJ)
08260		VSF(I)=2*SIDEL(I,JJ)*SIDEH(I,JJ)*SIDET(I,JJ)
08270		VEF(I)=2*ENDH(I,JJ)*ENDW(I,JJ)*ENDT(I,JJ)
08280		VOL(I,JJ)=VTF(I)+VSF(I)+VEF(I)
08290	C	*** CUCST IS CUSHION COST ***
08300	750	CUCST(I,JJ)=VOL(I,JJ)*CCV(I)/144.0
08310	C
08320		IF(I.EQ.7.OR.I.EQ.8.OR.I.EQ.9.OR.I.EQ.14) GO TO 760
08330		GO TO 1690
08340	C	CALCULATIONS FOR MATERIALS HAVING DIFFERENT COSTS
08350	C	FOR DIFFERENT THICKNESSES
08360	760	IF(I.NE.14) GO TO 770
08370	C	SET POINTER TO COST
08380		NTHKT=40+ITHK(I,JJ,1)
08390		NTHKS=40+ITHK(I,JJ,2)
08400		NTHKE=40+ITHK(I,JJ,3)
08410		GO TO 780
08420	C	SET POINTER TO COST
08430	770	NTHKT=(I-7)*6+22+ITHK(I,JJ,1)
08440		NTHKS=(I-7)*6+22+ITHK(I,JJ,2)
08450		NTHKE=(I-7)*6+22+ITHK(I,JJ,3)
08460	780	IF(JJ.EQ.2) GO TO 1680
08470		CUCST(I,JJ)=(VTF(I)*CCV(NTHKT)*VSF(I)*
08480	     1	CCV(NTHKS)+VEF(I)*CCV(NTHKE))/144.0
08490		GO TO 1690
08500	1680	VT=CPAD(I,1)**2*ITHK(I,JJ,1)
08510		VS=(CPAD(I,2)+ITHK(I,JJ,1))*CPAD(I,1)*ITHK(I,JJ,2)
08520		VE=(CPAD(I,3)+ITHK(I,JJ,1))*(CPAD(I,1)+ITHK(I,JJ,2))
08530	     1	*ITHK(I,JJ,3)
08540		CUCST(I,JJ)=8.0*(VT*CCV(NTHKT)+VS*CCV(NTHKS)+VE*CCV(NTHKE))/144.0
08550	C	*** CALCULATE COST TO CUT CUSHIONING ***
08560	1690	CTCCU(I,JJ)=0.0747*0.2310*CUAREA(I,JJ)**0.4955
08570		IF(CUAREA(I,JJ).LT.1.0) CTCCU(I,JJ)=0.0
08580	C	***CUWT IS CUSHION WEIGHT ***
08590		CUWT(I,JJ)=VOL(I,JJ)*WTFAC(I)/1728.0
08600	C	*** CONTAINER DIMENSIONS ***
08610		CHGT(I,JJ)=HGT+2*ITHK(I,JJ,1)
08620		CLTH(I,JJ)=RLTH+2*ITHK(I,JJ,3)
08630		CWIDE(I,JJ)=WIDE+2*ITHK(I,JJ,2)
08640	C	*** CALCULATE SURFACE AREA OF CONTAINER ***
08650		COAREA(I,JJ)=2.0*(CLTH(I,JJ)*CWIDE(I,JJ)+(CLTH(I,JJ)+
08660	     1	CWIDE(I,JJ))*CHGT(I,JJ))
08670	C	*** CALCULATE LABOR COST TO CLOSE ***
08680		CTCLO(I,JJ)=0.0747*(1.4334+0.0026*COAREA(I,JJ))
08690		IF(COAREA(I,JJ).LT.150.0) CTCLO(I,JJ)=0.0
08700	C	*** COST IS CONTAINER COST ***
08710	C	*** COST FOR RSC CONTAINER ***
08720		IF(CTYPE.NE.RSC) GO TO 1700
08730		CCST(I,JJ)=2.0*(CWIDE(I,JJ)+CHGT(I,JJ))*(CLTH(I,JJ)+CWIDE(I,JJ)
08740	     1	+1.0)*CCSQF/144.0+(2.0*CLTH(I,JJ)+5.0*CWIDE(I,JJ)+
08750	     1	CHGT(I,JJ)+4.0)*0.00124+(CLTH(I,JJ)+CWIDE(I,JJ)+
08760	     1	CHGT(I,JJ))*0.00248+(CHGT(I,JJ)-1.0)*0.0011+2.0*
08770	     1	(CWIDE(I,JJ)-2.0)*0.0011
08780	C	***MATERIAL COST OF TAPE ***
08790		COT(I,JJ)=((CLTH(I,JJ)+6.0)+2.0*(CWIDE(I,JJ)+6.0))*0.039/36.0
08800		GO TO 1710
08810	C	*** COST FOR FTC CONTAINER ***
08820	1700	CCST(I,JJ)=2.0*(CLTH(I,JJ)+2.0*CHGT(I,JJ))*(CWIDE(I,JJ)+
08830	     1	2.0*CHGT(I,JJ))*CCSQF/144.0+(CWIDE(I,JJ)+CLTH(I,JJ)+
08840	     1	6.0*CHGT(I,JJ))*0.00248+(CLTH(I,JJ)+CWIDE(I,JJ))*
08850	     1	.00248+0.045
08860	C	*** MATERIAL COST OF TAPE ***
08870		COT(I,JJ)=2.0*(CLTH(I,JJ)+CWIDE(I,JJ)+2.0)*0.039/36.0
08880	1710	CONTINUE
08890	C	*** CALCULATE CONTAINER WEIGHT ***
08900		COWT(I,JJ)=CWSQF*2.0*(CLTH(I,JJ)*CWIDE(I,JJ)+CLTH(I,JJ)*
08910	     1	CHGT(I,JJ)+CWIDE(I,JJ)*CHGT(I,JJ))/144.0
08920		TWT(I,JJ)=WGT+CUWT(I,JJ)+COWT(I,JJ)
08930	C	*** SHIPPING COST ***
08940		GO TO (1711,1712,1714,1716,1717),ITTYPE
08950	1711	SHCST(I,JJ)=RPPMF(ITDIST)*TWT(I,JJ)+RPPAF(ITDIST)
08960		GO TO 1719
08970	1712	IF(ITDIST.LT.2000) GO TO 1713
08980		SHCST(I,JJ)=ITDIST*0.0118+6.40
08990		GO TO 1719
09000	1713	ITDCD=ITDIST/500+1
09010		GO TO 1719
09020	1714	IF(ITDIST.GT.1000) GO TO 1715
09030		SHCST(I,JJ)=10.50
09040		GO TO 1719
09050	1715	TRMF= .0062
09060		IF(ITDIST.LT.2300) TRMF=0.007
09070		IF(ITDIST.LT.1500) TRMF=0.0105
09080		SHCST(I,JJ)=ITDIST*TRMF
09090		GO TO 1719
09100	1716	CSTLGA=FLOAT(ITLIST)/10000.0*TWT(I,JJ)
09110		IF(CSTLGA.LT.1.5) CSTLGA=1.50
09120		SHCST(I,JJ)=CSTLGA
09130		GO TO 1719
09140	1717	SHCST(I,JJ)=0.0
09150	C	*** TOTAL COST ***
09160	1719	TOLCST(I,JJ)=SHCST(I,JJ)+CUCST(I,JJ)+CCST(I,JJ)+
09170	     1	CTCLO(I,JJ)+COT(I,JJ)+CTCCU(I,JJ)
09180	799	CONTINUE
09190	C
09200	C
09210	C	THIS SECTION SORTS TOTAL COST FIGURES FOR OUTPUT
09220	C
09230	C
09240	C	INITIALIZE POINTERS TO COSTS
09250		DO 293 I293=1,NMAT
09260		ICPTRS(I293)=I293
09270	293	CONTINUE
09280		NCSTS=NMAT
09290	294	NCSTS=NCSTS-1
09300		NCHG=0
09310	C	LOOP TO DO 'BUBBLE' SORT
09320		DO 295 I295=1,NCSTS
09330		IS1=ICPTRS(I295)
09340		IS2=ICPTRS(I295+1)
09350		IF(TOLCST(IS1,JJ).LE.TOLCST(IS2,JJ)) GO TO 295
09360		NCHG=NCHG+1
09370		ICPTRS(I295)=IS2
09380		ICPTRS(I295+1)=IS1
09390	295	CONTINUE
09400	C	CHECK FOR 'NO SWAP' CONDITION
09410		IF(NCHG.NE.0) GO TO 294
09420		IS1=ICPTRS(NMAT)
09430	C	TRANSFER IF ANY MATERIAL CAN PROVIDE ADEQUATE PROTECTION
09440		GO TO 291
09450		CALL P('ALL COSTS 0.0--  NO MATERIAL PROTECTS')
09460		GO TO 999
09470	291	TYPE 5
09480	C
09490		CALL P('THE FOLLOWING TABLE LISTS THE MATERIAL NUMBERS')
09500		CALL P('AND THEIR RESPECTIVE TOTAL COST FIGURES.')
09510		TYPE 5
09520		TYPE 296
09530	296	FORMAT('0 ',5('MAT    TOTAL    '))
09540		TYPE 297
09550	297	FORMAT('  ',5('NUM     COST    '))
09560		TYPE 298
09570	298	FORMAT('+ ',5('-----------     '))
09580	C	LOOP TO TYPE SORTED COST FIGURES
09590		DO 290 I290=1,NMAT,5
09600		IS1=ICPTRS(I290)
09610		IS2=ICPTRS(I290+1)
09620		IF(I290.EQ.21) GO TO 292
09630		IS3=ICPTRS(I290+2)
09640		IS4=ICPTRS(I290+3)
09650		IS5=ICPTRS(I290+4)
09660		IS5X=IS5
09670		TYPE 1290,IS1,TOLCST(IS1,JJ),IS2,TOLCST(IS2,JJ),IS3,
09680	     1	TOLCST(IS3,JJ),IS4,TOLCST(IS4,JJ),IS5X,TOLCST(IS5,JJ)
09690	1290	FORMAT(' ',1X,5(I2,1X,F8.2,3X))
09700	290	CONTINUE
09710	C	SPECIAL TYPE FOR LAST 2 MATERIALS
09720	292	TYPE 1290,IS1,TOLCST(IS1,JJ),IS2,TOLCST(IS2,JJ)
09730		TYPE 5
09740		IF(IANS.EQ.0) GO TO 1720
09750		IANS=0
09760		CALL P('YOU MAY NOW LIST COMPLETE DATA FOR ANY MATERIAL,')
09770		CALL P('RESPOND TO THE QUESTION "MAT #?" WITH THE NUMBER OF')
09780		CALL P('THE MATERIAL FOR WHICH DATA IS REQUIRED.  THE ')
09790		CALL P('QUESTION WILL BE ASKED REPEATEDLY UNTIL A')
09800		CALL P('"0" RESPONSE IS GIVEN,')
09810	C
09820	C
09830	C	INTERACT WITH USER TO TYPE COMPLETE CALCULATIONS
09840	C
09850	C
09860	1720	CALL P('MAT.#?')
09870		ACCEPT 29998,I
09880		IF(I.EQ.0) GO TO 999
09890		IF(I.LE.NMAT) GO TO (701,702,703),JJ
09900		TYPE 39999,I
09910	39999	FORMAT('MAT. # ',I,' NOT AVAILABLE- RE-INPUT')
09920		GO TO 1720
09930	701	TYPE 70199,I
09940	70199	FORMAT('CUSHION DIMENSIONS (COMPLETE ENCAPSULATON) FOR MAT. #',
09950	     1	I5)
09960		GO TO 287
09970	702	TYPE 70299,I
09980	70299	FORMAT(' CORNER PAD DIMENSIONS FOR MAT. #',I5)
09990		GO TO 288
10000	703	TYPE 70399,I
10010	70399	FORMAT(' WRAPPING MATERIAL DIMENSIONS FOR MAT. #',I5)
10020		GO TO 289
10030	287	TYPE 630
10040		TYPE 631,TOPL(I,JJ),TOPW(I,JJ),TOPT(I,JJ)
10050	631	FORMAT(' TOP FACE  ',3(F8.2,'IN.'))
10060		TYPE 632,SIDEL(I,JJ),SIDEH(I,JJ),SIDET(I,JJ)
10070	632	FORMAT(' SIDE FACE ',3(F8.2,' IN.'))
10080		TYPE 633,ENDH(I,JJ),ENDW(I,JJ),ENDT(I,JJ)
10090	633	FORMAT(' END FACE  ',3(F8.2,' IN,'))
10100		GO TO 704
10110	288	TYPE 660
10120	660	FORMAT(12X,' INSIDE DIMENSIONS',6X,'THICKNESS')
10130		TYPE 661,CPAD(I,1),CPAD(I,1),ITHK(I,JJ,1)
10140	661	FORMAT(' BOTTOM  ',F8.2,' BY',2(F8.2,' IN.'))
10150		TYPE 662,CPAD(I,1),CPAD(I,2),ITHK(I,JJ,2)
10160	662	FORMAT(' SIDE    ',F8.2,' BY',2(F8.2,' IN.'))
10170		TYPE 663,CPAD(I,1),CPAD(I,3),ITHK(I,JJ,3)
10180	663	FORMAT(' END     ',F8.2,' BY',2(F8.2,' IN.'))
10190		GO TO 704
10200	289	TYPE 630
10210	630	FORMAT(15X,'LENGTH',6X,'WIDTH',5X,'THICKNESS')
10220		TYPE 664,TOPL(I,JJ),TOPW(I,JJ),ITHK(I,JJ,1)
10230	664	FORMAT(13X,F8.2,' BY',F8.2,6X,F4.1,'IN.')
10240	704	TYPE 5
10250		CALL P(' CONTAINER DIMENSIONS ARE AS FOLLOWS')
10260		TYPE 640
10270	640	FORMAT(14X,'LENGTH',6X,'WIDTH',7X,'HEIGHT')
10280		TYPE 641,CLTH(I,JJ),CWIDE(I,JJ),CHGT(I,JJ)
10290	641	FORMAT(11X,3(F8.2,' IN.'))
10300		TYPE 5
10310		TYPE 645,TWT(I,JJ)
10320	645	FORMAT(' TOTAL WEIGHT     ',F8.2,' LBS.')
10330		TYPE 5
10340		TYPE 650
10350	650	FORMAT('   CUSHION    CONTAINER     SHIPPING     OTHER',
10360	     1	'     TOTAL')
10370		TYPE 651
10380	651	FORMAT('    COST         COST         COST       COSTS',
10390	     1	'     COST')
10400		OCOSTS=CTCLO(I,JJ)+COT(I,JJ)+CTCCU(I,JJ)
10410		TYPE 652,CUCST(I,JJ),CCST(I,JJ),SHCST(I,JJ),OCOSTS,TOLCST(I,JJ)
10420	652	FORMAT(2X,5('$',F8.2,4X))
10430		TYPE 5
10440	C	*** END OF TYPEING RESULTS ***
10450		GO TO 1720
10460	999	CONTINUE
10470		IF(JJ.NE.1) GO TO 600
10480		CALL P('OUTPUT COMPLETE FOR ENCAPSULATION. DO YOU WANT')
10490		CALL P('RESULTS FOR OPTIONS 3 OR 4? ( YES OR NO )')
10500		GO TO 620
10510	600	IF(JJ.NE.2) GO TO 610
10520		CALL P('OUTPUT COMPLETE FOR CORNER PADS. DO YOU WANT')
10530		CALL P('RESULTS FOR OPTIONS 2 OR 4? ( YES OR NO )')
10540		GO TO 620
10550	610	CALL P('OUTPUT COMPLETE FOR WRAPPING. DO YOU WANT')
10560		CALL P('RESULTS FOR OPTIONS 2 OR 3? ( YES OR NO )')
10570	620	ACCEPT 29999,ANS
10580	29999	FORMAT (A5)
10590		IF(ANS.NE.YES) GO TO 19
10600		GO TO 11
10610	19	CALL P(' IS A NEW RUN,USING NEW DATA, DESIRED?')
10620		ACCEPT 29999,ANS
10630		IF(ANS.EQ.YES) GO TO 10
10640		STOP
10650	C
10660	C
10670	C
10680	C	COMPUTE LEVEL OF PROTECTION USING SPECIFIED PARAMETERS
10690	C
10700	C
10710	C	CHECK TO SEE IF WAO IS BETWEEN THE BOUNDARY VALUES FOR THE EQ.
10720	4000	IF(ARG1.GT.A(ARG4+5,ARG3,ARG2)) GO TO 4010
10730		IF(ARG1.LT.A(ARG4+4,ARG3,ARG2)) GO TO 4010
10740	C	CALCUALTE THE PEAK ACCELERATION
10750		Y=A(ARG4,ARG3,ARG2)+A(ARG4+1,ARG3,ARG2)*ARG1+A(ARG4+2,ARG3,ARG2)*
10760	     1	ARG1**2+A(ARG4+3,ARG3,ARG2)*ARG1**3
10770	C	WRITE ERROR MESSAGE IF ACCELERATION NOT POSITIVE
10780		IF(Y.GT.0) GO TO 4020
10790		CALL P('***********************************************')
10800		TYPE 3000
10810	3000	FORMAT('OPERM. FILE ERROR- PEAK ACCELERATION < 0.0 FOR:')
10820		TYPE 3010,NFILE,ARG2,ARG3,ARG1
10830	3010	FORMAT(' FILE #',I3,' MAT. #',I3,' EQN. #',I3,' SS=',F8.3)
10840		TYPE 3020
10850	3020	FORMAT(' PLEASE NOTIFY THE PERSON OR OFFICE RESPONSIBLE',
10860	     1	' FOR THE OPERATION OF THIS'/' PROGRAM AND SUPPLY ',
10870	     1	'THEM WITH YOUR INPUT DATA AND THE DATA JUST TYPEED.',/
10880	     1	' A COPY OF THIS TYPE.OUT MAY BE NECESSARY TO COMPLETELY RESO'
10890	     1	'LVE',/' THE PROBLEM, THEREFORE, PLEASE SAVE IT TEMPORARILY'///)
10900		CALL P('***********************************************')
10910		IFLAG=3
10920		GO TO 4030
10930	4010	IFLAG=1
10940		GO TO 4030
10950	4020	IFLAG=2
10960	4030	GO TO (152,162,242,432),IRETRN
10970	5000	CONTINUE
10980		END