Liren Large Software Subsidy 9

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

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

Wrap

Text File | 1980-01-04 | 96.6 KB | 1,223 lines

PROGRAM SAP6P2 R0001101 IMPLICIT REAL*8(A-H,O-Z) 00001100 LOGICAL ELPRT,ELPCH,GENPRT,GENPCH,DEFPCH,GEOST 00001110 COMMON/BMDATA/IAISC,ILDTYP,ILDMUL,IBMSEC,NLWAVE,ILOCAL 00001120 COMMON/EQUILB/NEQIL,NX43 00001130 COMMON/CTL/ELPRT,ELPCH,GENPRT,GENPCH 00001140 COMMON / JUNK / DUK(227) 00001150 REAL*8 NPAR 00001160 COMMON /QTSARG/ QQQ(1000) 00001170 COMMON/DYN3/ NEIG,NAD,ANORM,NVV,NFO 00001180 COMMON /DYN4/KDYN,NRESS,NCRD,NCWT,NRESS1 00001190 COMMON /DYN5/FRSHFT,FRINIT,FREND,MODEFR,NOSS 00001200 COMMON /TAPES/NSTIF,NRED,NL,NR,NT,NMASS 00001210 COMMON /EXTRA/MODEX,NT8,N10SV,NT10,KEQB,NY,T(10) 00001220 COMMON/GEOSTF/GEOST,NELGEO 00001230 COMMON/MASS/LMASS 00001240 COMMON/MATL/MATLCO R0001241 COMMON/SIZE/NDMX,MXDF,NSMX,NTERM,NADND 00001250 COMMON/SLVE/NSLAVE 00001260 COMMON /ELPAR/ NPAR(14),NUMNP,MBAND,NELTYP,N1,N2,N3,N4,N5,MTOT,NEQ00001270 $ ,N2P,N3P,NMRI,NTRI,N1P,NUMEL,NUMEL2,KZ(20,2),NEMN 00001280 COMMON / MISC / NBLOCK,NEQB,LL,NFREQ,LB 00001290 COMMON/AMB/ GRAV,REFT,JROT 00001300 COMMON /PREP/ XMX,XAD,KSKIP,NDYN,I1,I99,POS,PRTCOD 00001310 $ ,POSSAV,PRTOFF,PRTON,PRTDUM,IDIRC 00001320 COMMON /DYN/ IFIL1(11),IFIL2 00001330 COMMON/ELARRY/NELAR(4,20) 00001340 COMMON /ELTEMP/ SET1(103) 00001350 $ /OUT/KSET2(6),KELRST,MAXDF,IFIL3(2) 00001360 $ /SQZ/ SET3,LIST,LISTC,LISTB,LISTA 00001370 $ /TRASH/ SET4(490) 00001380 $ /GPS/ SET5(10) 00001390 $ /CG/ SET6(4),RFIL1(2) 00001400 $ /TAPES/ SET7(6) 00001410 $ /DYN2/KSET8(3),NFVC,SET8(12) 00001420 COMMON /WORDS/ NWDS(30,2) 00001430 COMMON /BAND/ NRNM(3),IRSK,IFIL4(4) 00001440 COMMON /HEADIN/TITLE1(20),TITLE2(5),TITLE3(10) 00001450 COMMON /SUPEL/ NSELEM,NEQL,NODESE 00001460 $,KSET(3) 00001470 COMMON/FORCE/ NLC,NELD 00001480 COMMON/DAPG/NQ1,NQX,DUMY(210) 00001490 COMMON/VAXPLT/IVPLT,XVB(6),XVA(4),MINX,MINY,LEN 00001500 COMMON /ICM/ICOMP,MMRI,MTRI,M1P,M2P,M3P 00001510 COMMON/PLOTH/IPLT,IPLWRT 00001520 COMMON/COMMT/NTYP,NUMET,NNRRC,NNRRC1 R0001521 COMMON/COMMT1/NDSSS,KDSSS,NTY,NSLDM,NBLANK,MDYN,NE2B,KRK1,MCB,MLT R0001522 DIMENSION KZN(20),ZD(31) 00001530 DIMENSION NEXPDT(2),NOWDTE(4) 00001540 COMMON A(1) 00001550 DATA KZN/2,7,1,2,7,7,10,7,21,1177,6,51,10,21,9,7,8,5,0,0/ 00001560 DATA NEXPDT/78,222/ 00001570 WRITE (*,990) R0001611 990 FORMAT (' ************** PROGRAM SAP6P2 STARTING *********')R0001612 KZN(1)=2 00001880 KZN(2)=7 00001890 KZN(3)=1 00001900 KZN(4)=2 00001910 KZN(5)=7 00001920 KZN(6)=7 00001930 KZN(7)=10 00001940 KZN(8)=7 00001950 KZN(9)=21 00001960 KZN(10)=1177 00001970 KZN(11)=6 00001980 KZN(12)=51 00001990 KZN(13)=10 00002000 KZN(14)=21 00002010 KZN(15)=9 00002020 KZN(16)=7 00002030 KZN(17)=8 00002040 KZN(18)=5 00002050 KZN(19)=0 00002060 KZN(20)=0 00002070 MKZ=20 00002090 CALL SIZER2 R0002091 MTOTR = MTOT R0002091 CALL COMMRW(1) R0002092 MTOT = MTOTR R0002093 NDSSS=NDYN 00002250 IF(NDYN.NE.12)GO TO 115 00002260 NDSSS=12 00002270 KDSSS=KDYN 00002280 NDYN=6 00002290 KDYN=6 00002300 IF(KDSSS.LT.0)KDYN=-6 00002310 115 CONTINUE 00002320 CALL RDWRT(1,A(1),1,11,I) 00002330 IF(NTYP.EQ.0) GO TO 170 00002340 REWIND 3 00002350 NEMN=(MXDF+LL)*(NSMX+MXDF)+MXDF*2+NDMX*LL 00002360 IF(LMASS.EQ.1) NEMN=NEMN+MXDF*(MXDF-1) 00002370 IF(NDYN.EQ.11) GEOST=.TRUE. IF(GEOST) WRITE(6,2009) NDYN 2009 FORMAT (5X,'****** SAP6PC2 NDYN ********',I5/) IF(GEOST) 00002380 $ NEMN=NEMN+3*(MXDF*MXDF) 00002390 NEMN=NEMN+3 00002400 NI=1+NEMN 00002410 DO 120 I=1,MKZ 00002420 120 KZ(I,1)=KZ(I,1)+NEMN 00002430 NTYP=NTYP+NEMN 00002440 N1P =N1P +NEMN 00002450 N2P =N2P +NEMN 00002460 N3P =N3P +NEMN 00002470 M1P = M1P + NEMN 00002480 M2P = M2P + NEMN 00002490 M3P = M3P + NEMN 00002500 130 J=0 00002510 DO 140 I=1,MKZ 00002520 IF(KZ(I,1).EQ.NI) J=I 00002530 140 CONTINUE 00002540 IF(J.GT.0) GO TO 150 00002550 NF=NTRI*4+NMRI*3+NI-1 00002560 GO TO 160 00002570 150 NTY=KZN(J) 00002580 IF(J.EQ.16) NTY=NTY*LL 00002590 NF=NI+KZ(J,2)*NTY-1 00002600 IF(ICOMP.EQ.1.AND.J.EQ.7)NF=NI+MTRI*9+MMRI*3-1 00002610 160 READ (3) (A(I),I=NI,NF) 00002620 WRITE(6,2002) N1P,N2P,N3P,NI,NF,NTYP WRITE(6,2001) (A(II),II=NI,NF) 2001 FORMAT (1X,'**S2**',12E10.4/) 2002 FORMAT (5X,'** N1P N2P N3P NI NF NTYP **',6I5/) NI=NF+1 00002630 IF(NF.LT.NTYP) GO TO 130 00002640 170 CONTINUE 00002650 N1=NTYP+1 00002660 N2=N1+NUMNP*3 00002670 N3=N1+NUMEL*13 00002680 IF(N2.GT.MTOT) CALL ERROR(N2-MTOT) 00002690 N4=N3+NTERM*NADND 00002700 N5=N4+NSLAVE*4 00002710 NSLDM=NSLAVE 00002720 IF(NSLDM.EQ.0) NSLDM=1 00002730 IF(N5.GT.MTOT) CALL ERROR(N5-MTOT) 00002740 KRK1 = N5 R0002741 180 CALL INPTN (A(N1),A(N1),A(N3),NUMEL,NUMEL2,NUMNP,NTERM,NADND, 00002750 $NEQ,I,A(N4),NSLDM) 00002760 NBLANK=I 00002770 IF(NEQ.EQ.0) KSKIP=1 00002780 IF(KSKIP.EQ.1.AND.NEQ.EQ.0) NEQ=1 00002790 CALL SECOND(T(2)) 00002800 DO 9180 I=3,10 00002810 9180 T(I)=T(2) 00002820 IF(KSKIP.EQ.1) GO TO 185 00002830 NEMNM=NEMN-NDMX*LL-2 00002840 IF(.NOT.GEOST) GO TO 1180 00002850 NEMNM=NEMNM-3*(MXDF*MXDF) 00002860 1180 CONTINUE 00002870 IF(KELRST.NE.2) GO TO 181 00002880 NNRRC = 183 R0002881 GO TO 183 00002890 181 CONTINUE 00002900 KAPG=N4 00002910 KAPG1=KAPG+NUMNP 00002920 KRK1=KAPG1+NSLAVE*4 00002930 IF(KRK1 .GT.MTOT)CALL ERROR(KRK1-MTOT) 00002940 NBLANK=0 00002950 MAXDF=0 00002960 CALL ELSTF(NDMX,LL,A(NEMNM),NBLANK,NTERM,ZD(1),NADND 00002970 & ,A(KAPG),NUMNP,A(KAPG1),NSLDM) 00002980 IF(NSELEM.LE.0) GO TO 183 00002990 IF(LMASS.NE.-1) GO TO 1190 00003000 IF(NDYN.NE.8) GO TO 1190 00003010 WRITE(6,550)NDYN,LMASS 00003020 KSKIP = 1 00003030 1190 CONTINUE 00003040 N3=N1 00003050 N1=1 00003060 N2=KZ(6,1) 00003070 N4=7*LL 00003080 CALL QVCOPY(A(N2),A(N1),N4) 00003090 N2=N4+1 00003100 N4=NUMNP*3 00003110 CALL QVCOPY(A(N3),A(N2),N4) 00003120 N3=N2+N4 00003130 CALL SUPSTF(NSELEM,A(N1),A(N2),A(N3),LL,NUMNP,MTOT,MBAND,MAXDF) 00003140 N5=7*LL 00003150 CALL QVCOPY(A(N1),A(N3),N5) 00003160 KZ(6,1)=N3 00003170 CALL QVCOPY(A(N2),A(N1),N4) 00003180 N2=N1+N4 00003190 550 FORMAT(5X,47H ** ERROR. ONLY ONE LEVEL OF SUBSTRUCTURING IS, 00007710 $18HALLOWED WHEN NDYN=,I3,2X,10HAND LMASS=,I3) 00007720 183 CONTINUE 185 CONTINUE WRITE (*,1095) N2,N4,N5,KRK1 1095 FORMAT (5X,'****** N2,N4,N5,KRK1 ******',4I5) CALL COMMRW(0) WRITE (*,1099) 1099 FORMAT (5X,'********** SAP6P2 FINISHED ***********') CC STOP END SUBROUTINE ERROR(I) 00086230 IMPLICIT REAL*8(A-H,O-Z) 00086240 REAL*8 X 00086250 COMMON /EXTRA/ MODEX,NREXTR(25) R0086260 COMMON /PREP/ X(2),KSKIP,RRPREP(8) R0086270 KSKIP=1 00086280 MODEX=1 00086290 WRITE(6,100)I 00086300 100 FORMAT (1H0//1X,30HALLOCATED STORAGE EXCEEDED BY ,I7,6H WORDS) 00086310 WRITE(6,110) 00086320 110 FORMAT(/1X, 29HNO EXECUTION WILL BE ALLOWED./) 00086330 RETURN 00086340 END 00086350 SUBROUTINE INPTN(ID,ID2,ID4,NUMEL,NUMEL2,NUMNP,NTERM,NADND,NEQ,I, 00118260 1ISL,NSLDM) 00118270 IMPLICIT REAL*8(A-H,O-Z) 00118280 REAL*8 ID3,ID2 R0118290 REAL*8 ID 00118300 REAL*8 ID4 R0118310 LOGICAL ISLAVE R0118311 COMMON /GPS/ NEQ4(10),NRGPS(10) R0118320 COMMON /PREP/ XMX,XAD,KSKIP,NDYN,I1,I99,POS,PRTCOD 00118330 $ ,POSSAV,PRTOFF,PRTON,PRTDUM,IDIRC 00118340 COMMON /SUPEL/NSELEM,NEQL,NODESE,NRSUPE(3) R0118350 COMMON/SLVE/NSLAVE 00118360 COMMON /ELARRY/NELAR(4,20) 00118390 DIMENSION ID4(NADND) R0118370 DIMENSION ID(NUMNP,3) R0118380 DIMENSION IX(6) R0118390 DIMENSION IZ(6) 00118400 DIMENSION ID3(9),ID2(13),ISL(NSLDM,4) R0118410 CALL FILES(7) 00118430 REWIND 8 00118440 READ (8) ((ID(I,J),J=1,3),I=1,NUMNP) RR118450 IF(NSLAVE.NE.0) REWIND 30 00118460 IF(NSLAVE.NE.0) READ(30)((ISL(I,J),J=1,4),I=1,NSLAVE) RR118470 IF(KSKIP.EQ.1) GO TO 90 00118480 IF(PRTCOD.EQ.PRTOFF) GO TO 95 00118490 IF(POS.EQ.PRTDUM.AND.PRTCOD.NE.PRTON) GO TO 95 00118500 90 WRITE(6,100) 00118510 95 CONTINUE 00118520 100 FORMAT(1X ,35X,28HEQUATION NUMBERS VS. DEGREES,1X, 00118530 110HOF FREEDOM,/26X,58(1H-) 00118540 2 //15X,2(40HNODE X Y Z XX YY ZZ,10X)/) 00118550 110 FORMAT(15X,I5,6I6) 00118560 111 FORMAT(1H+,64X,I5,6I6) 00118570 I1I1=-I1*I1 00118580 DO 120 I=1,10 00118590 120 NEQ4(I)=I1I1 00118600 NG=1000 00118610 NEQ=0 00118620 DO 190 I=1,NUMNP 00118630 ISLAVE=.FALSE. 00118640 IF(NSLAVE.EQ.0) GO TO 1150 00118650 DO 1120 J=1,NSLAVE 00118660 IF(I.EQ.ISL(J,1)) GO TO 1140 00118670 1120 CONTINUE 00118680 GO TO 1150 00118690 1140 ISLAVE=.TRUE. 00118700 ISLRF=J 00118710 1150 CONTINUE 00118720 DO 160 K=1,3 00118730 NNN=ID(I,K) 00118740 NNN= MOD(NNN,I1) 00118750 IF(NNN.EQ.1) GO TO 150 00118760 IF(.NOT.ISLAVE) GO TO 1160 00118770 JJ=ISL(ISLRF,(K+1)) 00118780 JJ=MOD(JJ,10000) 00118790 IF(JJ.EQ.0) GO TO 1160 00118800 GO TO 1170 00118810 1160 CONTINUE 00118820 NEQ=NEQ+1 00118830 NEQ1=NEQ 00118840 IF(NNN.EQ.0) GO TO 140 00118850 NEQ2=NNN/NG 00118860 IF(NEQ4(NEQ2).GT.0) GO TO 130 00118870 NEQ4(NEQ2)=NEQ1 00118880 GO TO 140 00118890 130 NEQ=NEQ1-1 00118900 NEQ1=NEQ4(NEQ2) 00118910 140 IX(K)=NEQ1 00118920 GO TO 1175 00118930 150 IX(K )=0 00118940 GO TO 1175 00118950 1170 IZ(K)=-JJ 00118960 IX(K)=0 00118970 GO TO 160 00118980 1175 IZ(K)=IX(K) 00118990 160 CONTINUE 00119000 DO 180 K=1,3 00119010 NNN=ID(I,K) 00119020 NN2=NNN 00119030 NNN=NNN/I1 00119040 IF(NNN.GT.0) GO TO 170 00119050 IF(.NOT.ISLAVE) GO TO 1180 00119060 JJ=ISL(ISLRF,(K+1))/10000 00119070 IF(JJ.EQ.0) GO TO 1180 00119080 GO TO 1190 00119090 1180 CONTINUE 00119100 NEQ=NEQ+1 00119110 IX(K+3)=0 00119120 IF(IX(K).GT.0) IX(K+3)=NEQ-IX(K) 00119130 IF(IX(K).EQ.0.AND. NEQ.EQ.1) IX(K)=I1 00119140 IF(IX(K).EQ.0)IX(K)=-NEQ 00119150 IZ(K+3)=NEQ 00119160 GO TO 180 00119170 170 IX(K+3)=0 00119180 IZ(K+3)=0 00119190 GO TO 180 00119200 1190 IX(K+3)=0 00119210 IZ(K+3)=-JJ 00119220 180 ID(I,K)=(ID(I,K)-NN2)+IX(K)+IX(K+3)*I1 00119230 IF(KSKIP.EQ.1) GO TO 186 00119240 IF(PRTCOD.EQ.PRTOFF) GO TO 190 00119250 IF(POS.EQ.PRTDUM.AND.PRTCOD.NE.PRTON) GO TO 190 00119260 186 CONTINUE 00119270 IF(MOD(I,2)) 184,185,184 00119280 184 WRITE(6,110) I,IZ 00119290 GO TO 190 00119300 185 WRITE(6,111) I,IZ 00119310 190 CONTINUE 00119320 IF(NSLAVE.EQ.0)GO TO 1350 00119330 DO 1300 I=1,NSLAVE 00119340 ISLN=ISL(I,1) 00119350 DO 1265 K=1,3 00119360 JJ=ISL(I,(K+1)) 00119370 JJ=MOD(JJ,10000) 00119380 CALL UNPKID(ID,NUMNP,W,WX,2,ISLN,K) 00119390 NEQSL=W 00119400 IF(JJ.EQ.0) GO TO 1260 00119410 NNN=ID(JJ,K) 00119420 NNN=MOD(NNN,I1) 00119430 CALL UNPKID(ID,NUMNP,W,WX,2,JJ,K) 00119440 NEQM=W 00119450 1250 IX(K)=NEQM 00119460 IZ(K)=NEQM 00119470 GO TO 1265 00119480 1260 CONTINUE 00119490 IX(K)=NEQSL 00119500 IZ(K)=NEQSL 00119510 1265 CONTINUE 00119520 DO 1280 K=1,3 00119530 NNS=ID(ISLN,K) 00119540 NNN=NNS/I1 00119550 CALL UNPKID(ID,NUMNP,W,WX,2,ISLN,K+3) 00119560 NEQSL=W 00119570 CALL UNPKID(ID,NUMNP,W,COORD,1,ISLN,K) 00119580 JJ=ISL(I,K+1)/10000 00119590 IF(JJ.EQ.0) GO TO 1270 00119600 NNN=ID(JJ,K) 00119610 NNN=NNN/I1 00119620 CALL UNPKID(ID,NUMNP,W,WX,2,JJ,K+3) 00119630 NEQM=W 00119640 IX(K+3)=0 00119650 IZ(K+3)=NEQM 00119660 IF(NEQM.EQ.0) GO TO 1280 00119670 GO TO 1275 00119680 1270 CONTINUE 00119690 IX(K+3)=0 00119700 IZ(K+3)=NEQSL 00119710 NEQM=NEQSL 00119720 IF(NEQM.EQ.0) GO TO 1280 00119730 1275 CONTINUE 00119740 IF(IX(K).GT.0.AND.IX(K).GT.NEQM) GO TO 1277 00119750 IF(IX(K).GT.0) IX(K+3)=NEQM-IX(K) 00119760 IF(IX(K).EQ.0.AND.NEQM.EQ.1) IX(K)=I1 00119770 IF(IX(K).EQ.0) IX(K)=-NEQM 00119780 GO TO 1280 00119790 1277 IX(K)=-IX(K) 00119800 IX(K+3)=-NEQM 00119810 1280 ID(ISLN,K)=COORD/XMX+XAD+IX(K)+IX(K+3)*I1 00119820 IF(MOD(I,2))1290,1295,1290 00119830 1290 CONTINUE 00119840 GO TO 1300 00119850 1295 CONTINUE 00119860 1300 CONTINUE 00119870 1350 CONTINUE 00119880 PRTCOD = POS 00119890 IF(NSLAVE.EQ.0) GO TO 1410 00119900 WRITE(6,310) 00119910 DO 1400 I=1,NUMNP 00119920 DO 1360 K=1,6 00119930 IZ(K)=0 00119940 CALL UNPKID(ID,NUMNP,W,WX,2,I,K) 00119950 IZ(K)=W 00119960 1360 CONTINUE 00119970 IF(MOD(I,2))1390,1395,1390 00119980 1390 WRITE(6,110)I,IZ 00119990 GO TO 1400 00120000 1395 WRITE(6,111)I,IZ 00120010 1400 CONTINUE 00120020 1410 CONTINUE 00120030 IF (KSKIP.EQ.1.AND.NDYN.NE.2) GO TO 250 00120040 NEQL=0 00120050 IF(NDYN.NE.8.AND.NDYN.NE.9) GO TO 196 00120060 DO 192 K=1,6 00120070 CALL UNPKID(ID,NUMNP,W,WX,2,NODESE,K) 00120080 IF(W.GT.0.0)GO TO 194 00120090 192 CONTINUE 00120100 194 NEQL=W-1 00120110 WRITE(6,195)NEQL 00120120 195 FORMAT(/20X,37HTHE LAST EQUATION TO BE ELIMINATED IS,I5//) 00120130 196 CONTINUE 00120140 REWIND 8 00120150 WRITE (8) ID 00120160 200 REWIND 4 00120170 NBLANK=0 00120180 DO 210 I=1,NUMEL R0120181 READ (4) ID2 R0120190 IF(NTERM.GT.1) READ (4) ID4 RR120200 CC DO 210 I=1,NUMEL 00120210 MT=ID2(13) R0120220 IF(MT.EQ.7) NBLANK=NBLANK+1 00120230 CC WRITE (6,1009) I,ID2 R0120232 WRITE (68) ID2 R0120240 IF(NTERM.GT.1.AND.NELAR(1,MT).GT.8) WRITE (68) ID4 R0120250 210 CONTINUE 00120260 220 IF(NUMEL2.EQ.0) GO TO 240 00120270 REWIND 9 00120280 DO 230 I=1,NUMEL2 00120290 READ (9) ID3 00120300 230 WRITE (8) ID3 00120310 240 REWIND 8 00120320 CC REWIND 68 R0120321 I=NBLANK 00120330 READ (8) ID 00120340 250 CONTINUE 00120350 RETURN 00120360 300 FORMAT(1X ,36X,28HEQUATION NUMBERS VS. DEGREES,1X, 00120370 131HOF FREEDOM FOR SLAVE NODES ONLY,/37X,60(1H-) 00120380 2 //15X,2(40HNODE X Y Z XX YY ZZ,10X)/) 00120390 310 FORMAT(1X ,20X,28HEQUATION NUMBERS VS. DEGREES,1X, 00120400 157HOF FREEDOM AFTER THE DECOMPOSTION OF SLAVE NODE EQUATIONS, 00120410 2/11X,105(1H-) 00120420 2 //15X,2(40HNODE X Y Z XX YY ZZ,10X)/) 00120430 C1009 FORMAT (1X,'IN INPTN OF ELEMENT RANGE ',I5,13F7.1/) R0120431 END 00120440 SUBROUTINE UNPKID(ID,NUMNP,X,COORD,MODE,N,IDOF) 00317660 IMPLICIT REAL*8 (A-H,O-Z) 00317670 REAL*8 ID 00317680 DIMENSION ID(NUMNP,3) 00317690 COMMON /PREP/XMX,XAD,J1(2),I1,RRPREP(7) R0317700 GO TO (100,110),MODE 00317710 100 X=ID(N,IDOF) 00317720 K=X 00317730 IF(X.LT.0.0) K=K-1 00317740 COORD=(X-K-XAD)*XMX 00317750 RETURN 00317760 110 JJ=IDOF 00317770 IF(IDOF.GE.4) GO TO 120 00317780 NNN=ID(N,JJ) 00317790 IF(NNN.LT.0) GO TO 115 00317800 NNN= MOD(NNN,I1) 00317810 GO TO 117 00317820 115 CONTINUE 00317830 IF(IABS(NNN).GT.I1) GO TO 116 00317840 NNN=MOD(NNN,I1) 00317850 IF(NNN.LT.0) NNN=0 00317860 GO TO 117 00317870 116 NNN=1-NNN 00317880 NNN=MOD(NNN,I1) 00317890 GO TO 117 00317900 117 X=NNN 00317910 RETURN 00317920 120 JJ=JJ-3 00317930 NNN=ID(N,JJ) 00317940 00317950 IF(NNN.GE.0) GO TO 130 00317960 IF(IABS(NNN).LT.I1) GO TO 130 00317970 NN2=NNN/I1 00317980 NNN=-NN2 00317990 GO TO 140 00318000 130 CONTINUE 00318010 NN2=MOD(NNN,I1) 00318020 NNN=NNN/I1 00318030 IF(NNN.GT.0) NNN=NNN+NN2 00318040 IF(NN2.LT.0) NNN=1-NN2 00318050 140 CONTINUE 00318060 X=NNN 00318070 RETURN 00318080 END 00318090 SUBROUTINE FILES (NOPEN) 00087420 RETURN 00087430 END 00087440 SUBROUTINE QVCOPY(FROM,TO,N) 00193850 REAL*8 FROM,TO 00193860 DIMENSION FROM(1),TO(1) 00193870 DO 100 I=1,N 00193880 100 TO(I)=FROM(I) 00193890 RETURN 00193900 END 00193910 SUBROUTINE QMR2(C,D,FAC,B,N,JC,KC,JB) 00186840 IMPLICIT REAL*8(A-H,O-Z) 00186850 DIMENSION B(1),C(1),D(1) 00186860 IB=1 00186870 IC=1 00186880 DO 100 I=1,N 00186890 C(IC)=D(IC)-FAC*B(IB) 00186900 IB=IB+JB 00186910 100 IC=IC+JC 00186920 RETURN 00186930 END 00186940 SUBROUTINE QVSET(C,A,N) 00194580 REAL*8 C,A 00194590 DIMENSION A(1) 00194600 DO 100 I=1,N 00194610 100 A(I)=C 00194620 RETURN 00194630 END 00194640 SUBROUTINE CLOSE RETURN END SUBROUTINE EXIT WRITE (6,101) 101 FORMAT (5X,'******** SAP6 PROGRAM STOP ********') STOP END SUBROUTINE SECOND(T) 00234270 IMPLICIT REAL*8 (A-H,O-Z) 00234280 CALL GETTIM(NA,NB,NC,ND) R0234281 AA = NA * 100.0 R0234282 CC = NC R0234283 CC = CC / 100.0 R0234284 T = AA + NB + CC R0234285 RETURN 00234300 END R0234310 BLOCKDATA 00007790 IMPLICIT REAL*8(A-H,O-Z) 00007800 COMMON/HEADIN/TITLE1(20),TITLE2(5),TITLE3(10) 00007810 COMMON/ELARRY/NELAR(4,20) 00007820 COMMON /GASS/ XK(4,4),WGT(4,4),IPERM(3) 00007830 COMMON/GASS2/A5(7,2),W5(7) 00007840 COMMON /PREP/XMX,XAD,KSKIP,NDYN,I1,I99,POS,PRTCOD 00007850 1,POSSAV,PRTOFF,PRTON,PRTDUM,IDIRC 00007860 DATA XK / 0.D0, 0.D0, 0.D0, 0.D0,00007870 $ -.5773502691896D0, .5773502691896D0, 0.D0, 0.D0,00007880 $ -.7745966692415D0, .0000000000000D0, .7745966692415D0, 0.D0,00007890 $ -.8611363115941D0,-.3399810435849D0, .3399810435849D0, 00007900 $.8611363115941D0/ 00007910 DATA WGT / 2.000D0, 0.D0, 0.D0, 0.D0, 00007920 $ 1.0000000000000D0,1.0000000000000D0, 0.D0, 0.D0, 00007930 $ .5555555555556D0, .8888888888889D0, .5555555555556D0,0.D0, 00007940 $ .3478548451375D0, .6521451548625D0, .6521451548625D0, 00007950 $ .3478548451375D0/ 00007960 DATA IPERM / 2,3,1 / 00007970 DATA A5(1,1)/-0.333333333333D0/,A5(2,1)/-0.88056825640D0/ 00007980 DATA A5(3,1)/-0.05971587178D0/,A5(4,1)/-0.05971587178D0/ 00007990 DATA A5(5,1)/ 0.59485397070D0/, A5(6,1)/-0.79742698530D0/ 00008000 DATA A5(7,1)/-0.79742698530D0/, A5(1,2)/-0.333333333333D0/ 00008010 DATA A5(2,2)/-0.05971587178D0/, A5(3,2)/-0.88076825640D0/ 00008020 DATA A5(4,2)/-0.05971587178D0/ ,A5(5,2)/-0.79742698530D0/ 00008030 DATA A5(6,2)/ 0.59485397070D0/ ,A5(7,2)/-0.79742698530D0/ 00008040 DATA W5(1)/ 0.225 D0/, W5(2)/ 0.13239415 D0/ 00008050 DATA W5(3)/ 0.13239415 D0/, W5(4)/ 0.13239415 D0/ 00008060 DATA W5(5)/ 0.12593918 D0/, W5(6)/ 0.12593918 D0/ 00008070 DATA W5(7)/ 0.12593918 D0/ 00008080 DATA NELAR / 00008090 $ 2, 2, 6, 2, 00008100 $ 3, 2, 12, 28, 00008110 $ 4, 4, 12, 8, 00008120 $ 4, 4, 8, 4, 00008130 $ 8, 8, 33, 54, 00008140 $ 4, 4, 42, 24, 00008150 $ 1, 1, 1, 1, 00008160 $ 4, 4, 8, 4, 00008170 $ 3, 2, 12, 39, 00008180 $ 20, 20, 60, 54, 00008190 $ 8, 8, 16, 52, 00008200 $ 8, 8, 16, 52, 00008210 $ 8, 8, 16, 52, 00008220 $ 4, 1, 6, 6, 00008230 $ 8, 8, 48, 6, 00008240 $ 20*0/ 00008250 DATA TITLE2/4H ,4HSAP6,4H ,4HVER.,4H 2.0/ 00008260 DATA TITLE3(3)/4H LPI/,TITLE3(4)/4HAUTO/,TITLE3(5)/54./ 00008330 DATA POS/3H /,PRTCOD/3H / 00008340 DATA POSSAV/3H /,PRTOFF/3HOFF/,PRTON/3HON-/,PRTDUM/3HDUM/ 00008350 DATA IDIRC/0/ 00008360 END 00008370 SUBROUTINE ALPHZH(T,M,ALPHZM) 00017030 IMPLICIT REAL*8(A-H,O-Z) 00017040 DIMENSION COEF(11,8) 00017050 DATA COEF/ 00017060 1 7.0,100.0,1500.0,8.971084,1.541013E-3,4.438142E-6,-2.33287E-8, 00017070 1 4.508292E-11,-4.192721E-14,1.877651E-17,-3.252818E-21, 00017080 2 7.0,100.0,1500.0,8.971084,1.541013E-3,4.438142E-6,-2.33287E-8, 00017090 2 4.508292E-11,-4.192721E-14,1.877651E-17,-3.252818E-21, 00017100 3 0.0,0.0,2500.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0, 00017110 4 4.0,75.0,1400.0,6.971162,2.609495E-3,-3.323012E-6, 00017120 4 2.919442E-9,-8.657382E-13,0.0,0.0,0.0, 00017130 5 4.0,100.0,800.0,5.839035,3.176186E-3,-3.025846E-6, 00017140 5 3.570877E-9,-1.518135E-12,0.0,0.0,0.0, 00017150 6 4.0,100.0,800.0,5.839035,3.176186E-3,-3.025846E-6, 00017160 6 3.570877E-9,-1.518135E-12,0.0,0.0,0.0, 00017170 7 4.0,100.0,800.0,5.839035,3.176186E-3,-3.025846E-6, 00017180 7 3.570877E-9,-1.518135E-12,0.0,0.0,0.0, 00017190 8 0.0,0.0,2500.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0/ 00017200 ICODE=4 00017210 IF(M.LT.1.OR.M.GT.8)CALL RPZLVZ(M,T,ICODE,8) 00017220 N=COEF(1,M) 00017230 T1=COEF(2,M) 00017240 T2=COEF(3,M) 00017250 IF(T.LT.T1.OR.T.GT.T2)CALL RPZLVZ(M,T,ICODE,1) 00017260 ALPHZM=COEF(N+4,M) 00017270 IF(N.EQ.0)RETURN 00017280 DO 10 I=1,N 00017290 10 ALPHZM=ALPHZM*T+COEF(N-I+4,M) 00017300 RETURN 00017310 END 00017320 SUBROUTINE ALPHZL(T,M,ALPHZM) 00017330 IMPLICIT REAL*8(A-H,O-Z) 00017340 IF(M.LT.1.OR.M.GT.15) GO TO 1000 00017350 IF(M.EQ.1) ALPHZM=6.12 00017360 IF(M.EQ.1) RETURN 00017370 1000 WRITE(6,1010) M 00017380 1010 FORMAT(1X ,88HERROR--YOU HAVE ENTERED MATERIAL PROPERTY ROUTINE AL00017390 1PHZM WITH A MATERIAL CODE NUMBER OF ,I5,1H./8X,74HONLY VALUES BETW00017400 2EEN 1 AND 15 ARE VALID. CHECK YOUR INPUT, JOB TERMINATED.) 00017410 RETURN 00017420 END 00017430 DOUBLE PRECISION FUNCTION ALPHZM(T,M) 00017440 IMPLICIT REAL*8(A-H,O-Z) 00017450 COMMON/MATL/MATLCO 00017460 DATA NHIGH/4HHIGH/ 00017470 IF(MATLCO.NE.NHIGH)GO TO 10 00017480 CALL ALPHZH(T,M,X) 00017490 ALPHZM=X*1.0D-6 00017500 RETURN 00017510 10 CALL ALPHZL(T,M,X) 00017520 ALPHZM=X*1.0D-6 00017530 RETURN 00017540 END 00017550 SUBROUTINE DENS1 (T,M,DENS ) 00056740 IMPLICIT REAL*8(A-H,O-Z) 00056750 IF(M.LT.1.OR.M.GT.15) GO TO 1000 00056760 IF(M.EQ.1) DENS=490.9 00056770 IF(M.EQ.1) RETURN 00056780 1000 WRITE(6,1010) M 00056790 1010 FORMAT(1X ,86HERROR--YOU HAVE ENTERED MATERIAL PROPERTY ROUTINE DE00056800 1NS WITH A MATERIAL CODE NUMBER OF , I5,1H./8X,74HONLY VALUES BETW00056810 2EEN 1 AND 15 ARE VALID. CHECK YOUR INPUT, JOB TERMINATED.) 00056820 RETURN 00056830 END 00056840 SUBROUTINE DENS2 (T,M,DENS ) 00056850 IMPLICIT REAL*8(A-H,O-Z) 00056860 DIMENSION COEF(11,8) 00056870 DATA COEF/ 00056880 1 1.0,100.0,1500.0,502.5447,-1.603769E-2,0.0,0.0,0.0,0.0,0.0,0.0, 00056890 2 1.0,100.0,1500.0,498.5886,-1.537035E-2,0.0,0.0,0.0,0.0,0.0,0.0, 00056900 3 3.0,32.0,2500.0,59.566,-7.9504E-3,-2.872E-7,6.035E-11,0.0,0.0, 00056910 3 0.0,0.0, 00056920 4 2.0,75.0,1400.0,526.1008,-1.345453E-2,-1.194367E-7,0.0,0.0,0.0, 00056930 4 0.0,0.0, 00056940 5 1.0,100.0,800.0,491.8014,-1.287008E-2,0.0,0.0,0.0,0.0,0.0,0.0, 00056950 6 1.0,100.0,800.0,491.8014,-1.287008E-2,0.0,0.0,0.0,0.0,0.0,0.0, 00056960 7 4.0,100.0,800.0,492.0608,-1.713633E-2,1.997181E-5,-3.37813E-8, 00056970 7 1.874099E-11,0.0,0.0,0.0, 00056980 8 4.0,0.0,2500.0,8.591723E-2,-1.737652E-4,2.648259E-7,-.2314231E-9,00056990 8 8.177454E-14,0.0,0.0,0.0/ 00057000 ICODE=3 00057010 IF(M.LT.1.OR.M.GT.8)CALL RPZLVZ(M,T,ICODE,8) 00057020 N=COEF(1,M) 00057030 T1=COEF(2,M) 00057040 T2=COEF(3,M) 00057050 IF(T.LT.T1.OR.T.GT.T2)CALL RPZLVZ(M,T,ICODE,1) 00057060 IF(T.GT.208.OR.M.NE.3)GO TO 5 00057070 DENS=60.93-6.792E-3*T-2.9E-6*T*T 00057080 RETURN 00057090 5 CONTINUE 00057100 DENS =COEF(N+4,M) 00057110 IF(N.EQ.0)RETURN 00057120 DO 10 I=1,N 00057130 10 DENS =DENS *T+COEF(N-I+4,M) 00057140 RETURN 00057150 END 00057160 DOUBLE PRECISION FUNCTION DENS (T,M) 00056620 IMPLICIT REAL*8(A-H,O-Z) 00056630 COMMON/MATL/MATLCO 00056640 DATA NHIGH/4HHIGH/ 00056650 IF(MATLCO.NE.NHIGH)GO TO 10 00056660 CALL DENS2 (T,M,X) 00056670 DENS=X 00056680 RETURN 00056690 10 CALL DENS1 (T,M,X) 00056700 DENS=X 00056710 RETURN 00056720 END 00056730 SUBROUTINE MODUE1 (T,M,MODUE ) 00150370 IMPLICIT REAL*8(A-H,O-Z) 00150380 REAL*8MODUE 00150390 IF(M.LT.1.OR.M.GT.15) GO TO 1000 00150400 IF(M.EQ.1) MODUE=29.665 00150410 IF(M.EQ.1) RETURN 00150420 1000 WRITE(6,1010) M 00150430 1010 FORMAT(1X ,87HERROR--YOU HAVE ENTERED MATERIAL PROPERTY ROUTINE MO00150440 1DUE WITH A MATERIAL CODE NUMBER OF , I5,1H./8X,74HONLY VALUES BETW00150450 2EEN 1 AND 15 ARE VALID. CHECK YOUR INPUT, JOB TERMINATED.) 00150460 RETURN 00150470 END 00150480 SUBROUTINE MODUE2 (T,M,MODUE ) 00150490 IMPLICIT REAL*8(A-H,O-Z) 00150500 REAL*8 MODUE 00150510 DIMENSION COEF(11,8) 00150520 DATA COEF/ 00150530 1 3.0,100.0,1500.0,28.33669,-2.882211E-3,-3.697849E-6,7.709188E-10,00150540 1 0.0,0.0,0.0,0.0, 00150550 2 3.0,100.0,1500.0,28.33669,-2.882211E-3,-3.697849E-6,7.709188E-10,00150560 2 0.0,0.0,0.0,0.0, 00150570 3 0.0,32.0,2500.0,0.01,0.0,0.0,0.0,0.0,0.0,0.0,0.0, 00150580 4 7.0,75.0,1600.0,32.17532,-8.441689E-3,1.0776E-5,1.433823E-9, 00150590 4 -3.887096E-11,5.191192E-14,-2.767454E-17,5.402884E-21, 00150600 5 4.0,100.0,800.0,30.28987,-3.658438E-3,-2.600385E-6,4.86326E-9, 00150610 5 -6.323402E-12,0.0,0.0,0.0, 00150620 6 4.0,100.0,800.0,30.28987,-3.658438E-3,-2.600385E-6,4.86326E-9, 00150630 6 -6.323402E-12,0.0,0.0,0.0, 00150640 7 4.0,100.0,800.0,30.28987,-3.658438E-3,-2.600385E-6,4.86326E-9, 00150650 7 -6.323402E-12,0.0,0.0,0.0, 00150660 8 0.0,0.0,2500.0,0.01,0.0,0.0,0.0,0.0,0.0,0.0,0.0/ 00150670 ICODE=5 00150680 IF(M.LT.1.OR.M.GT.8)CALL RPZLVZ(M,T,ICODE,8) 00150690 N=COEF(1,M) 00150700 T1=COEF(2,M) 00150710 T2=COEF(3,M) 00150720 IF(T.LT.T1.OR.T.GT.T2)CALL RPZLVZ(M,T,ICODE,1) 00150730 MODUE =COEF(N+4,M) 00150740 IF(N.EQ.0)RETURN 00150750 DO 10 I=1,N 00150760 10 MODUE =MODUE *T+COEF(N-I+4,M) 00150770 RETURN 00150780 END 00150790 DOUBLE PRECISION FUNCTION MODUE (T,M) 00150250 IMPLICIT REAL*8(A-H,O-Z) 00150260 COMMON/MATL/MATLCO 00150270 DATA NHIGH/4HHIGH/ 00150280 IF(MATLCO.NE.NHIGH)GO TO 10 00150290 CALL MODUE2 (T,M,X) 00150300 MODUE=X*1.0D6 00150310 RETURN 00150320 10 CALL MODUE1 (T,M,X) 00150330 MODUE=X*1.0D6 00150340 RETURN 00150350 END 00150360 SUBROUTINE PRATO1 (T,M,PRATO ) 00175250 IMPLICIT REAL*8(A-H,O-Z) 00175260 IF(M.LT.1.OR.M.GT.15) GO TO 1000 00175270 GO TO(841,842,843,844,845,846,847,848,849,850,851,852,853,854,855)00175280 1,M 00175290 841 PRATO = 0.3 00175300 RETURN 00175310 842 PRATO = 0.3 00175320 RETURN 00175330 843 PRATO = 0.3 00175340 RETURN 00175350 844 PRATO = 0.3 00175360 RETURN 00175370 845 PRATO = 0.3 00175380 RETURN 00175390 846 PRATO = 0.3 00175400 RETURN 00175410 847 PRATO = 0.3 00175420 RETURN 00175430 848 PRATO = 0.3 00175440 RETURN 00175450 849 PRATO = 0.0 00175460 RETURN 00175470 850 PRATO = 0.0 00175480 RETURN 00175490 851 PRATO = 0.3 00175500 RETURN 00175510 852 PRATO = 0.3 00175520 RETURN 00175530 853 PRATO = 0.0 00175540 RETURN 00175550 854 PRATO = 0.0 00175560 RETURN 00175570 855 PRATO = 0.0 00175580 RETURN 00175590 1000 WRITE(6,1010) M 00175600 1010 FORMAT(1X ,88HERROR--YOU HAVE ENTERED MATERIAL PROPERTY ROUTINE PR00175610 1ATO WITH A MATERIAL CODE NUMBER OF ,I5,1H./8X,74HONLY VALUES BETW00175620 2EEN 1 AND 15 ARE VALID. CHECK YOUR INPUT, JOB TERMINATED.) 00175630 RETURN 00175640 END 00175650 SUBROUTINE PRATO2(T,M,PRATO) 00175660 IMPLICIT REAL*8(A-H,O-Z) 00175670 DIMENSION COEF(11,8) 00175680 DATA COEF/ 00175690 1 3.0,100.0,1500.0,2.596489E-1,6.268223E-5,-2.928358E-8, 00175700 1 1.156704E-11,0.0,0.0,0.0,0.0, 00175710 2 1.0,100.0,1500.0,2.624811E-1,4.265787E-5,0.0,0.0,0.0,0.0,0.0,0.0,00175720 3 0.0,32.0,2500.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0, 00175730 4 3.0,75.0,1600.0,2.867834E-1,5.339406E-5,-8.19186E-10, 00175740 4 4.805192E-12,0.0,0.0,0.0,0.0, 00175750 5 0.0,100.0,800.0,0.3,0.0,0.0,0.0,0.0,0.0,0.0,0.0, 00175760 6 0.0,100.0,800.0,0.3,0.0,0.0,0.0,0.0,0.0,0.0,0.0, 00175770 7 0.0,100.0,800.0,0.3,0.0,0.0,0.0,0.0,0.0,0.0,0.0, 00175780 8 0.0,0.0,2500.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0/ 00175790 ICODE=7 00175800 IF(M.LT.1.OR.M.GT.8)CALL RPZLVZ(M,T,ICODE,8) 00175810 N=COEF(1,M) 00175820 T1=COEF(2,M) 00175830 T2=COEF(3,M) 00175840 IF(T.LT.T1.OR.T.GT.T2)CALL RPZLVZ(M,T,ICODE,1) 00175850 PRATO =COEF(N+4,M) 00175860 IF(N.EQ.0)RETURN 00175870 DO 10 I=1,N 00175880 10 PRATO =PRATO *T+COEF(N-I+4,M) 00175890 RETURN 00175900 END 00175910 SUBROUTINE RPZLVZ(MCODE,TEMP,PCODE,ECODE) 00216460 IMPLICIT REAL*8(A-H,O-Z) 00216470 INTEGER PROP(2,10),PCODE,ECODE 00216480 DATA PROP/4HCOND,4HT ,4HSPHT,4H ,4HDENS,4H ,4HALPH,4HZM ,00216490 X 4HMODU,4HE ,4HYDST,4HR ,4HPRAT,4HO ,4HBIYL,4HD ,00216500 X 4HPLAS,4HTC ,4HHBIY,4HLD / 00216510 IF(ECODE.GT.1)GO TO 10 00216520 RETURN 00216530 10 WRITE(6,30)(PROP(I,PCODE),I=1,2),MCODE,ECODE,TEMP 00216540 RETURN 00216550 20 FORMAT(//,68H **** WARNING - YOU HAVE ENTERED THE LMFBR MARERIAL L00216560 2IBRARY ROUTINE ,2A4,18HWITH A TEMPERATURE,F7.0,20H OUT OF VALID RA00216570 3NGE.,/,42H PLEASE CHECK YOUR INPUT. MATERIAL CODE =,I3,/) 00216580 30 FORMAT(//,66H **** ERROR - YOU HAVE ENTERED THE LMFBR MATERIAL LIB00216590 2RARY ROUTINE ,2A4,23HWITH A MATERIAL CODE OF,I5,/,20HONLY CODES 1 00216600 3THROUGH,I3,43H ARE VALID. JOB TERMINATED. TEMPERATURE =,F7.0,/) 00216610 END 00216620 SUBROUTINE POSINV (A,NMAX,NDD) 00174950 IMPLICIT REAL*8 (A-H,O-Z) 00174960 DIMENSION A(NDD,NDD) 00174970 DO 150 N=1,NMAX 00174980 D=A(N,N) 00174990 DO 100 J=1,NMAX 00175000 100 A(N,J)=-A(N,J)/D 00175010 DO 140 I=1,NMAX 00175020 IF(N-I) 110,140,110 00175030 110 DO 130 J=1,NMAX 00175040 IF(N-J) 120,130,120 00175050 120 A(I,J)=A(I,J)+A(I,N)*A(N,J) 00175060 130 CONTINUE 00175070 140 A(I,N)=A(I,N)/D 00175080 A(N,N)=1.0E0/D 00175090 150 CONTINUE 00175100 RETURN 00175110 END 00175120 DOUBLE PRECISION FUNCTION PRATO (T,M) 00175130 IMPLICIT REAL*8(A-H,O-Z) 00175140 COMMON/MATL/MATLCO 00175150 DATA NHIGH/4HHIGH/ 00175160 IF(MATLCO.NE.NHIGH)GO TO 10 00175170 CALL PRATO2 (T,M,X) 00175180 PRATO=X 00175190 RETURN 00175200 10 CALL PRATO1 (T,M,X) 00175210 PRATO=X 00175220 RETURN 00175230 END 00175240 SUBROUTINE SUPSTF(NSELEM,PROP6,ID,LM,LL,NUMNP,MTOT,MBAND,MAXDF ) 00286490 IMPLICIT REAL*8(A-H,O-Z) 00286500 REAL*8 LM(1),ID(NUMNP,3),JD 00286510 LOGICAL ELPRT,ELPCH,GENPRT,GENPCH 00286520 DIMENSION PROP6(LL,7) 00286530 COMMON/QTSARG/ NOD(1000),RRQTSA(500) R0286540 COMMON /CG/ SCG(4),RRCG(2) R0286550 COMMON/CTL/ELPRT,ELPCH,GENPRT,GENPCH 00286560 COMMON/FORCE/NLC,NELD 00286570 COMMON/MASS/LMASS 00286580 COMMON /TRASH/JD(100,3),KCF,KP,KAX,KAY,KAZ,KT,KM,LT,NWDS,L,I,J,K 00286590 $KN,ND,NDF,KS,KE,JR,IR,IC,JC,KC,LC,NDL,JM1,IK,JK,KJ,KI,NDIF,IM1,IP100286600 & ,RRTRAS(174) R0286601 COMMON /JUNK/ PM,T,TYPE,TIME,W,WX,EMAX,RRJUNK(220) R0286610 COMMON /PREP/ ZD(2),KSKIP,RRPREP(8) R0286620 CALL FILES(2) 00286630 NT2=1 00286640 NT1=2 00286650 MAXDF=0 00286660 MAX=MTOT-3*NUMNP-7*LL 00286670 NSE=16 00286680 NT20=20 00286690 ZER=0.0 00286700 REWIND NSE 00286710 DO 1000 L=1,NSELEM 00286720 READ (NSE) MATNO,NUM,(NOD(J),J=1,NUM) 00286730 REWIND NT20 00286740 200 READ (NT20,END=9000)M,NDF,KT,LT 00286750 205 CONTINUE 00286760 IF(M.EQ.MATNO) GO TO 210 00286770 LT=LT+2 00286780 IF(LMASS.EQ.1) LT=LT+1 00286790 DO 206 J=1,LT 00286800 206 READ (NT20) 00286810 GO TO 200 00286820 210 ND=NDF 00286830 NDM=ND-1 00286840 NWDS=ND+(ND*ND-ND)/2 00286850 IF(LMASS.EQ.1) GO TO 1210 00286860 IF(NWDS.LE.MAX) GO TO 230 00286870 GO TO 215 00286880 1210 IF(2*NWDS.LE.MAX) GO TO 230 00286890 215 WRITE(6,220)M,L 00286900 220 FORMAT (/20X,6HMATRIX,I4,20H ON SUPERELEMENT NO.,I4, 00286910 $47H IS TOO LARGE FOR THE AMOUNT OF CORE AVAILABLE.//) 00286920 KSKIP=1 00286930 RETURN 00286940 230 KN=KT 00286950 IF(KT.EQ.0) KN=1 00286960 KS=ND+1 00286970 KE=KS+NWDS-1 00286980 READ (NT20) KCF,KP,KAX,KAY,KAZ,KM,KBE,((JD(J,K),K=1,3),J=1,KN) 00286990 READ (NT20) 00287000 $ (LM(J),J=KS,KE) 00287010 240 JLOCI=KE 00287020 LC=0 00287030 NTERM=ND*(LL+1) 00287040 IF(LMASS.EQ.1) NTERM=NTERM+JLOCI 00287050 IF(JLOCI+NTERM.GT.MAX) GO TO 215 00287060 JLOC=JLOCI+1 00287070 CALL QVSET(ZER,LM(JLOC),NTERM) 00287080 IF(KCF.LE.0) GO TO 260 00287090 DO 250 J=1,KCF 00287100 KS=JLOCI+(J-1)*ND+1 00287110 KE=KS+NDM 00287120 250 READ (NT20) (LM(K),K=KS,KE) 00287130 260 CONTINUE 00287140 IF(KCF.EQ.LT) GO TO 390 00287150 LC=KCF 00287160 270 LC=LC+1 00287170 IF(LC.GT.LT) GO TO 390 00287180 IF(KM.EQ.LC) GO TO 280 00287190 IF(KP.EQ.LC) GO TO 290 00287200 IF(KAX.EQ.LC) GO TO 310 00287210 IF(KAY.EQ.LC) GO TO 330 00287220 IF(KAZ.EQ.LC) GO TO 350 00287230 IF(KBE.EQ.LC) GO TO 361 00287240 IF(KT.EQ.0) GO TO 276 00287250 DO 275 K=1,KT 00287260 KE=K 00287270 KS=JD(K,1) 00287280 IF(KS.EQ.LC) GO TO 370 00287290 275 CONTINUE 00287300 276 READ (NT20) 00287310 GO TO 270 00287320 280 CONTINUE 00287330 KS=JLOCI+ND*LL+1 00287340 KE=KS+NDM 00287350 READ (NT20) (LM(K),K=KS,KE) 00287360 GO TO 270 00287370 290 READ (NT20)(LM(K),K=1,ND) 00287380 DO 300 K=1,LL 00287390 PM=-PROP6(K,1) 00287400 IF(PM.EQ.0.0) GO TO 300 00287410 KS=JLOCI+ND*(K-1)+1 00287420 CALL QMR2(LM(KS),LM(KS),PM,LM(1),ND,1,1,1) 00287430 300 CONTINUE 00287440 GO TO 270 00287450 310 READ (NT20)(LM(K),K=1,ND) 00287460 DO 320 K=1,LL 00287470 PM=-PROP6(K,5) 00287480 IF(PM.EQ.0.0) GO TO 320 00287490 KS=JLOCI+ND*(K-1)+1 00287500 CALL QMR2(LM(KS),LM(KS),PM,LM(1),ND,1,1,1) 00287510 320 CONTINUE 00287520 GO TO 270 00287530 330 READ (NT20)(LM(K),K=1,ND) 00287540 DO 340 K=1,LL 00287550 PM=-PROP6(K,6) 00287560 IF(PM.EQ.0.0) GO TO 340 00287570 KS=JLOCI+ND*(K-1)+1 00287580 CALL QMR2(LM(KS),LM(KS),PM,LM(1),ND,1,1,1) 00287590 340 CONTINUE 00287600 GO TO 270 00287610 350 READ (NT20)(LM(K),K=1,ND) 00287620 DO 360 K=1,LL 00287630 PM=-PROP6(K,7) 00287640 IF(PM.EQ.0.0) GO TO 360 00287650 KS=JLOCI+ND*(K-1)+1 00287660 CALL QMR2(LM(KS),LM(KS),PM,LM(1),ND,1,1,1) 00287670 360 CONTINUE 00287680 GO TO 270 00287690 361 READ (NT20) (LM(K),K=1,ND) 00287700 DO 365 K=1,LL 00287710 PM=-PROP6(K,4) 00287720 IF(PM.EQ.0.0) GO TO 365 00287730 KS=JLOCI+ND*(K-1)+1 00287740 CALL QMR2(LM(KS),LM(KS),PM,LM(1),ND,1,1,1) 00287750 365 CONTINUE 00287760 GO TO 270 00287770 370 READ (NT20)(LM(K),K=1,ND) 00287780 TIME=JD(KE,3) 00287790 TYPE=JD(KE,2) 00287800 DO 380 K=1,LL 00287810 PM=PROP6(K,2) 00287820 IF(PM.NE.TYPE)GO TO 380 00287830 PM=PROP6(K,3) 00287840 IF(PM.NE.TIME)GO TO 380 00287850 KS=JLOCI+ND*(K-1)+1 00287860 PM=-1.0 00287870 CALL QMR2(LM(KS),LM(KS),PM,LM(1),ND,1,1,1) 00287880 380 CONTINUE 00287890 GO TO 270 00287900 390 CONTINUE 00287910 IF(LMASS.NE.1) GO TO 1390 00287920 KS=JLOCI+ND*LL+1 00287930 KE=KS+NWDS-1 00287940 READ(NT20)(LM(K),K=KS,KE) 00287950 1390 CONTINUE 00287960 JM1=JLOCI+NDF*LL 00287970 ND=0 00287980 DO 405 J=1,NUM 00287990 NODE=NOD(J) 00288000 KN=0 00288010 DO 400 K=1,6 00288020 CALL UNPKID(ID,NUMNP,W,WX,2,NODE,K) 00288030 IF(W.LE.0.0) GO TO 400 00288040 ND=ND+1 00288050 IF(K.GT.3) GO TO 395 00288060 JC=JM1+ND 00288070 IF(LMASS.EQ.1) JC=JM1+ND*(ND+1)/2 00288080 IF(LM(JC).EQ.0.0) GO TO 395 00288090 CALL UNPKID(ID,NUMNP,WX,T,1,NODE,K) 00288100 SCG(K)=SCG(K)+LM(JC)*T 00288110 IF(KN.EQ.0) SCG(4)=SCG(4)+LM(JC) 00288120 KN=1 00288130 395 CONTINUE 00288140 IF(ND.GT.NDF) GO TO 410 00288150 LM(ND)=W 00288160 400 CONTINUE 00288170 405 CONTINUE 00288180 IF(ND.EQ.NDF) GO TO 430 00288190 410 WRITE(6,420)M,NDF,L,ND 00288200 420 FORMAT(/20X,9HMATRIX NO,I4,4H HAS,I4, 00288210 127H DEGREES-OF-FREEDOM AND THE,1X, 00288220 $32HNODES LISTED FOR SUPERELEMENT NO,I4/20X,5H HAVE,I4,5H DOF.//) 00288230 KSKIP=1 00288240 430 CONTINUE 00288250 PM=LM(ND+1) 00288260 T =LM(ND+2) 00288270 LM(ND+1)=MATNO 00288280 LM(ND+2)=ND 00288290 KOUNT=ND+2 00288300 CALL RDWRT(NT2,LM,KOUNT,1,K) 00288310 LM(ND+1)=PM 00288320 LM(ND+2)=T 00288330 I=ND 00288340 NDP=ND+1 00288350 440 EMAX=LM(1) 00288360 J=1 00288370 DO 450 K=1,I 00288380 IF(LM(K).LT.EMAX) GO TO 450 00288390 EMAX=LM(K) 00288400 J=K 00288410 450 CONTINUE 00288420 IF(I.EQ.J) GO TO 490 00288430 IC=I*ND+I-(I*I-I)/2 00288440 JC=J *ND+J-(J*J-J)/2 00288450 JM1=J-1 00288460 IF(JM1.LT.1) GO TO 460 00288470 IK=ND+I 00288480 JK=ND+J 00288490 DO 455 K=1,JM1 00288500 T=LM(IK) 00288510 LM(IK)=LM(JK) 00288520 LM(JK)=T 00288530 NDK=ND-K 00288540 IK=IK+NDK 00288550 455 JK=JK+NDK 00288560 460 JP1=J+1 00288570 IM1=I-1 00288580 IF(JP1.GT.IM1) GO TO 470 00288590 KJ=JC 00288600 IK=KJ+I-J 00288610 DO 465 K=JP1,IM1 00288620 IK=IK+NDP-K 00288630 KJ=KJ+1 00288640 T=LM(KJ) 00288650 LM(KJ)=LM(IK) 00288660 465 LM(IK)=T 00288670 470 IP1=I+1 00288680 IF(IP1.GT.ND) GO TO 478 00288690 KJ=JC+I-J 00288700 KI=IC 00288710 DO 475 K=IP1,ND 00288720 KJ=KJ+1 00288730 KI=KI+1 00288740 T=LM(KI) 00288750 LM(KI)=LM(KJ) 00288760 475 LM(KJ)=T 00288770 478 T=LM(I) 00288780 LM(I)=LM(J) 00288790 LM(J)=T 00288800 T=LM(IC) 00288810 LM(IC)=LM(JC) 00288820 LM(JC)=T 00288830 IR=JLOCI+I 00288840 JR=JLOCI+J 00288850 DO 480 K=1,LL 00288860 KC=(K-1)*ND 00288870 IK=IR+KC 00288880 JK=JR+KC 00288890 T=LM(IK) 00288900 LM(IK)=LM(JK) 00288910 480 LM(JK)=T 00288920 IF(LMASS.EQ.1) GO TO 1450 00288930 IR=JLOCI+ND*LL+I 00288940 JR=JLOCI+ND*LL+J 00288950 T=LM(IR) 00288960 LM(IR)=LM(JR) 00288970 LM(JR)=T 00288980 GO TO 490 00288990 1450 CONTINUE 00289000 IC=JLOCI+ND*LL+(I-1)*ND+I-(I*I-I)/2 00289010 JC=JLOCI+ND*LL+(J-1)*ND+J-(J*J-J)/2 00289020 JM1=J-1 00289030 IF(JM1.LT.1) GO TO 1460 00289040 IK=JLOCI+ND*LL+I 00289050 JK=JLOCI+ND*LL+J 00289060 DO 1455 K=1,JM1 00289070 T=LM(IK) 00289080 LM(IK)=LM(JK) 00289090 LM(JK)=T 00289100 NDK=ND-K 00289110 IK=IK+NDK 00289120 1455 JK=JK+NDK 00289130 1460 JP1=J+1 00289140 IM1=I-1 00289150 IF(JP1.GT.IM1) GO TO 1470 00289160 KJ=JC 00289170 IK=KJ+I-J 00289180 DO 1465 K=JP1,IM1 00289190 IK=IK+NDP-K 00289200 KJ=KJ+1 00289210 T=LM(KJ) 00289220 LM(KJ)=LM(IK) 00289230 1465 LM(IK)=T 00289240 1470 IP1=I+1 00289250 IF(IP1.GT.ND) GO TO 1478 00289260 KJ=JC+I-J 00289270 KI=IC 00289280 DO 1475 K=IP1,ND 00289290 KJ=KJ+1 00289300 KI=KI+1 00289310 T=LM(KI) 00289320 LM(KI)=LM(KJ) 00289330 1475 LM(KJ)=T 00289340 1478 CONTINUE 00289350 T=LM(IC) 00289360 LM(IC)=LM(JC) 00289370 LM(JC)=T 00289380 490 I=I-1 00289390 IF(I.GT.0) GO TO 440 00289400 NDIF=LM(ND)-LM(1)+1 00289410 IF(NDIF.GT.MBAND) MBAND=NDIF 00289420 IF(ND.GT.MAXDF) MAXDF=ND 00289430 IF(.NOT.ELPRT) GO TO 1600 00289440 WRITE(6,660)MATNO,ND 00289450 IF(ELPCH) WRITE(7,680)MATNO,ND 00289460 WRITE(6,670)(LM(I),I=1,ND) 00289470 IF(ELPCH)WRITE(7,690)(LM(I),I=1,ND) 00289480 WRITE(6,770) 00289490 IK=0 00289500 DO 1510 I=1,ND 00289510 JJ=ND-I+1 00289520 IF(ELPCH) WRITE(7,780)(LM(ND+IK+J),J=1,JJ) 00289530 WRITE(6,790)(LM(ND+IK+J),J=1,JJ) 00289540 1510 IK=IK+JJ 00289550 INLL=8 00289560 IF(LL.LT.8) INLL=LL 00289570 DO 1520 J=1,LL,INLL 00289580 K=J+INLL-1 00289590 WRITE(6,720)J,K 00289600 JK=(J-1)*ND+JLOCI 00289610 DO 1540 I=1,ND 00289620 IK=JK+I-1 00289630 IKK=INLL*ND 00289640 IF(ELPCH) WRITE(7,780)(LM(IK+LRK),LRK=1,IKK,ND) 00289650 1540 WRITE(6,790)(LM(IK+LRK),LRK=1,IKK,ND) 00289660 1520 CONTINUE 00289670 IK=JLOCI+ND*LL 00289680 IF(LMASS.NE.1) GO TO 1570 00289690 WRITE(6,730) 00289700 DO 1560 I=1,ND 00289710 JJ=ND-I+1 00289720 IF(ELPCH) WRITE(7,780)(LM(IK+J),J=1,JJ) 00289730 WRITE(6,790)(LM(IK+J),J=1,JJ) 00289740 1560 IK=IK+JJ 00289750 GO TO 1600 00289760 1570 CONTINUE 00289770 WRITE(6,740) 00289780 IF(ELPCH) WRITE(7,780)(LM(IK+J),J=1,ND) 00289790 WRITE(6,790)(LM(IK+J),J=1,ND) 00289800 1600 CONTINUE 00289810 KJ=LL 00289820 IF(NELD.EQ.1) GO TO 510 00289830 KJ=0 00289840 IF(LMASS.EQ.1) GO TO 1680 00289850 DO 500 I=1,ND 00289860 IR=JLOCI+I 00289870 JR=IR+ND*LL 00289880 500 LM(IR)=LM(JR) 00289890 GO TO 510 00289900 1680 KL=0 00289910 DO 1690 I=1,ND 00289920 DO 1690 J=I,ND 00289930 KL=KL+1 00289940 IR=JLOCI+KL 00289950 JR=IR+ND*LL 00289960 1690 LM(IR)=LM(JR) 00289970 510 KOUNT=JLOCI+ND*(KJ+1)+1 00289980 IF(LMASS.EQ.1) KOUNT=JLOCI+ND*KJ+ND*(ND+1)/2 +1 00289990 LM(KOUNT)=ND 00290000 1000 CALL RDWRT(NT1,LM,KOUNT,1,I) 00290010 RETURN 00290020 660 FORMAT(5X,11HMATRIX NO =,I4,5X,20HDEGREES OF FREEDOM =,I4) 00290030 670 FORMAT(/1X,29HSUPER ELEMENT LOCATION MATRIX/(1H ,10F13.0)) 00290040 680 FORMAT(2I5) 00290050 690 FORMAT((1P8E10.3)) 00290060 720 FORMAT(/1X,32HELEMENT LOAD MATRIX - LOAD CASES,I5,3X,2HTO,I5) 00290070 730 FORMAT(/1X,41HELEMENT MASS MATRIX - LOWER TRIANGLE ONLY) 00290080 740 FORMAT(/1X,19HELEMENT MASS MATRIX) 00290090 770 FORMAT(/1X,30HSUPER ELEMENT STIFFNESS MATRIX, 00290100 11X,21H- LOWER TRIANGLE ONLY) 00290110 780 FORMAT((1P8E10.3)) 00290120 790 FORMAT((1X ,1P10E13.4)) 00290130 9000 WRITE(6,9010) MATNO,NT20,L 00290140 9010 FORMAT(//20X,6HMATRIX ,I5,27H COULD NOT BE FOUND ON TAPE,I5, 00290150 $21H FOR SUPERELEMENT NO.,I5//) 00290160 KSKIP=1 00290170 RETURN 00290180 END 00290190