Liren Large Software Subsidy 9

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

/ Liren Large Software Subsidy 9 / 09.iso / e / e003 / 4.ddi / ELSTF15.FOR < prev next >

Wrap

Text File | 1987-02-20 | 27.1 KB | 340 lines

SUBROUTINE SIXBY6( 00237090 $ID,PROP1,PROP2,PROP3,PROP4,PROP5,PROP6,PROP7,LM,S,P,XM,SA,TT,TEMPD00237100 $,KK1,KK2,KK3,KK4,KK5,KK6,KK7,IX,NEL,NUMNP,NDMX,NSMX,MXDF,PROP9,KK900237110 $) 00237120 IMPLICIT REAL*8(A-H,O-Z) 00237130 REAL*8 LM,ID 00237140 DIMENSION LM(MXDF),S(MXDF,MXDF),SA(NSMX,MXDF),ID(NUMNP,1),PROP9(KK00237150 $9,21),IX(1) 00237160 COMMON /PREP/ XZ(2),KSKIP,RRPREP(8) R0237170 COMMON /QTSARG/ T(3,3),STIF(6,6),X(4,3),Y1,Y2,X1,X2,Z1,Z2,S1,S2, R0237180 $ XX,AX,AY,AZ,I,J,K,MA,MB,LA,LB,JM,IL,NRQTSA(1853) R0237190 COMMON /ELPAR/ZPAR(14),NZP,MBAND,RRELPA(28) R0237200 NS=6 00237210 ND=6 00237220 DO 100 I=1,4 00237230 IF(IX(I).GE.0.AND.IX(I).LE.NUMNP) GO TO 100 00237240 KSKIP=1 00237250 WRITE(6,110)IX(I) 00237260 100 CONTINUE 00237270 110 FORMAT (20X,6H NODE ,I6,17H IS OUT OF RANGE.) 00237280 IF(KSKIP.EQ.1) RETURN 00237290 DO 120 I=1,4 00237300 NX=IX(I) 00237310 IF(NX.EQ.0) GO TO 120 00237320 DO 115 J=1,3 00237330 115 CALL UNPKID(ID,NUMNP,WX,X(I,J),1,NX,J) 00237340 120 CONTINUE 00237350 MAT=IX(9) 00237360 IF(MAT.GT.0.AND.MAT.LE.KK9) GO TO 140 00237370 KSKIP=1 00237380 WRITE(6,130)NEL 00237390 130 FORMAT(///42H A MATRIX COULD NOT BE LOCATED FOR ELEMENT,I6//) 00237400 140 KK=0 00237410 DO 150 I=1,6 00237420 DO 150 J=I,6 00237430 KK=KK+1 00237440 STIF(I,J)=PROP9(MAT,KK) 00237450 150 STIF(J,I)=STIF(I,J) 00237460 DO 160 I=1,6 00237470 160 CALL UNPKID(ID,NUMNP,LM(I),WX,2,IX(1),I) 00237480 DO 170 I=1,3 00237490 DO 170 J=1,3 00237500 T(I,J)=0.0 00237510 170 T(I,I)=1.0 00237520 IF(IX(2).EQ.0) GO TO 180 00237530 X1=X(3,1)-X(2,1) 00237540 Y1=X(3,2)-X(2,2) 00237550 Z1=X(3,3)-X(2,3) 00237560 X2=X(4,1)-X(2,1) 00237570 Y2=X(4,2)-X(2,2) 00237580 Z2=X(4,3)-X(2,3) 00237590 S1=X1*X1+Y1*Y1+Z1*Z1 00237600 S1= DSQRT(S1) 00237610 X1=X1/S1 00237620 Y1=Y1/S1 00237630 Z1=Z1/S1 00237640 T(1,1)=X1 00237650 T(1,2)=Y1 00237660 T(1,3)=Z1 00237670 AA=X1*X1+Y1*Y1+Z1*Z1 00237680 AB=X1*X2+Y1*Y2+Z1*Z2 00237690 U1=AA*X2-AB*X1 00237700 U2=AA*Y2-AB*Y1 00237710 U3=AA*Z2-AB*Z1 00237720 UU=U1*U1+U2*U2+U3*U3 00237730 UU= DSQRT(UU) 00237740 T(2,1)=U1/UU 00237750 T(2,2)=U2/UU 00237760 T(2,3)=U3/UU 00237770 T(3,1)=T(1,2)*T(2,3)-T(1,3)*T(2,2) 00237780 T(3,2)=T(1,3)*T(2,1)-T(1,1)*T(2,3) 00237790 T(3,3)=T(1,1)*T(2,2)-T(1,2)*T(2,1) 00237800 180 CONTINUE 00237810 DO 200 LA=1,4,3 00237820 LB=LA+2 00237830 DO 200 MA=1,4,3 00237840 MB=MA-1 00237850 DO 200 I=LA,LB 00237860 DO 200 JM=1,3 00237870 J=JM+MB 00237880 XX=0.0 00237890 DO 190 K=1,3 00237900 KMB= K+MB 00237910 XXS=STIF(I,KMB)*T(K,JM) 00237920 190 XX=XX+XXS 00237930 200 SA(I,J)=XX 00237940 DO 220 LA=1,4,3 00237950 LB=LA-1 00237960 DO 220 MA=1,4,3 00237970 MB=MA+2 00237980 DO 220 IL=1,3 00237990 I=IL+LB 00238000 DO 220 J=MA,MB 00238010 XX=0.0 00238020 DO 210 K=1,3 00238030 KLB=K+LB 00238040 XXS=T(K,IL)*SA(KLB,J) 00238050 210 XX=XX+XXS 00238060 220 S(I,J)=XX 00238070 CALL WRITET(MBAND,NDIF,14,ND,NS,LM,SA) 00238080 RETURN 00238090 END 00238100 SUBROUTINE GESTEL(ID,LM,S,P 00104820 &,XM,SA,TT,TEMPD,KK1,KK2,KK3,KK4,KK5,KK6,KK7,IX,IA,NEL 00104830 &,NUMNP,NDMX,NSMX,MXDF,P10,KK10,KK10A) 00104840 IMPLICIT REAL*8 (A-H,O-Z) 00104850 REAL*8 LM,ID 00104860 DIMENSION LM(MXDF),S(MXDF,MXDF),IX(9) 00104870 &,SA(NSMX,MXDF),ID(NUMNP,1),P10(1177,KK10A) 00104880 COMMON /PREP/ XZ(2),KSKIP,NDYN,I1,RRPREP(7) R0104890 COMMON /ELPAR/ZPAR(14),NZP,MBAND,RRELPA(28) R0104900 NODS=0 00104910 DO 10 I=1,8 00104920 IF(IX(I).GT.0)GO TO 9 00104930 GO TO 11 00104940 9 IF(IX(I).LE.NUMNP)GO TO 10 00104950 KSKIP=1 00104960 WRITE(6,1000)IX(I) 00104970 10 NODS=NODS+1 00104980 11 CONTINUE 00104990 IF(NODS.EQ.0)WRITE(6,1002)IX(9) 00105000 IF(NODS.EQ.0)KSKIP=1 00105010 IF(KSKIP.EQ.1)RETURN 00105020 MTYPE=IX(9) 00105030 IF(MTYPE.LE.KK10)GO TO 12 00105040 KSKIP=1 00105050 WRITE(6,1001)NEL 00105060 RETURN 00105070 12 CONTINUE 00105080 ND=6*NODS 00105090 M1=0 00105100 DO 20 I=1,ND 00105110 DO 20 J=I,ND 00105120 M1=M1+1 00105130 S(I,J)=P10(M1,MTYPE) 00105140 S(J,I)=S(I,J) 00105150 20 CONTINUE 00105160 MATYP=P10(1177,MTYPE) 00105170 IF(MATYP.EQ.0)GO TO 200 00105180 200 CONTINUE 00105190 DO 300 I=1,NSMX 00105200 DO 300 J=1,MXDF 00105210 300 SA(I,J)=0. 00105220 K=0 00105230 DO 310 J=1,NODS 00105240 DO 310 I=1,6 00105250 K=K+1 00105260 CALL UNPKID(ID,NUMNP,LM(K),DX,2,IX(J),I) 00105270 310 CONTINUE 00105280 NS=6 00105290 NELTYP=15 00105300 CALL WRITET(MBAND,NDIF,NELTYP,ND,NS,LM,SA) 00105310 RETURN 00105320 1000 FORMAT(20X,26H ERROR IN ELEMENT TYPE 15/ 00105330 &20X,5H NODE,I5,16H IS OUT OF RANGE) 00105340 1001 FORMAT(40H FATAL ERROR. THE STIFFNESS MATRIX FOR, 00105350 &8H ELEMENT,I5,15H DOES NOT EXIST) 00105360 1002 FORMAT(47H FATAL ERROR. NO NODES HAVE BEEN SPECIFIED FOR, 00105370 &8H ELEMENT,I5) 00105380 END 00105390 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 SUBROUTINE CLAMP( 00040000 $ID,PROP1,PROP2,PROP3,PROP4,PROP5,PROP6,PROP7,LM,S,P,XM,SA,TT,TEMPD00040010 $,KK1,KK2,KK3,KK4,KK5,KK6,KK7,IX,IA,NEL,NUMNP,NDMX,NSMX,MXDF) 00040020 IMPLICIT REAL*8(A-H,O-Z) 00040030 REAL*8 LM 00040040 REAL*8 ID 00040050 REAL*8 NPAR 00040060 LOGICAL ELPRT,ELPCH,GENPRT,GENPCH 00040070 COMMON/CTL/ELPRT,ELPCH,GENPRT,GENPCH 00040080 COMMON /ELPAR/ NPAR(14),NUMNN,MBAND,NELTYP,N1,N2,N3,N4,N5,MTOT,NEQ00040090 $ ,N2P,N3P,NMRI,NTRI,N1P,NUMEL,NUMEL2,KZ(20,2),NEMN 00040100 DIMENSION LM(MXDF),S(MXDF,MXDF),P(MXDF,KK6), XM(MXDF) 00040110 DIMENSION SA(NSMX,MXDF),TT(NSMX,KK6) 00040120 DIMENSION ID(NUMNP,1),PROP6(KK6,7) 00040130 COMMON / MISC / NBLOCK,NEQB,LL,NF,LB 00040140 COMMON/PREP/XMX,XAD,KSKIP,NDYN,I1,RRPREP(7) R0040150 COMMON/JUNK/R(6),X(5,3),N(5),I,Z(5),Y(3),RRJUNK(195) R0040160 NS=2 00040170 ND=6 00040180 DO 210 MMM=1,NUMEL2 00040190 ZER=0.0D0 00040200 CALL MEMSET (ZER,LM(1),NEMN) 00040210 READ (8) Z,SC,Y 00040220 DO 100 I=1,5 00040230 100 N(I)= Z(I) 00040240 IF(N(3).EQ.0) N(3)=N(1) 00040250 SD=Y(1) 00040260 SR=Y(2) 00040270 TRACE= Y(3) 00040280 IF (TRACE.LT.0.1)TRACE=1.0E+10 00040290 KD=0 00040300 KR=0 00040310 IF(SC.GE.10) KD=1 00040320 IF(SC.EQ.1.0.OR.SC.EQ.11.0) KR=1 00040330 DO 115 I=1,5 00040340 NX=N(I) 00040350 IF(NX.EQ.0) GO TO 115 00040360 DO 110 J=1,3 00040370 CALL UNPKID ( ID ,NUMNP,W ,X(I,J) ,1,NX,J) 00040380 110 CONTINUE 00040390 115 CONTINUE 00040400 IF(N(4).EQ.0) GO TO 120 00040410 X1=X(3,1)-X(2,1) 00040420 Y1=X(3,2)-X(2,2) 00040430 Z1=X(3,3)-X(2,3) 00040440 X2=X(5,1)-X(4,1) 00040450 Y2=X(5,2)-X(4,2) 00040460 Z2=X(5,3)-X(4,3) 00040470 T1=Y1*Z2-Y2*Z1 00040480 T2=Z1*X2-Z2*X1 00040490 T3=X1*Y2-X2*Y1 00040500 GO TO 130 00040510 120 T1=X(3,1)-X(2,1) 00040520 T2=X(3,2)-X(2,2) 00040530 T3=X(3,3)-X(2,3) 00040540 130 XL=T1*T1+T2*T2+T3*T3 00040550 XL= DSQRT(XL) 00040560 T1=T1/XL 00040570 T2=T2/XL 00040580 T3=T3/XL 00040590 IF (KD.EQ.0) GO TO 140 00040600 SA(1,1)=T1*TRACE 00040610 SA(1,2)=T2*TRACE 00040620 SA(1,3)=T3*TRACE 00040630 S(1,1)=T1*T1*TRACE 00040640 S(1,2)=T1*T2*TRACE 00040650 S(1,3)=T1*T3*TRACE 00040660 S(2,2)=T2*T2*TRACE 00040670 S(2,3)=T2*T3*TRACE 00040680 S(3,3)=T3*T3*TRACE 00040690 PP=TRACE*SD 00040700 R(1)=T1*PP 00040710 R(2)=T2*PP 00040720 R(3)=T3*PP 00040730 DO 135 J=1,LL 00040740 135 TT(1,J)=-PP*PROP6(J,4) 00040750 GO TO 150 00040760 140 S(1,1)=0. 00040770 S(1,2)=0. 00040780 S(1,3)=0. 00040790 S(2,2)=0. 00040800 S(2,3)=0. 00040810 S(3,3)=0. 00040820 SA(1,1)=0. 00040830 SA(1,2)=0. 00040840 SA(1,3)=0. 00040850 R(1)=0. 00040860 R(2)=0. 00040870 R(3)=0. 00040880 150 IF (KR.EQ.0) GO TO 160 00040890 SA(2,4)=T1*TRACE 00040900 SA(2,5)=T2*TRACE 00040910 SA(2,6)=T3*TRACE 00040920 S(4,4)=T1*T1*TRACE 00040930 S(4,5)=T1*T2*TRACE 00040940 S(4,6)=T1*T3*TRACE 00040950 S(5,5)=T2*T2*TRACE 00040960 S(5,6)=T2*T3*TRACE 00040970 S(6,6)=T3*T3*TRACE 00040980 PP=TRACE*SR 00040990 R(4)=T1*PP 00041000 R(5)=T2*PP 00041010 R(6)=T3*PP 00041020 DO 155 J=1,LL 00041030 155 TT(2,J)=-PP*PROP6(J,4) 00041040 GO TO 170 00041050 160 S(4,4)=0. 00041060 S(4,5)=0. 00041070 S(4,6)=0. 00041080 S(5,5)=0. 00041090 S(5,6)=0. 00041100 S(6,6)=0. 00041110 SA(2,4)=0. 00041120 SA(2,5)=0. 00041130 SA(2,6)=0. 00041140 R(4)=0. 00041150 R(5)=0. 00041160 R(6)=0. 00041170 170 DO 180 I=2,6 00041180 IM1=I-1 00041190 DO 180 J=1,IM1 00041200 180 S(I,J)=S(J,I) 00041210 DO 190 I=1,6 00041220 DO 190 J=1,LL 00041230 190 P(I,J)=R(I)*PROP6(J,4) 00041240 NN=N(1) 00041250 DO 200 I=1,6 00041260 200 CALL UNPKID ( ID ,NUMNP,LM(I) ,WX ,2,NN,I) 00041270 TT(1,1)=TT(1,1)+N(1)/10000. 00041280 TT(2,1)=TT(2,1)+N(1)/10000. 00041290 IF(.NOT.ELPRT) GO TO 1150 00041300 IRAM=MMM+NUMEL 00041310 WRITE(6,1400)IRAM 00041320 IF(ELPCH) WRITE(7,1400) IRAM 00041330 1150 CONTINUE 00041340 CALL WRITET(MBAND,NDIF,7,ND,NS,LM,SA) 00041350 210 CONTINUE 00041360 RETURN 00041370 1400 FORMAT(5X,17HELEMENT NUMBER = ,I5) 00041380 END 00041390