Trailing-Edge
-
PDP-10 Archives
-
decuslib20-04
-
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