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 PERIM (MP, ML, MS, NS, MAXNL, MAXNP, MAXNBC, MAXSBC, & KNBC, KSBC, KNUM, IPOINT, COOR, IPBOUN, ILINE, LTYPE, NINT, & FACTOR, LCON, ILBOUN, ISBOUN, ISIDE, NLPS, IFLINE, ILLIST, & ISLIST, NPPF, IFPB, LISTPB, NLPF, IFLB, LISTLB, NSPF, IFSB, & LISTSB, LINKP, LINKL, LINKS, LINKPB, LINKLB, LINKSB, X, Y, NID, & N, LISTL, NL, LSTNBC, MARKED, EVEN, REAL, 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) C*********************************************************************** C SUBROUTINE PERIM = GENERATES THE PERIMETER OF A REGION C*********************************************************************** C SUBROUTINE CALLED BY: C QMESH = GENERATES THE QUADRILATERAL MESH C*********************************************************************** C VARIABLES USED: C X = THE X VALUES OF THE PERIMETER LIST C Y = THE Y VALUES OF THE PERIMETER LIST C NID = AN ARRAY OF UNIQUE NODE IDENTIFIERS WITHIN THE BODY. C IF 00000YYYYY, YYYYY IS AN INDEX INTO THE POINT TABLE. C IF 1XXXXYYYYY, XXXX IS AN INDEX INTO THE LINE TABLE. C N = THE NUMBER OF NODES ON THE PERIMETER C ERR = .TRUE. IF ERRORS WERE ENCOUNTERED C*********************************************************************** DIMENSION IPOINT (MP), COOR (2, MP), IPBOUN (MP) DIMENSION ILINE (ML), NINT (ML), LTYPE (ML) DIMENSION FACTOR (ML), LCON (3, ML) DIMENSION ILBOUN (ML), ISBOUN (ML) DIMENSION ISIDE (MS), NLPS (MS), IFLINE (MS) DIMENSION ILLIST (MS*3), ISLIST (NS) DIMENSION LINKP (2, MP), LINKL (2, ML), LINKS (2, MS) DIMENSION LISTL (MAXNL), X (MAXNP), Y (MAXNP), NID (MAXNP) 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), MARKED (3, MAXNL) 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, REAL, EVEN, CCW, TEST, ADDLNK, ITRIED, INDETR, NOROOM LOGICAL COUNT, REMESH, GRAPH N = 0 ADDLNK = .FALSE. GRAPH = .FALSE. ITRIED = .FALSE. IF (GRAPH) THEN XDIMD = 1. YDIMD = .75 CALL PLTBGN XDIMR = REXMAX - REXMIN YDIMR = REYMAX - REYMIN CALL MPVIEW (0., XDIMD, 0., YDIMD) XRAT = XDIMR/XDIMD YRAT = YDIMR/YDIMD IF (XRAT.LT.YRAT) THEN XDIMR = XDIMD * YRAT XX1 = (REXMIN + REXMAX - XDIMR) * .5 XX2 = (REXMIN + REXMAX + XDIMR) * .5 XDIMR = XX2 - XX1 YY1 = REYMIN YY2 = REYMAX ELSE YDIMR = YDIMD * XRAT YY1 = (REYMIN + REYMAX - YDIMR) * .5 YY2 = (REYMIN + REYMAX + YDIMR) * .5 YDIMR = YY2 - YY1 XX1 = REXMIN XX2 = REXMAX ENDIF XX1 = XX1 - (XDIMR * .1) XX2 = XX2 + (XDIMR * .1) YY1 = YY1 - (YDIMR * .1) YY2 = YY2 + (YDIMR * .1) CALL MPORT2 (XX1, XX2, YY1, YY2) CALL PLTFRM (0) ENDIF C GET LIST OF LINES CALL LLIST (MS, ML, MAXNL, NS, NL, KNUM, LISTL, ILINE, ISIDE, & NLPS, IFLINE, ILLIST, LCON, ISLIST, LINKS, LINKL, ERR) IF (ERR)RETURN ERR = .TRUE. C DEFINE VALUE OF KP, THE BEGINNING CONNECTIVITY POINT IF (NL .LT. 2) THEN CALL LTSORT (ML, LINKL, LISTL (1), ILI, ADDLNK) KP = LCON (1, ILI) ELSE CALL LTSORT (ML, LINKL, LISTL (1), IL1, ADDLNK) CALL LTSORT (ML, LINKL, LISTL (2), IL2, ADDLNK) J1 = LCON (1, IL1) J2 = LCON (2, IL1) K1 = LCON (1, IL2) K2 = LCON (2, IL2) KP = 0 IF ((J1 .EQ. K1).OR. (J1 .EQ. K2))KP = J2 IF ((J2 .EQ. K1).OR. (J2 .EQ. K2))KP = J1 ILI = IL2 IF (KP .EQ. 0) THEN WRITE (*, 10000)ILINE (IL2) RETURN ENDIF ENDIF C IF PERIMETER HAS ODD NUMBER OF POINTS, C DO A TRIAL PERIMETER GENERATION TO SEE WHERE TO INSERT A NODE. IF (EVEN) THEN NUMINT = 0 DO 100 IL = 1, NL CALL LTSORT (ML, LINKL, LISTL (IL), ILI, ADDLNK) NUMINT = NUMINT+IABS (NINT (ILI)) 100 CONTINUE IF ((MOD (NUMINT, 2) .EQ. 1) .OR. REMESH) THEN DX = 0.0 IX = 0 DO 140 IL = 1, NL CALL LTSORT (ML, LINKL, LISTL (IL), ILI, ADDLNK) C SKIP PREVIOUSLY USED LINES C SKIP LINES USED TWICE IN THIS BOUNDARY (RECALL ANNULUS) IF (NINT (ILI) .GT. 0) THEN DO 110 I = 1, NL CALL LTSORT (ML, LINKL, LISTL (I), IPNTR, ADDLNK) IF ((I.NE.IL).AND. (IPNTR .EQ. ILI))GOTO 130 110 CONTINUE CALL LTSORT (MP, LINKP, LCON (1, ILI), IP1, ADDLNK) CALL LTSORT (MP, LINKP, LCON (2, ILI), IP2, ADDLNK) IF (LCON (3, ILI) .GT. 0) THEN CALL LTSORT (MP, LINKP, LCON (3, ILI), IP3, ADDLNK) ELSEIF (LCON (3, ILI) .LT. 0) THEN CALL LTSORT (MP, LINKP, IABS (LCON (3, ILI)), IP3, & ADDLNK) IP3 = -IP3 ELSE IP3 = 0 ENDIF TEST = .TRUE. CALL PLINE (MP, ML, MAXNP, MAXNBC, MAXSBC, IPOINT, & COOR, LINKP, ILINE (ILI), LTYPE (ILI), NINT (ILI), & FACTOR (ILI), IP1, IP2, IP3, X, Y, NID, & IPBOUN (IP1), IPBOUN (IP2), ILBOUN (ILI), & ISBOUN (ILI), LINKPB, NPPF, IFPB, LISTPB, LINKLB, & NLPF, IFLB, LISTLB, LINKSB, NSPF, IFSB, LISTSB, & LSTNBC, KNBC, KSBC, ERR, TEST, REAL, COUNT, NOROOM, & AMESUR, XNOLD, YNOLD, NXKOLD, MMPOLD, LINKEG, & LISTEG, BMESUR, MLINK, NPROLD, NPNOLD, NPEOLD, & NNXK, REMESH, REXMIN, REXMAX, REYMIN, REYMAX, & IDIVIS, SIZMIN, EMAX, EMIN, GRAPH, DXMAX) IF (ERR) RETURN IF (REMESH) THEN IF (IL .EQ. 1) THEN IX = ILI DX = DXMAX ELSE IF (DXMAX .GT. DX) THEN IX = ILI DX = DXMAX ENDIF ENDIF ELSE DO 120 I = 2, IABS (NINT (ILI))+1 D = SQRT ((X (I)-X (I-1))**2 + & (Y (I)-Y (I-1))**2) IF (D .GT. DX) THEN DX = D IX = ILI ENDIF 120 CONTINUE ENDIF ENDIF 130 CONTINUE 140 CONTINUE IF (IX .EQ. 0) THEN ERR = .TRUE. WRITE (*, 10010)KNUM RETURN ENDIF C RECALCULATE THE NUMBER OF INTERVALS IF REMESHING IF (REMESH) THEN NUMINT = 0 DO 150 IL = 1, NL CALL LTSORT (ML, LINKL, LISTL (IL), ILI, ADDLNK) NUMINT = NUMINT+IABS (NINT (ILI)) 150 CONTINUE IF (MOD (NUMINT, 2) .EQ. 1) THEN NINT (IX) = NINT (IX) + 1 WRITE (*, 10020)ILINE (IX) ENDIF ELSE NINT (IX) = NINT (IX)+1 WRITE (*, 10020)ILINE (IX) ENDIF ENDIF ENDIF C NOW LOOP THROUGH THE LINES TO GENERATE THE PERIMETER IF (GRAPH) THEN CALL PLTBGN CALL MPVIEW (0., XDIMD, 0., YDIMD) CALL MPORT2 (XX1, XX2, YY1, YY2) CALL PLTFRM (0) ENDIF 160 CONTINUE J1 = KP N = 0 DO 170 IL = 1, NL CALL LTSORT (ML, LINKL, LISTL (IL), ILI, ADDLNK) K1 = LCON (1, ILI) K2 = LCON (2, ILI) IF ((K1.NE.KP).AND. (K2.NE.KP)) THEN WRITE (*, 10000)ILINE (ILI) RETURN ENDIF IF (N .GT. 0)NIDSAV = NID (N+1) CALL LTSORT (MP, LINKP, LCON (1, ILI), IP1, ADDLNK) CALL LTSORT (MP, LINKP, LCON (2, ILI), IP2, ADDLNK) IF (LCON (3, ILI) .GT. 0) THEN CALL LTSORT (MP, LINKP, LCON (3, ILI), IP3, ADDLNK) ELSEIF (LCON (3, ILI) .LT. 0) THEN CALL LTSORT (MP, LINKP, IABS (LCON (3, ILI)), IP3, ADDLNK) IP3 = -IP3 ELSE IP3 = 0 ENDIF IMAXNP = MAXNP-N TEST = .FALSE. if (imaxnp .lt. nint(ili)) then stop 'ERROR: Intervals larger than space' end if CALL PLINE (MP, ML, IMAXNP, MAXNBC, MAXSBC, IPOINT, COOR, & LINKP, ILINE (ILI), LTYPE (ILI), NINT (ILI), FACTOR (ILI), & IP1, IP2, IP3, X (N+1), Y (N+1), NID (N+1), IPBOUN (IP1), & IPBOUN (IP2), ILBOUN (ILI), ISBOUN (ILI), LINKPB, NPPF, & IFPB, LISTPB, LINKLB, NLPF, IFLB, LISTLB, LINKSB, NSPF, & IFSB, LISTSB, LSTNBC, KNBC, KSBC, ERR, TEST, REAL, COUNT, & NOROOM, AMESUR, XNOLD, YNOLD, NXKOLD, MMPOLD, LINKEG, & LISTEG, BMESUR, MLINK, NPROLD, NPNOLD, NPEOLD, NNXK, REMESH, & REXMIN, REXMAX, REYMIN, REYMAX, IDIVIS, SIZMIN, EMAX, EMIN, & GRAPH, DXMAX) IF (ERR)RETURN ERR = .TRUE. C REVERSE LINE IF NECESSARY IF (K1.NE.KP) THEN CALL REVERS (X (N+1), IABS (NINT (ILI))+1) CALL REVERS (Y (N+1), IABS (NINT (ILI))+1) CALL IREVER (NID (N+1), IABS (NINT (ILI))+1) ENDIF IF (N .GT. 0)NID (N+1) = NIDSAV C FINISH UP WITH THIS LINE C KP IS THE POINT ON THE FAR END OF THE LINE C DON'T INCLUDE THE LAST POINT ON THIS LINE IN THE LIST KP = (K1+K2)-KP N = N+IABS (NINT (ILI)) C MARK ALL THE LINES AS USED AND C REMEMBER WHICH HAVE JUST BEEN MARKED IF (IPOINT (IP1) .GT. 0) THEN MARKED (1, IL) = IP1 IPOINT (IP1) = - IABS (IPOINT (IP1)) ELSE MARKED (1, IL) = 0 ENDIF IF (IPOINT (IP2) .GT. 0) THEN MARKED (2, IL) = IP2 IPOINT (IP2) = - IABS (IPOINT (IP2)) ELSE MARKED (2, IL) = 0 ENDIF IF (NINT (ILI) .GT. 0) THEN MARKED (3, IL) = ILI NINT (ILI) = - IABS (NINT (ILI)) ELSE MARKED (3, IL) = 0 ENDIF 170 CONTINUE C LINES ARE EXHAUSTED - CHECK FOR CIRCULARITY CALL LTSORT (ML, LINKL, LISTL (1), ILI, ADDLNK) IF (KP.NE.J1) THEN WRITE (*, 10000)ILINE (ILI) RETURN ENDIF C RESET THE JUST MARKED LINES DO 180 I = 1, NL IF (MARKED (1, I) .GT. 0) & IPOINT (MARKED (1, I)) = IABS (IPOINT (MARKED (1, I))) IF (MARKED (2, I) .GT. 0) & IPOINT (MARKED (2, I)) = IABS (IPOINT (MARKED (2, I))) IF (MARKED (3, I) .GT. 0) & NINT (MARKED (3, I)) = IABS (NINT (MARKED (3, I))) 180 CONTINUE C PERIMETER COMPLETED C INSURE PROPER ORIENTATION (COUNTER-CLOCKWISE) CALL CCLOCK (X, Y, N, CCW, ERR, INDETR) C THE LINE ORIENTATION MAY BE BAD - TRY A SIMPLE FIX IF ((INDETR).AND. (.NOT.ITRIED)) THEN DO 190 IL = 1, NL CALL LTSORT (ML, LINKL, LISTL (IL), ILI, ADDLNK) IF (LCON (1, ILI) .EQ. LCON (2, ILI)) THEN LCON (3, ILI) = -LCON (3, ILI) ITRIED = .TRUE. GOTO 160 ENDIF 190 CONTINUE ELSEIF ((INDETR).AND. (ITRIED)) THEN CALL MESSAGE('ORIENTATION OF PERIMETER CANNOT BE DETERMINED') ENDIF IF (ERR)RETURN ERR = .TRUE. IF (.NOT.CCW) THEN CALL REVERS (X (2), N-1) CALL REVERS (Y (2), N-1) CALL IREVER (NID (2), N-1) ENDIF C EXIT ERR = .FALSE. RETURN 10000 FORMAT (' LINE', I5, ' DOES NOT CONNECT TO THE', /, + ' PREVIOUS SECTION OF THE PERIMETER') 10010 FORMAT (' IN REGION', I5, ' NO LINE IS ALTERABLE TO ENFORCE', /, + ' AN EVEN NUMBER OF PERIMETER POINTS') 10020 FORMAT (' NO. OF INTERVALS ON LINE', I5, ' WAS INCREASED BY 1') END