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 PMSCHM (NPER, NPRM, MXND, MLN, MP, ML, MS, MR, NL, & MAXNL, MAXNP, MAXPRM, MAXNB, MAXNBC, MAXSBC, KNBC, KSBC, KNUM, & IPOINT, COOR, IPBOUN, ILINE, LTYPE, NINT, FACTOR, LCON, ILBOUN, & ISBOUN, ISIDE, NLPS, IFLINE, ILLIST, ISLIST, IREGN, NPPF, IFPB, & LISTPB, NLPF, IFLB, LISTLB, NSPF, IFSB, LISTSB, LINKP, LINKL, & LINKS, LINKR, LINKPB, LINKLB, LINKSB, NSPR, IFSIDE, RSIZE, & IFHOLE, NHPR, IHLIST, X, Y, NID, LISTL, XN, YN, ZN, NUID, LXK, & KXL, NXL, LXN, LSTNBC, NPERIM, ANGLE, BNSIZE, LNODES, LINKPR, & MARKED, IPTPER, NUMPER, LPERIM, KKK, NNN, LLL, IAVAIL, NAVAIL, & DEV1, KREG, IPNTRG, BATCH, NOROOM, ERR, AMESUR, XNOLD, YNOLD, & NXKOLD, MMPOLD, LINKEG, LISTEG, BMESUR, MLINK, NPROLD, NPNOLD, & NPEOLD, NNXK, REMESH, REXMIN, REXMAX, REYMIN, REYMAX, IDIVIS, & SIZMIN, EMAX, EMIN) C*********************************************************************** C SUBROUTINE FMSCHM = GENERATES AN INITIAL PAVED MESH C*********************************************************************** C VARIABLES USED: C X = X VALUES AROUND THE PERIMETER C Y = Y VALUES AROUND THE PERIMETER C NID = PERIMETER NODE UNIQUE ID'S C NPER = NUMBER OF PERIMETER NODES C ERR = .TRUE. IF ERRORS WERE ENCOUNTERED C XN = GLOBAL X VALUES OF NODES C YN = GLOBAL Y VALUES OF NODES C NUID = GLOBAL NODE UNIQUE IDENTIFIERS C LXK = LINES PER ELEMENT C KXL = ELEMENTS PER LINE C NXL = NODES PER LINE C LXN = LINES PER NODE C NOTE: C FOR *XN TABLES A NEGATIVE FLAG IN THE FOURTH COLUMN MEANS C GO TO THAT ROW FOR A CONTINUATION OF THE LIST. IN THAT ROW C THE FIRST ELEMENT WILL BE NEGATED TO INDICATE THAT THIS IS C A CONTINUATION ROW. C A NEGATIVE FLAG IN THE SECOND COLUMN OF THE LXN ARRAY MEANS C THAT THIS NODE IS AN EXTERIOR BOUNDARY NODE. C*********************************************************************** DIMENSION ANGLE (MXND), BNSIZE (2, MXND), LNODES (MLN, MXND) DIMENSION LINKPR (3, MAXPRM) DIMENSION IPTPER (MAXPRM), NUMPER (MAXPRM), LPERIM(MAXNB) DIMENSION IPOINT(MP), COOR(2, MP), IPBOUN(MP) DIMENSION ILINE(ML), NINT(ML), LTYPE(ML), FACTOR(ML), LCON(3, ML) DIMENSION ILBOUN(ML), ISBOUN(ML), LINKR(2, MR) DIMENSION ISIDE(MS), NLPS(MS), IFLINE(MS), ILLIST(MS*3) DIMENSION IREGN(MR), NSPR(MR), IFSIDE(MR), ISLIST(MR*4) DIMENSION RSIZE(MR), IFHOLE(MR), NHPR(MR), IHLIST(MR*2) DIMENSION LINKP(2, MP), LINKL(2, ML), LINKS(2, MS) DIMENSION LISTL(MAXNL), MARKED(3, MAXNL) DIMENSION X(MAXNP), Y(MAXNP), NID(MAXNP, MAXPRM), NPERIM(MAXPRM) DIMENSION LINKPB(2, MP), NPPF(MP), IFPB(MP), LISTPB(2, MP) DIMENSION LINKLB(2, ML), NLPF(ML), IFLB(ML), LISTLB(2, ML) DIMENSION LINKSB(2, ML), NSPF(ML), IFSB(ML), LISTSB(2, ML) DIMENSION LSTNBC(MAXNBC) DIMENSION XN(MXND), YN(MXND), ZN(MXND), NUID(MXND) DIMENSION LXK(4, MXND), KXL(2, 3*MXND) DIMENSION NXL(2, 3*MXND), LXN(4, MXND) DIMENSION AMESUR(NPEOLD), XNOLD(NPNOLD), YNOLD(NPNOLD) DIMENSION NXKOLD(NNXK, NPEOLD), MMPOLD(3, NPROLD) DIMENSION LINKEG(2, MLINK), LISTEG(4 * NPEOLD), BMESUR(NPNOLD) LOGICAL ERR, GRAPH, ERRCHK, NOROOM, VIDEO LOGICAL ADDLNK, CCW, EVEN, LREAL, COUNT, SIZEIT, TIMER LOGICAL BATCH, REMESH CHARACTER*3 DEV1 ADDLNK = .FALSE. ERR = .FALSE. GRAPH = .FALSE. TIMER = .FALSE. SIZEIT = .FALSE. ERRCHK = .TRUE. DEFSIZ = RSIZE (IPNTRG) VIDEO = .FALSE. C PUT ALL THE NODES IN THE ORIGINAL PERIMETER INTO THE GLOBAL C PERIMETER ARRAYS FOR THE PAVING ROUTINE DO 100 I = 1, NPER XN(I) = X(I) YN(I) = Y(I) NUID(I) = NID(I, 1) LPERIM(I) = I 100 CONTINUE IPTPER(1) = 1 NUMPER(1) = NPER NBNODE = NPER C NOW GENERATE ALL THE HOLE PERIMETERS CCW = .TRUE. COUNT = .TRUE. EVEN = .TRUE. LREAL = .TRUE. CALL LTSORT (MR, LINKR, KREG, IPNTR, ADDLNK) DO 120 IR = IFHOLE(IPNTR), IFHOLE(IPNTR) + NHPR (IPNTR) - 1 CALL LTSORT (MR, LINKR, IHLIST (IR), JPNTR, ADDLNK) IF (JPNTR .GT. 0) THEN NPRM = NPRM + 1 CALL DATAOK (MP, ML, MS, MR, JPNTR, IABS(IREGN(IR)), COOR, & ILINE, LTYPE, NINT, LCON, NLPS, IFLINE, ILLIST, NSPR, & IFSIDE, ISLIST, LINKP, LINKL, LINKS, RSIZE(JPNTR), & ERRCHK, ERR) IF (ERR) GOTO 130 NLP1 = NL + 1 CALL PERIM (MP, ML, MS, NSPR(JPNTR), MAXNL, MAXNP, MAXNBC, & MAXSBC, KNBC, KSBC, KNUM, IPOINT, COOR, IPBOUN, ILINE, & LTYPE, NINT, FACTOR, LCON, ILBOUN, ISBOUN, ISIDE, NLPS, & IFLINE, ILLIST, ISLIST(IFSIDE(JPNTR)), NPPF, IFPB, & LISTPB, NLPF, IFLB, LISTLB, NSPF, IFSB, LISTSB, LINKP, & LINKL, LINKS, LINKPB, LINKLB, LINKSB, X, Y, NID(1, NPRM), & NPERIM(NPRM), LISTL(NLP1), NL1, LSTNBC, MARKED, EVEN, & LREAL, ERR, CCW, COUNT, NOROOM, AMESUR, XNOLD, YNOLD, & NXKOLD, MMPOLD, LINKEG, LISTEG, BMESUR, MLINK, NPROLD, & NPNOLD, NPEOLD, NNXK, REMESH, REXMIN, REXMAX, REYMIN, & REYMAX, IDIVIS, SIZMIN, EMAX, EMIN) IF (NOROOM .OR. ERR) GO TO 130 IF (NL1 .GE. 0 .AND. NL + NL1 .LE. MAXNL) THEN NL = NL + NL1 ELSE CALL MESSAGE('** PROBLEMS IN FMSCHM ADDING HOLE LINES '// & 'TO REGION LINE LIST **') ERR = .TRUE. GO TO 130 END IF C NOW LINK THIS HOLE'S PERIMETER NODES TOGETHER INTO THE GLOBAL C PERIMETER LIST CALL REVERS (X (2), NPERIM(NPRM) - 1) CALL REVERS (Y (2), NPERIM(NPRM) - 1) CALL IREVER (NID (2, NPRM), NPERIM(NPRM) - 1) IPTPER (NPRM) = NBNODE + 1 NUMPER (NPRM) = NPERIM(NPRM) NBNODE = NBNODE + NPERIM(NPRM) DO 110 J = 1, NPERIM(NPRM) NODE = J + IPTPER(NPRM) - 1 XN(NODE) = X(J) YN(NODE) = Y(J) ZN(NODE) = 0. NUID(NODE) = NID(J, NPRM) LPERIM(NODE) = NODE 110 CONTINUE ENDIF 120 CONTINUE C NOW MESH THE BOUNDARIES WITH PAVING NNN = NBNODE CALL PAVING (NBNODE, NPRM, MLN, IPTPER, NUMPER, LPERIM, XN, YN, & ZN, LXK, NXL, NNN, LLL, KKK, MXND, ANGLE, BNSIZE, LNODES, & LINKPR, NPERIM, LXK, KXL, NXL, LXN, NUID, IAVAIL, NAVAIL, & GRAPH, TIMER, VIDEO, DEFSIZ, SIZEIT, DEV1, KREG, BATCH, & NOROOM, ERR, AMESUR, XNOLD, YNOLD, NXKOLD, MMPOLD, LINKEG, & LISTEG, BMESUR, MLINK, NPROLD, NPNOLD, NPEOLD, NNXK, REMESH, & REXMIN, REXMAX, REYMIN, REYMAX, IDIVIS, SIZMIN, EMAX, EMIN) ERR = .FALSE. RETURN C ERROR DURING GENERATION 130 CONTINUE RETURN END