Liren Large Software Subsidy 9

home *** CD-ROM | disk | FTP | other *** search

/ Liren Large Software Subsidy 9 / 09.iso / e / e003 / 8.ddi / STIDYN5.FOR < prev

Wrap

Text File | 1980-01-03 | 81.9 KB | 1,024 lines

SUBROUTINE STHRED 00269240 IMPLICIT REAL*8(A-H,O-Z) 00269250 REAL*8NS 00269260 REAL*8 IS1,IS2,IS3,IS4 00269270 DIMENSION SPR(6) 00269280 DIMENSION EFS(2) 00269290 COMMON / JUNK / SIG(15), EXRA(185),MM,L,K,NTAG,NDYN,NRJUNK(49) R0269300 COMMON /OUT/NRES,NSTR,NDIS,NROUT(7) R0269310 EQUIVALENCE (IS3,SIG(13)),(IS4,SIG(14)),(NS,SIG(15)) 00269320 100 CONTINUE 00269330 IF(NTAG.EQ.0) WRITE (6,140) 00269340 NG=NS 00269350 IS1=IS3 00269360 IS2=IS4 00269370 IF(IS1.LT.1) IS1=IS1*100.+0.001 00269380 IF(IS2.LT.1) IS2=IS2*100.+0.001 00269390 NF1=IS1 00269400 NF2=IS2 00269410 IS1=NF1 00269420 IS2=NF2 00269430 IF(NF1.EQ.0) NF1=7 00269440 IF(NF2.EQ.0) NF2=7 00269450 NF=10*NF1+NF2 00269460 IF(NF.EQ.77) NF=71 00269470 EFS(2)=0.0 00269480 SPR(4)=0.0 00269490 SPR(5)=0.0 00269500 CALL SPRIST(IS1,IS2,SIG,SPR,NS) 00269510 II=NG/6 00269520 DO 120 J=1,II 00269530 M=6*J-6 00269540 EFS(J)=(SIG(M+1)-SIG(M+2))**2+(SIG(M+2)-SIG(M+3))**2+(SIG(M+3)- 00269550 $SIG(M+1))**2 00269560 DO 110 I=4,6 00269570 MI=M+I 00269580 110 EFS(J)=EFS(J)+6.*SIG(MI)**2 00269590 120 EFS(J)= DSQRT(EFS(J)/2.) 00269600 WRITE (6,150) MM,L,IS1,(SIG(I),I=1,6),(SPR(I),I=1,3) ,EFS(1) 00269610 LTYP=5 00269620 WRITE(35,170)MM,LTYP,L,(SIG(I),I=1,6),(SPR(I),I=1,3),EFS(1) 00269630 170 FORMAT(3I5,10E10.3) 00269640 IF(NG.EQ.12) WRITE (6,160) IS2,(SIG(I),I=7,12),(SPR(I),I=4,6) ,00269650 $EFS(2) 00269660 II=6+NG 00269670 IF(NSTR.GT.0) WRITE(NSTR,1234) II,L,NF,SPR(1),SPR(2),EFS(1),SPR(4)00269680 $,SPR(5),EFS(2),(SIG(I),I=1,NG) 00269690 1234 FORMAT(I4,I2,I2,2H 5,7G10.4/(8G10.4)) 00269700 130 FORMAT (I4,2I2,6F9.0) 00269710 RETURN 00269720 140 FORMAT(36H1.....8-NODE SOLID ELEMENT STRESSES // 00269730 $118H ELEM. LOAD FACE SIG-XX SIG-YY SIG-ZZ SIG-XY SI00269740 $G-YZ SIG-ZX SIG-MAX SIG-MIN S2 OR SIG-EF / 16H NO00269750 $. NO. NO.,84X,5HANGLE/) 00269760 150 FORMAT(I5,I4,F5.0,1X,10E10.3) 00269770 160 FORMAT(9X ,F5.0,1X,10E10.3) 00269780 END 00269790 SUBROUTINE SBOUND(NORD,NADD) 00222790 IMPLICIT REAL*8(A-H,O-Z) 00222800 COMMON / JUNK / SIG(12), EXRA(188),MM,L,K,NTAG,NDYN,NRJUNK(49) R0222810 DIMENSION NORD(NADD) 00222820 100 IF(NTAG.EQ.0) WRITE(6,110) 00222830 IF(EXRA(138).LE.1.0) NN=EXRA(138)*10000.+.001 00222840 IF(EXRA(138).GT.1.0) NN=EXRA(139)*10000.D0+.001D0 00222850 IF(NADD.GT.1.AND.NN.LE.NADD.AND.NN.GT.0) NN=NORD(NN) 00222860 IF(NN.LE.0) NN=0 00222870 WRITE(6,120) MM,NN,L,SIG(1),SIG(2) 00222880 RETURN 00222890 110 FORMAT(1H1,39H CONSTRAINT FORCE - BOUNDARY ELEMENTS // 00222900 $77H EL. NUMBER NODE N LOAD CASE FORCE( ) M00222910 $OMENT( ) /) 00222920 120 FORMAT(1X,I10,I12,I11,4X,2F20.5) 00222930 END 00222940 SUBROUTINE SBEAM 00221500 IMPLICIT REAL*8(A-H,O-Z) 00221510 COMMON /JUNK/SIG(26),EXTRA(174),MM,L,K,NTAG,NDYN,NRJUNK(49) R0221520 COMMON /OUT/NRES,NSTR,NDIS,NBMSTR,NROUT(6) R0221530 100 IF(NTAG.EQ.0) WRITE (6,120) 00221540 IF(NTAG.EQ.0 .AND. NBMSTR.EQ.1)WRITE(6,125) 00221550 IF(NTAG.EQ.0)WRITE(6,126) 00221560 NS=EXTRA(174) 00221570 IF(NS.GT.12) 00221580 XWRITE(6,130)MM,L,(SIG(I1),I1=1,6), 00221590 X (SIG(I2),I2=13,19), 00221600 X (SIG(I3),I3=7,12), 00221610 X (SIG(I4),I4=20,26) 00221620 IF(NS.LE.12) 00221630 XWRITE(6,140)MM,L,(SIG(I1),I1= 1,12) 00221640 NTAG=1 00221650 IF(NSTR.GT.0) WRITE(NSTR,1234) NS,L,(SIG(I),I=1,NS) 00221660 1234 FORMAT(I4,I2,2X,2H 2,7G10.4/(8G10.4)) 00221670 RETURN 00221680 120 FORMAT(/59H1....BEAM FORCES, MOMENTS, AND STRESSES 00221690 X // 00221700 X1X,7HELEMENT,2X,4HLOAD,2X,7HSTATION,15X,5HAXIAL,2(6X,5HSHEAR), 00221710 X4X,9HTORSION ,3X,2(5X,13HB E N D I N G ,6X)/ 00221720 X2X,6HNUMBER,2X,4HCASE,11X,5HFORCE, 00221730 X 11X,2HR1,9X,2HR2,9X,2HR3,9X,2HM1,23X,2HM2,24X,2HM3) 00221740 125 FORMAT( 00221750 X25X,6HSTRESS,7X,5HR1/A1,3X,8HAT Q3/B3,4X,8HAT Q2/B2,5X,4H- - ,1X, 00221760 X4X,9H AT +C3,3X,9H AT -C3, 00221770 X3X,9H AT +C2,3X,9H AT -C2 ) 00221780 126 FORMAT(1X) 00221790 130 FORMAT(4X,I4,2X,I4,4X, 00221800 X 5HEND-I, 2X,6HFORCE ,2X,1P4E12.4,12X,1PE12.4,12X,1PE12.4/ 00221810 X23X,2X,6HSTRESS,2X,1P3E12.4,12X,1P4E12.4/ 00221820 X18X,5HEND-J, 2X,6HFORCE ,2X,1P4E12.4,12X,1PE12.4,12X,1PE12.4/ 00221830 X23X,2X,6HSTRESS,2X,1P3E12.4,12X,1P4E12.4) 00221840 140 FORMAT(4X,I4,2X,I4,4X, 00221850 X 5HEND-I, 2X,6HFORCE ,2X,1P4E12.4,12X,1PE12.4,12X,1PE12.4/ 00221860 X18X,5HEND-J, 2X,6HFORCE ,2X,1P4E12.4,12X,1PE12.4,12X,1PE12.4) 00221870 END 00221880 SUBROUTINE SPLANE 00251070 IMPLICIT REAL*8(A-H,O-Z) 00251080 COMMON /OUT/NRES,NSTR,NDIS,NROUT(7) R0251090 COMMON /SIGO/MTYP 00251100 COMMON/JUNK/SIG(12),EXTRA(188),MM,L,K,NTAG,NDYN,NRJUNK(49) R0251110 100 IF(NTAG.EQ.0) WRITE (6,120) 00251120 CC=(SIG(1)+SIG(2))/2.0 00251130 BB=(SIG(1)-SIG(2))/2. 00251140 CR= DSQRT(BB**2+SIG(4)**2) 00251150 SIG(5)=CC+CR 00251160 SIG(6)=CC-CR 00251170 SIG(7)=0.0 00251180 EF=(SIG(3)-SIG(5))**2+(SIG(5)-SIG(6))**2+(SIG(6)-SIG(3))**2 00251190 EF= DSQRT(EF/2.) 00251200 IF ((BB.EQ.0.0).AND.(SIG(4).EQ.0.0)) GO TO 110 00251210 SIG(7)=28.648* DATAN2(SIG(4),BB) 00251220 110 WRITE(6,130)MM,L,(SIG (I),I=1,7),EF 00251230 WRITE(35,210)MM,MTYP,L,(SIG(I),I=1,7),EF,EF,EF 00251240 210 FORMAT(3I5,10E10.3) 00251250 NTAG=1 00251260 IF(NSTR.GT.0) WRITE(NSTR,1234) L,SIG(5),SIG(6),EF,(SIG(I),I=1,4) 00251270 1234 FORMAT(3X,1H7,I2,4H12 3 ,7G10.4) 00251280 RETURN 00251290 120 FORMAT(39H1 PLANE STRESS/STRAIN ELEMENT STRESSES // 00251300 $ 12H0EL.NO. LOAD,7X,8HR-STRESS,7X,8HZ-STRESS,7X, 00251310 $ 8HT-STRESS,6X,9HRZ-STRESS,5X,10HMAX-STRESS,5X,10HMIN-STRESS, 00251320 $3X,5HANGLE,5X,6HSIG-EF/) 00251330 130 FORMAT(2I6,6E15.5,F8.3,E12.5) 00251340 140 FORMAT (I4,I2,2H12,6F9.0) 00251350 END 00251360 SUBROUTINE STFGPK(ND1,NDMX,STIF,S,KOUNT) 00268270 IMPLICIT REAL*8(A-H,O-Z) 00268280 REAL*8 S(NDMX,NDMX),T 00268290 REAL*8 STIF 00268300 LOGICAL ELPRT,ELPCH,GENPRT,GENPCH 00268310 DIMENSION STIF(1) 00268320 COMMON/CTL/ELPRT,ELPCH,GENPRT,GENPCH 00268330 COMMON /FORCE/ NLC,NELD 00268340 COMMON/MASS/LMASS 00268350 IF(.NOT.ELPRT) GO TO 1100 00268360 WRITE(6,160)(STIF(I),I=1,ND1) 00268370 IF(ELPCH) WRITE(7,180)(STIF(I),I=1,ND1) 00268380 WRITE(6,170) 00268390 DO 1020 I=1,ND1 00268400 IF(ELPCH) WRITE(7,180)(S(I,J),J=1,ND1) 00268410 1020 WRITE(6,190)(S(I,J),J=1,ND1) 00268420 1100 CONTINUE 00268430 IF(ND1.EQ.1) GO TO 8 00268440 NDM=ND1-1 00268450 DO 7 J=1,NDM 00268460 IF(STIF(J).LE.0.) GO TO 7 00268470 JP1=J+1 00268480 DO 6 I=JP1,ND1 00268490 IF(STIF(J).NE.STIF(I)) GO TO 6 00268500 DO 1 K=1,J 00268510 1 S(J,K)=S(J,K)+S(I,K) 00268520 IM1=I-1 00268530 DO 2 K=J,IM1 00268540 2 S(K,J)=S(K,J)+S(I,K) 00268550 IP1=I+1 00268560 IF(IP1.GT.ND1) GO TO 4 00268570 DO 3 K=IP1,ND1 00268580 3 S(K,J)=S(K,J)+S(K,I) 00268590 4 STIF(I)=0.0 00268600 S(J,J)=S(J,J)+S(I,I) 00268610 6 CONTINUE 00268620 7 CONTINUE 00268630 8 CONTINUE 00268640 I=ND1 00268650 10 EMAX=STIF(1) 00268660 J=1 00268670 DO 40 K=1,I 00268680 IF(STIF(K).GT.0.0) GO TO 30 00268690 J=K 00268700 GO TO 50 00268710 30 IF(STIF(K).LT.EMAX) GO TO 40 00268720 EMAX=STIF(K) 00268730 J=K 00268740 40 CONTINUE 00268750 50 IF(I.EQ.J)GO TO 90 00268760 JM1=J-1 00268770 IF(JM1.LT.1) GO TO 60 00268780 DO 55 K=1,JM1 00268790 T=S(I,K) 00268800 S(I,K)=S(J,K) 00268810 55 S(J,K)=T 00268820 60 JP1=J+1 00268830 IM1=I-1 00268840 IF(JP1.GT.IM1) GO TO 70 00268850 DO 65 K=JP1,IM1 00268860 T=S(K,J) 00268870 S(K,J)=S(I,K) 00268880 65 S(I,K)=T 00268890 70 IP1=I+1 00268900 IF(IP1.GT.ND1) GO TO 78 00268910 DO 75 K=IP1,ND1 00268920 T=S(K,I) 00268930 S(K,I)=S(K,J) 00268940 75 S(K,J)=T 00268950 78 T=S(I,I) 00268960 S(I,I)=S(J,J) 00268970 S(J,J)=T 00268980 T=STIF(I) 00268990 STIF(I)=STIF(J) 00269000 STIF(J)=T 00269010 90 IF(STIF(I).EQ.0.0) ND1=ND1-1 00269020 I=I-1 00269030 IF(I.GT.0) GO TO 10 00269040 IF(ND1.LE.0) ND1=1 00269050 KOUNT=0 00269060 KST=0 00269070 DO 100 I=1,ND1 00269080 KST=KST+NDMX 00269090 KK=KST+I-1 00269100 DO 100 J=I,ND1 00269110 KK=KK+1 00269120 KOUNT=KOUNT+1 00269130 100 STIF(KOUNT)=STIF(KK) 00269140 KOUNT=KOUNT+1 00269150 STIF(KOUNT)=ND1 00269160 160 FORMAT(/1X,22HELEMENT LOCATION MATRX,/,(1H ,10F13.0)) 00269170 170 FORMAT(/1X,34HELEMENT GEOMETRIC STIFFNESS MATRIX) 00269180 180 FORMAT((1P8E10.3)) 00269190 190 FORMAT( (1H ,1P10E13.4)) 00269200 200 FORMAT( (1H ,1P8E13.4)) 00269210 RETURN 00269220 END 00269230 SUBROUTINE SSHELL 00255910 IMPLICIT REAL*8 (A-H,O-Z) 00255920 COMMON/JUNK/SIG(200),MM,L,K,NTAG,NDYN,NRJUNK(49) R0255930 COMMON /OUT/NRES,NSTR,NDIS,NROUT(7) R0255940 COMMON/RLSE/KRLX 00255950 COMMON /RIGID/IIA(20),NREX 00255960 DIMENSION EFS(2) 00255970 IF(KRLX.GT.0)GO TO 200 00255980 100 IF(NTAG.EQ.0) WRITE(6,120) 00255990 SIG( 7)=SIG(1)+SIG(4) 00256000 SIG( 8)=SIG(2)+SIG(5) 00256010 SIG( 9)=SIG(3)+SIG(6) 00256020 CC=(SIG( 7)+SIG( 8))/2. 00256030 BB=(SIG( 7)-SIG( 8))/2. 00256040 CR= DSQRT(BB**2+SIG( 9)**2) 00256050 SIG(10)=CC+CR 00256060 SIG(11)=CC-CR 00256070 SIG(12)=0.0 00256080 IF(BB.NE.0) SIG(12)=28.648* DATAN2(SIG( 9),BB) 00256090 SIG(13)=SIG(1)-SIG(4) 00256100 SIG(14)=SIG(2)-SIG(5) 00256110 SIG(15)=SIG(3)-SIG(6) 00256120 CC=(SIG(13)+SIG(14))/2. 00256130 BB=(SIG(13)-SIG(14))/2. 00256140 CR= DSQRT(BB**2+SIG(15)**2) 00256150 SIG(16)=CC+CR 00256160 SIG(17)=CC-CR 00256170 SIG(18)=0.0 00256180 IF(BB.NE.0) SIG(18)=28.648* DATAN2(SIG(15),BB) 00256190 EFS(1)=SIG(10)**2+SIG(11)**2-SIG(10)*SIG(11) 00256200 EFS(1)= DSQRT(EFS(1)) 00256210 EFS(2)=SIG(16)**2+SIG(17)**2-SIG(16)*SIG(17) 00256220 EFS(2)= DSQRT(EFS(2)) 00256230 110 WRITE(6,130)MM,L,(SIG(I),I=1,12),EFS(1),(SIG(I),I=13,18),EFS(2) 00256240 IF(NSTR.GT.0) WRITE(NSTR,1234) L,SIG(10),SIG(11),EFS(1),SIG(16), 00256250 $SIG(17),EFS(2),(SIG(I),I=7,9),SIG(12),(SIG(I),I=13,15),SIG(18) 00256260 1234 FORMAT(4H 14,I2,4H12 6, 7G10.4/(8G10.4)) 00256270 RETURN 00256280 120 FORMAT(24H1 SHELL ELEMENT STRESSES //10X, 00256290 $10H ELEMENT,6X,4HLOAD,10H SIG-X,9X,5HSIG-Y,9X,6HSIG-XY,7X, 00256300 $7HSIG-MAX,7X,7HSIG-MIN,8X,5HANGLE,9X,6HSIG-EF) 00256310 130 FORMAT(//9H MEMBRANE,1X,2I10,1X,1PE12.5,2X,1PE12.5,2X,1PE12.5/ 00256320 $9H BENDING,21X,1X,1PE12.5,2X,1PE12.5,2X,1PE12.5/ 00256330 $10H +T/2 SIDE,20X,1X,1PE12.5,2X,1PE12.5,2X,1PE12.5,2X,1PE12.5,2X, 00256340 $1PE12.5,2X,1PE12.5,2X,1PE12.5/ 00256350 $10H -T/2 SIDE,20X,1X,1PE12.5,2X,1PE12.5,2X,1PE12.5,2X,1PE12.5,2X, 00256360 $1PE12.5,2X,1PE12.5,2X,1PE12.5) 00256370 140 FORMAT (I4,I2,2H12,6F9.0) 00256380 200 IF(NTAG.EQ.0) WRITE(6,1000) 00256390 1000 FORMAT(38H1.....SHELL ELEMENT FORCES AND MOMENTS// 00256400 & 9H ELEMENT,3X,4HLOAD,3X,4HNODE,3X,2HFX,13X,2HFY,13X,2HFZ 00256410 & ,13X,2HMX,13X,2HMY,13X,2HMZ) 00256420 WRITE(6,1010)MM,L,IIA(1),(SIG(I),I=1,6),IIA(2) 00256430 & ,(SIG(I),I=7,12),IIA(3),(SIG(I),I=13,18),IIA(4) 00256440 & ,(SIG(I),I=19,24) 00256450 1010 FORMAT(/I5,5X,I3,I7,2X,1P6E15.5/13X,I7,2X,6E15.5/ 00256460 & 13X,I7,2X,6E15.5/13X,I7,2X,6E15.5) 00256470 RETURN 00256480 END 00256490 SUBROUTINE WIDEF 00322320 DOUBLE PRECISION A,SM2,SM3,VQIB2,VQIB3,DP,BF,TF,TW,DIAM,WALL,R2, 00322330 1 R3,EBM,RED,FY,XK,YK,DL,FATEN,FASHR,FACOM,FB2,FB3,PSI,SHR,COMB,00322340 2 AXR,BEND2,BEND3,P,S2I,S3I,S2J,S3J,XM2I,XM3I,XM2J,XM3J,TYPE, 00322350 3 PI,XLR2,XLR3,XLR,CC,RTL,FE2,FE3,XINER,AWC,DT257,FY6,AF,C,S76, 00322360 4 FB4,AFC,SQFY,S20,BT,T1,BT65,C102,DT,AW,BT95,C510,FB5,B,TI,XX, 00322370 5 DT1,ROD,CID,DT2,RID,DTA,AOD,AID,COD,ST,BTT,SS,DTT,BT190,BTS, 00322380 6 BT238,DTS,FS,T2,CM3T3,XFB2I,COMB2J,XFB3JB,T3,SH2I,XFB3I,TJ, 00322390 7 XFAFA,CM2,SH2J,XFB2J,COMB1I,XFB2IB,CM3,SH3I,XFB3J,COMB2I, 00322400 8 XFB3IB,CM2T2,SH3J,XFA,COMB1J,XFB2JB,TEMP,FLG,XINC, 00322410 9 XINER2,XINER3 00322420 COMMON/STEEL/A,SM2,SM3,VQIB2,VQIB3,DP,BF,TF,TW,DIAM,WALL,R2,R3, 00322430 1 EBM,RED,FY,XK,YK,DL,FATEN,FASHR,FACOM,FB2,FB3,PSI,SHR,COMB, 00322440 2 AXR,BEND2,BEND3,P,S2I,S3I,S2J,S3J,XM2I,XM3I,XM2J,XM3J, 00322450 3 TYPE,PI,XLR2,XLR3,XLR,CC,RTL,FE2,FE3,XINER,AWC,DT257,FY6,AF, 00322460 4 C,S76,FB4,AFC,SQFY,S20,BT,T1,BT65,C102,DT,AW,BT95,C510,FB5, 00322470 5 B,TI,XX,DT1,ROD,CID,DT2,RID,DTA,AOD,AID,COD,ST,BTT,SS,DTT, 00322480 6 BT190,BTS,BT238,DTS,FS,T2,CM3T3,XFB2I,COMB2J,XFB3JB,T3,SH2I, 00322490 7 XFB3I,TJ,XFAFA,CM2,SH2J,XFB2J,COMB1I,XFB2IB,CM3,SH3I,XFB3J, 00322500 8 COMB2I,XFB3IB,CM2T2,SH3J,XFA,COMB1J,XFB2JB,TEMP,FLG,XINC, 00322510 9 XINER2,XINER3,ICT,KATX,KATY 00322520 RED=1.0D0 00322530 XINER=SM3*DP/2.0D0 00322540 R3=DSQRT(XINER/A) 00322550 AF=BF*TF 00322560 AFC=(DP/2.0D0)-(TF/2.0D0) 00322570 T1=(DP/2.0D0)-TF 00322580 AW=T1*TW 00322590 AWC=T1/2.0D0 00322600 C=((AF*AFC)+(AW*AWC))/(AF+AW) 00322610 VQIB2=(A*C)/(2.0D0*XINER*TW) 00322620 T1=(DP-TF-TF)/3.0D0 00322630 AW=T1*TW 00322640 RTL=DSQRT(((TF*BF**3)+(T1*TW**3))/(12.0D0*(AF+AW))) 00322650 XINER=SM2*BF/2.0D0 00322660 R2=DSQRT(XINER/A) 00322670 T1=(BF-TW)/2.0D0 00322680 AFC=(T1+TW)/2.0D0 00322690 VQIB3=T1*AFC/XINER 00322700 BT65=65.0D0/SQFY 00322710 BT95=95.0D0/SQFY 00322720 S76=76.0D0*BF/SQFY 00322730 S20=20000.0D0/((DP/(BF*TF))*FY) 00322740 IF(S20.GT.S76)S20=S76 00322750 C102=DSQRT(102000.0D0/FY) 00322760 C510=DSQRT(510000.0D0/FY) 00322770 BT=BF/(2.0D0*TF) 00322780 DT=DP/TW 00322790 RTL=FLG/RTL 00322800 FB2=1.0D0 00322810 IF(BT.LE.BT65)FB2=.75D0*FY 00322820 IF(BT.GT.BT65.AND.BT.LE.BT95)FB2=(1.075D0-.005D0*BT*SQFY)*FY 00322830 RETURN 00322840 END 00322850 SUBROUTINE WRDIS1(NORD,A,B,NUMNP,LL,NDPBLK,NDIS,NBLK 00322880 & ,AD,XXK,ARE,NREL,ISL,NSLDM) 00322890 IMPLICIT REAL*8(A-H,O-Z) 00322900 DIMENSION NORD(NUMNP),A(6,LL),B(NDPBLK,6,LL) 00322910 & ,AD(NUMNP,3),XXK(NREL,6,LL),ARE(51,NREL),DX(3),ISL(NSLDM,4) 00322920 COMMON /BAND/ KOPT,NRBAND(7) R0322930 COMMON/SLVE/NSLAVE 00322940 COMMON /RIGID/ IIA(20),NREX 00322950 COMMON /OUT/ KDUMMY(9),KROT 00322960 COMMON /DYN4/ KDYN,NRDYN4(4) R0322970 COMMON/COMBLD/PCT(15,7),SINC(15),NCOMB,NB(15),LD(15,7) 00322980 NT1=17 00322990 NT2=18 00323000 IF(NSLAVE.NE.0) REWIND 30 00323010 IF(NSLAVE.NE.0) READ(30)((ISL(I,J),J=1,4),I=1,NSLAVE) 00323020 IF(NCOMB.GT.0) NT2=1 00323030 NT40=40 00323040 REWIND 8 00323050 READ(8)AD 00323060 IF(KOPT.GT.0) READ (NT1) NORD 00323070 IF(NREX.LE.0)GO TO 10 00323080 REWIND NT40 00323090 READ(NT40)ARE 00323100 REWIND NT2 00323110 DO 8 K=1,NUMNP 00323120 KK=K 00323130 IF(KOPT.GT.0)KK=NORD(K) 00323140 DO 7 J=1,NREX 00323150 NN=ARE(2,J) 00323160 IF(KK.NE.NN)GO TO 7 00323170 READ(NT2)A 00323180 DO 5 M=1,6 00323190 DO 5 L=1,LL 00323200 5 XXK(J,M,L)=A(M,L) 00323210 GO TO 8 00323220 7 CONTINUE 00323230 READ(NT2) 00323240 8 CONTINUE 00323250 10 CONTINUE 00323260 KSHF2=0 00323270 KSHF=1-NDPBLK 00323280 KNT=0 00323290 DO 140 I=1,NBLK 00323300 REWIND NT2 00323310 KOUNT=0 00323320 KK=NUMNP+1 00323330 KSHF=KSHF+NDPBLK 00323340 KSHF2=KSHF2+NDPBLK 00323350 DO 110 KK=1,NUMNP 00323360 READ (NT2) A 00323370 KCH= KK 00323380 IF(KOPT.GT.0) KCH=NORD(KK) 00323390 IF(KCH.LT.KSHF.OR.KCH.GT.KSHF2) GO TO 110 00323400 KNT=KNT+1 00323410 KOUNT=KOUNT+1 00323420 NSHFT=KCH-KSHF+1 00323430 DO 100 K=1,6 00323440 DO 100 M=1,LL 00323450 100 B(NSHFT,K,M)=A(K,M) 00323460 IF(NREX.LE.0)GO TO 109 00323470 DO 108 J=1,NREX 00323480 NN=ARE(1,J)+1 00323490 NK=ARE(2,J) 00323500 DO 107 K=3,NN 00323510 N=ARE(K,J) 00323520 IF(N.NE.NSHFT)GO TO 107 00323530 DO 101 M=4,6 00323540 DO 101 L=1,LL 00323550 101 B(NSHFT,M,L)=XXK(J,M,L) 00323560 NQA=NSHFT 00323570 NQB=NK 00323580 IF(KOPT.LE.0)GO TO 1015 00323590 DO 1010 L=1,NUMNP 00323600 IF(NORD(L).NE.NSHFT)GO TO 1009 00323610 NQA=L 00323620 1009 IF(NORD(L).NE.NK)GO TO 1010 00323630 NQB=L 00323640 1010 CONTINUE 00323650 1015 CONTINUE 00323660 DO 102 M=1,3 00323670 CALL UNPKID(AD,NUMNP,X,XJ,1,NQA,M) 00323680 CALL UNPKID(AD,NUMNP,X,XK,1,NQB,M) 00323690 102 DX(M)=XK-XJ 00323700 DO 104 L=1,LL 00323710 B(NSHFT,1,L)=XXK(J,1,L)-XXK(J,5,L)*DX(3)+XXK(J,6,L)*DX(2) 00323720 B(NSHFT,2,L)=XXK(J,2,L)+XXK(J,4,L)*DX(3)-XXK(J,6,L)*DX(1) 00323730 B(NSHFT,3,L)=XXK(J,3,L)-XXK(J,4,L)*DX(2)+XXK(J,5,L)*DX(1) 00323740 104 CONTINUE 00323750 GO TO 109 00323760 107 CONTINUE 00323770 108 CONTINUE 00323780 109 CONTINUE 00323790 IF(NSLAVE.EQ.0) GO TO 1200 00323800 DO 1120 J=1,NSLAVE 00323810 IF(KK.EQ.ISL(J,1)) GO TO 1130 00323820 1120 CONTINUE 00323830 GO TO 1200 00323840 1130 CONTINUE 00323850 ISLRF=J 00323860 DO 1180 J=1,3 00323870 NMAST=MOD(ISL(ISLRF,J+1),10000) 00323880 IF(NMAST.EQ.0) GO TO 1180 00323890 DO 1160 M=1,3 00323900 CALL UNPKID(AD,NUMNP,X,XJ,1,NMAST,M) 00323910 CALL UNPKID(AD,NUMNP,X,XK,1,KK,M) 00323920 1160 DX(M)=XK-XJ 00323930 DO 1170 L=1,LL 00323940 IF(J.EQ.1) B(NSHFT,1,L)=B(NSHFT,1,L)+DX(3)*B(NSHFT,5,L) 00323950 1 -DX(2)*B(NSHFT,6,L) 00323960 IF(J.EQ.2) B(NSHFT,2,L)=B(NSHFT,2,L)-DX(3)*B(NSHFT,4,L) 00323970 1 +DX(1)*B(NSHFT,6,L) 00323980 IF(J.EQ.3) B(NSHFT,3,L)=B(NSHFT,3,L)+DX(2)*B(NSHFT,4,L) 00323990 1 -DX(1)*B(NSHFT,5,L) 00324000 1170 CONTINUE 00324010 1180 CONTINUE 00324020 1200 CONTINUE 00324030 IF(KOUNT.EQ.NDPBLK.OR.KNT.EQ.NUMNP) GO TO 120 00324040 110 CONTINUE 00324050 120 KNT1=(I-1)*NDPBLK 00324060 DO 130 J=1,NDPBLK 00324070 KNT1=KNT1+1 00324080 IF(KNT1.GT.NUMNP) GO TO 150 00324090 WRITE(6,160)KNT1,(M,(B(J,K,M),K=1,6),M=1,LL) 00324100 IF(IABS(KDYN).EQ.11)GO TO 130 00324110 IF(NDIS.GT.0) WRITE (NDIS,170) KNT1,( (B(J,K,M),K=1,3),M=1,LL) 00324120 DO 125 M=1,LL 00324130 125 WRITE(32,200)KNT1,M,(B(J,K,M),K=1,3) 00324140 200 FORMAT(2I5,3F20.10) 00324150 IF(NDIS.GT.0.AND.KROT.EQ.2) WRITE (NDIS,170) KNT1,( (B(J,K,M),K=400324160 $,6),M=1,LL) 00324170 130 CONTINUE 00324180 140 CONTINUE 00324190 150 IF(KOPT.GT.0) WRITE(6,180) 00324200 160 FORMAT(1H0,I4,I5,1P6E20.10/(I10,6E20.10)) 00324210 170 FORMAT(I10,7E10.4/(8E10.4)) 00324220 180 FORMAT(// 3X,46H*** NOTE *** NODE NUMBERS ARE ORIGINAL NUMBERS //)00324230 RETURN 00324240 END 00324250 SUBROUTINE WRDIS2(NORD,A,B,NUMNP,LL,NDPBLK,NDIS,NBLK) 00324260 IMPLICIT REAL*8(A-H,O-Z) 00324270 DIMENSION NORD(NUMNP),A(6,LL),B(NDPBLK,6,LL) 00324280 COMMON /OUT/ KDUMMY(9),KROT 00324290 COMMON /BAND/ KOPT,NRBAND(7) R0324300 NT1=17 00324310 NT2=18 00324320 IF(KOPT.GT.0) READ (NT1) NORD 00324330 KSHF2=0 00324340 KSHF=1-NDPBLK 00324350 KNT=0 00324360 DO 140 I=1,NBLK 00324370 REWIND NT2 00324380 KOUNT=0 00324390 KK=NUMNP+1 00324400 KSHF=KSHF+NDPBLK 00324410 KSHF2=KSHF2+NDPBLK 00324420 DO 110 J=1,NUMNP 00324430 KK=KK-1 00324440 READ (NT2) A 00324450 KCH= KK 00324460 IF(KOPT.GT.0) KCH=NORD(KK) 00324470 IF(KCH.LT.KSHF.OR.KCH.GT.KSHF2) GO TO 110 00324480 KNT=KNT+1 00324490 KOUNT=KOUNT+1 00324500 NSHFT=KCH-KSHF+1 00324510 DO 100 K=1,6 00324520 DO 100 M=1,LL 00324530 100 B(NSHFT,K,M)=A(K,M) 00324540 IF(KOUNT.EQ.NDPBLK.OR.KNT.EQ.NUMNP) GO TO 120 00324550 110 CONTINUE 00324560 120 KNT1=(I-1)*NDPBLK 00324570 DO 130 J=1,NDPBLK 00324580 KNT1=KNT1+1 00324590 IF(KNT1.GT.NUMNP) GO TO 150 00324600 WRITE(6,160)KNT1,(M,(B(J,K,M),K=1,6),M=1,LL) 00324610 IF(NDIS.GT.0) WRITE (NDIS,170) KNT1,( (B(J,K,M),K=1,3),M=1,LL) 00324620 IF(NDIS.GT.0.AND.KROT.EQ.2) WRITE (NDIS,170) KNT1,( (B(J,K,M),K=400324630 $,6),M=1,LL) 00324640 DO 125 M=1,LL 00324650 125 WRITE(32,200)KNT1,M,(B(J,K,M),K=1,3) 00324660 200 FORMAT(2I5,3F20.10) 00324670 130 CONTINUE 00324680 140 CONTINUE 00324690 150 IF(KOPT.GT.0) WRITE(6,180) 00324700 160 FORMAT(1H0,I4,I5,1P3E12.3,3E11.2/(I10,3E12.3,3E11.2)) 00324710 170 FORMAT(I10,7E10.4/(8E10.4)) 00324720 180 FORMAT(// 3X,46H*** NOTE *** NODE NUMBERS ARE ORIGINAL NUMBERS //)00324730 RETURN 00324740 END 00324750 SUBROUTINE ALLFA 00016620 DOUBLE PRECISION A,SM2,SM3,VQIB2,VQIB3,DP,BF,TF,TW,DIAM,WALL,R2, 00016630 1 R3,EBM,RED,FY,XK,YK,DL,FATEN,FASHR,FACOM,FB2,FB3,PSI,SHR,COMB,00016640 2 AXR,BEND2,BEND3,P,S2I,S3I,S2J,S3J,XM2I,XM3I,XM2J,XM3J,TYPE, 00016650 3 PI,XLR2,XLR3,XLR,CC,RTL,FE2,FE3,XINER,AWC,DT257,FY6,AF,C,S76, 00016660 4 FB4,AFC,SQFY,S20,BT,T1,BT65,C102,DT,AW,BT95,C510,FB5,B,TI,XX, 00016670 5 DT1,ROD,CID,DT2,RID,DTA,AOD,AID,COD,ST,BTT,SS,DTT,BT190,BTS, 00016680 6 BT238,DTS,FS,T2,CM3T3,XFB2I,COMB2J,XFB3JB,T3,SH2I,XFB3I,TJ, 00016690 7 XFAFA,CM2,SH2J,XFB2J,COMB1I,XFB2IB,CM3,SH3I,XFB3J,COMB2I, 00016700 8 XFB3IB,CM2T2,SH3J,XFA,COMB1J,XFB2JB,TEMP,FLG,XINC, 00016710 9 XINER2,XINER3 00016720 COMMON/STEEL/A,SM2,SM3,VQIB2,VQIB3,DP,BF,TF,TW,DIAM,WALL,R2,R3, 00016730 1 EBM,RED,FY,XK,YK,DL,FATEN,FASHR,FACOM,FB2,FB3,PSI,SHR,COMB, 00016740 2 AXR,BEND2,BEND3,P,S2I,S3I,S2J,S3J,XM2I,XM3I,XM2J,XM3J, 00016750 3 TYPE,PI,XLR2,XLR3,XLR,CC,RTL,FE2,FE3,XINER,AWC,DT257,FY6,AF, 00016760 4 C,S76,FB4,AFC,SQFY,S20,BT,T1,BT65,C102,DT,AW,BT95,C510,FB5, 00016770 5 B,TI,XX,DT1,ROD,CID,DT2,RID,DTA,AOD,AID,COD,ST,BTT,SS,DTT, 00016780 6 BT190,BTS,BT238,DTS,FS,T2,CM3T3,XFB2I,COMB2J,XFB3JB,T3,SH2I, 00016790 7 XFB3I,TJ,XFAFA,CM2,SH2J,XFB2J,COMB1I,XFB2IB,CM3,SH3I,XFB3J, 00016800 8 COMB2I,XFB3IB,CM2T2,SH3J,XFA,COMB1J,XFB2JB,TEMP,FLG,XINC, 00016810 9 XINER2,XINER3,ICT,KATX,KATY 00016820 FATEN=.6D0*FY 00016830 FASHR=.4D0*FY 00016840 T1=(12.0D0*PI*PI*EBM)/23.0D0 00016850 XLR2=XK*DL/R2 00016860 XLR3=YK*DL/R3 00016870 FE2=T1/(XLR2*XLR2) 00016880 FE3=T1/(XLR3*XLR3) 00016890 XLR=XLR2 00016900 IF(XLR3.GT.XLR2)XLR=XLR3 00016910 IF(XLR.GT.200.0D0)GO TO 100 00016920 CC=DSQRT(2.0D0*PI*PI*EBM/(RED*FY)) 00016930 FS=(5.0D0/3.0D0)+(3.0D0*XLR)/(8.0D0*CC)-(XLR**3)/(8.0D0*CC**3) 00016940 FACOM=(1.0D0-((XLR*XLR)/(2.0D0*CC*CC)))*FY*RED/FS 00016950 IF(XLR.GT.CC)FACOM=T1/(XLR*XLR) 00016960 GO TO 150 00016970 100 FACOM=1.0D0 00016980 150 RETURN 00016990 END 00017000 00017010 00017020 SUBROUTINE COMBDS(D,DNEW,LL,NT18,NCOMB1,NUMNP) 00045700 IMPLICIT REAL*8(A-H,O-Z) 00045710 DIMENSION D(6,LL),DNEW(6,NCOMB1) 00045720 COMMON/COMBLD/PCT(15,7),SINC(15),NCOMB,NB(15),LD(15,7) 00045730 ITAPE1=1 00045740 REWIND ITAPE1 00045750 REWIND NT18 00045760 DO 500 MM=1,NUMNP 00045770 READ(NT18)D 00045780 DO 300 N=1,NCOMB 00045790 DO 270 I=1,6 00045800 270 DNEW(I,N)=0.0D0 00045810 NB1=NB(N) 00045820 DO 290 M=1,NB1 00045830 LCASE=LD(N,M) 00045840 IF(LCASE.EQ.0) GO TO 290 00045850 DO 280 I=1,6 00045860 280 DNEW(I,N)=DNEW(I,N)+D(I,LCASE)*PCT(N,M) 00045870 290 CONTINUE 00045880 300 CONTINUE 00045890 WRITE(ITAPE1)DNEW 00045900 500 CONTINUE 00045910 RETURN 00045920 END 00045930 SUBROUTINE SPRIST (IS1,IS2,SIG,SPR,NS) 00252280 IMPLICIT REAL*8(A-H,O-Z) 00252290 REAL*8 IS1,IS2,NS 00252300 DIMENSION SIG(12),SPR(6),IS(2),SG(6) 00252310 IS(1)=IS1 00252320 IS(2)=IS2 00252330 NNS=1 00252340 IF (NS.EQ.12) NNS=2 00252350 DO 150 N=1,NNS 00252360 IN=3*N-3 00252370 II=IN*2 00252380 IF (IS(N).EQ.0) GO TO 100 00252390 CC=(SIG(II+1)+SIG(II+2))/2. 00252400 BB=(SIG(II+1)-SIG(II+2))/2. 00252410 CR= 00252420 $ DSQRT(BB**2+SIG(II+4)**2) 00252430 SPR(IN+1)=CC+CR 00252440 SPR(IN+2)=CC-CR 00252450 SPR(IN+3)=0. 00252460 IF (BB.NE.0.)SPR(IN+3)=28.648* 00252470 $ DATAN2(SIG(II+4),BB) 00252480 GO TO 150 00252490 100 CC=(SIG(II+1)+SIG(II+2)+SIG(II+3))/3. 00252500 DO 110 I=1,3 00252510 SG(I)=SIG(II+I)-CC 00252520 110 SG(I+3)=SIG(II+I+3) 00252530 C2=(SG(1)**2+SG(2)**2+SG(3)**2)*.5+SG(4)**2+SG(5)**2+SG(6)**2 00252540 C3=SG(1)*(SG(2)*SG(3)-SG(5)*SG(5))+SG(4)*(SG(5)*SG(6)-SG(4)*SG(3))00252550 $+SG(6)*(SG(4)*SG(5)-SG(2)*SG(6)) 00252560 IF(C2.EQ.0.0D0) C2=1.0D-08 00252570 T= DSQRT(C2/1.5) 00252580 A=C3*1.414214/T**3 00252590 AXQ=A+1.0 00252600 IF(AXQ.GT.0.0.AND.AXQ.LT.2.0) A=DARCOS(A)/3.0 00252610 IF(AXQ.GE.2.0) A=0.0 00252620 IF(AXQ.LE.0.0) A=1.0471976 00252630 T=T*1.414214 00252640 SPR(IN+1)=T* DCOS(A) 00252650 SPR(IN+2)=T* DCOS(A+2.0944) 00252660 SPR(IN+3)=T* DCOS(A-2.0944) 00252670 DO 120 I=2,3 00252680 IF (SPR(IN+1).GT.SPR(IN+I)) GO TO 120 00252690 C3=SPR(IN+1) 00252700 SPR(IN+1)=SPR(IN+I) 00252710 SPR(IN+I)=C3 00252720 120 CONTINUE 00252730 IF (SPR(IN+2).LE.SPR(IN+3)) GO TO 130 00252740 C3=SPR(IN+2) 00252750 SPR(IN+2)=SPR(IN+3) 00252760 SPR(IN+3)=C3 00252770 130 DO 140 I=1,3 00252780 140 SPR(IN+I)=SPR(IN+I)+CC 00252790 150 CONTINUE 00252800 RETURN 00252810 END 00252820 SUBROUTINE WFFB 00321880 DOUBLE PRECISION A,SM2,SM3,VQIB2,VQIB3,DP,BF,TF,TW,DIAM,WALL,R2, 00321890 1 R3,EBM,RED,FY,XK,YK,DL,FATEN,FASHR,FACOM,FB2,FB3,PSI,SHR,COMB,00321900 2 AXR,BEND2,BEND3,P,S2I,S3I,S2J,S3J,XM2I,XM3I,XM2J,XM3J,TYPE, 00321910 3 PI,XLR2,XLR3,XLR,CC,RTL,FE2,FE3,XINER,AWC,DT257,FY6,AF,C,S76, 00321920 4 FB4,AFC,SQFY,S20,BT,T1,BT65,C102,DT,AW,BT95,C510,FB5,B,TI,XX, 00321930 5 DT1,ROD,CID,DT2,RID,DTA,AOD,AID,COD,ST,BTT,SS,DTT,BT190,BTS, 00321940 6 BT238,DTS,FS,T2,CM3T3,XFB2I,COMB2J,XFB3JB,T3,SH2I,XFB3I,TJ, 00321950 7 XFAFA,CM2,SH2J,XFB2J,COMB1I,XFB2IB,CM3,SH3I,XFB3J,COMB2I, 00321960 8 XFB3IB,CM2T2,SH3J,XFA,COMB1J,XFB2JB,TEMP,FLG,XINC, 00321970 9 XINER2,XINER3 00321980 COMMON/STEEL/A,SM2,SM3,VQIB2,VQIB3,DP,BF,TF,TW,DIAM,WALL,R2,R3, 00321990 1 EBM,RED,FY,XK,YK,DL,FATEN,FASHR,FACOM,FB2,FB3,PSI,SHR,COMB, 00322000 2 AXR,BEND2,BEND3,P,S2I,S3I,S2J,S3J,XM2I,XM3I,XM2J,XM3J, 00322010 3 TYPE,PI,XLR2,XLR3,XLR,CC,RTL,FE2,FE3,XINER,AWC,DT257,FY6,AF, 00322020 4 C,S76,FB4,AFC,SQFY,S20,BT,T1,BT65,C102,DT,AW,BT95,C510,FB5, 00322030 5 B,TI,XX,DT1,ROD,CID,DT2,RID,DTA,AOD,AID,COD,ST,BTT,SS,DTT, 00322040 6 BT190,BTS,BT238,DTS,FS,T2,CM3T3,XFB2I,COMB2J,XFB3JB,T3,SH2I, 00322050 7 XFB3I,TJ,XFAFA,CM2,SH2J,XFB2J,COMB1I,XFB2IB,CM3,SH3I,XFB3J, 00322060 8 COMB2I,XFB3IB,CM2T2,SH3J,XFA,COMB1J,XFB2JB,TEMP,FLG,XINC, 00322070 9 XINER2,XINER3,ICT,KATX,KATY 00322080 IF(ICT)10,10,20 00322090 10 DT257=640.0D0/SQFY 00322100 GO TO 30 00322110 20 TEMP=XFA/FY 00322120 DT257=257.0D0/SQFY 00322130 IF(TEMP.LE..16D0)DT257=640.0D0*(1.0D0-3.74D0*TEMP)/SQFY 00322140 30 FB3=FY6 00322150 FB4=FY6 00322160 IF(BT.LE.BT65.AND.DT.LE.DT257.AND.FLG.LE.S20)FB3=.6666667D0*FY 00322170 IF(BT.GT.BT65.AND.BT.LE.BT95.AND.DT.LE.DT257.AND.FLG.LE.S20) 00322180 1 FB3=(.79D0-.002D0*BT*SQFY)*FY 00322190 IF(RTL.GT.C102.AND.RTL.LE.C510) 00322200 1 FB4=((2.0D0/3.0D0)-((FY*RTL*RTL)/1530000.0D0))*FY 00322210 IF(RTL.GT.C510)FB4=(170000.0D0/(RTL*RTL)) 00322220 FB5=12000.0D0/((FLG*DP)/(BF*TF)) 00322230 IF(FB4.LT.FB5)FB4=FB5 00322240 IF(FB4.GT.FY6)FB4=FY6 00322250 IF(FB4.LT.FY6)FB3=FB4 00322260 IF(BT.GT.BT95)FB3=1.0D0 00322270 RETURN 00322280 END 00322290 00322300 00322310 SUBROUTINE TUFB 00317030 DOUBLE PRECISION A,SM2,SM3,VQIB2,VQIB3,DP,BF,TF,TW,DIAM,WALL,R2, 00317040 1 R3,EBM,RED,FY,XK,YK,DL,FATEN,FASHR,FACOM,FB2,FB3,PSI,SHR,COMB,00317050 2 AXR,BEND2,BEND3,P,S2I,S3I,S2J,S3J,XM2I,XM3I,XM2J,XM3J,TYPE, 00317060 3 PI,XLR2,XLR3,XLR,CC,RTL,FE2,FE3,XINER,AWC,DT257,FY6,AF,C,S76, 00317070 4 FB4,AFC,SQFY,S20,BT,T1,BT65,C102,DT,AW,BT95,C510,FB5,B,TI,XX, 00317080 5 DT1,ROD,CID,DT2,RID,DTA,AOD,AID,COD,ST,BTT,SS,DTT,BT190,BTS, 00317090 6 BT238,DTS,FS,T2,CM3T3,XFB2I,COMB2J,XFB3JB,T3,SH2I,XFB3I,TJ, 00317100 7 XFAFA,CM2,SH2J,XFB2J,COMB1I,XFB2IB,CM3,SH3I,XFB3J,COMB2I, 00317110 8 XFB3IB,CM2T2,SH3J,XFA,COMB1J,XFB2JB,TEMP,FLG,XINC, 00317120 9 XINER2,XINER3 00317130 COMMON/STEEL/A,SM2,SM3,VQIB2,VQIB3,DP,BF,TF,TW,DIAM,WALL,R2,R3, 00317140 1 EBM,RED,FY,XK,YK,DL,FATEN,FASHR,FACOM,FB2,FB3,PSI,SHR,COMB, 00317150 2 AXR,BEND2,BEND3,P,S2I,S3I,S2J,S3J,XM2I,XM3I,XM2J,XM3J, 00317160 3 TYPE,PI,XLR2,XLR3,XLR,CC,RTL,FE2,FE3,XINER,AWC,DT257,FY6,AF, 00317170 4 C,S76,FB4,AFC,SQFY,S20,BT,T1,BT65,C102,DT,AW,BT95,C510,FB5, 00317180 5 B,TI,XX,DT1,ROD,CID,DT2,RID,DTA,AOD,AID,COD,ST,BTT,SS,DTT, 00317190 6 BT190,BTS,BT238,DTS,FS,T2,CM3T3,XFB2I,COMB2J,XFB3JB,T3,SH2I, 00317200 7 XFB3I,TJ,XFAFA,CM2,SH2J,XFB2J,COMB1I,XFB2IB,CM3,SH3I,XFB3J, 00317210 8 COMB2I,XFB3IB,CM2T2,SH3J,XFA,COMB1J,XFB2JB,TEMP,FLG,XINC, 00317220 9 XINER2,XINER3,ICT,KATX,KATY 00317230 IF(ICT)10,10,20 00317240 10 DT257=640.0D0/SQFY 00317250 GO TO 30 00317260 20 TEMP=XFA/FY 00317270 DT257=257.0D0/SQFY 00317280 IF(TEMP.LE..16D0)DT257=640.0D0*(1.0D0-3.74D0*TEMP)/SQFY 00317290 30 IF((DABS(XM3I).LE.DABS(XM3J)).AND.XM3J.NE.0.0D0)TEMP=XM3I/XM3J 00317300 IF(DABS(XM3I).GT.DABS(XM3J))TEMP=XM3J/XM3I 00317310 IF(XM3I.EQ.0.0D0.OR.XM3J.EQ.0.0D0)TEMP=0.0D0 00317320 TEMP=1950.0D0+1200.0D0*TEMP 00317330 IF(TEMP.LT.1200.0D0)TEMP=1200.0D0 00317340 ST=TEMP*BF/FY 00317350 IF((DABS(XM2I).LE.DABS(XM2J)).AND.XM2J.NE.0.0D0)TEMP=XM2I/XM2J 00317360 IF(DABS(XM2I).GT.DABS(XM2J))TEMP=XM2J/XM2I 00317370 IF(XM2I.EQ.0.0D0.OR.XM2J.EQ.0.0D0)TEMP=0.0D0 00317380 TEMP=1950.0D0+1200.0D0*TEMP 00317390 IF(TEMP.LT.1200.0D0)TEMP=1200.0D0 00317400 SS=TEMP*DP/FY 00317410 FB2=FY6 00317420 FB3=FY6 00317430 IF(BTT.LE.BT190.AND.DTT.LE.DT257.AND.FLG.LE.ST)FB3=.6666667D0*FY 00317440 IF(BTS.LE.BT190.AND.DTS.LE.DT257.AND.FLG.LE.SS)FB2=.6666667D0*FY 00317450 IF(BTT.GT.BT238)FB3=1.0D0 00317460 IF(BTS.GT.BT238)FB2=1.0D0 00317470 RETURN 00317480 END 00317490 00317500 00317510 FUNCTION DARCOS(X) 00051930 IMPLICIT REAL*8(A-H,O-Z) 00051940 IF(X.EQ.0.0)DARCOS=3.141592653589793/2. 00051950 IF(X.EQ.0.0)RETURN 00051960 Y=DSQRT(1.-X*X) 00051970 Z=Y/X 00051980 DARCOS=DATAN(Z) 00051990 RETURN 00052000 END 00052010 SUBROUTINE USOL (A,B,MAXB,NEQB,MB,LL,NBLOCK,NSB,NORG,NBKS,NT1, 00318100 $NT2,NRST,DIS) 00318110 IMPLICIT REAL*8(A-H,O-Z) 00318120 REAL*8 MAXB 00318130 DIMENSION A(NSB),B(NSB),MAXB(NEQB) 00318140 DIMENSION ICOO(10),IFORM(4) 00318150 COMMON /SQZ/ ISQZ,NRSQZ(5) R0318160 COMMON /GPS/ NEQ4(10),NRGPS(10) R0318170 DIMENSION DIS(10,LL) 00318180 DATA ICOO /3H001,3H013,3H025,3H037,3H049,3H061,3H073,3H085,3H097, 00318190 $ 3H109/ 00318200 DATA IFORM(1),IFORM(3),IFORM(4)/4H(1H+,4HX,F7,4H.2) / 00318210 CALL FILES(11) 00318220 NSBE=NEQB+NSB 00318230 NC=MB+LL 00318240 NBR=(MB-1)/NEQB+1 00318250 INC=NEQB-1 00318260 NMB=NEQB*MB 00318270 NMB2=NMB*2/10 00318280 ZER=0.0D0 00318290 NGP=0 00318300 DO 100 I=1,10 00318310 IF(NEQ4(I).GT.0) NGP=I 00318320 100 CONTINUE 00318330 N2=NT2 00318340 N1=NT1 00318350 CALL RDWRT(NORG,A,1,6,INUM) 00318360 CALL RDWRT(NBKS,A,1,6,INUM) 00318370 WRITE(6,105) 00318380 105 FORMAT(1H1) 00318390 WRITE(6,106) 00318400 106 FORMAT(//10X,49HTHE LAST NUMBER PRINTED IS THE PERCENT OF THE FOR,00318410 $ 39HWARD REDUCTION THAT HAS BEEN COMPLETED.//) 00318420 ICO=1 00318430 DO 290 N=1,NBLOCK 00318440 KOD=0 00318450 NSUM=0 00318460 IF (N.GT.1.AND.NBR.EQ.1) GO TO 120 00318470 IF (NBR.EQ.1) GO TO 110 00318480 CALL RDWRT(N1 ,A,1,6,INUM) 00318490 CALL RDWRT(N2 ,A,1,6,INUM) 00318500 110 NI=N1 00318510 IF(N.EQ.1) NI=NORG 00318520 CALL EXPAND(A,NSB ,NI) 00318530 120 DO 210 I=1,NEQB 00318540 MAXB(I)=0 00318550 D=A(I) 00318560 IF(D) 130,210,150 00318570 130 M=NEQB*(N-1)+I 00318580 WRITE (6,140) M,D 00318590 140 FORMAT (33H0SET OF EQUATIONS MAY BE SINGULAR / 00318600 $ 26H DIAGONAL TERM OF EQUATION, I8, 8H EQUALS, 1PE12.4) 00318610 WRITE(6,106) 00318620 ICO=1 00318630 150 II=I 00318640 D=1.0/D 00318650 NCM1=NC-1 00318660 CALL QVMPY1(A(I+NEQB),A(I+NEQB),D,NCM1,NEQB,NEQB,0) 00318670 K=NMB+I 00318680 DO 170 J=1,MB 00318690 NJ=J 00318700 K=K-NEQB 00318710 IF(A(K).NE.0.0) GO TO 180 00318720 170 CONTINUE 00318730 180 MAXB(I)=K 00318740 NSUM=NSUM+NJ 00318750 IF(I.EQ.NEQB.AND.NSUM.LT.NMB2) KOD=1 00318760 JL=I+1 00318770 IF (JL.GT.NEQB) GO TO 210 00318780 II=I 00318790 DO 200 J=JL,NEQB 00318800 II=II+NEQB 00318810 IF(II.GT.NMB) GO TO 200 00318820 C=A(II) 00318830 IF (C.EQ.0.0) GO TO 200 00318840 C=C*A(I) 00318850 KK=J-II 00318860 MAX=MAXB(I) 00318870 CALL QMR2(A(J),A(J),C,A(II),(MAX-II)/NEQB+1,NEQB,NEQB,NEQB) 00318880 KK=J +NMB 00318890 JJ=I+NMB 00318900 DO 190 L=1,LL 00318910 A(KK)=A(KK)-C*A(JJ) 00318920 KK=KK+NEQB 00318930 190 JJ=JJ+NEQB 00318940 200 CONTINUE 00318950 210 CONTINUE 00318960 IF(N.EQ.NBLOCK) CALL SQEEZE(A,NSBE,NBKS,KOD) 00318970 IF(N.EQ.NBLOCK) GO TO 270 00318980 DO 260 NN=1,NBR 00318990 IF(N+NN.GT.NBLOCK) GO TO 260 00319000 NI=N1 00319010 IF(N.EQ.1) NI=NORG 00319020 IF(NN.EQ.NBR) NI=NORG 00319030 CALL EXPAND(B,NSB,NI) 00319040 IL=1+NN*NEQB*NEQB 00319050 DO 240 I=1,NEQB 00319060 II=IL 00319070 DO 230 K=1,NEQB 00319080 IF (II.GT.NMB) GO TO 230 00319090 C=A(II) 00319100 IF (C.EQ.0.0) GO TO 230 00319110 C=C*A(K) 00319120 MAX=MAXB(K) 00319130 KK=I-II 00319140 CALL QMR2(B(I),B(I),C,A(II),(MAX-II)/NEQB+1,NEQB,NEQB,NEQB) 00319150 KK=I+NMB 00319160 JJ=K+NMB 00319170 DO 220 L=1,LL 00319180 B(KK)=B(KK)-C*A(JJ) 00319190 KK=KK+NEQB 00319200 220 JJ=JJ+NEQB 00319210 230 II=II-INC 00319220 240 IL=IL+NEQB 00319230 IF(NBR.NE.1) GO TO 250 00319240 CALL SQEEZE(A,NSBE,NBKS,KOD) 00319250 CALL MEMOVE (B(1),A(1),NSB) 00319260 GO TO 260 00319270 250 CALL SQEEZE(B,NSB,N2,ISQZ) 00319280 260 CONTINUE 00319290 IF(NBR.NE.1.OR.NBLOCK.EQ.1) CALL SQEEZE(A,NSBE,NBKS,KOD) 00319300 270 CONTINUE 00319310 PER=N*100.0/NBLOCK 00319320 IFORM(2) = ICOO(ICO) 00319330 WRITE (6,IFORM) PER 00319340 ICO=ICO+1 00319350 IF(ICO.LT.11) GO TO 285 00319360 WRITE(6,284) 00319370 284 FORMAT(1H ) 00319380 ICO=1 00319390 285 CONTINUE 00319400 M=N1 00319410 N1=N2 00319420 290 N2=M 00319430 LS=LL*NEQB 00319440 NEB=NEQB*(NBR+1) 00319450 NUM=NBR*NEQB 00319460 MAX=NEB*LL 00319470 CALL MEMSET (ZER,B(1),MAX) 00319480 CALL RDWRT(NRST,A,1,6,INUM) 00319490 WRITE(6,105) 00319500 WRITE(6,295) 00319510 295 FORMAT(//10X,49HTHE LAST NUMBER PRINTED IS THE PERCENT OF THE BAC,00319520 $ 39HK SUBSTITUTION THAT HAS BEEN COMPLETED.//) 00319530 ICO=1 00319540 DO 380 N=1,NBLOCK 00319550 NEQT=(NBLOCK-N )*NEQB 00319560 CALL RDWRT(NBKS,A,1,2,INUM) 00319570 CALL EXPAND(A,NSBE,NBKS) 00319580 CALL RDWRT(NBKS,A,1,2,INUM) 00319590 DO 300 L=1,LL 00319600 K=L*NEB 00319610 DO 300 J=1,NUM 00319620 I=K-NEQB 00319630 B(K)=B(I) 00319640 300 K=K-1 00319650 I=NMB+1 00319660 DO 310 L=1,LL 00319670 K=(L-1)*NEB+1 00319680 CALL MEMOVE (A(I),B(K),NEQB) 00319690 310 I=I+NEQB 00319700 DO 350 I=1,NEQB 00319710 J=NEQB+1-I 00319720 MAX=MAXB(J) 00319730 IF (A(J).EQ.0.) GO TO 350 00319740 KGP=0 00319750 IF(NGP.EQ.0) GO TO 330 00319760 NEN=NEQT+J 00319770 DO 320 IG=1,NGP 00319780 IF(NEN.EQ.NEQ4(IG)) KGP=IG 00319790 320 CONTINUE 00319800 330 CONTINUE 00319810 DO 340 L=1,LL 00319820 KK=J+(L-1)*NEB 00319830 JJ=KK+1 00319840 IL=J+NEQB 00319850 C=B(KK) 00319860 NTER=(MAX-IL)/NEQB+1 00319870 IF( NTER.LE.0) GO TO 340 00319880 CONST=C 00319890 CALL QVDOT(C,A(IL),B(JJ),NTER,NEQB,1) 00319900 C=CONST-C 00319910 B(KK)=C 00319920 IF(KGP.GT.0) DIS(KGP,L)=C 00319930 340 CONTINUE 00319940 350 CONTINUE 00319950 I=1 00319960 DO 360 L=1,LL 00319970 K=(L-1)*NEB+1 00319980 CALL MEMOVE (B(K),A(I),NEQB) 00319990 360 I=I+NEQB 00320000 CALL RDWRT(NRST,A,LS,13,K) 00320010 PER=N*100.0/NBLOCK 00320020 IFORM(2) = ICOO(ICO) 00320030 WRITE (6,IFORM) PER 00320040 ICO=ICO+1 00320050 IF(ICO.LT.11) GO TO 380 00320060 WRITE(6,284) 00320070 ICO=1 00320080 380 CONTINUE 00320090 WRITE(6,390) 00320100 390 FORMAT(////20X,40(1H*)/20X,40HGAUSSIAN ELIMINATION HAS BEEN COMPLE00320110 $TED./20X,40(1H*)) 00320120 RETURN 00320130 END 00320140 SUBROUTINE QVMPY1(A,B,C,N,INCA,INCB,INCC) 00194240 IMPLICIT REAL*8(A-H,O-Z) 00194250 DIMENSION A(1),B(1) 00194260 JA=1 00194270 JB=1 00194280 DO 100 I=1,N 00194290 A(JA)=B(JB)*C 00194300 JA=JA+INCA 00194310 100 JB=JB+INCB 00194320 RETURN 00194330 END 00194340 SUBROUTINE MEMOVE (IFROM,ITO,NWDS) 00135690 REAL*8 IFROM, ITO 00135700 DIMENSION IFROM(1),ITO(1) 00135710 DO 100 I=1,NWDS 00135720 100 ITO(I)=IFROM(I) 00135730 RETURN 00135740 END 00135750 FUNCTION GETWRD(GET001) 00105400 INTEGER SECT,POINT,BEGIN,GETSEC,EPOINT,BLANK,AGET,AGETW 00105410 LOGICAL EOL,EOS,EOF,ERROR,INDEX,GETWRD,IGET,RGET,ERR1 00105420 COMMON /FRECNT/ LINE(80),SECT,EOL,EOS,EOF, 00105430 1ERROR,BLANK,ICOMMA,POINT,BEGIN,LENGTH, 00105440 2EPOINT,NSECT,LINENM,MAXSTR,KUNIT,JUNIT,IUNIT 00105450 GETWRD = .FALSE. 00105460 LENGTH = 0 00105470 IF (EOL) RETURN 00105480 DO 100 BEGIN = POINT,80 00105490 IF (LINE(BEGIN).NE.BLANK) GO TO 110 00105500 100 CONTINUE 00105510 EOL = .TRUE. 00105520 POINT = 80 00105530 RETURN 00105540 110 DO 170 POINT = BEGIN,80 00105550 IF (LINE(POINT).EQ.BLANK.OR.LINE(POINT).EQ.ICOMMA) 00105560 1GO TO 180 00105570 LENGTH = POINT - BEGIN + 1 00105580 MAXSTR = LENGTH 00105590 170 CONTINUE 00105600 GETWRD = .TRUE. 00105610 EOL = .TRUE. 00105620 RETURN 00105630 180 IP = POINT 00105640 DO 200 POINT = POINT,80 00105650 IF (LINE(POINT).EQ.ICOMMA) GO TO 210 00105660 IF (LINE(POINT).NE.BLANK) GO TO 190 00105670 200 CONTINUE 00105680 GETWRD = .TRUE. 00105690 EOL =.TRUE. 00105700 RETURN 00105710 190 POINT = IP 00105720 GETWRD = .TRUE. 00105730 RETURN 00105740 210 POINT = POINT + 1 00105750 GETWRD = .TRUE. 00105760 RETURN 00105770 END 00105780