C Copyright(C) 1999-2020 National Technology & Engineering Solutions C of Sandia, LLC (NTESS). Under the terms of Contract DE-NA0003525 with C NTESS, the U.S. Government retains certain rights in this software. C C See packages/seacas/LICENSE for details SUBROUTINE RENUM (NPNODE, NPELEM, MXNFLG, MXSFLG, NPNBC, NPSBC, & NPWTS, NPREGN, MP, ML, MS, MR, MSC, MAXKXN, NNUID, NNXK, & MXLPS, IUNIT, NNN, KKK, KCRD, NL, NPBF, NLBF, NSBF, IPART, & LSTNBC, LSTSBC, NNFLG, NNPTR, NNLEN, NSFLG, NSPTR, NSLEN, & NVPTR, NVLEN, NSIDEN, NUID, XN, YN, NXK, MAT, KXN, LIST, LA, & LB, MATMAP, LISTN, WTNODE, WTSIDE, WTHOLD, IHERE, ILIST, XLIST, & NUMMAT, NBCNOD, NNLIST, NBCSID, NSLIST, NVLIST, COOR, ILINE, & LTYPE, LCON, ISIDE, NLPS, IFLINE, ILLIST, LINKP, LINKL, LINKS, & LINKR, IMAT, LINKB, JMAT, IPBF, NPPF, IFPB, LISTPB, IWTPBF, & ILBF, NLPF, IFLB, LISTLB, IWTLBF, ISBF, NSPF, IFSB, LISTSB, & IWTSBF, LINKPB, LINKLB, LINKSB, NUMBER, THREE, EIGHT, NINE, & OPTIM, ISBARS) C*********************************************************************** C SUBROUTINE RENUM = NUMBERS QMESH OUTPUT, AND RENUMBERS AS NEEDED FOR C OPTIMIZATION C*********************************************************************** C THE REFERENCE DOCUMENTS FOR THIS CODE ARE SLA-73-1088, JULY 1974, C AND SLA-74-0239, JULY 1974 C*********************************************************************** DIMENSION NLIST(20), IPART(3, NPREGN) DIMENSION COOR(2, MP), ILINE(ML), LTYPE(ML), LCON(3, ML) DIMENSION ISIDE(MS), NLPS(MS), IFLINE(MS), ILLIST(MS*3) DIMENSION LINKP(2, MP), LINKL(2, ML), LINKS(2, MS), LINKB(2, MS) DIMENSION LINKR(2, MR) DIMENSION IMAT(MR), JMAT(MS) DIMENSION IPBF(MP), NPPF(MP), IFPB(MP), LISTPB(2, MP) DIMENSION ILBF(ML), NLPF(ML), IFLB(ML), LISTLB(2, ML) DIMENSION ISBF(ML), NSPF(ML), IFSB(ML), LISTSB(2, ML) DIMENSION IWTPBF(3, MP), IWTLBF(3, ML), IWTSBF(3, ML) DIMENSION LINKPB(2, MP), LINKLB(2, ML), LINKSB(2, ML) DIMENSION LIST(NNUID), LISTN(NNUID), NUID(NNUID), XN(NPNODE) DIMENSION YN(NPNODE), NXK(NNXK, NPELEM), MAT(NPELEM) DIMENSION KXN(NNXK, MAXKXN), LA(NPNODE), LB(NPNODE) DIMENSION IHERE(NNUID), ILIST(MXLPS), XLIST(MXLPS) DIMENSION LSTNBC(NPNBC), LSTSBC(NPSBC), NSIDEN(NPSBC) DIMENSION NNFLG(MXNFLG), NNLEN(MXNFLG), NNPTR(MXNFLG) DIMENSION NSFLG(MXSFLG), NSLEN(MXSFLG), NSPTR(MXSFLG) DIMENSION WTHOLD(NPWTS), WTNODE(NPNBC), WTSIDE(NPSBC) DIMENSION NVLEN(MXSFLG), NVPTR(MXSFLG), MATMAP(3, NPREGN) DIMENSION KLIST(20) LOGICAL OPTIM, ERR, NOROOM, ALL, THREE, EIGHT, NINE LOGICAL ITSOK, ISBARS CHARACTER*80 NUMBER(MSC) C HEADER CALL MESSAGE(' ') CALL MESSAGE('NUMBERING OF GENERATED OUTPUT BEGUN') IF (OPTIM) CALL MESSAGE(' -- OPTIMIZATION IS ENABLED --') C READ THE MESH TAPE CALL RDMESH (NPNODE, NPELEM, NPNBC, NPSBC, NPREGN, MS, MR, NNUID, & NNXK, IUNIT, NNN, KKK, IPART, LSTNBC, LSTSBC, NUID, XN, YN, & NXK, MAT, MATMAP, NUMMAT, ISIDE, NLPS, IFLINE, ILLIST, LINKS, & LINKR, IMAT, LINKB, JMAT, NNNBC, NNSBC, ERR) IF (ERR) THEN CALL MESSAGE('** NUMBERING ABORT **') RETURN END IF C SORT NODE LIST INTO INCREASING NUID-S DO 100 I = 1, NNN LISTN(I) = NUID(I) 100 CONTINUE IF (OPTIM) THEN CALL NODORD (NPNODE, XN, YN, LISTN, NUID, NNN) ELSE DO 110 I = 1, NNN LIST(I) = I 110 CONTINUE CALL SORT (NNN, NUID, LIST) END IF C CONVERT REFERENCES TO NUID-S TO REFERENCES TO C SEQUENCE NUMBERS DO 130 I = 1, 4 DO 120 K = 1, KKK IF (NXK(I, K) .GT. 0) THEN NEW = INDX(NNN, NUID, NXK(I, K)) IF (NEW .EQ. 0) THEN CALL MESSAGE('ERROR SORTING NUMBERING DATA -- NODE') CALL MESSAGE('*** NO MESH SAVED ***') KKK = 0 RETURN END IF IF (OPTIM) THEN NXK(I, K) = NEW ELSE NXK(I, K) = LIST(NEW) END IF END IF 120 CONTINUE 130 CONTINUE IF (NNNBC .GT. 0) THEN DO 140 I = 1, NNNBC IF (LSTNBC(I) .GT. 0) THEN NEW = INDX(NNN, NUID, LSTNBC(I)) IF (NEW .EQ. 0) THEN CALL MESSAGE('ERROR SORTING NUMBERING DATA -- NBC') CALL MESSAGE('*** NO MESH SAVED ***') KKK = 0 RETURN END IF IF (OPTIM) THEN LSTNBC(I) = NEW ELSE LSTNBC(I) = LIST(NEW) END IF END IF 140 CONTINUE END IF C BUILD KXN ARRAY NUMKXN = NNN DO 160 I = 1, NNXK DO 150 J = 1, MAXKXN KXN(I, J) = 0 150 CONTINUE 160 CONTINUE DO 180 I = 1, 4 DO 170 K = 1, KKK IF (NXK(I, K) .GT. 0) THEN CALL KXNADD (MAXKXN, NNXK, KXN, NUMKXN, K, NXK(I, K), & ERR) IF (ERR) THEN CALL MESSAGE('** NUMBERING ABORT **') KKK = 0 RETURN END IF END IF 170 CONTINUE 180 CONTINUE IF (OPTIM) THEN C GET STARTING LIST FOR CUTHILL-MCKEE PROCESS IF (KCRD .GT. 0) THEN CALL GNLIST (NPNODE, NNUID, MSC, NPNODE, NPELEM, MAXKXN, & NNXK, KXN, NXK, NUID, XN, YN, LIST, NUML, NUMBER, KCRD, & NNN, ERR, NOROOM) IF (NOROOM) THEN CALL MESSAGE('TOO MANY NODES IN STARTING LIST') CALL MESSAGE('*** NO MESH SAVED ***') CALL MESSAGE('** NUMBERING ABORT **') KKK = 0 RETURN ELSE IF (ERR) THEN CALL MESSAGE('ERROR GENERATING STARTING LIST') CALL MESSAGE('*** NO MESH SAVED ***') CALL MESSAGE('** NUMBERING ABORT **') KKK = 0 RETURN END IF ELSE CALL MESSAGE('NO CARDS AVAILABLE FOR STARTING LIST') CALL MESSAGE('FIRST NODE IN THE OUTPUT USED') NUML = 1 LIST(1) = 1 END IF C INITIALIZE LISTS DO 190 I = 1, NNN LISTN(I) = I 190 CONTINUE C USE LISTN AS A CHECK ON WHETHER THE NODE HAS BEEN USED (NEGATED) DO 200 I = 1, NUML LA(I) = LIST(I) NODE = LIST(I) LISTN(NODE) = -LISTN(NODE) 200 CONTINUE NUMA = NUML C CREATE LIST OF NEW NODES CONNECTED TO LIST A 210 CONTINUE NUMB = 0 DO 230 N = 1, NUMA ALL = .TRUE. CALL GETNXN (NPNODE, NPELEM, MAXKXN, NNXK, KXN, NXK, LISTN, & LA(N), NLIST, NUMB1, ALL, ERR) IF (ERR) THEN CALL MESSAGE('** NUMBERING ABORT **') KKK = 0 RETURN END IF IF (NUMB1 .GT. 0) THEN IF ((NUMB + NUMB1) .GT. NPNODE) THEN CALL MESSAGE('LIST B HAS OVERFLOWED') CALL MESSAGE('*** NO MESH SAVED ***') CALL MESSAGE('** NUMBERING ABORT **') KKK = 0 RETURN END IF DO 220 I = 1, NUMB1 NODE = NLIST(I) NUMB = NUMB + 1 LB(NUMB) = NODE LISTN(NODE) = -LISTN(NODE) 220 CONTINUE END IF 230 CONTINUE IF (NUMB .GT. 0) THEN C INCLUDE LIST B INTO FULL LIST C ALSO TRANSFER LIST B TO LIST A DO 240 I = 1, NUMB NUML = NUML + 1 LIST(NUML) = LB(I) LA(I) = LB(I) 240 CONTINUE NUMA = NUMB C CHECK FOR CONVERGENCE IF (NUML .LT. NNN) GO TO 210 C PROCESS HAS CONVERGED C CHECK IF ALL NODES WERE COVERED ELSE IF (NUML .LT. NNN) THEN DO 250 I = 1, NNN IF (LISTN(I) .GT. 0) THEN C START THE LIST AGAIN WITH THE MISSED NODE CALL MESSAGE('A DISCONTINUITY (SLIDE LINE) IN THE '// & 'BODY HAS BEEN FOUND') CALL MESSAGE & ('SEPARATE PART NUMBERING WILL ALSO BE OPTIMIZED') NUMA = 1 LA(1) = I GO TO 210 END IF 250 CONTINUE C DEFINITE ERROR IN THE NUMBERING PROCESS CALL MESSAGE('ALL NODES COULD NOT BE FOUND TO NUMBER') CALL MESSAGE(' *** NO MESH SAVED ***') CALL MESSAGE(' ** NUMBERING ABORT **') KKK = 0 RETURN END IF C PREPARE TO PUT NODE LIST INTO NEWLY DETERMINED ORDER C LISTN BECOMES THE POINTER FROM THE OLD NUMBER TO THE NEW DO 260 I = 1, NNN J = LIST(I) LISTN(J) = I 260 CONTINUE C CONVERT NODE NUMBERS TO NEW NODE ORDER BY REDOING THE NXK ARRAY DO 280 I = 1, 4 DO 270 K = 1, KKK J = NXK(I, K) IF (J .GT. 0) NXK(I, K) = LISTN(J) 270 CONTINUE 280 CONTINUE IF (NNNBC .GT. 0) THEN DO 290 I = 1, NNNBC IF (LSTNBC(I) .GT. 0) THEN J = LSTNBC(I) LSTNBC(I) = LISTN(J) END IF 290 CONTINUE END IF C PUT NODE LIST INTO NEW ORDER CALL NODORD (NPNODE, XN, YN, LISTN, NUID, NNN) C REBUILD KXN ARRAY NUMKXN = NNN DO 310 I = 1, NNXK DO 300 J = 1, MAXKXN KXN(I, J) = 0 300 CONTINUE 310 CONTINUE DO 330 I = 1, 4 DO 320 K = 1, KKK IF (NXK(I, K) .GT. 0) THEN CALL KXNADD (MAXKXN, NNXK, KXN, NUMKXN, K, NXK(I, K), & ERR) IF (ERR) THEN CALL MESSAGE('** NUMBERING ABORT **') KKK = 0 RETURN END IF END IF 320 CONTINUE 330 CONTINUE C PUT ELEMENT NUMBERING INTO NEW ORDER USING LA AS TEMPORARY STORAGE DO 340 I = 1, KKK LA(I) = 0 LB(I) = 0 340 CONTINUE KOUNT = 0 DO 360 I = 1, NNN CALL GETKXN (NPNODE, MAXKXN, NNXK, KXN, NUID, I, KLIST, & NUMK, ERR) DO 350 J = 1, NUMK IF (LB(KLIST(J)) .EQ. 0) THEN KOUNT = KOUNT + 1 LA(KOUNT) = KLIST(J) LB(KLIST(J)) = 1 END IF 350 CONTINUE 360 CONTINUE C END OF OPTIMIZATION ELSE DO 370 I = 1, NNN NUID(I) = LISTN(I) 370 CONTINUE END IF C STICK LSTNBC INTO LISTN AS A WORK ARRAY FOR SORTING NODAL BOUNDARY C CONDITIONS LISTS IF (NNNBC .GT. 0) THEN DO 380 I = 1, NNNBC LISTN(I) = LSTNBC(I) 380 CONTINUE C SORT THROUGH LSTNBC AND RECREATE IT IN PLACE C USING LISTN AS THE ARRAY TO TAKE LSTNBC OVER C AND IHERE AS A WORK ARRAY C (LSTNBC NOW BECOMES THE NODES ARRAY FOR THE C GENESIS DATA BASE) CALL SRTNBC (MXNFLG, NPNBC, NNN, NNFLG, NNLEN, NNPTR, LSTNBC, & LISTN, IHERE, NNNBC, NBCNOD, NNLIST) ELSE NNLIST = 0 NBCNOD = 0 END IF C SORT THROUGH LSTSBC AND RECREATE IT IN PLACE C USING LISTN AS THE ARRAY TO TAKE LSTSBC OVER C AND KXN AS A WORK ARRAY C (LSTSBC NOW BECOMES THE NELEMS ARRAY FOR THE C GENESIS DATA BASE) IF (NNSBC .GT. 0) THEN DO 390 I = 1, NNSBC LISTN(I) = LSTSBC(I) 390 CONTINUE CALL SRTSBC (MXSFLG, NPSBC, NPELEM, NNXK, NXK, NSFLG, NSLEN, & NSPTR, NVLEN, NVPTR, LISTN, LSTSBC, NSIDEN, IHERE, NNSBC, & NSLIST, NVLIST, NBCSID) ELSE NBCSID = 0 NSLIST = 0 NVLIST = 0 END IF C PUT WEIGHTS ON FLAGGED NODES AS NEEDED C USE THE IHERE ARRAY AS A WORK ARRAY CALL ADDWT (NNUID, NNXK, MAXKXN, NPNODE, NPELEM, MXLPS, MP, ML, & MS, NPNBC, NPSBC, MXNFLG, MXSFLG, NPWTS, COOR, ILINE, LTYPE, & LCON, ISIDE, NLPS, IFLINE, ILLIST, LINKP, LINKL, LINKS, IPBF, & NPPF, IFPB, LISTPB, IWTPBF, ILBF, NLPF, IFLB, LISTLB, IWTLBF, & ISBF, NSPF, IFSB, LISTSB, IWTSBF, LINKPB, LINKLB, LINKSB, XN, & YN, NUID, NXK, KXN, LSTNBC, NNFLG, NNPTR, NNLEN, NSFLG, NVPTR, & NVLEN, NSIDEN, WTNODE, WTSIDE, WTHOLD, NBCNOD, NNLIST, NBCSID, & NSLIST, NVLIST, ILIST, XLIST) C SORT NUMBERS ACCORDING TO MATERIAL TYPE C USE KXN AS A WORK ARRAY DO 410 J = 1, 4 DO 400 I = 1, KKK KXN(J, I) = NXK(J, I) 400 CONTINUE 410 CONTINUE C SET UP THE MATERIAL MAPPING ARRAY C MATMAP(1, I) = THE MATERIAL ID FOR THE I'TH BLOCK C MATMAP(2, I) = THE FIRST ELEMENT IN THE I'TH BLOCK C MATMAP(3, I) = THE LAST ELEMENT IN THE I'TH BLOCK KOUNT = 1 DO 440 I = 1, NUMMAT KMAT = MATMAP(1, I) MATMAP(2, I) = KOUNT DO 430 J = 1, KKK IF (MAT(J) .EQ. KMAT) THEN LISTN(J) = KOUNT LIST(KOUNT) = J DO 420 K = 1, 4 NXK(K, KOUNT) = KXN(K, J) 420 CONTINUE KOUNT = KOUNT + 1 END IF 430 CONTINUE MATMAP(3, I) = KOUNT - 1 440 CONTINUE IF (KOUNT - 1 .NE. KKK) THEN CALL MESSAGE('ALL ELEMENTS DID NOT HAVE AN ELEMENT ID') CALL MESSAGE('MESH NUMBERING ABORTED') KKK = 0 RETURN END IF C REDO THE REGION POINTER ARRAY DO 450 I = 1, NPREGN IPART(2, I) = LISTN(IPART(2, I)) IPART(3, I) = LISTN(IPART(3, I)) 450 CONTINUE C REDO THE MATERIAL ARRAY DO 470 I = 1, NUMMAT DO 460 J = MATMAP(2, I), MATMAP(3, I) MAT(J) = MATMAP(1, I) 460 CONTINUE 470 CONTINUE C REDO THE MAPPING ARRAY IF OPTIMIZING RENUMBERING HAS BEEN DONE IF (OPTIM) THEN DO 480 I = 1, KKK LA(I) = LISTN(LA(I)) 480 CONTINUE END IF C REDO THE ELEMENT SIDE BOUNDARY LISTING WITH THE CURRENT ELEMENT NO. DO 490 I = 1, NSLIST LSTSBC(I) = LISTN(LSTSBC(I)) 490 CONTINUE C STORE THE LISTN POINTER SYSTEM FOR NOW DO 500 I = 1, KKK LIST(I) = LISTN(I) 500 CONTINUE C ADD THE MID-SIDE NODES IF EIGHT OR NINE NODE QUADS ARE WANTED C OR IF THREE NODE BARS ARE WANTED IF ((EIGHT) .OR. (NINE) .OR. (THREE)) THEN C FLAG ALL ELEMENT SIDES ONLY ONCE (NO SHARED SIDE FLAGGED) CALL NXKBDY (NNXK * MAXKXN, NNXK, NPELEM, NXK, KKK, KXN, & THREE, EIGHT, NINE) C CREATE THE MIDSIDE NODES CALL MIDNOD (NPNODE, NNUID, NPELEM, NNXK, MP, ML, KKK, NNN, & NALL, NL, NXK, NUID, XN, YN, LISTN, COOR, ILINE, LTYPE, & LCON, LINKP, LINKL, THREE, EIGHT, NINE) C MODIFY THE IDENTIFIERS OF THE OLD NODES DO 510 I = 1, NNN LISTN(I) = I * 100000 510 CONTINUE NNN = NALL C ORDER THE EXPANDED NODE LIST CALL NODORD (NPNODE, XN, YN, LISTN, NUID, NNN) C EXPAND THE CONNECTIVITY ARRAY TO INCLUDE THE MIDSIDE NODES C WHILE REPOSITIONING THE CORNER NODES INTO PROPER SEQUENCE DO 540 I = 1, KKK IF ((THREE) .AND. (NXK (3, I) .EQ. 0)) THEN ITSOK = .TRUE. ELSEIF ((NXK (3, I) .NE. 0) .AND. ((EIGHT) .OR. (NINE))) & THEN ITSOK = .TRUE. ELSE ITSOK = .FALSE. ENDIF IF (ITSOK) THEN DO 520 J = 4, 1, -1 JJ = J + 1 IF (JJ .EQ. 5) JJ = 1 NODEA = IABS(NXK(J, I)) NODEB = IABS(NXK(JJ, I)) C CHECK FOR 3 NODE BAR ELEMENTS IF ((NODEA .GT. 0) .AND. (NODEB .GT. 0)) THEN NXK (J * 2 - 1, I) = NODEA * 100000 NLO = MIN0(NODEA, NODEB) NHI = MAX0(NODEA, NODEB) NXK (J * 2, I) = NLO * 100000 + NHI ELSE IF (NODEA .GT. 0) THEN NXK (J * 2 - 1, I) = NODEA * 100000 END IF 520 CONTINUE ELSE DO 530 J = 1, 4 NXK (J, I) = IABS (NXK (J,I)) * 100000 530 CONTINUE ENDIF 540 CONTINUE C GET THE LIST OF NODAL BOUNDARY FLAGS EXTENDED AND THE NEW IDENTIFIERS C IN PLACE (USE NUID AND WTHOLD AS WORK ARRAYS) IF (NBCNOD .GT. 0) THEN KOUNT = 0 DO 570 I = 1, NBCNOD JEND = NNLEN(I) + NNPTR(I) - 1 DO 560 J = NNPTR(I), JEND KOUNT = KOUNT + 1 NUID(KOUNT) = LSTNBC(J) * 100000 WTHOLD(KOUNT) = WTNODE(J) DO 550 K = J + 1, JEND ILO = MIN0(LSTNBC(J), LSTNBC(K)) IHI = MAX0(LSTNBC(J), LSTNBC(K)) ITRY = (ILO * 100000) + IHI IF (INDX(NNN, LISTN, ITRY) .GT. 0) THEN KOUNT = KOUNT + 1 NNLEN(I) = NNLEN(I) + 1 NUID(KOUNT) = ITRY WTHOLD(KOUNT) = (WTNODE(J) + WTNODE(K)) * .5 END IF 550 CONTINUE 560 CONTINUE IF (I .NE. 1) NNPTR(I) = NNPTR(I - 1) + NNLEN(I - 1) 570 CONTINUE NNLIST = KOUNT DO 580 I = 1, NNLIST LSTNBC(I) = NUID(I) WTNODE(I) = WTHOLD(I) 580 CONTINUE END IF C GET THE LIST OF SIDE BOUNDARY FLAGS EXTENDED AND THE NEW IDENTIFIERS C IN PLACE (USE NUID, WTHOLD, AND KXN AS WORK ARRAYS) IF (NBCSID .GT. 0) THEN KOUNT = 0 KOUNT2 = 0 DO 600 I = 1, NBCSID ISTART = NSPTR (I) IEND = NSPTR (I) + NSLEN (I) - 1 J = NVPTR (I) JEND = NVPTR (I) + NVLEN (I) - 1 DO 590 II = ISTART, IEND KELEM = LSTSBC (II) KOUNT = KOUNT + 1 KXN (1, KOUNT) = KELEM K = J + 1 KOUNT2 = KOUNT2 + 1 NUID(KOUNT2) = NSIDEN(J) * 100000 WTHOLD(KOUNT2) = WTSIDE(J) C DO THE ADJUSTMENTS IF THE ELEMENT IS ONE THAT HAS BEEN EXPANDED IF ( ((THREE) .AND. (NXK (4, KELEM) .EQ. 0)) .OR. & ( ((EIGHT) .OR. (NINE)) .AND. & (NXK (4, KELEM) .NE. 0) ) ) THEN KOUNT = KOUNT + 1 KXN (1, KOUNT) = LSTSBC(II) NSLEN (I) = NSLEN (I) + 1 ILO = MIN0(NSIDEN(J), NSIDEN(K)) IHI = MAX0(NSIDEN(J), NSIDEN(K)) ITRY = (ILO * 100000) + IHI KOUNT2 = KOUNT2 + 1 NUID(KOUNT2) = ITRY WTHOLD(KOUNT2) = (WTSIDE(J) + WTSIDE(K)) * .5 KOUNT2 = KOUNT2 + 1 NUID(KOUNT2) = ITRY WTHOLD(KOUNT2) = (WTSIDE(J) + WTSIDE(K)) * .5 NVLEN(I) = NVLEN(I) + 2 ENDIF KOUNT2 = KOUNT2 + 1 NUID(KOUNT2) = NSIDEN(K) * 100000 WTHOLD(KOUNT2) = WTSIDE(K) J = J + 2 590 CONTINUE IF (I .GT. 1) THEN NSPTR(I) = NSPTR(I - 1) + NSLEN(I - 1) NVPTR(I) = NVPTR(I - 1) + NVLEN(I - 1) ENDIF 600 CONTINUE C TRANSFER THE ELEMENT BOUNDARIES BACK FROM THE WORK ARRAYS NSLIST = KOUNT DO 610 I = 1, NSLIST LSTSBC(I) = KXN(1, I) 610 CONTINUE NVLIST = KOUNT2 DO 620 I = 1, NVLIST NSIDEN(I) = NUID(I) WTSIDE(I) = WTHOLD(I) 620 CONTINUE END IF C ADD A CENTER NODE TO THE NODE LIST IF NEEDED IF (NINE) THEN NOLD = NNN DO 630 I = 1, KKK C WATCH OUT FOR 3 NODE BAR ELEMENTS IF (.NOT. ISBARS .OR. NXK(4, I) .GT. 0) THEN N2 = INDX(NOLD, LISTN, NXK(2, I)) N4 = INDX(NOLD, LISTN, NXK(4, I)) N6 = INDX(NOLD, LISTN, NXK(6, I)) N8 = INDX(NOLD, LISTN, NXK(8, I)) IF ((N2 .EQ. 0) .OR. (N4 .EQ. 0) .OR. & (N6 .EQ. 0) .OR. (N8 .EQ. 0)) THEN CALL MESSAGE('BAD LINK IN RENUM AT 8 NODE LIST') CALL MESSAGE('NO MESH SAVED') KKK = 0 RETURN END IF DIST1 = SQRT((XN(N2) - XN(N6)) **2 & + (YN(N2) - YN(N6)) **2) DIST2 = SQRT((XN(N8) - XN(N4)) **2 & + (YN(N8) - YN(N4)) **2) NNN = NNN + 1 IF (DIST1 .LT. DIST2) THEN XN(NNN) = .5 * (XN(N2) + XN(N6)) YN(NNN) = .5 * (YN(N2) + YN(N6)) ELSE XN(NNN) = .5 * (XN(N4) + XN(N8)) YN(NNN) = .5 * (YN(N4) + YN(N8)) END IF LISTN(NNN) = INT((MIN0(NXK(1, I), NXK(5, I))) + & (MAX0(NXK(1, I), NXK(5, I)) * .0001)) NXK(9, I) = LISTN(NNN) ELSE write (*,*) 'Element ', i, ' is a 3-node bar?' END IF 630 CONTINUE C NOW, ORDER THE EXPANDED NODE LIST AGAIN CALL NODORD (NPNODE, XN, YN, LISTN, NUID, NNN) IEND = 9 ELSEIF (EIGHT) THEN IEND = 8 ELSE IEND = 4 END IF C NOW REPLACE THE NODE REFERENCES WITH AN EXPANDED ORDER NUMBER C FIRST FIX THE CONNECTIVITY (NXK ARRAY) DO 650 I = 1, IEND DO 640 K = 1, KKK C AGAIN, WATCH OUT FOR 3 NODE BAR ELEMENTS IF (.NOT. ISBARS .OR. NXK(I, K) .GT. 0) THEN NEW = INDX(NNN, LISTN, NXK(I, K)) IF (NEW .EQ. 0) THEN CALL MESSAGE('BAD LINK IN RENUM 8 NODE LIST') CALL MESSAGE('NO MESH SAVED') KKK = 0 RETURN END IF NXK(I, K) = NEW END IF 640 CONTINUE 650 CONTINUE C NOW FIX THE NODE BOUNDARY FLAGS IF (NBCNOD .GT. 0) THEN DO 660 I = 1, NNLIST NEW = INDX(NNN, LISTN, LSTNBC(I)) IF (NEW .EQ. 0) THEN CALL MESSAGE('BAD LINK IN RENUM AT 8 NODE NBC') CALL MESSAGE('NO MESH SAVED') KKK = 0 RETURN END IF LSTNBC(I) = NEW 660 CONTINUE END IF C NOW FIX THE SIDE BOUNDARY FLAGS IF (NBCSID .GT. 0) THEN DO 670 I = 1, NVLIST NEW = INDX(NNN, LISTN, NSIDEN(I)) IF (NEW .EQ. 0) THEN CALL MESSAGE('BAD LINK IN RENUM AT 8 NODE SBC') CALL MESSAGE('NO MESH SAVED') KKK = 0 RETURN END IF NSIDEN(I) = NEW 670 CONTINUE END IF END IF C RENUMBERING COMPLETED CALL MESSAGE(' ') CALL MESSAGE('**************************************************') CALL MESSAGE('** MESH PROCESSING COMPLETED **') IF (ISBARS .AND. NINE) THEN CALL MESSAGE('** THREE NODE BARS OUTPUT '// & ' **') ENDIF IF (NINE) THEN CALL MESSAGE('** NINE NODE QUADS OUTPUT '// & ' **') ELSE IF (EIGHT) THEN CALL MESSAGE('** EIGHT NODE QUADS OUTPUT '// & ' **') END IF IF (OPTIM) THEN CALL MESSAGE & ('** WITH NODE AND ELEMENT NUMBERING OPTIMIZED **') C FIND LARGEST NODE DIFFERENCE FOR AN ELEMENT LWID = 0 DO 680 K = 1, KKK N1 = NXK(1, K) N2 = NXK(2, K) N3 = NXK(3, K) N4 = NXK(4, K) IF ((N4 .GT. 0) .AND. ((EIGHT) .OR. (NINE))) THEN N5 = NXK(5, K) N6 = NXK(6, K) N7 = NXK(7, K) N8 = NXK(8, K) IF (NINE) THEN N9 = NXK(9, K) NLO = MIN0(N1, N2, N3, N4, N5, N6, N7, N8, N9) NHI = MAX0(N1, N2, N3, N4, N5, N6, N7, N8, N9) ELSE NLO = MIN0(N1, N2, N3, N4, N5, N6, N7, N8) NHI = MAX0(N1, N2, N3, N4, N5, N6, N7, N8) END IF ELSE IF (N3 .LE. 0) N3 = N1 IF (N4 .LE. 0) N4 = N2 NLO = MIN0(N1, N2, N3, N4) NHI = MAX0(N1, N2, N3, N4) END IF LWID = MAX0(LWID, NHI - NLO) 680 CONTINUE WRITE(*, 10000) LWID END IF WRITE(*, 10010) NNN, KKK, NUMMAT CALL MESSAGE('**************************************************') C RESTORE THE NUID ARRAY AS A POINTER ARRAY OF OLD TO NEW ELEMENTS C (MAPDXG ARRAY) IF (OPTIM) THEN DO 690 I = 1, KKK NUID(I) = LA(I) LIST(NUID(I)) = I 690 CONTINUE ELSE DO 700 I = 1, KKK NUID(I) = I LIST(I) = I 700 CONTINUE END IF RETURN 10000 FORMAT(' ** LARGEST NODE DIFFERENCE PER ELEMENT:', I6, ' **') 10010 FORMAT(' ** NODES:', I6, '; ELEMENTS:', I6, '; MATERIALS:', I3, & ' **') END