Liren Large Software Subsidy 9

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

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

Wrap

Text File | 1987-04-15 | 54.9 KB | 686 lines

SUBROUTINE RENUM(NX,IES) 00205630 IMPLICIT REAL*8 (A-H,O-Z) 00205640 REAL*8 NPAR 00205650 COMMON/ELPAR/NPAR(14),NUMNP,II(7),MTOT,I2(6),NUMEL,NUMEL2 00205660 & ,NRELPA(41) R0205661 COMMON /BAND/ NRNM(3),ICRIT,NRBAND(4) R0205670 COMMON/SLVE/NSLAVE 00205690 COMMON/SIZE/NDMX,MXDF,NSMX,NTERM,NADND 00205700 COMMON /TRASH/ X(30),RRTRAS(460) R0205710 COMMON /SUPEL/ LDUM(4),NEADD,NRSUPE R0205720 COMMON/PREP/XMX,XAD,KSKIP,NDYN,I1,RRPREP(7) R0205730 COMMON/FORCE/ NLC,NELD R0205740 COMMON /A/ MAXGRD,MAXDEG,NRMAXG(3) R0205750 COMMON /S/NN,MM 00205760 COMMON /BITS/ NBITIN 00205770 COMMON /ZERO/ KT 00205780 COMMON A(1) 00205790 CALL FILES(21) 00205800 MULT=4 00205810 IF(KSKIP.EQ.1) RETURN 00205820 CALL SECOND(T1) 00205830 NC=IABS(NX) 00205840 M2=600 00205850 IF(NRNM(3).GT.9.AND.NRNM(3).LT.9500) M2=NRNM(3) 00205860 MTEF= MTOT*MULT 00205870 M2I=M2 00205880 NK=0 00205890 50 NK=NK+1 00205900 M2=M2I*NK 00205910 NBITIN=15 00205920 NWORDS=M2+NUMNP*7+NC*MULT*(NUMNP+MULT)/4 00205930 IF(NRNM(2).EQ.2) NWORDS=MTEF 00205940 N=NUMNP 00205950 II1=NUMNP 00205960 IF(N.LT.100) N=100 00205970 N=N+3 00205980 N=N-MOD(N,4) 00205990 MAXGRD=N 00206000 IIR=N/MULT 00206010 IF(MULT.EQ.1)IIR=NUMNP 00206020 MAXDEG=NC 00206030 IF(NWORDS.GT.MTEF) WRITE(6,100) 00206040 IF(NWORDS.GT.MTEF) KSKIP=1 00206050 IF(NWORDS.GT.MTEF) RETURN 00206060 100 FORMAT (/20X, 95HFOR THE GIVEN NO. OF NODES THERE IS NOT ENOUGH ST00206070 $ORAGE ALLOCATED -- NO MINIMIZATION IS ALLOWED.//) 00206080 IF(KSKIP.EQ.10) GO TO 9105 00206090 N2=1+NUMEL*13 00206100 NZ=NTERM 00206110 IF(NZ.EQ.0) NZ=1 00206120 CALL ELORD(A(1),NUMEL,NUMEL2,NZ,NADND,A(N2)) 00206130 ND=(NUMNP+MULT)/MULT 00206140 N1=1 00206150 N2=N1+ND 00206160 CCR IF(NRNM(2).EQ.2) CALL RENRST(A(N1),NUMNP,KT) R0206170 CCR IF(NRNM(2).EQ.2) GO TO 106 R0206180 DO 105 I=1,MTOT 00206190 105 A(I)=0.0 00206200 CALL CONECT(A(N2),NUMNP,NUMEL,I1,KSKIP,NC,X(1),NZ,NADND,II1) 00206210 IF(KSKIP.EQ.1) RETURN 00206220 N3=N2+IIR*NC 00206230 N4=N3+ND 00206240 N5=N4+ND 00206250 N6=N5+ND 00206260 N7=N6+ND 00206270 N8=N7+ND 00206280 N9=N8+ND 00206290 IF(NRNM(3).LT.9000) GO TO 9105 00206300 CALL SETNOD(A(N2),II1,A(N3),NUMNP,A(N1),KT,I1) 00206310 GO TO 106 00206320 9105 CONTINUE 00206330 IF(KSKIP.EQ.10) KSKIP=0 00206340 KDIM=M2/4 00206350 N10=N9+KDIM 00206360 N11=N10+KDIM 00206370 N12=N11+KDIM 00206380 N13=N12+KDIM/2 00206390 MM=NC 00206400 NN=NUMNP 00206410 CALL GIBSTK(A(N2),II1,A(N7),A(N1),A(N4),A(N3),A(N5),A(N6),A(N8), 00206420 $ICRIT,A(N9),A(N10),A(N11),A(N12),A(N13),KDIM) 00206430 IF (KSKIP.EQ.1) KSKIP=10 00206440 IF(KSKIP.EQ.10) GO TO 50 00206450 106 CONTINUE 00206460 IF(NRNM(3).LT.0) CALL SETNOD(A(N2),II1,A(N3),NUMNP,A(N1),KT,I1) 00206470 N3=N2+NUMNP*3 00206480 NSLDM=NSLAVE 00206490 IF(NSLDM.EQ.0) NSLDM=1 00206500 CALL NODORD(A(N2),NUMNP,A(N1),KT,I1,A(N3),NSLDM) 00206510 NUMEL=NUMEL-NEADD 00206520 N3=N2+NUMEL*13 00206530 N4=N3+NZ*NADND 00206540 N5=N4+NADND 00206550 IF(N5.GT.MTOT) CALL ERROR(N5-MTOT) 00206560 CALL ELRORD(A(N2),NUMEL,NUMEL2,A(N1),NUMNP,I1,A(N3),A(N4),NZ,NADND00206570 $) 00206580 IF(IES.NE.0)CALL FGNORD(NUMNP,A(N1),IES) 00206590 N3=N2+NLC*6 00206600 IF(NLC.GT.0) CALL LDRORD(A(N1),A(N2),A(N3),NUMNP,NLC) 00206610 CALL RORD(A(N1),A(N2),NUMNP) 00206620 NTERM=NTERM-NEADD 00206630 CALL SECOND(T2) 00206640 T2=T2-T1 00206650 WRITE(6,110)T2 00206660 110 FORMAT(///20X,F8.2, 53H SECONDS WERE REQUIRED TO REDUCE THE MODELS00206670 $ BANDWIDTH//) 00206680 RETURN 00206690 END 00206700 SUBROUTINE ELORD(ID2,NUMEL,NUMEL2,NZ,NADND,ID4) 00079580 IMPLICIT REAL*8(A-H,O-Z) 00079590 REAL*8 ID2,ID3 00079600 REAL*8 ID4 00079610 DIMENSION ID2(NUMEL,13),ID3(9) 00079620 DIMENSION ID4(NZ,NADND) 00079630 REWIND 4 00079640 READ (4) ((ID2(I,J),J=1,13),I=1,NUMEL ) 00079650 IF(NZ.EQ.NUMEL) READ (4) ((ID4(I,J),J=1,NADND),I=1,NUMEL) 00079660 REWIND 17 00079670 DO 100 I=1,NUMEL 00079680 WRITE (17) (ID2(I,J),J=1,13) 00079690 IF(NZ.EQ.NUMEL) WRITE (17)(ID4(I,J),J=1,NADND) 00079700 100 CONTINUE 00079710 CALL SEORD(NUMEL,NADND,ID4) 00079720 IF(NUMEL2.EQ.0) RETURN 00079730 REWIND 9 00079740 DO 110 I=1,NUMEL2 00079750 READ (9) ID3 00079760 WRITE (17) ID3 00079770 110 CONTINUE 00079780 RETURN 00079790 END 00079800 SUBROUTINE SEORD(NUMEL,NADND,A) 00234320 IMPLICIT REAL*8(A-H,O-Z) 00234330 DIMENSION A(NADND),EEAD(13) 00234340 COMMON /PREP/XMX,XAD,IDUM(2),I1,RRPREP(7) R0234350 COMMON /SUPEL/ NSELEM,NEQL,NODESE,MATNO,NEADD,NRSUPE R0234360 COMMON/TRASH/EAD(5),NOD(450),NUM,I,IX(8),N,NI,J,NF,II,NL,RRTR(252)R0234370 COMMON /SIZE/ NDMX,MXDF,NSMX,NZ,NRRND R0234380 NEADD=0 00234390 EAD(5)=500000000. 00234400 IF(NSELEM.EQ.0) RETURN 00234410 DO 10 I=1,12 00234420 10 EEAD(I)=0. 00234430 EEAD(13)=5. 00234440 NSE=16 00234450 NE=17 00234460 REWIND NSE 00234470 DO 130 I=1,NSELEM 00234480 READ(NSE) MAT,NUM,(NOD(J),J=1,NUM) 00234490 IF(NUM.EQ.1) GO TO 130 00234500 N=1 00234510 NI=2 00234520 90 DO 100 J=1,8 00234530 100 IX(J)=0 00234540 NF=NI+6 00234550 IF(NF.GT.NUM) NF=NUM 00234560 II=0 00234570 DO 110 J=NI,NF 00234580 II=II+1 00234590 110 IX(II)=NOD(J) 00234600 NL=N 00234610 IF(NF.EQ.NUM) NL=1 00234620 IX(II+1)=NOD(NL) 00234630 DO 120 J=1,8 00234640 120 EEAD(J)=IX(J) 00234650 NEADD=NEADD+1 00234660 NI=NF 00234670 N=N+1 00234680 WRITE (NE)EEAD 00234690 IF(NZ.GT.1) WRITE (NE) A 00234700 IF(NF.LT.NUM) GO TO 90 00234710 130 CONTINUE 00234720 NUMEL=NUMEL+NEADD 00234730 RETURN 00234740 END 00234750 SUBROUTINE CONECT(IG,NUMNP,NUMEL,I1,KSKIP,NC,ID4,NZ,NADND,II1) 00050420 IMPLICIT REAL*8(A-H,O-Z) 00050430 INTEGER*2 IG 00050440 REAL*8 ID4 00050450 REAL*8 ID2 00050460 INTEGER T,ZM 00050470 DIMENSION ID4(NADND) 00050480 DIMENSION ID2(13),IG(II1,1) ,IX(8) 00050490 COMMON/ELARRY/NELAR(4,20) 00050500 COMMON /TRASH/ Z(30),IA(100),RRTRAS(410) R0050510 ZM=10000 00050520 KM=100000000 00050530 KN=10000 00050540 DO 100 I=1,NUMNP 00050550 DO 100 J=1,NC 00050560 100 IG(I,J)=0 00050570 REWIND 17 00050580 DO 230 I=1,NUMEL 00050590 READ (17)ID2 00050600 DO 110 J=1,8 00050610 NN=ID2(J) 00050620 110 IA(J)= NN 00050630 MT=ID2(13) 00050640 IF(NZ.LE.1) GO TO 130 00050650 READ (17) ID4 00050660 DO 120 J=1,NADND 00050670 T= ID4(J) 00050680 IA(J+8)=T 00050690 120 CONTINUE 00050700 130 CONTINUE 00050710 IF(MT.EQ.7) GO TO 230 00050720 NODES=NELAR(2,MT) 00050730 NODESM=NODES-1 00050740 IF(IA(NODES).GT.NUMNP) GO TO 240 00050750 DO 220 J=1,NODESM 00050760 NN=IA(J) 00050770 IF(NN.GT.NUMNP) GO TO 240 00050780 IF(NN.EQ.0) GO TO 220 00050790 JP1=J+1 00050800 DO 210 K=JP1,NODES 00050810 MM=IA(K) 00050820 IF(MM.EQ.0) GO TO 210 00050830 IF(MM.EQ.NN) GO TO 210 00050840 DO 140 K1=1,NC 00050850 IF(MM.EQ.IG(NN,K1)) GO TO 200 00050860 K2=K1 00050870 IF(IG(NN,K1).EQ.0) GO TO 170 00050880 140 CONTINUE 00050890 150 WRITE(6,160) 00050900 160 FORMAT (/20X,42H NC IN SUBROUTINE RENUM MUST BE INCREASED./) 00050910 KSKIP=1 00050920 RETURN 00050930 170 IG(NN,K2)=MM 00050940 DO 180 K1=1,NC 00050950 K2=K1 00050960 IF(IG(MM,K1).EQ.0) GO TO 190 00050970 180 CONTINUE 00050980 GO TO 150 00050990 190 IG(MM,K2)=NN 00051000 200 CONTINUE 00051010 210 CONTINUE 00051020 220 CONTINUE 00051030 230 CONTINUE 00051040 RETURN 00051050 240 WRITE(6,250) 00051060 250 FORMAT(//20X,45HA NODE NO. HAS BEEN FOUND THAT IS LARGER THAN, 00051070 $6H NUMNP//) 00051080 KSKIP=1 00051090 RETURN 00051100 END 00051110 SUBROUTINE SETNOD(IG,II1,ID,NUMNP,ISIR,KT,I1) 00235560 IMPLICIT REAL*8(A-H,O-Z) 00235570 REAL*8 ID(NUMNP,3) 00235580 INTEGER*2 ISIR,IG 00235590 DIMENSION IG(II1,1),ISIR(NUMNP) 00235600 COMMON /SUPEL/NZ(2),NODE,NRSUPE(3) R0235610 COMMON /BAND/ NRNM(2),NSTN,NRBAND(5) R0235620 COMMON /BITS/ NBITIN 00235630 COMMON/TRASH/NSET(450),NDUM(16),RRTRAS(257) R0235640 COMMON/PREP/QD(2),KSKIP,RRPREP(8) R0235650 KX=KT 00235660 IF(NSTN.LT.0) GO TO 125 00235670 KT=0 00235680 REWIND 8 00235690 READ (8) ((ID(I,J),J=1,3),I=1,NUMNP) 00235700 REWIND 8 00235710 DO 110 I=1,NUMNP 00235720 IF(IG(I,1).GT.0) GO TO 110 00235730 DO 100 J=1,3 00235740 NNN=ID(I,J) 00235750 100 ID(I,J)=ID(I,J)-NNN+1.0+I1 00235760 110 CONTINUE 00235770 WRITE (8) ((ID(I,J),J=1,3),I=1,NUMNP) 00235780 DO 120 I=1,NUMNP 00235790 120 ISIR(I)=I 00235800 IF(NSTN.GE.0) RETURN 00235810 125 CONTINUE 00235820 NSTN=IABS(NSTN) 00235830 WRITE(6,130)NSTN,NSTN 00235840 130 FORMAT (/20X,13HTHE FOLLOWING,I5,25H NODES ARE TO BE RETAINED, 00235850 $36H DURING THE SUPERELEMENT FORMULATION/20X,13HTHE NODES ARE, 00235860 $22H RESTACKED AS THE LAST,I5,7H NODES.//) 00235870 MAXN=450 00235880 I=0 00235890 IF(NSTN.GT.MAXN) GO TO 230 00235900 131 READ(5,140)NDUM 00235910 DO 134 J=1,16 00235920 IF(I.GT.NSTN)GO TO 240 00235930 IF(NDUM(J).EQ.0) GO TO 135 00235940 IF(J.EQ.1) GO TO 133 00235950 IF(J.EQ.16.AND.NDUM(16).LT.0) GO TO 240 00235960 IF(NDUM(J-1).LT.0) GO TO 134 00235970 IF(NDUM(J).GT.0) GO TO 133 00235980 KT=NDUM(J+1) 00235990 KI=NDUM(J-1)+KT 00236000 KF=-NDUM(J) 00236010 DO 132 K=KI,KF,KT 00236020 I=I+1 00236030 132 NSET(I)=K 00236040 KT=0 00236050 GO TO 134 00236060 133 I=I+1 00236070 NSET(I)=NDUM(J) 00236080 134 CONTINUE 00236090 135 IF(I.NE.NSTN) GO TO 131 00236100 140 FORMAT (16I5) 00236110 WRITE(6,150)(NSET(I),I=1,NSTN) 00236120 150 FORMAT (/20X,10I5) 00236130 DO 160 I=1,NUMNP 00236140 K=ISIR(I) 00236150 160 ID(K,1)=I 00236160 K=NUMNP-NSTN-KX 00236170 DO 170 I=1,NSTN 00236180 K=K+1 00236190 KF=NSET(I) 00236200 KI=ISIR(KF) 00236210 KT=ID(K,1) 00236220 ISIR(KF)=K 00236230 ISIR(KT)=KI 00236240 ID(KI,1)=KT 00236250 170 ID(K,1) =KF 00236260 KT=KX 00236270 NODE=NSET(1) 00236280 NODE=ISIR(NODE) 00236290 RETURN 00236300 230 WRITE(6,235)NSTN,MAXN 00236310 235 FORMAT(/20X,20HERROR-TOO MANY NODES,I5,11H ALLOWABLE-,I5//) 00236320 GO TO 250 00236330 240 WRITE(6,245)NDUM 00236340 245 FORMAT(/20X,28HERROR ON THE FOLLOWING CARD-/20X,16I5//) 00236350 250 KSKIP=1 00236360 RETURN 00236370 END 00236380 SUBROUTINE GIBSTK(NDSTK,NR,IOLD,RENUM,NDEG,LVL,LVLS1,LVLS2,CCSTOR,00105790 $ICRIT,NHIGH,NLOW,NACUM,SIZE,STPT,IDIM) 00105800 IMPLICIT REAL*8(A-H,O-Z) 00105810 INTEGER*2 CCSTOR,IOLD,NDSTK,LVL,LVLS1,LVLS2,RENUM,NDEG 00105820 INTEGER STNODE,RVNODE,XC,SORT2,STNUM,SIZE,STPT,SBNUM 00105830 CHARACTER*4 METH R0105831 COMMON /ZERO/NZERO 00105840 COMMON /PREP/XDZ(2),KSKIP,RRPREP(8) R0105850 COMMON /S/ NN,MM 00105860 COMMON /A/ MAXGRD,MAXDEG,N,IDPTH,IDEG 00105870 DIMENSION NHIGH(IDIM),NLOW(IDIM),NACUM(IDIM),SIZE(1),STPT(1) 00105880 DIMENSION CCSTOR(1),IOLD(1) 00105890 DIMENSION NDSTK(NR,1),LVL(1),LVLS1(1),LVLS2(1),RENUM(1),NDEG(1) 00105900 INTEGER OBW,OP,XCMAX 00105910 INTEGER SUMW0,SUMSQ0,SUMWB,SUMSQB 00105920 REAL*8 IM1,IM2 00105930 DATA METH/4H GPS/ 00105940 IOU6=6 00105950 XCMAX=IDIM/2 00105960 NCM=0 00105970 N=NN 00105980 IBW2=0 00105990 IPF2=0 00106000 DO 10 I=1,N 00106010 IOLD(I)=I 00106020 RENUM(I)=0 00106030 10 CONTINUE 00106040 CALL DGREE(NDSTK,NR,NDEG,IOLD,IBW1,IPF1) 00106050 CALL WAVEY(NDSTK,NR,IOLD,LVL,0,LVLS2,LVLS1,MAXB0,MAXW0,AVERW0, 00106060 1 SUMW0,SUMSQ0,RMS0) 00106070 MAXWA=MAXW0 00106080 RMSA=RMS0 00106090 WRITE(IOU6,29) 00106100 29 FORMAT( 26H0BEFORE RESEQUENCING - - - ) 00106110 WRITE (IOU6,51) MAXB0,SUMW0,AVERW0,RMS0 00106120 51 FORMAT(10X,19HNODE DIFFERENCE ,I9/10X,13HPROFILE ,I9/ 00106130 $10X,20HAVERAGE NODE DIFF. ,F9.2/ 00106140 $10X,20HRMS NODE DIFFERENCE ,F9.2/ 00106150 $) 00106160 25 CONTINUE 00106170 SBNUM=1 00106180 STNUM=N 00106190 DO 40 I=1,N 00106200 IF(NDEG(I).GT.0) GO TO 40 00106210 RENUM(I)=STNUM 00106220 STNUM=STNUM-1 00106230 40 CONTINUE 00106240 NZERO=N-STNUM 00106250 NCM=NZERO 00106260 50 LOWDG=IDEG+1 00106270 NCM=NCM + 1 00106280 NFLG=1 00106290 ISDIR=1 00106300 DO 70 I=1,N 00106310 IF(NDEG(I).GE.LOWDG) GO TO 70 00106320 IF(RENUM(I).GT.0) GO TO 70 00106330 LOWDG=NDEG(I) 00106340 STNODE=I 00106350 70 CONTINUE 00106360 CALL FNDIAM(STNODE,RVNODE,NDSTK,NR,NDEG,LVL,LVLS1,LVLS2,CCSTOR, 00106370 -IDFLT,NHIGH,IDIM) 00106380 IF(KSKIP.EQ.1) RETURN 00106390 IF(NDEG(STNODE).LE.NDEG(RVNODE)) GO TO 75 00106400 NFLG=-1 00106410 STNODE=RVNODE 00106420 75 CALL RSETUP(LVL,LVLS1,LVLS2,NHIGH,NLOW,NACUM,IDIM) 00106430 IF(KSKIP.EQ.1) RETURN 00106440 XC=0 00106450 LROOT=1 00106460 LVLN=1 00106470 DO 80 I=1,N 00106480 IF(LVL(I).NE.0) GO TO 80 00106490 XC=XC+1 00106500 IF(XC.LE.XCMAX) GO TO 85 00106510 NDXL=4*IDIM 00106520 WRITE(6,91)NDXL 00106530 91 FORMAT(//20X,31HAN INTERNAL DEFAULT DIMENSION (,I4,12H) IS SMALLER00106540 $ /20X,50HTHAN YOUR PROBLEM REQUIRES. INCREASE IT BY PUTTING00106550 $ /20X,48HA LARGER NO. IN COL. 21-25 OF THE RENUMBER CARD. 00106560 $ /20X,19HEXECUTION WILL END.//) 00106570 KSKIP=1 00106580 RETURN 00106590 85 CONTINUE 00106600 STPT(XC)=LROOT 00106610 CALL TREE(I,NDSTK,NR,LVL,CCSTOR,NDEG,LVLWTH,LVLBOT,LVLN,MAXLW,N)00106620 SIZE(XC)=LVLBOT+LVLWTH-LROOT 00106630 LROOT=LVLBOT+LVLWTH 00106640 LVLN=LROOT 00106650 80 CONTINUE 00106660 IF(SORT2(XC,SIZE,STPT).EQ.0) GO TO 90 00106670 CALL PIKLVL(LVLS1,LVLS2,CCSTOR,IDFLT,ISDIR,XC,NHIGH,NLOW, 00106680 - NACUM,SIZE,STPT) 00106690 90 ISDIR=ISDIR*NFLG 00106700 NUM=SBNUM 00106710 IF(ISDIR.LT.0) NUM=STNUM 00106720 CALL NUMBAR(STNODE,NUM,NDSTK,LVLS2,NDEG,RENUM,LVLS1,LVL,NR,NFLG, 00106730 - IBW2,IPF2,CCSTOR,ISDIR,NHIGH,NLOW,NACUM,SIZE,IDIM) 00106740 IF(KSKIP.EQ.1) RETURN 00106750 IF(ISDIR.LT.0) STNUM=NUM 00106760 IF(ISDIR.GT.0) SBNUM=NUM 00106770 IF(SBNUM.LE.STNUM) GO TO 50 00106780 CALL WAVEY(NDSTK,NR,RENUM,LVL,0,LVLS2,LVLS1,MAXB,MAXWB,AVERWB, 00106790 1 SUMWB,SUMSQB,RMSB) 00106800 IBW2=MAXB 00106810 IPF2=SUMWB 00106820 WRITE(IOU6,705) METH 00106830 705 FORMAT( 23H0AFTER RESEQUENCING BY ,A4) 00106840 WRITE (IOU6,51) MAXB,SUMWB,AVERWB,RMSB 00106850 130 IM1=RMSA 00106860 GO TO (130,135,140,145), ICRIT 00106870 IM2=IPF1 00106880 CRIT1=RMSB 00106890 CRIT2=IPF2 00106900 GO TO 92 00106910 135 IM1=IBW1 00106920 IM2=IPF1 00106930 CRIT1=IBW2 00106940 CRIT2=IPF2 00106950 GO TO 92 00106960 140 IM1=IPF1 00106970 IM2=IBW1 00106980 CRIT1=IPF2 00106990 CRIT2=IBW2 00107000 GO TO 92 00107010 145 IM1=MAXWA 00107020 IM2=RMSA 00107030 CRIT1=MAXWB 00107040 CRIT2=RMSB 00107050 GO TO 92 00107060 92 CONTINUE 00107070 IF(CRIT1-IM1) 110,94,97 00107080 94 IF(CRIT2.LT.IM2) GO TO 110 00107090 97 CONTINUE 00107100 DO 100 I=1,N 00107110 RENUM(I)=IOLD(I) 00107120 100 CONTINUE 00107130 IBW2=IBW1 00107140 IPF2=IPF1 00107150 MAXWB=MAXWA 00107160 RMSB=RMSA 00107170 GO TO 112 00107180 110 CONTINUE 00107190 JUMP=0 00107200 112 CONTINUE 00107210 OBW=IBW1 00107220 OP=IPF1 00107230 115 NBW=IBW2 00107240 NP=IPF2 00107250 MAXW1=MAXWB 00107260 RMS1=RMSB 00107270 RETURN 00107280 END 00107290 SUBROUTINE DGREE(NDSTK,NR,NDEG,IOLD,IBW1,IPF1) 00059100 IMPLICIT REAL*8(A-H,O-Z) 00059110 INTEGER*2 NDSTK,NDEG,IOLD 00059120 COMMON /A/ MAXGRD,MAXDEG,N,IDPTH,IDEG 00059130 COMMON /BITS/NBITIN 00059140 COMMON /S/ NN,MM 00059150 DIMENSION NDSTK(NR,1),NDEG(1),IOLD(1) 00059160 IBW1=0 00059170 IPF1=0 00059180 IDEG=MM 00059190 MM=0 00059200 DO 100 I=1,N 00059210 NDEG(I)=0 00059220 IRW=0 00059230 DO 80 J=1,IDEG 00059240 ITST=NDSTK(I,J) 00059250 IF(ITST) 90,90,50 00059260 50 NDEG(I)=NDEG(I)+1 00059270 IDIF=IOLD(I)-IOLD(ITST) 00059280 IF(IRW.LT.IDIF) IRW=IDIF 00059290 MM=MAX0(MM,J) 00059300 80 CONTINUE 00059310 90 IPF1=IPF1+IRW 00059320 IF(IRW.GT.IBW1) IBW1=IRW 00059330 100 CONTINUE 00059340 IDEG=MM 00059350 IBW1=IBW1+1 00059360 IPF1=IPF1+N 00059370 RETURN 00059380 END 00059390 SUBROUTINE WAVEY(IG,II1,ILD,NEW,NC,IC,KACT,MAXB,MAXW,AVERW,SUMW, 00321310 - SUMSQ,RMS) 00321320 IMPLICIT REAL*8(A-H,O-Z) 00321330 INTEGER*2 IG,ILD,NEW,KACT 00321340 COMMON /S/ NN,MM 00321350 COMMON /A/ MAXGRD,NRMAXG(4) R0321360 DIMENSION IG(II1,1),ILD(1),NEW(1),KACT(1) 00321370 COMMON /BITS/NBITIN 00321380 DIMENSION IC(1) 00321390 INTEGER SUMW,SUMSQ 00321400 MAXB=0 00321410 MAXW=0 00321420 SUMW=0 00321430 SUMSQ=0 00321440 AVERW=0. 00321450 RMS=0. 00321460 IF((NN*MM).LE.0) RETURN 00321470 IF(NC.GT.0) GO TO 8 00321480 DO 5 I=1,NN 00321490 K=ILD(I) 00321500 IF(K.LE.0) GO TO 5 00321510 NEW(K)=I 00321520 5 CONTINUE 00321530 8 CONTINUE 00321540 DO 10 I=1,NN 00321550 10 KACT(I)=0 00321560 IWAVE=1 00321570 KT=0 00321580 DO 40 I=1,NN 00321590 K=NEW(I) 00321600 IF(NC) 18,18,15 00321610 15 IF(K.LE.0) GO TO 40 00321620 IF(NC-IC(K)) 40,18,40 00321630 18 CONTINUE 00321640 KT=KT + 1 00321650 DO 20 J=1,MM 00321660 L=IG(K,J) 00321670 IF(L.EQ.0) GO TO 30 00321680 M=ILD(L) 00321690 MAXB=MAX0(MAXB,I-M) 00321700 IF(M.LE.I) GO TO 20 00321710 IF(KACT(M).EQ.1) GO TO 20 00321720 IWAVE=IWAVE+1 00321730 KACT(M)=1 00321740 20 CONTINUE 00321750 30 CONTINUE 00321760 IF(KACT(I).EQ.1) IWAVE=IWAVE-1 00321770 MAXW=MAX0(MAXW,IWAVE) 00321780 SUMW=SUMW+IWAVE 00321790 SUMSQ=SUMSQ+IWAVE*IWAVE 00321800 40 CONTINUE 00321810 ANN=DBLE(KT) R0321820 AVERW=DBLE(SUMW)/ANN R0321830 SQ=DBLE(SUMSQ) R0321840 RMS=DSQRT(SQ/ANN) 00321850 RETURN 00321860 END 00321870 SUBROUTINE FNDIAM(SND1,SND2,NDSTK,NR,NDEG,LVL,LVLS1,LVLS2, 00087790 - IWK,IDFLT,NDLST,IDIM) 00087800 IMPLICIT REAL*8(A-H,O-Z) 00087810 INTEGER*2 NDSTK,NDEG,LVL,LVLS1,LVLS2,IWK,NDLST 00087820 INTEGER FLAG,SND,SND1,SND2 00087830 COMMON /A/ MAXGRD,MAXDEG,N,IDPTH,IDEG 00087840 COMMON /PREP/XDZ(2),KSKIP,RRPREP(8) R0087850 DIMENSION NDSTK(NR,1),NDEG(1),LVL(1),LVLS1(1),LVLS2(1),IWK(1) 00087860 DIMENSION NDLST(IDIM) 00087870 FLAG=0 00087880 MTW2=N 00087890 SND=SND1 00087900 20 DO 25 I=1,N 00087910 LVL(I)=0 00087920 25 CONTINUE 00087930 LVLN=1 00087940 CALL TREE(SND,NDSTK,NR,LVL,IWK,NDEG,LVLWTH,LVLBOT,LVLN,MAXLW,MTW2)00087950 IF(FLAG.GE.1) GO TO 110 00087960 FLAG=1 00087970 70 IDPTH=LVLN-1 00087980 MTW1=MAXLW 00087990 DO 75 I=1,N 00088000 LVLS1(I)=LVL(I) 00088010 75 CONTINUE 00088020 NDXN=1 00088030 NDXL=0 00088040 MTW2=N 00088050 CALL SORTDG(NDLST,IWK(LVLBOT),NDXL,LVLWTH,NDEG) 00088060 IF(NDXL.LE.IDIM) GO TO 100 00088070 NDXL=4*IDIM 00088080 WRITE(6,90)NDXL 00088090 90 FORMAT(//20X,31HAN INTERNAL DEFAULT DIMENSION (,I4,12H) IS SMALLER00088100 $ /20X,50HTHAN YOUR PROBLEM REQUIRES. INCREASE IT BY PUTTING00088110 $ /20X,48HA LARGER NO. IN COL. 21-25 OF THE RENUMBER CARD. 00088120 $ /20X,19HEXECUTION WILL END.//) 00088130 KSKIP=1 00088140 RETURN 00088150 100 CONTINUE 00088160 SND=NDLST(1) 00088170 GO TO 20 00088180 110 IF(IDPTH.GE.LVLN-1) GO TO 120 00088190 SND1=SND 00088200 GO TO 70 00088210 120 IF(MAXLW.GE.MTW2) GO TO 130 00088220 MTW2=MAXLW 00088230 SND2=SND 00088240 DO 125 I=1,N 00088250 LVLS2(I)=LVL(I) 00088260 125 CONTINUE 00088270 130 IF(NDXN.EQ.NDXL) GO TO 140 00088280 NDXN=NDXN+1 00088290 SND=NDLST(NDXN) 00088300 GO TO 20 00088310 140 IDFLT=1 00088320 IF(MTW2.LE.MTW1) IDFLT=2 00088330 RETURN 00088340 END 00088350 SUBROUTINE TREE(IROOT,NDSTK,NR,LVL,IWK,NDEG,LVLWTH,LVLBOT, 00313850 -LVLN,MAXLW,IBORT) 00313860 IMPLICIT REAL*8(A-H,O-Z) 00313870 INTEGER*2 NDSTK,LVL,IWK,NDEG 00313880 DIMENSION NDSTK(NR,1),LVL(1),IWK(1),NDEG(1) 00313890 COMMON /A/ MAXGRD,MAXDEG,NRMAXG(3) R0313900 COMMON /BITS/NBITIN 00313910 MAXLW=0 00313920 ITOP=LVLN 00313930 INOW=LVLN 00313940 LVLBOT=LVLN 00313950 LVLTOP=LVLN+1 00313960 LVLN=1 00313970 LVL(IROOT)=1 00313980 IWK(ITOP)=IROOT 00313990 30 LVLN=LVLN+1 00314000 35 IWKNOW=IWK(INOW) 00314010 NDROW=NDEG(IWKNOW) 00314020 DO 40 J=1,NDROW 00314030 ITEST=NDSTK(IWKNOW,J) 00314040 IF(LVL(ITEST).NE.0) GO TO 40 00314050 LVL(ITEST)=LVLN 00314060 ITOP=ITOP+1 00314070 IWK(ITOP)=ITEST 00314080 40 CONTINUE 00314090 INOW=INOW+1 00314100 IF(INOW.LT.LVLTOP) GO TO 35 00314110 LVLWTH=LVLTOP-LVLBOT 00314120 IF(MAXLW.LT.LVLWTH) MAXLW=LVLWTH 00314130 IF(MAXLW.GE.IBORT) RETURN 00314140 IF(ITOP.LT.LVLTOP) RETURN 00314150 LVLBOT=INOW 00314160 LVLTOP=ITOP+1 00314170 GO TO 30 00314180 END 00314190 INTEGER FUNCTION SORT2(XC,SIZE,STPT) 00248470 IMPLICIT REAL*8(A-H,O-Z) 00248480 INTEGER*2 SIZE,STPT 00248490 INTEGER TEMP,XC 00248500 DIMENSION SIZE(1),STPT(1) 00248510 SORT2=0 00248520 IF(XC.EQ.0) RETURN 00248530 SORT2=1 00248540 IND=XC 00248550 10 ITEST=0 00248560 IND=IND-1 00248570 IF(IND.LT.1) RETURN 00248580 DO 17 I=1,IND 00248590 J=I+1 00248600 IF(SIZE(I).GE.SIZE(J)) GO TO 17 00248610 ITEST=1 00248620 TEMP=SIZE(I) 00248630 SIZE(I)=SIZE(J) 00248640 SIZE(J)=TEMP 00248650 TEMP=STPT(I) 00248660 STPT(I)=STPT(J) 00248670 STPT(J)=TEMP 00248680 17 CONTINUE 00248690 IF(ITEST.EQ.1) GO TO 10 00248700 RETURN 00248710 END 00248720